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-2018, 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 -- Switches -- 377 -------------- 378 379 -- The following switches may be used to control the behavior of the ABE 380 -- mechanism. 381 -- 382 -- -gnatd_a stop elaboration checks on accept or select statement 383 -- 384 -- The ABE mechanism stops the traversal of a task body when it 385 -- encounters an accept or a select statement. This behavior is 386 -- equivalent to restriction No_Entry_Calls_In_Elaboration_Code, 387 -- but without penalizing actual entry calls during elaboration. 388 -- 389 -- -gnatd_e ignore entry calls and requeue statements for elaboration 390 -- 391 -- The ABE mechanism does not generate N_Call_Marker nodes for 392 -- protected or task entry calls as well as requeue statements. 393 -- As a result, the calls and requeues are not recorded or 394 -- processed. 395 -- 396 -- -gnatdE elaboration checks on predefined units 397 -- 398 -- The ABE mechanism considers scenarios which appear in internal 399 -- units (Ada, GNAT, Interfaces, System). 400 -- 401 -- -gnatd.G ignore calls through generic formal parameters for elaboration 402 -- 403 -- The ABE mechanism does not generate N_Call_Marker nodes for 404 -- calls which occur in expanded instances, and invoke generic 405 -- actual subprograms through generic formal subprograms. As a 406 -- result, the calls are not recorded or processed. 407 -- 408 -- -gnatd_i ignore activations and calls to instances for elaboration 409 -- 410 -- The ABE mechanism ignores calls and task activations when they 411 -- target a subprogram or task type defined an external instance. 412 -- As a result, the calls and task activations are not processed. 413 -- 414 -- -gnatdL ignore external calls from instances for elaboration 415 -- 416 -- The ABE mechanism does not generate N_Call_Marker nodes for 417 -- calls which occur in expanded instances, do not invoke generic 418 -- actual subprograms through formal subprograms, and the target 419 -- is external to the instance. As a result, the calls are not 420 -- recorded or processed. 421 -- 422 -- -gnatd.o conservative elaboration order for indirect calls 423 -- 424 -- The ABE mechanism treats '[Unrestricted_]Access of an entry, 425 -- operator, or subprogram as an immediate invocation of the 426 -- target. As a result, it performs ABE checks and diagnostics on 427 -- the immediate call. 428 -- 429 -- -gnatd_p ignore assertion pragmas for elaboration 430 -- 431 -- The ABE mechanism does not generate N_Call_Marker nodes for 432 -- calls to subprograms which verify the run-time semantics of 433 -- the following assertion pragmas: 434 -- 435 -- Default_Initial_Condition 436 -- Initial_Condition 437 -- Invariant 438 -- Invariant'Class 439 -- Post 440 -- Post'Class 441 -- Postcondition 442 -- Type_Invariant 443 -- Type_Invariant_Class 444 -- 445 -- As a result, the assertion expressions of the pragmas are not 446 -- processed. 447 -- 448 -- -gnatd.U ignore indirect calls for static elaboration 449 -- 450 -- The ABE mechanism does not consider '[Unrestricted_]Access of 451 -- entries, operators, and subprograms. As a result, the scenarios 452 -- are not recorder or processed. 453 -- 454 -- -gnatd.v enforce SPARK elaboration rules in SPARK code 455 -- 456 -- The ABE mechanism applies some of the SPARK elaboration rules 457 -- defined in the SPARK reference manual, chapter 7.7. Note that 458 -- certain rules are always enforced, regardless of whether the 459 -- switch is active. 460 -- 461 -- -gnatd.y disable implicit pragma Elaborate_All on task bodies 462 -- 463 -- The ABE mechanism does not generate implicit Elaborate_All when 464 -- the need for the pragma came from a task body. 465 -- 466 -- -gnatE dynamic elaboration checking mode enabled 467 -- 468 -- The ABE mechanism assumes that any scenario is elaborated or 469 -- invoked by elaboration code. The ABE mechanism performs very 470 -- little diagnostics and generates condintional ABE checks to 471 -- detect ABE issues at run-time. 472 -- 473 -- -gnatel turn on info messages on generated Elaborate[_All] pragmas 474 -- 475 -- The ABE mechanism produces information messages on generated 476 -- implicit Elabote[_All] pragmas along with traceback showing 477 -- why the pragma was generated. In addition, the ABE mechanism 478 -- produces information messages for each scenario elaborated or 479 -- invoked by elaboration code. 480 -- 481 -- -gnateL turn off info messages on generated Elaborate[_All] pragmas 482 -- 483 -- The complementary switch for -gnatel. 484 -- 485 -- -gnatH legacy elaboration checking mode enabled 486 -- 487 -- When this switch is in effect, the pre-18.x ABE model becomes 488 -- the defacto ABE model. This ammounts to cutting off all entry 489 -- points into the new ABE mechanism, and giving full control to 490 -- the old ABE mechanism. 491 -- 492 -- -gnatJ permissive elaboration checking mode enabled 493 -- 494 -- This switch activates the following switches: 495 -- 496 -- -gnatd_a 497 -- -gnatd_e 498 -- -gnatd.G 499 -- -gnatd_i 500 -- -gnatdL 501 -- -gnatd_p 502 -- -gnatd.U 503 -- -gnatd.y 504 -- 505 -- IMPORTANT: The behavior of the ABE mechanism becomes more 506 -- permissive at the cost of accurate diagnostics and runtime 507 -- ABE checks. 508 -- 509 -- -gnatw.f turn on warnings for suspicious Subp'Access 510 -- 511 -- The ABE mechanism treats '[Unrestricted_]Access of an entry, 512 -- operator, or subprogram as a pseudo invocation of the target. 513 -- As a result, it performs ABE diagnostics on the pseudo call. 514 -- 515 -- -gnatw.F turn off warnings for suspicious Subp'Access 516 -- 517 -- The complementary switch for -gnatw.f. 518 -- 519 -- -gnatwl turn on warnings for elaboration problems 520 -- 521 -- The ABE mechanism produces warnings on detected ABEs along with 522 -- a traceback showing the graph of the ABE. 523 -- 524 -- -gnatwL turn off warnings for elaboration problems 525 -- 526 -- The complementary switch for -gnatwl. 527 528 --------------------------- 529 -- Adding a new scenario -- 530 --------------------------- 531 532 -- The following steps describe how to add a new elaboration scenario and 533 -- preserve the existing architecture. Note that not all of the steps may 534 -- need to be carried out. 535 -- 536 -- 1) Update predicate Is_Scenario 537 -- 538 -- 2) Add predicate Is_Suitable_xxx. Include a call to it in predicate 539 -- Is_Suitable_Scenario. 540 -- 541 -- 3) Update routine Record_Elaboration_Scenario 542 -- 543 -- 4) Add routine Process_Conditional_ABE_xxx. Include a call to it in 544 -- routine Process_Conditional_ABE. 545 -- 546 -- 5) Add routine Process_Guaranteed_ABE_xxx. Include a call to it in 547 -- routine Process_Guaranteed_ABE. 548 -- 549 -- 6) Add routine Check_SPARK_xxx. Include a call to it in routine 550 -- Check_SPARK_Scenario. 551 -- 552 -- 7) Add routine Info_xxx. Include a call to it in routine 553 -- Process_Conditional_ABE_xxx. 554 -- 555 -- 8) Add routine Output_xxx. Include a call to it in routine 556 -- Output_Active_Scenarios. 557 -- 558 -- 9) Add routine Extract_xxx_Attributes 559 -- 560 -- 10) Update routine Is_Potential_Scenario 561 562 ------------------------- 563 -- Adding a new target -- 564 ------------------------- 565 566 -- The following steps describe how to add a new elaboration target and 567 -- preserve the existing architecture. Note that not all of the steps may 568 -- need to be carried out. 569 -- 570 -- 1) Add predicate Is_xxx. 571 -- 572 -- 2) Update the following predicates 573 -- 574 -- Is_Ada_Semantic_Target 575 -- Is_Assertion_Pragma_Target 576 -- Is_Bridge_Target 577 -- Is_SPARK_Semantic_Target 578 -- 579 -- If necessary, create a new category. 580 -- 581 -- 3) Update the appropriate Info_xxx routine. 582 -- 583 -- 4) Update the appropriate Output_xxx routine. 584 -- 585 -- 5) Update routine Extract_Target_Attributes. If necessary, create a 586 -- new Extract_xxx routine. 587 588 -------------------------- 589 -- Debugging ABE issues -- 590 -------------------------- 591 592 -- * If the issue involves a call, ensure that the call is eligible for ABE 593 -- processing and receives a corresponding call marker. The routines of 594 -- interest are 595 -- 596 -- Build_Call_Marker 597 -- Record_Elaboration_Scenario 598 599 -- * If the issue involves an arbitrary scenario, ensure that the scenario 600 -- is either recorded, or is successfully recognized while traversing a 601 -- body. The routines of interest are 602 -- 603 -- Record_Elaboration_Scenario 604 -- Process_Conditional_ABE 605 -- Process_Guaranteed_ABE 606 -- Traverse_Body 607 608 -- * If the issue involves a circularity in the elaboration order, examine 609 -- the ALI files and look for the following encodings next to units: 610 -- 611 -- E indicates a source Elaborate 612 -- 613 -- EA indicates a source Elaborate_All 614 -- 615 -- AD indicates an implicit Elaborate_All 616 -- 617 -- ED indicates an implicit Elaborate 618 -- 619 -- If possible, compare these encodings with those generated by the old 620 -- ABE mechanism. The routines of interest are 621 -- 622 -- Ensure_Prior_Elaboration 623 624 ---------------- 625 -- Attributes -- 626 ---------------- 627 628 -- To minimize the amount of code within routines, the ABE mechanism relies 629 -- on "attribute" records to capture relevant information for a scenario or 630 -- a target. 631 632 -- The following type captures relevant attributes which pertain to a call 633 634 type Call_Attributes is record 635 Elab_Checks_OK : Boolean; 636 -- This flag is set when the call has elaboration checks enabled 637 638 Elab_Warnings_OK : Boolean; 639 -- This flag is set when the call has elaboration warnings elabled 640 641 From_Source : Boolean; 642 -- This flag is set when the call comes from source 643 644 Ghost_Mode_Ignore : Boolean; 645 -- This flag is set when the call appears in a region subject to pragma 646 -- Ghost with policy Ignore. 647 648 In_Declarations : Boolean; 649 -- This flag is set when the call appears at the declaration level 650 651 Is_Dispatching : Boolean; 652 -- This flag is set when the call is dispatching 653 654 SPARK_Mode_On : Boolean; 655 -- This flag is set when the call appears in a region subject to pragma 656 -- SPARK_Mode with value On. 657 end record; 658 659 -- The following type captures relevant attributes which pertain to the 660 -- prior elaboration of a unit. This type is coupled together with a unit 661 -- to form a key -> value relationship. 662 663 type Elaboration_Attributes is record 664 Source_Pragma : Node_Id; 665 -- This attribute denotes a source Elaborate or Elaborate_All pragma 666 -- which guarantees the prior elaboration of some unit with respect 667 -- to the main unit. The pragma may come from the following contexts: 668 669 -- * The main unit 670 -- * The spec of the main unit (if applicable) 671 -- * Any parent spec of the main unit (if applicable) 672 -- * Any parent subunit of the main unit (if applicable) 673 674 -- The attribute remains Empty if no such pragma is available. Source 675 -- pragmas play a role in satisfying SPARK elaboration requirements. 676 677 With_Clause : Node_Id; 678 -- This attribute denotes an internally generated or source with clause 679 -- for some unit withed by the main unit. With clauses carry flags which 680 -- represent implicit Elaborate or Elaborate_All pragmas. These clauses 681 -- play a role in supplying the elaboration dependencies to binde. 682 end record; 683 684 No_Elaboration_Attributes : constant Elaboration_Attributes := 685 (Source_Pragma => Empty, 686 With_Clause => Empty); 687 688 -- The following type captures relevant attributes which pertain to an 689 -- instantiation. 690 691 type Instantiation_Attributes is record 692 Elab_Checks_OK : Boolean; 693 -- This flag is set when the instantiation has elaboration checks 694 -- enabled. 695 696 Elab_Warnings_OK : Boolean; 697 -- This flag is set when the instantiation has elaboration warnings 698 -- enabled. 699 700 Ghost_Mode_Ignore : Boolean; 701 -- This flag is set when the instantiation appears in a region subject 702 -- to pragma Ghost with policy ignore, or starts one such region. 703 704 In_Declarations : Boolean; 705 -- This flag is set when the instantiation appears at the declaration 706 -- level. 707 708 SPARK_Mode_On : Boolean; 709 -- This flag is set when the instantiation appears in a region subject 710 -- to pragma SPARK_Mode with value On, or starts one such region. 711 end record; 712 713 -- The following type captures relevant attributes which pertain to the 714 -- state of the Processing phase. 715 716 type Processing_Attributes is record 717 Suppress_Implicit_Pragmas : Boolean; 718 -- This flag is set when the Processing phase must not generate any 719 -- implicit Elaborate[_All] pragmas. 720 721 Within_Initial_Condition : Boolean; 722 -- This flag is set when the Processing phase is currently examining a 723 -- scenario which was reached from an initial condition procedure. 724 725 Within_Instance : Boolean; 726 -- This flag is set when the Processing phase is currently examining a 727 -- scenario which was reached from a scenario defined in an instance. 728 729 Within_Partial_Finalization : Boolean; 730 -- This flag is set when the Processing phase is currently examining a 731 -- scenario which was reached from a partial finalization procedure. 732 733 Within_Task_Body : Boolean; 734 -- This flag is set when the Processing phase is currently examining a 735 -- scenario which was reached from a task body. 736 end record; 737 738 Initial_State : constant Processing_Attributes := 739 (Suppress_Implicit_Pragmas => False, 740 Within_Initial_Condition => False, 741 Within_Instance => False, 742 Within_Partial_Finalization => False, 743 Within_Task_Body => False); 744 745 -- The following type captures relevant attributes which pertain to a 746 -- target. 747 748 type Target_Attributes is record 749 Elab_Checks_OK : Boolean; 750 -- This flag is set when the target has elaboration checks enabled 751 752 From_Source : Boolean; 753 -- This flag is set when the target comes from source 754 755 Ghost_Mode_Ignore : Boolean; 756 -- This flag is set when the target appears in a region subject to 757 -- pragma Ghost with policy ignore, or starts one such region. 758 759 SPARK_Mode_On : Boolean; 760 -- This flag is set when the target appears in a region subject to 761 -- pragma SPARK_Mode with value On, or starts one such region. 762 763 Spec_Decl : Node_Id; 764 -- This attribute denotes the declaration of Spec_Id 765 766 Unit_Id : Entity_Id; 767 -- This attribute denotes the top unit where Spec_Id resides 768 769 -- The semantics of the following attributes depend on the target 770 771 Body_Barf : Node_Id; 772 Body_Decl : Node_Id; 773 Spec_Id : Entity_Id; 774 775 -- The target is a generic package or a subprogram 776 -- 777 -- * Body_Barf - Empty 778 -- 779 -- * Body_Decl - This attribute denotes the generic or subprogram 780 -- body. 781 -- 782 -- * Spec_Id - This attribute denotes the entity of the generic 783 -- package or subprogram. 784 785 -- The target is a protected entry 786 -- 787 -- * Body_Barf - This attribute denotes the body of the barrier 788 -- function if expansion took place, otherwise it is Empty. 789 -- 790 -- * Body_Decl - This attribute denotes the body of the procedure 791 -- which emulates the entry if expansion took place, otherwise it 792 -- denotes the body of the protected entry. 793 -- 794 -- * Spec_Id - This attribute denotes the entity of the procedure 795 -- which emulates the entry if expansion took place, otherwise it 796 -- denotes the protected entry. 797 798 -- The target is a protected subprogram 799 -- 800 -- * Body_Barf - Empty 801 -- 802 -- * Body_Decl - This attribute denotes the body of the protected or 803 -- unprotected version of the protected subprogram if expansion took 804 -- place, otherwise it denotes the body of the protected subprogram. 805 -- 806 -- * Spec_Id - This attribute denotes the entity of the protected or 807 -- unprotected version of the protected subprogram if expansion took 808 -- place, otherwise it is the entity of the protected subprogram. 809 810 -- The target is a task entry 811 -- 812 -- * Body_Barf - Empty 813 -- 814 -- * Body_Decl - This attribute denotes the body of the procedure 815 -- which emulates the task body if expansion took place, otherwise 816 -- it denotes the body of the task type. 817 -- 818 -- * Spec_Id - This attribute denotes the entity of the procedure 819 -- which emulates the task body if expansion took place, otherwise 820 -- it denotes the entity of the task type. 821 end record; 822 823 -- The following type captures relevant attributes which pertain to a task 824 -- type. 825 826 type Task_Attributes is record 827 Body_Decl : Node_Id; 828 -- This attribute denotes the declaration of the procedure body which 829 -- emulates the behaviour of the task body. 830 831 Elab_Checks_OK : Boolean; 832 -- This flag is set when the task type has elaboration checks enabled 833 834 Ghost_Mode_Ignore : Boolean; 835 -- This flag is set when the task type appears in a region subject to 836 -- pragma Ghost with policy ignore, or starts one such region. 837 838 SPARK_Mode_On : Boolean; 839 -- This flag is set when the task type appears in a region subject to 840 -- pragma SPARK_Mode with value On, or starts one such region. 841 842 Spec_Id : Entity_Id; 843 -- This attribute denotes the entity of the initial declaration of the 844 -- procedure body which emulates the behaviour of the task body. 845 846 Task_Decl : Node_Id; 847 -- This attribute denotes the declaration of the task type 848 849 Unit_Id : Entity_Id; 850 -- This attribute denotes the entity of the compilation unit where the 851 -- task type resides. 852 end record; 853 854 -- The following type captures relevant attributes which pertain to a 855 -- variable. 856 857 type Variable_Attributes is record 858 Unit_Id : Entity_Id; 859 -- This attribute denotes the entity of the compilation unit where the 860 -- variable resides. 861 end record; 862 863 --------------------- 864 -- Data structures -- 865 --------------------- 866 867 -- The ABE mechanism employs lists and hash tables to store information 868 -- pertaining to scenarios and targets, as well as the Processing phase. 869 -- The need for data structures comes partly from the size limitation of 870 -- nodes. Note that the use of hash tables is conservative and operations 871 -- are carried out only when a particular hash table has at least one key 872 -- value pair (see xxx_In_Use flags). 873 874 -- The following table stores the early call regions of subprogram bodies 875 876 Early_Call_Regions_Max : constant := 101; 877 878 type Early_Call_Regions_Index is range 0 .. Early_Call_Regions_Max - 1; 879 880 function Early_Call_Regions_Hash 881 (Key : Entity_Id) return Early_Call_Regions_Index; 882 -- Obtain the hash value of entity Key 883 884 Early_Call_Regions_In_Use : Boolean := False; 885 -- This flag determines whether table Early_Call_Regions contains at least 886 -- least one key/value pair. 887 888 Early_Call_Regions_No_Element : constant Node_Id := Empty; 889 890 package Early_Call_Regions is new Simple_HTable 891 (Header_Num => Early_Call_Regions_Index, 892 Element => Node_Id, 893 No_Element => Early_Call_Regions_No_Element, 894 Key => Entity_Id, 895 Hash => Early_Call_Regions_Hash, 896 Equal => "="); 897 898 -- The following table stores the elaboration status of all units withed by 899 -- the main unit. 900 901 Elaboration_Statuses_Max : constant := 1009; 902 903 type Elaboration_Statuses_Index is range 0 .. Elaboration_Statuses_Max - 1; 904 905 function Elaboration_Statuses_Hash 906 (Key : Entity_Id) return Elaboration_Statuses_Index; 907 -- Obtain the hash value of entity Key 908 909 Elaboration_Statuses_In_Use : Boolean := False; 910 -- This flag flag determines whether table Elaboration_Statuses contains at 911 -- least one key/value pair. 912 913 Elaboration_Statuses_No_Element : constant Elaboration_Attributes := 914 No_Elaboration_Attributes; 915 916 package Elaboration_Statuses is new Simple_HTable 917 (Header_Num => Elaboration_Statuses_Index, 918 Element => Elaboration_Attributes, 919 No_Element => Elaboration_Statuses_No_Element, 920 Key => Entity_Id, 921 Hash => Elaboration_Statuses_Hash, 922 Equal => "="); 923 924 -- The following table stores a status flag for each SPARK scenario saved 925 -- in table SPARK_Scenarios. 926 927 Recorded_SPARK_Scenarios_Max : constant := 127; 928 929 type Recorded_SPARK_Scenarios_Index is 930 range 0 .. Recorded_SPARK_Scenarios_Max - 1; 931 932 function Recorded_SPARK_Scenarios_Hash 933 (Key : Node_Id) return Recorded_SPARK_Scenarios_Index; 934 -- Obtain the hash value of Key 935 936 Recorded_SPARK_Scenarios_In_Use : Boolean := False; 937 -- This flag flag determines whether table Recorded_SPARK_Scenarios 938 -- contains at least one key/value pair. 939 940 Recorded_SPARK_Scenarios_No_Element : constant Boolean := False; 941 942 package Recorded_SPARK_Scenarios is new Simple_HTable 943 (Header_Num => Recorded_SPARK_Scenarios_Index, 944 Element => Boolean, 945 No_Element => Recorded_SPARK_Scenarios_No_Element, 946 Key => Node_Id, 947 Hash => Recorded_SPARK_Scenarios_Hash, 948 Equal => "="); 949 950 -- The following table stores a status flag for each top-level scenario 951 -- recorded in table Top_Level_Scenarios. 952 953 Recorded_Top_Level_Scenarios_Max : constant := 503; 954 955 type Recorded_Top_Level_Scenarios_Index is 956 range 0 .. Recorded_Top_Level_Scenarios_Max - 1; 957 958 function Recorded_Top_Level_Scenarios_Hash 959 (Key : Node_Id) return Recorded_Top_Level_Scenarios_Index; 960 -- Obtain the hash value of entity Key 961 962 Recorded_Top_Level_Scenarios_In_Use : Boolean := False; 963 -- This flag flag determines whether table Recorded_Top_Level_Scenarios 964 -- contains at least one key/value pair. 965 966 Recorded_Top_Level_Scenarios_No_Element : constant Boolean := False; 967 968 package Recorded_Top_Level_Scenarios is new Simple_HTable 969 (Header_Num => Recorded_Top_Level_Scenarios_Index, 970 Element => Boolean, 971 No_Element => Recorded_Top_Level_Scenarios_No_Element, 972 Key => Node_Id, 973 Hash => Recorded_Top_Level_Scenarios_Hash, 974 Equal => "="); 975 976 -- The following table stores all active scenarios in a recursive traversal 977 -- starting from a top-level scenario. This table must be maintained in a 978 -- FIFO fashion. 979 980 package Scenario_Stack is new Table.Table 981 (Table_Component_Type => Node_Id, 982 Table_Index_Type => Int, 983 Table_Low_Bound => 1, 984 Table_Initial => 50, 985 Table_Increment => 100, 986 Table_Name => "Scenario_Stack"); 987 988 -- The following table stores SPARK scenarios which are not necessarily 989 -- executable during elaboration, but still require elaboration-related 990 -- checks. 991 992 package SPARK_Scenarios is new Table.Table 993 (Table_Component_Type => Node_Id, 994 Table_Index_Type => Int, 995 Table_Low_Bound => 1, 996 Table_Initial => 50, 997 Table_Increment => 100, 998 Table_Name => "SPARK_Scenarios"); 999 1000 -- The following table stores all top-level scenario saved during the 1001 -- Recording phase. The contents of this table act as traversal roots 1002 -- later in the Processing phase. This table must be maintained in a 1003 -- LIFO fashion. 1004 1005 package Top_Level_Scenarios is new Table.Table 1006 (Table_Component_Type => Node_Id, 1007 Table_Index_Type => Int, 1008 Table_Low_Bound => 1, 1009 Table_Initial => 1000, 1010 Table_Increment => 100, 1011 Table_Name => "Top_Level_Scenarios"); 1012 1013 -- The following table stores the bodies of all eligible scenarios visited 1014 -- during a traversal starting from a top-level scenario. The contents of 1015 -- this table must be reset upon each new traversal. 1016 1017 Visited_Bodies_Max : constant := 511; 1018 1019 type Visited_Bodies_Index is range 0 .. Visited_Bodies_Max - 1; 1020 1021 function Visited_Bodies_Hash (Key : Node_Id) return Visited_Bodies_Index; 1022 -- Obtain the hash value of node Key 1023 1024 Visited_Bodies_In_Use : Boolean := False; 1025 -- This flag determines whether table Visited_Bodies contains at least one 1026 -- key/value pair. 1027 1028 Visited_Bodies_No_Element : constant Boolean := False; 1029 1030 package Visited_Bodies is new Simple_HTable 1031 (Header_Num => Visited_Bodies_Index, 1032 Element => Boolean, 1033 No_Element => Visited_Bodies_No_Element, 1034 Key => Node_Id, 1035 Hash => Visited_Bodies_Hash, 1036 Equal => "="); 1037 1038 ----------------------- 1039 -- Local subprograms -- 1040 ----------------------- 1041 1042 -- Multiple local subprograms are utilized to lower the semantic complexity 1043 -- of the Recording and Processing phase. 1044 1045 procedure Check_Preelaborated_Call (Call : Node_Id); 1046 pragma Inline (Check_Preelaborated_Call); 1047 -- Verify that entry, operator, or subprogram call Call does not appear at 1048 -- the library level of a preelaborated unit. 1049 1050 procedure Check_SPARK_Derived_Type (Typ_Decl : Node_Id); 1051 pragma Inline (Check_SPARK_Derived_Type); 1052 -- Verify that the freeze node of a derived type denoted by declaration 1053 -- Typ_Decl is within the early call region of each overriding primitive 1054 -- body that belongs to the derived type (SPARK RM 7.7(8)). 1055 1056 procedure Check_SPARK_Instantiation (Exp_Inst : Node_Id); 1057 pragma Inline (Check_SPARK_Instantiation); 1058 -- Verify that expanded instance Exp_Inst does not precede the generic body 1059 -- it instantiates (SPARK RM 7.7(6)). 1060 1061 procedure Check_SPARK_Model_In_Effect (N : Node_Id); 1062 pragma Inline (Check_SPARK_Model_In_Effect); 1063 -- Determine whether a suitable elaboration model is currently in effect 1064 -- for verifying the SPARK rules of scenario N. Emit a warning if this is 1065 -- not the case. 1066 1067 procedure Check_SPARK_Scenario (N : Node_Id); 1068 pragma Inline (Check_SPARK_Scenario); 1069 -- Top-level dispatcher for verifying SPARK scenarios which are not always 1070 -- executable during elaboration but still need elaboration-related checks. 1071 1072 procedure Check_SPARK_Refined_State_Pragma (N : Node_Id); 1073 pragma Inline (Check_SPARK_Refined_State_Pragma); 1074 -- Verify that each constituent of Refined_State pragma N which belongs to 1075 -- an abstract state mentioned in pragma Initializes has prior elaboration 1076 -- with respect to the main unit (SPARK RM 7.7.1(7)). 1077 1078 function Compilation_Unit (Unit_Id : Entity_Id) return Node_Id; 1079 pragma Inline (Compilation_Unit); 1080 -- Return the N_Compilation_Unit node of unit Unit_Id 1081 1082 function Early_Call_Region (Body_Id : Entity_Id) return Node_Id; 1083 pragma Inline (Early_Call_Region); 1084 -- Return the early call region associated with entry or subprogram body 1085 -- Body_Id. IMPORTANT: This routine does not find the early call region. 1086 -- To compute it, use routine Find_Early_Call_Region. 1087 1088 procedure Elab_Msg_NE 1089 (Msg : String; 1090 N : Node_Id; 1091 Id : Entity_Id; 1092 Info_Msg : Boolean; 1093 In_SPARK : Boolean); 1094 pragma Inline (Elab_Msg_NE); 1095 -- Wrapper around Error_Msg_NE. Emit message Msg concerning arbitrary node 1096 -- N and entity. If flag Info_Msg is set, the routine emits an information 1097 -- message, otherwise it emits an error. If flag In_SPARK is set, then 1098 -- string " in SPARK" is added to the end of the message. 1099 1100 function Elaboration_Status 1101 (Unit_Id : Entity_Id) return Elaboration_Attributes; 1102 pragma Inline (Elaboration_Status); 1103 -- Return the set of elaboration attributes associated with unit Unit_Id 1104 1105 procedure Ensure_Prior_Elaboration 1106 (N : Node_Id; 1107 Unit_Id : Entity_Id; 1108 Prag_Nam : Name_Id; 1109 State : Processing_Attributes); 1110 -- Guarantee the elaboration of unit Unit_Id with respect to the main unit 1111 -- by installing pragma Elaborate or Elaborate_All denoted by Prag_Nam. N 1112 -- denotes the related scenario. State denotes the current state of the 1113 -- Processing phase. 1114 1115 procedure Ensure_Prior_Elaboration_Dynamic 1116 (N : Node_Id; 1117 Unit_Id : Entity_Id; 1118 Prag_Nam : Name_Id); 1119 -- Guarantee the elaboration of unit Unit_Id with respect to the main unit 1120 -- by suggesting the use of Elaborate[_All] with name Prag_Nam. N denotes 1121 -- the related scenario. 1122 1123 procedure Ensure_Prior_Elaboration_Static 1124 (N : Node_Id; 1125 Unit_Id : Entity_Id; 1126 Prag_Nam : Name_Id); 1127 -- Guarantee the elaboration of unit Unit_Id with respect to the main unit 1128 -- by installing an implicit Elaborate[_All] pragma with name Prag_Nam. N 1129 -- denotes the related scenario. 1130 1131 function Extract_Assignment_Name (Asmt : Node_Id) return Node_Id; 1132 pragma Inline (Extract_Assignment_Name); 1133 -- Obtain the Name attribute of assignment statement Asmt 1134 1135 procedure Extract_Call_Attributes 1136 (Call : Node_Id; 1137 Target_Id : out Entity_Id; 1138 Attrs : out Call_Attributes); 1139 pragma Inline (Extract_Call_Attributes); 1140 -- Obtain attributes Attrs associated with call Call. Target_Id is the 1141 -- entity of the call target. 1142 1143 function Extract_Call_Name (Call : Node_Id) return Node_Id; 1144 pragma Inline (Extract_Call_Name); 1145 -- Obtain the Name attribute of entry or subprogram call Call 1146 1147 procedure Extract_Instance_Attributes 1148 (Exp_Inst : Node_Id; 1149 Inst_Body : out Node_Id; 1150 Inst_Decl : out Node_Id); 1151 pragma Inline (Extract_Instance_Attributes); 1152 -- Obtain body Inst_Body and spec Inst_Decl of expanded instance Exp_Inst 1153 1154 procedure Extract_Instantiation_Attributes 1155 (Exp_Inst : Node_Id; 1156 Inst : out Node_Id; 1157 Inst_Id : out Entity_Id; 1158 Gen_Id : out Entity_Id; 1159 Attrs : out Instantiation_Attributes); 1160 pragma Inline (Extract_Instantiation_Attributes); 1161 -- Obtain attributes Attrs associated with expanded instantiation Exp_Inst. 1162 -- Inst is the instantiation. Inst_Id is the entity of the instance. Gen_Id 1163 -- is the entity of the generic unit being instantiated. 1164 1165 procedure Extract_Target_Attributes 1166 (Target_Id : Entity_Id; 1167 Attrs : out Target_Attributes); 1168 -- Obtain attributes Attrs associated with an entry, package, or subprogram 1169 -- denoted by Target_Id. 1170 1171 procedure Extract_Task_Attributes 1172 (Typ : Entity_Id; 1173 Attrs : out Task_Attributes); 1174 pragma Inline (Extract_Task_Attributes); 1175 -- Obtain attributes Attrs associated with task type Typ 1176 1177 procedure Extract_Variable_Reference_Attributes 1178 (Ref : Node_Id; 1179 Var_Id : out Entity_Id; 1180 Attrs : out Variable_Attributes); 1181 pragma Inline (Extract_Variable_Reference_Attributes); 1182 -- Obtain attributes Attrs associated with reference Ref that mentions 1183 -- variable Var_Id. 1184 1185 function Find_Code_Unit (N : Node_Or_Entity_Id) return Entity_Id; 1186 pragma Inline (Find_Code_Unit); 1187 -- Return the code unit which contains arbitrary node or entity N. This 1188 -- is the unit of the file which physically contains the related construct 1189 -- denoted by N except when N is within an instantiation. In that case the 1190 -- unit is that of the top-level instantiation. 1191 1192 function Find_Early_Call_Region 1193 (Body_Decl : Node_Id; 1194 Assume_Elab_Body : Boolean := False; 1195 Skip_Memoization : Boolean := False) return Node_Id; 1196 -- Find the start of the early call region which belongs to subprogram body 1197 -- Body_Decl as defined in SPARK RM 7.7. The behavior of the routine is to 1198 -- find the early call region, memoize it, and return it, but this behavior 1199 -- can be altered. Flag Assume_Elab_Body should be set when a package spec 1200 -- may lack pragma Elaborate_Body, but the routine must still examine that 1201 -- spec. Flag Skip_Memoization should be set when the routine must avoid 1202 -- memoizing the region. 1203 1204 procedure Find_Elaborated_Units; 1205 -- Populate table Elaboration_Statuses with all units which have prior 1206 -- elaboration with respect to the main unit. 1207 1208 function Find_Enclosing_Instance (N : Node_Id) return Node_Id; 1209 pragma Inline (Find_Enclosing_Instance); 1210 -- Find the declaration or body of the nearest expanded instance which 1211 -- encloses arbitrary node N. Return Empty if no such instance exists. 1212 1213 function Find_Top_Unit (N : Node_Or_Entity_Id) return Entity_Id; 1214 pragma Inline (Find_Top_Unit); 1215 -- Return the top unit which contains arbitrary node or entity N. The unit 1216 -- is obtained by logically unwinding instantiations and subunits when N 1217 -- resides within one. 1218 1219 function Find_Unit_Entity (N : Node_Id) return Entity_Id; 1220 pragma Inline (Find_Unit_Entity); 1221 -- Return the entity of unit N 1222 1223 function First_Formal_Type (Subp_Id : Entity_Id) return Entity_Id; 1224 pragma Inline (First_Formal_Type); 1225 -- Return the type of subprogram Subp_Id's first formal parameter. If the 1226 -- subprogram lacks formal parameters, return Empty. 1227 1228 function Has_Body (Pack_Decl : Node_Id) return Boolean; 1229 -- Determine whether package declaration Pack_Decl has a corresponding body 1230 -- or would eventually have one. 1231 1232 function Has_Prior_Elaboration 1233 (Unit_Id : Entity_Id; 1234 Context_OK : Boolean := False; 1235 Elab_Body_OK : Boolean := False; 1236 Same_Unit_OK : Boolean := False) return Boolean; 1237 pragma Inline (Has_Prior_Elaboration); 1238 -- Determine whether unit Unit_Id is elaborated prior to the main unit. 1239 -- If flag Context_OK is set, the routine considers the following case 1240 -- as valid prior elaboration: 1241 -- 1242 -- * Unit_Id is in the elaboration context of the main unit 1243 -- 1244 -- If flag Elab_Body_OK is set, the routine considers the following case 1245 -- as valid prior elaboration: 1246 -- 1247 -- * Unit_Id has pragma Elaborate_Body and is not the main unit 1248 -- 1249 -- If flag Same_Unit_OK is set, the routine considers the following cases 1250 -- as valid prior elaboration: 1251 -- 1252 -- * Unit_Id is the main unit 1253 -- 1254 -- * Unit_Id denotes the spec of the main unit body 1255 1256 function In_External_Instance 1257 (N : Node_Id; 1258 Target_Decl : Node_Id) return Boolean; 1259 pragma Inline (In_External_Instance); 1260 -- Determine whether a target desctibed by its declaration Target_Decl 1261 -- resides in a package instance which is external to scenario N. 1262 1263 function In_Main_Context (N : Node_Id) return Boolean; 1264 pragma Inline (In_Main_Context); 1265 -- Determine whether arbitrary node N appears within the main compilation 1266 -- unit. 1267 1268 function In_Same_Context 1269 (N1 : Node_Id; 1270 N2 : Node_Id; 1271 Nested_OK : Boolean := False) return Boolean; 1272 -- Determine whether two arbitrary nodes N1 and N2 appear within the same 1273 -- context ignoring enclosing library levels. Nested_OK should be set when 1274 -- the context of N1 can enclose that of N2. 1275 1276 procedure Info_Call 1277 (Call : Node_Id; 1278 Target_Id : Entity_Id; 1279 Info_Msg : Boolean; 1280 In_SPARK : Boolean); 1281 -- Output information concerning call Call which invokes target Target_Id. 1282 -- If flag Info_Msg is set, the routine emits an information message, 1283 -- otherwise it emits an error. If flag In_SPARK is set, then the string 1284 -- " in SPARK" is added to the end of the message. 1285 1286 procedure Info_Instantiation 1287 (Inst : Node_Id; 1288 Gen_Id : Entity_Id; 1289 Info_Msg : Boolean; 1290 In_SPARK : Boolean); 1291 pragma Inline (Info_Instantiation); 1292 -- Output information concerning instantiation Inst which instantiates 1293 -- generic unit Gen_Id. If flag Info_Msg is set, the routine emits an 1294 -- information message, otherwise it emits an error. If flag In_SPARK 1295 -- is set, then string " in SPARK" is added to the end of the message. 1296 1297 procedure Info_Variable_Reference 1298 (Ref : Node_Id; 1299 Var_Id : Entity_Id; 1300 Info_Msg : Boolean; 1301 In_SPARK : Boolean); 1302 pragma Inline (Info_Variable_Reference); 1303 -- Output information concerning reference Ref which mentions variable 1304 -- Var_Id. If flag Info_Msg is set, the routine emits an information 1305 -- message, otherwise it emits an error. If flag In_SPARK is set, then 1306 -- string " in SPARK" is added to the end of the message. 1307 1308 function Insertion_Node (N : Node_Id; Ins_Nod : Node_Id) return Node_Id; 1309 pragma Inline (Insertion_Node); 1310 -- Obtain the proper insertion node of an ABE check or failure for scenario 1311 -- N and candidate insertion node Ins_Nod. 1312 1313 procedure Install_ABE_Check 1314 (N : Node_Id; 1315 Id : Entity_Id; 1316 Ins_Nod : Node_Id); 1317 -- Insert a run-time ABE check for elaboration scenario N which verifies 1318 -- whether arbitrary entity Id is elaborated. The check in inserted prior 1319 -- to node Ins_Nod. 1320 1321 procedure Install_ABE_Check 1322 (N : Node_Id; 1323 Target_Id : Entity_Id; 1324 Target_Decl : Node_Id; 1325 Target_Body : Node_Id; 1326 Ins_Nod : Node_Id); 1327 -- Insert a run-time ABE check for elaboration scenario N which verifies 1328 -- whether target Target_Id with initial declaration Target_Decl and body 1329 -- Target_Body is elaborated. The check is inserted prior to node Ins_Nod. 1330 1331 procedure Install_ABE_Failure (N : Node_Id; Ins_Nod : Node_Id); 1332 -- Insert a Program_Error concerning a guaranteed ABE for elaboration 1333 -- scenario N. The failure is inserted prior to node Node_Id. 1334 1335 function Is_Accept_Alternative_Proc (Id : Entity_Id) return Boolean; 1336 pragma Inline (Is_Accept_Alternative_Proc); 1337 -- Determine whether arbitrary entity Id denotes an internally generated 1338 -- procedure which encapsulates the statements of an accept alternative. 1339 1340 function Is_Activation_Proc (Id : Entity_Id) return Boolean; 1341 pragma Inline (Is_Activation_Proc); 1342 -- Determine whether arbitrary entity Id denotes a runtime procedure in 1343 -- charge with activating tasks. 1344 1345 function Is_Ada_Semantic_Target (Id : Entity_Id) return Boolean; 1346 pragma Inline (Is_Ada_Semantic_Target); 1347 -- Determine whether arbitrary entity Id denodes a source or internally 1348 -- generated subprogram which emulates Ada semantics. 1349 1350 function Is_Assertion_Pragma_Target (Id : Entity_Id) return Boolean; 1351 pragma Inline (Is_Assertion_Pragma_Target); 1352 -- Determine whether arbitrary entity Id denotes a procedure which varifies 1353 -- the run-time semantics of an assertion pragma. 1354 1355 function Is_Bodiless_Subprogram (Subp_Id : Entity_Id) return Boolean; 1356 pragma Inline (Is_Bodiless_Subprogram); 1357 -- Determine whether subprogram Subp_Id will never have a body 1358 1359 function Is_Controlled_Proc 1360 (Subp_Id : Entity_Id; 1361 Subp_Nam : Name_Id) return Boolean; 1362 pragma Inline (Is_Controlled_Proc); 1363 -- Determine whether subprogram Subp_Id denotes controlled type primitives 1364 -- Adjust, Finalize, or Initialize as denoted by name Subp_Nam. 1365 1366 function Is_Default_Initial_Condition_Proc (Id : Entity_Id) return Boolean; 1367 pragma Inline (Is_Default_Initial_Condition_Proc); 1368 -- Determine whether arbitrary entity Id denotes internally generated 1369 -- routine Default_Initial_Condition. 1370 1371 function Is_Finalizer_Proc (Id : Entity_Id) return Boolean; 1372 pragma Inline (Is_Finalizer_Proc); 1373 -- Determine whether arbitrary entity Id denotes internally generated 1374 -- routine _Finalizer. 1375 1376 function Is_Guaranteed_ABE 1377 (N : Node_Id; 1378 Target_Decl : Node_Id; 1379 Target_Body : Node_Id) return Boolean; 1380 pragma Inline (Is_Guaranteed_ABE); 1381 -- Determine whether scenario N with a target described by its initial 1382 -- declaration Target_Decl and body Target_Decl results in a guaranteed 1383 -- ABE. 1384 1385 function Is_Initial_Condition_Proc (Id : Entity_Id) return Boolean; 1386 pragma Inline (Is_Initial_Condition_Proc); 1387 -- Determine whether arbitrary entity Id denotes internally generated 1388 -- routine Initial_Condition. 1389 1390 function Is_Initialized (Obj_Decl : Node_Id) return Boolean; 1391 pragma Inline (Is_Initialized); 1392 -- Determine whether object declaration Obj_Decl is initialized 1393 1394 function Is_Invariant_Proc (Id : Entity_Id) return Boolean; 1395 pragma Inline (Is_Invariant_Proc); 1396 -- Determine whether arbitrary entity Id denotes an invariant procedure 1397 1398 function Is_Non_Library_Level_Encapsulator (N : Node_Id) return Boolean; 1399 pragma Inline (Is_Non_Library_Level_Encapsulator); 1400 -- Determine whether arbitrary node N is a non-library encapsulator 1401 1402 function Is_Partial_Invariant_Proc (Id : Entity_Id) return Boolean; 1403 pragma Inline (Is_Partial_Invariant_Proc); 1404 -- Determine whether arbitrary entity Id denotes a partial invariant 1405 -- procedure. 1406 1407 function Is_Postconditions_Proc (Id : Entity_Id) return Boolean; 1408 pragma Inline (Is_Postconditions_Proc); 1409 -- Determine whether arbitrary entity Id denotes internally generated 1410 -- routine _Postconditions. 1411 1412 function Is_Preelaborated_Unit (Id : Entity_Id) return Boolean; 1413 pragma Inline (Is_Preelaborated_Unit); 1414 -- Determine whether arbitrary entity Id denotes a unit which is subject to 1415 -- one of the following pragmas: 1416 -- 1417 -- * Preelaborable 1418 -- * Pure 1419 -- * Remote_Call_Interface 1420 -- * Remote_Types 1421 -- * Shared_Passive 1422 1423 function Is_Protected_Entry (Id : Entity_Id) return Boolean; 1424 pragma Inline (Is_Protected_Entry); 1425 -- Determine whether arbitrary entity Id denotes a protected entry 1426 1427 function Is_Protected_Subp (Id : Entity_Id) return Boolean; 1428 pragma Inline (Is_Protected_Subp); 1429 -- Determine whether entity Id denotes a protected subprogram 1430 1431 function Is_Protected_Body_Subp (Id : Entity_Id) return Boolean; 1432 pragma Inline (Is_Protected_Body_Subp); 1433 -- Determine whether entity Id denotes the protected or unprotected version 1434 -- of a protected subprogram. 1435 1436 function Is_Recorded_SPARK_Scenario (N : Node_Id) return Boolean; 1437 pragma Inline (Is_Recorded_SPARK_Scenario); 1438 -- Determine whether arbitrary node N is a recorded SPARK scenario which 1439 -- appears in table SPARK_Scenarios. 1440 1441 function Is_Recorded_Top_Level_Scenario (N : Node_Id) return Boolean; 1442 pragma Inline (Is_Recorded_Top_Level_Scenario); 1443 -- Determine whether arbitrary node N is a recorded top-level scenario 1444 -- which appears in table Top_Level_Scenarios. 1445 1446 function Is_Safe_Activation 1447 (Call : Node_Id; 1448 Task_Decl : Node_Id) return Boolean; 1449 pragma Inline (Is_Safe_Activation); 1450 -- Determine whether call Call which activates a task object described by 1451 -- declaration Task_Decl is always ABE-safe. 1452 1453 function Is_Safe_Call 1454 (Call : Node_Id; 1455 Target_Attrs : Target_Attributes) return Boolean; 1456 pragma Inline (Is_Safe_Call); 1457 -- Determine whether call Call which invokes a target described by 1458 -- attributes Target_Attrs is always ABE-safe. 1459 1460 function Is_Safe_Instantiation 1461 (Inst : Node_Id; 1462 Gen_Attrs : Target_Attributes) return Boolean; 1463 pragma Inline (Is_Safe_Instantiation); 1464 -- Determine whether instance Inst which instantiates a generic unit 1465 -- described by attributes Gen_Attrs is always ABE-safe. 1466 1467 function Is_Same_Unit 1468 (Unit_1 : Entity_Id; 1469 Unit_2 : Entity_Id) return Boolean; 1470 pragma Inline (Is_Same_Unit); 1471 -- Determine whether entities Unit_1 and Unit_2 denote the same unit 1472 1473 function Is_Scenario (N : Node_Id) return Boolean; 1474 pragma Inline (Is_Scenario); 1475 -- Determine whether attribute node N denotes a scenario. The scenario may 1476 -- not necessarily be eligible for ABE processing. 1477 1478 function Is_SPARK_Semantic_Target (Id : Entity_Id) return Boolean; 1479 pragma Inline (Is_SPARK_Semantic_Target); 1480 -- Determine whether arbitrary entity Id nodes a source or internally 1481 -- generated subprogram which emulates SPARK semantics. 1482 1483 function Is_Suitable_Access (N : Node_Id) return Boolean; 1484 pragma Inline (Is_Suitable_Access); 1485 -- Determine whether arbitrary node N denotes a suitable attribute for ABE 1486 -- processing. 1487 1488 function Is_Suitable_Call (N : Node_Id) return Boolean; 1489 pragma Inline (Is_Suitable_Call); 1490 -- Determine whether arbitrary node N denotes a suitable call for ABE 1491 -- processing. 1492 1493 function Is_Suitable_Instantiation (N : Node_Id) return Boolean; 1494 pragma Inline (Is_Suitable_Instantiation); 1495 -- Determine whether arbitrary node N is a suitable instantiation for ABE 1496 -- processing. 1497 1498 function Is_Suitable_Scenario (N : Node_Id) return Boolean; 1499 pragma Inline (Is_Suitable_Scenario); 1500 -- Determine whether arbitrary node N is a suitable scenario for ABE 1501 -- processing. 1502 1503 function Is_Suitable_SPARK_Derived_Type (N : Node_Id) return Boolean; 1504 pragma Inline (Is_Suitable_SPARK_Derived_Type); 1505 -- Determine whether arbitrary node N denotes a suitable derived type 1506 -- declaration for ABE processing using the SPARK rules. 1507 1508 function Is_Suitable_SPARK_Instantiation (N : Node_Id) return Boolean; 1509 pragma Inline (Is_Suitable_SPARK_Instantiation); 1510 -- Determine whether arbitrary node N denotes a suitable instantiation for 1511 -- ABE processing using the SPARK rules. 1512 1513 function Is_Suitable_SPARK_Refined_State_Pragma 1514 (N : Node_Id) return Boolean; 1515 pragma Inline (Is_Suitable_SPARK_Refined_State_Pragma); 1516 -- Determine whether arbitrary node N denotes a suitable Refined_State 1517 -- pragma for ABE processing using the SPARK rules. 1518 1519 function Is_Suitable_Variable_Assignment (N : Node_Id) return Boolean; 1520 pragma Inline (Is_Suitable_Variable_Assignment); 1521 -- Determine whether arbitrary node N denotes a suitable assignment for ABE 1522 -- processing. 1523 1524 function Is_Suitable_Variable_Reference (N : Node_Id) return Boolean; 1525 pragma Inline (Is_Suitable_Variable_Reference); 1526 -- Determine whether arbitrary node N is a suitable variable reference for 1527 -- ABE processing. 1528 1529 function Is_Task_Entry (Id : Entity_Id) return Boolean; 1530 pragma Inline (Is_Task_Entry); 1531 -- Determine whether arbitrary entity Id denotes a task entry 1532 1533 function Is_Up_Level_Target (Target_Decl : Node_Id) return Boolean; 1534 pragma Inline (Is_Up_Level_Target); 1535 -- Determine whether the current root resides at the declaration level. If 1536 -- this is the case, determine whether a target described by declaration 1537 -- Target_Decl is within a context which encloses the current root or is in 1538 -- a different unit. 1539 1540 function Is_Visited_Body (Body_Decl : Node_Id) return Boolean; 1541 pragma Inline (Is_Visited_Body); 1542 -- Determine whether subprogram body Body_Decl is already visited during a 1543 -- recursive traversal started from a top-level scenario. 1544 1545 procedure Meet_Elaboration_Requirement 1546 (N : Node_Id; 1547 Target_Id : Entity_Id; 1548 Req_Nam : Name_Id); 1549 -- Determine whether elaboration requirement Req_Nam for scenario N with 1550 -- target Target_Id is met by the context of the main unit using the SPARK 1551 -- rules. Req_Nam must denote either Elaborate or Elaborate_All. Emit an 1552 -- error if this is not the case. 1553 1554 function Non_Private_View (Typ : Entity_Id) return Entity_Id; 1555 pragma Inline (Non_Private_View); 1556 -- Return the full view of private type Typ if available, otherwise return 1557 -- type Typ. 1558 1559 procedure Output_Active_Scenarios (Error_Nod : Node_Id); 1560 -- Output the contents of the active scenario stack from earliest to latest 1561 -- to supplement an earlier error emitted for node Error_Nod. 1562 1563 procedure Pop_Active_Scenario (N : Node_Id); 1564 pragma Inline (Pop_Active_Scenario); 1565 -- Pop the top of the scenario stack. A check is made to ensure that the 1566 -- scenario being removed is the same as N. 1567 1568 generic 1569 with procedure Process_Single_Activation 1570 (Call : Node_Id; 1571 Call_Attrs : Call_Attributes; 1572 Obj_Id : Entity_Id; 1573 Task_Attrs : Task_Attributes; 1574 State : Processing_Attributes); 1575 -- Perform ABE checks and diagnostics for task activation call Call 1576 -- which activates task Obj_Id. Call_Attrs are the attributes of the 1577 -- activation call. Task_Attrs are the attributes of the task type. 1578 -- State is the current state of the Processing phase. 1579 1580 procedure Process_Activation_Generic 1581 (Call : Node_Id; 1582 Call_Attrs : Call_Attributes; 1583 State : Processing_Attributes); 1584 -- Perform ABE checks and diagnostics for activation call Call by invoking 1585 -- routine Process_Single_Activation on each task object being activated. 1586 -- Call_Attrs are the attributes of the activation call. State is the 1587 -- current state of the Processing phase. 1588 1589 procedure Process_Conditional_ABE 1590 (N : Node_Id; 1591 State : Processing_Attributes := Initial_State); 1592 -- Top-level dispatcher for processing of various elaboration scenarios. 1593 -- Perform conditional ABE checks and diagnostics for scenario N. State 1594 -- is the current state of the Processing phase. 1595 1596 procedure Process_Conditional_ABE_Access 1597 (Attr : Node_Id; 1598 State : Processing_Attributes); 1599 -- Perform ABE checks and diagnostics for 'Access to entry, operator, or 1600 -- subprogram denoted by Attr. State is the current state of the Processing 1601 -- phase. 1602 1603 procedure Process_Conditional_ABE_Activation_Impl 1604 (Call : Node_Id; 1605 Call_Attrs : Call_Attributes; 1606 Obj_Id : Entity_Id; 1607 Task_Attrs : Task_Attributes; 1608 State : Processing_Attributes); 1609 -- Perform common conditional ABE checks and diagnostics for call Call 1610 -- which activates task Obj_Id ignoring the Ada or SPARK rules. Call_Attrs 1611 -- are the attributes of the activation call. Task_Attrs are the attributes 1612 -- of the task type. State is the current state of the Processing phase. 1613 1614 procedure Process_Conditional_ABE_Call 1615 (Call : Node_Id; 1616 Call_Attrs : Call_Attributes; 1617 Target_Id : Entity_Id; 1618 State : Processing_Attributes); 1619 -- Top-level dispatcher for processing of calls. Perform ABE checks and 1620 -- diagnostics for call Call which invokes target Target_Id. Call_Attrs 1621 -- are the attributes of the call. State is the current state of the 1622 -- Processing phase. 1623 1624 procedure Process_Conditional_ABE_Call_Ada 1625 (Call : Node_Id; 1626 Call_Attrs : Call_Attributes; 1627 Target_Id : Entity_Id; 1628 Target_Attrs : Target_Attributes; 1629 State : Processing_Attributes); 1630 -- Perform ABE checks and diagnostics for call Call which invokes target 1631 -- Target_Id using the Ada rules. Call_Attrs are the attributes of the 1632 -- call. Target_Attrs are attributes of the target. State is the current 1633 -- state of the Processing phase. 1634 1635 procedure Process_Conditional_ABE_Call_SPARK 1636 (Call : Node_Id; 1637 Target_Id : Entity_Id; 1638 Target_Attrs : Target_Attributes; 1639 State : Processing_Attributes); 1640 -- Perform ABE checks and diagnostics for call Call which invokes target 1641 -- Target_Id using the SPARK rules. Target_Attrs denotes the attributes of 1642 -- the target. State is the current state of the Processing phase. 1643 1644 procedure Process_Conditional_ABE_Instantiation 1645 (Exp_Inst : Node_Id; 1646 State : Processing_Attributes); 1647 -- Top-level dispatcher for processing of instantiations. Perform ABE 1648 -- checks and diagnostics for expanded instantiation Exp_Inst. State is 1649 -- the current state of the Processing phase. 1650 1651 procedure Process_Conditional_ABE_Instantiation_Ada 1652 (Exp_Inst : Node_Id; 1653 Inst : Node_Id; 1654 Inst_Attrs : Instantiation_Attributes; 1655 Gen_Id : Entity_Id; 1656 Gen_Attrs : Target_Attributes; 1657 State : Processing_Attributes); 1658 -- Perform ABE checks and diagnostics for expanded instantiation Exp_Inst 1659 -- of generic Gen_Id using the Ada rules. Inst is the instantiation node. 1660 -- Inst_Attrs are the attributes of the instance. Gen_Attrs denotes the 1661 -- attributes of the generic. State is the current state of the Processing 1662 -- phase. 1663 1664 procedure Process_Conditional_ABE_Instantiation_SPARK 1665 (Inst : Node_Id; 1666 Gen_Id : Entity_Id; 1667 Gen_Attrs : Target_Attributes; 1668 State : Processing_Attributes); 1669 -- Perform ABE checks and diagnostics for instantiation Inst of generic 1670 -- Gen_Id using the SPARK rules. Gen_Attrs denotes the attributes of the 1671 -- generic. State is the current state of the Processing phase. 1672 1673 procedure Process_Conditional_ABE_Variable_Assignment (Asmt : Node_Id); 1674 -- Top-level dispatcher for processing of variable assignments. Perform ABE 1675 -- checks and diagnostics for assignment statement Asmt. 1676 1677 procedure Process_Conditional_ABE_Variable_Assignment_Ada 1678 (Asmt : Node_Id; 1679 Var_Id : Entity_Id); 1680 -- Perform ABE checks and diagnostics for assignment statement Asmt that 1681 -- updates the value of variable Var_Id using the Ada rules. 1682 1683 procedure Process_Conditional_ABE_Variable_Assignment_SPARK 1684 (Asmt : Node_Id; 1685 Var_Id : Entity_Id); 1686 -- Perform ABE checks and diagnostics for assignment statement Asmt that 1687 -- updates the value of variable Var_Id using the SPARK rules. 1688 1689 procedure Process_Conditional_ABE_Variable_Reference (Ref : Node_Id); 1690 -- Top-level dispatcher for processing of variable references. Perform ABE 1691 -- checks and diagnostics for variable reference Ref. 1692 1693 procedure Process_Conditional_ABE_Variable_Reference_Read 1694 (Ref : Node_Id; 1695 Var_Id : Entity_Id; 1696 Attrs : Variable_Attributes); 1697 -- Perform ABE checks and diagnostics for reference Ref described by its 1698 -- attributes Attrs, that reads variable Var_Id. 1699 1700 procedure Process_Guaranteed_ABE (N : Node_Id); 1701 -- Top-level dispatcher for processing of scenarios which result in a 1702 -- guaranteed ABE. 1703 1704 procedure Process_Guaranteed_ABE_Activation_Impl 1705 (Call : Node_Id; 1706 Call_Attrs : Call_Attributes; 1707 Obj_Id : Entity_Id; 1708 Task_Attrs : Task_Attributes; 1709 State : Processing_Attributes); 1710 -- Perform common guaranteed ABE checks and diagnostics for call Call which 1711 -- activates task Obj_Id ignoring the Ada or SPARK rules. Call_Attrs are 1712 -- the attributes of the activation call. Task_Attrs are the attributes of 1713 -- the task type. State is provided for compatibility and is not used. 1714 1715 procedure Process_Guaranteed_ABE_Call 1716 (Call : Node_Id; 1717 Call_Attrs : Call_Attributes; 1718 Target_Id : Entity_Id); 1719 -- Perform common guaranteed ABE checks and diagnostics for call Call which 1720 -- invokes target Target_Id ignoring the Ada or SPARK rules. Call_Attrs are 1721 -- the attributes of the call. 1722 1723 procedure Process_Guaranteed_ABE_Instantiation (Exp_Inst : Node_Id); 1724 -- Perform common guaranteed ABE checks and diagnostics for expanded 1725 -- instantiation Exp_Inst of generic Gen_Id ignoring the Ada or SPARK 1726 -- rules. 1727 1728 procedure Push_Active_Scenario (N : Node_Id); 1729 pragma Inline (Push_Active_Scenario); 1730 -- Push scenario N on top of the scenario stack 1731 1732 procedure Record_SPARK_Elaboration_Scenario (N : Node_Id); 1733 pragma Inline (Record_SPARK_Elaboration_Scenario); 1734 -- Save SPARK scenario N in table SPARK_Scenarios for later processing 1735 1736 procedure Reset_Visited_Bodies; 1737 pragma Inline (Reset_Visited_Bodies); 1738 -- Clear the contents of table Visited_Bodies 1739 1740 function Root_Scenario return Node_Id; 1741 pragma Inline (Root_Scenario); 1742 -- Return the top-level scenario which started a recursive search for other 1743 -- scenarios. It is assumed that there is a valid top-level scenario on the 1744 -- active scenario stack. 1745 1746 procedure Set_Early_Call_Region (Body_Id : Entity_Id; Start : Node_Id); 1747 pragma Inline (Set_Early_Call_Region); 1748 -- Associate an early call region with begins at construct Start with entry 1749 -- or subprogram body Body_Id. 1750 1751 procedure Set_Elaboration_Status 1752 (Unit_Id : Entity_Id; 1753 Val : Elaboration_Attributes); 1754 pragma Inline (Set_Elaboration_Status); 1755 -- Associate an set of elaboration attributes with unit Unit_Id 1756 1757 procedure Set_Is_Recorded_SPARK_Scenario 1758 (N : Node_Id; 1759 Val : Boolean := True); 1760 pragma Inline (Set_Is_Recorded_SPARK_Scenario); 1761 -- Mark scenario N as being recorded in table SPARK_Scenarios 1762 1763 procedure Set_Is_Recorded_Top_Level_Scenario 1764 (N : Node_Id; 1765 Val : Boolean := True); 1766 pragma Inline (Set_Is_Recorded_Top_Level_Scenario); 1767 -- Mark scenario N as being recorded in table Top_Level_Scenarios 1768 1769 procedure Set_Is_Visited_Body (Subp_Body : Node_Id); 1770 pragma Inline (Set_Is_Visited_Body); 1771 -- Mark subprogram body Subp_Body as being visited during a recursive 1772 -- traversal started from a top-level scenario. 1773 1774 function Static_Elaboration_Checks return Boolean; 1775 pragma Inline (Static_Elaboration_Checks); 1776 -- Determine whether the static model is in effect 1777 1778 procedure Traverse_Body (N : Node_Id; State : Processing_Attributes); 1779 -- Inspect the declarative and statement lists of subprogram body N for 1780 -- suitable elaboration scenarios and process them. State is the current 1781 -- state of the Processing phase. 1782 1783 procedure Update_Elaboration_Scenario (New_N : Node_Id; Old_N : Node_Id); 1784 pragma Inline (Update_Elaboration_Scenario); 1785 -- Update all relevant internal data structures when scenario Old_N is 1786 -- transformed into scenario New_N by Atree.Rewrite. 1787 1788 ----------------------- 1789 -- Build_Call_Marker -- 1790 ----------------------- 1791 1792 procedure Build_Call_Marker (N : Node_Id) is 1793 function In_External_Context 1794 (Call : Node_Id; 1795 Target_Attrs : Target_Attributes) return Boolean; 1796 pragma Inline (In_External_Context); 1797 -- Determine whether a target described by attributes Target_Attrs is 1798 -- external to call Call which must reside within an instance. 1799 1800 function In_Premature_Context (Call : Node_Id) return Boolean; 1801 -- Determine whether call Call appears within a premature context 1802 1803 function Is_Bridge_Target (Id : Entity_Id) return Boolean; 1804 pragma Inline (Is_Bridge_Target); 1805 -- Determine whether arbitrary entity Id denotes a bridge target 1806 1807 function Is_Default_Expression (Call : Node_Id) return Boolean; 1808 pragma Inline (Is_Default_Expression); 1809 -- Determine whether call Call acts as the expression of a defaulted 1810 -- parameter within a source call. 1811 1812 function Is_Generic_Formal_Subp (Subp_Id : Entity_Id) return Boolean; 1813 pragma Inline (Is_Generic_Formal_Subp); 1814 -- Determine whether subprogram Subp_Id denotes a generic formal 1815 -- subprogram which appears in the "prologue" of an instantiation. 1816 1817 ------------------------- 1818 -- In_External_Context -- 1819 ------------------------- 1820 1821 function In_External_Context 1822 (Call : Node_Id; 1823 Target_Attrs : Target_Attributes) return Boolean 1824 is 1825 Inst : Node_Id; 1826 Inst_Body : Node_Id; 1827 Inst_Decl : Node_Id; 1828 1829 begin 1830 -- Performance note: parent traversal 1831 1832 Inst := Find_Enclosing_Instance (Call); 1833 1834 -- The call appears within an instance 1835 1836 if Present (Inst) then 1837 1838 -- The call comes from the main unit and the target does not 1839 1840 if In_Extended_Main_Code_Unit (Call) 1841 and then not In_Extended_Main_Code_Unit (Target_Attrs.Spec_Decl) 1842 then 1843 return True; 1844 1845 -- Otherwise the target declaration must not appear within the 1846 -- instance spec or body. 1847 1848 else 1849 Extract_Instance_Attributes 1850 (Exp_Inst => Inst, 1851 Inst_Decl => Inst_Decl, 1852 Inst_Body => Inst_Body); 1853 1854 -- Performance note: parent traversal 1855 1856 return not In_Subtree 1857 (N => Target_Attrs.Spec_Decl, 1858 Root1 => Inst_Decl, 1859 Root2 => Inst_Body); 1860 end if; 1861 end if; 1862 1863 return False; 1864 end In_External_Context; 1865 1866 -------------------------- 1867 -- In_Premature_Context -- 1868 -------------------------- 1869 1870 function In_Premature_Context (Call : Node_Id) return Boolean is 1871 Par : Node_Id; 1872 1873 begin 1874 -- Climb the parent chain looking for premature contexts 1875 1876 Par := Parent (Call); 1877 while Present (Par) loop 1878 1879 -- Aspect specifications and generic associations are premature 1880 -- contexts because nested calls has not been relocated to their 1881 -- final context. 1882 1883 if Nkind_In (Par, N_Aspect_Specification, 1884 N_Generic_Association) 1885 then 1886 return True; 1887 1888 -- Prevent the search from going too far 1889 1890 elsif Is_Body_Or_Package_Declaration (Par) then 1891 exit; 1892 end if; 1893 1894 Par := Parent (Par); 1895 end loop; 1896 1897 return False; 1898 end In_Premature_Context; 1899 1900 ---------------------- 1901 -- Is_Bridge_Target -- 1902 ---------------------- 1903 1904 function Is_Bridge_Target (Id : Entity_Id) return Boolean is 1905 begin 1906 return 1907 Is_Accept_Alternative_Proc (Id) 1908 or else Is_Finalizer_Proc (Id) 1909 or else Is_Partial_Invariant_Proc (Id) 1910 or else Is_Postconditions_Proc (Id) 1911 or else Is_TSS (Id, TSS_Deep_Adjust) 1912 or else Is_TSS (Id, TSS_Deep_Finalize) 1913 or else Is_TSS (Id, TSS_Deep_Initialize); 1914 end Is_Bridge_Target; 1915 1916 --------------------------- 1917 -- Is_Default_Expression -- 1918 --------------------------- 1919 1920 function Is_Default_Expression (Call : Node_Id) return Boolean is 1921 Outer_Call : constant Node_Id := Parent (Call); 1922 Outer_Nam : Node_Id; 1923 1924 begin 1925 -- To qualify, the node must appear immediately within a source call 1926 -- which invokes a source target. 1927 1928 if Nkind_In (Outer_Call, N_Entry_Call_Statement, 1929 N_Function_Call, 1930 N_Procedure_Call_Statement) 1931 and then Comes_From_Source (Outer_Call) 1932 then 1933 Outer_Nam := Extract_Call_Name (Outer_Call); 1934 1935 return 1936 Is_Entity_Name (Outer_Nam) 1937 and then Present (Entity (Outer_Nam)) 1938 and then Is_Subprogram_Or_Entry (Entity (Outer_Nam)) 1939 and then Comes_From_Source (Entity (Outer_Nam)); 1940 end if; 1941 1942 return False; 1943 end Is_Default_Expression; 1944 1945 ---------------------------- 1946 -- Is_Generic_Formal_Subp -- 1947 ---------------------------- 1948 1949 function Is_Generic_Formal_Subp (Subp_Id : Entity_Id) return Boolean is 1950 Subp_Decl : constant Node_Id := Unit_Declaration_Node (Subp_Id); 1951 Context : constant Node_Id := Parent (Subp_Decl); 1952 1953 begin 1954 -- To qualify, the subprogram must rename a generic actual subprogram 1955 -- where the enclosing context is an instantiation. 1956 1957 return 1958 Nkind (Subp_Decl) = N_Subprogram_Renaming_Declaration 1959 and then not Comes_From_Source (Subp_Decl) 1960 and then Nkind_In (Context, N_Function_Specification, 1961 N_Package_Specification, 1962 N_Procedure_Specification) 1963 and then Present (Generic_Parent (Context)); 1964 end Is_Generic_Formal_Subp; 1965 1966 -- Local variables 1967 1968 Call_Attrs : Call_Attributes; 1969 Call_Nam : Node_Id; 1970 Marker : Node_Id; 1971 Target_Attrs : Target_Attributes; 1972 Target_Id : Entity_Id; 1973 1974 -- Start of processing for Build_Call_Marker 1975 1976 begin 1977 -- Nothing to do when switch -gnatH (legacy elaboration checking mode 1978 -- enabled) is in effect because the legacy ABE mechanism does not need 1979 -- to carry out this action. 1980 1981 if Legacy_Elaboration_Checks then 1982 return; 1983 1984 -- Nothing to do for ASIS. As a result, ABE checks and diagnostics are 1985 -- not performed in this mode. 1986 1987 elsif ASIS_Mode then 1988 return; 1989 1990 -- Nothing to do when the call is being preanalyzed as the marker will 1991 -- be inserted in the wrong place. 1992 1993 elsif Preanalysis_Active then 1994 return; 1995 1996 -- Nothing to do when the input does not denote a call or a requeue 1997 1998 elsif not Nkind_In (N, N_Entry_Call_Statement, 1999 N_Function_Call, 2000 N_Procedure_Call_Statement, 2001 N_Requeue_Statement) 2002 then 2003 return; 2004 2005 -- Nothing to do when the input denotes entry call or requeue statement, 2006 -- and switch -gnatd_e (ignore entry calls and requeue statements for 2007 -- elaboration) is in effect. 2008 2009 elsif Debug_Flag_Underscore_E 2010 and then Nkind_In (N, N_Entry_Call_Statement, N_Requeue_Statement) 2011 then 2012 return; 2013 end if; 2014 2015 Call_Nam := Extract_Call_Name (N); 2016 2017 -- Nothing to do when the call is erroneous or left in a bad state 2018 2019 if not (Is_Entity_Name (Call_Nam) 2020 and then Present (Entity (Call_Nam)) 2021 and then Is_Subprogram_Or_Entry (Entity (Call_Nam))) 2022 then 2023 return; 2024 2025 -- Nothing to do when the call invokes a generic formal subprogram and 2026 -- switch -gnatd.G (ignore calls through generic formal parameters for 2027 -- elaboration) is in effect. This check must be performed with the 2028 -- direct target of the call to avoid the side effects of mapping 2029 -- actuals to formals using renamings. 2030 2031 elsif Debug_Flag_Dot_GG 2032 and then Is_Generic_Formal_Subp (Entity (Call_Nam)) 2033 then 2034 return; 2035 2036 -- Nothing to do when the call is analyzed/resolved too early within an 2037 -- intermediate context. This check is saved for last because it incurs 2038 -- a performance penalty. 2039 2040 -- Performance note: parent traversal 2041 2042 elsif In_Premature_Context (N) then 2043 return; 2044 end if; 2045 2046 Extract_Call_Attributes 2047 (Call => N, 2048 Target_Id => Target_Id, 2049 Attrs => Call_Attrs); 2050 2051 Extract_Target_Attributes 2052 (Target_Id => Target_Id, 2053 Attrs => Target_Attrs); 2054 2055 -- Nothing to do when the call appears within the expanded spec or 2056 -- body of an instantiated generic, the call does not invoke a generic 2057 -- formal subprogram, the target is external to the instance, and switch 2058 -- -gnatdL (ignore external calls from instances for elaboration) is in 2059 -- effect. 2060 2061 if Debug_Flag_LL 2062 and then not Is_Generic_Formal_Subp (Entity (Call_Nam)) 2063 2064 -- Performance note: parent traversal 2065 2066 and then In_External_Context 2067 (Call => N, 2068 Target_Attrs => Target_Attrs) 2069 then 2070 return; 2071 2072 -- Nothing to do when the call invokes an assertion pragma procedure 2073 -- and switch -gnatd_p (ignore assertion pragmas for elaboration) is 2074 -- in effect. 2075 2076 elsif Debug_Flag_Underscore_P 2077 and then Is_Assertion_Pragma_Target (Target_Id) 2078 then 2079 return; 2080 2081 -- Source calls to source targets are always considered because they 2082 -- reflect the original call graph. 2083 2084 elsif Target_Attrs.From_Source and then Call_Attrs.From_Source then 2085 null; 2086 2087 -- A call to a source function which acts as the default expression in 2088 -- another call requires special detection. 2089 2090 elsif Target_Attrs.From_Source 2091 and then Nkind (N) = N_Function_Call 2092 and then Is_Default_Expression (N) 2093 then 2094 null; 2095 2096 -- The target emulates Ada semantics 2097 2098 elsif Is_Ada_Semantic_Target (Target_Id) then 2099 null; 2100 2101 -- The target acts as a link between scenarios 2102 2103 elsif Is_Bridge_Target (Target_Id) then 2104 null; 2105 2106 -- The target emulates SPARK semantics 2107 2108 elsif Is_SPARK_Semantic_Target (Target_Id) then 2109 null; 2110 2111 -- Otherwise the call is not suitable for ABE processing. This prevents 2112 -- the generation of call markers which will never play a role in ABE 2113 -- diagnostics. 2114 2115 else 2116 return; 2117 end if; 2118 2119 -- At this point it is known that the call will play some role in ABE 2120 -- checks and diagnostics. Create a corresponding call marker in case 2121 -- the original call is heavily transformed by expansion later on. 2122 2123 Marker := Make_Call_Marker (Sloc (N)); 2124 2125 -- Inherit the attributes of the original call 2126 2127 Set_Target (Marker, Target_Id); 2128 Set_Is_Declaration_Level_Node (Marker, Call_Attrs.In_Declarations); 2129 Set_Is_Dispatching_Call (Marker, Call_Attrs.Is_Dispatching); 2130 Set_Is_Elaboration_Checks_OK_Node 2131 (Marker, Call_Attrs.Elab_Checks_OK); 2132 Set_Is_Elaboration_Warnings_OK_Node 2133 (Marker, Call_Attrs.Elab_Warnings_OK); 2134 Set_Is_Ignored_Ghost_Node (Marker, Call_Attrs.Ghost_Mode_Ignore); 2135 Set_Is_Source_Call (Marker, Call_Attrs.From_Source); 2136 Set_Is_SPARK_Mode_On_Node (Marker, Call_Attrs.SPARK_Mode_On); 2137 2138 -- The marker is inserted prior to the original call. This placement has 2139 -- several desirable effects: 2140 2141 -- 1) The marker appears in the same context, in close proximity to 2142 -- the call. 2143 2144 -- <marker> 2145 -- <call> 2146 2147 -- 2) Inserting the marker prior to the call ensures that an ABE check 2148 -- will take effect prior to the call. 2149 2150 -- <ABE check> 2151 -- <marker> 2152 -- <call> 2153 2154 -- 3) The above two properties are preserved even when the call is a 2155 -- function which is subsequently relocated in order to capture its 2156 -- result. Note that if the call is relocated to a new context, the 2157 -- relocated call will receive a marker of its own. 2158 2159 -- <ABE check> 2160 -- <maker> 2161 -- Temp : ... := Func_Call ...; 2162 -- ... Temp ... 2163 2164 -- The insertion must take place even when the call does not occur in 2165 -- the main unit to keep the tree symmetric. This ensures that internal 2166 -- name serialization is consistent in case the call marker causes the 2167 -- tree to transform in some way. 2168 2169 Insert_Action (N, Marker); 2170 2171 -- The marker becomes the "corresponding" scenario for the call. Save 2172 -- the marker for later processing by the ABE phase. 2173 2174 Record_Elaboration_Scenario (Marker); 2175 end Build_Call_Marker; 2176 2177 ------------------------------------- 2178 -- Build_Variable_Reference_Marker -- 2179 ------------------------------------- 2180 2181 procedure Build_Variable_Reference_Marker 2182 (N : Node_Id; 2183 Read : Boolean; 2184 Write : Boolean) 2185 is 2186 function In_Pragma (Nod : Node_Id) return Boolean; 2187 -- Determine whether arbitrary node Nod appears within a pragma 2188 2189 --------------- 2190 -- In_Pragma -- 2191 --------------- 2192 2193 function In_Pragma (Nod : Node_Id) return Boolean is 2194 Par : Node_Id; 2195 2196 begin 2197 Par := Nod; 2198 while Present (Par) loop 2199 if Nkind (Par) = N_Pragma then 2200 return True; 2201 2202 -- Prevent the search from going too far 2203 2204 elsif Is_Body_Or_Package_Declaration (Par) then 2205 exit; 2206 end if; 2207 2208 Par := Parent (Par); 2209 end loop; 2210 2211 return False; 2212 end In_Pragma; 2213 2214 -- Local variables 2215 2216 Marker : Node_Id; 2217 Prag : Node_Id; 2218 Var_Attrs : Variable_Attributes; 2219 Var_Id : Entity_Id; 2220 2221 -- Start of processing for Build_Variable_Reference_Marker 2222 2223 begin 2224 -- Nothing to do when switch -gnatH (legacy elaboration checking mode 2225 -- enabled) is in effect because the legacy ABE mechanism does not need 2226 -- to carry out this action. 2227 2228 if Legacy_Elaboration_Checks then 2229 return; 2230 2231 -- Nothing to do for ASIS. As a result, ABE checks and diagnostics are 2232 -- not performed in this mode. 2233 2234 elsif ASIS_Mode then 2235 return; 2236 2237 -- Nothing to do when the reference is being preanalyzed as the marker 2238 -- will be inserted in the wrong place. 2239 2240 elsif Preanalysis_Active then 2241 return; 2242 2243 -- Nothing to do when the input does not denote a reference 2244 2245 elsif not Nkind_In (N, N_Expanded_Name, N_Identifier) then 2246 return; 2247 2248 -- Nothing to do for internally-generated references 2249 2250 elsif not Comes_From_Source (N) then 2251 return; 2252 2253 -- Nothing to do when the reference is erroneous, left in a bad state, 2254 -- or does not denote a variable. 2255 2256 elsif not (Present (Entity (N)) 2257 and then Ekind (Entity (N)) = E_Variable 2258 and then Entity (N) /= Any_Id) 2259 then 2260 return; 2261 end if; 2262 2263 Extract_Variable_Reference_Attributes 2264 (Ref => N, 2265 Var_Id => Var_Id, 2266 Attrs => Var_Attrs); 2267 2268 Prag := SPARK_Pragma (Var_Id); 2269 2270 if Comes_From_Source (Var_Id) 2271 2272 -- Both the variable and the reference must appear in SPARK_Mode On 2273 -- regions because this scenario falls under the SPARK rules. 2274 2275 and then Present (Prag) 2276 and then Get_SPARK_Mode_From_Annotation (Prag) = On 2277 and then Is_SPARK_Mode_On_Node (N) 2278 2279 -- The reference must not be considered when it appears in a pragma. 2280 -- If the pragma has run-time semantics, then the reference will be 2281 -- reconsidered once the pragma is expanded. 2282 2283 -- Performance note: parent traversal 2284 2285 and then not In_Pragma (N) 2286 then 2287 null; 2288 2289 -- Otherwise the reference is not suitable for ABE processing. This 2290 -- prevents the generation of variable markers which will never play 2291 -- a role in ABE diagnostics. 2292 2293 else 2294 return; 2295 end if; 2296 2297 -- At this point it is known that the variable reference will play some 2298 -- role in ABE checks and diagnostics. Create a corresponding variable 2299 -- marker in case the original variable reference is folded or optimized 2300 -- away. 2301 2302 Marker := Make_Variable_Reference_Marker (Sloc (N)); 2303 2304 -- Inherit the attributes of the original variable reference 2305 2306 Set_Target (Marker, Var_Id); 2307 Set_Is_Read (Marker, Read); 2308 Set_Is_Write (Marker, Write); 2309 2310 -- The marker is inserted prior to the original variable reference. The 2311 -- insertion must take place even when the reference does not occur in 2312 -- the main unit to keep the tree symmetric. This ensures that internal 2313 -- name serialization is consistent in case the variable marker causes 2314 -- the tree to transform in some way. 2315 2316 Insert_Action (N, Marker); 2317 2318 -- The marker becomes the "corresponding" scenario for the reference. 2319 -- Save the marker for later processing for the ABE phase. 2320 2321 Record_Elaboration_Scenario (Marker); 2322 end Build_Variable_Reference_Marker; 2323 2324 --------------------------------- 2325 -- Check_Elaboration_Scenarios -- 2326 --------------------------------- 2327 2328 procedure Check_Elaboration_Scenarios is 2329 begin 2330 -- Nothing to do when switch -gnatH (legacy elaboration checking mode 2331 -- enabled) is in effect because the legacy ABE mechanism does not need 2332 -- to carry out this action. 2333 2334 if Legacy_Elaboration_Checks then 2335 return; 2336 2337 -- Nothing to do for ASIS. As a result, no ABE checks and diagnostics 2338 -- are performed in this mode. 2339 2340 elsif ASIS_Mode then 2341 return; 2342 end if; 2343 2344 -- Examine the context of the main unit and record all units with prior 2345 -- elaboration with respect to it. 2346 2347 Find_Elaborated_Units; 2348 2349 -- Examine each top-level scenario saved during the Recording phase for 2350 -- conditional ABEs and perform various actions depending on the model 2351 -- in effect. The table of visited bodies is created for each new top- 2352 -- level scenario. 2353 2354 for Index in Top_Level_Scenarios.First .. Top_Level_Scenarios.Last loop 2355 Reset_Visited_Bodies; 2356 2357 Process_Conditional_ABE (Top_Level_Scenarios.Table (Index)); 2358 end loop; 2359 2360 -- Examine each SPARK scenario saved during the Recording phase which 2361 -- is not necessarily executable during elaboration, but still requires 2362 -- elaboration-related checks. 2363 2364 for Index in SPARK_Scenarios.First .. SPARK_Scenarios.Last loop 2365 Check_SPARK_Scenario (SPARK_Scenarios.Table (Index)); 2366 end loop; 2367 end Check_Elaboration_Scenarios; 2368 2369 ------------------------------ 2370 -- Check_Preelaborated_Call -- 2371 ------------------------------ 2372 2373 procedure Check_Preelaborated_Call (Call : Node_Id) is 2374 function In_Preelaborated_Context (N : Node_Id) return Boolean; 2375 -- Determine whether arbitrary node appears in a preelaborated context 2376 2377 ------------------------------ 2378 -- In_Preelaborated_Context -- 2379 ------------------------------ 2380 2381 function In_Preelaborated_Context (N : Node_Id) return Boolean is 2382 Body_Id : constant Entity_Id := Find_Code_Unit (N); 2383 Spec_Id : constant Entity_Id := Unique_Entity (Body_Id); 2384 2385 begin 2386 -- The node appears within a package body whose corresponding spec is 2387 -- subject to pragma Remote_Call_Interface or Remote_Types. This does 2388 -- not result in a preelaborated context because the package body may 2389 -- be on another machine. 2390 2391 if Ekind (Body_Id) = E_Package_Body 2392 and then Ekind_In (Spec_Id, E_Generic_Package, E_Package) 2393 and then (Is_Remote_Call_Interface (Spec_Id) 2394 or else Is_Remote_Types (Spec_Id)) 2395 then 2396 return False; 2397 2398 -- Otherwise the node appears within a preelaborated context when the 2399 -- associated unit is preelaborated. 2400 2401 else 2402 return Is_Preelaborated_Unit (Spec_Id); 2403 end if; 2404 end In_Preelaborated_Context; 2405 2406 -- Local variables 2407 2408 Call_Attrs : Call_Attributes; 2409 Level : Enclosing_Level_Kind; 2410 Target_Id : Entity_Id; 2411 2412 -- Start of processing for Check_Preelaborated_Call 2413 2414 begin 2415 Extract_Call_Attributes 2416 (Call => Call, 2417 Target_Id => Target_Id, 2418 Attrs => Call_Attrs); 2419 2420 -- Nothing to do when the call is internally generated because it is 2421 -- assumed that it will never violate preelaboration. 2422 2423 if not Call_Attrs.From_Source then 2424 return; 2425 end if; 2426 2427 -- Performance note: parent traversal 2428 2429 Level := Find_Enclosing_Level (Call); 2430 2431 -- Library-level calls are always considered because they are part of 2432 -- the associated unit's elaboration actions. 2433 2434 if Level in Library_Level then 2435 null; 2436 2437 -- Calls at the library level of a generic package body must be checked 2438 -- because they would render an instantiation illegal if the template is 2439 -- marked as preelaborated. Note that this does not apply to calls at 2440 -- the library level of a generic package spec. 2441 2442 elsif Level = Generic_Package_Body then 2443 null; 2444 2445 -- Otherwise the call does not appear at the proper level and must not 2446 -- be considered for this check. 2447 2448 else 2449 return; 2450 end if; 2451 2452 -- The call appears within a preelaborated unit. Emit a warning only for 2453 -- internal uses, otherwise this is an error. 2454 2455 if In_Preelaborated_Context (Call) then 2456 Error_Msg_Warn := GNAT_Mode; 2457 Error_Msg_N 2458 ("<<non-static call not allowed in preelaborated unit", Call); 2459 end if; 2460 end Check_Preelaborated_Call; 2461 2462 ------------------------------ 2463 -- Check_SPARK_Derived_Type -- 2464 ------------------------------ 2465 2466 procedure Check_SPARK_Derived_Type (Typ_Decl : Node_Id) is 2467 Typ : constant Entity_Id := Defining_Entity (Typ_Decl); 2468 2469 -- NOTE: The routines within Check_SPARK_Derived_Type are intentionally 2470 -- unnested to avoid deep indentation of code. 2471 2472 Stop_Check : exception; 2473 -- This exception is raised when the freeze node violates the placement 2474 -- rules. 2475 2476 procedure Check_Overriding_Primitive 2477 (Prim : Entity_Id; 2478 FNode : Node_Id); 2479 pragma Inline (Check_Overriding_Primitive); 2480 -- Verify that freeze node FNode is within the early call region of 2481 -- overriding primitive Prim's body. 2482 2483 function Freeze_Node_Location (FNode : Node_Id) return Source_Ptr; 2484 pragma Inline (Freeze_Node_Location); 2485 -- Return a more accurate source location associated with freeze node 2486 -- FNode. 2487 2488 function Precedes_Source_Construct (N : Node_Id) return Boolean; 2489 pragma Inline (Precedes_Source_Construct); 2490 -- Determine whether arbitrary node N appears prior to some source 2491 -- construct. 2492 2493 procedure Suggest_Elaborate_Body 2494 (N : Node_Id; 2495 Body_Decl : Node_Id; 2496 Error_Nod : Node_Id); 2497 pragma Inline (Suggest_Elaborate_Body); 2498 -- Suggest the use of pragma Elaborate_Body when the pragma will allow 2499 -- for node N to appear within the early call region of subprogram body 2500 -- Body_Decl. The suggestion is attached to Error_Nod as a continuation 2501 -- error. 2502 2503 -------------------------------- 2504 -- Check_Overriding_Primitive -- 2505 -------------------------------- 2506 2507 procedure Check_Overriding_Primitive 2508 (Prim : Entity_Id; 2509 FNode : Node_Id) 2510 is 2511 Prim_Decl : constant Node_Id := Unit_Declaration_Node (Prim); 2512 Body_Decl : Node_Id; 2513 Body_Id : Entity_Id; 2514 Region : Node_Id; 2515 2516 begin 2517 Body_Id := Corresponding_Body (Prim_Decl); 2518 2519 -- Nothing to do when the primitive does not have a corresponding 2520 -- body. This can happen when the unit with the bodies is not the 2521 -- main unit subjected to ABE checks. 2522 2523 if No (Body_Id) then 2524 return; 2525 2526 -- The primitive overrides a parent or progenitor primitive 2527 2528 elsif Present (Overridden_Operation (Prim)) then 2529 2530 -- Nothing to do when overriding an interface primitive happens by 2531 -- inheriting a non-interface primitive as the check would be done 2532 -- on the parent primitive. 2533 2534 if Present (Alias (Prim)) then 2535 return; 2536 end if; 2537 2538 -- Nothing to do when the primitive is not overriding. The body of 2539 -- such a primitive cannot be targeted by a dispatching call which 2540 -- is executable during elaboration, and cannot cause an ABE. 2541 2542 else 2543 return; 2544 end if; 2545 2546 Body_Decl := Unit_Declaration_Node (Body_Id); 2547 Region := Find_Early_Call_Region (Body_Decl); 2548 2549 -- The freeze node appears prior to the early call region of the 2550 -- primitive body. 2551 2552 -- IMPORTANT: This check must always be performed even when -gnatd.v 2553 -- (enforce SPARK elaboration rules in SPARK code) is not specified 2554 -- because the static model cannot guarantee the absence of ABEs in 2555 -- in the presence of dispatching calls. 2556 2557 if Earlier_In_Extended_Unit (FNode, Region) then 2558 Error_Msg_Node_2 := Prim; 2559 Error_Msg_NE 2560 ("first freezing point of type & must appear within early call " 2561 & "region of primitive body & (SPARK RM 7.7(8))", 2562 Typ_Decl, Typ); 2563 2564 Error_Msg_Sloc := Sloc (Region); 2565 Error_Msg_N ("\region starts #", Typ_Decl); 2566 2567 Error_Msg_Sloc := Sloc (Body_Decl); 2568 Error_Msg_N ("\region ends #", Typ_Decl); 2569 2570 Error_Msg_Sloc := Freeze_Node_Location (FNode); 2571 Error_Msg_N ("\first freezing point #", Typ_Decl); 2572 2573 -- If applicable, suggest the use of pragma Elaborate_Body in the 2574 -- associated package spec. 2575 2576 Suggest_Elaborate_Body 2577 (N => FNode, 2578 Body_Decl => Body_Decl, 2579 Error_Nod => Typ_Decl); 2580 2581 raise Stop_Check; 2582 end if; 2583 end Check_Overriding_Primitive; 2584 2585 -------------------------- 2586 -- Freeze_Node_Location -- 2587 -------------------------- 2588 2589 function Freeze_Node_Location (FNode : Node_Id) return Source_Ptr is 2590 Context : constant Node_Id := Parent (FNode); 2591 Loc : constant Source_Ptr := Sloc (FNode); 2592 2593 Prv_Decls : List_Id; 2594 Vis_Decls : List_Id; 2595 2596 begin 2597 -- In general, the source location of the freeze node is as close as 2598 -- possible to the real freeze point, except when the freeze node is 2599 -- at the "bottom" of a package spec. 2600 2601 if Nkind (Context) = N_Package_Specification then 2602 Prv_Decls := Private_Declarations (Context); 2603 Vis_Decls := Visible_Declarations (Context); 2604 2605 -- The freeze node appears in the private declarations of the 2606 -- package. 2607 2608 if Present (Prv_Decls) 2609 and then List_Containing (FNode) = Prv_Decls 2610 then 2611 null; 2612 2613 -- The freeze node appears in the visible declarations of the 2614 -- package and there are no private declarations. 2615 2616 elsif Present (Vis_Decls) 2617 and then List_Containing (FNode) = Vis_Decls 2618 and then (No (Prv_Decls) or else Is_Empty_List (Prv_Decls)) 2619 then 2620 null; 2621 2622 -- Otherwise the freeze node is not in the "last" declarative list 2623 -- of the package. Use the existing source location of the freeze 2624 -- node. 2625 2626 else 2627 return Loc; 2628 end if; 2629 2630 -- The freeze node appears at the "bottom" of the package when it 2631 -- is in the "last" declarative list and is either the last in the 2632 -- list or is followed by internal constructs only. In that case 2633 -- the more appropriate source location is that of the package end 2634 -- label. 2635 2636 if not Precedes_Source_Construct (FNode) then 2637 return Sloc (End_Label (Context)); 2638 end if; 2639 end if; 2640 2641 return Loc; 2642 end Freeze_Node_Location; 2643 2644 ------------------------------- 2645 -- Precedes_Source_Construct -- 2646 ------------------------------- 2647 2648 function Precedes_Source_Construct (N : Node_Id) return Boolean is 2649 Decl : Node_Id; 2650 2651 begin 2652 Decl := Next (N); 2653 while Present (Decl) loop 2654 if Comes_From_Source (Decl) then 2655 return True; 2656 2657 -- A generated body for a source expression function is treated as 2658 -- a source construct. 2659 2660 elsif Nkind (Decl) = N_Subprogram_Body 2661 and then Was_Expression_Function (Decl) 2662 and then Comes_From_Source (Original_Node (Decl)) 2663 then 2664 return True; 2665 end if; 2666 2667 Next (Decl); 2668 end loop; 2669 2670 return False; 2671 end Precedes_Source_Construct; 2672 2673 ---------------------------- 2674 -- Suggest_Elaborate_Body -- 2675 ---------------------------- 2676 2677 procedure Suggest_Elaborate_Body 2678 (N : Node_Id; 2679 Body_Decl : Node_Id; 2680 Error_Nod : Node_Id) 2681 is 2682 Unt : constant Node_Id := Unit (Cunit (Main_Unit)); 2683 Region : Node_Id; 2684 2685 begin 2686 -- The suggestion applies only when the subprogram body resides in a 2687 -- compilation package body, and a pragma Elaborate_Body would allow 2688 -- for the node to appear in the early call region of the subprogram 2689 -- body. This implies that all code from the subprogram body up to 2690 -- the node is preelaborable. 2691 2692 if Nkind (Unt) = N_Package_Body then 2693 2694 -- Find the start of the early call region again assuming that the 2695 -- package spec has pragma Elaborate_Body. Note that the internal 2696 -- data structures are intentionally not updated because this is a 2697 -- speculative search. 2698 2699 Region := 2700 Find_Early_Call_Region 2701 (Body_Decl => Body_Decl, 2702 Assume_Elab_Body => True, 2703 Skip_Memoization => True); 2704 2705 -- If the node appears within the early call region, assuming that 2706 -- the package spec carries pragma Elaborate_Body, then it is safe 2707 -- to suggest the pragma. 2708 2709 if Earlier_In_Extended_Unit (Region, N) then 2710 Error_Msg_Name_1 := Name_Elaborate_Body; 2711 Error_Msg_NE 2712 ("\consider adding pragma % in spec of unit &", 2713 Error_Nod, Defining_Entity (Unt)); 2714 end if; 2715 end if; 2716 end Suggest_Elaborate_Body; 2717 2718 -- Local variables 2719 2720 FNode : constant Node_Id := Freeze_Node (Typ); 2721 Prims : constant Elist_Id := Direct_Primitive_Operations (Typ); 2722 2723 Prim_Elmt : Elmt_Id; 2724 2725 -- Start of processing for Check_SPARK_Derived_Type 2726 2727 begin 2728 -- A type should have its freeze node set by the time SPARK scenarios 2729 -- are being verified. 2730 2731 pragma Assert (Present (FNode)); 2732 2733 -- Verify that the freeze node of the derived type is within the early 2734 -- call region of each overriding primitive body (SPARK RM 7.7(8)). 2735 2736 if Present (Prims) then 2737 Prim_Elmt := First_Elmt (Prims); 2738 while Present (Prim_Elmt) loop 2739 Check_Overriding_Primitive 2740 (Prim => Node (Prim_Elmt), 2741 FNode => FNode); 2742 2743 Next_Elmt (Prim_Elmt); 2744 end loop; 2745 end if; 2746 2747 exception 2748 when Stop_Check => 2749 null; 2750 end Check_SPARK_Derived_Type; 2751 2752 ------------------------------- 2753 -- Check_SPARK_Instantiation -- 2754 ------------------------------- 2755 2756 procedure Check_SPARK_Instantiation (Exp_Inst : Node_Id) is 2757 Gen_Attrs : Target_Attributes; 2758 Gen_Id : Entity_Id; 2759 Inst : Node_Id; 2760 Inst_Attrs : Instantiation_Attributes; 2761 Inst_Id : Entity_Id; 2762 2763 begin 2764 Extract_Instantiation_Attributes 2765 (Exp_Inst => Exp_Inst, 2766 Inst => Inst, 2767 Inst_Id => Inst_Id, 2768 Gen_Id => Gen_Id, 2769 Attrs => Inst_Attrs); 2770 2771 Extract_Target_Attributes (Gen_Id, Gen_Attrs); 2772 2773 -- The instantiation and the generic body are both in the main unit 2774 2775 if Present (Gen_Attrs.Body_Decl) 2776 and then In_Extended_Main_Code_Unit (Gen_Attrs.Body_Decl) 2777 2778 -- If the instantiation appears prior to the generic body, then the 2779 -- instantiation is illegal (SPARK RM 7.7(6)). 2780 2781 -- IMPORTANT: This check must always be performed even when -gnatd.v 2782 -- (enforce SPARK elaboration rules in SPARK code) is not specified 2783 -- because the rule prevents use-before-declaration of objects that 2784 -- may precede the generic body. 2785 2786 and then Earlier_In_Extended_Unit (Inst, Gen_Attrs.Body_Decl) 2787 then 2788 Error_Msg_NE ("cannot instantiate & before body seen", Inst, Gen_Id); 2789 end if; 2790 end Check_SPARK_Instantiation; 2791 2792 --------------------------------- 2793 -- Check_SPARK_Model_In_Effect -- 2794 --------------------------------- 2795 2796 SPARK_Model_Warning_Posted : Boolean := False; 2797 -- This flag prevents the same SPARK model-related warning from being 2798 -- emitted multiple times. 2799 2800 procedure Check_SPARK_Model_In_Effect (N : Node_Id) is 2801 begin 2802 -- Do not emit the warning multiple times as this creates useless noise 2803 2804 if SPARK_Model_Warning_Posted then 2805 null; 2806 2807 -- SPARK rule verification requires the "strict" static model 2808 2809 elsif Static_Elaboration_Checks and not Relaxed_Elaboration_Checks then 2810 null; 2811 2812 -- Any other combination of models does not guarantee the absence of ABE 2813 -- problems for SPARK rule verification purposes. Note that there is no 2814 -- need to check for the legacy ABE mechanism because the legacy code 2815 -- has its own orthogonal processing for SPARK rules. 2816 2817 else 2818 SPARK_Model_Warning_Posted := True; 2819 2820 Error_Msg_N 2821 ("??SPARK elaboration checks require static elaboration model", N); 2822 2823 if Dynamic_Elaboration_Checks then 2824 Error_Msg_N ("\dynamic elaboration model is in effect", N); 2825 else 2826 pragma Assert (Relaxed_Elaboration_Checks); 2827 Error_Msg_N ("\relaxed elaboration model is in effect", N); 2828 end if; 2829 end if; 2830 end Check_SPARK_Model_In_Effect; 2831 2832 -------------------------- 2833 -- Check_SPARK_Scenario -- 2834 -------------------------- 2835 2836 procedure Check_SPARK_Scenario (N : Node_Id) is 2837 begin 2838 -- Ensure that a suitable elaboration model is in effect for SPARK rule 2839 -- verification. 2840 2841 Check_SPARK_Model_In_Effect (N); 2842 2843 -- Add the current scenario to the stack of active scenarios 2844 2845 Push_Active_Scenario (N); 2846 2847 if Is_Suitable_SPARK_Derived_Type (N) then 2848 Check_SPARK_Derived_Type (N); 2849 2850 elsif Is_Suitable_SPARK_Instantiation (N) then 2851 Check_SPARK_Instantiation (N); 2852 2853 elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then 2854 Check_SPARK_Refined_State_Pragma (N); 2855 end if; 2856 2857 -- Remove the current scenario from the stack of active scenarios once 2858 -- all ABE diagnostics and checks have been performed. 2859 2860 Pop_Active_Scenario (N); 2861 end Check_SPARK_Scenario; 2862 2863 -------------------------------------- 2864 -- Check_SPARK_Refined_State_Pragma -- 2865 -------------------------------------- 2866 2867 procedure Check_SPARK_Refined_State_Pragma (N : Node_Id) is 2868 2869 -- NOTE: The routines within Check_SPARK_Refined_State_Pragma are 2870 -- intentionally unnested to avoid deep indentation of code. 2871 2872 procedure Check_SPARK_Constituent (Constit_Id : Entity_Id); 2873 pragma Inline (Check_SPARK_Constituent); 2874 -- Ensure that a single constituent Constit_Id is elaborated prior to 2875 -- the main unit. 2876 2877 procedure Check_SPARK_Constituents (Constits : Elist_Id); 2878 pragma Inline (Check_SPARK_Constituents); 2879 -- Ensure that all constituents found in list Constits are elaborated 2880 -- prior to the main unit. 2881 2882 procedure Check_SPARK_Initialized_State (State : Node_Id); 2883 pragma Inline (Check_SPARK_Initialized_State); 2884 -- Ensure that the constituents of single abstract state State are 2885 -- elaborated prior to the main unit. 2886 2887 procedure Check_SPARK_Initialized_States (Pack_Id : Entity_Id); 2888 pragma Inline (Check_SPARK_Initialized_States); 2889 -- Ensure that the constituents of all abstract states which appear in 2890 -- the Initializes pragma of package Pack_Id are elaborated prior to the 2891 -- main unit. 2892 2893 ----------------------------- 2894 -- Check_SPARK_Constituent -- 2895 ----------------------------- 2896 2897 procedure Check_SPARK_Constituent (Constit_Id : Entity_Id) is 2898 Prag : Node_Id; 2899 2900 begin 2901 -- Nothing to do for "null" constituents 2902 2903 if Nkind (Constit_Id) = N_Null then 2904 return; 2905 2906 -- Nothing to do for illegal constituents 2907 2908 elsif Error_Posted (Constit_Id) then 2909 return; 2910 end if; 2911 2912 Prag := SPARK_Pragma (Constit_Id); 2913 2914 -- The check applies only when the constituent is subject to pragma 2915 -- SPARK_Mode On. 2916 2917 if Present (Prag) 2918 and then Get_SPARK_Mode_From_Annotation (Prag) = On 2919 then 2920 -- An external constituent of an abstract state which appears in 2921 -- the Initializes pragma of a package spec imposes an Elaborate 2922 -- requirement on the context of the main unit. Determine whether 2923 -- the context has a pragma strong enough to meet the requirement. 2924 2925 -- IMPORTANT: This check is performed only when -gnatd.v (enforce 2926 -- SPARK elaboration rules in SPARK code) is in effect because the 2927 -- static model can ensure the prior elaboration of the unit which 2928 -- contains a constituent by installing implicit Elaborate pragma. 2929 2930 if Debug_Flag_Dot_V then 2931 Meet_Elaboration_Requirement 2932 (N => N, 2933 Target_Id => Constit_Id, 2934 Req_Nam => Name_Elaborate); 2935 2936 -- Otherwise ensure that the unit with the external constituent is 2937 -- elaborated prior to the main unit. 2938 2939 else 2940 Ensure_Prior_Elaboration 2941 (N => N, 2942 Unit_Id => Find_Top_Unit (Constit_Id), 2943 Prag_Nam => Name_Elaborate, 2944 State => Initial_State); 2945 end if; 2946 end if; 2947 end Check_SPARK_Constituent; 2948 2949 ------------------------------ 2950 -- Check_SPARK_Constituents -- 2951 ------------------------------ 2952 2953 procedure Check_SPARK_Constituents (Constits : Elist_Id) is 2954 Constit_Elmt : Elmt_Id; 2955 2956 begin 2957 if Present (Constits) then 2958 Constit_Elmt := First_Elmt (Constits); 2959 while Present (Constit_Elmt) loop 2960 Check_SPARK_Constituent (Node (Constit_Elmt)); 2961 Next_Elmt (Constit_Elmt); 2962 end loop; 2963 end if; 2964 end Check_SPARK_Constituents; 2965 2966 ----------------------------------- 2967 -- Check_SPARK_Initialized_State -- 2968 ----------------------------------- 2969 2970 procedure Check_SPARK_Initialized_State (State : Node_Id) is 2971 Prag : Node_Id; 2972 State_Id : Entity_Id; 2973 2974 begin 2975 -- Nothing to do for "null" initialization items 2976 2977 if Nkind (State) = N_Null then 2978 return; 2979 2980 -- Nothing to do for illegal states 2981 2982 elsif Error_Posted (State) then 2983 return; 2984 end if; 2985 2986 State_Id := Entity_Of (State); 2987 2988 -- Sanitize the state 2989 2990 if No (State_Id) then 2991 return; 2992 2993 elsif Error_Posted (State_Id) then 2994 return; 2995 2996 elsif Ekind (State_Id) /= E_Abstract_State then 2997 return; 2998 end if; 2999 3000 -- The check is performed only when the abstract state is subject to 3001 -- SPARK_Mode On. 3002 3003 Prag := SPARK_Pragma (State_Id); 3004 3005 if Present (Prag) 3006 and then Get_SPARK_Mode_From_Annotation (Prag) = On 3007 then 3008 Check_SPARK_Constituents (Refinement_Constituents (State_Id)); 3009 end if; 3010 end Check_SPARK_Initialized_State; 3011 3012 ------------------------------------ 3013 -- Check_SPARK_Initialized_States -- 3014 ------------------------------------ 3015 3016 procedure Check_SPARK_Initialized_States (Pack_Id : Entity_Id) is 3017 Prag : constant Node_Id := Get_Pragma (Pack_Id, Pragma_Initializes); 3018 Init : Node_Id; 3019 Inits : Node_Id; 3020 3021 begin 3022 if Present (Prag) then 3023 Inits := Expression (Get_Argument (Prag, Pack_Id)); 3024 3025 -- Avoid processing a "null" initialization list. The only other 3026 -- alternative is an aggregate. 3027 3028 if Nkind (Inits) = N_Aggregate then 3029 3030 -- The initialization items appear in list form: 3031 -- 3032 -- (state1, state2) 3033 3034 if Present (Expressions (Inits)) then 3035 Init := First (Expressions (Inits)); 3036 while Present (Init) loop 3037 Check_SPARK_Initialized_State (Init); 3038 Next (Init); 3039 end loop; 3040 end if; 3041 3042 -- The initialization items appear in associated form: 3043 -- 3044 -- (state1 => item1, 3045 -- state2 => (item2, item3)) 3046 3047 if Present (Component_Associations (Inits)) then 3048 Init := First (Component_Associations (Inits)); 3049 while Present (Init) loop 3050 Check_SPARK_Initialized_State (Init); 3051 Next (Init); 3052 end loop; 3053 end if; 3054 end if; 3055 end if; 3056 end Check_SPARK_Initialized_States; 3057 3058 -- Local variables 3059 3060 Pack_Body : constant Node_Id := Find_Related_Package_Or_Body (N); 3061 3062 -- Start of processing for Check_SPARK_Refined_State_Pragma 3063 3064 begin 3065 -- Pragma Refined_State must be associated with a package body 3066 3067 pragma Assert 3068 (Present (Pack_Body) and then Nkind (Pack_Body) = N_Package_Body); 3069 3070 -- Verify that each external contitunent of an abstract state mentioned 3071 -- in pragma Initializes is properly elaborated. 3072 3073 Check_SPARK_Initialized_States (Unique_Defining_Entity (Pack_Body)); 3074 end Check_SPARK_Refined_State_Pragma; 3075 3076 ---------------------- 3077 -- Compilation_Unit -- 3078 ---------------------- 3079 3080 function Compilation_Unit (Unit_Id : Entity_Id) return Node_Id is 3081 Comp_Unit : Node_Id; 3082 3083 begin 3084 Comp_Unit := Parent (Unit_Id); 3085 3086 -- Handle the case where a concurrent subunit is rewritten as a null 3087 -- statement due to expansion activities. 3088 3089 if Nkind (Comp_Unit) = N_Null_Statement 3090 and then Nkind_In (Original_Node (Comp_Unit), N_Protected_Body, 3091 N_Task_Body) 3092 then 3093 Comp_Unit := Parent (Comp_Unit); 3094 pragma Assert (Nkind (Comp_Unit) = N_Subunit); 3095 3096 -- Otherwise use the declaration node of the unit 3097 3098 else 3099 Comp_Unit := Parent (Unit_Declaration_Node (Unit_Id)); 3100 end if; 3101 3102 -- Handle the case where a subprogram instantiation which acts as a 3103 -- compilation unit is expanded into an anonymous package that wraps 3104 -- the instantiated subprogram. 3105 3106 if Nkind (Comp_Unit) = N_Package_Specification 3107 and then Nkind_In (Original_Node (Parent (Comp_Unit)), 3108 N_Function_Instantiation, 3109 N_Procedure_Instantiation) 3110 then 3111 Comp_Unit := Parent (Parent (Comp_Unit)); 3112 3113 -- Handle the case where the compilation unit is a subunit 3114 3115 elsif Nkind (Comp_Unit) = N_Subunit then 3116 Comp_Unit := Parent (Comp_Unit); 3117 end if; 3118 3119 pragma Assert (Nkind (Comp_Unit) = N_Compilation_Unit); 3120 3121 return Comp_Unit; 3122 end Compilation_Unit; 3123 3124 ----------------------- 3125 -- Early_Call_Region -- 3126 ----------------------- 3127 3128 function Early_Call_Region (Body_Id : Entity_Id) return Node_Id is 3129 begin 3130 pragma Assert (Ekind_In (Body_Id, E_Entry, 3131 E_Entry_Family, 3132 E_Function, 3133 E_Procedure, 3134 E_Subprogram_Body)); 3135 3136 if Early_Call_Regions_In_Use then 3137 return Early_Call_Regions.Get (Body_Id); 3138 end if; 3139 3140 return Early_Call_Regions_No_Element; 3141 end Early_Call_Region; 3142 3143 ----------------------------- 3144 -- Early_Call_Regions_Hash -- 3145 ----------------------------- 3146 3147 function Early_Call_Regions_Hash 3148 (Key : Entity_Id) return Early_Call_Regions_Index 3149 is 3150 begin 3151 return Early_Call_Regions_Index (Key mod Early_Call_Regions_Max); 3152 end Early_Call_Regions_Hash; 3153 3154 ----------------- 3155 -- Elab_Msg_NE -- 3156 ----------------- 3157 3158 procedure Elab_Msg_NE 3159 (Msg : String; 3160 N : Node_Id; 3161 Id : Entity_Id; 3162 Info_Msg : Boolean; 3163 In_SPARK : Boolean) 3164 is 3165 function Prefix return String; 3166 -- Obtain the prefix of the message 3167 3168 function Suffix return String; 3169 -- Obtain the suffix of the message 3170 3171 ------------ 3172 -- Prefix -- 3173 ------------ 3174 3175 function Prefix return String is 3176 begin 3177 if Info_Msg then 3178 return "info: "; 3179 else 3180 return ""; 3181 end if; 3182 end Prefix; 3183 3184 ------------ 3185 -- Suffix -- 3186 ------------ 3187 3188 function Suffix return String is 3189 begin 3190 if In_SPARK then 3191 return " in SPARK"; 3192 else 3193 return ""; 3194 end if; 3195 end Suffix; 3196 3197 -- Start of processing for Elab_Msg_NE 3198 3199 begin 3200 Error_Msg_NE (Prefix & Msg & Suffix, N, Id); 3201 end Elab_Msg_NE; 3202 3203 ------------------------ 3204 -- Elaboration_Status -- 3205 ------------------------ 3206 3207 function Elaboration_Status 3208 (Unit_Id : Entity_Id) return Elaboration_Attributes 3209 is 3210 begin 3211 if Elaboration_Statuses_In_Use then 3212 return Elaboration_Statuses.Get (Unit_Id); 3213 end if; 3214 3215 return Elaboration_Statuses_No_Element; 3216 end Elaboration_Status; 3217 3218 ------------------------------- 3219 -- Elaboration_Statuses_Hash -- 3220 ------------------------------- 3221 3222 function Elaboration_Statuses_Hash 3223 (Key : Entity_Id) return Elaboration_Statuses_Index 3224 is 3225 begin 3226 return Elaboration_Statuses_Index (Key mod Elaboration_Statuses_Max); 3227 end Elaboration_Statuses_Hash; 3228 3229 ------------------------------ 3230 -- Ensure_Prior_Elaboration -- 3231 ------------------------------ 3232 3233 procedure Ensure_Prior_Elaboration 3234 (N : Node_Id; 3235 Unit_Id : Entity_Id; 3236 Prag_Nam : Name_Id; 3237 State : Processing_Attributes) 3238 is 3239 begin 3240 pragma Assert (Nam_In (Prag_Nam, Name_Elaborate, Name_Elaborate_All)); 3241 3242 -- Nothing to do when the caller has suppressed the generation of 3243 -- implicit Elaborate[_All] pragmas. 3244 3245 if State.Suppress_Implicit_Pragmas then 3246 return; 3247 3248 -- Nothing to do when the need for prior elaboration came from a partial 3249 -- finalization routine which occurs in an initialization context. This 3250 -- behaviour parallels that of the old ABE mechanism. 3251 3252 elsif State.Within_Partial_Finalization then 3253 return; 3254 3255 -- Nothing to do when the need for prior elaboration came from a task 3256 -- body and switch -gnatd.y (disable implicit pragma Elaborate_All on 3257 -- task bodies) is in effect. 3258 3259 elsif Debug_Flag_Dot_Y and then State.Within_Task_Body then 3260 return; 3261 3262 -- Nothing to do when the unit is elaborated prior to the main unit. 3263 -- This check must also consider the following cases: 3264 3265 -- * No check is made against the context of the main unit because this 3266 -- is specific to the elaboration model in effect and requires custom 3267 -- handling (see Ensure_xxx_Prior_Elaboration). 3268 3269 -- * Unit_Id is subject to pragma Elaborate_Body. An implicit pragma 3270 -- Elaborate[_All] MUST be generated even though Unit_Id is always 3271 -- elaborated prior to the main unit. This is a conservative strategy 3272 -- which ensures that other units withed by Unit_Id will not lead to 3273 -- an ABE. 3274 3275 -- package A is package body A is 3276 -- procedure ABE; procedure ABE is ... end ABE; 3277 -- end A; end A; 3278 3279 -- with A; 3280 -- package B is package body B is 3281 -- pragma Elaborate_Body; procedure Proc is 3282 -- begin 3283 -- procedure Proc; A.ABE; 3284 -- package B; end Proc; 3285 -- end B; 3286 3287 -- with B; 3288 -- package C is package body C is 3289 -- ... ... 3290 -- end C; begin 3291 -- B.Proc; 3292 -- end C; 3293 3294 -- In the example above, the elaboration of C invokes B.Proc. B is 3295 -- subject to pragma Elaborate_Body. If no pragma Elaborate[_All] is 3296 -- generated for B in C, then the following elaboratio order will lead 3297 -- to an ABE: 3298 3299 -- spec of A elaborated 3300 -- spec of B elaborated 3301 -- body of B elaborated 3302 -- spec of C elaborated 3303 -- body of C elaborated <-- calls B.Proc which calls A.ABE 3304 -- body of A elaborated <-- problem 3305 3306 -- The generation of an implicit pragma Elaborate_All (B) ensures that 3307 -- the elaboration order mechanism will not pick the above order. 3308 3309 -- An implicit Elaborate is NOT generated when the unit is subject to 3310 -- Elaborate_Body because both pragmas have the exact same effect. 3311 3312 -- * Unit_Id is the main unit. An implicit pragma Elaborate[_All] MUST 3313 -- NOT be generated in this case because a unit cannot depend on its 3314 -- own elaboration. This case is therefore treated as valid prior 3315 -- elaboration. 3316 3317 elsif Has_Prior_Elaboration 3318 (Unit_Id => Unit_Id, 3319 Same_Unit_OK => True, 3320 Elab_Body_OK => Prag_Nam = Name_Elaborate) 3321 then 3322 return; 3323 3324 -- Suggest the use of pragma Prag_Nam when the dynamic model is in 3325 -- effect. 3326 3327 elsif Dynamic_Elaboration_Checks then 3328 Ensure_Prior_Elaboration_Dynamic 3329 (N => N, 3330 Unit_Id => Unit_Id, 3331 Prag_Nam => Prag_Nam); 3332 3333 -- Install an implicit pragma Prag_Nam when the static model is in 3334 -- effect. 3335 3336 else 3337 pragma Assert (Static_Elaboration_Checks); 3338 3339 Ensure_Prior_Elaboration_Static 3340 (N => N, 3341 Unit_Id => Unit_Id, 3342 Prag_Nam => Prag_Nam); 3343 end if; 3344 end Ensure_Prior_Elaboration; 3345 3346 -------------------------------------- 3347 -- Ensure_Prior_Elaboration_Dynamic -- 3348 -------------------------------------- 3349 3350 procedure Ensure_Prior_Elaboration_Dynamic 3351 (N : Node_Id; 3352 Unit_Id : Entity_Id; 3353 Prag_Nam : Name_Id) 3354 is 3355 procedure Info_Missing_Pragma; 3356 pragma Inline (Info_Missing_Pragma); 3357 -- Output information concerning missing Elaborate or Elaborate_All 3358 -- pragma with name Prag_Nam for scenario N, which would ensure the 3359 -- prior elaboration of Unit_Id. 3360 3361 ------------------------- 3362 -- Info_Missing_Pragma -- 3363 ------------------------- 3364 3365 procedure Info_Missing_Pragma is 3366 begin 3367 -- Internal units are ignored as they cause unnecessary noise 3368 3369 if not In_Internal_Unit (Unit_Id) then 3370 3371 -- The name of the unit subjected to the elaboration pragma is 3372 -- fully qualified to improve the clarity of the info message. 3373 3374 Error_Msg_Name_1 := Prag_Nam; 3375 Error_Msg_Qual_Level := Nat'Last; 3376 3377 Error_Msg_NE ("info: missing pragma % for unit &", N, Unit_Id); 3378 Error_Msg_Qual_Level := 0; 3379 end if; 3380 end Info_Missing_Pragma; 3381 3382 -- Local variables 3383 3384 Elab_Attrs : Elaboration_Attributes; 3385 Level : Enclosing_Level_Kind; 3386 3387 -- Start of processing for Ensure_Prior_Elaboration_Dynamic 3388 3389 begin 3390 Elab_Attrs := Elaboration_Status (Unit_Id); 3391 3392 -- Nothing to do when the unit is guaranteed prior elaboration by means 3393 -- of a source Elaborate[_All] pragma. 3394 3395 if Present (Elab_Attrs.Source_Pragma) then 3396 return; 3397 end if; 3398 3399 -- Output extra information on a missing Elaborate[_All] pragma when 3400 -- switch -gnatel (info messages on implicit Elaborate[_All] pragmas 3401 -- is in effect. 3402 3403 if Elab_Info_Messages then 3404 3405 -- Performance note: parent traversal 3406 3407 Level := Find_Enclosing_Level (N); 3408 3409 -- Declaration-level scenario 3410 3411 if (Is_Suitable_Call (N) or else Is_Suitable_Instantiation (N)) 3412 and then Level = Declaration_Level 3413 then 3414 null; 3415 3416 -- Library-level scenario 3417 3418 elsif Level in Library_Level then 3419 null; 3420 3421 -- Instantiation library-level scenario 3422 3423 elsif Level = Instantiation then 3424 null; 3425 3426 -- Otherwise the scenario does not appear at the proper level and 3427 -- cannot possibly act as a top-level scenario. 3428 3429 else 3430 return; 3431 end if; 3432 3433 Info_Missing_Pragma; 3434 end if; 3435 end Ensure_Prior_Elaboration_Dynamic; 3436 3437 ------------------------------------- 3438 -- Ensure_Prior_Elaboration_Static -- 3439 ------------------------------------- 3440 3441 procedure Ensure_Prior_Elaboration_Static 3442 (N : Node_Id; 3443 Unit_Id : Entity_Id; 3444 Prag_Nam : Name_Id) 3445 is 3446 function Find_With_Clause 3447 (Items : List_Id; 3448 Withed_Id : Entity_Id) return Node_Id; 3449 pragma Inline (Find_With_Clause); 3450 -- Find a nonlimited with clause in the list of context items Items 3451 -- that withs unit Withed_Id. Return Empty if no such clause is found. 3452 3453 procedure Info_Implicit_Pragma; 3454 pragma Inline (Info_Implicit_Pragma); 3455 -- Output information concerning an implicitly generated Elaborate or 3456 -- Elaborate_All pragma with name Prag_Nam for scenario N which ensures 3457 -- the prior elaboration of unit Unit_Id. 3458 3459 ---------------------- 3460 -- Find_With_Clause -- 3461 ---------------------- 3462 3463 function Find_With_Clause 3464 (Items : List_Id; 3465 Withed_Id : Entity_Id) return Node_Id 3466 is 3467 Item : Node_Id; 3468 3469 begin 3470 -- Examine the context clauses looking for a suitable with. Note that 3471 -- limited clauses do not affect the elaboration order. 3472 3473 Item := First (Items); 3474 while Present (Item) loop 3475 if Nkind (Item) = N_With_Clause 3476 and then not Error_Posted (Item) 3477 and then not Limited_Present (Item) 3478 and then Entity (Name (Item)) = Withed_Id 3479 then 3480 return Item; 3481 end if; 3482 3483 Next (Item); 3484 end loop; 3485 3486 return Empty; 3487 end Find_With_Clause; 3488 3489 -------------------------- 3490 -- Info_Implicit_Pragma -- 3491 -------------------------- 3492 3493 procedure Info_Implicit_Pragma is 3494 begin 3495 -- Internal units are ignored as they cause unnecessary noise 3496 3497 if not In_Internal_Unit (Unit_Id) then 3498 3499 -- The name of the unit subjected to the elaboration pragma is 3500 -- fully qualified to improve the clarity of the info message. 3501 3502 Error_Msg_Name_1 := Prag_Nam; 3503 Error_Msg_Qual_Level := Nat'Last; 3504 3505 Error_Msg_NE 3506 ("info: implicit pragma % generated for unit &", N, Unit_Id); 3507 3508 Error_Msg_Qual_Level := 0; 3509 Output_Active_Scenarios (N); 3510 end if; 3511 end Info_Implicit_Pragma; 3512 3513 -- Local variables 3514 3515 Main_Cunit : constant Node_Id := Cunit (Main_Unit); 3516 Loc : constant Source_Ptr := Sloc (Main_Cunit); 3517 Unit_Cunit : constant Node_Id := Compilation_Unit (Unit_Id); 3518 3519 Clause : Node_Id; 3520 Elab_Attrs : Elaboration_Attributes; 3521 Items : List_Id; 3522 3523 -- Start of processing for Ensure_Prior_Elaboration_Static 3524 3525 begin 3526 Elab_Attrs := Elaboration_Status (Unit_Id); 3527 3528 -- Nothing to do when the unit is guaranteed prior elaboration by means 3529 -- of a source Elaborate[_All] pragma. 3530 3531 if Present (Elab_Attrs.Source_Pragma) then 3532 return; 3533 3534 -- Nothing to do when the unit has an existing implicit Elaborate[_All] 3535 -- pragma installed by a previous scenario. 3536 3537 elsif Present (Elab_Attrs.With_Clause) then 3538 3539 -- The unit is already guaranteed prior elaboration by means of an 3540 -- implicit Elaborate pragma, however the current scenario imposes 3541 -- a stronger requirement of Elaborate_All. "Upgrade" the existing 3542 -- pragma to match this new requirement. 3543 3544 if Elaborate_Desirable (Elab_Attrs.With_Clause) 3545 and then Prag_Nam = Name_Elaborate_All 3546 then 3547 Set_Elaborate_All_Desirable (Elab_Attrs.With_Clause); 3548 Set_Elaborate_Desirable (Elab_Attrs.With_Clause, False); 3549 end if; 3550 3551 return; 3552 end if; 3553 3554 -- At this point it is known that the unit has no prior elaboration 3555 -- according to pragmas and hierarchical relationships. 3556 3557 Items := Context_Items (Main_Cunit); 3558 3559 if No (Items) then 3560 Items := New_List; 3561 Set_Context_Items (Main_Cunit, Items); 3562 end if; 3563 3564 -- Locate the with clause for the unit. Note that there may not be a 3565 -- clause if the unit is visible through a subunit-body, body-spec, or 3566 -- spec-parent relationship. 3567 3568 Clause := 3569 Find_With_Clause 3570 (Items => Items, 3571 Withed_Id => Unit_Id); 3572 3573 -- Generate: 3574 -- with Id; 3575 3576 -- Note that adding implicit with clauses is safe because analysis, 3577 -- resolution, and expansion have already taken place and it is not 3578 -- possible to interfere with visibility. 3579 3580 if No (Clause) then 3581 Clause := 3582 Make_With_Clause (Loc, 3583 Name => New_Occurrence_Of (Unit_Id, Loc)); 3584 3585 Set_Implicit_With (Clause); 3586 Set_Library_Unit (Clause, Unit_Cunit); 3587 3588 Append_To (Items, Clause); 3589 end if; 3590 3591 -- Mark the with clause depending on the pragma required 3592 3593 if Prag_Nam = Name_Elaborate then 3594 Set_Elaborate_Desirable (Clause); 3595 else 3596 Set_Elaborate_All_Desirable (Clause); 3597 end if; 3598 3599 -- The implicit Elaborate[_All] ensures the prior elaboration of the 3600 -- unit. Include the unit in the elaboration context of the main unit. 3601 3602 Set_Elaboration_Status 3603 (Unit_Id => Unit_Id, 3604 Val => Elaboration_Attributes'(Source_Pragma => Empty, 3605 With_Clause => Clause)); 3606 3607 -- Output extra information on an implicit Elaborate[_All] pragma when 3608 -- switch -gnatel (info messages on implicit Elaborate[_All] pragmas is 3609 -- in effect. 3610 3611 if Elab_Info_Messages then 3612 Info_Implicit_Pragma; 3613 end if; 3614 end Ensure_Prior_Elaboration_Static; 3615 3616 ----------------------------- 3617 -- Extract_Assignment_Name -- 3618 ----------------------------- 3619 3620 function Extract_Assignment_Name (Asmt : Node_Id) return Node_Id is 3621 Nam : Node_Id; 3622 3623 begin 3624 Nam := Name (Asmt); 3625 3626 -- When the name denotes an array or record component, find the whole 3627 -- object. 3628 3629 while Nkind_In (Nam, N_Explicit_Dereference, 3630 N_Indexed_Component, 3631 N_Selected_Component, 3632 N_Slice) 3633 loop 3634 Nam := Prefix (Nam); 3635 end loop; 3636 3637 return Nam; 3638 end Extract_Assignment_Name; 3639 3640 ----------------------------- 3641 -- Extract_Call_Attributes -- 3642 ----------------------------- 3643 3644 procedure Extract_Call_Attributes 3645 (Call : Node_Id; 3646 Target_Id : out Entity_Id; 3647 Attrs : out Call_Attributes) 3648 is 3649 From_Source : Boolean; 3650 In_Declarations : Boolean; 3651 Is_Dispatching : Boolean; 3652 3653 begin 3654 -- Extraction for call markers 3655 3656 if Nkind (Call) = N_Call_Marker then 3657 Target_Id := Target (Call); 3658 From_Source := Is_Source_Call (Call); 3659 In_Declarations := Is_Declaration_Level_Node (Call); 3660 Is_Dispatching := Is_Dispatching_Call (Call); 3661 3662 -- Extraction for entry calls, requeue, and subprogram calls 3663 3664 else 3665 pragma Assert (Nkind_In (Call, N_Entry_Call_Statement, 3666 N_Function_Call, 3667 N_Procedure_Call_Statement, 3668 N_Requeue_Statement)); 3669 3670 Target_Id := Entity (Extract_Call_Name (Call)); 3671 From_Source := Comes_From_Source (Call); 3672 3673 -- Performance note: parent traversal 3674 3675 In_Declarations := Find_Enclosing_Level (Call) = Declaration_Level; 3676 Is_Dispatching := 3677 Nkind_In (Call, N_Function_Call, N_Procedure_Call_Statement) 3678 and then Present (Controlling_Argument (Call)); 3679 end if; 3680 3681 -- Obtain the original entry or subprogram which the target may rename 3682 -- except when the target is an instantiation. In this case the alias 3683 -- is the internally generated subprogram which appears within the the 3684 -- anonymous package created for the instantiation. Such an alias is not 3685 -- a suitable target. 3686 3687 if not (Is_Subprogram (Target_Id) 3688 and then Is_Generic_Instance (Target_Id)) 3689 then 3690 Target_Id := Get_Renamed_Entity (Target_Id); 3691 end if; 3692 3693 -- Set all attributes 3694 3695 Attrs.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Call); 3696 Attrs.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Node (Call); 3697 Attrs.From_Source := From_Source; 3698 Attrs.Ghost_Mode_Ignore := Is_Ignored_Ghost_Node (Call); 3699 Attrs.In_Declarations := In_Declarations; 3700 Attrs.Is_Dispatching := Is_Dispatching; 3701 Attrs.SPARK_Mode_On := Is_SPARK_Mode_On_Node (Call); 3702 end Extract_Call_Attributes; 3703 3704 ----------------------- 3705 -- Extract_Call_Name -- 3706 ----------------------- 3707 3708 function Extract_Call_Name (Call : Node_Id) return Node_Id is 3709 Nam : Node_Id; 3710 3711 begin 3712 Nam := Name (Call); 3713 3714 -- When the call invokes an entry family, the name appears as an indexed 3715 -- component. 3716 3717 if Nkind (Nam) = N_Indexed_Component then 3718 Nam := Prefix (Nam); 3719 end if; 3720 3721 -- When the call employs the object.operation form, the name appears as 3722 -- a selected component. 3723 3724 if Nkind (Nam) = N_Selected_Component then 3725 Nam := Selector_Name (Nam); 3726 end if; 3727 3728 return Nam; 3729 end Extract_Call_Name; 3730 3731 --------------------------------- 3732 -- Extract_Instance_Attributes -- 3733 --------------------------------- 3734 3735 procedure Extract_Instance_Attributes 3736 (Exp_Inst : Node_Id; 3737 Inst_Body : out Node_Id; 3738 Inst_Decl : out Node_Id) 3739 is 3740 Body_Id : Entity_Id; 3741 3742 begin 3743 -- Assume that the attributes are unavailable 3744 3745 Inst_Body := Empty; 3746 Inst_Decl := Empty; 3747 3748 -- Generic package or subprogram spec 3749 3750 if Nkind_In (Exp_Inst, N_Package_Declaration, 3751 N_Subprogram_Declaration) 3752 then 3753 Inst_Decl := Exp_Inst; 3754 Body_Id := Corresponding_Body (Inst_Decl); 3755 3756 if Present (Body_Id) then 3757 Inst_Body := Unit_Declaration_Node (Body_Id); 3758 end if; 3759 3760 -- Generic package or subprogram body 3761 3762 else 3763 pragma Assert 3764 (Nkind_In (Exp_Inst, N_Package_Body, N_Subprogram_Body)); 3765 3766 Inst_Body := Exp_Inst; 3767 Inst_Decl := Unit_Declaration_Node (Corresponding_Spec (Inst_Body)); 3768 end if; 3769 end Extract_Instance_Attributes; 3770 3771 -------------------------------------- 3772 -- Extract_Instantiation_Attributes -- 3773 -------------------------------------- 3774 3775 procedure Extract_Instantiation_Attributes 3776 (Exp_Inst : Node_Id; 3777 Inst : out Node_Id; 3778 Inst_Id : out Entity_Id; 3779 Gen_Id : out Entity_Id; 3780 Attrs : out Instantiation_Attributes) 3781 is 3782 begin 3783 Inst := Original_Node (Exp_Inst); 3784 Inst_Id := Defining_Entity (Inst); 3785 3786 -- Traverse a possible chain of renamings to obtain the original generic 3787 -- being instantiatied. 3788 3789 Gen_Id := Get_Renamed_Entity (Entity (Name (Inst))); 3790 3791 -- Set all attributes 3792 3793 Attrs.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Inst); 3794 Attrs.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Node (Inst); 3795 Attrs.Ghost_Mode_Ignore := Is_Ignored_Ghost_Node (Inst); 3796 Attrs.In_Declarations := Is_Declaration_Level_Node (Inst); 3797 Attrs.SPARK_Mode_On := Is_SPARK_Mode_On_Node (Inst); 3798 end Extract_Instantiation_Attributes; 3799 3800 ------------------------------- 3801 -- Extract_Target_Attributes -- 3802 ------------------------------- 3803 3804 procedure Extract_Target_Attributes 3805 (Target_Id : Entity_Id; 3806 Attrs : out Target_Attributes) 3807 is 3808 procedure Extract_Package_Or_Subprogram_Attributes 3809 (Spec_Id : out Entity_Id; 3810 Body_Decl : out Node_Id); 3811 -- Obtain the attributes associated with a package or a subprogram. 3812 -- Spec_Id is the package or subprogram. Body_Decl is the declaration 3813 -- of the corresponding package or subprogram body. 3814 3815 procedure Extract_Protected_Entry_Attributes 3816 (Spec_Id : out Entity_Id; 3817 Body_Decl : out Node_Id; 3818 Body_Barf : out Node_Id); 3819 -- Obtain the attributes associated with a protected entry [family]. 3820 -- Spec_Id is the entity of the protected body subprogram. Body_Decl 3821 -- is the declaration of Spec_Id's corresponding body. Body_Barf is 3822 -- the declaration of the barrier function body. 3823 3824 procedure Extract_Protected_Subprogram_Attributes 3825 (Spec_Id : out Entity_Id; 3826 Body_Decl : out Node_Id); 3827 -- Obtain the attributes associated with a protected subprogram. Formal 3828 -- Spec_Id is the entity of the protected body subprogram. Body_Decl is 3829 -- the declaration of Spec_Id's corresponding body. 3830 3831 procedure Extract_Task_Entry_Attributes 3832 (Spec_Id : out Entity_Id; 3833 Body_Decl : out Node_Id); 3834 -- Obtain the attributes associated with a task entry [family]. Formal 3835 -- Spec_Id is the entity of the task body procedure. Body_Decl is the 3836 -- declaration of Spec_Id's corresponding body. 3837 3838 ---------------------------------------------- 3839 -- Extract_Package_Or_Subprogram_Attributes -- 3840 ---------------------------------------------- 3841 3842 procedure Extract_Package_Or_Subprogram_Attributes 3843 (Spec_Id : out Entity_Id; 3844 Body_Decl : out Node_Id) 3845 is 3846 Body_Id : Entity_Id; 3847 Init_Id : Entity_Id; 3848 Spec_Decl : Node_Id; 3849 3850 begin 3851 -- Assume that the body is not available 3852 3853 Body_Decl := Empty; 3854 Spec_Id := Target_Id; 3855 3856 -- For body retrieval purposes, the entity of the initial declaration 3857 -- is that of the spec. 3858 3859 Init_Id := Spec_Id; 3860 3861 -- The only exception to the above is a function which returns a 3862 -- constrained array type in a SPARK-to-C compilation. In this case 3863 -- the function receives a corresponding procedure which has an out 3864 -- parameter. The proper body for ABE checks and diagnostics is that 3865 -- of the procedure. 3866 3867 if Ekind (Init_Id) = E_Function 3868 and then Rewritten_For_C (Init_Id) 3869 then 3870 Init_Id := Corresponding_Procedure (Init_Id); 3871 end if; 3872 3873 -- Extract the attributes of the body 3874 3875 Spec_Decl := Unit_Declaration_Node (Init_Id); 3876 3877 -- The initial declaration is a stand alone subprogram body 3878 3879 if Nkind (Spec_Decl) = N_Subprogram_Body then 3880 Body_Decl := Spec_Decl; 3881 3882 -- Otherwise the package or subprogram has a spec and a completing 3883 -- body. 3884 3885 elsif Nkind_In (Spec_Decl, N_Generic_Package_Declaration, 3886 N_Generic_Subprogram_Declaration, 3887 N_Package_Declaration, 3888 N_Subprogram_Body_Stub, 3889 N_Subprogram_Declaration) 3890 then 3891 Body_Id := Corresponding_Body (Spec_Decl); 3892 3893 if Present (Body_Id) then 3894 Body_Decl := Unit_Declaration_Node (Body_Id); 3895 end if; 3896 end if; 3897 end Extract_Package_Or_Subprogram_Attributes; 3898 3899 ---------------------------------------- 3900 -- Extract_Protected_Entry_Attributes -- 3901 ---------------------------------------- 3902 3903 procedure Extract_Protected_Entry_Attributes 3904 (Spec_Id : out Entity_Id; 3905 Body_Decl : out Node_Id; 3906 Body_Barf : out Node_Id) 3907 is 3908 Barf_Id : Entity_Id; 3909 Body_Id : Entity_Id; 3910 3911 begin 3912 -- Assume that the bodies are not available 3913 3914 Body_Barf := Empty; 3915 Body_Decl := Empty; 3916 3917 -- When the entry [family] has already been expanded, it carries both 3918 -- the procedure which emulates the behavior of the entry [family] as 3919 -- well as the barrier function. 3920 3921 if Present (Protected_Body_Subprogram (Target_Id)) then 3922 Spec_Id := Protected_Body_Subprogram (Target_Id); 3923 3924 -- Extract the attributes of the barrier function 3925 3926 Barf_Id := 3927 Corresponding_Body 3928 (Unit_Declaration_Node (Barrier_Function (Target_Id))); 3929 3930 if Present (Barf_Id) then 3931 Body_Barf := Unit_Declaration_Node (Barf_Id); 3932 end if; 3933 3934 -- Otherwise no expansion took place 3935 3936 else 3937 Spec_Id := Target_Id; 3938 end if; 3939 3940 -- Extract the attributes of the entry body 3941 3942 Body_Id := Corresponding_Body (Unit_Declaration_Node (Spec_Id)); 3943 3944 if Present (Body_Id) then 3945 Body_Decl := Unit_Declaration_Node (Body_Id); 3946 end if; 3947 end Extract_Protected_Entry_Attributes; 3948 3949 --------------------------------------------- 3950 -- Extract_Protected_Subprogram_Attributes -- 3951 --------------------------------------------- 3952 3953 procedure Extract_Protected_Subprogram_Attributes 3954 (Spec_Id : out Entity_Id; 3955 Body_Decl : out Node_Id) 3956 is 3957 Body_Id : Entity_Id; 3958 3959 begin 3960 -- Assume that the body is not available 3961 3962 Body_Decl := Empty; 3963 3964 -- When the protected subprogram has already been expanded, it 3965 -- carries the subprogram which seizes the lock and invokes the 3966 -- original statements. 3967 3968 if Present (Protected_Subprogram (Target_Id)) then 3969 Spec_Id := 3970 Protected_Body_Subprogram (Protected_Subprogram (Target_Id)); 3971 3972 -- Otherwise no expansion took place 3973 3974 else 3975 Spec_Id := Target_Id; 3976 end if; 3977 3978 -- Extract the attributes of the body 3979 3980 Body_Id := Corresponding_Body (Unit_Declaration_Node (Spec_Id)); 3981 3982 if Present (Body_Id) then 3983 Body_Decl := Unit_Declaration_Node (Body_Id); 3984 end if; 3985 end Extract_Protected_Subprogram_Attributes; 3986 3987 ----------------------------------- 3988 -- Extract_Task_Entry_Attributes -- 3989 ----------------------------------- 3990 3991 procedure Extract_Task_Entry_Attributes 3992 (Spec_Id : out Entity_Id; 3993 Body_Decl : out Node_Id) 3994 is 3995 Task_Typ : constant Entity_Id := Non_Private_View (Scope (Target_Id)); 3996 Body_Id : Entity_Id; 3997 3998 begin 3999 -- Assume that the body is not available 4000 4001 Body_Decl := Empty; 4002 4003 -- The the task type has already been expanded, it carries the 4004 -- procedure which emulates the behavior of the task body. 4005 4006 if Present (Task_Body_Procedure (Task_Typ)) then 4007 Spec_Id := Task_Body_Procedure (Task_Typ); 4008 4009 -- Otherwise no expansion took place 4010 4011 else 4012 Spec_Id := Task_Typ; 4013 end if; 4014 4015 -- Extract the attributes of the body 4016 4017 Body_Id := Corresponding_Body (Unit_Declaration_Node (Spec_Id)); 4018 4019 if Present (Body_Id) then 4020 Body_Decl := Unit_Declaration_Node (Body_Id); 4021 end if; 4022 end Extract_Task_Entry_Attributes; 4023 4024 -- Local variables 4025 4026 Prag : constant Node_Id := SPARK_Pragma (Target_Id); 4027 Body_Barf : Node_Id; 4028 Body_Decl : Node_Id; 4029 Spec_Id : Entity_Id; 4030 4031 -- Start of processing for Extract_Target_Attributes 4032 4033 begin 4034 -- Assume that the body of the barrier function is not available 4035 4036 Body_Barf := Empty; 4037 4038 -- The target is a protected entry [family] 4039 4040 if Is_Protected_Entry (Target_Id) then 4041 Extract_Protected_Entry_Attributes 4042 (Spec_Id => Spec_Id, 4043 Body_Decl => Body_Decl, 4044 Body_Barf => Body_Barf); 4045 4046 -- The target is a protected subprogram 4047 4048 elsif Is_Protected_Subp (Target_Id) 4049 or else Is_Protected_Body_Subp (Target_Id) 4050 then 4051 Extract_Protected_Subprogram_Attributes 4052 (Spec_Id => Spec_Id, 4053 Body_Decl => Body_Decl); 4054 4055 -- The target is a task entry [family] 4056 4057 elsif Is_Task_Entry (Target_Id) then 4058 Extract_Task_Entry_Attributes 4059 (Spec_Id => Spec_Id, 4060 Body_Decl => Body_Decl); 4061 4062 -- Otherwise the target is a package or a subprogram 4063 4064 else 4065 Extract_Package_Or_Subprogram_Attributes 4066 (Spec_Id => Spec_Id, 4067 Body_Decl => Body_Decl); 4068 end if; 4069 4070 -- Set all attributes 4071 4072 Attrs.Body_Barf := Body_Barf; 4073 Attrs.Body_Decl := Body_Decl; 4074 Attrs.Elab_Checks_OK := Is_Elaboration_Checks_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.Ghost_Mode_Ignore := Is_Ignored_Ghost_Entity (Task_Typ); 4126 Attrs.SPARK_Mode_On := 4127 Present (Prag) and then Get_SPARK_Mode_From_Annotation (Prag) = On; 4128 Attrs.Spec_Id := Spec_Id; 4129 Attrs.Task_Decl := Declaration_Node (Task_Typ); 4130 Attrs.Unit_Id := Find_Top_Unit (Task_Typ); 4131 4132 -- At this point certain attributes should always be available 4133 4134 pragma Assert (Present (Attrs.Spec_Id)); 4135 pragma Assert (Present (Attrs.Task_Decl)); 4136 pragma Assert (Present (Attrs.Unit_Id)); 4137 end Extract_Task_Attributes; 4138 4139 ------------------------------------------- 4140 -- Extract_Variable_Reference_Attributes -- 4141 ------------------------------------------- 4142 4143 procedure Extract_Variable_Reference_Attributes 4144 (Ref : Node_Id; 4145 Var_Id : out Entity_Id; 4146 Attrs : out Variable_Attributes) 4147 is 4148 function Get_Renamed_Variable (Id : Entity_Id) return Entity_Id; 4149 -- Obtain the ultimate renamed variable of variable Id 4150 4151 -------------------------- 4152 -- Get_Renamed_Variable -- 4153 -------------------------- 4154 4155 function Get_Renamed_Variable (Id : Entity_Id) return Entity_Id is 4156 Ren_Id : Entity_Id; 4157 4158 begin 4159 Ren_Id := Id; 4160 while Present (Renamed_Entity (Ren_Id)) 4161 and then Nkind (Renamed_Entity (Ren_Id)) in N_Entity 4162 loop 4163 Ren_Id := Renamed_Entity (Ren_Id); 4164 end loop; 4165 4166 return Ren_Id; 4167 end Get_Renamed_Variable; 4168 4169 -- Start of processing for Extract_Variable_Reference_Attributes 4170 4171 begin 4172 -- Extraction for variable reference markers 4173 4174 if Nkind (Ref) = N_Variable_Reference_Marker then 4175 Var_Id := Target (Ref); 4176 4177 -- Extraction for expanded names and identifiers 4178 4179 else 4180 Var_Id := Entity (Ref); 4181 end if; 4182 4183 -- Obtain the original variable which the reference mentions 4184 4185 Var_Id := Get_Renamed_Variable (Var_Id); 4186 Attrs.Unit_Id := Find_Top_Unit (Var_Id); 4187 4188 -- At this point certain attributes should always be available 4189 4190 pragma Assert (Present (Attrs.Unit_Id)); 4191 end Extract_Variable_Reference_Attributes; 4192 4193 -------------------- 4194 -- Find_Code_Unit -- 4195 -------------------- 4196 4197 function Find_Code_Unit (N : Node_Or_Entity_Id) return Entity_Id is 4198 begin 4199 return Find_Unit_Entity (Unit (Cunit (Get_Code_Unit (N)))); 4200 end Find_Code_Unit; 4201 4202 ---------------------------- 4203 -- Find_Early_Call_Region -- 4204 ---------------------------- 4205 4206 function Find_Early_Call_Region 4207 (Body_Decl : Node_Id; 4208 Assume_Elab_Body : Boolean := False; 4209 Skip_Memoization : Boolean := False) return Node_Id 4210 is 4211 -- NOTE: The routines within Find_Early_Call_Region are intentionally 4212 -- unnested to avoid deep indentation of code. 4213 4214 ECR_Found : exception; 4215 -- This exception is raised when the early call region has been found 4216 4217 Start : Node_Id := Empty; 4218 -- The start of the early call region. This variable is updated by the 4219 -- various nested routines. Due to the use of exceptions, the variable 4220 -- must be global to the nested routines. 4221 4222 -- The algorithm implemented in this routine attempts to find the early 4223 -- call region of a subprogram body by inspecting constructs in reverse 4224 -- declarative order, while navigating the tree. The algorithm consists 4225 -- of an Inspection phase and an Advancement phase. The pseudocode is as 4226 -- follows: 4227 -- 4228 -- loop 4229 -- inspection phase 4230 -- advancement phase 4231 -- end loop 4232 -- 4233 -- The infinite loop is terminated by raising exception ECR_Found. The 4234 -- algorithm utilizes two pointers, Curr and Start, to represent the 4235 -- current construct to inspect and the start of the early call region. 4236 -- 4237 -- IMPORTANT: The algorithm must maintain the following invariant at all 4238 -- time for it to function properly - a nested construct is entered only 4239 -- when it contains suitable constructs. This guarantees that leaving a 4240 -- nested or encapsulating construct functions properly. 4241 -- 4242 -- The Inspection phase determines whether the current construct is non- 4243 -- preelaborable, and if it is, the algorithm terminates. 4244 -- 4245 -- The Advancement phase walks the tree in reverse declarative order, 4246 -- while entering and leaving nested and encapsulating constructs. It 4247 -- may also terminate the elaborithm. There are several special cases 4248 -- of advancement. 4249 -- 4250 -- 1) General case: 4251 -- 4252 -- <construct 1> 4253 -- ... 4254 -- <construct N-1> <- Curr 4255 -- <construct N> <- Start 4256 -- <subprogram body> 4257 -- 4258 -- In the general case, a declarative or statement list is traversed in 4259 -- reverse order where Curr is the lead pointer, and Start indicates the 4260 -- last preelaborable construct. 4261 -- 4262 -- 2) Entering handled bodies 4263 -- 4264 -- package body Nested is <- Curr (2.3) 4265 -- <declarations> <- Curr (2.2) 4266 -- begin 4267 -- <statements> <- Curr (2.1) 4268 -- end Nested; 4269 -- <construct> <- Start 4270 -- 4271 -- In this case, the algorithm enters a handled body by starting from 4272 -- the last statement (2.1), or the last declaration (2.2), or the body 4273 -- is consumed (2.3) because it is empty and thus preelaborable. 4274 -- 4275 -- 3) Entering package declarations 4276 -- 4277 -- package Nested is <- Curr (2.3) 4278 -- <visible declarations> <- Curr (2.2) 4279 -- private 4280 -- <private declarations> <- Curr (2.1) 4281 -- end Nested; 4282 -- <construct> <- Start 4283 -- 4284 -- In this case, the algorithm enters a package declaration by starting 4285 -- from the last private declaration (2.1), the last visible declaration 4286 -- (2.2), or the package is consumed (2.3) because it is empty and thus 4287 -- preelaborable. 4288 -- 4289 -- 4) Transitioning from list to list of the same construct 4290 -- 4291 -- Certain constructs have two eligible lists. The algorithm must thus 4292 -- transition from the second to the first list when the second list is 4293 -- exhausted. 4294 -- 4295 -- declare <- Curr (4.2) 4296 -- <declarations> <- Curr (4.1) 4297 -- begin 4298 -- <statements> <- Start 4299 -- end; 4300 -- 4301 -- In this case, the algorithm has exhausted the second list (statements 4302 -- in the example), and continues with the last declaration (4.1) or the 4303 -- construct is consumed (4.2) because it contains only preelaborable 4304 -- code. 4305 -- 4306 -- 5) Transitioning from list to construct 4307 -- 4308 -- tack body Task is <- Curr (5.1) 4309 -- <- Curr (Empty) 4310 -- <construct 1> <- Start 4311 -- 4312 -- In this case, the algorithm has exhausted a list, Curr is Empty, and 4313 -- the owner of the list is consumed (5.1). 4314 -- 4315 -- 6) Transitioning from unit to unit 4316 -- 4317 -- A package body with a spec subject to pragma Elaborate_Body extends 4318 -- the possible range of the early call region to the package spec. 4319 -- 4320 -- package Pack is <- Curr (6.3) 4321 -- pragma Elaborate_Body; <- Curr (6.2) 4322 -- <visible declarations> <- Curr (6.2) 4323 -- private 4324 -- <private declarations> <- Curr (6.1) 4325 -- end Pack; 4326 -- 4327 -- package body Pack is <- Curr, Start 4328 -- 4329 -- In this case, the algorithm has reached a package body compilation 4330 -- unit whose spec is subject to pragma Elaborate_Body, or the caller 4331 -- of the algorithm has specified this behavior. This transition is 4332 -- equivalent to 3). 4333 -- 4334 -- 7) Transitioning from unit to termination 4335 -- 4336 -- Reaching a compilation unit always terminates the algorithm as there 4337 -- are no more lists to examine. This must take 6) into account. 4338 -- 4339 -- 8) Transitioning from subunit to stub 4340 -- 4341 -- package body Pack is separate; <- Curr (8.1) 4342 -- 4343 -- separate (...) 4344 -- package body Pack is <- Curr, Start 4345 -- 4346 -- Reaching a subunit continues the search from the corresponding stub 4347 -- (8.1). 4348 4349 procedure Advance (Curr : in out Node_Id); 4350 pragma Inline (Advance); 4351 -- Update the Curr and Start pointers depending on their location in the 4352 -- tree to the next eligible construct. This routine raises ECR_Found. 4353 4354 procedure Enter_Handled_Body (Curr : in out Node_Id); 4355 pragma Inline (Enter_Handled_Body); 4356 -- Update the Curr and Start pointers to enter a nested handled body if 4357 -- applicable. This routine raises ECR_Found. 4358 4359 procedure Enter_Package_Declaration (Curr : in out Node_Id); 4360 pragma Inline (Enter_Package_Declaration); 4361 -- Update the Curr and Start pointers to enter a nested package spec if 4362 -- applicable. This routine raises ECR_Found. 4363 4364 function Find_ECR (N : Node_Id) return Node_Id; 4365 pragma Inline (Find_ECR); 4366 -- Find an early call region starting from arbitrary node N 4367 4368 function Has_Suitable_Construct (List : List_Id) return Boolean; 4369 pragma Inline (Has_Suitable_Construct); 4370 -- Determine whether list List contains at least one suitable construct 4371 -- for inclusion into an early call region. 4372 4373 procedure Include (N : Node_Id; Curr : out Node_Id); 4374 pragma Inline (Include); 4375 -- Update the Curr and Start pointers to include arbitrary construct N 4376 -- in the early call region. This routine raises ECR_Found. 4377 4378 function Is_OK_Preelaborable_Construct (N : Node_Id) return Boolean; 4379 pragma Inline (Is_OK_Preelaborable_Construct); 4380 -- Determine whether arbitrary node N denotes a preelaboration-safe 4381 -- construct. 4382 4383 function Is_Suitable_Construct (N : Node_Id) return Boolean; 4384 pragma Inline (Is_Suitable_Construct); 4385 -- Determine whether arbitrary node N denotes a suitable construct for 4386 -- inclusion into the early call region. 4387 4388 procedure Transition_Body_Declarations 4389 (Bod : Node_Id; 4390 Curr : in out Node_Id); 4391 pragma Inline (Transition_Body_Declarations); 4392 -- Update the Curr and Start pointers when construct Bod denotes a block 4393 -- statement or a suitable body. This routine raises ECR_Found. 4394 4395 procedure Transition_Handled_Statements 4396 (HSS : Node_Id; 4397 Curr : in out Node_Id); 4398 pragma Inline (Transition_Handled_Statements); 4399 -- Update the Curr and Start pointers when node HSS denotes a handled 4400 -- sequence of statements. This routine raises ECR_Found. 4401 4402 procedure Transition_Spec_Declarations 4403 (Spec : Node_Id; 4404 Curr : in out Node_Id); 4405 pragma Inline (Transition_Spec_Declarations); 4406 -- Update the Curr and Start pointers when construct Spec denotes 4407 -- a concurrent definition or a package spec. This routine raises 4408 -- ECR_Found. 4409 4410 procedure Transition_Unit (Unit : Node_Id; Curr : in out Node_Id); 4411 pragma Inline (Transition_Unit); 4412 -- Update the Curr and Start pointers when node Unit denotes a potential 4413 -- compilation unit. This routine raises ECR_Found. 4414 4415 ------------- 4416 -- Advance -- 4417 ------------- 4418 4419 procedure Advance (Curr : in out Node_Id) is 4420 Context : Node_Id; 4421 4422 begin 4423 -- Curr denotes one of the following cases upon entry into this 4424 -- routine: 4425 -- 4426 -- * Empty - There is no current construct when a declarative or a 4427 -- statement list has been exhausted. This does not necessarily 4428 -- indicate that the early call region has been computed as it 4429 -- may still be possible to transition to another list. 4430 -- 4431 -- * Encapsulator - The current construct encapsulates declarations 4432 -- and/or statements. This indicates that the early call region 4433 -- may extend within the nested construct. 4434 -- 4435 -- * Preelaborable - The current construct is always preelaborable 4436 -- because Find_ECR would not invoke Advance if this was not the 4437 -- case. 4438 4439 -- The current construct is an encapsulator or is preelaborable 4440 4441 if Present (Curr) then 4442 4443 -- Enter encapsulators by inspecting their declarations and/or 4444 -- statements. 4445 4446 if Nkind_In (Curr, N_Block_Statement, N_Package_Body) then 4447 Enter_Handled_Body (Curr); 4448 4449 elsif Nkind (Curr) = N_Package_Declaration then 4450 Enter_Package_Declaration (Curr); 4451 4452 -- Early call regions have a property which can be exploited to 4453 -- optimize the algorithm. 4454 -- 4455 -- <preceding subprogram body> 4456 -- <preelaborable construct 1> 4457 -- ... 4458 -- <preelaborable construct N> 4459 -- <initiating subprogram body> 4460 -- 4461 -- If a traversal initiated from a subprogram body reaches a 4462 -- preceding subprogram body, then both bodies share the same 4463 -- early call region. 4464 -- 4465 -- The property results in the following desirable effects: 4466 -- 4467 -- * If the preceding body already has an early call region, then 4468 -- the initiating body can reuse it. This minimizes the amount 4469 -- of processing performed by the algorithm. 4470 -- 4471 -- * If the preceding body lack an early call region, then the 4472 -- algorithm can compute the early call region, and reuse it 4473 -- for the initiating body. This processing performs the same 4474 -- amount of work, but has the beneficial effect of computing 4475 -- the early call regions of all preceding bodies. 4476 4477 elsif Nkind_In (Curr, N_Entry_Body, N_Subprogram_Body) then 4478 Start := 4479 Find_Early_Call_Region 4480 (Body_Decl => Curr, 4481 Assume_Elab_Body => Assume_Elab_Body, 4482 Skip_Memoization => Skip_Memoization); 4483 4484 raise ECR_Found; 4485 4486 -- Otherwise current construct is preelaborable. Unpdate the early 4487 -- call region to include it. 4488 4489 else 4490 Include (Curr, Curr); 4491 end if; 4492 4493 -- Otherwise the current construct is missing, indicating that the 4494 -- current list has been exhausted. Depending on the context of the 4495 -- list, several transitions are possible. 4496 4497 else 4498 -- The invariant of the algorithm ensures that Curr and Start are 4499 -- at the same level of nesting at the point of a transition. The 4500 -- algorithm can determine which list the traversal came from by 4501 -- examining Start. 4502 4503 Context := Parent (Start); 4504 4505 -- Attempt the following transitions: 4506 -- 4507 -- private declarations -> visible declarations 4508 -- private declarations -> upper level 4509 -- private declarations -> terminate 4510 -- visible declarations -> upper level 4511 -- visible declarations -> terminate 4512 4513 if Nkind_In (Context, N_Package_Specification, 4514 N_Protected_Definition, 4515 N_Task_Definition) 4516 then 4517 Transition_Spec_Declarations (Context, Curr); 4518 4519 -- Attempt the following transitions: 4520 -- 4521 -- statements -> declarations 4522 -- statements -> upper level 4523 -- statements -> corresponding package spec (Elab_Body) 4524 -- statements -> terminate 4525 4526 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements then 4527 Transition_Handled_Statements (Context, Curr); 4528 4529 -- Attempt the following transitions: 4530 -- 4531 -- declarations -> upper level 4532 -- declarations -> corresponding package spec (Elab_Body) 4533 -- declarations -> terminate 4534 4535 elsif Nkind_In (Context, N_Block_Statement, 4536 N_Entry_Body, 4537 N_Package_Body, 4538 N_Protected_Body, 4539 N_Subprogram_Body, 4540 N_Task_Body) 4541 then 4542 Transition_Body_Declarations (Context, Curr); 4543 4544 -- Otherwise it is not possible to transition. Stop the search 4545 -- because there are no more declarations or statements to check. 4546 4547 else 4548 raise ECR_Found; 4549 end if; 4550 end if; 4551 end Advance; 4552 4553 -------------------------- 4554 -- Enter_Handled_Body -- 4555 -------------------------- 4556 4557 procedure Enter_Handled_Body (Curr : in out Node_Id) is 4558 Decls : constant List_Id := Declarations (Curr); 4559 HSS : constant Node_Id := Handled_Statement_Sequence (Curr); 4560 Stmts : List_Id := No_List; 4561 4562 begin 4563 if Present (HSS) then 4564 Stmts := Statements (HSS); 4565 end if; 4566 4567 -- The handled body has a non-empty statement sequence. The construct 4568 -- to inspect is the last statement. 4569 4570 if Has_Suitable_Construct (Stmts) then 4571 Curr := Last (Stmts); 4572 4573 -- The handled body lacks statements, but has non-empty declarations. 4574 -- The construct to inspect is the last declaration. 4575 4576 elsif Has_Suitable_Construct (Decls) then 4577 Curr := Last (Decls); 4578 4579 -- Otherwise the handled body lacks both declarations and statements. 4580 -- The construct to inspect is the node which precedes the handled 4581 -- body. Update the early call region to include the handled body. 4582 4583 else 4584 Include (Curr, Curr); 4585 end if; 4586 end Enter_Handled_Body; 4587 4588 ------------------------------- 4589 -- Enter_Package_Declaration -- 4590 ------------------------------- 4591 4592 procedure Enter_Package_Declaration (Curr : in out Node_Id) is 4593 Pack_Spec : constant Node_Id := Specification (Curr); 4594 Prv_Decls : constant List_Id := Private_Declarations (Pack_Spec); 4595 Vis_Decls : constant List_Id := Visible_Declarations (Pack_Spec); 4596 4597 begin 4598 -- The package has a non-empty private declarations. The construct to 4599 -- inspect is the last private declaration. 4600 4601 if Has_Suitable_Construct (Prv_Decls) then 4602 Curr := Last (Prv_Decls); 4603 4604 -- The package lacks private declarations, but has non-empty visible 4605 -- declarations. In this case the construct to inspect is the last 4606 -- visible declaration. 4607 4608 elsif Has_Suitable_Construct (Vis_Decls) then 4609 Curr := Last (Vis_Decls); 4610 4611 -- Otherwise the package lacks any declarations. The construct to 4612 -- inspect is the node which precedes the package. Update the early 4613 -- call region to include the package declaration. 4614 4615 else 4616 Include (Curr, Curr); 4617 end if; 4618 end Enter_Package_Declaration; 4619 4620 -------------- 4621 -- Find_ECR -- 4622 -------------- 4623 4624 function Find_ECR (N : Node_Id) return Node_Id is 4625 Curr : Node_Id; 4626 4627 begin 4628 -- The early call region starts at N 4629 4630 Curr := Prev (N); 4631 Start := N; 4632 4633 -- Inspect each node in reverse declarative order while going in and 4634 -- out of nested and enclosing constructs. Note that the only way to 4635 -- terminate this infinite loop is to raise exception ECR_Found. 4636 4637 loop 4638 -- The current construct is not preelaboration-safe. Terminate the 4639 -- traversal. 4640 4641 if Present (Curr) 4642 and then not Is_OK_Preelaborable_Construct (Curr) 4643 then 4644 raise ECR_Found; 4645 end if; 4646 4647 -- Advance to the next suitable construct. This may terminate the 4648 -- traversal by raising ECR_Found. 4649 4650 Advance (Curr); 4651 end loop; 4652 4653 exception 4654 when ECR_Found => 4655 return Start; 4656 end Find_ECR; 4657 4658 ---------------------------- 4659 -- Has_Suitable_Construct -- 4660 ---------------------------- 4661 4662 function Has_Suitable_Construct (List : List_Id) return Boolean is 4663 Item : Node_Id; 4664 4665 begin 4666 -- Examine the list in reverse declarative order, looking for a 4667 -- suitable construct. 4668 4669 if Present (List) then 4670 Item := Last (List); 4671 while Present (Item) loop 4672 if Is_Suitable_Construct (Item) then 4673 return True; 4674 end if; 4675 4676 Prev (Item); 4677 end loop; 4678 end if; 4679 4680 return False; 4681 end Has_Suitable_Construct; 4682 4683 ------------- 4684 -- Include -- 4685 ------------- 4686 4687 procedure Include (N : Node_Id; Curr : out Node_Id) is 4688 begin 4689 Start := N; 4690 4691 -- The input node is a compilation unit. This terminates the search 4692 -- because there are no more lists to inspect and there are no more 4693 -- enclosing constructs to climb up to. The transitions are: 4694 -- 4695 -- private declarations -> terminate 4696 -- visible declarations -> terminate 4697 -- statements -> terminate 4698 -- declarations -> terminate 4699 4700 if Nkind (Parent (Start)) = N_Compilation_Unit then 4701 raise ECR_Found; 4702 4703 -- Otherwise the input node is still within some list 4704 4705 else 4706 Curr := Prev (Start); 4707 end if; 4708 end Include; 4709 4710 ----------------------------------- 4711 -- Is_OK_Preelaborable_Construct -- 4712 ----------------------------------- 4713 4714 function Is_OK_Preelaborable_Construct (N : Node_Id) return Boolean is 4715 begin 4716 -- Assignment statements are acceptable as long as they were produced 4717 -- by the ABE mechanism to update elaboration flags. 4718 4719 if Nkind (N) = N_Assignment_Statement then 4720 return Is_Elaboration_Code (N); 4721 4722 -- Block statements are acceptable even though they directly violate 4723 -- preelaborability. The intention is not to penalize the early call 4724 -- region when a block contains only preelaborable constructs. 4725 -- 4726 -- declare 4727 -- Val : constant Integer := 1; 4728 -- begin 4729 -- pragma Assert (Val = 1); 4730 -- null; 4731 -- end; 4732 -- 4733 -- Note that the Advancement phase does enter blocks, and will detect 4734 -- any non-preelaborable declarations or statements within. 4735 4736 elsif Nkind (N) = N_Block_Statement then 4737 return True; 4738 end if; 4739 4740 -- Otherwise the construct must be preelaborable. The check must take 4741 -- the syntactic and semantic structure of the construct. DO NOT use 4742 -- Is_Preelaborable_Construct here. 4743 4744 return not Is_Non_Preelaborable_Construct (N); 4745 end Is_OK_Preelaborable_Construct; 4746 4747 --------------------------- 4748 -- Is_Suitable_Construct -- 4749 --------------------------- 4750 4751 function Is_Suitable_Construct (N : Node_Id) return Boolean is 4752 Context : constant Node_Id := Parent (N); 4753 4754 begin 4755 -- An internally-generated statement sequence which contains only a 4756 -- single null statement is not a suitable construct because it is a 4757 -- byproduct of the parser. Such a null statement should be excluded 4758 -- from the early call region because it carries the source location 4759 -- of the "end" keyword, and may lead to confusing diagnistics. 4760 4761 if Nkind (N) = N_Null_Statement 4762 and then not Comes_From_Source (N) 4763 and then Present (Context) 4764 and then Nkind (Context) = N_Handled_Sequence_Of_Statements 4765 and then not Comes_From_Source (N) 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 : in 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 : in 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 : in 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 : in 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 Related_Instance (Defining_Entity (N)); 5548 5549 -- The unit denotes a concurrent body acting as a subunit. Such bodies 5550 -- are generally rewritten into null statements. The proper entity is 5551 -- that of the "original node". 5552 5553 elsif Nkind (N) = N_Subunit 5554 and then Nkind (Proper_Body (N)) = N_Null_Statement 5555 and then Nkind_In (Original_Node (Proper_Body (N)), N_Protected_Body, 5556 N_Task_Body) 5557 then 5558 return Defining_Entity (Original_Node (Proper_Body (N))); 5559 5560 -- Otherwise the proper entity is the defining entity 5561 5562 else 5563 return Defining_Entity (N); 5564 end if; 5565 end Find_Unit_Entity; 5566 5567 ----------------------- 5568 -- First_Formal_Type -- 5569 ----------------------- 5570 5571 function First_Formal_Type (Subp_Id : Entity_Id) return Entity_Id is 5572 Formal_Id : constant Entity_Id := First_Formal (Subp_Id); 5573 Typ : Entity_Id; 5574 5575 begin 5576 if Present (Formal_Id) then 5577 Typ := Etype (Formal_Id); 5578 5579 -- Handle various combinations of concurrent and private types 5580 5581 loop 5582 if Ekind_In (Typ, E_Protected_Type, E_Task_Type) 5583 and then Present (Anonymous_Object (Typ)) 5584 then 5585 Typ := Anonymous_Object (Typ); 5586 5587 elsif Is_Concurrent_Record_Type (Typ) then 5588 Typ := Corresponding_Concurrent_Type (Typ); 5589 5590 elsif Is_Private_Type (Typ) and then Present (Full_View (Typ)) then 5591 Typ := Full_View (Typ); 5592 5593 else 5594 exit; 5595 end if; 5596 end loop; 5597 5598 return Typ; 5599 end if; 5600 5601 return Empty; 5602 end First_Formal_Type; 5603 5604 -------------- 5605 -- Has_Body -- 5606 -------------- 5607 5608 function Has_Body (Pack_Decl : Node_Id) return Boolean is 5609 function Find_Corresponding_Body (Spec_Id : Entity_Id) return Node_Id; 5610 -- Try to locate the corresponding body of spec Spec_Id. If no body is 5611 -- found, return Empty. 5612 5613 function Find_Body 5614 (Spec_Id : Entity_Id; 5615 From : Node_Id) return Node_Id; 5616 -- Try to locate the corresponding body of spec Spec_Id in the node list 5617 -- which follows arbitrary node From. If no body is found, return Empty. 5618 5619 function Load_Package_Body (Unit_Nam : Unit_Name_Type) return Node_Id; 5620 -- Attempt to load the body of unit Unit_Nam. If the load failed, return 5621 -- Empty. If the compilation will not generate code, return Empty. 5622 5623 ----------------------------- 5624 -- Find_Corresponding_Body -- 5625 ----------------------------- 5626 5627 function Find_Corresponding_Body (Spec_Id : Entity_Id) return Node_Id is 5628 Context : constant Entity_Id := Scope (Spec_Id); 5629 Spec_Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id); 5630 Body_Decl : Node_Id; 5631 Body_Id : Entity_Id; 5632 5633 begin 5634 if Is_Compilation_Unit (Spec_Id) then 5635 Body_Id := Corresponding_Body (Spec_Decl); 5636 5637 if Present (Body_Id) then 5638 return Unit_Declaration_Node (Body_Id); 5639 5640 -- The package is at the library and requires a body. Load the 5641 -- corresponding body because the optional body may be declared 5642 -- there. 5643 5644 elsif Unit_Requires_Body (Spec_Id) then 5645 return 5646 Load_Package_Body 5647 (Get_Body_Name (Unit_Name (Get_Source_Unit (Spec_Decl)))); 5648 5649 -- Otherwise there is no optional body 5650 5651 else 5652 return Empty; 5653 end if; 5654 5655 -- The immediate context is a package. The optional body may be 5656 -- within the body of that package. 5657 5658 -- procedure Proc is 5659 -- package Nested_1 is 5660 -- package Nested_2 is 5661 -- generic 5662 -- package Pack is 5663 -- end Pack; 5664 -- end Nested_2; 5665 -- end Nested_1; 5666 5667 -- package body Nested_1 is 5668 -- package body Nested_2 is separate; 5669 -- end Nested_1; 5670 5671 -- separate (Proc.Nested_1.Nested_2) 5672 -- package body Nested_2 is 5673 -- package body Pack is -- optional body 5674 -- ... 5675 -- end Pack; 5676 -- end Nested_2; 5677 5678 elsif Is_Package_Or_Generic_Package (Context) then 5679 Body_Decl := Find_Corresponding_Body (Context); 5680 5681 -- The optional body is within the body of the enclosing package 5682 5683 if Present (Body_Decl) then 5684 return 5685 Find_Body 5686 (Spec_Id => Spec_Id, 5687 From => First (Declarations (Body_Decl))); 5688 5689 -- Otherwise the enclosing package does not have a body. This may 5690 -- be the result of an error or a genuine lack of a body. 5691 5692 else 5693 return Empty; 5694 end if; 5695 5696 -- Otherwise the immediate context is a body. The optional body may 5697 -- be within the same list as the spec. 5698 5699 -- procedure Proc is 5700 -- generic 5701 -- package Pack is 5702 -- end Pack; 5703 5704 -- package body Pack is -- optional body 5705 -- ... 5706 -- end Pack; 5707 5708 else 5709 return 5710 Find_Body 5711 (Spec_Id => Spec_Id, 5712 From => Next (Spec_Decl)); 5713 end if; 5714 end Find_Corresponding_Body; 5715 5716 --------------- 5717 -- Find_Body -- 5718 --------------- 5719 5720 function Find_Body 5721 (Spec_Id : Entity_Id; 5722 From : Node_Id) return Node_Id 5723 is 5724 Spec_Nam : constant Name_Id := Chars (Spec_Id); 5725 Item : Node_Id; 5726 Lib_Unit : Node_Id; 5727 5728 begin 5729 Item := From; 5730 while Present (Item) loop 5731 5732 -- The current item denotes the optional body 5733 5734 if Nkind (Item) = N_Package_Body 5735 and then Chars (Defining_Entity (Item)) = Spec_Nam 5736 then 5737 return Item; 5738 5739 -- The current item denotes a stub, the optional body may be in 5740 -- the subunit. 5741 5742 elsif Nkind (Item) = N_Package_Body_Stub 5743 and then Chars (Defining_Entity (Item)) = Spec_Nam 5744 then 5745 Lib_Unit := Library_Unit (Item); 5746 5747 -- The corresponding subunit was previously loaded 5748 5749 if Present (Lib_Unit) then 5750 return Lib_Unit; 5751 5752 -- Otherwise attempt to load the corresponding subunit 5753 5754 else 5755 return Load_Package_Body (Get_Unit_Name (Item)); 5756 end if; 5757 end if; 5758 5759 Next (Item); 5760 end loop; 5761 5762 return Empty; 5763 end Find_Body; 5764 5765 ----------------------- 5766 -- Load_Package_Body -- 5767 ----------------------- 5768 5769 function Load_Package_Body (Unit_Nam : Unit_Name_Type) return Node_Id is 5770 Body_Decl : Node_Id; 5771 Unit_Num : Unit_Number_Type; 5772 5773 begin 5774 -- The load is performed only when the compilation will generate code 5775 5776 if Operating_Mode = Generate_Code then 5777 Unit_Num := 5778 Load_Unit 5779 (Load_Name => Unit_Nam, 5780 Required => False, 5781 Subunit => False, 5782 Error_Node => Pack_Decl); 5783 5784 -- The load failed most likely because the physical file is 5785 -- missing. 5786 5787 if Unit_Num = No_Unit then 5788 return Empty; 5789 5790 -- Otherwise the load was successful, return the body of the unit 5791 5792 else 5793 Body_Decl := Unit (Cunit (Unit_Num)); 5794 5795 -- If the unit is a subunit with an available proper body, 5796 -- return the proper body. 5797 5798 if Nkind (Body_Decl) = N_Subunit 5799 and then Present (Proper_Body (Body_Decl)) 5800 then 5801 Body_Decl := Proper_Body (Body_Decl); 5802 end if; 5803 5804 return Body_Decl; 5805 end if; 5806 end if; 5807 5808 return Empty; 5809 end Load_Package_Body; 5810 5811 -- Local variables 5812 5813 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl); 5814 5815 -- Start of processing for Has_Body 5816 5817 begin 5818 -- The body is available 5819 5820 if Present (Corresponding_Body (Pack_Decl)) then 5821 return True; 5822 5823 -- The body is required if the package spec contains a construct which 5824 -- requires a completion in a body. 5825 5826 elsif Unit_Requires_Body (Pack_Id) then 5827 return True; 5828 5829 -- The body may be optional 5830 5831 else 5832 return Present (Find_Corresponding_Body (Pack_Id)); 5833 end if; 5834 end Has_Body; 5835 5836 --------------------------- 5837 -- Has_Prior_Elaboration -- 5838 --------------------------- 5839 5840 function Has_Prior_Elaboration 5841 (Unit_Id : Entity_Id; 5842 Context_OK : Boolean := False; 5843 Elab_Body_OK : Boolean := False; 5844 Same_Unit_OK : Boolean := False) return Boolean 5845 is 5846 Main_Id : constant Entity_Id := Cunit_Entity (Main_Unit); 5847 5848 begin 5849 -- A preelaborated unit is always elaborated prior to the main unit 5850 5851 if Is_Preelaborated_Unit (Unit_Id) then 5852 return True; 5853 5854 -- An internal unit is always elaborated prior to a non-internal main 5855 -- unit. 5856 5857 elsif In_Internal_Unit (Unit_Id) 5858 and then not In_Internal_Unit (Main_Id) 5859 then 5860 return True; 5861 5862 -- A unit has prior elaboration if it appears within the context of the 5863 -- main unit. Consider this case only when requested by the caller. 5864 5865 elsif Context_OK 5866 and then Elaboration_Status (Unit_Id) /= No_Elaboration_Attributes 5867 then 5868 return True; 5869 5870 -- A unit whose body is elaborated together with its spec has prior 5871 -- elaboration except with respect to itself. Consider this case only 5872 -- when requested by the caller. 5873 5874 elsif Elab_Body_OK 5875 and then Has_Pragma_Elaborate_Body (Unit_Id) 5876 and then not Is_Same_Unit (Unit_Id, Main_Id) 5877 then 5878 return True; 5879 5880 -- A unit has no prior elaboration with respect to itself, but does not 5881 -- require any means of ensuring its own elaboration either. Treat this 5882 -- case as valid prior elaboration only when requested by the caller. 5883 5884 elsif Same_Unit_OK and then Is_Same_Unit (Unit_Id, Main_Id) then 5885 return True; 5886 end if; 5887 5888 return False; 5889 end Has_Prior_Elaboration; 5890 5891 -------------------------- 5892 -- In_External_Instance -- 5893 -------------------------- 5894 5895 function In_External_Instance 5896 (N : Node_Id; 5897 Target_Decl : Node_Id) return Boolean 5898 is 5899 Dummy : Node_Id; 5900 Inst_Body : Node_Id; 5901 Inst_Decl : Node_Id; 5902 5903 begin 5904 -- Performance note: parent traversal 5905 5906 Inst_Decl := Find_Enclosing_Instance (Target_Decl); 5907 5908 -- The target declaration appears within an instance spec. Visibility is 5909 -- ignored because internally generated primitives for private types may 5910 -- reside in the private declarations and still be invoked from outside. 5911 5912 if Present (Inst_Decl) 5913 and then Nkind (Inst_Decl) = N_Package_Declaration 5914 then 5915 -- The scenario comes from the main unit and the instance does not 5916 5917 if In_Extended_Main_Code_Unit (N) 5918 and then not In_Extended_Main_Code_Unit (Inst_Decl) 5919 then 5920 return True; 5921 5922 -- Otherwise the scenario must not appear within the instance spec or 5923 -- body. 5924 5925 else 5926 Extract_Instance_Attributes 5927 (Exp_Inst => Inst_Decl, 5928 Inst_Body => Inst_Body, 5929 Inst_Decl => Dummy); 5930 5931 -- Performance note: parent traversal 5932 5933 return not In_Subtree 5934 (N => N, 5935 Root1 => Inst_Decl, 5936 Root2 => Inst_Body); 5937 end if; 5938 end if; 5939 5940 return False; 5941 end In_External_Instance; 5942 5943 --------------------- 5944 -- In_Main_Context -- 5945 --------------------- 5946 5947 function In_Main_Context (N : Node_Id) return Boolean is 5948 begin 5949 -- Scenarios outside the main unit are not considered because the ALI 5950 -- information supplied to binde is for the main unit only. 5951 5952 if not In_Extended_Main_Code_Unit (N) then 5953 return False; 5954 5955 -- Scenarios within internal units are not considered unless switch 5956 -- -gnatdE (elaboration checks on predefined units) is in effect. 5957 5958 elsif not Debug_Flag_EE and then In_Internal_Unit (N) then 5959 return False; 5960 end if; 5961 5962 return True; 5963 end In_Main_Context; 5964 5965 --------------------- 5966 -- In_Same_Context -- 5967 --------------------- 5968 5969 function In_Same_Context 5970 (N1 : Node_Id; 5971 N2 : Node_Id; 5972 Nested_OK : Boolean := False) return Boolean 5973 is 5974 function Find_Enclosing_Context (N : Node_Id) return Node_Id; 5975 -- Return the nearest enclosing non-library-level or compilation unit 5976 -- node which which encapsulates arbitrary node N. Return Empty is no 5977 -- such context is available. 5978 5979 function In_Nested_Context 5980 (Outer : Node_Id; 5981 Inner : Node_Id) return Boolean; 5982 -- Determine whether arbitrary node Outer encapsulates arbitrary node 5983 -- Inner. 5984 5985 ---------------------------- 5986 -- Find_Enclosing_Context -- 5987 ---------------------------- 5988 5989 function Find_Enclosing_Context (N : Node_Id) return Node_Id is 5990 Context : Node_Id; 5991 Par : Node_Id; 5992 5993 begin 5994 Par := Parent (N); 5995 while Present (Par) loop 5996 5997 -- A traversal from a subunit continues via the corresponding stub 5998 5999 if Nkind (Par) = N_Subunit then 6000 Par := Corresponding_Stub (Par); 6001 6002 -- Stop the traversal when the nearest enclosing non-library-level 6003 -- encapsulator has been reached. 6004 6005 elsif Is_Non_Library_Level_Encapsulator (Par) then 6006 Context := Parent (Par); 6007 6008 -- The sole exception is when the encapsulator is the unit of 6009 -- compilation because this case requires special processing 6010 -- (see below). 6011 6012 if Present (Context) 6013 and then Nkind (Context) = N_Compilation_Unit 6014 then 6015 null; 6016 6017 else 6018 return Par; 6019 end if; 6020 6021 -- Reaching a compilation unit node without hitting a non-library- 6022 -- level encapsulator indicates that N is at the library level in 6023 -- which case the compilation unit is the context. 6024 6025 elsif Nkind (Par) = N_Compilation_Unit then 6026 return Par; 6027 end if; 6028 6029 Par := Parent (Par); 6030 end loop; 6031 6032 return Empty; 6033 end Find_Enclosing_Context; 6034 6035 ----------------------- 6036 -- In_Nested_Context -- 6037 ----------------------- 6038 6039 function In_Nested_Context 6040 (Outer : Node_Id; 6041 Inner : Node_Id) return Boolean 6042 is 6043 Par : Node_Id; 6044 6045 begin 6046 Par := Inner; 6047 while Present (Par) loop 6048 6049 -- A traversal from a subunit continues via the corresponding stub 6050 6051 if Nkind (Par) = N_Subunit then 6052 Par := Corresponding_Stub (Par); 6053 6054 elsif Par = Outer then 6055 return True; 6056 end if; 6057 6058 Par := Parent (Par); 6059 end loop; 6060 6061 return False; 6062 end In_Nested_Context; 6063 6064 -- Local variables 6065 6066 Context_1 : constant Node_Id := Find_Enclosing_Context (N1); 6067 Context_2 : constant Node_Id := Find_Enclosing_Context (N2); 6068 6069 -- Start of processing for In_Same_Context 6070 6071 begin 6072 -- Both nodes appear within the same context 6073 6074 if Context_1 = Context_2 then 6075 return True; 6076 6077 -- Both nodes appear in compilation units. Determine whether one unit 6078 -- is the body of the other. 6079 6080 elsif Nkind (Context_1) = N_Compilation_Unit 6081 and then Nkind (Context_2) = N_Compilation_Unit 6082 then 6083 return 6084 Is_Same_Unit 6085 (Unit_1 => Defining_Entity (Unit (Context_1)), 6086 Unit_2 => Defining_Entity (Unit (Context_2))); 6087 6088 -- The context of N1 encloses the context of N2 6089 6090 elsif Nested_OK and then In_Nested_Context (Context_1, Context_2) then 6091 return True; 6092 end if; 6093 6094 return False; 6095 end In_Same_Context; 6096 6097 ---------------- 6098 -- Initialize -- 6099 ---------------- 6100 6101 procedure Initialize is 6102 begin 6103 -- Set the soft link which enables Atree.Rewrite to update a top-level 6104 -- scenario each time it is transformed into another node. 6105 6106 Set_Rewriting_Proc (Update_Elaboration_Scenario'Access); 6107 end Initialize; 6108 6109 --------------- 6110 -- Info_Call -- 6111 --------------- 6112 6113 procedure Info_Call 6114 (Call : Node_Id; 6115 Target_Id : Entity_Id; 6116 Info_Msg : Boolean; 6117 In_SPARK : Boolean) 6118 is 6119 procedure Info_Accept_Alternative; 6120 pragma Inline (Info_Accept_Alternative); 6121 -- Output information concerning an accept alternative 6122 6123 procedure Info_Simple_Call; 6124 pragma Inline (Info_Simple_Call); 6125 -- Output information concerning the call 6126 6127 procedure Info_Type_Actions (Action : String); 6128 pragma Inline (Info_Type_Actions); 6129 -- Output information concerning action Action of a type 6130 6131 procedure Info_Verification_Call 6132 (Pred : String; 6133 Id : Entity_Id; 6134 Id_Kind : String); 6135 pragma Inline (Info_Verification_Call); 6136 -- Output information concerning the verification of predicate Pred 6137 -- applied to related entity Id with kind Id_Kind. 6138 6139 ----------------------------- 6140 -- Info_Accept_Alternative -- 6141 ----------------------------- 6142 6143 procedure Info_Accept_Alternative is 6144 Entry_Id : constant Entity_Id := Receiving_Entry (Target_Id); 6145 6146 begin 6147 pragma Assert (Present (Entry_Id)); 6148 6149 Elab_Msg_NE 6150 (Msg => "accept for entry & during elaboration", 6151 N => Call, 6152 Id => Entry_Id, 6153 Info_Msg => Info_Msg, 6154 In_SPARK => In_SPARK); 6155 end Info_Accept_Alternative; 6156 6157 ---------------------- 6158 -- Info_Simple_Call -- 6159 ---------------------- 6160 6161 procedure Info_Simple_Call is 6162 begin 6163 Elab_Msg_NE 6164 (Msg => "call to & during elaboration", 6165 N => Call, 6166 Id => Target_Id, 6167 Info_Msg => Info_Msg, 6168 In_SPARK => In_SPARK); 6169 end Info_Simple_Call; 6170 6171 ----------------------- 6172 -- Info_Type_Actions -- 6173 ----------------------- 6174 6175 procedure Info_Type_Actions (Action : String) is 6176 Typ : constant Entity_Id := First_Formal_Type (Target_Id); 6177 6178 begin 6179 pragma Assert (Present (Typ)); 6180 6181 Elab_Msg_NE 6182 (Msg => Action & " actions for type & during elaboration", 6183 N => Call, 6184 Id => Typ, 6185 Info_Msg => Info_Msg, 6186 In_SPARK => In_SPARK); 6187 end Info_Type_Actions; 6188 6189 ---------------------------- 6190 -- Info_Verification_Call -- 6191 ---------------------------- 6192 6193 procedure Info_Verification_Call 6194 (Pred : String; 6195 Id : Entity_Id; 6196 Id_Kind : String) 6197 is 6198 begin 6199 pragma Assert (Present (Id)); 6200 6201 Elab_Msg_NE 6202 (Msg => 6203 "verification of " & Pred & " of " & Id_Kind & " & during " 6204 & "elaboration", 6205 N => Call, 6206 Id => Id, 6207 Info_Msg => Info_Msg, 6208 In_SPARK => In_SPARK); 6209 end Info_Verification_Call; 6210 6211 -- Start of processing for Info_Call 6212 6213 begin 6214 -- Do not output anything for targets defined in internal units because 6215 -- this creates noise. 6216 6217 if not In_Internal_Unit (Target_Id) then 6218 6219 -- Accept alternative 6220 6221 if Is_Accept_Alternative_Proc (Target_Id) then 6222 Info_Accept_Alternative; 6223 6224 -- Adjustment 6225 6226 elsif Is_TSS (Target_Id, TSS_Deep_Adjust) then 6227 Info_Type_Actions ("adjustment"); 6228 6229 -- Default_Initial_Condition 6230 6231 elsif Is_Default_Initial_Condition_Proc (Target_Id) then 6232 Info_Verification_Call 6233 (Pred => "Default_Initial_Condition", 6234 Id => First_Formal_Type (Target_Id), 6235 Id_Kind => "type"); 6236 6237 -- Entries 6238 6239 elsif Is_Protected_Entry (Target_Id) then 6240 Info_Simple_Call; 6241 6242 -- Task entry calls are never processed because the entry being 6243 -- invoked does not have a corresponding "body", it has a select. 6244 6245 elsif Is_Task_Entry (Target_Id) then 6246 null; 6247 6248 -- Finalization 6249 6250 elsif Is_TSS (Target_Id, TSS_Deep_Finalize) then 6251 Info_Type_Actions ("finalization"); 6252 6253 -- Calls to _Finalizer procedures must not appear in the output 6254 -- because this creates confusing noise. 6255 6256 elsif Is_Finalizer_Proc (Target_Id) then 6257 null; 6258 6259 -- Initial_Condition 6260 6261 elsif Is_Initial_Condition_Proc (Target_Id) then 6262 Info_Verification_Call 6263 (Pred => "Initial_Condition", 6264 Id => Find_Enclosing_Scope (Call), 6265 Id_Kind => "package"); 6266 6267 -- Initialization 6268 6269 elsif Is_Init_Proc (Target_Id) 6270 or else Is_TSS (Target_Id, TSS_Deep_Initialize) 6271 then 6272 Info_Type_Actions ("initialization"); 6273 6274 -- Invariant 6275 6276 elsif Is_Invariant_Proc (Target_Id) then 6277 Info_Verification_Call 6278 (Pred => "invariants", 6279 Id => First_Formal_Type (Target_Id), 6280 Id_Kind => "type"); 6281 6282 -- Partial invariant calls must not appear in the output because this 6283 -- creates confusing noise. 6284 6285 elsif Is_Partial_Invariant_Proc (Target_Id) then 6286 null; 6287 6288 -- _Postconditions 6289 6290 elsif Is_Postconditions_Proc (Target_Id) then 6291 Info_Verification_Call 6292 (Pred => "postconditions", 6293 Id => Find_Enclosing_Scope (Call), 6294 Id_Kind => "subprogram"); 6295 6296 -- Subprograms must come last because some of the previous cases fall 6297 -- under this category. 6298 6299 elsif Ekind (Target_Id) = E_Function then 6300 Info_Simple_Call; 6301 6302 elsif Ekind (Target_Id) = E_Procedure then 6303 Info_Simple_Call; 6304 6305 else 6306 pragma Assert (False); 6307 null; 6308 end if; 6309 end if; 6310 end Info_Call; 6311 6312 ------------------------ 6313 -- Info_Instantiation -- 6314 ------------------------ 6315 6316 procedure Info_Instantiation 6317 (Inst : Node_Id; 6318 Gen_Id : Entity_Id; 6319 Info_Msg : Boolean; 6320 In_SPARK : Boolean) 6321 is 6322 begin 6323 Elab_Msg_NE 6324 (Msg => "instantiation of & during elaboration", 6325 N => Inst, 6326 Id => Gen_Id, 6327 Info_Msg => Info_Msg, 6328 In_SPARK => In_SPARK); 6329 end Info_Instantiation; 6330 6331 ----------------------------- 6332 -- Info_Variable_Reference -- 6333 ----------------------------- 6334 6335 procedure Info_Variable_Reference 6336 (Ref : Node_Id; 6337 Var_Id : Entity_Id; 6338 Info_Msg : Boolean; 6339 In_SPARK : Boolean) 6340 is 6341 begin 6342 if Is_Read (Ref) then 6343 Elab_Msg_NE 6344 (Msg => "read of variable & during elaboration", 6345 N => Ref, 6346 Id => Var_Id, 6347 Info_Msg => Info_Msg, 6348 In_SPARK => In_SPARK); 6349 end if; 6350 end Info_Variable_Reference; 6351 6352 -------------------- 6353 -- Insertion_Node -- 6354 -------------------- 6355 6356 function Insertion_Node (N : Node_Id; Ins_Nod : Node_Id) return Node_Id is 6357 begin 6358 -- When the scenario denotes an instantiation, the proper insertion node 6359 -- is the instance spec. This ensures that the generic actuals will not 6360 -- be evaluated prior to a potential ABE. 6361 6362 if Nkind (N) in N_Generic_Instantiation 6363 and then Present (Instance_Spec (N)) 6364 then 6365 return Instance_Spec (N); 6366 6367 -- Otherwise the proper insertion node is the candidate insertion node 6368 6369 else 6370 return Ins_Nod; 6371 end if; 6372 end Insertion_Node; 6373 6374 ----------------------- 6375 -- Install_ABE_Check -- 6376 ----------------------- 6377 6378 procedure Install_ABE_Check 6379 (N : Node_Id; 6380 Id : Entity_Id; 6381 Ins_Nod : Node_Id) 6382 is 6383 Check_Ins_Nod : constant Node_Id := Insertion_Node (N, Ins_Nod); 6384 -- Insert the check prior to this node 6385 6386 Loc : constant Source_Ptr := Sloc (N); 6387 Spec_Id : constant Entity_Id := Unique_Entity (Id); 6388 Unit_Id : constant Entity_Id := Find_Top_Unit (Id); 6389 Scop_Id : Entity_Id; 6390 6391 begin 6392 -- Nothing to do when compiling for GNATprove because raise statements 6393 -- are not supported. 6394 6395 if GNATprove_Mode then 6396 return; 6397 6398 -- Nothing to do when the compilation will not produce an executable 6399 6400 elsif Serious_Errors_Detected > 0 then 6401 return; 6402 6403 -- Nothing to do for a compilation unit because there is no executable 6404 -- environment at that level. 6405 6406 elsif Nkind (Parent (Check_Ins_Nod)) = N_Compilation_Unit then 6407 return; 6408 6409 -- Nothing to do when the unit is elaborated prior to the main unit. 6410 -- This check must also consider the following cases: 6411 6412 -- * Id's unit appears in the context of the main unit 6413 6414 -- * Id's unit is subject to pragma Elaborate_Body. An ABE check MUST 6415 -- NOT be generated because Id's unit is always elaborated prior to 6416 -- the main unit. 6417 6418 -- * Id's unit is the main unit. An ABE check MUST be generated in this 6419 -- case because a conditional ABE may be raised depending on the flow 6420 -- of execution within the main unit (flag Same_Unit_OK is False). 6421 6422 elsif Has_Prior_Elaboration 6423 (Unit_Id => Unit_Id, 6424 Context_OK => True, 6425 Elab_Body_OK => True) 6426 then 6427 return; 6428 end if; 6429 6430 -- Prevent multiple scenarios from installing the same ABE check 6431 6432 Set_Is_Elaboration_Checks_OK_Node (N, False); 6433 6434 -- Install the nearest enclosing scope of the scenario as there must be 6435 -- something on the scope stack. 6436 6437 -- Performance note: parent traversal 6438 6439 Scop_Id := Find_Enclosing_Scope (Check_Ins_Nod); 6440 pragma Assert (Present (Scop_Id)); 6441 6442 Push_Scope (Scop_Id); 6443 6444 -- Generate: 6445 -- if not Spec_Id'Elaborated then 6446 -- raise Program_Error with "access before elaboration"; 6447 -- end if; 6448 6449 Insert_Action (Check_Ins_Nod, 6450 Make_Raise_Program_Error (Loc, 6451 Condition => 6452 Make_Op_Not (Loc, 6453 Right_Opnd => 6454 Make_Attribute_Reference (Loc, 6455 Prefix => New_Occurrence_Of (Spec_Id, Loc), 6456 Attribute_Name => Name_Elaborated)), 6457 Reason => PE_Access_Before_Elaboration)); 6458 6459 Pop_Scope; 6460 end Install_ABE_Check; 6461 6462 ----------------------- 6463 -- Install_ABE_Check -- 6464 ----------------------- 6465 6466 procedure Install_ABE_Check 6467 (N : Node_Id; 6468 Target_Id : Entity_Id; 6469 Target_Decl : Node_Id; 6470 Target_Body : Node_Id; 6471 Ins_Nod : Node_Id) 6472 is 6473 procedure Build_Elaboration_Entity; 6474 pragma Inline (Build_Elaboration_Entity); 6475 -- Create a new elaboration flag for Target_Id, insert it prior to 6476 -- Target_Decl, and set it after Body_Decl. 6477 6478 ------------------------------ 6479 -- Build_Elaboration_Entity -- 6480 ------------------------------ 6481 6482 procedure Build_Elaboration_Entity is 6483 Loc : constant Source_Ptr := Sloc (Target_Id); 6484 Flag_Id : Entity_Id; 6485 6486 begin 6487 -- Create the declaration of the elaboration flag. The name carries a 6488 -- unique counter in case of name overloading. 6489 6490 Flag_Id := 6491 Make_Defining_Identifier (Loc, 6492 Chars => New_External_Name (Chars (Target_Id), 'E', -1)); 6493 6494 Set_Elaboration_Entity (Target_Id, Flag_Id); 6495 Set_Elaboration_Entity_Required (Target_Id); 6496 6497 Push_Scope (Scope (Target_Id)); 6498 6499 -- Generate: 6500 -- Enn : Short_Integer := 0; 6501 6502 Insert_Action (Target_Decl, 6503 Make_Object_Declaration (Loc, 6504 Defining_Identifier => Flag_Id, 6505 Object_Definition => 6506 New_Occurrence_Of (Standard_Short_Integer, Loc), 6507 Expression => Make_Integer_Literal (Loc, Uint_0))); 6508 6509 -- Generate: 6510 -- Enn := 1; 6511 6512 Set_Elaboration_Flag (Target_Body, Target_Id); 6513 6514 Pop_Scope; 6515 end Build_Elaboration_Entity; 6516 6517 -- Local variables 6518 6519 Target_Unit_Id : constant Entity_Id := Find_Top_Unit (Target_Id); 6520 6521 -- Start for processing for Install_ABE_Check 6522 6523 begin 6524 -- Nothing to do when compiling for GNATprove because raise statements 6525 -- are not supported. 6526 6527 if GNATprove_Mode then 6528 return; 6529 6530 -- Nothing to do when the compilation will not produce an executable 6531 6532 elsif Serious_Errors_Detected > 0 then 6533 return; 6534 6535 -- Nothing to do when the target is a protected subprogram because the 6536 -- check is associated with the protected body subprogram. 6537 6538 elsif Is_Protected_Subp (Target_Id) then 6539 return; 6540 6541 -- Nothing to do when the target is elaborated prior to the main unit. 6542 -- This check must also consider the following cases: 6543 6544 -- * The unit of the target appears in the context of the main unit 6545 6546 -- * The unit of the target is subject to pragma Elaborate_Body. An ABE 6547 -- check MUST NOT be generated because the unit is always elaborated 6548 -- prior to the main unit. 6549 6550 -- * The unit of the target is the main unit. An ABE check MUST be added 6551 -- in this case because a conditional ABE may be raised depending on 6552 -- the flow of execution within the main unit (flag Same_Unit_OK is 6553 -- False). 6554 6555 elsif Has_Prior_Elaboration 6556 (Unit_Id => Target_Unit_Id, 6557 Context_OK => True, 6558 Elab_Body_OK => True) 6559 then 6560 return; 6561 6562 -- Create an elaboration flag for the target when it does not have one 6563 6564 elsif No (Elaboration_Entity (Target_Id)) then 6565 Build_Elaboration_Entity; 6566 end if; 6567 6568 Install_ABE_Check 6569 (N => N, 6570 Ins_Nod => Ins_Nod, 6571 Id => Target_Id); 6572 end Install_ABE_Check; 6573 6574 ------------------------- 6575 -- Install_ABE_Failure -- 6576 ------------------------- 6577 6578 procedure Install_ABE_Failure (N : Node_Id; Ins_Nod : Node_Id) is 6579 Fail_Ins_Nod : constant Node_Id := Insertion_Node (N, Ins_Nod); 6580 -- Insert the failure prior to this node 6581 6582 Loc : constant Source_Ptr := Sloc (N); 6583 Scop_Id : Entity_Id; 6584 6585 begin 6586 -- Nothing to do when compiling for GNATprove because raise statements 6587 -- are not supported. 6588 6589 if GNATprove_Mode then 6590 return; 6591 6592 -- Nothing to do when the compilation will not produce an executable 6593 6594 elsif Serious_Errors_Detected > 0 then 6595 return; 6596 6597 -- Do not install an ABE check for a compilation unit because there is 6598 -- no executable environment at that level. 6599 6600 elsif Nkind (Parent (Fail_Ins_Nod)) = N_Compilation_Unit then 6601 return; 6602 end if; 6603 6604 -- Prevent multiple scenarios from installing the same ABE failure 6605 6606 Set_Is_Elaboration_Checks_OK_Node (N, False); 6607 6608 -- Install the nearest enclosing scope of the scenario as there must be 6609 -- something on the scope stack. 6610 6611 -- Performance note: parent traversal 6612 6613 Scop_Id := Find_Enclosing_Scope (Fail_Ins_Nod); 6614 pragma Assert (Present (Scop_Id)); 6615 6616 Push_Scope (Scop_Id); 6617 6618 -- Generate: 6619 -- raise Program_Error with "access before elaboration"; 6620 6621 Insert_Action (Fail_Ins_Nod, 6622 Make_Raise_Program_Error (Loc, 6623 Reason => PE_Access_Before_Elaboration)); 6624 6625 Pop_Scope; 6626 end Install_ABE_Failure; 6627 6628 -------------------------------- 6629 -- Is_Accept_Alternative_Proc -- 6630 -------------------------------- 6631 6632 function Is_Accept_Alternative_Proc (Id : Entity_Id) return Boolean is 6633 begin 6634 -- To qualify, the entity must denote a procedure with a receiving entry 6635 6636 return Ekind (Id) = E_Procedure and then Present (Receiving_Entry (Id)); 6637 end Is_Accept_Alternative_Proc; 6638 6639 ------------------------ 6640 -- Is_Activation_Proc -- 6641 ------------------------ 6642 6643 function Is_Activation_Proc (Id : Entity_Id) return Boolean is 6644 begin 6645 -- To qualify, the entity must denote one of the runtime procedures in 6646 -- charge of task activation. 6647 6648 if Ekind (Id) = E_Procedure then 6649 if Restricted_Profile then 6650 return Is_RTE (Id, RE_Activate_Restricted_Tasks); 6651 else 6652 return Is_RTE (Id, RE_Activate_Tasks); 6653 end if; 6654 end if; 6655 6656 return False; 6657 end Is_Activation_Proc; 6658 6659 ---------------------------- 6660 -- Is_Ada_Semantic_Target -- 6661 ---------------------------- 6662 6663 function Is_Ada_Semantic_Target (Id : Entity_Id) return Boolean is 6664 begin 6665 return 6666 Is_Activation_Proc (Id) 6667 or else Is_Controlled_Proc (Id, Name_Adjust) 6668 or else Is_Controlled_Proc (Id, Name_Finalize) 6669 or else Is_Controlled_Proc (Id, Name_Initialize) 6670 or else Is_Init_Proc (Id) 6671 or else Is_Invariant_Proc (Id) 6672 or else Is_Protected_Entry (Id) 6673 or else Is_Protected_Subp (Id) 6674 or else Is_Protected_Body_Subp (Id) 6675 or else Is_Task_Entry (Id); 6676 end Is_Ada_Semantic_Target; 6677 6678 -------------------------------- 6679 -- Is_Assertion_Pragma_Target -- 6680 -------------------------------- 6681 6682 function Is_Assertion_Pragma_Target (Id : Entity_Id) return Boolean is 6683 begin 6684 return 6685 Is_Default_Initial_Condition_Proc (Id) 6686 or else Is_Initial_Condition_Proc (Id) 6687 or else Is_Invariant_Proc (Id) 6688 or else Is_Partial_Invariant_Proc (Id) 6689 or else Is_Postconditions_Proc (Id); 6690 end Is_Assertion_Pragma_Target; 6691 6692 ---------------------------- 6693 -- Is_Bodiless_Subprogram -- 6694 ---------------------------- 6695 6696 function Is_Bodiless_Subprogram (Subp_Id : Entity_Id) return Boolean is 6697 begin 6698 -- An abstract subprogram does not have a body 6699 6700 if Ekind_In (Subp_Id, E_Function, 6701 E_Operator, 6702 E_Procedure) 6703 and then Is_Abstract_Subprogram (Subp_Id) 6704 then 6705 return True; 6706 6707 -- A formal subprogram does not have a body 6708 6709 elsif Is_Formal_Subprogram (Subp_Id) then 6710 return True; 6711 6712 -- An imported subprogram may have a body, however it is not known at 6713 -- compile or bind time where the body resides and whether it will be 6714 -- elaborated on time. 6715 6716 elsif Is_Imported (Subp_Id) then 6717 return True; 6718 end if; 6719 6720 return False; 6721 end Is_Bodiless_Subprogram; 6722 6723 ------------------------ 6724 -- Is_Controlled_Proc -- 6725 ------------------------ 6726 6727 function Is_Controlled_Proc 6728 (Subp_Id : Entity_Id; 6729 Subp_Nam : Name_Id) return Boolean 6730 is 6731 Formal_Id : Entity_Id; 6732 6733 begin 6734 pragma Assert (Nam_In (Subp_Nam, Name_Adjust, 6735 Name_Finalize, 6736 Name_Initialize)); 6737 6738 -- To qualify, the subprogram must denote a source procedure with name 6739 -- Adjust, Finalize, or Initialize where the sole formal is controlled. 6740 6741 if Comes_From_Source (Subp_Id) 6742 and then Ekind (Subp_Id) = E_Procedure 6743 and then Chars (Subp_Id) = Subp_Nam 6744 then 6745 Formal_Id := First_Formal (Subp_Id); 6746 6747 return 6748 Present (Formal_Id) 6749 and then Is_Controlled (Etype (Formal_Id)) 6750 and then No (Next_Formal (Formal_Id)); 6751 end if; 6752 6753 return False; 6754 end Is_Controlled_Proc; 6755 6756 --------------------------------------- 6757 -- Is_Default_Initial_Condition_Proc -- 6758 --------------------------------------- 6759 6760 function Is_Default_Initial_Condition_Proc 6761 (Id : Entity_Id) return Boolean 6762 is 6763 begin 6764 -- To qualify, the entity must denote a Default_Initial_Condition 6765 -- procedure. 6766 6767 return Ekind (Id) = E_Procedure and then Is_DIC_Procedure (Id); 6768 end Is_Default_Initial_Condition_Proc; 6769 6770 ----------------------- 6771 -- Is_Finalizer_Proc -- 6772 ----------------------- 6773 6774 function Is_Finalizer_Proc (Id : Entity_Id) return Boolean is 6775 begin 6776 -- To qualify, the entity must denote a _Finalizer procedure 6777 6778 return Ekind (Id) = E_Procedure and then Chars (Id) = Name_uFinalizer; 6779 end Is_Finalizer_Proc; 6780 6781 ----------------------- 6782 -- Is_Guaranteed_ABE -- 6783 ----------------------- 6784 6785 function Is_Guaranteed_ABE 6786 (N : Node_Id; 6787 Target_Decl : Node_Id; 6788 Target_Body : Node_Id) return Boolean 6789 is 6790 begin 6791 -- Avoid cascaded errors if there were previous serious infractions. 6792 -- As a result the scenario will not be treated as a guaranteed ABE. 6793 -- This behaviour parallels that of the old ABE mechanism. 6794 6795 if Serious_Errors_Detected > 0 then 6796 return False; 6797 6798 -- The scenario and the target appear within the same context ignoring 6799 -- enclosing library levels. 6800 6801 -- Performance note: parent traversal 6802 6803 elsif In_Same_Context (N, Target_Decl) then 6804 6805 -- The target body has already been encountered. The scenario results 6806 -- in a guaranteed ABE if it appears prior to the body. 6807 6808 if Present (Target_Body) then 6809 return Earlier_In_Extended_Unit (N, Target_Body); 6810 6811 -- Otherwise the body has not been encountered yet. The scenario is 6812 -- a guaranteed ABE since the body will appear later. It is assumed 6813 -- that the caller has already checked whether the scenario is ABE- 6814 -- safe as optional bodies are not considered here. 6815 6816 else 6817 return True; 6818 end if; 6819 end if; 6820 6821 return False; 6822 end Is_Guaranteed_ABE; 6823 6824 ------------------------------- 6825 -- Is_Initial_Condition_Proc -- 6826 ------------------------------- 6827 6828 function Is_Initial_Condition_Proc (Id : Entity_Id) return Boolean is 6829 begin 6830 -- To qualify, the entity must denote an Initial_Condition procedure 6831 6832 return 6833 Ekind (Id) = E_Procedure and then Is_Initial_Condition_Procedure (Id); 6834 end Is_Initial_Condition_Proc; 6835 6836 -------------------- 6837 -- Is_Initialized -- 6838 -------------------- 6839 6840 function Is_Initialized (Obj_Decl : Node_Id) return Boolean is 6841 begin 6842 -- To qualify, the object declaration must have an expression 6843 6844 return 6845 Present (Expression (Obj_Decl)) or else Has_Init_Expression (Obj_Decl); 6846 end Is_Initialized; 6847 6848 ----------------------- 6849 -- Is_Invariant_Proc -- 6850 ----------------------- 6851 6852 function Is_Invariant_Proc (Id : Entity_Id) return Boolean is 6853 begin 6854 -- To qualify, the entity must denote the "full" invariant procedure 6855 6856 return Ekind (Id) = E_Procedure and then Is_Invariant_Procedure (Id); 6857 end Is_Invariant_Proc; 6858 6859 --------------------------------------- 6860 -- Is_Non_Library_Level_Encapsulator -- 6861 --------------------------------------- 6862 6863 function Is_Non_Library_Level_Encapsulator (N : Node_Id) return Boolean is 6864 begin 6865 case Nkind (N) is 6866 when N_Abstract_Subprogram_Declaration 6867 | N_Aspect_Specification 6868 | N_Component_Declaration 6869 | N_Entry_Body 6870 | N_Entry_Declaration 6871 | N_Expression_Function 6872 | N_Formal_Abstract_Subprogram_Declaration 6873 | N_Formal_Concrete_Subprogram_Declaration 6874 | N_Formal_Object_Declaration 6875 | N_Formal_Package_Declaration 6876 | N_Formal_Type_Declaration 6877 | N_Generic_Association 6878 | N_Implicit_Label_Declaration 6879 | N_Incomplete_Type_Declaration 6880 | N_Private_Extension_Declaration 6881 | N_Private_Type_Declaration 6882 | N_Protected_Body 6883 | N_Protected_Type_Declaration 6884 | N_Single_Protected_Declaration 6885 | N_Single_Task_Declaration 6886 | N_Subprogram_Body 6887 | N_Subprogram_Declaration 6888 | N_Task_Body 6889 | N_Task_Type_Declaration 6890 => 6891 return True; 6892 6893 when others => 6894 return Is_Generic_Declaration_Or_Body (N); 6895 end case; 6896 end Is_Non_Library_Level_Encapsulator; 6897 6898 ------------------------------- 6899 -- Is_Partial_Invariant_Proc -- 6900 ------------------------------- 6901 6902 function Is_Partial_Invariant_Proc (Id : Entity_Id) return Boolean is 6903 begin 6904 -- To qualify, the entity must denote the "partial" invariant procedure 6905 6906 return 6907 Ekind (Id) = E_Procedure and then Is_Partial_Invariant_Procedure (Id); 6908 end Is_Partial_Invariant_Proc; 6909 6910 ---------------------------- 6911 -- Is_Postconditions_Proc -- 6912 ---------------------------- 6913 6914 function Is_Postconditions_Proc (Id : Entity_Id) return Boolean is 6915 begin 6916 -- To qualify, the entity must denote a _Postconditions procedure 6917 6918 return 6919 Ekind (Id) = E_Procedure and then Chars (Id) = Name_uPostconditions; 6920 end Is_Postconditions_Proc; 6921 6922 --------------------------- 6923 -- Is_Preelaborated_Unit -- 6924 --------------------------- 6925 6926 function Is_Preelaborated_Unit (Id : Entity_Id) return Boolean is 6927 begin 6928 return 6929 Is_Preelaborated (Id) 6930 or else Is_Pure (Id) 6931 or else Is_Remote_Call_Interface (Id) 6932 or else Is_Remote_Types (Id) 6933 or else Is_Shared_Passive (Id); 6934 end Is_Preelaborated_Unit; 6935 6936 ------------------------ 6937 -- Is_Protected_Entry -- 6938 ------------------------ 6939 6940 function Is_Protected_Entry (Id : Entity_Id) return Boolean is 6941 begin 6942 -- To qualify, the entity must denote an entry defined in a protected 6943 -- type. 6944 6945 return 6946 Is_Entry (Id) 6947 and then Is_Protected_Type (Non_Private_View (Scope (Id))); 6948 end Is_Protected_Entry; 6949 6950 ----------------------- 6951 -- Is_Protected_Subp -- 6952 ----------------------- 6953 6954 function Is_Protected_Subp (Id : Entity_Id) return Boolean is 6955 begin 6956 -- To qualify, the entity must denote a subprogram defined within a 6957 -- protected type. 6958 6959 return 6960 Ekind_In (Id, E_Function, E_Procedure) 6961 and then Is_Protected_Type (Non_Private_View (Scope (Id))); 6962 end Is_Protected_Subp; 6963 6964 ---------------------------- 6965 -- Is_Protected_Body_Subp -- 6966 ---------------------------- 6967 6968 function Is_Protected_Body_Subp (Id : Entity_Id) return Boolean is 6969 begin 6970 -- To qualify, the entity must denote a subprogram with attribute 6971 -- Protected_Subprogram set. 6972 6973 return 6974 Ekind_In (Id, E_Function, E_Procedure) 6975 and then Present (Protected_Subprogram (Id)); 6976 end Is_Protected_Body_Subp; 6977 6978 -------------------------------- 6979 -- Is_Recorded_SPARK_Scenario -- 6980 -------------------------------- 6981 6982 function Is_Recorded_SPARK_Scenario (N : Node_Id) return Boolean is 6983 begin 6984 if Recorded_SPARK_Scenarios_In_Use then 6985 return Recorded_SPARK_Scenarios.Get (N); 6986 end if; 6987 6988 return Recorded_SPARK_Scenarios_No_Element; 6989 end Is_Recorded_SPARK_Scenario; 6990 6991 ------------------------------------ 6992 -- Is_Recorded_Top_Level_Scenario -- 6993 ------------------------------------ 6994 6995 function Is_Recorded_Top_Level_Scenario (N : Node_Id) return Boolean is 6996 begin 6997 if Recorded_Top_Level_Scenarios_In_Use then 6998 return Recorded_Top_Level_Scenarios.Get (N); 6999 end if; 7000 7001 return Recorded_Top_Level_Scenarios_No_Element; 7002 end Is_Recorded_Top_Level_Scenario; 7003 7004 ------------------------ 7005 -- Is_Safe_Activation -- 7006 ------------------------ 7007 7008 function Is_Safe_Activation 7009 (Call : Node_Id; 7010 Task_Decl : Node_Id) return Boolean 7011 is 7012 begin 7013 -- The activation of a task coming from an external instance cannot 7014 -- cause an ABE because the generic was already instantiated. Note 7015 -- that the instantiation itself may lead to an ABE. 7016 7017 return 7018 In_External_Instance 7019 (N => Call, 7020 Target_Decl => Task_Decl); 7021 end Is_Safe_Activation; 7022 7023 ------------------ 7024 -- Is_Safe_Call -- 7025 ------------------ 7026 7027 function Is_Safe_Call 7028 (Call : Node_Id; 7029 Target_Attrs : Target_Attributes) return Boolean 7030 is 7031 begin 7032 -- The target is either an abstract subprogram, formal subprogram, or 7033 -- imported, in which case it does not have a body at compile or bind 7034 -- time. Assume that the call is ABE-safe. 7035 7036 if Is_Bodiless_Subprogram (Target_Attrs.Spec_Id) then 7037 return True; 7038 7039 -- The target is an instantiation of a generic subprogram. The call 7040 -- cannot cause an ABE because the generic was already instantiated. 7041 -- Note that the instantiation itself may lead to an ABE. 7042 7043 elsif Is_Generic_Instance (Target_Attrs.Spec_Id) then 7044 return True; 7045 7046 -- The invocation of a target coming from an external instance cannot 7047 -- cause an ABE because the generic was already instantiated. Note that 7048 -- the instantiation itself may lead to an ABE. 7049 7050 elsif In_External_Instance 7051 (N => Call, 7052 Target_Decl => Target_Attrs.Spec_Decl) 7053 then 7054 return True; 7055 7056 -- The target is a subprogram body without a previous declaration. The 7057 -- call cannot cause an ABE because the body has already been seen. 7058 7059 elsif Nkind (Target_Attrs.Spec_Decl) = N_Subprogram_Body 7060 and then No (Corresponding_Spec (Target_Attrs.Spec_Decl)) 7061 then 7062 return True; 7063 7064 -- The target is a subprogram body stub without a prior declaration. 7065 -- The call cannot cause an ABE because the proper body substitutes 7066 -- the stub. 7067 7068 elsif Nkind (Target_Attrs.Spec_Decl) = N_Subprogram_Body_Stub 7069 and then No (Corresponding_Spec_Of_Stub (Target_Attrs.Spec_Decl)) 7070 then 7071 return True; 7072 7073 -- Subprogram bodies which wrap attribute references used as actuals 7074 -- in instantiations are always ABE-safe. These bodies are artifacts 7075 -- of expansion. 7076 7077 elsif Present (Target_Attrs.Body_Decl) 7078 and then Nkind (Target_Attrs.Body_Decl) = N_Subprogram_Body 7079 and then Was_Attribute_Reference (Target_Attrs.Body_Decl) 7080 then 7081 return True; 7082 end if; 7083 7084 return False; 7085 end Is_Safe_Call; 7086 7087 --------------------------- 7088 -- Is_Safe_Instantiation -- 7089 --------------------------- 7090 7091 function Is_Safe_Instantiation 7092 (Inst : Node_Id; 7093 Gen_Attrs : Target_Attributes) return Boolean 7094 is 7095 begin 7096 -- The generic is an intrinsic subprogram in which case it does not 7097 -- have a body at compile or bind time. Assume that the instantiation 7098 -- is ABE-safe. 7099 7100 if Is_Bodiless_Subprogram (Gen_Attrs.Spec_Id) then 7101 return True; 7102 7103 -- The instantiation of an external nested generic cannot cause an ABE 7104 -- if the outer generic was already instantiated. Note that the instance 7105 -- of the outer generic may lead to an ABE. 7106 7107 elsif In_External_Instance 7108 (N => Inst, 7109 Target_Decl => Gen_Attrs.Spec_Decl) 7110 then 7111 return True; 7112 7113 -- The generic is a package. The instantiation cannot cause an ABE when 7114 -- the package has no body. 7115 7116 elsif Ekind (Gen_Attrs.Spec_Id) = E_Generic_Package 7117 and then not Has_Body (Gen_Attrs.Spec_Decl) 7118 then 7119 return True; 7120 end if; 7121 7122 return False; 7123 end Is_Safe_Instantiation; 7124 7125 ------------------ 7126 -- Is_Same_Unit -- 7127 ------------------ 7128 7129 function Is_Same_Unit 7130 (Unit_1 : Entity_Id; 7131 Unit_2 : Entity_Id) return Boolean 7132 is 7133 function Is_Subunit (Unit_Id : Entity_Id) return Boolean; 7134 pragma Inline (Is_Subunit); 7135 -- Determine whether unit Unit_Id is a subunit 7136 7137 function Normalize_Unit (Unit_Id : Entity_Id) return Entity_Id; 7138 -- Strip a potential subunit chain ending with unit Unit_Id and return 7139 -- the corresponding spec. 7140 7141 ---------------- 7142 -- Is_Subunit -- 7143 ---------------- 7144 7145 function Is_Subunit (Unit_Id : Entity_Id) return Boolean is 7146 begin 7147 return Nkind (Parent (Unit_Declaration_Node (Unit_Id))) = N_Subunit; 7148 end Is_Subunit; 7149 7150 -------------------- 7151 -- Normalize_Unit -- 7152 -------------------- 7153 7154 function Normalize_Unit (Unit_Id : Entity_Id) return Entity_Id is 7155 Result : Entity_Id; 7156 7157 begin 7158 -- Eliminate a potential chain of subunits to reach to proper body 7159 7160 Result := Unit_Id; 7161 while Present (Result) 7162 and then Result /= Standard_Standard 7163 and then Is_Subunit (Result) 7164 loop 7165 Result := Scope (Result); 7166 end loop; 7167 7168 -- Obtain the entity of the corresponding spec (if any) 7169 7170 return Unique_Entity (Result); 7171 end Normalize_Unit; 7172 7173 -- Start of processing for Is_Same_Unit 7174 7175 begin 7176 return Normalize_Unit (Unit_1) = Normalize_Unit (Unit_2); 7177 end Is_Same_Unit; 7178 7179 ----------------- 7180 -- Is_Scenario -- 7181 ----------------- 7182 7183 function Is_Scenario (N : Node_Id) return Boolean is 7184 begin 7185 case Nkind (N) is 7186 when N_Assignment_Statement 7187 | N_Attribute_Reference 7188 | N_Call_Marker 7189 | N_Entry_Call_Statement 7190 | N_Expanded_Name 7191 | N_Function_Call 7192 | N_Function_Instantiation 7193 | N_Identifier 7194 | N_Package_Instantiation 7195 | N_Procedure_Call_Statement 7196 | N_Procedure_Instantiation 7197 | N_Requeue_Statement 7198 => 7199 return True; 7200 7201 when others => 7202 return False; 7203 end case; 7204 end Is_Scenario; 7205 7206 ------------------------------ 7207 -- Is_SPARK_Semantic_Target -- 7208 ------------------------------ 7209 7210 function Is_SPARK_Semantic_Target (Id : Entity_Id) return Boolean is 7211 begin 7212 return 7213 Is_Default_Initial_Condition_Proc (Id) 7214 or else Is_Initial_Condition_Proc (Id); 7215 end Is_SPARK_Semantic_Target; 7216 7217 ------------------------ 7218 -- Is_Suitable_Access -- 7219 ------------------------ 7220 7221 function Is_Suitable_Access (N : Node_Id) return Boolean is 7222 Nam : Name_Id; 7223 Pref : Node_Id; 7224 Subp_Id : Entity_Id; 7225 7226 begin 7227 -- This scenario is relevant only when the static model is in effect 7228 -- because it is graph-dependent and does not involve any run-time 7229 -- checks. Allowing it in the dynamic model would create confusing 7230 -- noise. 7231 7232 if not Static_Elaboration_Checks then 7233 return False; 7234 7235 -- Nothing to do when switch -gnatd.U (ignore 'Access) is in effect 7236 7237 elsif Debug_Flag_Dot_UU then 7238 return False; 7239 7240 -- Nothing to do when the scenario is not an attribute reference 7241 7242 elsif Nkind (N) /= N_Attribute_Reference then 7243 return False; 7244 7245 -- Nothing to do for internally-generated attributes because they are 7246 -- assumed to be ABE safe. 7247 7248 elsif not Comes_From_Source (N) then 7249 return False; 7250 end if; 7251 7252 Nam := Attribute_Name (N); 7253 Pref := Prefix (N); 7254 7255 -- Sanitize the prefix of the attribute 7256 7257 if not Is_Entity_Name (Pref) then 7258 return False; 7259 7260 elsif No (Entity (Pref)) then 7261 return False; 7262 end if; 7263 7264 Subp_Id := Entity (Pref); 7265 7266 if not Is_Subprogram_Or_Entry (Subp_Id) then 7267 return False; 7268 end if; 7269 7270 -- Traverse a possible chain of renamings to obtain the original entry 7271 -- or subprogram which the prefix may rename. 7272 7273 Subp_Id := Get_Renamed_Entity (Subp_Id); 7274 7275 -- To qualify, the attribute must meet the following prerequisites: 7276 7277 return 7278 7279 -- The prefix must denote a source entry, operator, or subprogram 7280 -- which is not imported. 7281 7282 Comes_From_Source (Subp_Id) 7283 and then Is_Subprogram_Or_Entry (Subp_Id) 7284 and then not Is_Bodiless_Subprogram (Subp_Id) 7285 7286 -- The attribute name must be one of the 'Access forms. Note that 7287 -- 'Unchecked_Access cannot apply to a subprogram. 7288 7289 and then Nam_In (Nam, Name_Access, Name_Unrestricted_Access); 7290 end Is_Suitable_Access; 7291 7292 ---------------------- 7293 -- Is_Suitable_Call -- 7294 ---------------------- 7295 7296 function Is_Suitable_Call (N : Node_Id) return Boolean is 7297 begin 7298 -- Entry and subprogram calls are intentionally ignored because they 7299 -- may undergo expansion depending on the compilation mode, previous 7300 -- errors, generic context, etc. Call markers play the role of calls 7301 -- and provide a uniform foundation for ABE processing. 7302 7303 return Nkind (N) = N_Call_Marker; 7304 end Is_Suitable_Call; 7305 7306 ------------------------------- 7307 -- Is_Suitable_Instantiation -- 7308 ------------------------------- 7309 7310 function Is_Suitable_Instantiation (N : Node_Id) return Boolean is 7311 Orig_N : constant Node_Id := Original_Node (N); 7312 -- Use the original node in case an instantiation library unit is 7313 -- rewritten as a package or subprogram. 7314 7315 begin 7316 -- To qualify, the instantiation must come from source 7317 7318 return 7319 Comes_From_Source (Orig_N) 7320 and then Nkind (Orig_N) in N_Generic_Instantiation; 7321 end Is_Suitable_Instantiation; 7322 7323 -------------------------- 7324 -- Is_Suitable_Scenario -- 7325 -------------------------- 7326 7327 function Is_Suitable_Scenario (N : Node_Id) return Boolean is 7328 begin 7329 -- NOTE: Derived types and pragma Refined_State are intentionally left 7330 -- out because they are not executable during elaboration. 7331 7332 return 7333 Is_Suitable_Access (N) 7334 or else Is_Suitable_Call (N) 7335 or else Is_Suitable_Instantiation (N) 7336 or else Is_Suitable_Variable_Assignment (N) 7337 or else Is_Suitable_Variable_Reference (N); 7338 end Is_Suitable_Scenario; 7339 7340 ------------------------------------ 7341 -- Is_Suitable_SPARK_Derived_Type -- 7342 ------------------------------------ 7343 7344 function Is_Suitable_SPARK_Derived_Type (N : Node_Id) return Boolean is 7345 Prag : Node_Id; 7346 Typ : Entity_Id; 7347 7348 begin 7349 -- To qualify, the type declaration must denote a derived tagged type 7350 -- with primitive operations, subject to pragma SPARK_Mode On. 7351 7352 if Nkind (N) = N_Full_Type_Declaration 7353 and then Nkind (Type_Definition (N)) = N_Derived_Type_Definition 7354 then 7355 Typ := Defining_Entity (N); 7356 Prag := SPARK_Pragma (Typ); 7357 7358 return 7359 Is_Tagged_Type (Typ) 7360 and then Has_Primitive_Operations (Typ) 7361 and then Present (Prag) 7362 and then Get_SPARK_Mode_From_Annotation (Prag) = On; 7363 end if; 7364 7365 return False; 7366 end Is_Suitable_SPARK_Derived_Type; 7367 7368 ------------------------------------- 7369 -- Is_Suitable_SPARK_Instantiation -- 7370 ------------------------------------- 7371 7372 function Is_Suitable_SPARK_Instantiation (N : Node_Id) return Boolean is 7373 Gen_Attrs : Target_Attributes; 7374 Gen_Id : Entity_Id; 7375 Inst : Node_Id; 7376 Inst_Attrs : Instantiation_Attributes; 7377 Inst_Id : Entity_Id; 7378 7379 begin 7380 -- To qualify, both the instantiation and the generic must be subject to 7381 -- SPARK_Mode On. 7382 7383 if Is_Suitable_Instantiation (N) then 7384 Extract_Instantiation_Attributes 7385 (Exp_Inst => N, 7386 Inst => Inst, 7387 Inst_Id => Inst_Id, 7388 Gen_Id => Gen_Id, 7389 Attrs => Inst_Attrs); 7390 7391 Extract_Target_Attributes (Gen_Id, Gen_Attrs); 7392 7393 return Inst_Attrs.SPARK_Mode_On and Gen_Attrs.SPARK_Mode_On; 7394 end if; 7395 7396 return False; 7397 end Is_Suitable_SPARK_Instantiation; 7398 7399 -------------------------------------------- 7400 -- Is_Suitable_SPARK_Refined_State_Pragma -- 7401 -------------------------------------------- 7402 7403 function Is_Suitable_SPARK_Refined_State_Pragma 7404 (N : Node_Id) return Boolean 7405 is 7406 begin 7407 -- To qualfy, the pragma must denote Refined_State 7408 7409 return 7410 Nkind (N) = N_Pragma 7411 and then Pragma_Name (N) = Name_Refined_State; 7412 end Is_Suitable_SPARK_Refined_State_Pragma; 7413 7414 ------------------------------------- 7415 -- Is_Suitable_Variable_Assignment -- 7416 ------------------------------------- 7417 7418 function Is_Suitable_Variable_Assignment (N : Node_Id) return Boolean is 7419 N_Unit : Node_Id; 7420 N_Unit_Id : Entity_Id; 7421 Nam : Node_Id; 7422 Var_Decl : Node_Id; 7423 Var_Id : Entity_Id; 7424 Var_Unit : Node_Id; 7425 Var_Unit_Id : Entity_Id; 7426 7427 begin 7428 -- This scenario is relevant only when the static model is in effect 7429 -- because it is graph-dependent and does not involve any run-time 7430 -- checks. Allowing it in the dynamic model would create confusing 7431 -- noise. 7432 7433 if not Static_Elaboration_Checks then 7434 return False; 7435 7436 -- Nothing to do when the scenario is not an assignment 7437 7438 elsif Nkind (N) /= N_Assignment_Statement then 7439 return False; 7440 7441 -- Nothing to do for internally-generated assignments because they are 7442 -- assumed to be ABE safe. 7443 7444 elsif not Comes_From_Source (N) then 7445 return False; 7446 7447 -- Assignments are ignored in GNAT mode on the assumption that they are 7448 -- ABE-safe. This behaviour parallels that of the old ABE mechanism. 7449 7450 elsif GNAT_Mode then 7451 return False; 7452 end if; 7453 7454 Nam := Extract_Assignment_Name (N); 7455 7456 -- Sanitize the left hand side of the assignment 7457 7458 if not Is_Entity_Name (Nam) then 7459 return False; 7460 7461 elsif No (Entity (Nam)) then 7462 return False; 7463 end if; 7464 7465 Var_Id := Entity (Nam); 7466 7467 -- Sanitize the variable 7468 7469 if Var_Id = Any_Id then 7470 return False; 7471 7472 elsif Ekind (Var_Id) /= E_Variable then 7473 return False; 7474 end if; 7475 7476 Var_Decl := Declaration_Node (Var_Id); 7477 7478 if Nkind (Var_Decl) /= N_Object_Declaration then 7479 return False; 7480 end if; 7481 7482 N_Unit_Id := Find_Top_Unit (N); 7483 N_Unit := Unit_Declaration_Node (N_Unit_Id); 7484 7485 Var_Unit_Id := Find_Top_Unit (Var_Decl); 7486 Var_Unit := Unit_Declaration_Node (Var_Unit_Id); 7487 7488 -- To qualify, the assignment must meet the following prerequisites: 7489 7490 return 7491 Comes_From_Source (Var_Id) 7492 7493 -- The variable must be declared in the spec of compilation unit U 7494 7495 and then Nkind (Var_Unit) = N_Package_Declaration 7496 7497 -- Performance note: parent traversal 7498 7499 and then Find_Enclosing_Level (Var_Decl) = Package_Spec 7500 7501 -- The assignment must occur in the body of compilation unit U 7502 7503 and then Nkind (N_Unit) = N_Package_Body 7504 and then Present (Corresponding_Body (Var_Unit)) 7505 and then Corresponding_Body (Var_Unit) = N_Unit_Id; 7506 end Is_Suitable_Variable_Assignment; 7507 7508 ------------------------------------ 7509 -- Is_Suitable_Variable_Reference -- 7510 ------------------------------------ 7511 7512 function Is_Suitable_Variable_Reference (N : Node_Id) return Boolean is 7513 begin 7514 -- Expanded names and identifiers are intentionally ignored because they 7515 -- be folded, optimized away, etc. Variable references markers play the 7516 -- role of variable references and provide a uniform foundation for ABE 7517 -- processing. 7518 7519 return Nkind (N) = N_Variable_Reference_Marker; 7520 end Is_Suitable_Variable_Reference; 7521 7522 ------------------- 7523 -- Is_Task_Entry -- 7524 ------------------- 7525 7526 function Is_Task_Entry (Id : Entity_Id) return Boolean is 7527 begin 7528 -- To qualify, the entity must denote an entry defined in a task type 7529 7530 return 7531 Is_Entry (Id) and then Is_Task_Type (Non_Private_View (Scope (Id))); 7532 end Is_Task_Entry; 7533 7534 ------------------------ 7535 -- Is_Up_Level_Target -- 7536 ------------------------ 7537 7538 function Is_Up_Level_Target (Target_Decl : Node_Id) return Boolean is 7539 Root : constant Node_Id := Root_Scenario; 7540 7541 begin 7542 -- The root appears within the declaratons of a block statement, entry 7543 -- body, subprogram body, or task body ignoring enclosing packages. The 7544 -- root is always within the main unit. An up-level target is a notion 7545 -- applicable only to the static model because scenarios are reached by 7546 -- means of graph traversal started from a fixed declarative or library 7547 -- level. 7548 7549 -- Performance note: parent traversal 7550 7551 if Static_Elaboration_Checks 7552 and then Find_Enclosing_Level (Root) = Declaration_Level 7553 then 7554 -- The target is within the main unit. It acts as an up-level target 7555 -- when it appears within a context which encloses the root. 7556 7557 -- package body Main_Unit is 7558 -- function Func ...; -- target 7559 7560 -- procedure Proc is 7561 -- X : ... := Func; -- root scenario 7562 7563 if In_Extended_Main_Code_Unit (Target_Decl) then 7564 7565 -- Performance note: parent traversal 7566 7567 return not In_Same_Context (Root, Target_Decl, Nested_OK => True); 7568 7569 -- Otherwise the target is external to the main unit which makes it 7570 -- an up-level target. 7571 7572 else 7573 return True; 7574 end if; 7575 end if; 7576 7577 return False; 7578 end Is_Up_Level_Target; 7579 7580 --------------------- 7581 -- Is_Visited_Body -- 7582 --------------------- 7583 7584 function Is_Visited_Body (Body_Decl : Node_Id) return Boolean is 7585 begin 7586 if Visited_Bodies_In_Use then 7587 return Visited_Bodies.Get (Body_Decl); 7588 end if; 7589 7590 return Visited_Bodies_No_Element; 7591 end Is_Visited_Body; 7592 7593 ------------------------------- 7594 -- Kill_Elaboration_Scenario -- 7595 ------------------------------- 7596 7597 procedure Kill_Elaboration_Scenario (N : Node_Id) is 7598 procedure Kill_SPARK_Scenario; 7599 pragma Inline (Kill_SPARK_Scenario); 7600 -- Eliminate scenario N from table SPARK_Scenarios if it is recorded 7601 -- there. 7602 7603 procedure Kill_Top_Level_Scenario; 7604 pragma Inline (Kill_Top_Level_Scenario); 7605 -- Eliminate scenario N from table Top_Level_Scenarios if it is recorded 7606 -- there. 7607 7608 ------------------------- 7609 -- Kill_SPARK_Scenario -- 7610 ------------------------- 7611 7612 procedure Kill_SPARK_Scenario is 7613 package Scenarios renames SPARK_Scenarios; 7614 7615 begin 7616 if Is_Recorded_SPARK_Scenario (N) then 7617 7618 -- Performance note: list traversal 7619 7620 for Index in Scenarios.First .. Scenarios.Last loop 7621 if Scenarios.Table (Index) = N then 7622 Scenarios.Table (Index) := Empty; 7623 7624 -- The SPARK scenario is no longer recorded 7625 7626 Set_Is_Recorded_SPARK_Scenario (N, False); 7627 return; 7628 end if; 7629 end loop; 7630 7631 -- A recorded SPARK scenario must be in the table of recorded 7632 -- SPARK scenarios. 7633 7634 pragma Assert (False); 7635 end if; 7636 end Kill_SPARK_Scenario; 7637 7638 ----------------------------- 7639 -- Kill_Top_Level_Scenario -- 7640 ----------------------------- 7641 7642 procedure Kill_Top_Level_Scenario is 7643 package Scenarios renames Top_Level_Scenarios; 7644 7645 begin 7646 if Is_Recorded_Top_Level_Scenario (N) then 7647 7648 -- Performance node: list traversal 7649 7650 for Index in Scenarios.First .. Scenarios.Last loop 7651 if Scenarios.Table (Index) = N then 7652 Scenarios.Table (Index) := Empty; 7653 7654 -- The top-level scenario is no longer recorded 7655 7656 Set_Is_Recorded_Top_Level_Scenario (N, False); 7657 return; 7658 end if; 7659 end loop; 7660 7661 -- A recorded top-level scenario must be in the table of recorded 7662 -- top-level scenarios. 7663 7664 pragma Assert (False); 7665 end if; 7666 end Kill_Top_Level_Scenario; 7667 7668 -- Start of processing for Kill_Elaboration_Scenario 7669 7670 begin 7671 -- Nothing to do when switch -gnatH (legacy elaboration checking mode 7672 -- enabled) is in effect because the legacy ABE lechanism does not need 7673 -- to carry out this action. 7674 7675 if Legacy_Elaboration_Checks then 7676 return; 7677 end if; 7678 7679 -- Eliminate a recorded scenario when it appears within dead code 7680 -- because it will not be executed at elaboration time. 7681 7682 if Is_Scenario (N) then 7683 Kill_SPARK_Scenario; 7684 Kill_Top_Level_Scenario; 7685 end if; 7686 end Kill_Elaboration_Scenario; 7687 7688 ---------------------------------- 7689 -- Meet_Elaboration_Requirement -- 7690 ---------------------------------- 7691 7692 procedure Meet_Elaboration_Requirement 7693 (N : Node_Id; 7694 Target_Id : Entity_Id; 7695 Req_Nam : Name_Id) 7696 is 7697 Main_Id : constant Entity_Id := Cunit_Entity (Main_Unit); 7698 Unit_Id : constant Entity_Id := Find_Top_Unit (Target_Id); 7699 7700 function Find_Preelaboration_Pragma 7701 (Prag_Nam : Name_Id) return Node_Id; 7702 pragma Inline (Find_Preelaboration_Pragma); 7703 -- Traverse the visible declarations of unit Unit_Id and locate a source 7704 -- preelaboration-related pragma with name Prag_Nam. 7705 7706 procedure Info_Requirement_Met (Prag : Node_Id); 7707 pragma Inline (Info_Requirement_Met); 7708 -- Output information concerning pragma Prag which meets requirement 7709 -- Req_Nam. 7710 7711 procedure Info_Scenario; 7712 pragma Inline (Info_Scenario); 7713 -- Output information concerning scenario N 7714 7715 -------------------------------- 7716 -- Find_Preelaboration_Pragma -- 7717 -------------------------------- 7718 7719 function Find_Preelaboration_Pragma 7720 (Prag_Nam : Name_Id) return Node_Id 7721 is 7722 Spec : constant Node_Id := Parent (Unit_Id); 7723 Decl : Node_Id; 7724 7725 begin 7726 -- A preelaboration-related pragma comes from source and appears at 7727 -- the top of the visible declarations of a package. 7728 7729 if Nkind (Spec) = N_Package_Specification then 7730 Decl := First (Visible_Declarations (Spec)); 7731 while Present (Decl) loop 7732 if Comes_From_Source (Decl) then 7733 if Nkind (Decl) = N_Pragma 7734 and then Pragma_Name (Decl) = Prag_Nam 7735 then 7736 return Decl; 7737 7738 -- Otherwise the construct terminates the region where the 7739 -- preelabortion-related pragma may appear. 7740 7741 else 7742 exit; 7743 end if; 7744 end if; 7745 7746 Next (Decl); 7747 end loop; 7748 end if; 7749 7750 return Empty; 7751 end Find_Preelaboration_Pragma; 7752 7753 -------------------------- 7754 -- Info_Requirement_Met -- 7755 -------------------------- 7756 7757 procedure Info_Requirement_Met (Prag : Node_Id) is 7758 begin 7759 pragma Assert (Present (Prag)); 7760 7761 Error_Msg_Name_1 := Req_Nam; 7762 Error_Msg_Sloc := Sloc (Prag); 7763 Error_Msg_NE 7764 ("\\% requirement for unit & met by pragma #", N, Unit_Id); 7765 end Info_Requirement_Met; 7766 7767 ------------------- 7768 -- Info_Scenario -- 7769 ------------------- 7770 7771 procedure Info_Scenario is 7772 begin 7773 if Is_Suitable_Call (N) then 7774 Info_Call 7775 (Call => N, 7776 Target_Id => Target_Id, 7777 Info_Msg => False, 7778 In_SPARK => True); 7779 7780 elsif Is_Suitable_Instantiation (N) then 7781 Info_Instantiation 7782 (Inst => N, 7783 Gen_Id => Target_Id, 7784 Info_Msg => False, 7785 In_SPARK => True); 7786 7787 elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then 7788 Error_Msg_N 7789 ("read of refinement constituents during elaboration in SPARK", 7790 N); 7791 7792 elsif Is_Suitable_Variable_Reference (N) then 7793 Info_Variable_Reference 7794 (Ref => N, 7795 Var_Id => Target_Id, 7796 Info_Msg => False, 7797 In_SPARK => True); 7798 7799 -- No other scenario may impose a requirement on the context of the 7800 -- main unit. 7801 7802 else 7803 pragma Assert (False); 7804 null; 7805 end if; 7806 end Info_Scenario; 7807 7808 -- Local variables 7809 7810 Elab_Attrs : Elaboration_Attributes; 7811 Elab_Nam : Name_Id; 7812 Req_Met : Boolean; 7813 7814 -- Start of processing for Meet_Elaboration_Requirement 7815 7816 begin 7817 pragma Assert (Nam_In (Req_Nam, Name_Elaborate, Name_Elaborate_All)); 7818 7819 -- Assume that the requirement has not been met 7820 7821 Req_Met := False; 7822 7823 -- Elaboration requirements are verified only when the static model is 7824 -- in effect because this diagnostic is graph-dependent. 7825 7826 if not Static_Elaboration_Checks then 7827 return; 7828 7829 -- If the target is within the main unit, either at the source level or 7830 -- through an instantiation, then there is no real requirement to meet 7831 -- because the main unit cannot force its own elaboration by means of an 7832 -- Elaborate[_All] pragma. Treat this case as valid coverage. 7833 7834 elsif In_Extended_Main_Code_Unit (Target_Id) then 7835 Req_Met := True; 7836 7837 -- Otherwise the target resides in an external unit 7838 7839 -- The requirement is met when the target comes from an internal unit 7840 -- because such a unit is elaborated prior to a non-internal unit. 7841 7842 elsif In_Internal_Unit (Unit_Id) 7843 and then not In_Internal_Unit (Main_Id) 7844 then 7845 Req_Met := True; 7846 7847 -- The requirement is met when the target comes from a preelaborated 7848 -- unit. This portion must parallel predicate Is_Preelaborated_Unit. 7849 7850 elsif Is_Preelaborated_Unit (Unit_Id) then 7851 Req_Met := True; 7852 7853 -- Output extra information when switch -gnatel (info messages on 7854 -- implicit Elaborate[_All] pragmas. 7855 7856 if Elab_Info_Messages then 7857 if Is_Preelaborated (Unit_Id) then 7858 Elab_Nam := Name_Preelaborate; 7859 7860 elsif Is_Pure (Unit_Id) then 7861 Elab_Nam := Name_Pure; 7862 7863 elsif Is_Remote_Call_Interface (Unit_Id) then 7864 Elab_Nam := Name_Remote_Call_Interface; 7865 7866 elsif Is_Remote_Types (Unit_Id) then 7867 Elab_Nam := Name_Remote_Types; 7868 7869 else 7870 pragma Assert (Is_Shared_Passive (Unit_Id)); 7871 Elab_Nam := Name_Shared_Passive; 7872 end if; 7873 7874 Info_Requirement_Met (Find_Preelaboration_Pragma (Elab_Nam)); 7875 end if; 7876 7877 -- Determine whether the context of the main unit has a pragma strong 7878 -- enough to meet the requirement. 7879 7880 else 7881 Elab_Attrs := Elaboration_Status (Unit_Id); 7882 7883 -- The pragma must be either Elaborate_All or be as strong as the 7884 -- requirement. 7885 7886 if Present (Elab_Attrs.Source_Pragma) 7887 and then Nam_In (Pragma_Name (Elab_Attrs.Source_Pragma), 7888 Name_Elaborate_All, 7889 Req_Nam) 7890 then 7891 Req_Met := True; 7892 7893 -- Output extra information when switch -gnatel (info messages on 7894 -- implicit Elaborate[_All] pragmas. 7895 7896 if Elab_Info_Messages then 7897 Info_Requirement_Met (Elab_Attrs.Source_Pragma); 7898 end if; 7899 end if; 7900 end if; 7901 7902 -- The requirement was not met by the context of the main unit, issue an 7903 -- error. 7904 7905 if not Req_Met then 7906 Info_Scenario; 7907 7908 Error_Msg_Name_1 := Req_Nam; 7909 Error_Msg_Node_2 := Unit_Id; 7910 Error_Msg_NE ("\\unit & requires pragma % for &", N, Main_Id); 7911 7912 Output_Active_Scenarios (N); 7913 end if; 7914 end Meet_Elaboration_Requirement; 7915 7916 ---------------------- 7917 -- Non_Private_View -- 7918 ---------------------- 7919 7920 function Non_Private_View (Typ : Entity_Id) return Entity_Id is 7921 Result : Entity_Id; 7922 7923 begin 7924 Result := Typ; 7925 7926 if Is_Private_Type (Result) and then Present (Full_View (Result)) then 7927 Result := Full_View (Result); 7928 end if; 7929 7930 return Result; 7931 end Non_Private_View; 7932 7933 ----------------------------- 7934 -- Output_Active_Scenarios -- 7935 ----------------------------- 7936 7937 procedure Output_Active_Scenarios (Error_Nod : Node_Id) is 7938 procedure Output_Access (N : Node_Id); 7939 -- Emit a specific diagnostic message for 'Access denote by N 7940 7941 procedure Output_Activation_Call (N : Node_Id); 7942 -- Emit a specific diagnostic message for task activation N 7943 7944 procedure Output_Call (N : Node_Id; Target_Id : Entity_Id); 7945 -- Emit a specific diagnostic message for call N which invokes target 7946 -- Target_Id. 7947 7948 procedure Output_Header; 7949 -- Emit a specific diagnostic message for the unit of the root scenario 7950 7951 procedure Output_Instantiation (N : Node_Id); 7952 -- Emit a specific diagnostic message for instantiation N 7953 7954 procedure Output_SPARK_Refined_State_Pragma (N : Node_Id); 7955 -- Emit a specific diagnostic message for Refined_State pragma N 7956 7957 procedure Output_Variable_Assignment (N : Node_Id); 7958 -- Emit a specific diagnostic message for assignment statement N 7959 7960 procedure Output_Variable_Reference (N : Node_Id); 7961 -- Emit a specific diagnostic message for reference N which mentions a 7962 -- variable. 7963 7964 ------------------- 7965 -- Output_Access -- 7966 ------------------- 7967 7968 procedure Output_Access (N : Node_Id) is 7969 Subp_Id : constant Entity_Id := Entity (Prefix (N)); 7970 7971 begin 7972 Error_Msg_Name_1 := Attribute_Name (N); 7973 Error_Msg_Sloc := Sloc (N); 7974 Error_Msg_NE ("\\ % of & taken #", Error_Nod, Subp_Id); 7975 end Output_Access; 7976 7977 ---------------------------- 7978 -- Output_Activation_Call -- 7979 ---------------------------- 7980 7981 procedure Output_Activation_Call (N : Node_Id) is 7982 function Find_Activator (Call : Node_Id) return Entity_Id; 7983 -- Find the nearest enclosing construct which houses call Call 7984 7985 -------------------- 7986 -- Find_Activator -- 7987 -------------------- 7988 7989 function Find_Activator (Call : Node_Id) return Entity_Id is 7990 Par : Node_Id; 7991 7992 begin 7993 -- Climb the parent chain looking for a package [body] or a 7994 -- construct with a statement sequence. 7995 7996 Par := Parent (Call); 7997 while Present (Par) loop 7998 if Nkind_In (Par, N_Package_Body, N_Package_Declaration) then 7999 return Defining_Entity (Par); 8000 8001 elsif Nkind (Par) = N_Handled_Sequence_Of_Statements then 8002 return Defining_Entity (Parent (Par)); 8003 end if; 8004 8005 Par := Parent (Par); 8006 end loop; 8007 8008 return Empty; 8009 end Find_Activator; 8010 8011 -- Local variables 8012 8013 Activator : constant Entity_Id := Find_Activator (N); 8014 8015 -- Start of processing for Output_Activation_Call 8016 8017 begin 8018 pragma Assert (Present (Activator)); 8019 8020 Error_Msg_NE ("\\ local tasks of & activated", Error_Nod, Activator); 8021 end Output_Activation_Call; 8022 8023 ----------------- 8024 -- Output_Call -- 8025 ----------------- 8026 8027 procedure Output_Call (N : Node_Id; Target_Id : Entity_Id) is 8028 procedure Output_Accept_Alternative; 8029 pragma Inline (Output_Accept_Alternative); 8030 -- Emit a specific diagnostic message concerning an accept 8031 -- alternative. 8032 8033 procedure Output_Call (Kind : String); 8034 pragma Inline (Output_Call); 8035 -- Emit a specific diagnostic message concerning a call of kind Kind 8036 8037 procedure Output_Type_Actions (Action : String); 8038 pragma Inline (Output_Type_Actions); 8039 -- Emit a specific diagnostic message concerning action Action of a 8040 -- type. 8041 8042 procedure Output_Verification_Call 8043 (Pred : String; 8044 Id : Entity_Id; 8045 Id_Kind : String); 8046 pragma Inline (Output_Verification_Call); 8047 -- Emit a specific diagnostic message concerning the verification of 8048 -- predicate Pred applied to related entity Id with kind Id_Kind. 8049 8050 ------------------------------- 8051 -- Output_Accept_Alternative -- 8052 ------------------------------- 8053 8054 procedure Output_Accept_Alternative is 8055 Entry_Id : constant Entity_Id := Receiving_Entry (Target_Id); 8056 8057 begin 8058 pragma Assert (Present (Entry_Id)); 8059 8060 Error_Msg_NE ("\\ entry & selected #", Error_Nod, Entry_Id); 8061 end Output_Accept_Alternative; 8062 8063 ----------------- 8064 -- Output_Call -- 8065 ----------------- 8066 8067 procedure Output_Call (Kind : String) is 8068 begin 8069 Error_Msg_NE ("\\ " & Kind & " & called #", Error_Nod, Target_Id); 8070 end Output_Call; 8071 8072 ------------------------- 8073 -- Output_Type_Actions -- 8074 ------------------------- 8075 8076 procedure Output_Type_Actions (Action : String) is 8077 Typ : constant Entity_Id := First_Formal_Type (Target_Id); 8078 8079 begin 8080 pragma Assert (Present (Typ)); 8081 8082 Error_Msg_NE 8083 ("\\ " & Action & " actions for type & #", Error_Nod, Typ); 8084 end Output_Type_Actions; 8085 8086 ------------------------------ 8087 -- Output_Verification_Call -- 8088 ------------------------------ 8089 8090 procedure Output_Verification_Call 8091 (Pred : String; 8092 Id : Entity_Id; 8093 Id_Kind : String) 8094 is 8095 begin 8096 pragma Assert (Present (Id)); 8097 8098 Error_Msg_NE 8099 ("\\ " & Pred & " of " & Id_Kind & " & verified #", 8100 Error_Nod, Id); 8101 end Output_Verification_Call; 8102 8103 -- Start of processing for Output_Call 8104 8105 begin 8106 Error_Msg_Sloc := Sloc (N); 8107 8108 -- Accept alternative 8109 8110 if Is_Accept_Alternative_Proc (Target_Id) then 8111 Output_Accept_Alternative; 8112 8113 -- Adjustment 8114 8115 elsif Is_TSS (Target_Id, TSS_Deep_Adjust) then 8116 Output_Type_Actions ("adjustment"); 8117 8118 -- Default_Initial_Condition 8119 8120 elsif Is_Default_Initial_Condition_Proc (Target_Id) then 8121 Output_Verification_Call 8122 (Pred => "Default_Initial_Condition", 8123 Id => First_Formal_Type (Target_Id), 8124 Id_Kind => "type"); 8125 8126 -- Entries 8127 8128 elsif Is_Protected_Entry (Target_Id) then 8129 Output_Call ("entry"); 8130 8131 -- Task entry calls are never processed because the entry being 8132 -- invoked does not have a corresponding "body", it has a select. A 8133 -- task entry call appears in the stack of active scenarios for the 8134 -- sole purpose of checking No_Entry_Calls_In_Elaboration_Code and 8135 -- nothing more. 8136 8137 elsif Is_Task_Entry (Target_Id) then 8138 null; 8139 8140 -- Finalization 8141 8142 elsif Is_TSS (Target_Id, TSS_Deep_Finalize) then 8143 Output_Type_Actions ("finalization"); 8144 8145 -- Calls to _Finalizer procedures must not appear in the output 8146 -- because this creates confusing noise. 8147 8148 elsif Is_Finalizer_Proc (Target_Id) then 8149 null; 8150 8151 -- Initial_Condition 8152 8153 elsif Is_Initial_Condition_Proc (Target_Id) then 8154 Output_Verification_Call 8155 (Pred => "Initial_Condition", 8156 Id => Find_Enclosing_Scope (N), 8157 Id_Kind => "package"); 8158 8159 -- Initialization 8160 8161 elsif Is_Init_Proc (Target_Id) 8162 or else Is_TSS (Target_Id, TSS_Deep_Initialize) 8163 then 8164 Output_Type_Actions ("initialization"); 8165 8166 -- Invariant 8167 8168 elsif Is_Invariant_Proc (Target_Id) then 8169 Output_Verification_Call 8170 (Pred => "invariants", 8171 Id => First_Formal_Type (Target_Id), 8172 Id_Kind => "type"); 8173 8174 -- Partial invariant calls must not appear in the output because this 8175 -- creates confusing noise. Note that a partial invariant is always 8176 -- invoked by the "full" invariant which is already placed on the 8177 -- stack. 8178 8179 elsif Is_Partial_Invariant_Proc (Target_Id) then 8180 null; 8181 8182 -- _Postconditions 8183 8184 elsif Is_Postconditions_Proc (Target_Id) then 8185 Output_Verification_Call 8186 (Pred => "postconditions", 8187 Id => Find_Enclosing_Scope (N), 8188 Id_Kind => "subprogram"); 8189 8190 -- Subprograms must come last because some of the previous cases fall 8191 -- under this category. 8192 8193 elsif Ekind (Target_Id) = E_Function then 8194 Output_Call ("function"); 8195 8196 elsif Ekind (Target_Id) = E_Procedure then 8197 Output_Call ("procedure"); 8198 8199 else 8200 pragma Assert (False); 8201 null; 8202 end if; 8203 end Output_Call; 8204 8205 ------------------- 8206 -- Output_Header -- 8207 ------------------- 8208 8209 procedure Output_Header is 8210 Unit_Id : constant Entity_Id := Find_Top_Unit (Root_Scenario); 8211 8212 begin 8213 if Ekind (Unit_Id) = E_Package then 8214 Error_Msg_NE ("\\ spec of unit & elaborated", Error_Nod, Unit_Id); 8215 8216 elsif Ekind (Unit_Id) = E_Package_Body then 8217 Error_Msg_NE ("\\ body of unit & elaborated", Error_Nod, Unit_Id); 8218 8219 else 8220 Error_Msg_NE ("\\ in body of unit &", Error_Nod, Unit_Id); 8221 end if; 8222 end Output_Header; 8223 8224 -------------------------- 8225 -- Output_Instantiation -- 8226 -------------------------- 8227 8228 procedure Output_Instantiation (N : Node_Id) is 8229 procedure Output_Instantiation (Gen_Id : Entity_Id; Kind : String); 8230 pragma Inline (Output_Instantiation); 8231 -- Emit a specific diagnostic message concerning an instantiation of 8232 -- generic unit Gen_Id. Kind denotes the kind of the instantiation. 8233 8234 -------------------------- 8235 -- Output_Instantiation -- 8236 -------------------------- 8237 8238 procedure Output_Instantiation (Gen_Id : Entity_Id; Kind : String) is 8239 begin 8240 Error_Msg_NE 8241 ("\\ " & Kind & " & instantiated as & #", Error_Nod, Gen_Id); 8242 end Output_Instantiation; 8243 8244 -- Local variables 8245 8246 Inst : Node_Id; 8247 Inst_Attrs : Instantiation_Attributes; 8248 Inst_Id : Entity_Id; 8249 Gen_Id : Entity_Id; 8250 8251 -- Start of processing for Output_Instantiation 8252 8253 begin 8254 Extract_Instantiation_Attributes 8255 (Exp_Inst => N, 8256 Inst => Inst, 8257 Inst_Id => Inst_Id, 8258 Gen_Id => Gen_Id, 8259 Attrs => Inst_Attrs); 8260 8261 Error_Msg_Node_2 := Inst_Id; 8262 Error_Msg_Sloc := Sloc (Inst); 8263 8264 if Nkind (Inst) = N_Function_Instantiation then 8265 Output_Instantiation (Gen_Id, "function"); 8266 8267 elsif Nkind (Inst) = N_Package_Instantiation then 8268 Output_Instantiation (Gen_Id, "package"); 8269 8270 elsif Nkind (Inst) = N_Procedure_Instantiation then 8271 Output_Instantiation (Gen_Id, "procedure"); 8272 8273 else 8274 pragma Assert (False); 8275 null; 8276 end if; 8277 end Output_Instantiation; 8278 8279 --------------------------------------- 8280 -- Output_SPARK_Refined_State_Pragma -- 8281 --------------------------------------- 8282 8283 procedure Output_SPARK_Refined_State_Pragma (N : Node_Id) is 8284 begin 8285 Error_Msg_Sloc := Sloc (N); 8286 Error_Msg_N ("\\ refinement constituents read #", Error_Nod); 8287 end Output_SPARK_Refined_State_Pragma; 8288 8289 -------------------------------- 8290 -- Output_Variable_Assignment -- 8291 -------------------------------- 8292 8293 procedure Output_Variable_Assignment (N : Node_Id) is 8294 Var_Id : constant Entity_Id := Entity (Extract_Assignment_Name (N)); 8295 8296 begin 8297 Error_Msg_Sloc := Sloc (N); 8298 Error_Msg_NE ("\\ variable & assigned #", Error_Nod, Var_Id); 8299 end Output_Variable_Assignment; 8300 8301 ------------------------------- 8302 -- Output_Variable_Reference -- 8303 ------------------------------- 8304 8305 procedure Output_Variable_Reference (N : Node_Id) is 8306 Dummy : Variable_Attributes; 8307 Var_Id : Entity_Id; 8308 8309 begin 8310 Extract_Variable_Reference_Attributes 8311 (Ref => N, 8312 Var_Id => Var_Id, 8313 Attrs => Dummy); 8314 8315 Error_Msg_Sloc := Sloc (N); 8316 8317 if Is_Read (N) then 8318 Error_Msg_NE ("\\ variable & read #", Error_Nod, Var_Id); 8319 8320 else 8321 pragma Assert (False); 8322 null; 8323 end if; 8324 end Output_Variable_Reference; 8325 8326 -- Local variables 8327 8328 package Stack renames Scenario_Stack; 8329 8330 Dummy : Call_Attributes; 8331 N : Node_Id; 8332 Posted : Boolean; 8333 Target_Id : Entity_Id; 8334 8335 -- Start of processing for Output_Active_Scenarios 8336 8337 begin 8338 -- Active scenarios are emitted only when the static model is in effect 8339 -- because there is an inherent order by which all these scenarios were 8340 -- reached from the declaration or library level. 8341 8342 if not Static_Elaboration_Checks then 8343 return; 8344 end if; 8345 8346 Posted := False; 8347 8348 for Index in Stack.First .. Stack.Last loop 8349 N := Stack.Table (Index); 8350 8351 if not Posted then 8352 Posted := True; 8353 Output_Header; 8354 end if; 8355 8356 -- 'Access 8357 8358 if Nkind (N) = N_Attribute_Reference then 8359 Output_Access (N); 8360 8361 -- Calls 8362 8363 elsif Is_Suitable_Call (N) then 8364 Extract_Call_Attributes 8365 (Call => N, 8366 Target_Id => Target_Id, 8367 Attrs => Dummy); 8368 8369 if Is_Activation_Proc (Target_Id) then 8370 Output_Activation_Call (N); 8371 else 8372 Output_Call (N, Target_Id); 8373 end if; 8374 8375 -- Instantiations 8376 8377 elsif Is_Suitable_Instantiation (N) then 8378 Output_Instantiation (N); 8379 8380 -- Pragma Refined_State 8381 8382 elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then 8383 Output_SPARK_Refined_State_Pragma (N); 8384 8385 -- Variable assignments 8386 8387 elsif Nkind (N) = N_Assignment_Statement then 8388 Output_Variable_Assignment (N); 8389 8390 -- Variable references 8391 8392 elsif Is_Suitable_Variable_Reference (N) then 8393 Output_Variable_Reference (N); 8394 8395 else 8396 pragma Assert (False); 8397 null; 8398 end if; 8399 end loop; 8400 end Output_Active_Scenarios; 8401 8402 ------------------------- 8403 -- Pop_Active_Scenario -- 8404 ------------------------- 8405 8406 procedure Pop_Active_Scenario (N : Node_Id) is 8407 Top : Node_Id renames Scenario_Stack.Table (Scenario_Stack.Last); 8408 8409 begin 8410 pragma Assert (Top = N); 8411 Scenario_Stack.Decrement_Last; 8412 end Pop_Active_Scenario; 8413 8414 -------------------------------- 8415 -- Process_Activation_Generic -- 8416 -------------------------------- 8417 8418 procedure Process_Activation_Generic 8419 (Call : Node_Id; 8420 Call_Attrs : Call_Attributes; 8421 State : Processing_Attributes) 8422 is 8423 procedure Process_Task_Object (Obj_Id : Entity_Id; Typ : Entity_Id); 8424 -- Perform ABE checks and diagnostics for object Obj_Id with type Typ. 8425 -- Typ may be a task type or a composite type with at least one task 8426 -- component. 8427 8428 procedure Process_Task_Objects (List : List_Id); 8429 -- Perform ABE checks and diagnostics for all task objects found in 8430 -- the list List. 8431 8432 ------------------------- 8433 -- Process_Task_Object -- 8434 ------------------------- 8435 8436 procedure Process_Task_Object (Obj_Id : Entity_Id; Typ : Entity_Id) is 8437 Base_Typ : constant Entity_Id := Base_Type (Typ); 8438 8439 Comp_Id : Entity_Id; 8440 Task_Attrs : Task_Attributes; 8441 8442 begin 8443 if Is_Task_Type (Typ) then 8444 Extract_Task_Attributes 8445 (Typ => Base_Typ, 8446 Attrs => Task_Attrs); 8447 8448 Process_Single_Activation 8449 (Call => Call, 8450 Call_Attrs => Call_Attrs, 8451 Obj_Id => Obj_Id, 8452 Task_Attrs => Task_Attrs, 8453 State => State); 8454 8455 -- Examine the component type when the object is an array 8456 8457 elsif Is_Array_Type (Typ) and then Has_Task (Base_Typ) then 8458 Process_Task_Object (Obj_Id, Component_Type (Typ)); 8459 8460 -- Examine individual component types when the object is a record 8461 8462 elsif Is_Record_Type (Typ) and then Has_Task (Base_Typ) then 8463 Comp_Id := First_Component (Typ); 8464 while Present (Comp_Id) loop 8465 Process_Task_Object (Obj_Id, Etype (Comp_Id)); 8466 Next_Component (Comp_Id); 8467 end loop; 8468 end if; 8469 end Process_Task_Object; 8470 8471 -------------------------- 8472 -- Process_Task_Objects -- 8473 -------------------------- 8474 8475 procedure Process_Task_Objects (List : List_Id) is 8476 Item : Node_Id; 8477 Item_Id : Entity_Id; 8478 Item_Typ : Entity_Id; 8479 8480 begin 8481 -- Examine the contents of the list looking for an object declaration 8482 -- of a task type or one that contains a task within. 8483 8484 Item := First (List); 8485 while Present (Item) loop 8486 if Nkind (Item) = N_Object_Declaration then 8487 Item_Id := Defining_Entity (Item); 8488 Item_Typ := Etype (Item_Id); 8489 8490 if Has_Task (Item_Typ) then 8491 Process_Task_Object (Item_Id, Item_Typ); 8492 end if; 8493 end if; 8494 8495 Next (Item); 8496 end loop; 8497 end Process_Task_Objects; 8498 8499 -- Local variables 8500 8501 Context : Node_Id; 8502 Spec : Node_Id; 8503 8504 -- Start of processing for Process_Activation_Generic 8505 8506 begin 8507 -- Nothing to do when the activation is a guaranteed ABE 8508 8509 if Is_Known_Guaranteed_ABE (Call) then 8510 return; 8511 end if; 8512 8513 -- Find the proper context of the activation call where all task objects 8514 -- being activated are declared. This is usually the immediate parent of 8515 -- the call. 8516 8517 Context := Parent (Call); 8518 8519 -- In the case of package bodies, the activation call is in the handled 8520 -- sequence of statements, but the task objects are in the declaration 8521 -- list of the body. 8522 8523 if Nkind (Context) = N_Handled_Sequence_Of_Statements 8524 and then Nkind (Parent (Context)) = N_Package_Body 8525 then 8526 Context := Parent (Context); 8527 end if; 8528 8529 -- Process all task objects defined in both the spec and body when the 8530 -- activation call precedes the "begin" of a package body. 8531 8532 if Nkind (Context) = N_Package_Body then 8533 Spec := 8534 Specification 8535 (Unit_Declaration_Node (Corresponding_Spec (Context))); 8536 8537 Process_Task_Objects (Visible_Declarations (Spec)); 8538 Process_Task_Objects (Private_Declarations (Spec)); 8539 Process_Task_Objects (Declarations (Context)); 8540 8541 -- Process all task objects defined in the spec when the activation call 8542 -- appears at the end of a package spec. 8543 8544 elsif Nkind (Context) = N_Package_Specification then 8545 Process_Task_Objects (Visible_Declarations (Context)); 8546 Process_Task_Objects (Private_Declarations (Context)); 8547 8548 -- Otherwise the context of the activation is some construct with a 8549 -- declarative part. Note that the corresponding record type of a task 8550 -- type is controlled. Because of this, the finalization machinery must 8551 -- relocate the task object to the handled statements of the construct 8552 -- to perform proper finalization in case of an exception. Examine the 8553 -- statements of the construct rather than the declarations. 8554 8555 else 8556 pragma Assert (Nkind (Context) = N_Handled_Sequence_Of_Statements); 8557 8558 Process_Task_Objects (Statements (Context)); 8559 end if; 8560 end Process_Activation_Generic; 8561 8562 ------------------------------------ 8563 -- Process_Conditional_ABE_Access -- 8564 ------------------------------------ 8565 8566 procedure Process_Conditional_ABE_Access 8567 (Attr : Node_Id; 8568 State : Processing_Attributes) 8569 is 8570 function Build_Access_Marker (Target_Id : Entity_Id) return Node_Id; 8571 pragma Inline (Build_Access_Marker); 8572 -- Create a suitable call marker which invokes target Target_Id 8573 8574 ------------------------- 8575 -- Build_Access_Marker -- 8576 ------------------------- 8577 8578 function Build_Access_Marker (Target_Id : Entity_Id) return Node_Id is 8579 Marker : Node_Id; 8580 8581 begin 8582 Marker := Make_Call_Marker (Sloc (Attr)); 8583 8584 -- Inherit relevant attributes from the attribute 8585 8586 -- Performance note: parent traversal 8587 8588 Set_Target (Marker, Target_Id); 8589 Set_Is_Declaration_Level_Node 8590 (Marker, Find_Enclosing_Level (Attr) = Declaration_Level); 8591 Set_Is_Dispatching_Call 8592 (Marker, False); 8593 Set_Is_Elaboration_Checks_OK_Node 8594 (Marker, Is_Elaboration_Checks_OK_Node (Attr)); 8595 Set_Is_Source_Call 8596 (Marker, Comes_From_Source (Attr)); 8597 Set_Is_SPARK_Mode_On_Node 8598 (Marker, Is_SPARK_Mode_On_Node (Attr)); 8599 8600 -- Partially insert the call marker into the tree by setting its 8601 -- parent pointer. 8602 8603 Set_Parent (Marker, Attr); 8604 8605 return Marker; 8606 end Build_Access_Marker; 8607 8608 -- Local variables 8609 8610 Root : constant Node_Id := Root_Scenario; 8611 Target_Id : constant Entity_Id := Entity (Prefix (Attr)); 8612 8613 Target_Attrs : Target_Attributes; 8614 8615 -- Start of processing for Process_Conditional_ABE_Access 8616 8617 begin 8618 -- Output relevant information when switch -gnatel (info messages on 8619 -- implicit Elaborate[_All] pragmas) is in effect. 8620 8621 if Elab_Info_Messages then 8622 Error_Msg_NE 8623 ("info: access to & during elaboration", Attr, Target_Id); 8624 end if; 8625 8626 Extract_Target_Attributes 8627 (Target_Id => Target_Id, 8628 Attrs => Target_Attrs); 8629 8630 -- Both the attribute and the corresponding body are in the same unit. 8631 -- The corresponding body must appear prior to the root scenario which 8632 -- started the recursive search. If this is not the case, then there is 8633 -- a potential ABE if the access value is used to call the subprogram. 8634 -- Emit a warning only when switch -gnatw.f (warnings on suspucious 8635 -- 'Access) is in effect. 8636 8637 if Warn_On_Elab_Access 8638 and then Present (Target_Attrs.Body_Decl) 8639 and then In_Extended_Main_Code_Unit (Target_Attrs.Body_Decl) 8640 and then Earlier_In_Extended_Unit (Root, Target_Attrs.Body_Decl) 8641 then 8642 Error_Msg_Name_1 := Attribute_Name (Attr); 8643 Error_Msg_NE ("??% attribute of & before body seen", Attr, Target_Id); 8644 Error_Msg_N ("\possible Program_Error on later references", Attr); 8645 8646 Output_Active_Scenarios (Attr); 8647 end if; 8648 8649 -- Treat the attribute as an immediate invocation of the target when 8650 -- switch -gnatd.o (conservative elaboration order for indirect calls) 8651 -- is in effect. Note that the prior elaboration of the unit containing 8652 -- the target is ensured processing the corresponding call marker. 8653 8654 if Debug_Flag_Dot_O then 8655 Process_Conditional_ABE 8656 (N => Build_Access_Marker (Target_Id), 8657 State => State); 8658 8659 -- Otherwise ensure that the unit with the corresponding body is 8660 -- elaborated prior to the main unit. 8661 8662 else 8663 Ensure_Prior_Elaboration 8664 (N => Attr, 8665 Unit_Id => Target_Attrs.Unit_Id, 8666 Prag_Nam => Name_Elaborate_All, 8667 State => State); 8668 end if; 8669 end Process_Conditional_ABE_Access; 8670 8671 --------------------------------------------- 8672 -- Process_Conditional_ABE_Activation_Impl -- 8673 --------------------------------------------- 8674 8675 procedure Process_Conditional_ABE_Activation_Impl 8676 (Call : Node_Id; 8677 Call_Attrs : Call_Attributes; 8678 Obj_Id : Entity_Id; 8679 Task_Attrs : Task_Attributes; 8680 State : Processing_Attributes) 8681 is 8682 Check_OK : constant Boolean := 8683 not Is_Ignored_Ghost_Entity (Obj_Id) 8684 and then not Task_Attrs.Ghost_Mode_Ignore 8685 and then Is_Elaboration_Checks_OK_Id (Obj_Id) 8686 and then Task_Attrs.Elab_Checks_OK; 8687 -- A run-time ABE check may be installed only when the object and the 8688 -- task type have active elaboration checks, and both are not ignored 8689 -- Ghost constructs. 8690 8691 Root : constant Node_Id := Root_Scenario; 8692 8693 New_State : Processing_Attributes := State; 8694 -- Each step of the Processing phase constitutes a new state 8695 8696 begin 8697 -- Output relevant information when switch -gnatel (info messages on 8698 -- implicit Elaborate[_All] pragmas) is in effect. 8699 8700 if Elab_Info_Messages then 8701 Error_Msg_NE 8702 ("info: activation of & during elaboration", Call, Obj_Id); 8703 end if; 8704 8705 -- Nothing to do when the call activates a task whose type is defined 8706 -- within an instance and switch -gnatd_i (ignore activations and calls 8707 -- to instances for elaboration) is in effect. 8708 8709 if Debug_Flag_Underscore_I 8710 and then In_External_Instance 8711 (N => Call, 8712 Target_Decl => Task_Attrs.Task_Decl) 8713 then 8714 return; 8715 8716 -- Nothing to do when the activation is a guaranteed ABE 8717 8718 elsif Is_Known_Guaranteed_ABE (Call) then 8719 return; 8720 8721 -- Nothing to do when the root scenario appears at the declaration 8722 -- level and the task is in the same unit, but outside this context. 8723 -- 8724 -- task type Task_Typ; -- task declaration 8725 -- 8726 -- procedure Proc is 8727 -- function A ... is 8728 -- begin 8729 -- if Some_Condition then 8730 -- declare 8731 -- T : Task_Typ; 8732 -- begin 8733 -- <activation call> -- activation site 8734 -- end; 8735 -- ... 8736 -- end A; 8737 -- 8738 -- X : ... := A; -- root scenario 8739 -- ... 8740 -- 8741 -- task body Task_Typ is 8742 -- ... 8743 -- end Task_Typ; 8744 -- 8745 -- In the example above, the context of X is the declarative list of 8746 -- Proc. The "elaboration" of X may reach the activation of T whose body 8747 -- is defined outside of X's context. The task body is relevant only 8748 -- when Proc is invoked, but this happens only in "normal" elaboration, 8749 -- therefore the task body must not be considered if this is not the 8750 -- case. 8751 8752 -- Performance note: parent traversal 8753 8754 elsif Is_Up_Level_Target (Task_Attrs.Task_Decl) then 8755 return; 8756 8757 -- Nothing to do when the activation is ABE-safe 8758 -- 8759 -- generic 8760 -- package Gen is 8761 -- task type Task_Typ; 8762 -- end Gen; 8763 -- 8764 -- package body Gen is 8765 -- task body Task_Typ is 8766 -- begin 8767 -- ... 8768 -- end Task_Typ; 8769 -- end Gen; 8770 -- 8771 -- with Gen; 8772 -- procedure Main is 8773 -- package Nested is 8774 -- package Inst is new Gen; 8775 -- T : Inst.Task_Typ; 8776 -- <activation call> -- safe activation 8777 -- end Nested; 8778 -- ... 8779 8780 elsif Is_Safe_Activation (Call, Task_Attrs.Task_Decl) then 8781 8782 -- Note that the task body must still be examined for any nested 8783 -- scenarios. 8784 8785 null; 8786 8787 -- The activation call and the task body are both in the main unit 8788 8789 elsif Present (Task_Attrs.Body_Decl) 8790 and then In_Extended_Main_Code_Unit (Task_Attrs.Body_Decl) 8791 then 8792 -- If the root scenario appears prior to the task body, then this is 8793 -- a possible ABE with respect to the root scenario. 8794 -- 8795 -- task type Task_Typ; 8796 -- 8797 -- function A ... is 8798 -- begin 8799 -- if Some_Condition then 8800 -- declare 8801 -- package Pack is 8802 -- T : Task_Typ; 8803 -- end Pack; -- activation of T 8804 -- ... 8805 -- end A; 8806 -- 8807 -- X : ... := A; -- root scenario 8808 -- 8809 -- task body Task_Typ is -- task body 8810 -- ... 8811 -- end Task_Typ; 8812 -- 8813 -- Y : ... := A; -- root scenario 8814 -- 8815 -- IMPORTANT: The activation of T is a possible ABE for X, but 8816 -- not for Y. Intalling an unconditional ABE raise prior to the 8817 -- activation call would be wrong as it will fail for Y as well 8818 -- but in Y's case the activation of T is never an ABE. 8819 8820 if Earlier_In_Extended_Unit (Root, Task_Attrs.Body_Decl) then 8821 8822 -- Do not emit any ABE diagnostics when the activation occurs in 8823 -- a partial finalization context because this leads to confusing 8824 -- noise. 8825 8826 if State.Within_Partial_Finalization then 8827 null; 8828 8829 -- ABE diagnostics are emitted only in the static model because 8830 -- there is a well-defined order to visiting scenarios. Without 8831 -- this order diagnostics appear jumbled and result in unwanted 8832 -- noise. 8833 8834 elsif Static_Elaboration_Checks 8835 and then Call_Attrs.Elab_Warnings_OK 8836 then 8837 Error_Msg_Sloc := Sloc (Call); 8838 Error_Msg_N 8839 ("??task & will be activated # before elaboration of its " 8840 & "body", Obj_Id); 8841 Error_Msg_N 8842 ("\Program_Error may be raised at run time", Obj_Id); 8843 8844 Output_Active_Scenarios (Obj_Id); 8845 end if; 8846 8847 -- Install a conditional run-time ABE check to verify that the 8848 -- task body has been elaborated prior to the activation call. 8849 8850 if Check_OK then 8851 Install_ABE_Check 8852 (N => Call, 8853 Ins_Nod => Call, 8854 Target_Id => Task_Attrs.Spec_Id, 8855 Target_Decl => Task_Attrs.Task_Decl, 8856 Target_Body => Task_Attrs.Body_Decl); 8857 8858 -- Update the state of the Processing phase to indicate that 8859 -- no implicit Elaborate[_All] pragmas must be generated from 8860 -- this point on. 8861 -- 8862 -- task type Task_Typ; 8863 -- 8864 -- function A ... is 8865 -- begin 8866 -- if Some_Condition then 8867 -- declare 8868 -- package Pack is 8869 -- <ABE check> 8870 -- T : Task_Typ; 8871 -- end Pack; -- activation of T 8872 -- ... 8873 -- end A; 8874 -- 8875 -- X : ... := A; 8876 -- 8877 -- task body Task_Typ is 8878 -- begin 8879 -- External.Subp; -- imparts Elaborate_All 8880 -- end Task_Typ; 8881 -- 8882 -- If Some_Condition is True, then the ABE check will fail at 8883 -- runtime and the call to External.Subp will never take place, 8884 -- rendering the implicit Elaborate_All useless. 8885 -- 8886 -- If Some_Condition is False, then the call to External.Subp 8887 -- will never take place, rendering the implicit Elaborate_All 8888 -- useless. 8889 8890 New_State.Suppress_Implicit_Pragmas := True; 8891 end if; 8892 end if; 8893 8894 -- Otherwise the task body is not available in this compilation or it 8895 -- resides in an external unit. Install a run-time ABE check to verify 8896 -- that the task body has been elaborated prior to the activation call 8897 -- when the dynamic model is in effect. 8898 8899 elsif Dynamic_Elaboration_Checks and then Check_OK then 8900 Install_ABE_Check 8901 (N => Call, 8902 Ins_Nod => Call, 8903 Id => Task_Attrs.Unit_Id); 8904 end if; 8905 8906 -- Update the state of the Processing phase to indicate that any further 8907 -- traversal is now within a task body. 8908 8909 New_State.Within_Task_Body := True; 8910 8911 -- Both the activation call and task type are subject to SPARK_Mode 8912 -- On, this triggers the SPARK rules for task activation. Compared to 8913 -- calls and instantiations, task activation in SPARK does not require 8914 -- the presence of Elaborate[_All] pragmas in case the task type is 8915 -- defined outside the main unit. This is because SPARK utilizes a 8916 -- special policy which activates all tasks after the main unit has 8917 -- finished its elaboration. 8918 8919 if Call_Attrs.SPARK_Mode_On and Task_Attrs.SPARK_Mode_On then 8920 null; 8921 8922 -- Otherwise the Ada rules are in effect. Ensure that the unit with the 8923 -- task body is elaborated prior to the main unit. 8924 8925 else 8926 Ensure_Prior_Elaboration 8927 (N => Call, 8928 Unit_Id => Task_Attrs.Unit_Id, 8929 Prag_Nam => Name_Elaborate_All, 8930 State => New_State); 8931 end if; 8932 8933 Traverse_Body 8934 (N => Task_Attrs.Body_Decl, 8935 State => New_State); 8936 end Process_Conditional_ABE_Activation_Impl; 8937 8938 procedure Process_Conditional_ABE_Activation is 8939 new Process_Activation_Generic (Process_Conditional_ABE_Activation_Impl); 8940 8941 ---------------------------------- 8942 -- Process_Conditional_ABE_Call -- 8943 ---------------------------------- 8944 8945 procedure Process_Conditional_ABE_Call 8946 (Call : Node_Id; 8947 Call_Attrs : Call_Attributes; 8948 Target_Id : Entity_Id; 8949 State : Processing_Attributes) 8950 is 8951 function In_Initialization_Context (N : Node_Id) return Boolean; 8952 -- Determine whether arbitrary node N appears within a type init proc, 8953 -- primitive [Deep_]Initialize, or a block created for initialization 8954 -- purposes. 8955 8956 function Is_Partial_Finalization_Proc return Boolean; 8957 pragma Inline (Is_Partial_Finalization_Proc); 8958 -- Determine whether call Call with target Target_Id invokes a partial 8959 -- finalization procedure. 8960 8961 ------------------------------- 8962 -- In_Initialization_Context -- 8963 ------------------------------- 8964 8965 function In_Initialization_Context (N : Node_Id) return Boolean is 8966 Par : Node_Id; 8967 Spec_Id : Entity_Id; 8968 8969 begin 8970 -- Climb the parent chain looking for initialization actions 8971 8972 Par := Parent (N); 8973 while Present (Par) loop 8974 8975 -- A block may be part of the initialization actions of a default 8976 -- initialized object. 8977 8978 if Nkind (Par) = N_Block_Statement 8979 and then Is_Initialization_Block (Par) 8980 then 8981 return True; 8982 8983 -- A subprogram body may denote an initialization routine 8984 8985 elsif Nkind (Par) = N_Subprogram_Body then 8986 Spec_Id := Unique_Defining_Entity (Par); 8987 8988 -- The current subprogram body denotes a type init proc or 8989 -- primitive [Deep_]Initialize. 8990 8991 if Is_Init_Proc (Spec_Id) 8992 or else Is_Controlled_Proc (Spec_Id, Name_Initialize) 8993 or else Is_TSS (Spec_Id, TSS_Deep_Initialize) 8994 then 8995 return True; 8996 end if; 8997 8998 -- Prevent the search from going too far 8999 9000 elsif Is_Body_Or_Package_Declaration (Par) then 9001 exit; 9002 end if; 9003 9004 Par := Parent (Par); 9005 end loop; 9006 9007 return False; 9008 end In_Initialization_Context; 9009 9010 ---------------------------------- 9011 -- Is_Partial_Finalization_Proc -- 9012 ---------------------------------- 9013 9014 function Is_Partial_Finalization_Proc return Boolean is 9015 begin 9016 -- To qualify, the target must denote primitive [Deep_]Finalize or a 9017 -- finalizer procedure, and the call must appear in an initialization 9018 -- context. 9019 9020 return 9021 (Is_Controlled_Proc (Target_Id, Name_Finalize) 9022 or else Is_Finalizer_Proc (Target_Id) 9023 or else Is_TSS (Target_Id, TSS_Deep_Finalize)) 9024 and then In_Initialization_Context (Call); 9025 end Is_Partial_Finalization_Proc; 9026 9027 -- Local variables 9028 9029 SPARK_Rules_On : Boolean; 9030 Target_Attrs : Target_Attributes; 9031 9032 New_State : Processing_Attributes := State; 9033 -- Each step of the Processing phase constitutes a new state 9034 9035 -- Start of processing for Process_Conditional_ABE_Call 9036 9037 begin 9038 Extract_Target_Attributes 9039 (Target_Id => Target_Id, 9040 Attrs => Target_Attrs); 9041 9042 -- The SPARK rules are in effect when both the call and target are 9043 -- subject to SPARK_Mode On. 9044 9045 SPARK_Rules_On := 9046 Call_Attrs.SPARK_Mode_On and Target_Attrs.SPARK_Mode_On; 9047 9048 -- Output relevant information when switch -gnatel (info messages on 9049 -- implicit Elaborate[_All] pragmas) is in effect. 9050 9051 if Elab_Info_Messages then 9052 Info_Call 9053 (Call => Call, 9054 Target_Id => Target_Id, 9055 Info_Msg => True, 9056 In_SPARK => SPARK_Rules_On); 9057 end if; 9058 9059 -- Check whether the invocation of an entry clashes with an existing 9060 -- restriction. 9061 9062 if Is_Protected_Entry (Target_Id) then 9063 Check_Restriction (No_Entry_Calls_In_Elaboration_Code, Call); 9064 9065 elsif Is_Task_Entry (Target_Id) then 9066 Check_Restriction (No_Entry_Calls_In_Elaboration_Code, Call); 9067 9068 -- Task entry calls are never processed because the entry being 9069 -- invoked does not have a corresponding "body", it has a select. 9070 9071 return; 9072 end if; 9073 9074 -- Nothing to do when the call invokes a target defined within an 9075 -- instance and switch -gnatd_i (ignore activations and calls to 9076 -- instances for elaboration) is in effect. 9077 9078 if Debug_Flag_Underscore_I 9079 and then In_External_Instance 9080 (N => Call, 9081 Target_Decl => Target_Attrs.Spec_Decl) 9082 then 9083 return; 9084 9085 -- Nothing to do when the call is a guaranteed ABE 9086 9087 elsif Is_Known_Guaranteed_ABE (Call) then 9088 return; 9089 9090 -- Nothing to do when the root scenario appears at the declaration level 9091 -- and the target is in the same unit, but outside this context. 9092 -- 9093 -- function B ...; -- target declaration 9094 -- 9095 -- procedure Proc is 9096 -- function A ... is 9097 -- begin 9098 -- if Some_Condition then 9099 -- return B; -- call site 9100 -- ... 9101 -- end A; 9102 -- 9103 -- X : ... := A; -- root scenario 9104 -- ... 9105 -- 9106 -- function B ... is 9107 -- ... 9108 -- end B; 9109 -- 9110 -- In the example above, the context of X is the declarative region of 9111 -- Proc. The "elaboration" of X may eventually reach B which is defined 9112 -- outside of X's context. B is relevant only when Proc is invoked, but 9113 -- this happens only by means of "normal" elaboration, therefore B must 9114 -- not be considered if this is not the case. 9115 9116 -- Performance note: parent traversal 9117 9118 elsif Is_Up_Level_Target (Target_Attrs.Spec_Decl) then 9119 return; 9120 end if; 9121 9122 -- The call occurs in an initial condition context when a prior scenario 9123 -- is already in that mode, or when the target is an Initial_Condition 9124 -- procedure. Update the state of the Processing phase to reflect this. 9125 9126 New_State.Within_Initial_Condition := 9127 New_State.Within_Initial_Condition 9128 or else Is_Initial_Condition_Proc (Target_Id); 9129 9130 -- The call occurs in a partial finalization context when a prior 9131 -- scenario is already in that mode, or when the target denotes a 9132 -- [Deep_]Finalize primitive or a finalizer within an initialization 9133 -- context. Update the state of the Processing phase to reflect this. 9134 9135 New_State.Within_Partial_Finalization := 9136 New_State.Within_Partial_Finalization 9137 or else Is_Partial_Finalization_Proc; 9138 9139 -- The SPARK rules are in effect. Note that -gnatd.v (enforce SPARK 9140 -- elaboration rules in SPARK code) is intentionally not taken into 9141 -- account here because Process_Conditional_ABE_Call_SPARK has two 9142 -- separate modes of operation. 9143 9144 if SPARK_Rules_On then 9145 Process_Conditional_ABE_Call_SPARK 9146 (Call => Call, 9147 Target_Id => Target_Id, 9148 Target_Attrs => Target_Attrs, 9149 State => New_State); 9150 9151 -- Otherwise the Ada rules are in effect 9152 9153 else 9154 Process_Conditional_ABE_Call_Ada 9155 (Call => Call, 9156 Call_Attrs => Call_Attrs, 9157 Target_Id => Target_Id, 9158 Target_Attrs => Target_Attrs, 9159 State => New_State); 9160 end if; 9161 9162 -- Inspect the target body (and barried function) for other suitable 9163 -- elaboration scenarios. 9164 9165 Traverse_Body 9166 (N => Target_Attrs.Body_Barf, 9167 State => New_State); 9168 9169 Traverse_Body 9170 (N => Target_Attrs.Body_Decl, 9171 State => New_State); 9172 end Process_Conditional_ABE_Call; 9173 9174 -------------------------------------- 9175 -- Process_Conditional_ABE_Call_Ada -- 9176 -------------------------------------- 9177 9178 procedure Process_Conditional_ABE_Call_Ada 9179 (Call : Node_Id; 9180 Call_Attrs : Call_Attributes; 9181 Target_Id : Entity_Id; 9182 Target_Attrs : Target_Attributes; 9183 State : Processing_Attributes) 9184 is 9185 Check_OK : constant Boolean := 9186 not Call_Attrs.Ghost_Mode_Ignore 9187 and then not Target_Attrs.Ghost_Mode_Ignore 9188 and then Call_Attrs.Elab_Checks_OK 9189 and then Target_Attrs.Elab_Checks_OK; 9190 -- A run-time ABE check may be installed only when both the call and the 9191 -- target have active elaboration checks, and both are not ignored Ghost 9192 -- constructs. 9193 9194 Root : constant Node_Id := Root_Scenario; 9195 9196 New_State : Processing_Attributes := State; 9197 -- Each step of the Processing phase constitutes a new state 9198 9199 begin 9200 -- Nothing to do for an Ada dispatching call because there are no ABE 9201 -- diagnostics for either models. ABE checks for the dynamic model are 9202 -- handled by Install_Primitive_Elaboration_Check. 9203 9204 if Call_Attrs.Is_Dispatching then 9205 return; 9206 9207 -- Nothing to do when the call is ABE-safe 9208 -- 9209 -- generic 9210 -- function Gen ...; 9211 -- 9212 -- function Gen ... is 9213 -- begin 9214 -- ... 9215 -- end Gen; 9216 -- 9217 -- with Gen; 9218 -- procedure Main is 9219 -- function Inst is new Gen; 9220 -- X : ... := Inst; -- safe call 9221 -- ... 9222 9223 elsif Is_Safe_Call (Call, Target_Attrs) then 9224 return; 9225 9226 -- The call and the target body are both in the main unit 9227 9228 elsif Present (Target_Attrs.Body_Decl) 9229 and then In_Extended_Main_Code_Unit (Target_Attrs.Body_Decl) 9230 then 9231 -- If the root scenario appears prior to the target body, then this 9232 -- is a possible ABE with respect to the root scenario. 9233 -- 9234 -- function B ...; 9235 -- 9236 -- function A ... is 9237 -- begin 9238 -- if Some_Condition then 9239 -- return B; -- call site 9240 -- ... 9241 -- end A; 9242 -- 9243 -- X : ... := A; -- root scenario 9244 -- 9245 -- function B ... is -- target body 9246 -- ... 9247 -- end B; 9248 -- 9249 -- Y : ... := A; -- root scenario 9250 -- 9251 -- IMPORTANT: The call to B from A is a possible ABE for X, but not 9252 -- for Y. Installing an unconditional ABE raise prior to the call to 9253 -- B would be wrong as it will fail for Y as well, but in Y's case 9254 -- the call to B is never an ABE. 9255 9256 if Earlier_In_Extended_Unit (Root, Target_Attrs.Body_Decl) then 9257 9258 -- Do not emit any ABE diagnostics when the call occurs in a 9259 -- partial finalization context because this leads to confusing 9260 -- noise. 9261 9262 if State.Within_Partial_Finalization then 9263 null; 9264 9265 -- ABE diagnostics are emitted only in the static model because 9266 -- there is a well-defined order to visiting scenarios. Without 9267 -- this order diagnostics appear jumbled and result in unwanted 9268 -- noise. 9269 9270 elsif Static_Elaboration_Checks 9271 and then Call_Attrs.Elab_Warnings_OK 9272 then 9273 Error_Msg_NE 9274 ("??cannot call & before body seen", Call, Target_Id); 9275 Error_Msg_N ("\Program_Error may be raised at run time", Call); 9276 9277 Output_Active_Scenarios (Call); 9278 end if; 9279 9280 -- Install a conditional run-time ABE check to verify that the 9281 -- target body has been elaborated prior to the call. 9282 9283 if Check_OK then 9284 Install_ABE_Check 9285 (N => Call, 9286 Ins_Nod => Call, 9287 Target_Id => Target_Attrs.Spec_Id, 9288 Target_Decl => Target_Attrs.Spec_Decl, 9289 Target_Body => Target_Attrs.Body_Decl); 9290 9291 -- Update the state of the Processing phase to indicate that 9292 -- no implicit Elaborate[_All] pragmas must be generated from 9293 -- this point on. 9294 -- 9295 -- function B ...; 9296 -- 9297 -- function A ... is 9298 -- begin 9299 -- if Some_Condition then 9300 -- <ABE check> 9301 -- return B; 9302 -- ... 9303 -- end A; 9304 -- 9305 -- X : ... := A; 9306 -- 9307 -- function B ... is 9308 -- External.Subp; -- imparts Elaborate_All 9309 -- end B; 9310 -- 9311 -- If Some_Condition is True, then the ABE check will fail at 9312 -- runtime and the call to External.Subp will never take place, 9313 -- rendering the implicit Elaborate_All useless. 9314 -- 9315 -- If Some_Condition is False, then the call to External.Subp 9316 -- will never take place, rendering the implicit Elaborate_All 9317 -- useless. 9318 9319 New_State.Suppress_Implicit_Pragmas := True; 9320 end if; 9321 end if; 9322 9323 -- Otherwise the target body is not available in this compilation or it 9324 -- resides in an external unit. Install a run-time ABE check to verify 9325 -- that the target body has been elaborated prior to the call site when 9326 -- the dynamic model is in effect. 9327 9328 elsif Dynamic_Elaboration_Checks and then Check_OK then 9329 Install_ABE_Check 9330 (N => Call, 9331 Ins_Nod => Call, 9332 Id => Target_Attrs.Unit_Id); 9333 end if; 9334 9335 -- Ensure that the unit with the target body is elaborated prior to the 9336 -- main unit. The implicit Elaborate[_All] is generated only when the 9337 -- call has elaboration checks enabled. This behaviour parallels that of 9338 -- the old ABE mechanism. 9339 9340 if Call_Attrs.Elab_Checks_OK then 9341 Ensure_Prior_Elaboration 9342 (N => Call, 9343 Unit_Id => Target_Attrs.Unit_Id, 9344 Prag_Nam => Name_Elaborate_All, 9345 State => New_State); 9346 end if; 9347 end Process_Conditional_ABE_Call_Ada; 9348 9349 ---------------------------------------- 9350 -- Process_Conditional_ABE_Call_SPARK -- 9351 ---------------------------------------- 9352 9353 procedure Process_Conditional_ABE_Call_SPARK 9354 (Call : Node_Id; 9355 Target_Id : Entity_Id; 9356 Target_Attrs : Target_Attributes; 9357 State : Processing_Attributes) 9358 is 9359 Region : Node_Id; 9360 9361 begin 9362 -- Ensure that a suitable elaboration model is in effect for SPARK rule 9363 -- verification. 9364 9365 Check_SPARK_Model_In_Effect (Call); 9366 9367 -- The call and the target body are both in the main unit 9368 9369 if Present (Target_Attrs.Body_Decl) 9370 and then In_Extended_Main_Code_Unit (Target_Attrs.Body_Decl) 9371 then 9372 -- If the call appears prior to the target body, then the call must 9373 -- appear within the early call region of the target body. 9374 -- 9375 -- function B ...; 9376 -- 9377 -- X : ... := B; -- call site 9378 -- 9379 -- <preelaborable construct 1> --+ 9380 -- ... | early call region 9381 -- <preelaborable construct N> --+ 9382 -- 9383 -- function B ... is -- target body 9384 -- ... 9385 -- end B; 9386 -- 9387 -- When the call to B is not nested within some other scenario, the 9388 -- call is automatically illegal because it can never appear in the 9389 -- early call region of B's body. This is equivalent to a guaranteed 9390 -- ABE. 9391 -- 9392 -- <preelaborable construct 1> --+ 9393 -- | 9394 -- function B ...; | 9395 -- | 9396 -- function A ... is | 9397 -- begin | early call region 9398 -- if Some_Condition then 9399 -- return B; -- call site 9400 -- ... 9401 -- end A; | 9402 -- | 9403 -- <preelaborable construct N> --+ 9404 -- 9405 -- function B ... is -- target body 9406 -- ... 9407 -- end B; 9408 -- 9409 -- When the call to B is nested within some other scenario, the call 9410 -- is always ABE-safe. It is not immediately obvious why this is the 9411 -- case. The elaboration safety follows from the early call region 9412 -- rule being applied to ALL calls preceding their associated bodies. 9413 -- 9414 -- In the example above, the call to B is safe as long as the call to 9415 -- A is safe. There are several cases to consider: 9416 -- 9417 -- <call 1 to A> 9418 -- function B ...; 9419 -- 9420 -- <call 2 to A> 9421 -- function A ... is 9422 -- begin 9423 -- if Some_Condition then 9424 -- return B; 9425 -- ... 9426 -- end A; 9427 -- 9428 -- <call 3 to A> 9429 -- function B ... is 9430 -- ... 9431 -- end B; 9432 -- 9433 -- * Call 1 - This call is either nested within some scenario or not, 9434 -- which falls under the two general cases outlined above. 9435 -- 9436 -- * Call 2 - This is the same case as Call 1. 9437 -- 9438 -- * Call 3 - The placement of this call limits the range of B's 9439 -- early call region unto call 3, therefore the call to B is no 9440 -- longer within the early call region of B's body, making it ABE- 9441 -- unsafe and therefore illegal. 9442 9443 if Earlier_In_Extended_Unit (Call, Target_Attrs.Body_Decl) then 9444 9445 -- Do not emit any ABE diagnostics when the call occurs in an 9446 -- initial condition context because this leads to incorrect 9447 -- diagnostics. 9448 9449 if State.Within_Initial_Condition then 9450 null; 9451 9452 -- Do not emit any ABE diagnostics when the call occurs in a 9453 -- partial finalization context because this leads to confusing 9454 -- noise. 9455 9456 elsif State.Within_Partial_Finalization then 9457 null; 9458 9459 -- ABE diagnostics are emitted only in the static model because 9460 -- there is a well-defined order to visiting scenarios. Without 9461 -- this order diagnostics appear jumbled and result in unwanted 9462 -- noise. 9463 9464 elsif Static_Elaboration_Checks then 9465 9466 -- Ensure that a call which textually precedes the subprogram 9467 -- body it invokes appears within the early call region of the 9468 -- subprogram body. 9469 9470 -- IMPORTANT: This check must always be performed even when 9471 -- -gnatd.v (enforce SPARK elaboration rules in SPARK code) is 9472 -- not specified because the static model cannot guarantee the 9473 -- absence of elaboration issues in the presence of dispatching 9474 -- calls. 9475 9476 Region := Find_Early_Call_Region (Target_Attrs.Body_Decl); 9477 9478 if Earlier_In_Extended_Unit (Call, Region) then 9479 Error_Msg_NE 9480 ("call must appear within early call region of subprogram " 9481 & "body & (SPARK RM 7.7(3))", Call, Target_Id); 9482 9483 Error_Msg_Sloc := Sloc (Region); 9484 Error_Msg_N ("\region starts #", Call); 9485 9486 Error_Msg_Sloc := Sloc (Target_Attrs.Body_Decl); 9487 Error_Msg_N ("\region ends #", Call); 9488 9489 Output_Active_Scenarios (Call); 9490 end if; 9491 end if; 9492 9493 -- Otherwise the call appears after the target body. The call is 9494 -- ABE-safe as a consequence of applying the early call region rule 9495 -- to ALL calls preceding their associated bodies. 9496 9497 else 9498 null; 9499 end if; 9500 end if; 9501 9502 -- A call to a source target or to a target which emulates Ada or SPARK 9503 -- semantics imposes an Elaborate_All requirement on the context of the 9504 -- main unit. Determine whether the context has a pragma strong enough 9505 -- to meet the requirement. 9506 9507 -- IMPORTANT: This check must be performed only when -gnatd.v (enforce 9508 -- SPARK elaboration rules in SPARK code) is active because the static 9509 -- model can ensure the prior elaboration of the unit which contains a 9510 -- body by installing an implicit Elaborate[_All] pragma. 9511 9512 if Debug_Flag_Dot_V then 9513 if Target_Attrs.From_Source 9514 or else Is_Ada_Semantic_Target (Target_Id) 9515 or else Is_SPARK_Semantic_Target (Target_Id) 9516 then 9517 Meet_Elaboration_Requirement 9518 (N => Call, 9519 Target_Id => Target_Id, 9520 Req_Nam => Name_Elaborate_All); 9521 end if; 9522 9523 -- Otherwise ensure that the unit with the target body is elaborated 9524 -- prior to the main unit. 9525 9526 else 9527 Ensure_Prior_Elaboration 9528 (N => Call, 9529 Unit_Id => Target_Attrs.Unit_Id, 9530 Prag_Nam => Name_Elaborate_All, 9531 State => State); 9532 end if; 9533 end Process_Conditional_ABE_Call_SPARK; 9534 9535 ------------------------------------------- 9536 -- Process_Conditional_ABE_Instantiation -- 9537 ------------------------------------------- 9538 9539 procedure Process_Conditional_ABE_Instantiation 9540 (Exp_Inst : Node_Id; 9541 State : Processing_Attributes) 9542 is 9543 Gen_Attrs : Target_Attributes; 9544 Gen_Id : Entity_Id; 9545 Inst : Node_Id; 9546 Inst_Attrs : Instantiation_Attributes; 9547 Inst_Id : Entity_Id; 9548 9549 SPARK_Rules_On : Boolean; 9550 -- This flag is set when the SPARK rules are in effect 9551 9552 begin 9553 Extract_Instantiation_Attributes 9554 (Exp_Inst => Exp_Inst, 9555 Inst => Inst, 9556 Inst_Id => Inst_Id, 9557 Gen_Id => Gen_Id, 9558 Attrs => Inst_Attrs); 9559 9560 Extract_Target_Attributes (Gen_Id, Gen_Attrs); 9561 9562 -- The SPARK rules are in effect when both the instantiation and generic 9563 -- are subject to SPARK_Mode On. 9564 9565 SPARK_Rules_On := Inst_Attrs.SPARK_Mode_On and Gen_Attrs.SPARK_Mode_On; 9566 9567 -- Output relevant information when switch -gnatel (info messages on 9568 -- implicit Elaborate[_All] pragmas) is in effect. 9569 9570 if Elab_Info_Messages then 9571 Info_Instantiation 9572 (Inst => Inst, 9573 Gen_Id => Gen_Id, 9574 Info_Msg => True, 9575 In_SPARK => SPARK_Rules_On); 9576 end if; 9577 9578 -- Nothing to do when the instantiation is a guaranteed ABE 9579 9580 if Is_Known_Guaranteed_ABE (Inst) then 9581 return; 9582 9583 -- Nothing to do when the root scenario appears at the declaration level 9584 -- and the generic is in the same unit, but outside this context. 9585 -- 9586 -- generic 9587 -- procedure Gen is ...; -- generic declaration 9588 -- 9589 -- procedure Proc is 9590 -- function A ... is 9591 -- begin 9592 -- if Some_Condition then 9593 -- declare 9594 -- procedure I is new Gen; -- instantiation site 9595 -- ... 9596 -- ... 9597 -- end A; 9598 -- 9599 -- X : ... := A; -- root scenario 9600 -- ... 9601 -- 9602 -- procedure Gen is 9603 -- ... 9604 -- end Gen; 9605 -- 9606 -- In the example above, the context of X is the declarative region of 9607 -- Proc. The "elaboration" of X may eventually reach Gen which appears 9608 -- outside of X's context. Gen is relevant only when Proc is invoked, 9609 -- but this happens only by means of "normal" elaboration, therefore 9610 -- Gen must not be considered if this is not the case. 9611 9612 -- Performance note: parent traversal 9613 9614 elsif Is_Up_Level_Target (Gen_Attrs.Spec_Decl) then 9615 return; 9616 9617 -- The SPARK rules are in effect 9618 9619 elsif SPARK_Rules_On then 9620 Process_Conditional_ABE_Instantiation_SPARK 9621 (Inst => Inst, 9622 Gen_Id => Gen_Id, 9623 Gen_Attrs => Gen_Attrs, 9624 State => State); 9625 9626 -- Otherwise the Ada rules are in effect, or SPARK code is allowed to 9627 -- violate the SPARK rules. 9628 9629 else 9630 Process_Conditional_ABE_Instantiation_Ada 9631 (Exp_Inst => Exp_Inst, 9632 Inst => Inst, 9633 Inst_Attrs => Inst_Attrs, 9634 Gen_Id => Gen_Id, 9635 Gen_Attrs => Gen_Attrs, 9636 State => State); 9637 end if; 9638 end Process_Conditional_ABE_Instantiation; 9639 9640 ----------------------------------------------- 9641 -- Process_Conditional_ABE_Instantiation_Ada -- 9642 ----------------------------------------------- 9643 9644 procedure Process_Conditional_ABE_Instantiation_Ada 9645 (Exp_Inst : Node_Id; 9646 Inst : Node_Id; 9647 Inst_Attrs : Instantiation_Attributes; 9648 Gen_Id : Entity_Id; 9649 Gen_Attrs : Target_Attributes; 9650 State : Processing_Attributes) 9651 is 9652 Check_OK : constant Boolean := 9653 not Inst_Attrs.Ghost_Mode_Ignore 9654 and then not Gen_Attrs.Ghost_Mode_Ignore 9655 and then Inst_Attrs.Elab_Checks_OK 9656 and then Gen_Attrs.Elab_Checks_OK; 9657 -- A run-time ABE check may be installed only when both the instance and 9658 -- the generic have active elaboration checks and both are not ignored 9659 -- Ghost constructs. 9660 9661 New_State : Processing_Attributes := State; 9662 -- Each step of the Processing phase constitutes a new state 9663 9664 Root : constant Node_Id := Root_Scenario; 9665 9666 begin 9667 -- Nothing to do when the instantiation is ABE-safe 9668 -- 9669 -- generic 9670 -- package Gen is 9671 -- ... 9672 -- end Gen; 9673 -- 9674 -- package body Gen is 9675 -- ... 9676 -- end Gen; 9677 -- 9678 -- with Gen; 9679 -- procedure Main is 9680 -- package Inst is new Gen (ABE); -- safe instantiation 9681 -- ... 9682 9683 if Is_Safe_Instantiation (Inst, Gen_Attrs) then 9684 return; 9685 9686 -- The instantiation and the generic body are both in the main unit 9687 9688 elsif Present (Gen_Attrs.Body_Decl) 9689 and then In_Extended_Main_Code_Unit (Gen_Attrs.Body_Decl) 9690 then 9691 -- If the root scenario appears prior to the generic body, then this 9692 -- is a possible ABE with respect to the root scenario. 9693 -- 9694 -- generic 9695 -- package Gen is 9696 -- ... 9697 -- end Gen; 9698 -- 9699 -- function A ... is 9700 -- begin 9701 -- if Some_Condition then 9702 -- declare 9703 -- package Inst is new Gen; -- instantiation site 9704 -- ... 9705 -- end A; 9706 -- 9707 -- X : ... := A; -- root scenario 9708 -- 9709 -- package body Gen is -- generic body 9710 -- ... 9711 -- end Gen; 9712 -- 9713 -- Y : ... := A; -- root scenario 9714 -- 9715 -- IMPORTANT: The instantiation of Gen is a possible ABE for X, but 9716 -- not for Y. Installing an unconditional ABE raise prior to the 9717 -- instance site would be wrong as it will fail for Y as well, but in 9718 -- Y's case the instantiation of Gen is never an ABE. 9719 9720 if Earlier_In_Extended_Unit (Root, Gen_Attrs.Body_Decl) then 9721 9722 -- Do not emit any ABE diagnostics when the instantiation occurs 9723 -- in partial finalization context because this leads to unwanted 9724 -- noise. 9725 9726 if State.Within_Partial_Finalization then 9727 null; 9728 9729 -- ABE diagnostics are emitted only in the static model because 9730 -- there is a well-defined order to visiting scenarios. Without 9731 -- this order diagnostics appear jumbled and result in unwanted 9732 -- noise. 9733 9734 elsif Static_Elaboration_Checks 9735 and then Inst_Attrs.Elab_Warnings_OK 9736 then 9737 Error_Msg_NE 9738 ("??cannot instantiate & before body seen", Inst, Gen_Id); 9739 Error_Msg_N ("\Program_Error may be raised at run time", Inst); 9740 9741 Output_Active_Scenarios (Inst); 9742 end if; 9743 9744 -- Install a conditional run-time ABE check to verify that the 9745 -- generic body has been elaborated prior to the instantiation. 9746 9747 if Check_OK then 9748 Install_ABE_Check 9749 (N => Inst, 9750 Ins_Nod => Exp_Inst, 9751 Target_Id => Gen_Attrs.Spec_Id, 9752 Target_Decl => Gen_Attrs.Spec_Decl, 9753 Target_Body => Gen_Attrs.Body_Decl); 9754 9755 -- Update the state of the Processing phase to indicate that 9756 -- no implicit Elaborate[_All] pragmas must be generated from 9757 -- this point on. 9758 -- 9759 -- generic 9760 -- package Gen is 9761 -- ... 9762 -- end Gen; 9763 -- 9764 -- function A ... is 9765 -- begin 9766 -- if Some_Condition then 9767 -- <ABE check> 9768 -- declare Inst is new Gen; 9769 -- ... 9770 -- end A; 9771 -- 9772 -- X : ... := A; 9773 -- 9774 -- package body Gen is 9775 -- begin 9776 -- External.Subp; -- imparts Elaborate_All 9777 -- end Gen; 9778 -- 9779 -- If Some_Condition is True, then the ABE check will fail at 9780 -- runtime and the call to External.Subp will never take place, 9781 -- rendering the implicit Elaborate_All useless. 9782 -- 9783 -- If Some_Condition is False, then the call to External.Subp 9784 -- will never take place, rendering the implicit Elaborate_All 9785 -- useless. 9786 9787 New_State.Suppress_Implicit_Pragmas := True; 9788 end if; 9789 end if; 9790 9791 -- Otherwise the generic body is not available in this compilation or it 9792 -- resides in an external unit. Install a run-time ABE check to verify 9793 -- that the generic body has been elaborated prior to the instantiation 9794 -- when the dynamic model is in effect. 9795 9796 elsif Dynamic_Elaboration_Checks and then Check_OK then 9797 Install_ABE_Check 9798 (N => Inst, 9799 Ins_Nod => Exp_Inst, 9800 Id => Gen_Attrs.Unit_Id); 9801 end if; 9802 9803 -- Ensure that the unit with the generic body is elaborated prior to 9804 -- the main unit. No implicit pragma is generated if the instantiation 9805 -- has elaboration checks suppressed. This behaviour parallels that of 9806 -- the old ABE mechanism. 9807 9808 if Inst_Attrs.Elab_Checks_OK then 9809 Ensure_Prior_Elaboration 9810 (N => Inst, 9811 Unit_Id => Gen_Attrs.Unit_Id, 9812 Prag_Nam => Name_Elaborate, 9813 State => New_State); 9814 end if; 9815 end Process_Conditional_ABE_Instantiation_Ada; 9816 9817 ------------------------------------------------- 9818 -- Process_Conditional_ABE_Instantiation_SPARK -- 9819 ------------------------------------------------- 9820 9821 procedure Process_Conditional_ABE_Instantiation_SPARK 9822 (Inst : Node_Id; 9823 Gen_Id : Entity_Id; 9824 Gen_Attrs : Target_Attributes; 9825 State : Processing_Attributes) 9826 is 9827 Req_Nam : Name_Id; 9828 9829 begin 9830 -- Ensure that a suitable elaboration model is in effect for SPARK rule 9831 -- verification. 9832 9833 Check_SPARK_Model_In_Effect (Inst); 9834 9835 -- A source instantiation imposes an Elaborate[_All] requirement on the 9836 -- context of the main unit. Determine whether the context has a pragma 9837 -- strong enough to meet the requirement. The check is orthogonal to the 9838 -- ABE ramifications of the instantiation. 9839 9840 -- IMPORTANT: This check must be performed only when -gnatd.v (enforce 9841 -- SPARK elaboration rules in SPARK code) is active because the static 9842 -- model can ensure the prior elaboration of the unit which contains a 9843 -- body by installing an implicit Elaborate[_All] pragma. 9844 9845 if Debug_Flag_Dot_V then 9846 if Nkind (Inst) = N_Package_Instantiation then 9847 Req_Nam := Name_Elaborate_All; 9848 else 9849 Req_Nam := Name_Elaborate; 9850 end if; 9851 9852 Meet_Elaboration_Requirement 9853 (N => Inst, 9854 Target_Id => Gen_Id, 9855 Req_Nam => Req_Nam); 9856 9857 -- Otherwise ensure that the unit with the target body is elaborated 9858 -- prior to the main unit. 9859 9860 else 9861 Ensure_Prior_Elaboration 9862 (N => Inst, 9863 Unit_Id => Gen_Attrs.Unit_Id, 9864 Prag_Nam => Name_Elaborate, 9865 State => State); 9866 end if; 9867 end Process_Conditional_ABE_Instantiation_SPARK; 9868 9869 ------------------------------------------------- 9870 -- Process_Conditional_ABE_Variable_Assignment -- 9871 ------------------------------------------------- 9872 9873 procedure Process_Conditional_ABE_Variable_Assignment (Asmt : Node_Id) is 9874 Var_Id : constant Entity_Id := Entity (Extract_Assignment_Name (Asmt)); 9875 Prag : constant Node_Id := SPARK_Pragma (Var_Id); 9876 9877 SPARK_Rules_On : Boolean; 9878 -- This flag is set when the SPARK rules are in effect 9879 9880 begin 9881 -- The SPARK rules are in effect when both the assignment and the 9882 -- variable are subject to SPARK_Mode On. 9883 9884 SPARK_Rules_On := 9885 Present (Prag) 9886 and then Get_SPARK_Mode_From_Annotation (Prag) = On 9887 and then Is_SPARK_Mode_On_Node (Asmt); 9888 9889 -- Output relevant information when switch -gnatel (info messages on 9890 -- implicit Elaborate[_All] pragmas) is in effect. 9891 9892 if Elab_Info_Messages then 9893 Elab_Msg_NE 9894 (Msg => "assignment to & during elaboration", 9895 N => Asmt, 9896 Id => Var_Id, 9897 Info_Msg => True, 9898 In_SPARK => SPARK_Rules_On); 9899 end if; 9900 9901 -- The SPARK rules are in effect. These rules are applied regardless of 9902 -- whether -gnatd.v (enforce SPARK elaboration rules in SPARK code) is 9903 -- in effect because the static model cannot ensure safe assignment of 9904 -- variables. 9905 9906 if SPARK_Rules_On then 9907 Process_Conditional_ABE_Variable_Assignment_SPARK 9908 (Asmt => Asmt, 9909 Var_Id => Var_Id); 9910 9911 -- Otherwise the Ada rules are in effect 9912 9913 else 9914 Process_Conditional_ABE_Variable_Assignment_Ada 9915 (Asmt => Asmt, 9916 Var_Id => Var_Id); 9917 end if; 9918 end Process_Conditional_ABE_Variable_Assignment; 9919 9920 ----------------------------------------------------- 9921 -- Process_Conditional_ABE_Variable_Assignment_Ada -- 9922 ----------------------------------------------------- 9923 9924 procedure Process_Conditional_ABE_Variable_Assignment_Ada 9925 (Asmt : Node_Id; 9926 Var_Id : Entity_Id) 9927 is 9928 Var_Decl : constant Node_Id := Declaration_Node (Var_Id); 9929 Spec_Id : constant Entity_Id := Find_Top_Unit (Var_Decl); 9930 9931 begin 9932 -- Emit a warning when an uninitialized variable declared in a package 9933 -- spec without a pragma Elaborate_Body is initialized by elaboration 9934 -- code within the corresponding body. 9935 9936 if not Warnings_Off (Var_Id) 9937 and then not Is_Initialized (Var_Decl) 9938 and then not Has_Pragma_Elaborate_Body (Spec_Id) 9939 then 9940 Error_Msg_NE 9941 ("??variable & can be accessed by clients before this " 9942 & "initialization", Asmt, Var_Id); 9943 9944 Error_Msg_NE 9945 ("\add pragma ""Elaborate_Body"" to spec & to ensure proper " 9946 & "initialization", Asmt, Spec_Id); 9947 9948 Output_Active_Scenarios (Asmt); 9949 9950 -- Generate an implicit Elaborate_Body in the spec 9951 9952 Set_Elaborate_Body_Desirable (Spec_Id); 9953 end if; 9954 end Process_Conditional_ABE_Variable_Assignment_Ada; 9955 9956 ------------------------------------------------------- 9957 -- Process_Conditional_ABE_Variable_Assignment_SPARK -- 9958 ------------------------------------------------------- 9959 9960 procedure Process_Conditional_ABE_Variable_Assignment_SPARK 9961 (Asmt : Node_Id; 9962 Var_Id : Entity_Id) 9963 is 9964 Var_Decl : constant Node_Id := Declaration_Node (Var_Id); 9965 Spec_Id : constant Entity_Id := Find_Top_Unit (Var_Decl); 9966 9967 begin 9968 -- Ensure that a suitable elaboration model is in effect for SPARK rule 9969 -- verification. 9970 9971 Check_SPARK_Model_In_Effect (Asmt); 9972 9973 -- Emit an error when an initialized variable declared in a package spec 9974 -- without pragma Elaborate_Body is further modified by elaboration code 9975 -- within the corresponding body. 9976 9977 if Is_Initialized (Var_Decl) 9978 and then not Has_Pragma_Elaborate_Body (Spec_Id) 9979 then 9980 Error_Msg_NE 9981 ("variable & modified by elaboration code in package body", 9982 Asmt, Var_Id); 9983 9984 Error_Msg_NE 9985 ("\add pragma ""Elaborate_Body"" to spec & to ensure full " 9986 & "initialization", Asmt, Spec_Id); 9987 9988 Output_Active_Scenarios (Asmt); 9989 end if; 9990 end Process_Conditional_ABE_Variable_Assignment_SPARK; 9991 9992 ------------------------------------------------ 9993 -- Process_Conditional_ABE_Variable_Reference -- 9994 ------------------------------------------------ 9995 9996 procedure Process_Conditional_ABE_Variable_Reference (Ref : Node_Id) is 9997 Var_Attrs : Variable_Attributes; 9998 Var_Id : Entity_Id; 9999 10000 begin 10001 Extract_Variable_Reference_Attributes 10002 (Ref => Ref, 10003 Var_Id => Var_Id, 10004 Attrs => Var_Attrs); 10005 10006 if Is_Read (Ref) then 10007 Process_Conditional_ABE_Variable_Reference_Read 10008 (Ref => Ref, 10009 Var_Id => Var_Id, 10010 Attrs => Var_Attrs); 10011 end if; 10012 end Process_Conditional_ABE_Variable_Reference; 10013 10014 ----------------------------------------------------- 10015 -- Process_Conditional_ABE_Variable_Reference_Read -- 10016 ----------------------------------------------------- 10017 10018 procedure Process_Conditional_ABE_Variable_Reference_Read 10019 (Ref : Node_Id; 10020 Var_Id : Entity_Id; 10021 Attrs : Variable_Attributes) 10022 is 10023 begin 10024 -- Output relevant information when switch -gnatel (info messages on 10025 -- implicit Elaborate[_All] pragmas) is in effect. 10026 10027 if Elab_Info_Messages then 10028 Elab_Msg_NE 10029 (Msg => "read of variable & during elaboration", 10030 N => Ref, 10031 Id => Var_Id, 10032 Info_Msg => True, 10033 In_SPARK => True); 10034 end if; 10035 10036 -- Nothing to do when the variable appears within the main unit because 10037 -- diagnostics on reads are relevant only for external variables. 10038 10039 if Is_Same_Unit (Attrs.Unit_Id, Cunit_Entity (Main_Unit)) then 10040 null; 10041 10042 -- Nothing to do when the variable is already initialized. Note that the 10043 -- variable may be further modified by the external unit. 10044 10045 elsif Is_Initialized (Declaration_Node (Var_Id)) then 10046 null; 10047 10048 -- Nothing to do when the external unit guarantees the initialization of 10049 -- the variable by means of pragma Elaborate_Body. 10050 10051 elsif Has_Pragma_Elaborate_Body (Attrs.Unit_Id) then 10052 null; 10053 10054 -- A variable read imposes an Elaborate requirement on the context of 10055 -- the main unit. Determine whether the context has a pragma strong 10056 -- enough to meet the requirement. 10057 10058 else 10059 Meet_Elaboration_Requirement 10060 (N => Ref, 10061 Target_Id => Var_Id, 10062 Req_Nam => Name_Elaborate); 10063 end if; 10064 end Process_Conditional_ABE_Variable_Reference_Read; 10065 10066 ----------------------------- 10067 -- Process_Conditional_ABE -- 10068 ----------------------------- 10069 10070 -- NOTE: The body of this routine is intentionally out of order because it 10071 -- invokes an instantiated subprogram (Process_Conditional_ABE_Activation). 10072 -- Placing the body in alphabetical order will result in a guaranteed ABE. 10073 10074 procedure Process_Conditional_ABE 10075 (N : Node_Id; 10076 State : Processing_Attributes := Initial_State) 10077 is 10078 Call_Attrs : Call_Attributes; 10079 Target_Id : Entity_Id; 10080 10081 begin 10082 -- Add the current scenario to the stack of active scenarios 10083 10084 Push_Active_Scenario (N); 10085 10086 -- 'Access 10087 10088 if Is_Suitable_Access (N) then 10089 Process_Conditional_ABE_Access 10090 (Attr => N, 10091 State => State); 10092 10093 -- Activations and calls 10094 10095 elsif Is_Suitable_Call (N) then 10096 10097 -- In general, only calls found within the main unit are processed 10098 -- because the ALI information supplied to binde is for the main 10099 -- unit only. However, to preserve the consistency of the tree and 10100 -- ensure proper serialization of internal names, external calls 10101 -- also receive corresponding call markers (see Build_Call_Marker). 10102 -- Regardless of the reason, external calls must not be processed. 10103 10104 if In_Main_Context (N) then 10105 Extract_Call_Attributes 10106 (Call => N, 10107 Target_Id => Target_Id, 10108 Attrs => Call_Attrs); 10109 10110 if Is_Activation_Proc (Target_Id) then 10111 Process_Conditional_ABE_Activation 10112 (Call => N, 10113 Call_Attrs => Call_Attrs, 10114 State => State); 10115 10116 else 10117 Process_Conditional_ABE_Call 10118 (Call => N, 10119 Call_Attrs => Call_Attrs, 10120 Target_Id => Target_Id, 10121 State => State); 10122 end if; 10123 end if; 10124 10125 -- Instantiations 10126 10127 elsif Is_Suitable_Instantiation (N) then 10128 Process_Conditional_ABE_Instantiation 10129 (Exp_Inst => N, 10130 State => State); 10131 10132 -- Variable assignments 10133 10134 elsif Is_Suitable_Variable_Assignment (N) then 10135 Process_Conditional_ABE_Variable_Assignment (N); 10136 10137 -- Variable references 10138 10139 elsif Is_Suitable_Variable_Reference (N) then 10140 10141 -- In general, only variable references found within the main unit 10142 -- are processed because the ALI information supplied to binde is for 10143 -- the main unit only. However, to preserve the consistency of the 10144 -- tree and ensure proper serialization of internal names, external 10145 -- variable references also receive corresponding variable reference 10146 -- markers (see Build_Varaible_Reference_Marker). Regardless of the 10147 -- reason, external variable references must not be processed. 10148 10149 if In_Main_Context (N) then 10150 Process_Conditional_ABE_Variable_Reference (N); 10151 end if; 10152 end if; 10153 10154 -- Remove the current scenario from the stack of active scenarios once 10155 -- all ABE diagnostics and checks have been performed. 10156 10157 Pop_Active_Scenario (N); 10158 end Process_Conditional_ABE; 10159 10160 -------------------------------------------- 10161 -- Process_Guaranteed_ABE_Activation_Impl -- 10162 -------------------------------------------- 10163 10164 procedure Process_Guaranteed_ABE_Activation_Impl 10165 (Call : Node_Id; 10166 Call_Attrs : Call_Attributes; 10167 Obj_Id : Entity_Id; 10168 Task_Attrs : Task_Attributes; 10169 State : Processing_Attributes) 10170 is 10171 pragma Unreferenced (State); 10172 10173 Check_OK : constant Boolean := 10174 not Is_Ignored_Ghost_Entity (Obj_Id) 10175 and then not Task_Attrs.Ghost_Mode_Ignore 10176 and then Is_Elaboration_Checks_OK_Id (Obj_Id) 10177 and then Task_Attrs.Elab_Checks_OK; 10178 -- A run-time ABE check may be installed only when the object and the 10179 -- task type have active elaboration checks, and both are not ignored 10180 -- Ghost constructs. 10181 10182 begin 10183 -- Nothing to do when the root scenario appears at the declaration 10184 -- level and the task is in the same unit, but outside this context. 10185 -- 10186 -- task type Task_Typ; -- task declaration 10187 -- 10188 -- procedure Proc is 10189 -- function A ... is 10190 -- begin 10191 -- if Some_Condition then 10192 -- declare 10193 -- T : Task_Typ; 10194 -- begin 10195 -- <activation call> -- activation site 10196 -- end; 10197 -- ... 10198 -- end A; 10199 -- 10200 -- X : ... := A; -- root scenario 10201 -- ... 10202 -- 10203 -- task body Task_Typ is 10204 -- ... 10205 -- end Task_Typ; 10206 -- 10207 -- In the example above, the context of X is the declarative list of 10208 -- Proc. The "elaboration" of X may reach the activation of T whose body 10209 -- is defined outside of X's context. The task body is relevant only 10210 -- when Proc is invoked, but this happens only in "normal" elaboration, 10211 -- therefore the task body must not be considered if this is not the 10212 -- case. 10213 10214 -- Performance note: parent traversal 10215 10216 if Is_Up_Level_Target (Task_Attrs.Task_Decl) then 10217 return; 10218 10219 -- Nothing to do when the activation is ABE-safe 10220 -- 10221 -- generic 10222 -- package Gen is 10223 -- task type Task_Typ; 10224 -- end Gen; 10225 -- 10226 -- package body Gen is 10227 -- task body Task_Typ is 10228 -- begin 10229 -- ... 10230 -- end Task_Typ; 10231 -- end Gen; 10232 -- 10233 -- with Gen; 10234 -- procedure Main is 10235 -- package Nested is 10236 -- package Inst is new Gen; 10237 -- T : Inst.Task_Typ; 10238 -- end Nested; -- safe activation 10239 -- ... 10240 10241 elsif Is_Safe_Activation (Call, Task_Attrs.Task_Decl) then 10242 return; 10243 10244 -- An activation call leads to a guaranteed ABE when the activation 10245 -- call and the task appear within the same context ignoring library 10246 -- levels, and the body of the task has not been seen yet or appears 10247 -- after the activation call. 10248 -- 10249 -- procedure Guaranteed_ABE is 10250 -- task type Task_Typ; 10251 -- 10252 -- package Nested is 10253 -- T : Task_Typ; 10254 -- <activation call> -- guaranteed ABE 10255 -- end Nested; 10256 -- 10257 -- task body Task_Typ is 10258 -- ... 10259 -- end Task_Typ; 10260 -- ... 10261 10262 -- Performance note: parent traversal 10263 10264 elsif Is_Guaranteed_ABE 10265 (N => Call, 10266 Target_Decl => Task_Attrs.Task_Decl, 10267 Target_Body => Task_Attrs.Body_Decl) 10268 then 10269 if Call_Attrs.Elab_Warnings_OK then 10270 Error_Msg_Sloc := Sloc (Call); 10271 Error_Msg_N 10272 ("??task & will be activated # before elaboration of its body", 10273 Obj_Id); 10274 Error_Msg_N ("\Program_Error will be raised at run time", Obj_Id); 10275 end if; 10276 10277 -- Mark the activation call as a guaranteed ABE 10278 10279 Set_Is_Known_Guaranteed_ABE (Call); 10280 10281 -- Install a run-time ABE failue because this activation call will 10282 -- always result in an ABE. 10283 10284 if Check_OK then 10285 Install_ABE_Failure 10286 (N => Call, 10287 Ins_Nod => Call); 10288 end if; 10289 end if; 10290 end Process_Guaranteed_ABE_Activation_Impl; 10291 10292 procedure Process_Guaranteed_ABE_Activation is 10293 new Process_Activation_Generic (Process_Guaranteed_ABE_Activation_Impl); 10294 10295 --------------------------------- 10296 -- Process_Guaranteed_ABE_Call -- 10297 --------------------------------- 10298 10299 procedure Process_Guaranteed_ABE_Call 10300 (Call : Node_Id; 10301 Call_Attrs : Call_Attributes; 10302 Target_Id : Entity_Id) 10303 is 10304 Target_Attrs : Target_Attributes; 10305 10306 begin 10307 Extract_Target_Attributes 10308 (Target_Id => Target_Id, 10309 Attrs => Target_Attrs); 10310 10311 -- Nothing to do when the root scenario appears at the declaration level 10312 -- and the target is in the same unit, but outside this context. 10313 -- 10314 -- function B ...; -- target declaration 10315 -- 10316 -- procedure Proc is 10317 -- function A ... is 10318 -- begin 10319 -- if Some_Condition then 10320 -- return B; -- call site 10321 -- ... 10322 -- end A; 10323 -- 10324 -- X : ... := A; -- root scenario 10325 -- ... 10326 -- 10327 -- function B ... is 10328 -- ... 10329 -- end B; 10330 -- 10331 -- In the example above, the context of X is the declarative region of 10332 -- Proc. The "elaboration" of X may eventually reach B which is defined 10333 -- outside of X's context. B is relevant only when Proc is invoked, but 10334 -- this happens only by means of "normal" elaboration, therefore B must 10335 -- not be considered if this is not the case. 10336 10337 -- Performance note: parent traversal 10338 10339 if Is_Up_Level_Target (Target_Attrs.Spec_Decl) then 10340 return; 10341 10342 -- Nothing to do when the call is ABE-safe 10343 -- 10344 -- generic 10345 -- function Gen ...; 10346 -- 10347 -- function Gen ... is 10348 -- begin 10349 -- ... 10350 -- end Gen; 10351 -- 10352 -- with Gen; 10353 -- procedure Main is 10354 -- function Inst is new Gen; 10355 -- X : ... := Inst; -- safe call 10356 -- ... 10357 10358 elsif Is_Safe_Call (Call, Target_Attrs) then 10359 return; 10360 10361 -- A call leads to a guaranteed ABE when the call and the target appear 10362 -- within the same context ignoring library levels, and the body of the 10363 -- target has not been seen yet or appears after the call. 10364 -- 10365 -- procedure Guaranteed_ABE is 10366 -- function Func ...; 10367 -- 10368 -- package Nested is 10369 -- Obj : ... := Func; -- guaranteed ABE 10370 -- end Nested; 10371 -- 10372 -- function Func ... is 10373 -- ... 10374 -- end Func; 10375 -- ... 10376 10377 -- Performance note: parent traversal 10378 10379 elsif Is_Guaranteed_ABE 10380 (N => Call, 10381 Target_Decl => Target_Attrs.Spec_Decl, 10382 Target_Body => Target_Attrs.Body_Decl) 10383 then 10384 if Call_Attrs.Elab_Warnings_OK then 10385 Error_Msg_NE ("??cannot call & before body seen", Call, Target_Id); 10386 Error_Msg_N ("\Program_Error will be raised at run time", Call); 10387 end if; 10388 10389 -- Mark the call as a guarnateed ABE 10390 10391 Set_Is_Known_Guaranteed_ABE (Call); 10392 10393 -- Install a run-time ABE failure because the call will always result 10394 -- in an ABE. The failure is installed when both the call and target 10395 -- have enabled elaboration checks, and both are not ignored Ghost 10396 -- constructs. 10397 10398 if Call_Attrs.Elab_Checks_OK 10399 and then Target_Attrs.Elab_Checks_OK 10400 and then not Call_Attrs.Ghost_Mode_Ignore 10401 and then not Target_Attrs.Ghost_Mode_Ignore 10402 then 10403 Install_ABE_Failure 10404 (N => Call, 10405 Ins_Nod => Call); 10406 end if; 10407 end if; 10408 end Process_Guaranteed_ABE_Call; 10409 10410 ------------------------------------------ 10411 -- Process_Guaranteed_ABE_Instantiation -- 10412 ------------------------------------------ 10413 10414 procedure Process_Guaranteed_ABE_Instantiation (Exp_Inst : Node_Id) is 10415 Gen_Attrs : Target_Attributes; 10416 Gen_Id : Entity_Id; 10417 Inst : Node_Id; 10418 Inst_Attrs : Instantiation_Attributes; 10419 Inst_Id : Entity_Id; 10420 10421 begin 10422 Extract_Instantiation_Attributes 10423 (Exp_Inst => Exp_Inst, 10424 Inst => Inst, 10425 Inst_Id => Inst_Id, 10426 Gen_Id => Gen_Id, 10427 Attrs => Inst_Attrs); 10428 10429 Extract_Target_Attributes (Gen_Id, Gen_Attrs); 10430 10431 -- Nothing to do when the root scenario appears at the declaration level 10432 -- and the generic is in the same unit, but outside this context. 10433 -- 10434 -- generic 10435 -- procedure Gen is ...; -- generic declaration 10436 -- 10437 -- procedure Proc is 10438 -- function A ... is 10439 -- begin 10440 -- if Some_Condition then 10441 -- declare 10442 -- procedure I is new Gen; -- instantiation site 10443 -- ... 10444 -- ... 10445 -- end A; 10446 -- 10447 -- X : ... := A; -- root scenario 10448 -- ... 10449 -- 10450 -- procedure Gen is 10451 -- ... 10452 -- end Gen; 10453 -- 10454 -- In the example above, the context of X is the declarative region of 10455 -- Proc. The "elaboration" of X may eventually reach Gen which appears 10456 -- outside of X's context. Gen is relevant only when Proc is invoked, 10457 -- but this happens only by means of "normal" elaboration, therefore 10458 -- Gen must not be considered if this is not the case. 10459 10460 -- Performance note: parent traversal 10461 10462 if Is_Up_Level_Target (Gen_Attrs.Spec_Decl) then 10463 return; 10464 10465 -- Nothing to do when the instantiation is ABE-safe 10466 -- 10467 -- generic 10468 -- package Gen is 10469 -- ... 10470 -- end Gen; 10471 -- 10472 -- package body Gen is 10473 -- ... 10474 -- end Gen; 10475 -- 10476 -- with Gen; 10477 -- procedure Main is 10478 -- package Inst is new Gen (ABE); -- safe instantiation 10479 -- ... 10480 10481 elsif Is_Safe_Instantiation (Inst, Gen_Attrs) then 10482 return; 10483 10484 -- An instantiation leads to a guaranteed ABE when the instantiation and 10485 -- the generic appear within the same context ignoring library levels, 10486 -- and the body of the generic has not been seen yet or appears after 10487 -- the instantiation. 10488 -- 10489 -- procedure Guaranteed_ABE is 10490 -- generic 10491 -- procedure Gen; 10492 -- 10493 -- package Nested is 10494 -- procedure Inst is new Gen; -- guaranteed ABE 10495 -- end Nested; 10496 -- 10497 -- procedure Gen is 10498 -- ... 10499 -- end Gen; 10500 -- ... 10501 10502 -- Performance note: parent traversal 10503 10504 elsif Is_Guaranteed_ABE 10505 (N => Inst, 10506 Target_Decl => Gen_Attrs.Spec_Decl, 10507 Target_Body => Gen_Attrs.Body_Decl) 10508 then 10509 if Inst_Attrs.Elab_Warnings_OK then 10510 Error_Msg_NE 10511 ("??cannot instantiate & before body seen", Inst, Gen_Id); 10512 Error_Msg_N ("\Program_Error will be raised at run time", Inst); 10513 end if; 10514 10515 -- Mark the instantiation as a guarantee ABE. This automatically 10516 -- suppresses the instantiation of the generic body. 10517 10518 Set_Is_Known_Guaranteed_ABE (Inst); 10519 10520 -- Install a run-time ABE failure because the instantiation will 10521 -- always result in an ABE. The failure is installed when both the 10522 -- instance and the generic have enabled elaboration checks, and both 10523 -- are not ignored Ghost constructs. 10524 10525 if Inst_Attrs.Elab_Checks_OK 10526 and then Gen_Attrs.Elab_Checks_OK 10527 and then not Inst_Attrs.Ghost_Mode_Ignore 10528 and then not Gen_Attrs.Ghost_Mode_Ignore 10529 then 10530 Install_ABE_Failure 10531 (N => Inst, 10532 Ins_Nod => Exp_Inst); 10533 end if; 10534 end if; 10535 end Process_Guaranteed_ABE_Instantiation; 10536 10537 ---------------------------- 10538 -- Process_Guaranteed_ABE -- 10539 ---------------------------- 10540 10541 -- NOTE: The body of this routine is intentionally out of order because it 10542 -- invokes an instantiated subprogram (Process_Guaranteed_ABE_Activation). 10543 -- Placing the body in alphabetical order will result in a guaranteed ABE. 10544 10545 procedure Process_Guaranteed_ABE (N : Node_Id) is 10546 Call_Attrs : Call_Attributes; 10547 Target_Id : Entity_Id; 10548 10549 begin 10550 -- Add the current scenario to the stack of active scenarios 10551 10552 Push_Active_Scenario (N); 10553 10554 -- Only calls, instantiations, and task activations may result in a 10555 -- guaranteed ABE. 10556 10557 if Is_Suitable_Call (N) then 10558 Extract_Call_Attributes 10559 (Call => N, 10560 Target_Id => Target_Id, 10561 Attrs => Call_Attrs); 10562 10563 if Is_Activation_Proc (Target_Id) then 10564 Process_Guaranteed_ABE_Activation 10565 (Call => N, 10566 Call_Attrs => Call_Attrs, 10567 State => Initial_State); 10568 10569 else 10570 Process_Guaranteed_ABE_Call 10571 (Call => N, 10572 Call_Attrs => Call_Attrs, 10573 Target_Id => Target_Id); 10574 end if; 10575 10576 elsif Is_Suitable_Instantiation (N) then 10577 Process_Guaranteed_ABE_Instantiation (N); 10578 end if; 10579 10580 -- Remove the current scenario from the stack of active scenarios once 10581 -- all ABE diagnostics and checks have been performed. 10582 10583 Pop_Active_Scenario (N); 10584 end Process_Guaranteed_ABE; 10585 10586 -------------------------- 10587 -- Push_Active_Scenario -- 10588 -------------------------- 10589 10590 procedure Push_Active_Scenario (N : Node_Id) is 10591 begin 10592 Scenario_Stack.Append (N); 10593 end Push_Active_Scenario; 10594 10595 --------------------------------- 10596 -- Record_Elaboration_Scenario -- 10597 --------------------------------- 10598 10599 procedure Record_Elaboration_Scenario (N : Node_Id) is 10600 Level : Enclosing_Level_Kind; 10601 10602 Any_Level_OK : Boolean; 10603 -- This flag is set when a particular scenario is allowed to appear at 10604 -- any level. 10605 10606 Declaration_Level_OK : Boolean; 10607 -- This flag is set when a particular scenario is allowed to appear at 10608 -- the declaration level. 10609 10610 Library_Level_OK : Boolean; 10611 -- This flag is set when a particular scenario is allowed to appear at 10612 -- the library level. 10613 10614 begin 10615 -- Assume that the scenario cannot appear on any level 10616 10617 Any_Level_OK := False; 10618 Declaration_Level_OK := False; 10619 Library_Level_OK := False; 10620 10621 -- Nothing to do when switch -gnatH (legacy elaboration checking mode 10622 -- enabled) is in effect because the legacy ABE mechanism does not need 10623 -- to carry out this action. 10624 10625 if Legacy_Elaboration_Checks then 10626 return; 10627 10628 -- Nothing to do for ASIS. As a result, no ABE checks and diagnostics 10629 -- are performed in this mode. 10630 10631 elsif ASIS_Mode then 10632 return; 10633 10634 -- Nothing to do when the scenario is being preanalyzed 10635 10636 elsif Preanalysis_Active then 10637 return; 10638 end if; 10639 10640 -- Ensure that a library-level call does not appear in a preelaborated 10641 -- unit. The check must come before ignoring scenarios within external 10642 -- units or inside generics because calls in those context must also be 10643 -- verified. 10644 10645 if Is_Suitable_Call (N) then 10646 Check_Preelaborated_Call (N); 10647 end if; 10648 10649 -- Nothing to do when the scenario does not appear within the main unit 10650 10651 if not In_Main_Context (N) then 10652 return; 10653 10654 -- Scenarios within a generic unit are never considered because generics 10655 -- cannot be elaborated. 10656 10657 elsif Inside_A_Generic then 10658 return; 10659 10660 -- Scenarios which do not fall in one of the elaboration categories 10661 -- listed below are not considered. The categories are: 10662 10663 -- 'Access for entries, operators, and subprograms 10664 -- Assignments to variables 10665 -- Calls (includes task activation) 10666 -- Derived types 10667 -- Instantiations 10668 -- Pragma Refined_State 10669 -- Reads of variables 10670 10671 elsif Is_Suitable_Access (N) then 10672 Library_Level_OK := True; 10673 10674 -- Signal any enclosing local exception handlers that the 'Access may 10675 -- raise Program_Error due to a failed ABE check when switch -gnatd.o 10676 -- (conservative elaboration order for indirect calls) is in effect. 10677 -- Marking the exception handlers ensures proper expansion by both 10678 -- the front and back end restriction when No_Exception_Propagation 10679 -- is in effect. 10680 10681 if Debug_Flag_Dot_O then 10682 Possible_Local_Raise (N, Standard_Program_Error); 10683 end if; 10684 10685 elsif Is_Suitable_Call (N) or else Is_Suitable_Instantiation (N) then 10686 Declaration_Level_OK := True; 10687 Library_Level_OK := True; 10688 10689 -- Signal any enclosing local exception handlers that the call or 10690 -- instantiation may raise Program_Error due to a failed ABE check. 10691 -- Marking the exception handlers ensures proper expansion by both 10692 -- the front and back end restriction when No_Exception_Propagation 10693 -- is in effect. 10694 10695 Possible_Local_Raise (N, Standard_Program_Error); 10696 10697 elsif Is_Suitable_SPARK_Derived_Type (N) then 10698 Any_Level_OK := True; 10699 10700 elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then 10701 Library_Level_OK := True; 10702 10703 elsif Is_Suitable_Variable_Assignment (N) 10704 or else Is_Suitable_Variable_Reference (N) 10705 then 10706 Library_Level_OK := True; 10707 10708 -- Otherwise the input does not denote a suitable scenario 10709 10710 else 10711 return; 10712 end if; 10713 10714 -- The static model imposes additional restrictions on the placement of 10715 -- scenarios. In contrast, the dynamic model assumes that every scenario 10716 -- will be elaborated or invoked at some point. 10717 10718 if Static_Elaboration_Checks then 10719 10720 -- Certain scenarios are allowed to appear at any level. This check 10721 -- is performed here in order to save on a parent traversal. 10722 10723 if Any_Level_OK then 10724 null; 10725 10726 -- Otherwise the scenario must appear at a specific level 10727 10728 else 10729 -- Performance note: parent traversal 10730 10731 Level := Find_Enclosing_Level (N); 10732 10733 -- Declaration-level scenario 10734 10735 if Declaration_Level_OK and then Level = Declaration_Level then 10736 null; 10737 10738 -- Library-level or instantiation scenario 10739 10740 elsif Library_Level_OK 10741 and then Level in Library_Or_Instantiation_Level 10742 then 10743 null; 10744 10745 -- Otherwise the scenario does not appear at the proper level and 10746 -- cannot possibly act as a top-level scenario. 10747 10748 else 10749 return; 10750 end if; 10751 end if; 10752 end if; 10753 10754 -- Derived types subject to SPARK_Mode On require elaboration-related 10755 -- checks even though the type may not be declared within elaboration 10756 -- code. The types are recorded in a separate table which is examined 10757 -- during the Processing phase. Note that the checks must be delayed 10758 -- because the bodies of overriding primitives are not available yet. 10759 10760 if Is_Suitable_SPARK_Derived_Type (N) then 10761 Record_SPARK_Elaboration_Scenario (N); 10762 10763 -- Nothing left to do for derived types 10764 10765 return; 10766 10767 -- Instantiations of generics both subject to SPARK_Mode On require 10768 -- elaboration-related checks even though the instantiations may not 10769 -- appear within elaboration code. The instantiations are recored in 10770 -- a separate table which is examined during the Procesing phase. Note 10771 -- that the checks must be delayed because it is not known yet whether 10772 -- the generic unit has a body or not. 10773 10774 -- IMPORTANT: A SPARK instantiation is also a normal instantiation which 10775 -- is subject to common conditional and guaranteed ABE checks. 10776 10777 elsif Is_Suitable_SPARK_Instantiation (N) then 10778 Record_SPARK_Elaboration_Scenario (N); 10779 10780 -- External constituents that refine abstract states which appear in 10781 -- pragma Initializes require elaboration-related checks even though 10782 -- a Refined_State pragma lacks any elaboration semantic. 10783 10784 elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then 10785 Record_SPARK_Elaboration_Scenario (N); 10786 10787 -- Nothing left to do for pragma Refined_State 10788 10789 return; 10790 end if; 10791 10792 -- Perform early detection of guaranteed ABEs in order to suppress the 10793 -- instantiation of generic bodies as gigi cannot handle certain types 10794 -- of premature instantiations. 10795 10796 Process_Guaranteed_ABE (N); 10797 10798 -- At this point all checks have been performed. Record the scenario for 10799 -- later processing by the ABE phase. 10800 10801 Top_Level_Scenarios.Append (N); 10802 Set_Is_Recorded_Top_Level_Scenario (N); 10803 end Record_Elaboration_Scenario; 10804 10805 --------------------------------------- 10806 -- Record_SPARK_Elaboration_Scenario -- 10807 --------------------------------------- 10808 10809 procedure Record_SPARK_Elaboration_Scenario (N : Node_Id) is 10810 begin 10811 SPARK_Scenarios.Append (N); 10812 Set_Is_Recorded_SPARK_Scenario (N); 10813 end Record_SPARK_Elaboration_Scenario; 10814 10815 ----------------------------------- 10816 -- Recorded_SPARK_Scenarios_Hash -- 10817 ----------------------------------- 10818 10819 function Recorded_SPARK_Scenarios_Hash 10820 (Key : Node_Id) return Recorded_SPARK_Scenarios_Index 10821 is 10822 begin 10823 return 10824 Recorded_SPARK_Scenarios_Index (Key mod Recorded_SPARK_Scenarios_Max); 10825 end Recorded_SPARK_Scenarios_Hash; 10826 10827 --------------------------------------- 10828 -- Recorded_Top_Level_Scenarios_Hash -- 10829 --------------------------------------- 10830 10831 function Recorded_Top_Level_Scenarios_Hash 10832 (Key : Node_Id) return Recorded_Top_Level_Scenarios_Index 10833 is 10834 begin 10835 return 10836 Recorded_Top_Level_Scenarios_Index 10837 (Key mod Recorded_Top_Level_Scenarios_Max); 10838 end Recorded_Top_Level_Scenarios_Hash; 10839 10840 -------------------------- 10841 -- Reset_Visited_Bodies -- 10842 -------------------------- 10843 10844 procedure Reset_Visited_Bodies is 10845 begin 10846 if Visited_Bodies_In_Use then 10847 Visited_Bodies_In_Use := False; 10848 Visited_Bodies.Reset; 10849 end if; 10850 end Reset_Visited_Bodies; 10851 10852 ------------------- 10853 -- Root_Scenario -- 10854 ------------------- 10855 10856 function Root_Scenario return Node_Id is 10857 package Stack renames Scenario_Stack; 10858 10859 begin 10860 -- Ensure that the scenario stack has at least one active scenario in 10861 -- it. The one at the bottom (index First) is the root scenario. 10862 10863 pragma Assert (Stack.Last >= Stack.First); 10864 return Stack.Table (Stack.First); 10865 end Root_Scenario; 10866 10867 --------------------------- 10868 -- Set_Early_Call_Region -- 10869 --------------------------- 10870 10871 procedure Set_Early_Call_Region (Body_Id : Entity_Id; Start : Node_Id) is 10872 begin 10873 pragma Assert (Ekind_In (Body_Id, E_Entry, 10874 E_Entry_Family, 10875 E_Function, 10876 E_Procedure, 10877 E_Subprogram_Body)); 10878 10879 Early_Call_Regions_In_Use := True; 10880 Early_Call_Regions.Set (Body_Id, Start); 10881 end Set_Early_Call_Region; 10882 10883 ---------------------------- 10884 -- Set_Elaboration_Status -- 10885 ---------------------------- 10886 10887 procedure Set_Elaboration_Status 10888 (Unit_Id : Entity_Id; 10889 Val : Elaboration_Attributes) 10890 is 10891 begin 10892 Elaboration_Statuses_In_Use := True; 10893 Elaboration_Statuses.Set (Unit_Id, Val); 10894 end Set_Elaboration_Status; 10895 10896 ------------------------------------ 10897 -- Set_Is_Recorded_SPARK_Scenario -- 10898 ------------------------------------ 10899 10900 procedure Set_Is_Recorded_SPARK_Scenario 10901 (N : Node_Id; 10902 Val : Boolean := True) 10903 is 10904 begin 10905 Recorded_SPARK_Scenarios_In_Use := True; 10906 Recorded_SPARK_Scenarios.Set (N, Val); 10907 end Set_Is_Recorded_SPARK_Scenario; 10908 10909 ---------------------------------------- 10910 -- Set_Is_Recorded_Top_Level_Scenario -- 10911 ---------------------------------------- 10912 10913 procedure Set_Is_Recorded_Top_Level_Scenario 10914 (N : Node_Id; 10915 Val : Boolean := True) 10916 is 10917 begin 10918 Recorded_Top_Level_Scenarios_In_Use := True; 10919 Recorded_Top_Level_Scenarios.Set (N, Val); 10920 end Set_Is_Recorded_Top_Level_Scenario; 10921 10922 ------------------------- 10923 -- Set_Is_Visited_Body -- 10924 ------------------------- 10925 10926 procedure Set_Is_Visited_Body (Subp_Body : Node_Id) is 10927 begin 10928 Visited_Bodies_In_Use := True; 10929 Visited_Bodies.Set (Subp_Body, True); 10930 end Set_Is_Visited_Body; 10931 10932 ------------------------------- 10933 -- Static_Elaboration_Checks -- 10934 ------------------------------- 10935 10936 function Static_Elaboration_Checks return Boolean is 10937 begin 10938 return not Dynamic_Elaboration_Checks; 10939 end Static_Elaboration_Checks; 10940 10941 ------------------- 10942 -- Traverse_Body -- 10943 ------------------- 10944 10945 procedure Traverse_Body (N : Node_Id; State : Processing_Attributes) is 10946 procedure Find_And_Process_Nested_Scenarios; 10947 pragma Inline (Find_And_Process_Nested_Scenarios); 10948 -- Examine the declarations and statements of subprogram body N for 10949 -- suitable scenarios. Save each discovered scenario and process it 10950 -- accordingly. 10951 10952 procedure Process_Nested_Scenarios (Nested : Elist_Id); 10953 pragma Inline (Process_Nested_Scenarios); 10954 -- Invoke Process_Conditional_ABE on each individual scenario found in 10955 -- list Nested. 10956 10957 --------------------------------------- 10958 -- Find_And_Process_Nested_Scenarios -- 10959 --------------------------------------- 10960 10961 procedure Find_And_Process_Nested_Scenarios is 10962 Body_Id : constant Entity_Id := Defining_Entity (N); 10963 10964 function Is_Potential_Scenario 10965 (Nod : Node_Id) return Traverse_Result; 10966 -- Determine whether arbitrary node Nod denotes a suitable scenario. 10967 -- If it does, save it in the Nested_Scenarios list of the subprogram 10968 -- body, and process it. 10969 10970 procedure Save_Scenario (Nod : Node_Id); 10971 pragma Inline (Save_Scenario); 10972 -- Save scenario Nod in the Nested_Scenarios list of the subprogram 10973 -- body. 10974 10975 procedure Traverse_List (List : List_Id); 10976 pragma Inline (Traverse_List); 10977 -- Invoke Traverse_Potential_Scenarios on each node in list List 10978 10979 procedure Traverse_Potential_Scenarios is 10980 new Traverse_Proc (Is_Potential_Scenario); 10981 10982 --------------------------- 10983 -- Is_Potential_Scenario -- 10984 --------------------------- 10985 10986 function Is_Potential_Scenario 10987 (Nod : Node_Id) return Traverse_Result 10988 is 10989 begin 10990 -- Special cases 10991 10992 -- Skip constructs which do not have elaboration of their own and 10993 -- need to be elaborated by other means such as invocation, task 10994 -- activation, etc. 10995 10996 if Is_Non_Library_Level_Encapsulator (Nod) then 10997 return Skip; 10998 10999 -- Terminate the traversal of a task body with an accept statement 11000 -- when no entry calls in elaboration are allowed because the task 11001 -- will block at run-time and the remaining statements will not be 11002 -- executed. 11003 11004 elsif Nkind_In (Original_Node (Nod), N_Accept_Statement, 11005 N_Selective_Accept) 11006 then 11007 if Restriction_Active (No_Entry_Calls_In_Elaboration_Code) then 11008 return Abandon; 11009 11010 -- The same behavior is achieved when switch -gnatd_a (stop 11011 -- elabortion checks on accept or select statement) is in 11012 -- effect. 11013 11014 elsif Debug_Flag_Underscore_A then 11015 return Abandon; 11016 end if; 11017 11018 -- Certain nodes carry semantic lists which act as repositories 11019 -- until expansion transforms the node and relocates the contents. 11020 -- Examine these lists in case expansion is disabled. 11021 11022 elsif Nkind_In (Nod, N_And_Then, N_Or_Else) then 11023 Traverse_List (Actions (Nod)); 11024 11025 elsif Nkind_In (Nod, N_Elsif_Part, N_Iteration_Scheme) then 11026 Traverse_List (Condition_Actions (Nod)); 11027 11028 elsif Nkind (Nod) = N_If_Expression then 11029 Traverse_List (Then_Actions (Nod)); 11030 Traverse_List (Else_Actions (Nod)); 11031 11032 elsif Nkind_In (Nod, N_Component_Association, 11033 N_Iterated_Component_Association) 11034 then 11035 Traverse_List (Loop_Actions (Nod)); 11036 11037 -- General case 11038 11039 -- Save a suitable scenario in the Nested_Scenarios list of the 11040 -- subprogram body. As a result any subsequent traversals of the 11041 -- subprogram body started from a different top-level scenario no 11042 -- longer need to reexamine the tree. 11043 11044 elsif Is_Suitable_Scenario (Nod) then 11045 Save_Scenario (Nod); 11046 11047 Process_Conditional_ABE 11048 (N => Nod, 11049 State => State); 11050 end if; 11051 11052 return OK; 11053 end Is_Potential_Scenario; 11054 11055 ------------------- 11056 -- Save_Scenario -- 11057 ------------------- 11058 11059 procedure Save_Scenario (Nod : Node_Id) is 11060 Nested : Elist_Id; 11061 11062 begin 11063 Nested := Nested_Scenarios (Body_Id); 11064 11065 if No (Nested) then 11066 Nested := New_Elmt_List; 11067 Set_Nested_Scenarios (Body_Id, Nested); 11068 end if; 11069 11070 Append_Elmt (Nod, Nested); 11071 end Save_Scenario; 11072 11073 ------------------- 11074 -- Traverse_List -- 11075 ------------------- 11076 11077 procedure Traverse_List (List : List_Id) is 11078 Item : Node_Id; 11079 11080 begin 11081 Item := First (List); 11082 while Present (Item) loop 11083 Traverse_Potential_Scenarios (Item); 11084 Next (Item); 11085 end loop; 11086 end Traverse_List; 11087 11088 -- Start of processing for Find_And_Process_Nested_Scenarios 11089 11090 begin 11091 -- Examine the declarations for suitable scenarios 11092 11093 Traverse_List (Declarations (N)); 11094 11095 -- Examine the handled sequence of statements. This also includes any 11096 -- exceptions handlers. 11097 11098 Traverse_Potential_Scenarios (Handled_Statement_Sequence (N)); 11099 end Find_And_Process_Nested_Scenarios; 11100 11101 ------------------------------ 11102 -- Process_Nested_Scenarios -- 11103 ------------------------------ 11104 11105 procedure Process_Nested_Scenarios (Nested : Elist_Id) is 11106 Nested_Elmt : Elmt_Id; 11107 11108 begin 11109 Nested_Elmt := First_Elmt (Nested); 11110 while Present (Nested_Elmt) loop 11111 Process_Conditional_ABE 11112 (N => Node (Nested_Elmt), 11113 State => State); 11114 11115 Next_Elmt (Nested_Elmt); 11116 end loop; 11117 end Process_Nested_Scenarios; 11118 11119 -- Local variables 11120 11121 Nested : Elist_Id; 11122 11123 -- Start of processing for Traverse_Body 11124 11125 begin 11126 -- Nothing to do when there is no body 11127 11128 if No (N) then 11129 return; 11130 11131 elsif Nkind (N) /= N_Subprogram_Body then 11132 return; 11133 end if; 11134 11135 -- Nothing to do if the body was already traversed during the processing 11136 -- of the same top-level scenario. 11137 11138 if Is_Visited_Body (N) then 11139 return; 11140 11141 -- Otherwise mark the body as traversed 11142 11143 else 11144 Set_Is_Visited_Body (N); 11145 end if; 11146 11147 Nested := Nested_Scenarios (Defining_Entity (N)); 11148 11149 -- The subprogram body was already examined as part of the elaboration 11150 -- graph starting from a different top-level scenario. There is no need 11151 -- to traverse the declarations and statements again because this will 11152 -- yield the exact same scenarios. Use the nested scenarios collected 11153 -- during the first inspection of the body. 11154 11155 if Present (Nested) then 11156 Process_Nested_Scenarios (Nested); 11157 11158 -- Otherwise examine the declarations and statements of the subprogram 11159 -- body for suitable scenarios, save and process them accordingly. 11160 11161 else 11162 Find_And_Process_Nested_Scenarios; 11163 end if; 11164 end Traverse_Body; 11165 11166 --------------------------------- 11167 -- Update_Elaboration_Scenario -- 11168 --------------------------------- 11169 11170 procedure Update_Elaboration_Scenario (New_N : Node_Id; Old_N : Node_Id) is 11171 procedure Update_SPARK_Scenario; 11172 pragma Inline (Update_SPARK_Scenario); 11173 -- Update the contents of table SPARK_Scenarios if Old_N is recorded 11174 -- there. 11175 11176 procedure Update_Top_Level_Scenario; 11177 pragma Inline (Update_Top_Level_Scenario); 11178 -- Update the contexts of table Top_Level_Scenarios if Old_N is recorded 11179 -- there. 11180 11181 --------------------------- 11182 -- Update_SPARK_Scenario -- 11183 --------------------------- 11184 11185 procedure Update_SPARK_Scenario is 11186 package Scenarios renames SPARK_Scenarios; 11187 11188 begin 11189 if Is_Recorded_SPARK_Scenario (Old_N) then 11190 11191 -- Performance note: list traversal 11192 11193 for Index in Scenarios.First .. Scenarios.Last loop 11194 if Scenarios.Table (Index) = Old_N then 11195 Scenarios.Table (Index) := New_N; 11196 11197 -- The old SPARK scenario is no longer recorded, but the new 11198 -- one is. 11199 11200 Set_Is_Recorded_Top_Level_Scenario (Old_N, False); 11201 Set_Is_Recorded_Top_Level_Scenario (New_N); 11202 return; 11203 end if; 11204 end loop; 11205 11206 -- A recorded SPARK scenario must be in the table of recorded 11207 -- SPARK scenarios. 11208 11209 pragma Assert (False); 11210 end if; 11211 end Update_SPARK_Scenario; 11212 11213 ------------------------------- 11214 -- Update_Top_Level_Scenario -- 11215 ------------------------------- 11216 11217 procedure Update_Top_Level_Scenario is 11218 package Scenarios renames Top_Level_Scenarios; 11219 11220 begin 11221 if Is_Recorded_Top_Level_Scenario (Old_N) then 11222 11223 -- Performance note: list traversal 11224 11225 for Index in Scenarios.First .. Scenarios.Last loop 11226 if Scenarios.Table (Index) = Old_N then 11227 Scenarios.Table (Index) := New_N; 11228 11229 -- The old top-level scenario is no longer recorded, but the 11230 -- new one is. 11231 11232 Set_Is_Recorded_Top_Level_Scenario (Old_N, False); 11233 Set_Is_Recorded_Top_Level_Scenario (New_N); 11234 return; 11235 end if; 11236 end loop; 11237 11238 -- A recorded top-level scenario must be in the table of recorded 11239 -- top-level scenarios. 11240 11241 pragma Assert (False); 11242 end if; 11243 end Update_Top_Level_Scenario; 11244 11245 -- Start of processing for Update_Elaboration_Requirement 11246 11247 begin 11248 -- Nothing to do when the old and new scenarios are one and the same 11249 11250 if Old_N = New_N then 11251 return; 11252 11253 -- A scenario is being transformed by Atree.Rewrite. Update all relevant 11254 -- internal data structures to reflect this change. This ensures that a 11255 -- potential run-time conditional ABE check or a guaranteed ABE failure 11256 -- is inserted at the proper place in the tree. 11257 11258 elsif Is_Scenario (Old_N) then 11259 Update_SPARK_Scenario; 11260 Update_Top_Level_Scenario; 11261 end if; 11262 end Update_Elaboration_Scenario; 11263 11264 ------------------------- 11265 -- Visited_Bodies_Hash -- 11266 ------------------------- 11267 11268 function Visited_Bodies_Hash (Key : Node_Id) return Visited_Bodies_Index is 11269 begin 11270 return Visited_Bodies_Index (Key mod Visited_Bodies_Max); 11271 end Visited_Bodies_Hash; 11272 11273 --------------------------------------------------------------------------- 11274 -- -- 11275 -- 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 -- 11276 -- -- 11277 -- M E C H A N I S M -- 11278 -- -- 11279 --------------------------------------------------------------------------- 11280 11281 -- This section contains the implementation of the pre-18.x legacy ABE 11282 -- mechanism. The mechanism can be activated using switch -gnatH (legacy 11283 -- elaboration checking mode enabled). 11284 11285 ----------------------------- 11286 -- Description of Approach -- 11287 ----------------------------- 11288 11289 -- Every non-static call that is encountered by Sem_Res results in a call 11290 -- to Check_Elab_Call, with N being the call node, and Outer set to its 11291 -- default value of True. In addition X'Access is treated like a call 11292 -- for the access-to-procedure case, and in SPARK mode only we also 11293 -- check variable references. 11294 11295 -- The goal of Check_Elab_Call is to determine whether or not the reference 11296 -- in question can generate an access before elaboration error (raising 11297 -- Program_Error) either by directly calling a subprogram whose body 11298 -- has not yet been elaborated, or indirectly, by calling a subprogram 11299 -- whose body has been elaborated, but which contains a call to such a 11300 -- subprogram. 11301 11302 -- In addition, in SPARK mode, we are checking for a variable reference in 11303 -- another package, which requires an explicit Elaborate_All pragma. 11304 11305 -- The only references that we need to look at the outer level are 11306 -- references that occur in elaboration code. There are two cases. The 11307 -- reference can be at the outer level of elaboration code, or it can 11308 -- be within another unit, e.g. the elaboration code of a subprogram. 11309 11310 -- In the case of an elaboration call at the outer level, we must trace 11311 -- all calls to outer level routines either within the current unit or to 11312 -- other units that are with'ed. For calls within the current unit, we can 11313 -- determine if the body has been elaborated or not, and if it has not, 11314 -- then a warning is generated. 11315 11316 -- Note that there are two subcases. If the original call directly calls a 11317 -- subprogram whose body has not been elaborated, then we know that an ABE 11318 -- will take place, and we replace the call by a raise of Program_Error. 11319 -- If the call is indirect, then we don't know that the PE will be raised, 11320 -- since the call might be guarded by a conditional. In this case we set 11321 -- Do_Elab_Check on the call so that a dynamic check is generated, and 11322 -- output a warning. 11323 11324 -- For calls to a subprogram in a with'ed unit or a 'Access or variable 11325 -- reference (SPARK mode case), we require that a pragma Elaborate_All 11326 -- or pragma Elaborate be present, or that the referenced unit have a 11327 -- pragma Preelaborate, pragma Pure, or pragma Elaborate_Body. If none 11328 -- of these conditions is met, then a warning is generated that a pragma 11329 -- Elaborate_All may be needed (error in the SPARK case), or an implicit 11330 -- pragma is generated. 11331 11332 -- For the case of an elaboration call at some inner level, we are 11333 -- interested in tracing only calls to subprograms at the same level, i.e. 11334 -- those that can be called during elaboration. Any calls to outer level 11335 -- routines cannot cause ABE's as a result of the original call (there 11336 -- might be an outer level call to the subprogram from outside that causes 11337 -- the ABE, but that gets analyzed separately). 11338 11339 -- Note that we never trace calls to inner level subprograms, since these 11340 -- cannot result in ABE's unless there is an elaboration problem at a lower 11341 -- level, which will be separately detected. 11342 11343 -- Note on pragma Elaborate. The checking here assumes that a pragma 11344 -- Elaborate on a with'ed unit guarantees that subprograms within the unit 11345 -- can be called without causing an ABE. This is not in fact the case since 11346 -- pragma Elaborate does not guarantee the transitive coverage guaranteed 11347 -- by Elaborate_All. However, we decide to trust the user in this case. 11348 11349 -------------------------------------- 11350 -- Instantiation Elaboration Errors -- 11351 -------------------------------------- 11352 11353 -- A special case arises when an instantiation appears in a context that is 11354 -- known to be before the body is elaborated, e.g. 11355 11356 -- generic package x is ... 11357 -- ... 11358 -- package xx is new x; 11359 -- ... 11360 -- package body x is ... 11361 11362 -- In this situation it is certain that an elaboration error will occur, 11363 -- and an unconditional raise Program_Error statement is inserted before 11364 -- the instantiation, and a warning generated. 11365 11366 -- The problem is that in this case we have no place to put the body of 11367 -- the instantiation. We can't put it in the normal place, because it is 11368 -- too early, and will cause errors to occur as a result of referencing 11369 -- entities before they are declared. 11370 11371 -- Our approach in this case is simply to avoid creating the body of the 11372 -- instantiation in such a case. The instantiation spec is modified to 11373 -- include dummy bodies for all subprograms, so that the resulting code 11374 -- does not contain subprogram specs with no corresponding bodies. 11375 11376 -- The following table records the recursive call chain for output in the 11377 -- Output routine. Each entry records the call node and the entity of the 11378 -- called routine. The number of entries in the table (i.e. the value of 11379 -- Elab_Call.Last) indicates the current depth of recursion and is used to 11380 -- identify the outer level. 11381 11382 type Elab_Call_Element is record 11383 Cloc : Source_Ptr; 11384 Ent : Entity_Id; 11385 end record; 11386 11387 package Elab_Call is new Table.Table 11388 (Table_Component_Type => Elab_Call_Element, 11389 Table_Index_Type => Int, 11390 Table_Low_Bound => 1, 11391 Table_Initial => 50, 11392 Table_Increment => 100, 11393 Table_Name => "Elab_Call"); 11394 11395 -- The following table records all calls that have been processed starting 11396 -- from an outer level call. The table prevents both infinite recursion and 11397 -- useless reanalysis of calls within the same context. The use of context 11398 -- is important because it allows for proper checks in more complex code: 11399 11400 -- if ... then 11401 -- Call; -- requires a check 11402 -- Call; -- does not need a check thanks to the table 11403 -- elsif ... then 11404 -- Call; -- requires a check, different context 11405 -- end if; 11406 11407 -- Call; -- requires a check, different context 11408 11409 type Visited_Element is record 11410 Subp_Id : Entity_Id; 11411 -- The entity of the subprogram being called 11412 11413 Context : Node_Id; 11414 -- The context where the call to the subprogram occurs 11415 end record; 11416 11417 package Elab_Visited is new Table.Table 11418 (Table_Component_Type => Visited_Element, 11419 Table_Index_Type => Int, 11420 Table_Low_Bound => 1, 11421 Table_Initial => 200, 11422 Table_Increment => 100, 11423 Table_Name => "Elab_Visited"); 11424 11425 -- The following table records delayed calls which must be examined after 11426 -- all generic bodies have been instantiated. 11427 11428 type Delay_Element is record 11429 N : Node_Id; 11430 -- The parameter N from the call to Check_Internal_Call. Note that this 11431 -- node may get rewritten over the delay period by expansion in the call 11432 -- case (but not in the instantiation case). 11433 11434 E : Entity_Id; 11435 -- The parameter E from the call to Check_Internal_Call 11436 11437 Orig_Ent : Entity_Id; 11438 -- The parameter Orig_Ent from the call to Check_Internal_Call 11439 11440 Curscop : Entity_Id; 11441 -- The current scope of the call. This is restored when we complete the 11442 -- delayed call, so that we do this in the right scope. 11443 11444 Outer_Scope : Entity_Id; 11445 -- Save scope of outer level call 11446 11447 From_Elab_Code : Boolean; 11448 -- Save indication of whether this call is from elaboration code 11449 11450 In_Task_Activation : Boolean; 11451 -- Save indication of whether this call is from a task body. Tasks are 11452 -- activated at the "begin", which is after all local procedure bodies, 11453 -- so calls to those procedures can't fail, even if they occur after the 11454 -- task body. 11455 11456 From_SPARK_Code : Boolean; 11457 -- Save indication of whether this call is under SPARK_Mode => On 11458 end record; 11459 11460 package Delay_Check is new Table.Table 11461 (Table_Component_Type => Delay_Element, 11462 Table_Index_Type => Int, 11463 Table_Low_Bound => 1, 11464 Table_Initial => 1000, 11465 Table_Increment => 100, 11466 Table_Name => "Delay_Check"); 11467 11468 C_Scope : Entity_Id; 11469 -- Top-level scope of current scope. Compute this only once at the outer 11470 -- level, i.e. for a call to Check_Elab_Call from outside this unit. 11471 11472 Outer_Level_Sloc : Source_Ptr; 11473 -- Save Sloc value for outer level call node for comparisons of source 11474 -- locations. A body is too late if it appears after the *outer* level 11475 -- call, not the particular call that is being analyzed. 11476 11477 From_Elab_Code : Boolean; 11478 -- This flag shows whether the outer level call currently being examined 11479 -- is or is not in elaboration code. We are only interested in calls to 11480 -- routines in other units if this flag is True. 11481 11482 In_Task_Activation : Boolean := False; 11483 -- This flag indicates whether we are performing elaboration checks on task 11484 -- bodies, at the point of activation. If true, we do not raise 11485 -- Program_Error for calls to local procedures, because all local bodies 11486 -- are known to be elaborated. However, we still need to trace such calls, 11487 -- because a local procedure could call a procedure in another package, 11488 -- so we might need an implicit Elaborate_All. 11489 11490 Delaying_Elab_Checks : Boolean := True; 11491 -- This is set True till the compilation is complete, including the 11492 -- insertion of all instance bodies. Then when Check_Elab_Calls is called, 11493 -- the delay table is used to make the delayed calls and this flag is reset 11494 -- to False, so that the calls are processed. 11495 11496 ----------------------- 11497 -- Local Subprograms -- 11498 ----------------------- 11499 11500 -- Note: Outer_Scope in all following specs represents the scope of 11501 -- interest of the outer level call. If it is set to Standard_Standard, 11502 -- then it means the outer level call was at elaboration level, and that 11503 -- thus all calls are of interest. If it was set to some other scope, 11504 -- then the original call was an inner call, and we are not interested 11505 -- in calls that go outside this scope. 11506 11507 procedure Activate_Elaborate_All_Desirable (N : Node_Id; U : Entity_Id); 11508 -- Analysis of construct N shows that we should set Elaborate_All_Desirable 11509 -- for the WITH clause for unit U (which will always be present). A special 11510 -- case is when N is a function or procedure instantiation, in which case 11511 -- it is sufficient to set Elaborate_Desirable, since in this case there is 11512 -- no possibility of transitive elaboration issues. 11513 11514 procedure Check_A_Call 11515 (N : Node_Id; 11516 E : Entity_Id; 11517 Outer_Scope : Entity_Id; 11518 Inter_Unit_Only : Boolean; 11519 Generate_Warnings : Boolean := True; 11520 In_Init_Proc : Boolean := False); 11521 -- This is the internal recursive routine that is called to check for 11522 -- possible elaboration error. The argument N is a subprogram call or 11523 -- generic instantiation, or 'Access attribute reference to be checked, and 11524 -- E is the entity of the called subprogram, or instantiated generic unit, 11525 -- or subprogram referenced by 'Access. 11526 -- 11527 -- In SPARK mode, N can also be a variable reference, since in SPARK this 11528 -- also triggers a requirement for Elaborate_All, and in this case E is the 11529 -- entity being referenced. 11530 -- 11531 -- Outer_Scope is the outer level scope for the original reference. 11532 -- Inter_Unit_Only is set if the call is only to be checked in the 11533 -- case where it is to another unit (and skipped if within a unit). 11534 -- Generate_Warnings is set to False to suppress warning messages about 11535 -- missing pragma Elaborate_All's. These messages are not wanted for 11536 -- inner calls in the dynamic model. Note that an instance of the Access 11537 -- attribute applied to a subprogram also generates a call to this 11538 -- procedure (since the referenced subprogram may be called later 11539 -- indirectly). Flag In_Init_Proc should be set whenever the current 11540 -- context is a type init proc. 11541 -- 11542 -- Note: this might better be called Check_A_Reference to recognize the 11543 -- variable case for SPARK, but we prefer to retain the historical name 11544 -- since in practice this is mostly about checking calls for the possible 11545 -- occurrence of an access-before-elaboration exception. 11546 11547 procedure Check_Bad_Instantiation (N : Node_Id); 11548 -- N is a node for an instantiation (if called with any other node kind, 11549 -- Check_Bad_Instantiation ignores the call). This subprogram checks for 11550 -- the special case of a generic instantiation of a generic spec in the 11551 -- same declarative part as the instantiation where a body is present and 11552 -- has not yet been seen. This is an obvious error, but needs to be checked 11553 -- specially at the time of the instantiation, since it is a case where we 11554 -- cannot insert the body anywhere. If this case is detected, warnings are 11555 -- generated, and a raise of Program_Error is inserted. In addition any 11556 -- subprograms in the generic spec are stubbed, and the Bad_Instantiation 11557 -- flag is set on the instantiation node. The caller in Sem_Ch12 uses this 11558 -- flag as an indication that no attempt should be made to insert an 11559 -- instance body. 11560 11561 procedure Check_Internal_Call 11562 (N : Node_Id; 11563 E : Entity_Id; 11564 Outer_Scope : Entity_Id; 11565 Orig_Ent : Entity_Id); 11566 -- N is a function call or procedure statement call node and E is the 11567 -- entity of the called function, which is within the current compilation 11568 -- unit (where subunits count as part of the parent). This call checks if 11569 -- this call, or any call within any accessed body could cause an ABE, and 11570 -- if so, outputs a warning. Orig_Ent differs from E only in the case of 11571 -- renamings, and points to the original name of the entity. This is used 11572 -- for error messages. Outer_Scope is the outer level scope for the 11573 -- original call. 11574 11575 procedure Check_Internal_Call_Continue 11576 (N : Node_Id; 11577 E : Entity_Id; 11578 Outer_Scope : Entity_Id; 11579 Orig_Ent : Entity_Id); 11580 -- The processing for Check_Internal_Call is divided up into two phases, 11581 -- and this represents the second phase. The second phase is delayed if 11582 -- Delaying_Elab_Checks is set to True. In this delayed case, the first 11583 -- phase makes an entry in the Delay_Check table, which is processed when 11584 -- Check_Elab_Calls is called. N, E and Orig_Ent are as for the call to 11585 -- Check_Internal_Call. Outer_Scope is the outer level scope for the 11586 -- original call. 11587 11588 function Get_Referenced_Ent (N : Node_Id) return Entity_Id; 11589 -- N is either a function or procedure call or an access attribute that 11590 -- references a subprogram. This call retrieves the relevant entity. If 11591 -- this is a call to a protected subprogram, the entity is a selected 11592 -- component. The callable entity may be absent, in which case Empty is 11593 -- returned. This happens with non-analyzed calls in nested generics. 11594 -- 11595 -- If SPARK_Mode is On, then N can also be a reference to an E_Variable 11596 -- entity, in which case, the value returned is simply this entity. 11597 11598 function Has_Generic_Body (N : Node_Id) return Boolean; 11599 -- N is a generic package instantiation node, and this routine determines 11600 -- if this package spec does in fact have a generic body. If so, then 11601 -- True is returned, otherwise False. Note that this is not at all the 11602 -- same as checking if the unit requires a body, since it deals with 11603 -- the case of optional bodies accurately (i.e. if a body is optional, 11604 -- then it looks to see if a body is actually present). Note: this 11605 -- function can only do a fully correct job if in generating code mode 11606 -- where all bodies have to be present. If we are operating in semantics 11607 -- check only mode, then in some cases of optional bodies, a result of 11608 -- False may incorrectly be given. In practice this simply means that 11609 -- some cases of warnings for incorrect order of elaboration will only 11610 -- be given when generating code, which is not a big problem (and is 11611 -- inevitable, given the optional body semantics of Ada). 11612 11613 procedure Insert_Elab_Check (N : Node_Id; C : Node_Id := Empty); 11614 -- Given code for an elaboration check (or unconditional raise if the check 11615 -- is not needed), inserts the code in the appropriate place. N is the call 11616 -- or instantiation node for which the check code is required. C is the 11617 -- test whose failure triggers the raise. 11618 11619 function Is_Call_Of_Generic_Formal (N : Node_Id) return Boolean; 11620 -- Returns True if node N is a call to a generic formal subprogram 11621 11622 function Is_Finalization_Procedure (Id : Entity_Id) return Boolean; 11623 -- Determine whether entity Id denotes a [Deep_]Finalize procedure 11624 11625 procedure Output_Calls 11626 (N : Node_Id; 11627 Check_Elab_Flag : Boolean); 11628 -- Outputs chain of calls stored in the Elab_Call table. The caller has 11629 -- already generated the main warning message, so the warnings generated 11630 -- are all continuation messages. The argument is the call node at which 11631 -- the messages are to be placed. When Check_Elab_Flag is set, calls are 11632 -- enumerated only when flag Elab_Warning is set for the dynamic case or 11633 -- when flag Elab_Info_Messages is set for the static case. 11634 11635 function Same_Elaboration_Scope (Scop1, Scop2 : Entity_Id) return Boolean; 11636 -- Given two scopes, determine whether they are the same scope from an 11637 -- elaboration point of view, i.e. packages and blocks are ignored. 11638 11639 procedure Set_C_Scope; 11640 -- On entry C_Scope is set to some scope. On return, C_Scope is reset 11641 -- to be the enclosing compilation unit of this scope. 11642 11643 procedure Set_Elaboration_Constraint 11644 (Call : Node_Id; 11645 Subp : Entity_Id; 11646 Scop : Entity_Id); 11647 -- The current unit U may depend semantically on some unit P that is not 11648 -- in the current context. If there is an elaboration call that reaches P, 11649 -- we need to indicate that P requires an Elaborate_All, but this is not 11650 -- effective in U's ali file, if there is no with_clause for P. In this 11651 -- case we add the Elaborate_All on the unit Q that directly or indirectly 11652 -- makes P available. This can happen in two cases: 11653 -- 11654 -- a) Q declares a subtype of a type declared in P, and the call is an 11655 -- initialization call for an object of that subtype. 11656 -- 11657 -- b) Q declares an object of some tagged type whose root type is 11658 -- declared in P, and the initialization call uses object notation on 11659 -- that object to reach a primitive operation or a classwide operation 11660 -- declared in P. 11661 -- 11662 -- If P appears in the context of U, the current processing is correct. 11663 -- Otherwise we must identify these two cases to retrieve Q and place the 11664 -- Elaborate_All_Desirable on it. 11665 11666 function Spec_Entity (E : Entity_Id) return Entity_Id; 11667 -- Given a compilation unit entity, if it is a spec entity, it is returned 11668 -- unchanged. If it is a body entity, then the spec for the corresponding 11669 -- spec is returned 11670 11671 function Within (E1, E2 : Entity_Id) return Boolean; 11672 -- Given two scopes E1 and E2, returns True if E1 is equal to E2, or is one 11673 -- of its contained scopes, False otherwise. 11674 11675 function Within_Elaborate_All 11676 (Unit : Unit_Number_Type; 11677 E : Entity_Id) return Boolean; 11678 -- Return True if we are within the scope of an Elaborate_All for E, or if 11679 -- we are within the scope of an Elaborate_All for some other unit U, and U 11680 -- with's E. This prevents spurious warnings when the called entity is 11681 -- renamed within U, or in case of generic instances. 11682 11683 -------------------------------------- 11684 -- Activate_Elaborate_All_Desirable -- 11685 -------------------------------------- 11686 11687 procedure Activate_Elaborate_All_Desirable (N : Node_Id; U : Entity_Id) is 11688 UN : constant Unit_Number_Type := Get_Code_Unit (N); 11689 CU : constant Node_Id := Cunit (UN); 11690 UE : constant Entity_Id := Cunit_Entity (UN); 11691 Unm : constant Unit_Name_Type := Unit_Name (UN); 11692 CI : constant List_Id := Context_Items (CU); 11693 Itm : Node_Id; 11694 Ent : Entity_Id; 11695 11696 procedure Add_To_Context_And_Mark (Itm : Node_Id); 11697 -- This procedure is called when the elaborate indication must be 11698 -- applied to a unit not in the context of the referencing unit. The 11699 -- unit gets added to the context as an implicit with. 11700 11701 function In_Withs_Of (UEs : Entity_Id) return Boolean; 11702 -- UEs is the spec entity of a unit. If the unit to be marked is 11703 -- in the context item list of this unit spec, then the call returns 11704 -- True and Itm is left set to point to the relevant N_With_Clause node. 11705 11706 procedure Set_Elab_Flag (Itm : Node_Id); 11707 -- Sets Elaborate_[All_]Desirable as appropriate on Itm 11708 11709 ----------------------------- 11710 -- Add_To_Context_And_Mark -- 11711 ----------------------------- 11712 11713 procedure Add_To_Context_And_Mark (Itm : Node_Id) is 11714 CW : constant Node_Id := 11715 Make_With_Clause (Sloc (Itm), 11716 Name => Name (Itm)); 11717 11718 begin 11719 Set_Library_Unit (CW, Library_Unit (Itm)); 11720 Set_Implicit_With (CW); 11721 11722 -- Set elaborate all desirable on copy and then append the copy to 11723 -- the list of body with's and we are done. 11724 11725 Set_Elab_Flag (CW); 11726 Append_To (CI, CW); 11727 end Add_To_Context_And_Mark; 11728 11729 ----------------- 11730 -- In_Withs_Of -- 11731 ----------------- 11732 11733 function In_Withs_Of (UEs : Entity_Id) return Boolean is 11734 UNs : constant Unit_Number_Type := Get_Source_Unit (UEs); 11735 CUs : constant Node_Id := Cunit (UNs); 11736 CIs : constant List_Id := Context_Items (CUs); 11737 11738 begin 11739 Itm := First (CIs); 11740 while Present (Itm) loop 11741 if Nkind (Itm) = N_With_Clause then 11742 Ent := 11743 Cunit_Entity (Get_Cunit_Unit_Number (Library_Unit (Itm))); 11744 11745 if U = Ent then 11746 return True; 11747 end if; 11748 end if; 11749 11750 Next (Itm); 11751 end loop; 11752 11753 return False; 11754 end In_Withs_Of; 11755 11756 ------------------- 11757 -- Set_Elab_Flag -- 11758 ------------------- 11759 11760 procedure Set_Elab_Flag (Itm : Node_Id) is 11761 begin 11762 if Nkind (N) in N_Subprogram_Instantiation then 11763 Set_Elaborate_Desirable (Itm); 11764 else 11765 Set_Elaborate_All_Desirable (Itm); 11766 end if; 11767 end Set_Elab_Flag; 11768 11769 -- Start of processing for Activate_Elaborate_All_Desirable 11770 11771 begin 11772 -- Do not set binder indication if expansion is disabled, as when 11773 -- compiling a generic unit. 11774 11775 if not Expander_Active then 11776 return; 11777 end if; 11778 11779 -- If an instance of a generic package contains a controlled object (so 11780 -- we're calling Initialize at elaboration time), and the instance is in 11781 -- a package body P that says "with P;", then we need to return without 11782 -- adding "pragma Elaborate_All (P);" to P. 11783 11784 if U = Main_Unit_Entity then 11785 return; 11786 end if; 11787 11788 Itm := First (CI); 11789 while Present (Itm) loop 11790 if Nkind (Itm) = N_With_Clause then 11791 Ent := Cunit_Entity (Get_Cunit_Unit_Number (Library_Unit (Itm))); 11792 11793 -- If we find it, then mark elaborate all desirable and return 11794 11795 if U = Ent then 11796 Set_Elab_Flag (Itm); 11797 return; 11798 end if; 11799 end if; 11800 11801 Next (Itm); 11802 end loop; 11803 11804 -- If we fall through then the with clause is not present in the 11805 -- current unit. One legitimate possibility is that the with clause 11806 -- is present in the spec when we are a body. 11807 11808 if Is_Body_Name (Unm) 11809 and then In_Withs_Of (Spec_Entity (UE)) 11810 then 11811 Add_To_Context_And_Mark (Itm); 11812 return; 11813 end if; 11814 11815 -- Similarly, we may be in the spec or body of a child unit, where 11816 -- the unit in question is with'ed by some ancestor of the child unit. 11817 11818 if Is_Child_Name (Unm) then 11819 declare 11820 Pkg : Entity_Id; 11821 11822 begin 11823 Pkg := UE; 11824 loop 11825 Pkg := Scope (Pkg); 11826 exit when Pkg = Standard_Standard; 11827 11828 if In_Withs_Of (Pkg) then 11829 Add_To_Context_And_Mark (Itm); 11830 return; 11831 end if; 11832 end loop; 11833 end; 11834 end if; 11835 11836 -- Here if we do not find with clause on spec or body. We just ignore 11837 -- this case; it means that the elaboration involves some other unit 11838 -- than the unit being compiled, and will be caught elsewhere. 11839 end Activate_Elaborate_All_Desirable; 11840 11841 ------------------ 11842 -- Check_A_Call -- 11843 ------------------ 11844 11845 procedure Check_A_Call 11846 (N : Node_Id; 11847 E : Entity_Id; 11848 Outer_Scope : Entity_Id; 11849 Inter_Unit_Only : Boolean; 11850 Generate_Warnings : Boolean := True; 11851 In_Init_Proc : Boolean := False) 11852 is 11853 Access_Case : constant Boolean := Nkind (N) = N_Attribute_Reference; 11854 -- Indicates if we have Access attribute case 11855 11856 function Call_To_Instance_From_Outside (Id : Entity_Id) return Boolean; 11857 -- True if we're calling an instance of a generic subprogram, or a 11858 -- subprogram in an instance of a generic package, and the call is 11859 -- outside that instance. 11860 11861 procedure Elab_Warning 11862 (Msg_D : String; 11863 Msg_S : String; 11864 Ent : Node_Or_Entity_Id); 11865 -- Generate a call to Error_Msg_NE with parameters Msg_D or Msg_S (for 11866 -- dynamic or static elaboration model), N and Ent. Msg_D is a real 11867 -- warning (output if Msg_D is non-null and Elab_Warnings is set), 11868 -- Msg_S is an info message (output if Elab_Info_Messages is set). 11869 11870 function Find_W_Scope return Entity_Id; 11871 -- Find top-level scope for called entity (not following renamings 11872 -- or derivations). This is where the Elaborate_All will go if it is 11873 -- needed. We start with the called entity, except in the case of an 11874 -- initialization procedure outside the current package, where the init 11875 -- proc is in the root package, and we start from the entity of the name 11876 -- in the call. 11877 11878 ----------------------------------- 11879 -- Call_To_Instance_From_Outside -- 11880 ----------------------------------- 11881 11882 function Call_To_Instance_From_Outside (Id : Entity_Id) return Boolean is 11883 Scop : Entity_Id := Id; 11884 11885 begin 11886 loop 11887 if Scop = Standard_Standard then 11888 return False; 11889 end if; 11890 11891 if Is_Generic_Instance (Scop) then 11892 return not In_Open_Scopes (Scop); 11893 end if; 11894 11895 Scop := Scope (Scop); 11896 end loop; 11897 end Call_To_Instance_From_Outside; 11898 11899 ------------------ 11900 -- Elab_Warning -- 11901 ------------------ 11902 11903 procedure Elab_Warning 11904 (Msg_D : String; 11905 Msg_S : String; 11906 Ent : Node_Or_Entity_Id) 11907 is 11908 begin 11909 -- Dynamic elaboration checks, real warning 11910 11911 if Dynamic_Elaboration_Checks then 11912 if not Access_Case then 11913 if Msg_D /= "" and then Elab_Warnings then 11914 Error_Msg_NE (Msg_D, N, Ent); 11915 end if; 11916 11917 -- In the access case emit first warning message as well, 11918 -- otherwise list of calls will appear as errors. 11919 11920 elsif Elab_Warnings then 11921 Error_Msg_NE (Msg_S, N, Ent); 11922 end if; 11923 11924 -- Static elaboration checks, info message 11925 11926 else 11927 if Elab_Info_Messages then 11928 Error_Msg_NE (Msg_S, N, Ent); 11929 end if; 11930 end if; 11931 end Elab_Warning; 11932 11933 ------------------ 11934 -- Find_W_Scope -- 11935 ------------------ 11936 11937 function Find_W_Scope return Entity_Id is 11938 Refed_Ent : constant Entity_Id := Get_Referenced_Ent (N); 11939 W_Scope : Entity_Id; 11940 11941 begin 11942 if Is_Init_Proc (Refed_Ent) 11943 and then not In_Same_Extended_Unit (N, Refed_Ent) 11944 then 11945 W_Scope := Scope (Refed_Ent); 11946 else 11947 W_Scope := E; 11948 end if; 11949 11950 -- Now loop through scopes to get to the enclosing compilation unit 11951 11952 while not Is_Compilation_Unit (W_Scope) loop 11953 W_Scope := Scope (W_Scope); 11954 end loop; 11955 11956 return W_Scope; 11957 end Find_W_Scope; 11958 11959 -- Local variables 11960 11961 Inst_Case : constant Boolean := Nkind (N) in N_Generic_Instantiation; 11962 -- Indicates if we have instantiation case 11963 11964 Loc : constant Source_Ptr := Sloc (N); 11965 11966 Variable_Case : constant Boolean := 11967 Nkind (N) in N_Has_Entity 11968 and then Present (Entity (N)) 11969 and then Ekind (Entity (N)) = E_Variable; 11970 -- Indicates if we have variable reference case 11971 11972 W_Scope : constant Entity_Id := Find_W_Scope; 11973 -- Top-level scope of directly called entity for subprogram. This 11974 -- differs from E_Scope in the case where renamings or derivations 11975 -- are involved, since it does not follow these links. W_Scope is 11976 -- generally in a visible unit, and it is this scope that may require 11977 -- an Elaborate_All. However, there are some cases (initialization 11978 -- calls and calls involving object notation) where W_Scope might not 11979 -- be in the context of the current unit, and there is an intermediate 11980 -- package that is, in which case the Elaborate_All has to be placed 11981 -- on this intermediate package. These special cases are handled in 11982 -- Set_Elaboration_Constraint. 11983 11984 Ent : Entity_Id; 11985 Callee_Unit_Internal : Boolean; 11986 Caller_Unit_Internal : Boolean; 11987 Decl : Node_Id; 11988 Inst_Callee : Source_Ptr; 11989 Inst_Caller : Source_Ptr; 11990 Unit_Callee : Unit_Number_Type; 11991 Unit_Caller : Unit_Number_Type; 11992 11993 Body_Acts_As_Spec : Boolean; 11994 -- Set to true if call is to body acting as spec (no separate spec) 11995 11996 Cunit_SC : Boolean := False; 11997 -- Set to suppress dynamic elaboration checks where one of the 11998 -- enclosing scopes has Elaboration_Checks_Suppressed set, or else 11999 -- if a pragma Elaborate[_All] applies to that scope, in which case 12000 -- warnings on the scope are also suppressed. For the internal case, 12001 -- we ignore this flag. 12002 12003 E_Scope : Entity_Id; 12004 -- Top-level scope of entity for called subprogram. This value includes 12005 -- following renamings and derivations, so this scope can be in a 12006 -- non-visible unit. This is the scope that is to be investigated to 12007 -- see whether an elaboration check is required. 12008 12009 Is_DIC : Boolean; 12010 -- Flag set when the subprogram being invoked is the procedure generated 12011 -- for pragma Default_Initial_Condition. 12012 12013 SPARK_Elab_Errors : Boolean; 12014 -- Flag set when an entity is called or a variable is read during SPARK 12015 -- dynamic elaboration. 12016 12017 -- Start of processing for Check_A_Call 12018 12019 begin 12020 -- If the call is known to be within a local Suppress Elaboration 12021 -- pragma, nothing to check. This can happen in task bodies. But 12022 -- we ignore this for a call to a generic formal. 12023 12024 if Nkind (N) in N_Subprogram_Call 12025 and then No_Elaboration_Check (N) 12026 and then not Is_Call_Of_Generic_Formal (N) 12027 then 12028 return; 12029 12030 -- If this is a rewrite of a Valid_Scalars attribute, then nothing to 12031 -- check, we don't mind in this case if the call occurs before the body 12032 -- since this is all generated code. 12033 12034 elsif Nkind (Original_Node (N)) = N_Attribute_Reference 12035 and then Attribute_Name (Original_Node (N)) = Name_Valid_Scalars 12036 then 12037 return; 12038 12039 -- Intrinsics such as instances of Unchecked_Deallocation do not have 12040 -- any body, so elaboration checking is not needed, and would be wrong. 12041 12042 elsif Is_Intrinsic_Subprogram (E) then 12043 return; 12044 12045 -- Do not consider references to internal variables for SPARK semantics 12046 12047 elsif Variable_Case and then not Comes_From_Source (E) then 12048 return; 12049 end if; 12050 12051 -- Proceed with check 12052 12053 Ent := E; 12054 12055 -- For a variable reference, just set Body_Acts_As_Spec to False 12056 12057 if Variable_Case then 12058 Body_Acts_As_Spec := False; 12059 12060 -- Additional checks for all other cases 12061 12062 else 12063 -- Go to parent for derived subprogram, or to original subprogram in 12064 -- the case of a renaming (Alias covers both these cases). 12065 12066 loop 12067 if (Suppress_Elaboration_Warnings (Ent) 12068 or else Elaboration_Checks_Suppressed (Ent)) 12069 and then (Inst_Case or else No (Alias (Ent))) 12070 then 12071 return; 12072 end if; 12073 12074 -- Nothing to do for imported entities 12075 12076 if Is_Imported (Ent) then 12077 return; 12078 end if; 12079 12080 exit when Inst_Case or else No (Alias (Ent)); 12081 Ent := Alias (Ent); 12082 end loop; 12083 12084 Decl := Unit_Declaration_Node (Ent); 12085 12086 if Nkind (Decl) = N_Subprogram_Body then 12087 Body_Acts_As_Spec := True; 12088 12089 elsif Nkind_In (Decl, N_Subprogram_Declaration, 12090 N_Subprogram_Body_Stub) 12091 or else Inst_Case 12092 then 12093 Body_Acts_As_Spec := False; 12094 12095 -- If we have none of an instantiation, subprogram body or subprogram 12096 -- declaration, or in the SPARK case, a variable reference, then 12097 -- it is not a case that we want to check. (One case is a call to a 12098 -- generic formal subprogram, where we do not want the check in the 12099 -- template). 12100 12101 else 12102 return; 12103 end if; 12104 end if; 12105 12106 E_Scope := Ent; 12107 loop 12108 if Elaboration_Checks_Suppressed (E_Scope) 12109 or else Suppress_Elaboration_Warnings (E_Scope) 12110 then 12111 Cunit_SC := True; 12112 end if; 12113 12114 -- Exit when we get to compilation unit, not counting subunits 12115 12116 exit when Is_Compilation_Unit (E_Scope) 12117 and then (Is_Child_Unit (E_Scope) 12118 or else Scope (E_Scope) = Standard_Standard); 12119 12120 pragma Assert (E_Scope /= Standard_Standard); 12121 12122 -- Move up a scope looking for compilation unit 12123 12124 E_Scope := Scope (E_Scope); 12125 end loop; 12126 12127 -- No checks needed for pure or preelaborated compilation units 12128 12129 if Is_Pure (E_Scope) or else Is_Preelaborated (E_Scope) then 12130 return; 12131 end if; 12132 12133 -- If the generic entity is within a deeper instance than we are, then 12134 -- either the instantiation to which we refer itself caused an ABE, in 12135 -- which case that will be handled separately, or else we know that the 12136 -- body we need appears as needed at the point of the instantiation. 12137 -- However, this assumption is only valid if we are in static mode. 12138 12139 if not Dynamic_Elaboration_Checks 12140 and then 12141 Instantiation_Depth (Sloc (Ent)) > Instantiation_Depth (Sloc (N)) 12142 then 12143 return; 12144 end if; 12145 12146 -- Do not give a warning for a package with no body 12147 12148 if Ekind (Ent) = E_Generic_Package and then not Has_Generic_Body (N) then 12149 return; 12150 end if; 12151 12152 -- Case of entity is in same unit as call or instantiation. In the 12153 -- instantiation case, W_Scope may be different from E_Scope; we want 12154 -- the unit in which the instantiation occurs, since we're analyzing 12155 -- based on the expansion. 12156 12157 if W_Scope = C_Scope then 12158 if not Inter_Unit_Only then 12159 Check_Internal_Call (N, Ent, Outer_Scope, E); 12160 end if; 12161 12162 return; 12163 end if; 12164 12165 -- Case of entity is not in current unit (i.e. with'ed unit case) 12166 12167 -- We are only interested in such calls if the outer call was from 12168 -- elaboration code, or if we are in Dynamic_Elaboration_Checks mode. 12169 12170 if not From_Elab_Code and then not Dynamic_Elaboration_Checks then 12171 return; 12172 end if; 12173 12174 -- Nothing to do if some scope said that no checks were required 12175 12176 if Cunit_SC then 12177 return; 12178 end if; 12179 12180 -- Nothing to do for a generic instance, because a call to an instance 12181 -- cannot fail the elaboration check, because the body of the instance 12182 -- is always elaborated immediately after the spec. 12183 12184 if Call_To_Instance_From_Outside (Ent) then 12185 return; 12186 end if; 12187 12188 -- Nothing to do if subprogram with no separate spec. However, a call 12189 -- to Deep_Initialize may result in a call to a user-defined Initialize 12190 -- procedure, which imposes a body dependency. This happens only if the 12191 -- type is controlled and the Initialize procedure is not inherited. 12192 12193 if Body_Acts_As_Spec then 12194 if Is_TSS (Ent, TSS_Deep_Initialize) then 12195 declare 12196 Typ : constant Entity_Id := Etype (First_Formal (Ent)); 12197 Init : Entity_Id; 12198 12199 begin 12200 if not Is_Controlled (Typ) then 12201 return; 12202 else 12203 Init := Find_Prim_Op (Typ, Name_Initialize); 12204 12205 if Comes_From_Source (Init) then 12206 Ent := Init; 12207 else 12208 return; 12209 end if; 12210 end if; 12211 end; 12212 12213 else 12214 return; 12215 end if; 12216 end if; 12217 12218 -- Check cases of internal units 12219 12220 Callee_Unit_Internal := In_Internal_Unit (E_Scope); 12221 12222 -- Do not give a warning if the with'ed unit is internal and this is 12223 -- the generic instantiation case (this saves a lot of hassle dealing 12224 -- with the Text_IO special child units) 12225 12226 if Callee_Unit_Internal and Inst_Case then 12227 return; 12228 end if; 12229 12230 if C_Scope = Standard_Standard then 12231 Caller_Unit_Internal := False; 12232 else 12233 Caller_Unit_Internal := In_Internal_Unit (C_Scope); 12234 end if; 12235 12236 -- Do not give a warning if the with'ed unit is internal and the caller 12237 -- is not internal (since the binder always elaborates internal units 12238 -- first). 12239 12240 if Callee_Unit_Internal and not Caller_Unit_Internal then 12241 return; 12242 end if; 12243 12244 -- For now, if debug flag -gnatdE is not set, do no checking for one 12245 -- internal unit withing another. This fixes the problem with the sgi 12246 -- build and storage errors. To be resolved later ??? 12247 12248 if (Callee_Unit_Internal and Caller_Unit_Internal) 12249 and not Debug_Flag_EE 12250 then 12251 return; 12252 end if; 12253 12254 if Is_TSS (E, TSS_Deep_Initialize) then 12255 Ent := E; 12256 end if; 12257 12258 -- If the call is in an instance, and the called entity is not 12259 -- defined in the same instance, then the elaboration issue focuses 12260 -- around the unit containing the template, it is this unit that 12261 -- requires an Elaborate_All. 12262 12263 -- However, if we are doing dynamic elaboration, we need to chase the 12264 -- call in the usual manner. 12265 12266 -- We also need to chase the call in the usual manner if it is a call 12267 -- to a generic formal parameter, since that case was not handled as 12268 -- part of the processing of the template. 12269 12270 Inst_Caller := Instantiation (Get_Source_File_Index (Sloc (N))); 12271 Inst_Callee := Instantiation (Get_Source_File_Index (Sloc (Ent))); 12272 12273 if Inst_Caller = No_Location then 12274 Unit_Caller := No_Unit; 12275 else 12276 Unit_Caller := Get_Source_Unit (N); 12277 end if; 12278 12279 if Inst_Callee = No_Location then 12280 Unit_Callee := No_Unit; 12281 else 12282 Unit_Callee := Get_Source_Unit (Ent); 12283 end if; 12284 12285 if Unit_Caller /= No_Unit 12286 and then Unit_Callee /= Unit_Caller 12287 and then not Dynamic_Elaboration_Checks 12288 and then not Is_Call_Of_Generic_Formal (N) 12289 then 12290 E_Scope := Spec_Entity (Cunit_Entity (Unit_Caller)); 12291 12292 -- If we don't get a spec entity, just ignore call. Not quite 12293 -- clear why this check is necessary. ??? 12294 12295 if No (E_Scope) then 12296 return; 12297 end if; 12298 12299 -- Otherwise step to enclosing compilation unit 12300 12301 while not Is_Compilation_Unit (E_Scope) loop 12302 E_Scope := Scope (E_Scope); 12303 end loop; 12304 12305 -- For the case where N is not an instance, and is not a call within 12306 -- instance to other than a generic formal, we recompute E_Scope 12307 -- for the error message, since we do NOT want to go to the unit 12308 -- that has the ultimate declaration in the case of renaming and 12309 -- derivation and we also want to go to the generic unit in the 12310 -- case of an instance, and no further. 12311 12312 else 12313 -- Loop to carefully follow renamings and derivations one step 12314 -- outside the current unit, but not further. 12315 12316 if not (Inst_Case or Variable_Case) 12317 and then Present (Alias (Ent)) 12318 then 12319 E_Scope := Alias (Ent); 12320 else 12321 E_Scope := Ent; 12322 end if; 12323 12324 loop 12325 while not Is_Compilation_Unit (E_Scope) loop 12326 E_Scope := Scope (E_Scope); 12327 end loop; 12328 12329 -- If E_Scope is the same as C_Scope, it means that there 12330 -- definitely was a local renaming or derivation, and we 12331 -- are not yet out of the current unit. 12332 12333 exit when E_Scope /= C_Scope; 12334 Ent := Alias (Ent); 12335 E_Scope := Ent; 12336 12337 -- If no alias, there could be a previous error, but not if we've 12338 -- already reached the outermost level (Standard). 12339 12340 if No (Ent) then 12341 return; 12342 end if; 12343 end loop; 12344 end if; 12345 12346 if Within_Elaborate_All (Current_Sem_Unit, E_Scope) then 12347 return; 12348 end if; 12349 12350 -- Determine whether the Default_Initial_Condition procedure of some 12351 -- type is being invoked. 12352 12353 Is_DIC := Ekind (Ent) = E_Procedure and then Is_DIC_Procedure (Ent); 12354 12355 -- Checks related to Default_Initial_Condition fall under the SPARK 12356 -- umbrella because this is a SPARK-specific annotation. 12357 12358 SPARK_Elab_Errors := 12359 SPARK_Mode = On and (Is_DIC or Dynamic_Elaboration_Checks); 12360 12361 -- Now check if an Elaborate_All (or dynamic check) is needed 12362 12363 if (Elab_Info_Messages or Elab_Warnings or SPARK_Elab_Errors) 12364 and then Generate_Warnings 12365 and then not Suppress_Elaboration_Warnings (Ent) 12366 and then not Elaboration_Checks_Suppressed (Ent) 12367 and then not Suppress_Elaboration_Warnings (E_Scope) 12368 and then not Elaboration_Checks_Suppressed (E_Scope) 12369 then 12370 -- Instantiation case 12371 12372 if Inst_Case then 12373 if Comes_From_Source (Ent) and then SPARK_Elab_Errors then 12374 Error_Msg_NE 12375 ("instantiation of & during elaboration in SPARK", N, Ent); 12376 else 12377 Elab_Warning 12378 ("instantiation of & may raise Program_Error?l?", 12379 "info: instantiation of & during elaboration?$?", Ent); 12380 end if; 12381 12382 -- Indirect call case, info message only in static elaboration 12383 -- case, because the attribute reference itself cannot raise an 12384 -- exception. Note that SPARK does not permit indirect calls. 12385 12386 elsif Access_Case then 12387 Elab_Warning ("", "info: access to & during elaboration?$?", Ent); 12388 12389 -- Variable reference in SPARK mode 12390 12391 elsif Variable_Case then 12392 if Comes_From_Source (Ent) and then SPARK_Elab_Errors then 12393 Error_Msg_NE 12394 ("reference to & during elaboration in SPARK", N, Ent); 12395 end if; 12396 12397 -- Subprogram call case 12398 12399 else 12400 if Nkind (Name (N)) in N_Has_Entity 12401 and then Is_Init_Proc (Entity (Name (N))) 12402 and then Comes_From_Source (Ent) 12403 then 12404 Elab_Warning 12405 ("implicit call to & may raise Program_Error?l?", 12406 "info: implicit call to & during elaboration?$?", 12407 Ent); 12408 12409 elsif SPARK_Elab_Errors then 12410 12411 -- Emit a specialized error message when the elaboration of an 12412 -- object of a private type evaluates the expression of pragma 12413 -- Default_Initial_Condition. This prevents the internal name 12414 -- of the procedure from appearing in the error message. 12415 12416 if Is_DIC then 12417 Error_Msg_N 12418 ("call to Default_Initial_Condition during elaboration in " 12419 & "SPARK", N); 12420 else 12421 Error_Msg_NE 12422 ("call to & during elaboration in SPARK", N, Ent); 12423 end if; 12424 12425 else 12426 Elab_Warning 12427 ("call to & may raise Program_Error?l?", 12428 "info: call to & during elaboration?$?", 12429 Ent); 12430 end if; 12431 end if; 12432 12433 Error_Msg_Qual_Level := Nat'Last; 12434 12435 -- Case of Elaborate_All not present and required, for SPARK this 12436 -- is an error, so give an error message. 12437 12438 if SPARK_Elab_Errors then 12439 Error_Msg_NE -- CODEFIX 12440 ("\Elaborate_All pragma required for&", N, W_Scope); 12441 12442 -- Otherwise we generate an implicit pragma. For a subprogram 12443 -- instantiation, Elaborate is good enough, since no transitive 12444 -- call is possible at elaboration time in this case. 12445 12446 elsif Nkind (N) in N_Subprogram_Instantiation then 12447 Elab_Warning 12448 ("\missing pragma Elaborate for&?l?", 12449 "\implicit pragma Elaborate for& generated?$?", 12450 W_Scope); 12451 12452 -- For all other cases, we need an implicit Elaborate_All 12453 12454 else 12455 Elab_Warning 12456 ("\missing pragma Elaborate_All for&?l?", 12457 "\implicit pragma Elaborate_All for & generated?$?", 12458 W_Scope); 12459 end if; 12460 12461 Error_Msg_Qual_Level := 0; 12462 12463 -- Take into account the flags related to elaboration warning 12464 -- messages when enumerating the various calls involved. This 12465 -- ensures the proper pairing of the main warning and the 12466 -- clarification messages generated by Output_Calls. 12467 12468 Output_Calls (N, Check_Elab_Flag => True); 12469 12470 -- Set flag to prevent further warnings for same unit unless in 12471 -- All_Errors_Mode. 12472 12473 if not All_Errors_Mode and not Dynamic_Elaboration_Checks then 12474 Set_Suppress_Elaboration_Warnings (W_Scope); 12475 end if; 12476 end if; 12477 12478 -- Check for runtime elaboration check required 12479 12480 if Dynamic_Elaboration_Checks then 12481 if not Elaboration_Checks_Suppressed (Ent) 12482 and then not Elaboration_Checks_Suppressed (W_Scope) 12483 and then not Elaboration_Checks_Suppressed (E_Scope) 12484 and then not Cunit_SC 12485 then 12486 -- Runtime elaboration check required. Generate check of the 12487 -- elaboration Boolean for the unit containing the entity. 12488 12489 -- Note that for this case, we do check the real unit (the one 12490 -- from following renamings, since that is the issue). 12491 12492 -- Could this possibly miss a useless but required PE??? 12493 12494 Insert_Elab_Check (N, 12495 Make_Attribute_Reference (Loc, 12496 Attribute_Name => Name_Elaborated, 12497 Prefix => 12498 New_Occurrence_Of (Spec_Entity (E_Scope), Loc))); 12499 12500 -- Prevent duplicate elaboration checks on the same call, which 12501 -- can happen if the body enclosing the call appears itself in a 12502 -- call whose elaboration check is delayed. 12503 12504 if Nkind (N) in N_Subprogram_Call then 12505 Set_No_Elaboration_Check (N); 12506 end if; 12507 end if; 12508 12509 -- Case of static elaboration model 12510 12511 else 12512 -- Do not do anything if elaboration checks suppressed. Note that 12513 -- we check Ent here, not E, since we want the real entity for the 12514 -- body to see if checks are suppressed for it, not the dummy 12515 -- entry for renamings or derivations. 12516 12517 if Elaboration_Checks_Suppressed (Ent) 12518 or else Elaboration_Checks_Suppressed (E_Scope) 12519 or else Elaboration_Checks_Suppressed (W_Scope) 12520 then 12521 null; 12522 12523 -- Do not generate an Elaborate_All for finalization routines 12524 -- that perform partial clean up as part of initialization. 12525 12526 elsif In_Init_Proc and then Is_Finalization_Procedure (Ent) then 12527 null; 12528 12529 -- Here we need to generate an implicit elaborate all 12530 12531 else 12532 -- Generate Elaborate_All warning unless suppressed 12533 12534 if (Elab_Info_Messages and Generate_Warnings and not Inst_Case) 12535 and then not Suppress_Elaboration_Warnings (Ent) 12536 and then not Suppress_Elaboration_Warnings (E_Scope) 12537 and then not Suppress_Elaboration_Warnings (W_Scope) 12538 then 12539 Error_Msg_Node_2 := W_Scope; 12540 Error_Msg_NE 12541 ("info: call to& in elaboration code requires pragma " 12542 & "Elaborate_All on&?$?", N, E); 12543 end if; 12544 12545 -- Set indication for binder to generate Elaborate_All 12546 12547 Set_Elaboration_Constraint (N, E, W_Scope); 12548 end if; 12549 end if; 12550 end Check_A_Call; 12551 12552 ----------------------------- 12553 -- Check_Bad_Instantiation -- 12554 ----------------------------- 12555 12556 procedure Check_Bad_Instantiation (N : Node_Id) is 12557 Ent : Entity_Id; 12558 12559 begin 12560 -- Nothing to do if we do not have an instantiation (happens in some 12561 -- error cases, and also in the formal package declaration case) 12562 12563 if Nkind (N) not in N_Generic_Instantiation then 12564 return; 12565 12566 -- Nothing to do if serious errors detected (avoid cascaded errors) 12567 12568 elsif Serious_Errors_Detected /= 0 then 12569 return; 12570 12571 -- Nothing to do if not in full analysis mode 12572 12573 elsif not Full_Analysis then 12574 return; 12575 12576 -- Nothing to do if inside a generic template 12577 12578 elsif Inside_A_Generic then 12579 return; 12580 12581 -- Nothing to do if a library level instantiation 12582 12583 elsif Nkind (Parent (N)) = N_Compilation_Unit then 12584 return; 12585 12586 -- Nothing to do if we are compiling a proper body for semantic 12587 -- purposes only. The generic body may be in another proper body. 12588 12589 elsif 12590 Nkind (Parent (Unit_Declaration_Node (Main_Unit_Entity))) = N_Subunit 12591 then 12592 return; 12593 end if; 12594 12595 Ent := Get_Generic_Entity (N); 12596 12597 -- The case we are interested in is when the generic spec is in the 12598 -- current declarative part 12599 12600 if not Same_Elaboration_Scope (Current_Scope, Scope (Ent)) 12601 or else not In_Same_Extended_Unit (N, Ent) 12602 then 12603 return; 12604 end if; 12605 12606 -- If the generic entity is within a deeper instance than we are, then 12607 -- either the instantiation to which we refer itself caused an ABE, in 12608 -- which case that will be handled separately. Otherwise, we know that 12609 -- the body we need appears as needed at the point of the instantiation. 12610 -- If they are both at the same level but not within the same instance 12611 -- then the body of the generic will be in the earlier instance. 12612 12613 declare 12614 D1 : constant Nat := Instantiation_Depth (Sloc (Ent)); 12615 D2 : constant Nat := Instantiation_Depth (Sloc (N)); 12616 12617 begin 12618 if D1 > D2 then 12619 return; 12620 12621 elsif D1 = D2 12622 and then Is_Generic_Instance (Scope (Ent)) 12623 and then not In_Open_Scopes (Scope (Ent)) 12624 then 12625 return; 12626 end if; 12627 end; 12628 12629 -- Now we can proceed, if the entity being called has a completion, 12630 -- then we are definitely OK, since we have already seen the body. 12631 12632 if Has_Completion (Ent) then 12633 return; 12634 end if; 12635 12636 -- If there is no body, then nothing to do 12637 12638 if not Has_Generic_Body (N) then 12639 return; 12640 end if; 12641 12642 -- Here we definitely have a bad instantiation 12643 12644 Error_Msg_Warn := SPARK_Mode /= On; 12645 Error_Msg_NE ("cannot instantiate& before body seen<<", N, Ent); 12646 Error_Msg_N ("\Program_Error [<<", N); 12647 12648 Insert_Elab_Check (N); 12649 Set_Is_Known_Guaranteed_ABE (N); 12650 end Check_Bad_Instantiation; 12651 12652 --------------------- 12653 -- Check_Elab_Call -- 12654 --------------------- 12655 12656 procedure Check_Elab_Call 12657 (N : Node_Id; 12658 Outer_Scope : Entity_Id := Empty; 12659 In_Init_Proc : Boolean := False) 12660 is 12661 Ent : Entity_Id; 12662 P : Node_Id; 12663 12664 begin 12665 pragma Assert (Legacy_Elaboration_Checks); 12666 12667 -- If the reference is not in the main unit, there is nothing to check. 12668 -- Elaboration call from units in the context of the main unit will lead 12669 -- to semantic dependencies when those units are compiled. 12670 12671 if not In_Extended_Main_Code_Unit (N) then 12672 return; 12673 end if; 12674 12675 -- For an entry call, check relevant restriction 12676 12677 if Nkind (N) = N_Entry_Call_Statement 12678 and then not In_Subprogram_Or_Concurrent_Unit 12679 then 12680 Check_Restriction (No_Entry_Calls_In_Elaboration_Code, N); 12681 12682 -- Nothing to do if this is not an expected type of reference (happens 12683 -- in some error conditions, and in some cases where rewriting occurs). 12684 12685 elsif Nkind (N) not in N_Subprogram_Call 12686 and then Nkind (N) /= N_Attribute_Reference 12687 and then (SPARK_Mode /= On 12688 or else Nkind (N) not in N_Has_Entity 12689 or else No (Entity (N)) 12690 or else Ekind (Entity (N)) /= E_Variable) 12691 then 12692 return; 12693 12694 -- Nothing to do if this is a call already rewritten for elab checking. 12695 -- Such calls appear as the targets of If_Expressions. 12696 12697 -- This check MUST be wrong, it catches far too much 12698 12699 elsif Nkind (Parent (N)) = N_If_Expression then 12700 return; 12701 12702 -- Nothing to do if inside a generic template 12703 12704 elsif Inside_A_Generic 12705 and then No (Enclosing_Generic_Body (N)) 12706 then 12707 return; 12708 12709 -- Nothing to do if call is being pre-analyzed, as when within a 12710 -- pre/postcondition, a predicate, or an invariant. 12711 12712 elsif In_Spec_Expression then 12713 return; 12714 end if; 12715 12716 -- Nothing to do if this is a call to a postcondition, which is always 12717 -- within a subprogram body, even though the current scope may be the 12718 -- enclosing scope of the subprogram. 12719 12720 if Nkind (N) = N_Procedure_Call_Statement 12721 and then Is_Entity_Name (Name (N)) 12722 and then Chars (Entity (Name (N))) = Name_uPostconditions 12723 then 12724 return; 12725 end if; 12726 12727 -- Here we have a reference at elaboration time that must be checked 12728 12729 if Debug_Flag_Underscore_LL then 12730 Write_Str (" Check_Elab_Ref: "); 12731 12732 if Nkind (N) = N_Attribute_Reference then 12733 if not Is_Entity_Name (Prefix (N)) then 12734 Write_Str ("<<not entity name>>"); 12735 else 12736 Write_Name (Chars (Entity (Prefix (N)))); 12737 end if; 12738 12739 Write_Str ("'Access"); 12740 12741 elsif No (Name (N)) or else not Is_Entity_Name (Name (N)) then 12742 Write_Str ("<<not entity name>> "); 12743 12744 else 12745 Write_Name (Chars (Entity (Name (N)))); 12746 end if; 12747 12748 Write_Str (" reference at "); 12749 Write_Location (Sloc (N)); 12750 Write_Eol; 12751 end if; 12752 12753 -- Climb up the tree to make sure we are not inside default expression 12754 -- of a parameter specification or a record component, since in both 12755 -- these cases, we will be doing the actual reference later, not now, 12756 -- and it is at the time of the actual reference (statically speaking) 12757 -- that we must do our static check, not at the time of its initial 12758 -- analysis). 12759 12760 -- However, we have to check references within component definitions 12761 -- (e.g. a function call that determines an array component bound), 12762 -- so we terminate the loop in that case. 12763 12764 P := Parent (N); 12765 while Present (P) loop 12766 if Nkind_In (P, N_Parameter_Specification, 12767 N_Component_Declaration) 12768 then 12769 return; 12770 12771 -- The reference occurs within the constraint of a component, 12772 -- so it must be checked. 12773 12774 elsif Nkind (P) = N_Component_Definition then 12775 exit; 12776 12777 else 12778 P := Parent (P); 12779 end if; 12780 end loop; 12781 12782 -- Stuff that happens only at the outer level 12783 12784 if No (Outer_Scope) then 12785 Elab_Visited.Set_Last (0); 12786 12787 -- Nothing to do if current scope is Standard (this is a bit odd, but 12788 -- it happens in the case of generic instantiations). 12789 12790 C_Scope := Current_Scope; 12791 12792 if C_Scope = Standard_Standard then 12793 return; 12794 end if; 12795 12796 -- First case, we are in elaboration code 12797 12798 From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit; 12799 12800 if From_Elab_Code then 12801 12802 -- Complain if ref that comes from source in preelaborated unit 12803 -- and we are not inside a subprogram (i.e. we are in elab code). 12804 12805 if Comes_From_Source (N) 12806 and then In_Preelaborated_Unit 12807 and then not In_Inlined_Body 12808 and then Nkind (N) /= N_Attribute_Reference 12809 then 12810 -- This is a warning in GNAT mode allowing such calls to be 12811 -- used in the predefined library with appropriate care. 12812 12813 Error_Msg_Warn := GNAT_Mode; 12814 Error_Msg_N 12815 ("<<non-static call not allowed in preelaborated unit", N); 12816 return; 12817 end if; 12818 12819 -- Second case, we are inside a subprogram or concurrent unit, which 12820 -- means we are not in elaboration code. 12821 12822 else 12823 -- In this case, the issue is whether we are inside the 12824 -- declarative part of the unit in which we live, or inside its 12825 -- statements. In the latter case, there is no issue of ABE calls 12826 -- at this level (a call from outside to the unit in which we live 12827 -- might cause an ABE, but that will be detected when we analyze 12828 -- that outer level call, as it recurses into the called unit). 12829 12830 -- Climb up the tree, doing this test, and also testing for being 12831 -- inside a default expression, which, as discussed above, is not 12832 -- checked at this stage. 12833 12834 declare 12835 P : Node_Id; 12836 L : List_Id; 12837 12838 begin 12839 P := N; 12840 loop 12841 -- If we find a parentless subtree, it seems safe to assume 12842 -- that we are not in a declarative part and that no 12843 -- checking is required. 12844 12845 if No (P) then 12846 return; 12847 end if; 12848 12849 if Is_List_Member (P) then 12850 L := List_Containing (P); 12851 P := Parent (L); 12852 else 12853 L := No_List; 12854 P := Parent (P); 12855 end if; 12856 12857 exit when Nkind (P) = N_Subunit; 12858 12859 -- Filter out case of default expressions, where we do not 12860 -- do the check at this stage. 12861 12862 if Nkind_In (P, N_Parameter_Specification, 12863 N_Component_Declaration) 12864 then 12865 return; 12866 end if; 12867 12868 -- A protected body has no elaboration code and contains 12869 -- only other bodies. 12870 12871 if Nkind (P) = N_Protected_Body then 12872 return; 12873 12874 elsif Nkind_In (P, N_Subprogram_Body, 12875 N_Task_Body, 12876 N_Block_Statement, 12877 N_Entry_Body) 12878 then 12879 if L = Declarations (P) then 12880 exit; 12881 12882 -- We are not in elaboration code, but we are doing 12883 -- dynamic elaboration checks, in this case, we still 12884 -- need to do the reference, since the subprogram we are 12885 -- in could be called from another unit, also in dynamic 12886 -- elaboration check mode, at elaboration time. 12887 12888 elsif Dynamic_Elaboration_Checks then 12889 12890 -- We provide a debug flag to disable this check. That 12891 -- way we have an easy work around for regressions 12892 -- that are caused by this new check. This debug flag 12893 -- can be removed later. 12894 12895 if Debug_Flag_DD then 12896 return; 12897 end if; 12898 12899 -- Do the check in this case 12900 12901 exit; 12902 12903 elsif Nkind (P) = N_Task_Body then 12904 12905 -- The check is deferred until Check_Task_Activation 12906 -- but we need to capture local suppress pragmas 12907 -- that may inhibit checks on this call. 12908 12909 Ent := Get_Referenced_Ent (N); 12910 12911 if No (Ent) then 12912 return; 12913 12914 elsif Elaboration_Checks_Suppressed (Current_Scope) 12915 or else Elaboration_Checks_Suppressed (Ent) 12916 or else Elaboration_Checks_Suppressed (Scope (Ent)) 12917 then 12918 if Nkind (N) in N_Subprogram_Call then 12919 Set_No_Elaboration_Check (N); 12920 end if; 12921 end if; 12922 12923 return; 12924 12925 -- Static model, call is not in elaboration code, we 12926 -- never need to worry, because in the static model the 12927 -- top-level caller always takes care of things. 12928 12929 else 12930 return; 12931 end if; 12932 end if; 12933 end loop; 12934 end; 12935 end if; 12936 end if; 12937 12938 Ent := Get_Referenced_Ent (N); 12939 12940 if No (Ent) then 12941 return; 12942 end if; 12943 12944 -- Determine whether a prior call to the same subprogram was already 12945 -- examined within the same context. If this is the case, then there is 12946 -- no need to proceed with the various warnings and checks because the 12947 -- work was already done for the previous call. 12948 12949 declare 12950 Self : constant Visited_Element := 12951 (Subp_Id => Ent, Context => Parent (N)); 12952 12953 begin 12954 for Index in 1 .. Elab_Visited.Last loop 12955 if Self = Elab_Visited.Table (Index) then 12956 return; 12957 end if; 12958 end loop; 12959 end; 12960 12961 -- See if we need to analyze this reference. We analyze it if either of 12962 -- the following conditions is met: 12963 12964 -- It is an inner level call (since in this case it was triggered 12965 -- by an outer level call from elaboration code), but only if the 12966 -- call is within the scope of the original outer level call. 12967 12968 -- It is an outer level reference from elaboration code, or a call to 12969 -- an entity is in the same elaboration scope. 12970 12971 -- And in these cases, we will check both inter-unit calls and 12972 -- intra-unit (within a single unit) calls. 12973 12974 C_Scope := Current_Scope; 12975 12976 -- If not outer level reference, then we follow it if it is within the 12977 -- original scope of the outer reference. 12978 12979 if Present (Outer_Scope) 12980 and then Within (Scope (Ent), Outer_Scope) 12981 then 12982 Set_C_Scope; 12983 Check_A_Call 12984 (N => N, 12985 E => Ent, 12986 Outer_Scope => Outer_Scope, 12987 Inter_Unit_Only => False, 12988 In_Init_Proc => In_Init_Proc); 12989 12990 -- Nothing to do if elaboration checks suppressed for this scope. 12991 -- However, an interesting exception, the fact that elaboration checks 12992 -- are suppressed within an instance (because we can trace the body when 12993 -- we process the template) does not extend to calls to generic formal 12994 -- subprograms. 12995 12996 elsif Elaboration_Checks_Suppressed (Current_Scope) 12997 and then not Is_Call_Of_Generic_Formal (N) 12998 then 12999 null; 13000 13001 elsif From_Elab_Code then 13002 Set_C_Scope; 13003 Check_A_Call (N, Ent, Standard_Standard, Inter_Unit_Only => False); 13004 13005 elsif Same_Elaboration_Scope (C_Scope, Scope (Ent)) then 13006 Set_C_Scope; 13007 Check_A_Call (N, Ent, Scope (Ent), Inter_Unit_Only => False); 13008 13009 -- If none of those cases holds, but Dynamic_Elaboration_Checks mode 13010 -- is set, then we will do the check, but only in the inter-unit case 13011 -- (this is to accommodate unguarded elaboration calls from other units 13012 -- in which this same mode is set). We don't want warnings in this case, 13013 -- it would generate warnings having nothing to do with elaboration. 13014 13015 elsif Dynamic_Elaboration_Checks then 13016 Set_C_Scope; 13017 Check_A_Call 13018 (N, 13019 Ent, 13020 Standard_Standard, 13021 Inter_Unit_Only => True, 13022 Generate_Warnings => False); 13023 13024 -- Otherwise nothing to do 13025 13026 else 13027 return; 13028 end if; 13029 13030 -- A call to an Init_Proc in elaboration code may bring additional 13031 -- dependencies, if some of the record components thereof have 13032 -- initializations that are function calls that come from source. We 13033 -- treat the current node as a call to each of these functions, to check 13034 -- their elaboration impact. 13035 13036 if Is_Init_Proc (Ent) and then From_Elab_Code then 13037 Process_Init_Proc : declare 13038 Unit_Decl : constant Node_Id := Unit_Declaration_Node (Ent); 13039 13040 function Check_Init_Call (Nod : Node_Id) return Traverse_Result; 13041 -- Find subprogram calls within body of Init_Proc for Traverse 13042 -- instantiation below. 13043 13044 procedure Traverse_Body is new Traverse_Proc (Check_Init_Call); 13045 -- Traversal procedure to find all calls with body of Init_Proc 13046 13047 --------------------- 13048 -- Check_Init_Call -- 13049 --------------------- 13050 13051 function Check_Init_Call (Nod : Node_Id) return Traverse_Result is 13052 Func : Entity_Id; 13053 13054 begin 13055 if Nkind (Nod) in N_Subprogram_Call 13056 and then Is_Entity_Name (Name (Nod)) 13057 then 13058 Func := Entity (Name (Nod)); 13059 13060 if Comes_From_Source (Func) then 13061 Check_A_Call 13062 (N, Func, Standard_Standard, Inter_Unit_Only => True); 13063 end if; 13064 13065 return OK; 13066 13067 else 13068 return OK; 13069 end if; 13070 end Check_Init_Call; 13071 13072 -- Start of processing for Process_Init_Proc 13073 13074 begin 13075 if Nkind (Unit_Decl) = N_Subprogram_Body then 13076 Traverse_Body (Handled_Statement_Sequence (Unit_Decl)); 13077 end if; 13078 end Process_Init_Proc; 13079 end if; 13080 end Check_Elab_Call; 13081 13082 ----------------------- 13083 -- Check_Elab_Assign -- 13084 ----------------------- 13085 13086 procedure Check_Elab_Assign (N : Node_Id) is 13087 Ent : Entity_Id; 13088 Scop : Entity_Id; 13089 13090 Pkg_Spec : Entity_Id; 13091 Pkg_Body : Entity_Id; 13092 13093 begin 13094 pragma Assert (Legacy_Elaboration_Checks); 13095 13096 -- For record or array component, check prefix. If it is an access type, 13097 -- then there is nothing to do (we do not know what is being assigned), 13098 -- but otherwise this is an assignment to the prefix. 13099 13100 if Nkind_In (N, N_Indexed_Component, 13101 N_Selected_Component, 13102 N_Slice) 13103 then 13104 if not Is_Access_Type (Etype (Prefix (N))) then 13105 Check_Elab_Assign (Prefix (N)); 13106 end if; 13107 13108 return; 13109 end if; 13110 13111 -- For type conversion, check expression 13112 13113 if Nkind (N) = N_Type_Conversion then 13114 Check_Elab_Assign (Expression (N)); 13115 return; 13116 end if; 13117 13118 -- Nothing to do if this is not an entity reference otherwise get entity 13119 13120 if Is_Entity_Name (N) then 13121 Ent := Entity (N); 13122 else 13123 return; 13124 end if; 13125 13126 -- What we are looking for is a reference in the body of a package that 13127 -- modifies a variable declared in the visible part of the package spec. 13128 13129 if Present (Ent) 13130 and then Comes_From_Source (N) 13131 and then not Suppress_Elaboration_Warnings (Ent) 13132 and then Ekind (Ent) = E_Variable 13133 and then not In_Private_Part (Ent) 13134 and then Is_Library_Level_Entity (Ent) 13135 then 13136 Scop := Current_Scope; 13137 loop 13138 if No (Scop) or else Scop = Standard_Standard then 13139 return; 13140 elsif Ekind (Scop) = E_Package 13141 and then Is_Compilation_Unit (Scop) 13142 then 13143 exit; 13144 else 13145 Scop := Scope (Scop); 13146 end if; 13147 end loop; 13148 13149 -- Here Scop points to the containing library package 13150 13151 Pkg_Spec := Scop; 13152 Pkg_Body := Body_Entity (Pkg_Spec); 13153 13154 -- All OK if the package has an Elaborate_Body pragma 13155 13156 if Has_Pragma_Elaborate_Body (Scop) then 13157 return; 13158 end if; 13159 13160 -- OK if entity being modified is not in containing package spec 13161 13162 if not In_Same_Source_Unit (Scop, Ent) then 13163 return; 13164 end if; 13165 13166 -- All OK if entity appears in generic package or generic instance. 13167 -- We just get too messed up trying to give proper warnings in the 13168 -- presence of generics. Better no message than a junk one. 13169 13170 Scop := Scope (Ent); 13171 while Present (Scop) and then Scop /= Pkg_Spec loop 13172 if Ekind (Scop) = E_Generic_Package then 13173 return; 13174 elsif Ekind (Scop) = E_Package 13175 and then Is_Generic_Instance (Scop) 13176 then 13177 return; 13178 end if; 13179 13180 Scop := Scope (Scop); 13181 end loop; 13182 13183 -- All OK if in task, don't issue warnings there 13184 13185 if In_Task_Activation then 13186 return; 13187 end if; 13188 13189 -- OK if no package body 13190 13191 if No (Pkg_Body) then 13192 return; 13193 end if; 13194 13195 -- OK if reference is not in package body 13196 13197 if not In_Same_Source_Unit (Pkg_Body, N) then 13198 return; 13199 end if; 13200 13201 -- OK if package body has no handled statement sequence 13202 13203 declare 13204 HSS : constant Node_Id := 13205 Handled_Statement_Sequence (Declaration_Node (Pkg_Body)); 13206 begin 13207 if No (HSS) or else not Comes_From_Source (HSS) then 13208 return; 13209 end if; 13210 end; 13211 13212 -- We definitely have a case of a modification of an entity in 13213 -- the package spec from the elaboration code of the package body. 13214 -- We may not give the warning (because there are some additional 13215 -- checks to avoid too many false positives), but it would be a good 13216 -- idea for the binder to try to keep the body elaboration close to 13217 -- the spec elaboration. 13218 13219 Set_Elaborate_Body_Desirable (Pkg_Spec); 13220 13221 -- All OK in gnat mode (we know what we are doing) 13222 13223 if GNAT_Mode then 13224 return; 13225 end if; 13226 13227 -- All OK if all warnings suppressed 13228 13229 if Warning_Mode = Suppress then 13230 return; 13231 end if; 13232 13233 -- All OK if elaboration checks suppressed for entity 13234 13235 if Checks_May_Be_Suppressed (Ent) 13236 and then Is_Check_Suppressed (Ent, Elaboration_Check) 13237 then 13238 return; 13239 end if; 13240 13241 -- OK if the entity is initialized. Note that the No_Initialization 13242 -- flag usually means that the initialization has been rewritten into 13243 -- assignments, but that still counts for us. 13244 13245 declare 13246 Decl : constant Node_Id := Declaration_Node (Ent); 13247 begin 13248 if Nkind (Decl) = N_Object_Declaration 13249 and then (Present (Expression (Decl)) 13250 or else No_Initialization (Decl)) 13251 then 13252 return; 13253 end if; 13254 end; 13255 13256 -- Here is where we give the warning 13257 13258 -- All OK if warnings suppressed on the entity 13259 13260 if not Has_Warnings_Off (Ent) then 13261 Error_Msg_Sloc := Sloc (Ent); 13262 13263 Error_Msg_NE 13264 ("??& can be accessed by clients before this initialization", 13265 N, Ent); 13266 Error_Msg_NE 13267 ("\??add Elaborate_Body to spec to ensure & is initialized", 13268 N, Ent); 13269 end if; 13270 13271 if not All_Errors_Mode then 13272 Set_Suppress_Elaboration_Warnings (Ent); 13273 end if; 13274 end if; 13275 end Check_Elab_Assign; 13276 13277 ---------------------- 13278 -- Check_Elab_Calls -- 13279 ---------------------- 13280 13281 -- WARNING: This routine manages SPARK regions 13282 13283 procedure Check_Elab_Calls is 13284 Saved_SM : SPARK_Mode_Type; 13285 Saved_SMP : Node_Id; 13286 13287 begin 13288 pragma Assert (Legacy_Elaboration_Checks); 13289 13290 -- If expansion is disabled, do not generate any checks, unless we 13291 -- are in GNATprove mode, so that errors are issued in GNATprove for 13292 -- violations of static elaboration rules in SPARK code. Also skip 13293 -- checks if any subunits are missing because in either case we lack the 13294 -- full information that we need, and no object file will be created in 13295 -- any case. 13296 13297 if (not Expander_Active and not GNATprove_Mode) 13298 or else Is_Generic_Unit (Cunit_Entity (Main_Unit)) 13299 or else Subunits_Missing 13300 then 13301 return; 13302 end if; 13303 13304 -- Skip delayed calls if we had any errors 13305 13306 if Serious_Errors_Detected = 0 then 13307 Delaying_Elab_Checks := False; 13308 Expander_Mode_Save_And_Set (True); 13309 13310 for J in Delay_Check.First .. Delay_Check.Last loop 13311 Push_Scope (Delay_Check.Table (J).Curscop); 13312 From_Elab_Code := Delay_Check.Table (J).From_Elab_Code; 13313 In_Task_Activation := Delay_Check.Table (J).In_Task_Activation; 13314 13315 Saved_SM := SPARK_Mode; 13316 Saved_SMP := SPARK_Mode_Pragma; 13317 13318 -- Set appropriate value of SPARK_Mode 13319 13320 if Delay_Check.Table (J).From_SPARK_Code then 13321 SPARK_Mode := On; 13322 end if; 13323 13324 Check_Internal_Call_Continue 13325 (N => Delay_Check.Table (J).N, 13326 E => Delay_Check.Table (J).E, 13327 Outer_Scope => Delay_Check.Table (J).Outer_Scope, 13328 Orig_Ent => Delay_Check.Table (J).Orig_Ent); 13329 13330 Restore_SPARK_Mode (Saved_SM, Saved_SMP); 13331 Pop_Scope; 13332 end loop; 13333 13334 -- Set Delaying_Elab_Checks back on for next main compilation 13335 13336 Expander_Mode_Restore; 13337 Delaying_Elab_Checks := True; 13338 end if; 13339 end Check_Elab_Calls; 13340 13341 ------------------------------ 13342 -- Check_Elab_Instantiation -- 13343 ------------------------------ 13344 13345 procedure Check_Elab_Instantiation 13346 (N : Node_Id; 13347 Outer_Scope : Entity_Id := Empty) 13348 is 13349 Ent : Entity_Id; 13350 13351 begin 13352 pragma Assert (Legacy_Elaboration_Checks); 13353 13354 -- Check for and deal with bad instantiation case. There is some 13355 -- duplicated code here, but we will worry about this later ??? 13356 13357 Check_Bad_Instantiation (N); 13358 13359 if Is_Known_Guaranteed_ABE (N) then 13360 return; 13361 end if; 13362 13363 -- Nothing to do if we do not have an instantiation (happens in some 13364 -- error cases, and also in the formal package declaration case) 13365 13366 if Nkind (N) not in N_Generic_Instantiation then 13367 return; 13368 end if; 13369 13370 -- Nothing to do if inside a generic template 13371 13372 if Inside_A_Generic then 13373 return; 13374 end if; 13375 13376 -- Nothing to do if the instantiation is not in the main unit 13377 13378 if not In_Extended_Main_Code_Unit (N) then 13379 return; 13380 end if; 13381 13382 Ent := Get_Generic_Entity (N); 13383 From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit; 13384 13385 -- See if we need to analyze this instantiation. We analyze it if 13386 -- either of the following conditions is met: 13387 13388 -- It is an inner level instantiation (since in this case it was 13389 -- triggered by an outer level call from elaboration code), but 13390 -- only if the instantiation is within the scope of the original 13391 -- outer level call. 13392 13393 -- It is an outer level instantiation from elaboration code, or the 13394 -- instantiated entity is in the same elaboration scope. 13395 13396 -- And in these cases, we will check both the inter-unit case and 13397 -- the intra-unit (within a single unit) case. 13398 13399 C_Scope := Current_Scope; 13400 13401 if Present (Outer_Scope) and then Within (Scope (Ent), Outer_Scope) then 13402 Set_C_Scope; 13403 Check_A_Call (N, Ent, Outer_Scope, Inter_Unit_Only => False); 13404 13405 elsif From_Elab_Code then 13406 Set_C_Scope; 13407 Check_A_Call (N, Ent, Standard_Standard, Inter_Unit_Only => False); 13408 13409 elsif Same_Elaboration_Scope (C_Scope, Scope (Ent)) then 13410 Set_C_Scope; 13411 Check_A_Call (N, Ent, Scope (Ent), Inter_Unit_Only => False); 13412 13413 -- If none of those cases holds, but Dynamic_Elaboration_Checks mode is 13414 -- set, then we will do the check, but only in the inter-unit case (this 13415 -- is to accommodate unguarded elaboration calls from other units in 13416 -- which this same mode is set). We inhibit warnings in this case, since 13417 -- this instantiation is not occurring in elaboration code. 13418 13419 elsif Dynamic_Elaboration_Checks then 13420 Set_C_Scope; 13421 Check_A_Call 13422 (N, 13423 Ent, 13424 Standard_Standard, 13425 Inter_Unit_Only => True, 13426 Generate_Warnings => False); 13427 13428 else 13429 return; 13430 end if; 13431 end Check_Elab_Instantiation; 13432 13433 ------------------------- 13434 -- Check_Internal_Call -- 13435 ------------------------- 13436 13437 procedure Check_Internal_Call 13438 (N : Node_Id; 13439 E : Entity_Id; 13440 Outer_Scope : Entity_Id; 13441 Orig_Ent : Entity_Id) 13442 is 13443 function Within_Initial_Condition (Call : Node_Id) return Boolean; 13444 -- Determine whether call Call occurs within pragma Initial_Condition or 13445 -- pragma Check with check_kind set to Initial_Condition. 13446 13447 ------------------------------ 13448 -- Within_Initial_Condition -- 13449 ------------------------------ 13450 13451 function Within_Initial_Condition (Call : Node_Id) return Boolean is 13452 Args : List_Id; 13453 Nam : Name_Id; 13454 Par : Node_Id; 13455 13456 begin 13457 -- Traverse the parent chain looking for an enclosing pragma 13458 13459 Par := Call; 13460 while Present (Par) loop 13461 if Nkind (Par) = N_Pragma then 13462 Nam := Pragma_Name (Par); 13463 13464 -- Pragma Initial_Condition appears in its alternative from as 13465 -- Check (Initial_Condition, ...). 13466 13467 if Nam = Name_Check then 13468 Args := Pragma_Argument_Associations (Par); 13469 13470 -- Pragma Check should have at least two arguments 13471 13472 pragma Assert (Present (Args)); 13473 13474 return 13475 Chars (Expression (First (Args))) = Name_Initial_Condition; 13476 13477 -- Direct match 13478 13479 elsif Nam = Name_Initial_Condition then 13480 return True; 13481 13482 -- Since pragmas are never nested within other pragmas, stop 13483 -- the traversal. 13484 13485 else 13486 return False; 13487 end if; 13488 13489 -- Prevent the search from going too far 13490 13491 elsif Is_Body_Or_Package_Declaration (Par) then 13492 exit; 13493 end if; 13494 13495 Par := Parent (Par); 13496 13497 -- If assertions are not enabled, the check pragma is rewritten 13498 -- as an if_statement in sem_prag, to generate various warnings 13499 -- on boolean expressions. Retrieve the original pragma. 13500 13501 if Nkind (Original_Node (Par)) = N_Pragma then 13502 Par := Original_Node (Par); 13503 end if; 13504 end loop; 13505 13506 return False; 13507 end Within_Initial_Condition; 13508 13509 -- Local variables 13510 13511 Inst_Case : constant Boolean := Nkind (N) in N_Generic_Instantiation; 13512 13513 -- Start of processing for Check_Internal_Call 13514 13515 begin 13516 -- For P'Access, we want to warn if the -gnatw.f switch is set, and the 13517 -- node comes from source. 13518 13519 if Nkind (N) = N_Attribute_Reference 13520 and then ((not Warn_On_Elab_Access and then not Debug_Flag_Dot_O) 13521 or else not Comes_From_Source (N)) 13522 then 13523 return; 13524 13525 -- If not function or procedure call, instantiation, or 'Access, then 13526 -- ignore call (this happens in some error cases and rewriting cases). 13527 13528 elsif not Nkind_In (N, N_Attribute_Reference, 13529 N_Function_Call, 13530 N_Procedure_Call_Statement) 13531 and then not Inst_Case 13532 then 13533 return; 13534 13535 -- Nothing to do if this is a call or instantiation that has already 13536 -- been found to be a sure ABE. 13537 13538 elsif Nkind (N) /= N_Attribute_Reference 13539 and then Is_Known_Guaranteed_ABE (N) 13540 then 13541 return; 13542 13543 -- Nothing to do if errors already detected (avoid cascaded errors) 13544 13545 elsif Serious_Errors_Detected /= 0 then 13546 return; 13547 13548 -- Nothing to do if not in full analysis mode 13549 13550 elsif not Full_Analysis then 13551 return; 13552 13553 -- Nothing to do if analyzing in special spec-expression mode, since the 13554 -- call is not actually being made at this time. 13555 13556 elsif In_Spec_Expression then 13557 return; 13558 13559 -- Nothing to do for call to intrinsic subprogram 13560 13561 elsif Is_Intrinsic_Subprogram (E) then 13562 return; 13563 13564 -- Nothing to do if call is within a generic unit 13565 13566 elsif Inside_A_Generic then 13567 return; 13568 13569 -- Nothing to do when the call appears within pragma Initial_Condition. 13570 -- The pragma is part of the elaboration statements of a package body 13571 -- and may only call external subprograms or subprograms whose body is 13572 -- already available. 13573 13574 elsif Within_Initial_Condition (N) then 13575 return; 13576 end if; 13577 13578 -- Delay this call if we are still delaying calls 13579 13580 if Delaying_Elab_Checks then 13581 Delay_Check.Append 13582 ((N => N, 13583 E => E, 13584 Orig_Ent => Orig_Ent, 13585 Curscop => Current_Scope, 13586 Outer_Scope => Outer_Scope, 13587 From_Elab_Code => From_Elab_Code, 13588 In_Task_Activation => In_Task_Activation, 13589 From_SPARK_Code => SPARK_Mode = On)); 13590 return; 13591 13592 -- Otherwise, call phase 2 continuation right now 13593 13594 else 13595 Check_Internal_Call_Continue (N, E, Outer_Scope, Orig_Ent); 13596 end if; 13597 end Check_Internal_Call; 13598 13599 ---------------------------------- 13600 -- Check_Internal_Call_Continue -- 13601 ---------------------------------- 13602 13603 procedure Check_Internal_Call_Continue 13604 (N : Node_Id; 13605 E : Entity_Id; 13606 Outer_Scope : Entity_Id; 13607 Orig_Ent : Entity_Id) 13608 is 13609 function Find_Elab_Reference (N : Node_Id) return Traverse_Result; 13610 -- Function applied to each node as we traverse the body. Checks for 13611 -- call or entity reference that needs checking, and if so checks it. 13612 -- Always returns OK, so entire tree is traversed, except that as 13613 -- described below subprogram bodies are skipped for now. 13614 13615 procedure Traverse is new Atree.Traverse_Proc (Find_Elab_Reference); 13616 -- Traverse procedure using above Find_Elab_Reference function 13617 13618 ------------------------- 13619 -- Find_Elab_Reference -- 13620 ------------------------- 13621 13622 function Find_Elab_Reference (N : Node_Id) return Traverse_Result is 13623 Actual : Node_Id; 13624 13625 begin 13626 -- If user has specified that there are no entry calls in elaboration 13627 -- code, do not trace past an accept statement, because the rendez- 13628 -- vous will happen after elaboration. 13629 13630 if Nkind_In (Original_Node (N), N_Accept_Statement, 13631 N_Selective_Accept) 13632 and then Restriction_Active (No_Entry_Calls_In_Elaboration_Code) 13633 then 13634 return Abandon; 13635 13636 -- If we have a function call, check it 13637 13638 elsif Nkind (N) = N_Function_Call then 13639 Check_Elab_Call (N, Outer_Scope); 13640 return OK; 13641 13642 -- If we have a procedure call, check the call, and also check 13643 -- arguments that are assignments (OUT or IN OUT mode formals). 13644 13645 elsif Nkind (N) = N_Procedure_Call_Statement then 13646 Check_Elab_Call (N, Outer_Scope, In_Init_Proc => Is_Init_Proc (E)); 13647 13648 Actual := First_Actual (N); 13649 while Present (Actual) loop 13650 if Known_To_Be_Assigned (Actual) then 13651 Check_Elab_Assign (Actual); 13652 end if; 13653 13654 Next_Actual (Actual); 13655 end loop; 13656 13657 return OK; 13658 13659 -- If we have an access attribute for a subprogram, check it. 13660 -- Suppress this behavior under debug flag. 13661 13662 elsif not Debug_Flag_Dot_UU 13663 and then Nkind (N) = N_Attribute_Reference 13664 and then Nam_In (Attribute_Name (N), Name_Access, 13665 Name_Unrestricted_Access) 13666 and then Is_Entity_Name (Prefix (N)) 13667 and then Is_Subprogram (Entity (Prefix (N))) 13668 then 13669 Check_Elab_Call (N, Outer_Scope); 13670 return OK; 13671 13672 -- In SPARK mode, if we have an entity reference to a variable, then 13673 -- check it. For now we consider any reference. 13674 13675 elsif SPARK_Mode = On 13676 and then Nkind (N) in N_Has_Entity 13677 and then Present (Entity (N)) 13678 and then Ekind (Entity (N)) = E_Variable 13679 then 13680 Check_Elab_Call (N, Outer_Scope); 13681 return OK; 13682 13683 -- If we have a generic instantiation, check it 13684 13685 elsif Nkind (N) in N_Generic_Instantiation then 13686 Check_Elab_Instantiation (N, Outer_Scope); 13687 return OK; 13688 13689 -- Skip subprogram bodies that come from source (wait for call to 13690 -- analyze these). The reason for the come from source test is to 13691 -- avoid catching task bodies. 13692 13693 -- For task bodies, we should really avoid these too, waiting for the 13694 -- task activation, but that's too much trouble to catch for now, so 13695 -- we go in unconditionally. This is not so terrible, it means the 13696 -- error backtrace is not quite complete, and we are too eager to 13697 -- scan bodies of tasks that are unused, but this is hardly very 13698 -- significant. 13699 13700 elsif Nkind (N) = N_Subprogram_Body 13701 and then Comes_From_Source (N) 13702 then 13703 return Skip; 13704 13705 elsif Nkind (N) = N_Assignment_Statement 13706 and then Comes_From_Source (N) 13707 then 13708 Check_Elab_Assign (Name (N)); 13709 return OK; 13710 13711 else 13712 return OK; 13713 end if; 13714 end Find_Elab_Reference; 13715 13716 Inst_Case : constant Boolean := Is_Generic_Unit (E); 13717 Loc : constant Source_Ptr := Sloc (N); 13718 13719 Ebody : Entity_Id; 13720 Sbody : Node_Id; 13721 13722 -- Start of processing for Check_Internal_Call_Continue 13723 13724 begin 13725 -- Save outer level call if at outer level 13726 13727 if Elab_Call.Last = 0 then 13728 Outer_Level_Sloc := Loc; 13729 end if; 13730 13731 -- If the call is to a function that renames a literal, no check needed 13732 13733 if Ekind (E) = E_Enumeration_Literal then 13734 return; 13735 end if; 13736 13737 -- Register the subprogram as examined within this particular context. 13738 -- This ensures that calls to the same subprogram but in different 13739 -- contexts receive warnings and checks of their own since the calls 13740 -- may be reached through different flow paths. 13741 13742 Elab_Visited.Append ((Subp_Id => E, Context => Parent (N))); 13743 13744 Sbody := Unit_Declaration_Node (E); 13745 13746 if not Nkind_In (Sbody, N_Subprogram_Body, N_Package_Body) then 13747 Ebody := Corresponding_Body (Sbody); 13748 13749 if No (Ebody) then 13750 return; 13751 else 13752 Sbody := Unit_Declaration_Node (Ebody); 13753 end if; 13754 end if; 13755 13756 -- If the body appears after the outer level call or instantiation then 13757 -- we have an error case handled below. 13758 13759 if Earlier_In_Extended_Unit (Outer_Level_Sloc, Sloc (Sbody)) 13760 and then not In_Task_Activation 13761 then 13762 null; 13763 13764 -- If we have the instantiation case we are done, since we now know that 13765 -- the body of the generic appeared earlier. 13766 13767 elsif Inst_Case then 13768 return; 13769 13770 -- Otherwise we have a call, so we trace through the called body to see 13771 -- if it has any problems. 13772 13773 else 13774 pragma Assert (Nkind (Sbody) = N_Subprogram_Body); 13775 13776 Elab_Call.Append ((Cloc => Loc, Ent => E)); 13777 13778 if Debug_Flag_Underscore_LL then 13779 Write_Str ("Elab_Call.Last = "); 13780 Write_Int (Int (Elab_Call.Last)); 13781 Write_Str (" Ent = "); 13782 Write_Name (Chars (E)); 13783 Write_Str (" at "); 13784 Write_Location (Sloc (N)); 13785 Write_Eol; 13786 end if; 13787 13788 -- Now traverse declarations and statements of subprogram body. Note 13789 -- that we cannot simply Traverse (Sbody), since traverse does not 13790 -- normally visit subprogram bodies. 13791 13792 declare 13793 Decl : Node_Id; 13794 begin 13795 Decl := First (Declarations (Sbody)); 13796 while Present (Decl) loop 13797 Traverse (Decl); 13798 Next (Decl); 13799 end loop; 13800 end; 13801 13802 Traverse (Handled_Statement_Sequence (Sbody)); 13803 13804 Elab_Call.Decrement_Last; 13805 return; 13806 end if; 13807 13808 -- Here is the case of calling a subprogram where the body has not yet 13809 -- been encountered. A warning message is needed, except if this is the 13810 -- case of appearing within an aspect specification that results in 13811 -- a check call, we do not really have such a situation, so no warning 13812 -- is needed (e.g. the case of a precondition, where the call appears 13813 -- textually before the body, but in actual fact is moved to the 13814 -- appropriate subprogram body and so does not need a check). 13815 13816 declare 13817 P : Node_Id; 13818 O : Node_Id; 13819 13820 begin 13821 P := Parent (N); 13822 loop 13823 -- Keep looking at parents if we are still in the subexpression 13824 13825 if Nkind (P) in N_Subexpr then 13826 P := Parent (P); 13827 13828 -- Here P is the parent of the expression, check for special case 13829 13830 else 13831 O := Original_Node (P); 13832 13833 -- Definitely not the special case if orig node is not a pragma 13834 13835 exit when Nkind (O) /= N_Pragma; 13836 13837 -- Check we have an If statement or a null statement (happens 13838 -- when the If has been expanded to be True). 13839 13840 exit when not Nkind_In (P, N_If_Statement, N_Null_Statement); 13841 13842 -- Our special case will be indicated either by the pragma 13843 -- coming from an aspect ... 13844 13845 if Present (Corresponding_Aspect (O)) then 13846 return; 13847 13848 -- Or, in the case of an initial condition, specifically by a 13849 -- Check pragma specifying an Initial_Condition check. 13850 13851 elsif Pragma_Name (O) = Name_Check 13852 and then 13853 Chars 13854 (Expression (First (Pragma_Argument_Associations (O)))) = 13855 Name_Initial_Condition 13856 then 13857 return; 13858 13859 -- For anything else, we have an error 13860 13861 else 13862 exit; 13863 end if; 13864 end if; 13865 end loop; 13866 end; 13867 13868 -- Not that special case, warning and dynamic check is required 13869 13870 -- If we have nothing in the call stack, then this is at the outer 13871 -- level, and the ABE is bound to occur, unless it's a 'Access, or 13872 -- it's a renaming. 13873 13874 if Elab_Call.Last = 0 then 13875 Error_Msg_Warn := SPARK_Mode /= On; 13876 13877 declare 13878 Insert_Check : Boolean := True; 13879 -- This flag is set to True if an elaboration check should be 13880 -- inserted. 13881 13882 begin 13883 if In_Task_Activation then 13884 Insert_Check := False; 13885 13886 elsif Inst_Case then 13887 Error_Msg_NE 13888 ("cannot instantiate& before body seen<<", N, Orig_Ent); 13889 13890 elsif Nkind (N) = N_Attribute_Reference then 13891 Error_Msg_NE 13892 ("Access attribute of & before body seen<<", N, Orig_Ent); 13893 Error_Msg_N ("\possible Program_Error on later references<", N); 13894 Insert_Check := False; 13895 13896 elsif Nkind (Unit_Declaration_Node (Orig_Ent)) /= 13897 N_Subprogram_Renaming_Declaration 13898 then 13899 Error_Msg_NE 13900 ("cannot call& before body seen<<", N, Orig_Ent); 13901 13902 elsif not Is_Generic_Actual_Subprogram (Orig_Ent) then 13903 Insert_Check := False; 13904 end if; 13905 13906 if Insert_Check then 13907 Error_Msg_N ("\Program_Error [<<", N); 13908 Insert_Elab_Check (N); 13909 end if; 13910 end; 13911 13912 -- Call is not at outer level 13913 13914 else 13915 -- Do not generate elaboration checks in GNATprove mode because the 13916 -- elaboration counter and the check are both forms of expansion. 13917 13918 if GNATprove_Mode then 13919 null; 13920 13921 -- Generate an elaboration check 13922 13923 elsif not Elaboration_Checks_Suppressed (E) then 13924 Set_Elaboration_Entity_Required (E); 13925 13926 -- Create a declaration of the elaboration entity, and insert it 13927 -- prior to the subprogram or the generic unit, within the same 13928 -- scope. Since the subprogram may be overloaded, create a unique 13929 -- entity. 13930 13931 if No (Elaboration_Entity (E)) then 13932 declare 13933 Loce : constant Source_Ptr := Sloc (E); 13934 Ent : constant Entity_Id := 13935 Make_Defining_Identifier (Loc, 13936 New_External_Name (Chars (E), 'E', -1)); 13937 13938 begin 13939 Set_Elaboration_Entity (E, Ent); 13940 Push_Scope (Scope (E)); 13941 13942 Insert_Action (Declaration_Node (E), 13943 Make_Object_Declaration (Loce, 13944 Defining_Identifier => Ent, 13945 Object_Definition => 13946 New_Occurrence_Of (Standard_Short_Integer, Loce), 13947 Expression => 13948 Make_Integer_Literal (Loc, Uint_0))); 13949 13950 -- Set elaboration flag at the point of the body 13951 13952 Set_Elaboration_Flag (Sbody, E); 13953 13954 -- Kill current value indication. This is necessary because 13955 -- the tests of this flag are inserted out of sequence and 13956 -- must not pick up bogus indications of the wrong constant 13957 -- value. Also, this is never a true constant, since one way 13958 -- or another, it gets reset. 13959 13960 Set_Current_Value (Ent, Empty); 13961 Set_Last_Assignment (Ent, Empty); 13962 Set_Is_True_Constant (Ent, False); 13963 Pop_Scope; 13964 end; 13965 end if; 13966 13967 -- Generate: 13968 -- if Enn = 0 then 13969 -- raise Program_Error with "access before elaboration"; 13970 -- end if; 13971 13972 Insert_Elab_Check (N, 13973 Make_Attribute_Reference (Loc, 13974 Attribute_Name => Name_Elaborated, 13975 Prefix => New_Occurrence_Of (E, Loc))); 13976 end if; 13977 13978 -- Generate the warning 13979 13980 if not Suppress_Elaboration_Warnings (E) 13981 and then not Elaboration_Checks_Suppressed (E) 13982 13983 -- Suppress this warning if we have a function call that occurred 13984 -- within an assertion expression, since we can get false warnings 13985 -- in this case, due to the out of order handling in this case. 13986 13987 and then 13988 (Nkind (Original_Node (N)) /= N_Function_Call 13989 or else not In_Assertion_Expression_Pragma (Original_Node (N))) 13990 then 13991 Error_Msg_Warn := SPARK_Mode /= On; 13992 13993 if Inst_Case then 13994 Error_Msg_NE 13995 ("instantiation of& may occur before body is seen<l<", 13996 N, Orig_Ent); 13997 else 13998 -- A rather specific check. For Finalize/Adjust/Initialize, if 13999 -- the type has Warnings_Off set, suppress the warning. 14000 14001 if Nam_In (Chars (E), Name_Adjust, 14002 Name_Finalize, 14003 Name_Initialize) 14004 and then Present (First_Formal (E)) 14005 then 14006 declare 14007 T : constant Entity_Id := Etype (First_Formal (E)); 14008 begin 14009 if Is_Controlled (T) then 14010 if Warnings_Off (T) 14011 or else (Ekind (T) = E_Private_Type 14012 and then Warnings_Off (Full_View (T))) 14013 then 14014 goto Output; 14015 end if; 14016 end if; 14017 end; 14018 end if; 14019 14020 -- Go ahead and give warning if not this special case 14021 14022 Error_Msg_NE 14023 ("call to& may occur before body is seen<l<", N, Orig_Ent); 14024 end if; 14025 14026 Error_Msg_N ("\Program_Error ]<l<", N); 14027 14028 -- There is no need to query the elaboration warning message flags 14029 -- because the main message is an error, not a warning, therefore 14030 -- all the clarification messages produces by Output_Calls must be 14031 -- emitted unconditionally. 14032 14033 <<Output>> 14034 14035 Output_Calls (N, Check_Elab_Flag => False); 14036 end if; 14037 end if; 14038 end Check_Internal_Call_Continue; 14039 14040 --------------------------- 14041 -- Check_Task_Activation -- 14042 --------------------------- 14043 14044 procedure Check_Task_Activation (N : Node_Id) is 14045 Loc : constant Source_Ptr := Sloc (N); 14046 Inter_Procs : constant Elist_Id := New_Elmt_List; 14047 Intra_Procs : constant Elist_Id := New_Elmt_List; 14048 Ent : Entity_Id; 14049 P : Entity_Id; 14050 Task_Scope : Entity_Id; 14051 Cunit_SC : Boolean := False; 14052 Decl : Node_Id; 14053 Elmt : Elmt_Id; 14054 Enclosing : Entity_Id; 14055 14056 procedure Add_Task_Proc (Typ : Entity_Id); 14057 -- Add to Task_Procs the task body procedure(s) of task types in Typ. 14058 -- For record types, this procedure recurses over component types. 14059 14060 procedure Collect_Tasks (Decls : List_Id); 14061 -- Collect the types of the tasks that are to be activated in the given 14062 -- list of declarations, in order to perform elaboration checks on the 14063 -- corresponding task procedures that are called implicitly here. 14064 14065 function Outer_Unit (E : Entity_Id) return Entity_Id; 14066 -- find enclosing compilation unit of Entity, ignoring subunits, or 14067 -- else enclosing subprogram. If E is not a package, there is no need 14068 -- for inter-unit elaboration checks. 14069 14070 ------------------- 14071 -- Add_Task_Proc -- 14072 ------------------- 14073 14074 procedure Add_Task_Proc (Typ : Entity_Id) is 14075 Comp : Entity_Id; 14076 Proc : Entity_Id := Empty; 14077 14078 begin 14079 if Is_Task_Type (Typ) then 14080 Proc := Get_Task_Body_Procedure (Typ); 14081 14082 elsif Is_Array_Type (Typ) 14083 and then Has_Task (Base_Type (Typ)) 14084 then 14085 Add_Task_Proc (Component_Type (Typ)); 14086 14087 elsif Is_Record_Type (Typ) 14088 and then Has_Task (Base_Type (Typ)) 14089 then 14090 Comp := First_Component (Typ); 14091 while Present (Comp) loop 14092 Add_Task_Proc (Etype (Comp)); 14093 Comp := Next_Component (Comp); 14094 end loop; 14095 end if; 14096 14097 -- If the task type is another unit, we will perform the usual 14098 -- elaboration check on its enclosing unit. If the type is in the 14099 -- same unit, we can trace the task body as for an internal call, 14100 -- but we only need to examine other external calls, because at 14101 -- the point the task is activated, internal subprogram bodies 14102 -- will have been elaborated already. We keep separate lists for 14103 -- each kind of task. 14104 14105 -- Skip this test if errors have occurred, since in this case 14106 -- we can get false indications. 14107 14108 if Serious_Errors_Detected /= 0 then 14109 return; 14110 end if; 14111 14112 if Present (Proc) then 14113 if Outer_Unit (Scope (Proc)) = Enclosing then 14114 14115 if No (Corresponding_Body (Unit_Declaration_Node (Proc))) 14116 and then 14117 (not Is_Generic_Instance (Scope (Proc)) 14118 or else Scope (Proc) = Scope (Defining_Identifier (Decl))) 14119 then 14120 Error_Msg_Warn := SPARK_Mode /= On; 14121 Error_Msg_N 14122 ("task will be activated before elaboration of its body<<", 14123 Decl); 14124 Error_Msg_N ("\Program_Error [<<", Decl); 14125 14126 elsif Present 14127 (Corresponding_Body (Unit_Declaration_Node (Proc))) 14128 then 14129 Append_Elmt (Proc, Intra_Procs); 14130 end if; 14131 14132 else 14133 -- No need for multiple entries of the same type 14134 14135 Elmt := First_Elmt (Inter_Procs); 14136 while Present (Elmt) loop 14137 if Node (Elmt) = Proc then 14138 return; 14139 end if; 14140 14141 Next_Elmt (Elmt); 14142 end loop; 14143 14144 Append_Elmt (Proc, Inter_Procs); 14145 end if; 14146 end if; 14147 end Add_Task_Proc; 14148 14149 ------------------- 14150 -- Collect_Tasks -- 14151 ------------------- 14152 14153 procedure Collect_Tasks (Decls : List_Id) is 14154 begin 14155 if Present (Decls) then 14156 Decl := First (Decls); 14157 while Present (Decl) loop 14158 if Nkind (Decl) = N_Object_Declaration 14159 and then Has_Task (Etype (Defining_Identifier (Decl))) 14160 then 14161 Add_Task_Proc (Etype (Defining_Identifier (Decl))); 14162 end if; 14163 14164 Next (Decl); 14165 end loop; 14166 end if; 14167 end Collect_Tasks; 14168 14169 ---------------- 14170 -- Outer_Unit -- 14171 ---------------- 14172 14173 function Outer_Unit (E : Entity_Id) return Entity_Id is 14174 Outer : Entity_Id; 14175 14176 begin 14177 Outer := E; 14178 while Present (Outer) loop 14179 if Elaboration_Checks_Suppressed (Outer) then 14180 Cunit_SC := True; 14181 end if; 14182 14183 exit when Is_Child_Unit (Outer) 14184 or else Scope (Outer) = Standard_Standard 14185 or else Ekind (Outer) /= E_Package; 14186 Outer := Scope (Outer); 14187 end loop; 14188 14189 return Outer; 14190 end Outer_Unit; 14191 14192 -- Start of processing for Check_Task_Activation 14193 14194 begin 14195 pragma Assert (Legacy_Elaboration_Checks); 14196 14197 Enclosing := Outer_Unit (Current_Scope); 14198 14199 -- Find all tasks declared in the current unit 14200 14201 if Nkind (N) = N_Package_Body then 14202 P := Unit_Declaration_Node (Corresponding_Spec (N)); 14203 14204 Collect_Tasks (Declarations (N)); 14205 Collect_Tasks (Visible_Declarations (Specification (P))); 14206 Collect_Tasks (Private_Declarations (Specification (P))); 14207 14208 elsif Nkind (N) = N_Package_Declaration then 14209 Collect_Tasks (Visible_Declarations (Specification (N))); 14210 Collect_Tasks (Private_Declarations (Specification (N))); 14211 14212 else 14213 Collect_Tasks (Declarations (N)); 14214 end if; 14215 14216 -- We only perform detailed checks in all tasks that are library level 14217 -- entities. If the master is a subprogram or task, activation will 14218 -- depend on the activation of the master itself. 14219 14220 -- Should dynamic checks be added in the more general case??? 14221 14222 if Ekind (Enclosing) /= E_Package then 14223 return; 14224 end if; 14225 14226 -- For task types defined in other units, we want the unit containing 14227 -- the task body to be elaborated before the current one. 14228 14229 Elmt := First_Elmt (Inter_Procs); 14230 while Present (Elmt) loop 14231 Ent := Node (Elmt); 14232 Task_Scope := Outer_Unit (Scope (Ent)); 14233 14234 if not Is_Compilation_Unit (Task_Scope) then 14235 null; 14236 14237 elsif Suppress_Elaboration_Warnings (Task_Scope) 14238 or else Elaboration_Checks_Suppressed (Task_Scope) 14239 then 14240 null; 14241 14242 elsif Dynamic_Elaboration_Checks then 14243 if not Elaboration_Checks_Suppressed (Ent) 14244 and then not Cunit_SC 14245 and then not Restriction_Active 14246 (No_Entry_Calls_In_Elaboration_Code) 14247 then 14248 -- Runtime elaboration check required. Generate check of the 14249 -- elaboration counter for the unit containing the entity. 14250 14251 Insert_Elab_Check (N, 14252 Make_Attribute_Reference (Loc, 14253 Prefix => 14254 New_Occurrence_Of (Spec_Entity (Task_Scope), Loc), 14255 Attribute_Name => Name_Elaborated)); 14256 end if; 14257 14258 else 14259 -- Force the binder to elaborate other unit first 14260 14261 if Elab_Info_Messages 14262 and then not Suppress_Elaboration_Warnings (Ent) 14263 and then not Elaboration_Checks_Suppressed (Ent) 14264 and then not Suppress_Elaboration_Warnings (Task_Scope) 14265 and then not Elaboration_Checks_Suppressed (Task_Scope) 14266 then 14267 Error_Msg_Node_2 := Task_Scope; 14268 Error_Msg_NE 14269 ("info: activation of an instance of task type & requires " 14270 & "pragma Elaborate_All on &?$?", N, Ent); 14271 end if; 14272 14273 Activate_Elaborate_All_Desirable (N, Task_Scope); 14274 Set_Suppress_Elaboration_Warnings (Task_Scope); 14275 end if; 14276 14277 Next_Elmt (Elmt); 14278 end loop; 14279 14280 -- For tasks declared in the current unit, trace other calls within the 14281 -- task procedure bodies, which are available. 14282 14283 if not Debug_Flag_Dot_Y then 14284 In_Task_Activation := True; 14285 14286 Elmt := First_Elmt (Intra_Procs); 14287 while Present (Elmt) loop 14288 Ent := Node (Elmt); 14289 Check_Internal_Call_Continue (N, Ent, Enclosing, Ent); 14290 Next_Elmt (Elmt); 14291 end loop; 14292 14293 In_Task_Activation := False; 14294 end if; 14295 end Check_Task_Activation; 14296 14297 ------------------------ 14298 -- Get_Referenced_Ent -- 14299 ------------------------ 14300 14301 function Get_Referenced_Ent (N : Node_Id) return Entity_Id is 14302 Nam : Node_Id; 14303 14304 begin 14305 if Nkind (N) in N_Has_Entity 14306 and then Present (Entity (N)) 14307 and then Ekind (Entity (N)) = E_Variable 14308 then 14309 return Entity (N); 14310 end if; 14311 14312 if Nkind (N) = N_Attribute_Reference then 14313 Nam := Prefix (N); 14314 else 14315 Nam := Name (N); 14316 end if; 14317 14318 if No (Nam) then 14319 return Empty; 14320 elsif Nkind (Nam) = N_Selected_Component then 14321 return Entity (Selector_Name (Nam)); 14322 elsif not Is_Entity_Name (Nam) then 14323 return Empty; 14324 else 14325 return Entity (Nam); 14326 end if; 14327 end Get_Referenced_Ent; 14328 14329 ---------------------- 14330 -- Has_Generic_Body -- 14331 ---------------------- 14332 14333 function Has_Generic_Body (N : Node_Id) return Boolean is 14334 Ent : constant Entity_Id := Get_Generic_Entity (N); 14335 Decl : constant Node_Id := Unit_Declaration_Node (Ent); 14336 Scop : Entity_Id; 14337 14338 function Find_Body_In (E : Entity_Id; N : Node_Id) return Node_Id; 14339 -- Determine if the list of nodes headed by N and linked by Next 14340 -- contains a package body for the package spec entity E, and if so 14341 -- return the package body. If not, then returns Empty. 14342 14343 function Load_Package_Body (Nam : Unit_Name_Type) return Node_Id; 14344 -- This procedure is called load the unit whose name is given by Nam. 14345 -- This unit is being loaded to see whether it contains an optional 14346 -- generic body. The returned value is the loaded unit, which is always 14347 -- a package body (only package bodies can contain other entities in the 14348 -- sense in which Has_Generic_Body is interested). We only attempt to 14349 -- load bodies if we are generating code. If we are in semantics check 14350 -- only mode, then it would be wrong to load bodies that are not 14351 -- required from a semantic point of view, so in this case we return 14352 -- Empty. The result is that the caller may incorrectly decide that a 14353 -- generic spec does not have a body when in fact it does, but the only 14354 -- harm in this is that some warnings on elaboration problems may be 14355 -- lost in semantic checks only mode, which is not big loss. We also 14356 -- return Empty if we go for a body and it is not there. 14357 14358 function Locate_Corresponding_Body (PE : Entity_Id) return Node_Id; 14359 -- PE is the entity for a package spec. This function locates the 14360 -- corresponding package body, returning Empty if none is found. The 14361 -- package body returned is fully parsed but may not yet be analyzed, 14362 -- so only syntactic fields should be referenced. 14363 14364 ------------------ 14365 -- Find_Body_In -- 14366 ------------------ 14367 14368 function Find_Body_In (E : Entity_Id; N : Node_Id) return Node_Id is 14369 Nod : Node_Id; 14370 14371 begin 14372 Nod := N; 14373 while Present (Nod) loop 14374 14375 -- If we found the package body we are looking for, return it 14376 14377 if Nkind (Nod) = N_Package_Body 14378 and then Chars (Defining_Unit_Name (Nod)) = Chars (E) 14379 then 14380 return Nod; 14381 14382 -- If we found the stub for the body, go after the subunit, 14383 -- loading it if necessary. 14384 14385 elsif Nkind (Nod) = N_Package_Body_Stub 14386 and then Chars (Defining_Identifier (Nod)) = Chars (E) 14387 then 14388 if Present (Library_Unit (Nod)) then 14389 return Unit (Library_Unit (Nod)); 14390 14391 else 14392 return Load_Package_Body (Get_Unit_Name (Nod)); 14393 end if; 14394 14395 -- If neither package body nor stub, keep looking on chain 14396 14397 else 14398 Next (Nod); 14399 end if; 14400 end loop; 14401 14402 return Empty; 14403 end Find_Body_In; 14404 14405 ----------------------- 14406 -- Load_Package_Body -- 14407 ----------------------- 14408 14409 function Load_Package_Body (Nam : Unit_Name_Type) return Node_Id is 14410 U : Unit_Number_Type; 14411 14412 begin 14413 if Operating_Mode /= Generate_Code then 14414 return Empty; 14415 else 14416 U := 14417 Load_Unit 14418 (Load_Name => Nam, 14419 Required => False, 14420 Subunit => False, 14421 Error_Node => N); 14422 14423 if U = No_Unit then 14424 return Empty; 14425 else 14426 return Unit (Cunit (U)); 14427 end if; 14428 end if; 14429 end Load_Package_Body; 14430 14431 ------------------------------- 14432 -- Locate_Corresponding_Body -- 14433 ------------------------------- 14434 14435 function Locate_Corresponding_Body (PE : Entity_Id) return Node_Id is 14436 Spec : constant Node_Id := Declaration_Node (PE); 14437 Decl : constant Node_Id := Parent (Spec); 14438 Scop : constant Entity_Id := Scope (PE); 14439 PBody : Node_Id; 14440 14441 begin 14442 if Is_Library_Level_Entity (PE) then 14443 14444 -- If package is a library unit that requires a body, we have no 14445 -- choice but to go after that body because it might contain an 14446 -- optional body for the original generic package. 14447 14448 if Unit_Requires_Body (PE) then 14449 14450 -- Load the body. Note that we are a little careful here to use 14451 -- Spec to get the unit number, rather than PE or Decl, since 14452 -- in the case where the package is itself a library level 14453 -- instantiation, Spec will properly reference the generic 14454 -- template, which is what we really want. 14455 14456 return 14457 Load_Package_Body 14458 (Get_Body_Name (Unit_Name (Get_Source_Unit (Spec)))); 14459 14460 -- But if the package is a library unit that does NOT require 14461 -- a body, then no body is permitted, so we are sure that there 14462 -- is no body for the original generic package. 14463 14464 else 14465 return Empty; 14466 end if; 14467 14468 -- Otherwise look and see if we are embedded in a further package 14469 14470 elsif Is_Package_Or_Generic_Package (Scop) then 14471 14472 -- If so, get the body of the enclosing package, and look in 14473 -- its package body for the package body we are looking for. 14474 14475 PBody := Locate_Corresponding_Body (Scop); 14476 14477 if No (PBody) then 14478 return Empty; 14479 else 14480 return Find_Body_In (PE, First (Declarations (PBody))); 14481 end if; 14482 14483 -- If we are not embedded in a further package, then the body 14484 -- must be in the same declarative part as we are. 14485 14486 else 14487 return Find_Body_In (PE, Next (Decl)); 14488 end if; 14489 end Locate_Corresponding_Body; 14490 14491 -- Start of processing for Has_Generic_Body 14492 14493 begin 14494 if Present (Corresponding_Body (Decl)) then 14495 return True; 14496 14497 elsif Unit_Requires_Body (Ent) then 14498 return True; 14499 14500 -- Compilation units cannot have optional bodies 14501 14502 elsif Is_Compilation_Unit (Ent) then 14503 return False; 14504 14505 -- Otherwise look at what scope we are in 14506 14507 else 14508 Scop := Scope (Ent); 14509 14510 -- Case of entity is in other than a package spec, in this case 14511 -- the body, if present, must be in the same declarative part. 14512 14513 if not Is_Package_Or_Generic_Package (Scop) then 14514 declare 14515 P : Node_Id; 14516 14517 begin 14518 -- Declaration node may get us a spec, so if so, go to 14519 -- the parent declaration. 14520 14521 P := Declaration_Node (Ent); 14522 while not Is_List_Member (P) loop 14523 P := Parent (P); 14524 end loop; 14525 14526 return Present (Find_Body_In (Ent, Next (P))); 14527 end; 14528 14529 -- If the entity is in a package spec, then we have to locate 14530 -- the corresponding package body, and look there. 14531 14532 else 14533 declare 14534 PBody : constant Node_Id := Locate_Corresponding_Body (Scop); 14535 14536 begin 14537 if No (PBody) then 14538 return False; 14539 else 14540 return 14541 Present 14542 (Find_Body_In (Ent, (First (Declarations (PBody))))); 14543 end if; 14544 end; 14545 end if; 14546 end if; 14547 end Has_Generic_Body; 14548 14549 ----------------------- 14550 -- Insert_Elab_Check -- 14551 ----------------------- 14552 14553 procedure Insert_Elab_Check (N : Node_Id; C : Node_Id := Empty) is 14554 Nod : Node_Id; 14555 Loc : constant Source_Ptr := Sloc (N); 14556 14557 Chk : Node_Id; 14558 -- The check (N_Raise_Program_Error) node to be inserted 14559 14560 begin 14561 -- If expansion is disabled, do not generate any checks. Also 14562 -- skip checks if any subunits are missing because in either 14563 -- case we lack the full information that we need, and no object 14564 -- file will be created in any case. 14565 14566 if not Expander_Active or else Subunits_Missing then 14567 return; 14568 end if; 14569 14570 -- If we have a generic instantiation, where Instance_Spec is set, 14571 -- then this field points to a generic instance spec that has 14572 -- been inserted before the instantiation node itself, so that 14573 -- is where we want to insert a check. 14574 14575 if Nkind (N) in N_Generic_Instantiation 14576 and then Present (Instance_Spec (N)) 14577 then 14578 Nod := Instance_Spec (N); 14579 else 14580 Nod := N; 14581 end if; 14582 14583 -- Build check node, possibly with condition 14584 14585 Chk := 14586 Make_Raise_Program_Error (Loc, Reason => PE_Access_Before_Elaboration); 14587 14588 if Present (C) then 14589 Set_Condition (Chk, Make_Op_Not (Loc, Right_Opnd => C)); 14590 end if; 14591 14592 -- If we are inserting at the top level, insert in Aux_Decls 14593 14594 if Nkind (Parent (Nod)) = N_Compilation_Unit then 14595 declare 14596 ADN : constant Node_Id := Aux_Decls_Node (Parent (Nod)); 14597 14598 begin 14599 if No (Declarations (ADN)) then 14600 Set_Declarations (ADN, New_List (Chk)); 14601 else 14602 Append_To (Declarations (ADN), Chk); 14603 end if; 14604 14605 Analyze (Chk); 14606 end; 14607 14608 -- Otherwise just insert as an action on the node in question 14609 14610 else 14611 Insert_Action (Nod, Chk); 14612 end if; 14613 end Insert_Elab_Check; 14614 14615 ------------------------------- 14616 -- Is_Call_Of_Generic_Formal -- 14617 ------------------------------- 14618 14619 function Is_Call_Of_Generic_Formal (N : Node_Id) return Boolean is 14620 begin 14621 return Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement) 14622 14623 -- Always return False if debug flag -gnatd.G is set 14624 14625 and then not Debug_Flag_Dot_GG 14626 14627 -- For now, we detect this by looking for the strange identifier 14628 -- node, whose Chars reflect the name of the generic formal, but 14629 -- the Chars of the Entity references the generic actual. 14630 14631 and then Nkind (Name (N)) = N_Identifier 14632 and then Chars (Name (N)) /= Chars (Entity (Name (N))); 14633 end Is_Call_Of_Generic_Formal; 14634 14635 ------------------------------- 14636 -- Is_Finalization_Procedure -- 14637 ------------------------------- 14638 14639 function Is_Finalization_Procedure (Id : Entity_Id) return Boolean is 14640 begin 14641 -- Check whether Id is a procedure with at least one parameter 14642 14643 if Ekind (Id) = E_Procedure and then Present (First_Formal (Id)) then 14644 declare 14645 Typ : constant Entity_Id := Etype (First_Formal (Id)); 14646 Deep_Fin : Entity_Id := Empty; 14647 Fin : Entity_Id := Empty; 14648 14649 begin 14650 -- If the type of the first formal does not require finalization 14651 -- actions, then this is definitely not [Deep_]Finalize. 14652 14653 if not Needs_Finalization (Typ) then 14654 return False; 14655 end if; 14656 14657 -- At this point we have the following scenario: 14658 14659 -- procedure Name (Param1 : [in] [out] Ctrl[; Param2 : ...]); 14660 14661 -- Recover the two possible versions of [Deep_]Finalize using the 14662 -- type of the first parameter and compare with the input. 14663 14664 Deep_Fin := TSS (Typ, TSS_Deep_Finalize); 14665 14666 if Is_Controlled (Typ) then 14667 Fin := Find_Prim_Op (Typ, Name_Finalize); 14668 end if; 14669 14670 return (Present (Deep_Fin) and then Id = Deep_Fin) 14671 or else (Present (Fin) and then Id = Fin); 14672 end; 14673 end if; 14674 14675 return False; 14676 end Is_Finalization_Procedure; 14677 14678 ------------------ 14679 -- Output_Calls -- 14680 ------------------ 14681 14682 procedure Output_Calls 14683 (N : Node_Id; 14684 Check_Elab_Flag : Boolean) 14685 is 14686 function Emit (Flag : Boolean) return Boolean; 14687 -- Determine whether to emit an error message based on the combination 14688 -- of flags Check_Elab_Flag and Flag. 14689 14690 function Is_Printable_Error_Name return Boolean; 14691 -- An internal function, used to determine if a name, stored in the 14692 -- Name_Buffer, is either a non-internal name, or is an internal name 14693 -- that is printable by the error message circuits (i.e. it has a single 14694 -- upper case letter at the end). 14695 14696 ---------- 14697 -- Emit -- 14698 ---------- 14699 14700 function Emit (Flag : Boolean) return Boolean is 14701 begin 14702 if Check_Elab_Flag then 14703 return Flag; 14704 else 14705 return True; 14706 end if; 14707 end Emit; 14708 14709 ----------------------------- 14710 -- Is_Printable_Error_Name -- 14711 ----------------------------- 14712 14713 function Is_Printable_Error_Name return Boolean is 14714 begin 14715 if not Is_Internal_Name then 14716 return True; 14717 14718 elsif Name_Len = 1 then 14719 return False; 14720 14721 else 14722 Name_Len := Name_Len - 1; 14723 return not Is_Internal_Name; 14724 end if; 14725 end Is_Printable_Error_Name; 14726 14727 -- Local variables 14728 14729 Ent : Entity_Id; 14730 14731 -- Start of processing for Output_Calls 14732 14733 begin 14734 for J in reverse 1 .. Elab_Call.Last loop 14735 Error_Msg_Sloc := Elab_Call.Table (J).Cloc; 14736 14737 Ent := Elab_Call.Table (J).Ent; 14738 Get_Name_String (Chars (Ent)); 14739 14740 -- Dynamic elaboration model, warnings controlled by -gnatwl 14741 14742 if Dynamic_Elaboration_Checks then 14743 if Emit (Elab_Warnings) then 14744 if Is_Generic_Unit (Ent) then 14745 Error_Msg_NE ("\\?l?& instantiated #", N, Ent); 14746 elsif Is_Init_Proc (Ent) then 14747 Error_Msg_N ("\\?l?initialization procedure called #", N); 14748 elsif Is_Printable_Error_Name then 14749 Error_Msg_NE ("\\?l?& called #", N, Ent); 14750 else 14751 Error_Msg_N ("\\?l?called #", N); 14752 end if; 14753 end if; 14754 14755 -- Static elaboration model, info messages controlled by -gnatel 14756 14757 else 14758 if Emit (Elab_Info_Messages) then 14759 if Is_Generic_Unit (Ent) then 14760 Error_Msg_NE ("\\?$?& instantiated #", N, Ent); 14761 elsif Is_Init_Proc (Ent) then 14762 Error_Msg_N ("\\?$?initialization procedure called #", N); 14763 elsif Is_Printable_Error_Name then 14764 Error_Msg_NE ("\\?$?& called #", N, Ent); 14765 else 14766 Error_Msg_N ("\\?$?called #", N); 14767 end if; 14768 end if; 14769 end if; 14770 end loop; 14771 end Output_Calls; 14772 14773 ---------------------------- 14774 -- Same_Elaboration_Scope -- 14775 ---------------------------- 14776 14777 function Same_Elaboration_Scope (Scop1, Scop2 : Entity_Id) return Boolean is 14778 S1 : Entity_Id; 14779 S2 : Entity_Id; 14780 14781 begin 14782 -- Find elaboration scope for Scop1 14783 -- This is either a subprogram or a compilation unit. 14784 14785 S1 := Scop1; 14786 while S1 /= Standard_Standard 14787 and then not Is_Compilation_Unit (S1) 14788 and then Ekind_In (S1, E_Package, E_Protected_Type, E_Block) 14789 loop 14790 S1 := Scope (S1); 14791 end loop; 14792 14793 -- Find elaboration scope for Scop2 14794 14795 S2 := Scop2; 14796 while S2 /= Standard_Standard 14797 and then not Is_Compilation_Unit (S2) 14798 and then Ekind_In (S2, E_Package, E_Protected_Type, E_Block) 14799 loop 14800 S2 := Scope (S2); 14801 end loop; 14802 14803 return S1 = S2; 14804 end Same_Elaboration_Scope; 14805 14806 ----------------- 14807 -- Set_C_Scope -- 14808 ----------------- 14809 14810 procedure Set_C_Scope is 14811 begin 14812 while not Is_Compilation_Unit (C_Scope) loop 14813 C_Scope := Scope (C_Scope); 14814 end loop; 14815 end Set_C_Scope; 14816 14817 -------------------------------- 14818 -- Set_Elaboration_Constraint -- 14819 -------------------------------- 14820 14821 procedure Set_Elaboration_Constraint 14822 (Call : Node_Id; 14823 Subp : Entity_Id; 14824 Scop : Entity_Id) 14825 is 14826 Elab_Unit : Entity_Id; 14827 14828 -- Check whether this is a call to an Initialize subprogram for a 14829 -- controlled type. Note that Call can also be a 'Access attribute 14830 -- reference, which now generates an elaboration check. 14831 14832 Init_Call : constant Boolean := 14833 Nkind (Call) = N_Procedure_Call_Statement 14834 and then Chars (Subp) = Name_Initialize 14835 and then Comes_From_Source (Subp) 14836 and then Present (Parameter_Associations (Call)) 14837 and then Is_Controlled (Etype (First_Actual (Call))); 14838 14839 begin 14840 -- If the unit is mentioned in a with_clause of the current unit, it is 14841 -- visible, and we can set the elaboration flag. 14842 14843 if Is_Immediately_Visible (Scop) 14844 or else (Is_Child_Unit (Scop) and then Is_Visible_Lib_Unit (Scop)) 14845 then 14846 Activate_Elaborate_All_Desirable (Call, Scop); 14847 Set_Suppress_Elaboration_Warnings (Scop); 14848 return; 14849 end if; 14850 14851 -- If this is not an initialization call or a call using object notation 14852 -- we know that the unit of the called entity is in the context, and we 14853 -- can set the flag as well. The unit need not be visible if the call 14854 -- occurs within an instantiation. 14855 14856 if Is_Init_Proc (Subp) 14857 or else Init_Call 14858 or else Nkind (Original_Node (Call)) = N_Selected_Component 14859 then 14860 null; -- detailed processing follows. 14861 14862 else 14863 Activate_Elaborate_All_Desirable (Call, Scop); 14864 Set_Suppress_Elaboration_Warnings (Scop); 14865 return; 14866 end if; 14867 14868 -- If the unit is not in the context, there must be an intermediate unit 14869 -- that is, on which we need to place to elaboration flag. This happens 14870 -- with init proc calls. 14871 14872 if Is_Init_Proc (Subp) or else Init_Call then 14873 14874 -- The initialization call is on an object whose type is not declared 14875 -- in the same scope as the subprogram. The type of the object must 14876 -- be a subtype of the type of operation. This object is the first 14877 -- actual in the call. 14878 14879 declare 14880 Typ : constant Entity_Id := 14881 Etype (First (Parameter_Associations (Call))); 14882 begin 14883 Elab_Unit := Scope (Typ); 14884 while (Present (Elab_Unit)) 14885 and then not Is_Compilation_Unit (Elab_Unit) 14886 loop 14887 Elab_Unit := Scope (Elab_Unit); 14888 end loop; 14889 end; 14890 14891 -- If original node uses selected component notation, the prefix is 14892 -- visible and determines the scope that must be elaborated. After 14893 -- rewriting, the prefix is the first actual in the call. 14894 14895 elsif Nkind (Original_Node (Call)) = N_Selected_Component then 14896 Elab_Unit := Scope (Etype (First (Parameter_Associations (Call)))); 14897 14898 -- Not one of special cases above 14899 14900 else 14901 -- Using previously computed scope. If the elaboration check is 14902 -- done after analysis, the scope is not visible any longer, but 14903 -- must still be in the context. 14904 14905 Elab_Unit := Scop; 14906 end if; 14907 14908 Activate_Elaborate_All_Desirable (Call, Elab_Unit); 14909 Set_Suppress_Elaboration_Warnings (Elab_Unit); 14910 end Set_Elaboration_Constraint; 14911 14912 ----------------- 14913 -- Spec_Entity -- 14914 ----------------- 14915 14916 function Spec_Entity (E : Entity_Id) return Entity_Id is 14917 Decl : Node_Id; 14918 14919 begin 14920 -- Check for case of body entity 14921 -- Why is the check for E_Void needed??? 14922 14923 if Ekind_In (E, E_Void, E_Subprogram_Body, E_Package_Body) then 14924 Decl := E; 14925 14926 loop 14927 Decl := Parent (Decl); 14928 exit when Nkind (Decl) in N_Proper_Body; 14929 end loop; 14930 14931 return Corresponding_Spec (Decl); 14932 14933 else 14934 return E; 14935 end if; 14936 end Spec_Entity; 14937 14938 ------------ 14939 -- Within -- 14940 ------------ 14941 14942 function Within (E1, E2 : Entity_Id) return Boolean is 14943 Scop : Entity_Id; 14944 begin 14945 Scop := E1; 14946 loop 14947 if Scop = E2 then 14948 return True; 14949 elsif Scop = Standard_Standard then 14950 return False; 14951 else 14952 Scop := Scope (Scop); 14953 end if; 14954 end loop; 14955 end Within; 14956 14957 -------------------------- 14958 -- Within_Elaborate_All -- 14959 -------------------------- 14960 14961 function Within_Elaborate_All 14962 (Unit : Unit_Number_Type; 14963 E : Entity_Id) return Boolean 14964 is 14965 type Unit_Number_Set is array (Main_Unit .. Last_Unit) of Boolean; 14966 pragma Pack (Unit_Number_Set); 14967 14968 Seen : Unit_Number_Set := (others => False); 14969 -- Seen (X) is True after we have seen unit X in the walk. This is used 14970 -- to prevent processing the same unit more than once. 14971 14972 Result : Boolean := False; 14973 14974 procedure Helper (Unit : Unit_Number_Type); 14975 -- This helper procedure does all the work for Within_Elaborate_All. It 14976 -- walks the dependency graph, and sets Result to True if it finds an 14977 -- appropriate Elaborate_All. 14978 14979 ------------ 14980 -- Helper -- 14981 ------------ 14982 14983 procedure Helper (Unit : Unit_Number_Type) is 14984 CU : constant Node_Id := Cunit (Unit); 14985 14986 Item : Node_Id; 14987 Item2 : Node_Id; 14988 Elab_Id : Entity_Id; 14989 Par : Node_Id; 14990 14991 begin 14992 if Seen (Unit) then 14993 return; 14994 else 14995 Seen (Unit) := True; 14996 end if; 14997 14998 -- First, check for Elaborate_Alls on this unit 14999 15000 Item := First (Context_Items (CU)); 15001 while Present (Item) loop 15002 if Nkind (Item) = N_Pragma 15003 and then Pragma_Name (Item) = Name_Elaborate_All 15004 then 15005 -- Return if some previous error on the pragma itself. The 15006 -- pragma may be unanalyzed, because of a previous error, or 15007 -- if it is the context of a subunit, inherited by its parent. 15008 15009 if Error_Posted (Item) or else not Analyzed (Item) then 15010 return; 15011 end if; 15012 15013 Elab_Id := 15014 Entity 15015 (Expression (First (Pragma_Argument_Associations (Item)))); 15016 15017 if E = Elab_Id then 15018 Result := True; 15019 return; 15020 end if; 15021 15022 Par := Parent (Unit_Declaration_Node (Elab_Id)); 15023 15024 Item2 := First (Context_Items (Par)); 15025 while Present (Item2) loop 15026 if Nkind (Item2) = N_With_Clause 15027 and then Entity (Name (Item2)) = E 15028 and then not Limited_Present (Item2) 15029 then 15030 Result := True; 15031 return; 15032 end if; 15033 15034 Next (Item2); 15035 end loop; 15036 end if; 15037 15038 Next (Item); 15039 end loop; 15040 15041 -- Second, recurse on with's. We could do this as part of the above 15042 -- loop, but it's probably more efficient to have two loops, because 15043 -- the relevant Elaborate_All is likely to be on the initial unit. In 15044 -- other words, we're walking the with's breadth-first. This part is 15045 -- only necessary in the dynamic elaboration model. 15046 15047 if Dynamic_Elaboration_Checks then 15048 Item := First (Context_Items (CU)); 15049 while Present (Item) loop 15050 if Nkind (Item) = N_With_Clause 15051 and then not Limited_Present (Item) 15052 then 15053 -- Note: the following call to Get_Cunit_Unit_Number does a 15054 -- linear search, which could be slow, but it's OK because 15055 -- we're about to give a warning anyway. Also, there might 15056 -- be hundreds of units, but not millions. If it turns out 15057 -- to be a problem, we could store the Get_Cunit_Unit_Number 15058 -- in each N_Compilation_Unit node, but that would involve 15059 -- rearranging N_Compilation_Unit_Aux to make room. 15060 15061 Helper (Get_Cunit_Unit_Number (Library_Unit (Item))); 15062 15063 if Result then 15064 return; 15065 end if; 15066 end if; 15067 15068 Next (Item); 15069 end loop; 15070 end if; 15071 end Helper; 15072 15073 -- Start of processing for Within_Elaborate_All 15074 15075 begin 15076 Helper (Unit); 15077 return Result; 15078 end Within_Elaborate_All; 15079 15080end Sem_Elab; 15081