1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- S E M _ E L A B -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1997-2019, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Atree; use Atree; 27with Checks; use Checks; 28with Debug; use Debug; 29with Einfo; use Einfo; 30with Elists; use Elists; 31with Errout; use Errout; 32with Exp_Ch11; use Exp_Ch11; 33with Exp_Tss; use Exp_Tss; 34with Exp_Util; use Exp_Util; 35with Expander; use Expander; 36with Lib; use Lib; 37with Lib.Load; use Lib.Load; 38with Namet; use Namet; 39with Nlists; use Nlists; 40with Nmake; use Nmake; 41with Opt; use Opt; 42with Output; use Output; 43with Restrict; use Restrict; 44with Rident; use Rident; 45with Rtsfind; use Rtsfind; 46with Sem; use Sem; 47with Sem_Aux; use Sem_Aux; 48with Sem_Cat; use Sem_Cat; 49with Sem_Ch7; use Sem_Ch7; 50with Sem_Ch8; use Sem_Ch8; 51with Sem_Prag; use Sem_Prag; 52with Sem_Util; use Sem_Util; 53with Sinfo; use Sinfo; 54with Sinput; use Sinput; 55with Snames; use Snames; 56with Stand; use Stand; 57with Table; 58with Tbuild; use Tbuild; 59with Uintp; use Uintp; 60with Uname; use Uname; 61 62with GNAT.HTable; use GNAT.HTable; 63 64package body Sem_Elab is 65 66 ----------------------------------------- 67 -- Access-before-elaboration mechanism -- 68 ----------------------------------------- 69 70 -- The access-before-elaboration (ABE) mechanism implemented in this unit 71 -- has the following objectives: 72 -- 73 -- * Diagnose at compile-time or install run-time checks to prevent ABE 74 -- access to data and behaviour. 75 -- 76 -- The high-level idea is to accurately diagnose ABE issues within a 77 -- single unit because the ABE mechanism can inspect the whole unit. 78 -- As soon as the elaboration graph extends to an external unit, the 79 -- diagnostics stop because the body of the unit may not be available. 80 -- Due to control and data flow, the ABE mechanism cannot accurately 81 -- determine whether a particular scenario will be elaborated or not. 82 -- Conditional ABE checks are therefore used to verify the elaboration 83 -- status of a local and external target at run time. 84 -- 85 -- * Supply elaboration dependencies for a unit to binde 86 -- 87 -- The ABE mechanism registers each outgoing elaboration edge for the 88 -- main unit in its ALI file. GNATbind and binde can then reconstruct 89 -- the full elaboration graph and determine the proper elaboration 90 -- order for all units in the compilation. 91 -- 92 -- The ABE mechanism supports three models of elaboration: 93 -- 94 -- * Dynamic model - This is the most permissive of the three models. 95 -- When the dynamic model is in effect, the mechanism performs very 96 -- little diagnostics and generates run-time checks to detect ABE 97 -- issues. The behaviour of this model is identical to that specified 98 -- by the Ada RM. This model is enabled with switch -gnatE. 99 -- 100 -- * Static model - This is the middle ground of the three models. When 101 -- the static model is in effect, the mechanism diagnoses and installs 102 -- run-time checks to detect ABE issues in the main unit. In addition, 103 -- the mechanism generates implicit Elaborate or Elaborate_All pragmas 104 -- to ensure the prior elaboration of withed units. The model employs 105 -- textual order, with clause context, and elaboration-related source 106 -- pragmas. This is the default model. 107 -- 108 -- * SPARK model - This is the most conservative of the three models and 109 -- impelements the semantics defined in SPARK RM 7.7. The SPARK model 110 -- is in effect only when a context resides in a SPARK_Mode On region, 111 -- otherwise the mechanism falls back to one of the previous models. 112 -- 113 -- The ABE mechanism consists of a "recording" phase and a "processing" 114 -- phase. 115 116 ----------------- 117 -- Terminology -- 118 ----------------- 119 120 -- * ABE - An attempt to activate, call, or instantiate a scenario which 121 -- has not been fully elaborated. 122 -- 123 -- * Bridge target - A type of target. A bridge target is a link between 124 -- scenarios. It is usually a byproduct of expansion and does not have 125 -- any direct ABE ramifications. 126 -- 127 -- * Call marker - A special node used to indicate the presence of a call 128 -- in the tree in case expansion transforms or eliminates the original 129 -- call. N_Call_Marker nodes do not have static and run-time semantics. 130 -- 131 -- * Conditional ABE - A type of ABE. A conditional ABE occurs when the 132 -- elaboration or invocation of a target by a scenario within the main 133 -- unit causes an ABE, but does not cause an ABE for another scenarios 134 -- within the main unit. 135 -- 136 -- * Declaration level - A type of enclosing level. A scenario or target is 137 -- at the declaration level when it appears within the declarations of a 138 -- block statement, entry body, subprogram body, or task body, ignoring 139 -- enclosing packages. 140 -- 141 -- * Early call region - A section of code which ends at a subprogram body 142 -- and starts from the nearest non-preelaborable construct which precedes 143 -- the subprogram body. The early call region extends from a package body 144 -- to a package spec when the spec carries pragma Elaborate_Body. 145 -- 146 -- * Generic library level - A type of enclosing level. A scenario or 147 -- target is at the generic library level if it appears in a generic 148 -- package library unit, ignoring enclosing packages. 149 -- 150 -- * Guaranteed ABE - A type of ABE. A guaranteed ABE occurs when the 151 -- elaboration or invocation of a target by all scenarios within the 152 -- main unit causes an ABE. 153 -- 154 -- * Instantiation library level - A type of enclosing level. A scenario 155 -- or target is at the instantiation library level if it appears in an 156 -- instantiation library unit, ignoring enclosing packages. 157 -- 158 -- * Library level - A type of enclosing level. A scenario or target is at 159 -- the library level if it appears in a package library unit, ignoring 160 -- enclosng packages. 161 -- 162 -- * Non-library-level encapsulator - A construct that cannot be elaborated 163 -- on its own and requires elaboration by a top-level scenario. 164 -- 165 -- * Scenario - A construct or context which may be elaborated or executed 166 -- by elaboration code. The scenarios recognized by the ABE mechanism are 167 -- as follows: 168 -- 169 -- - '[Unrestricted_]Access of entries, operators, and subprograms 170 -- 171 -- - Assignments to variables 172 -- 173 -- - Calls to entries, operators, and subprograms 174 -- 175 -- - Derived type declarations 176 -- 177 -- - Instantiations 178 -- 179 -- - Pragma Refined_State 180 -- 181 -- - Reads of variables 182 -- 183 -- - Task activation 184 -- 185 -- * Target - A construct referenced by a scenario. The targets recognized 186 -- by the ABE mechanism are as follows: 187 -- 188 -- - For '[Unrestricted_]Access of entries, operators, and subprograms, 189 -- the target is the entry, operator, or subprogram. 190 -- 191 -- - For assignments to variables, the target is the variable 192 -- 193 -- - For calls, the target is the entry, operator, or subprogram 194 -- 195 -- - For derived type declarations, the target is the derived type 196 -- 197 -- - For instantiations, the target is the generic template 198 -- 199 -- - For pragma Refined_State, the targets are the constituents 200 -- 201 -- - For reads of variables, the target is the variable 202 -- 203 -- - For task activation, the target is the task body 204 -- 205 -- * Top-level scenario - A scenario which appears in a non-generic main 206 -- unit. Depending on the elaboration model is in effect, the following 207 -- addotional restrictions apply: 208 -- 209 -- - Dynamic model - No restrictions 210 -- 211 -- - SPARK model - Falls back to either the dynamic or static model 212 -- 213 -- - Static model - The scenario must be at the library level 214 215 --------------------- 216 -- Recording phase -- 217 --------------------- 218 219 -- The Recording phase coincides with the analysis/resolution phase of the 220 -- compiler. It has the following objectives: 221 -- 222 -- * Record all top-level scenarios for examination by the Processing 223 -- phase. 224 -- 225 -- Saving only a certain number of nodes improves the performance of 226 -- the ABE mechanism. This eliminates the need to examine the whole 227 -- tree in a separate pass. 228 -- 229 -- * Record certain SPARK scenarios which are not necessarily executable 230 -- during elaboration, but still require elaboration-related checks. 231 -- 232 -- Saving only a certain number of nodes improves the performance of 233 -- the ABE mechanism. This eliminates the need to examine the whole 234 -- tree in a separate pass. 235 -- 236 -- * Detect and diagnose calls in preelaborable or pure units, including 237 -- generic bodies. 238 -- 239 -- This diagnostic is carried out during the Recording phase because it 240 -- does not need the heavy recursive traversal done by the Processing 241 -- phase. 242 -- 243 -- * Detect and diagnose guaranteed ABEs caused by instantiations, 244 -- calls, and task activation. 245 -- 246 -- The issues detected by the ABE mechanism are reported as warnings 247 -- because they do not violate Ada semantics. Forward instantiations 248 -- may thus reach gigi, however gigi cannot handle certain kinds of 249 -- premature instantiations and may crash. To avoid this limitation, 250 -- the ABE mechanism must identify forward instantiations as early as 251 -- possible and suppress their bodies. Calls and task activations are 252 -- included in this category for completeness. 253 254 ---------------------- 255 -- Processing phase -- 256 ---------------------- 257 258 -- The Processing phase is a separate pass which starts after instantiating 259 -- and/or inlining of bodies, but before the removal of Ghost code. It has 260 -- the following objectives: 261 -- 262 -- * Examine all top-level scenarios saved during the Recording phase 263 -- 264 -- The top-level scenarios act as roots for depth-first traversal of 265 -- the call/instantiation/task activation graph. The traversal stops 266 -- when an outgoing edge leaves the main unit. 267 -- 268 -- * Examine all SPARK scenarios saved during the Recording phase 269 -- 270 -- * Depending on the elaboration model in effect, perform the following 271 -- actions: 272 -- 273 -- - Dynamic model - Install run-time conditional ABE checks. 274 -- 275 -- - SPARK model - Enforce the SPARK elaboration rules 276 -- 277 -- - Static model - Diagnose conditional ABEs, install run-time 278 -- conditional ABE checks, and guarantee the elaboration of 279 -- external units. 280 -- 281 -- * Examine nested scenarios 282 -- 283 -- Nested scenarios discovered during the depth-first traversal are 284 -- in turn subjected to the same actions outlined above and examined 285 -- for the next level of nested scenarios. 286 287 ------------------ 288 -- Architecture -- 289 ------------------ 290 291 -- Analysis/Resolution 292 -- | 293 -- +- Build_Call_Marker 294 -- | 295 -- +- Build_Variable_Reference_Marker 296 -- | 297 -- +- | -------------------- Recording phase ---------------------------+ 298 -- | v | 299 -- | Record_Elaboration_Scenario | 300 -- | | | 301 -- | +--> Check_Preelaborated_Call | 302 -- | | | 303 -- | +--> Process_Guaranteed_ABE | 304 -- | | | | 305 -- | | +--> Process_Guaranteed_ABE_Activation | 306 -- | | | | 307 -- | | +--> Process_Guaranteed_ABE_Call | 308 -- | | | | 309 -- | | +--> Process_Guaranteed_ABE_Instantiation | 310 -- | | | 311 -- +- | ----------------------------------------------------------------+ 312 -- | 313 -- | 314 -- +--> SPARK_Scenarios 315 -- | +-----------+-----------+ .. +-----------+ 316 -- | | Scenario1 | Scenario2 | .. | ScenarioN | 317 -- | +-----------+-----------+ .. +-----------+ 318 -- | 319 -- +--> Top_Level_Scenarios 320 -- | +-----------+-----------+ .. +-----------+ 321 -- | | Scenario1 | Scenario2 | .. | ScenarioN | 322 -- | +-----------+-----------+ .. +-----------+ 323 -- | 324 -- End of Compilation 325 -- | 326 -- +- | --------------------- Processing phase -------------------------+ 327 -- | v | 328 -- | Check_Elaboration_Scenarios | 329 -- | | | 330 -- | +--> Check_SPARK_Scenario | 331 -- | | | | 332 -- | | +--> Check_SPARK_Derived_Type | 333 -- | | | | 334 -- | | +--> Check_SPARK_Instantiation | 335 -- | | | | 336 -- | | +--> Check_SPARK_Refined_State_Pragma | 337 -- | | | 338 -- | +--> Process_Conditional_ABE <---------------------------+ | 339 -- | | | | 340 -- | +--> Process_Conditional_ABE_Access Is_Suitable_Scenario | 341 -- | | ^ | 342 -- | +--> Process_Conditional_ABE_Activation | | 343 -- | | | | | 344 -- | | +-----------------------------+ | | 345 -- | | | | | 346 -- | +--> Process_Conditional_ABE_Call +--------> Traverse_Body | 347 -- | | | | | 348 -- | | +-----------------------------+ | 349 -- | | | 350 -- | +--> Process_Conditional_ABE_Instantiation | 351 -- | | | 352 -- | +--> Process_Conditional_ABE_Variable_Assignment | 353 -- | | | 354 -- | +--> Process_Conditional_ABE_Variable_Reference | 355 -- | | 356 -- +--------------------------------------------------------------------+ 357 358 ---------------------- 359 -- Important points -- 360 ---------------------- 361 362 -- The Processing phase starts after the analysis, resolution, expansion 363 -- phase has completed. As a result, no current semantic information is 364 -- available. The scope stack is empty, global flags such as In_Instance 365 -- or Inside_A_Generic become useless. To remedy this, the ABE mechanism 366 -- must either save or recompute semantic information. 367 368 -- Expansion heavily transforms calls and to some extent instantiations. To 369 -- remedy this, the ABE mechanism generates N_Call_Marker nodes in order to 370 -- capture the target and relevant attributes of the original call. 371 372 -- The diagnostics of the ABE mechanism depend on accurate source locations 373 -- to determine the spacial relation of nodes. 374 375 ----------------------------------------- 376 -- Suppression of elaboration warnings -- 377 ----------------------------------------- 378 379 -- Elaboration warnings along multiple traversal paths rooted at a scenario 380 -- are suppressed when the scenario has elaboration warnings suppressed. 381 -- 382 -- Root scenario 383 -- | 384 -- +-- Child scenario 1 385 -- | | 386 -- | +-- Grandchild scenario 1 387 -- | | 388 -- | +-- Grandchild scenario N 389 -- | 390 -- +-- Child scenario N 391 -- 392 -- If the root scenario has elaboration warnings suppressed, then all its 393 -- child, grandchild, etc. scenarios will have their elaboration warnings 394 -- suppressed. 395 -- 396 -- In addition to switch -gnatwL, pragma Warnings may be used to suppress 397 -- elaboration-related warnings when used in the following manner: 398 -- 399 -- pragma Warnings ("L"); 400 -- <scenario-or-target> 401 -- 402 -- <target> 403 -- pragma Warnings (Off, target); 404 -- 405 -- pragma Warnings (Off); 406 -- <scenario-or-target> 407 -- 408 -- * To suppress elaboration warnings for '[Unrestricted_]Access of 409 -- entries, operators, and subprograms, either: 410 -- 411 -- - Suppress the entry, operator, or subprogram, or 412 -- - Suppress the attribute, or 413 -- - Use switch -gnatw.f 414 -- 415 -- * To suppress elaboration warnings for calls to entries, operators, 416 -- and subprograms, either: 417 -- 418 -- - Suppress the entry, operator, or subprogram, or 419 -- - Suppress the call 420 -- 421 -- * To suppress elaboration warnings for instantiations, suppress the 422 -- instantiation. 423 -- 424 -- * To suppress elaboration warnings for task activations, either: 425 -- 426 -- - Suppress the task object, or 427 -- - Suppress the task type, or 428 -- - Suppress the activation call 429 430 -------------- 431 -- Switches -- 432 -------------- 433 434 -- The following switches may be used to control the behavior of the ABE 435 -- mechanism. 436 -- 437 -- -gnatd_a stop elaboration checks on accept or select statement 438 -- 439 -- The ABE mechanism stops the traversal of a task body when it 440 -- encounters an accept or a select statement. This behavior is 441 -- equivalent to restriction No_Entry_Calls_In_Elaboration_Code, 442 -- but without penalizing actual entry calls during elaboration. 443 -- 444 -- -gnatd_e ignore entry calls and requeue statements for elaboration 445 -- 446 -- The ABE mechanism does not generate N_Call_Marker nodes for 447 -- protected or task entry calls as well as requeue statements. 448 -- As a result, the calls and requeues are not recorded or 449 -- processed. 450 -- 451 -- -gnatdE elaboration checks on predefined units 452 -- 453 -- The ABE mechanism considers scenarios which appear in internal 454 -- units (Ada, GNAT, Interfaces, System). 455 -- 456 -- -gnatd.G ignore calls through generic formal parameters for elaboration 457 -- 458 -- The ABE mechanism does not generate N_Call_Marker nodes for 459 -- calls which occur in expanded instances, and invoke generic 460 -- actual subprograms through generic formal subprograms. As a 461 -- result, the calls are not recorded or processed. 462 -- 463 -- -gnatd_i ignore activations and calls to instances for elaboration 464 -- 465 -- The ABE mechanism ignores calls and task activations when they 466 -- target a subprogram or task type defined an external instance. 467 -- As a result, the calls and task activations are not processed. 468 -- 469 -- -gnatdL ignore external calls from instances for elaboration 470 -- 471 -- The ABE mechanism does not generate N_Call_Marker nodes for 472 -- calls which occur in expanded instances, do not invoke generic 473 -- actual subprograms through formal subprograms, and the target 474 -- is external to the instance. As a result, the calls are not 475 -- recorded or processed. 476 -- 477 -- -gnatd.o conservative elaboration order for indirect calls 478 -- 479 -- The ABE mechanism treats '[Unrestricted_]Access of an entry, 480 -- operator, or subprogram as an immediate invocation of the 481 -- target. As a result, it performs ABE checks and diagnostics on 482 -- the immediate call. 483 -- 484 -- -gnatd_p ignore assertion pragmas for elaboration 485 -- 486 -- The ABE mechanism does not generate N_Call_Marker nodes for 487 -- calls to subprograms which verify the run-time semantics of 488 -- the following assertion pragmas: 489 -- 490 -- Default_Initial_Condition 491 -- Initial_Condition 492 -- Invariant 493 -- Invariant'Class 494 -- Post 495 -- Post'Class 496 -- Postcondition 497 -- Type_Invariant 498 -- Type_Invariant_Class 499 -- 500 -- As a result, the assertion expressions of the pragmas are not 501 -- processed. 502 -- 503 -- -gnatd_s stop elaboration checks on synchronous suspension 504 -- 505 -- The ABE mechanism stops the traversal of a task body when it 506 -- encounters a call to one of the following routines: 507 -- 508 -- Ada.Synchronous_Barriers.Wait_For_Release 509 -- Ada.Synchronous_Task_Control.Suspend_Until_True 510 -- 511 -- -gnatd.U ignore indirect calls for static elaboration 512 -- 513 -- The ABE mechanism does not consider '[Unrestricted_]Access of 514 -- entries, operators, and subprograms. As a result, the scenarios 515 -- are not recorder or processed. 516 -- 517 -- -gnatd.v enforce SPARK elaboration rules in SPARK code 518 -- 519 -- The ABE mechanism applies some of the SPARK elaboration rules 520 -- defined in the SPARK reference manual, chapter 7.7. Note that 521 -- certain rules are always enforced, regardless of whether the 522 -- switch is active. 523 -- 524 -- -gnatd.y disable implicit pragma Elaborate_All on task bodies 525 -- 526 -- The ABE mechanism does not generate implicit Elaborate_All when 527 -- the need for the pragma came from a task body. 528 -- 529 -- -gnatE dynamic elaboration checking mode enabled 530 -- 531 -- The ABE mechanism assumes that any scenario is elaborated or 532 -- invoked by elaboration code. The ABE mechanism performs very 533 -- little diagnostics and generates condintional ABE checks to 534 -- detect ABE issues at run-time. 535 -- 536 -- -gnatel turn on info messages on generated Elaborate[_All] pragmas 537 -- 538 -- The ABE mechanism produces information messages on generated 539 -- implicit Elabote[_All] pragmas along with traceback showing 540 -- why the pragma was generated. In addition, the ABE mechanism 541 -- produces information messages for each scenario elaborated or 542 -- invoked by elaboration code. 543 -- 544 -- -gnateL turn off info messages on generated Elaborate[_All] pragmas 545 -- 546 -- The complementary switch for -gnatel. 547 -- 548 -- -gnatH legacy elaboration checking mode enabled 549 -- 550 -- When this switch is in effect, the pre-18.x ABE model becomes 551 -- the defacto ABE model. This ammounts to cutting off all entry 552 -- points into the new ABE mechanism, and giving full control to 553 -- the old ABE mechanism. 554 -- 555 -- -gnatJ permissive elaboration checking mode enabled 556 -- 557 -- This switch activates the following switches: 558 -- 559 -- -gnatd_a 560 -- -gnatd_e 561 -- -gnatd.G 562 -- -gnatd_i 563 -- -gnatdL 564 -- -gnatd_p 565 -- -gnatd_s 566 -- -gnatd.U 567 -- -gnatd.y 568 -- 569 -- IMPORTANT: The behavior of the ABE mechanism becomes more 570 -- permissive at the cost of accurate diagnostics and runtime 571 -- ABE checks. 572 -- 573 -- -gnatw.f turn on warnings for suspicious Subp'Access 574 -- 575 -- The ABE mechanism treats '[Unrestricted_]Access of an entry, 576 -- operator, or subprogram as a pseudo invocation of the target. 577 -- As a result, it performs ABE diagnostics on the pseudo call. 578 -- 579 -- -gnatw.F turn off warnings for suspicious Subp'Access 580 -- 581 -- The complementary switch for -gnatw.f. 582 -- 583 -- -gnatwl turn on warnings for elaboration problems 584 -- 585 -- The ABE mechanism produces warnings on detected ABEs along with 586 -- a traceback showing the graph of the ABE. 587 -- 588 -- -gnatwL turn off warnings for elaboration problems 589 -- 590 -- The complementary switch for -gnatwl. 591 592 --------------------------- 593 -- Adding a new scenario -- 594 --------------------------- 595 596 -- The following steps describe how to add a new elaboration scenario and 597 -- preserve the existing architecture. Note that not all of the steps may 598 -- need to be carried out. 599 -- 600 -- 1) Update predicate Is_Scenario 601 -- 602 -- 2) Add predicate Is_Suitable_xxx. Include a call to it in predicate 603 -- Is_Suitable_Scenario. 604 -- 605 -- 3) Update routine Record_Elaboration_Scenario 606 -- 607 -- 4) Add routine Process_Conditional_ABE_xxx. Include a call to it in 608 -- routine Process_Conditional_ABE. 609 -- 610 -- 5) Add routine Process_Guaranteed_ABE_xxx. Include a call to it in 611 -- routine Process_Guaranteed_ABE. 612 -- 613 -- 6) Add routine Check_SPARK_xxx. Include a call to it in routine 614 -- Check_SPARK_Scenario. 615 -- 616 -- 7) Add routine Info_xxx. Include a call to it in routine 617 -- Process_Conditional_ABE_xxx. 618 -- 619 -- 8) Add routine Output_xxx. Include a call to it in routine 620 -- Output_Active_Scenarios. 621 -- 622 -- 9) Add routine Extract_xxx_Attributes 623 -- 624 -- 10) Update routine Is_Potential_Scenario 625 626 ------------------------- 627 -- Adding a new target -- 628 ------------------------- 629 630 -- The following steps describe how to add a new elaboration target and 631 -- preserve the existing architecture. Note that not all of the steps may 632 -- need to be carried out. 633 -- 634 -- 1) Add predicate Is_xxx. 635 -- 636 -- 2) Update the following predicates 637 -- 638 -- Is_Ada_Semantic_Target 639 -- Is_Assertion_Pragma_Target 640 -- Is_Bridge_Target 641 -- Is_SPARK_Semantic_Target 642 -- 643 -- If necessary, create a new category. 644 -- 645 -- 3) Update the appropriate Info_xxx routine. 646 -- 647 -- 4) Update the appropriate Output_xxx routine. 648 -- 649 -- 5) Update routine Extract_Target_Attributes. If necessary, create a 650 -- new Extract_xxx routine. 651 652 -------------------------- 653 -- Debugging ABE issues -- 654 -------------------------- 655 656 -- * If the issue involves a call, ensure that the call is eligible for ABE 657 -- processing and receives a corresponding call marker. The routines of 658 -- interest are 659 -- 660 -- Build_Call_Marker 661 -- Record_Elaboration_Scenario 662 663 -- * If the issue involves an arbitrary scenario, ensure that the scenario 664 -- is either recorded, or is successfully recognized while traversing a 665 -- body. The routines of interest are 666 -- 667 -- Record_Elaboration_Scenario 668 -- Process_Conditional_ABE 669 -- Process_Guaranteed_ABE 670 -- Traverse_Body 671 672 -- * If the issue involves a circularity in the elaboration order, examine 673 -- the ALI files and look for the following encodings next to units: 674 -- 675 -- E indicates a source Elaborate 676 -- 677 -- EA indicates a source Elaborate_All 678 -- 679 -- AD indicates an implicit Elaborate_All 680 -- 681 -- ED indicates an implicit Elaborate 682 -- 683 -- If possible, compare these encodings with those generated by the old 684 -- ABE mechanism. The routines of interest are 685 -- 686 -- Ensure_Prior_Elaboration 687 688 ---------------- 689 -- Attributes -- 690 ---------------- 691 692 -- To minimize the amount of code within routines, the ABE mechanism relies 693 -- on "attribute" records to capture relevant information for a scenario or 694 -- a target. 695 696 -- The following type captures relevant attributes which pertain to a call 697 698 type Call_Attributes is record 699 Elab_Checks_OK : Boolean; 700 -- This flag is set when the call has elaboration checks enabled 701 702 Elab_Warnings_OK : Boolean; 703 -- This flag is set when the call has elaboration warnings elabled 704 705 From_Source : Boolean; 706 -- This flag is set when the call comes from source 707 708 Ghost_Mode_Ignore : Boolean; 709 -- This flag is set when the call appears in a region subject to pragma 710 -- Ghost with policy Ignore. 711 712 In_Declarations : Boolean; 713 -- This flag is set when the call appears at the declaration level 714 715 Is_Dispatching : Boolean; 716 -- This flag is set when the call is dispatching 717 718 SPARK_Mode_On : Boolean; 719 -- This flag is set when the call appears in a region subject to pragma 720 -- SPARK_Mode with value On. 721 end record; 722 723 -- The following type captures relevant attributes which pertain to the 724 -- prior elaboration of a unit. This type is coupled together with a unit 725 -- to form a key -> value relationship. 726 727 type Elaboration_Attributes is record 728 Source_Pragma : Node_Id; 729 -- This attribute denotes a source Elaborate or Elaborate_All pragma 730 -- which guarantees the prior elaboration of some unit with respect 731 -- to the main unit. The pragma may come from the following contexts: 732 733 -- * The main unit 734 -- * The spec of the main unit (if applicable) 735 -- * Any parent spec of the main unit (if applicable) 736 -- * Any parent subunit of the main unit (if applicable) 737 738 -- The attribute remains Empty if no such pragma is available. Source 739 -- pragmas play a role in satisfying SPARK elaboration requirements. 740 741 With_Clause : Node_Id; 742 -- This attribute denotes an internally generated or source with clause 743 -- for some unit withed by the main unit. With clauses carry flags which 744 -- represent implicit Elaborate or Elaborate_All pragmas. These clauses 745 -- play a role in supplying the elaboration dependencies to binde. 746 end record; 747 748 No_Elaboration_Attributes : constant Elaboration_Attributes := 749 (Source_Pragma => Empty, 750 With_Clause => Empty); 751 752 -- The following type captures relevant attributes which pertain to an 753 -- instantiation. 754 755 type Instantiation_Attributes is record 756 Elab_Checks_OK : Boolean; 757 -- This flag is set when the instantiation has elaboration checks 758 -- enabled. 759 760 Elab_Warnings_OK : Boolean; 761 -- This flag is set when the instantiation has elaboration warnings 762 -- enabled. 763 764 Ghost_Mode_Ignore : Boolean; 765 -- This flag is set when the instantiation appears in a region subject 766 -- to pragma Ghost with policy ignore, or starts one such region. 767 768 In_Declarations : Boolean; 769 -- This flag is set when the instantiation appears at the declaration 770 -- level. 771 772 SPARK_Mode_On : Boolean; 773 -- This flag is set when the instantiation appears in a region subject 774 -- to pragma SPARK_Mode with value On, or starts one such region. 775 end record; 776 777 -- The following type captures relevant attributes which pertain to the 778 -- state of the Processing phase. 779 780 type Processing_Attributes is record 781 Suppress_Implicit_Pragmas : Boolean; 782 -- This flag is set when the Processing phase must not generate any 783 -- implicit Elaborate[_All] pragmas. 784 785 Suppress_Warnings : Boolean; 786 -- This flag is set when the Processing phase must not emit any warnings 787 -- on elaboration problems. 788 789 Within_Initial_Condition : Boolean; 790 -- This flag is set when the Processing phase is currently examining a 791 -- scenario which was reached from an initial condition procedure. 792 793 Within_Instance : Boolean; 794 -- This flag is set when the Processing phase is currently examining a 795 -- scenario which was reached from a scenario defined in an instance. 796 797 Within_Partial_Finalization : Boolean; 798 -- This flag is set when the Processing phase is currently examining a 799 -- scenario which was reached from a partial finalization procedure. 800 801 Within_Task_Body : Boolean; 802 -- This flag is set when the Processing phase is currently examining a 803 -- scenario which was reached from a task body. 804 end record; 805 806 Initial_State : constant Processing_Attributes := 807 (Suppress_Implicit_Pragmas => False, 808 Suppress_Warnings => False, 809 Within_Initial_Condition => False, 810 Within_Instance => False, 811 Within_Partial_Finalization => False, 812 Within_Task_Body => False); 813 814 -- The following type captures relevant attributes which pertain to a 815 -- target. 816 817 type Target_Attributes is record 818 Elab_Checks_OK : Boolean; 819 -- This flag is set when the target has elaboration checks enabled 820 821 Elab_Warnings_OK : Boolean; 822 -- This flag is set when the target has elaboration warnings enabled 823 824 From_Source : Boolean; 825 -- This flag is set when the target comes from source 826 827 Ghost_Mode_Ignore : Boolean; 828 -- This flag is set when the target appears in a region subject to 829 -- pragma Ghost with policy ignore, or starts one such region. 830 831 SPARK_Mode_On : Boolean; 832 -- This flag is set when the target appears in a region subject to 833 -- pragma SPARK_Mode with value On, or starts one such region. 834 835 Spec_Decl : Node_Id; 836 -- This attribute denotes the declaration of Spec_Id 837 838 Unit_Id : Entity_Id; 839 -- This attribute denotes the top unit where Spec_Id resides 840 841 -- The semantics of the following attributes depend on the target 842 843 Body_Barf : Node_Id; 844 Body_Decl : Node_Id; 845 Spec_Id : Entity_Id; 846 847 -- The target is a generic package or a subprogram 848 -- 849 -- * Body_Barf - Empty 850 -- 851 -- * Body_Decl - This attribute denotes the generic or subprogram 852 -- body. 853 -- 854 -- * Spec_Id - This attribute denotes the entity of the generic 855 -- package or subprogram. 856 857 -- The target is a protected entry 858 -- 859 -- * Body_Barf - This attribute denotes the body of the barrier 860 -- function if expansion took place, otherwise it is Empty. 861 -- 862 -- * Body_Decl - This attribute denotes the body of the procedure 863 -- which emulates the entry if expansion took place, otherwise it 864 -- denotes the body of the protected entry. 865 -- 866 -- * Spec_Id - This attribute denotes the entity of the procedure 867 -- which emulates the entry if expansion took place, otherwise it 868 -- denotes the protected entry. 869 870 -- The target is a protected subprogram 871 -- 872 -- * Body_Barf - Empty 873 -- 874 -- * Body_Decl - This attribute denotes the body of the protected or 875 -- unprotected version of the protected subprogram if expansion took 876 -- place, otherwise it denotes the body of the protected subprogram. 877 -- 878 -- * Spec_Id - This attribute denotes the entity of the protected or 879 -- unprotected version of the protected subprogram if expansion took 880 -- place, otherwise it is the entity of the protected subprogram. 881 882 -- The target is a task entry 883 -- 884 -- * Body_Barf - Empty 885 -- 886 -- * Body_Decl - This attribute denotes the body of the procedure 887 -- which emulates the task body if expansion took place, otherwise 888 -- it denotes the body of the task type. 889 -- 890 -- * Spec_Id - This attribute denotes the entity of the procedure 891 -- which emulates the task body if expansion took place, otherwise 892 -- it denotes the entity of the task type. 893 end record; 894 895 -- The following type captures relevant attributes which pertain to a task 896 -- type. 897 898 type Task_Attributes is record 899 Body_Decl : Node_Id; 900 -- This attribute denotes the declaration of the procedure body which 901 -- emulates the behaviour of the task body. 902 903 Elab_Checks_OK : Boolean; 904 -- This flag is set when the task type has elaboration checks enabled 905 906 Elab_Warnings_OK : Boolean; 907 -- This flag is set when the task type has elaboration warnings enabled 908 909 Ghost_Mode_Ignore : Boolean; 910 -- This flag is set when the task type appears in a region subject to 911 -- pragma Ghost with policy ignore, or starts one such region. 912 913 SPARK_Mode_On : Boolean; 914 -- This flag is set when the task type appears in a region subject to 915 -- pragma SPARK_Mode with value On, or starts one such region. 916 917 Spec_Id : Entity_Id; 918 -- This attribute denotes the entity of the initial declaration of the 919 -- procedure body which emulates the behaviour of the task body. 920 921 Task_Decl : Node_Id; 922 -- This attribute denotes the declaration of the task type 923 924 Unit_Id : Entity_Id; 925 -- This attribute denotes the entity of the compilation unit where the 926 -- task type resides. 927 end record; 928 929 -- The following type captures relevant attributes which pertain to a 930 -- variable. 931 932 type Variable_Attributes is record 933 Unit_Id : Entity_Id; 934 -- This attribute denotes the entity of the compilation unit where the 935 -- variable resides. 936 end record; 937 938 --------------------- 939 -- Data structures -- 940 --------------------- 941 942 -- The ABE mechanism employs lists and hash tables to store information 943 -- pertaining to scenarios and targets, as well as the Processing phase. 944 -- The need for data structures comes partly from the size limitation of 945 -- nodes. Note that the use of hash tables is conservative and operations 946 -- are carried out only when a particular hash table has at least one key 947 -- value pair (see xxx_In_Use flags). 948 949 -- The following table stores the early call regions of subprogram bodies 950 951 Early_Call_Regions_Max : constant := 101; 952 953 type Early_Call_Regions_Index is range 0 .. Early_Call_Regions_Max - 1; 954 955 function Early_Call_Regions_Hash 956 (Key : Entity_Id) return Early_Call_Regions_Index; 957 -- Obtain the hash value of entity Key 958 959 Early_Call_Regions_In_Use : Boolean := False; 960 -- This flag determines whether table Early_Call_Regions contains at least 961 -- least one key/value pair. 962 963 Early_Call_Regions_No_Element : constant Node_Id := Empty; 964 965 package Early_Call_Regions is new Simple_HTable 966 (Header_Num => Early_Call_Regions_Index, 967 Element => Node_Id, 968 No_Element => Early_Call_Regions_No_Element, 969 Key => Entity_Id, 970 Hash => Early_Call_Regions_Hash, 971 Equal => "="); 972 973 -- The following table stores the elaboration status of all units withed by 974 -- the main unit. 975 976 Elaboration_Statuses_Max : constant := 1009; 977 978 type Elaboration_Statuses_Index is range 0 .. Elaboration_Statuses_Max - 1; 979 980 function Elaboration_Statuses_Hash 981 (Key : Entity_Id) return Elaboration_Statuses_Index; 982 -- Obtain the hash value of entity Key 983 984 Elaboration_Statuses_In_Use : Boolean := False; 985 -- This flag flag determines whether table Elaboration_Statuses contains at 986 -- least one key/value pair. 987 988 Elaboration_Statuses_No_Element : constant Elaboration_Attributes := 989 No_Elaboration_Attributes; 990 991 package Elaboration_Statuses is new Simple_HTable 992 (Header_Num => Elaboration_Statuses_Index, 993 Element => Elaboration_Attributes, 994 No_Element => Elaboration_Statuses_No_Element, 995 Key => Entity_Id, 996 Hash => Elaboration_Statuses_Hash, 997 Equal => "="); 998 999 -- The following table stores a status flag for each SPARK scenario saved 1000 -- in table SPARK_Scenarios. 1001 1002 Recorded_SPARK_Scenarios_Max : constant := 127; 1003 1004 type Recorded_SPARK_Scenarios_Index is 1005 range 0 .. Recorded_SPARK_Scenarios_Max - 1; 1006 1007 function Recorded_SPARK_Scenarios_Hash 1008 (Key : Node_Id) return Recorded_SPARK_Scenarios_Index; 1009 -- Obtain the hash value of Key 1010 1011 Recorded_SPARK_Scenarios_In_Use : Boolean := False; 1012 -- This flag flag determines whether table Recorded_SPARK_Scenarios 1013 -- contains at least one key/value pair. 1014 1015 Recorded_SPARK_Scenarios_No_Element : constant Boolean := False; 1016 1017 package Recorded_SPARK_Scenarios is new Simple_HTable 1018 (Header_Num => Recorded_SPARK_Scenarios_Index, 1019 Element => Boolean, 1020 No_Element => Recorded_SPARK_Scenarios_No_Element, 1021 Key => Node_Id, 1022 Hash => Recorded_SPARK_Scenarios_Hash, 1023 Equal => "="); 1024 1025 -- The following table stores a status flag for each top-level scenario 1026 -- recorded in table Top_Level_Scenarios. 1027 1028 Recorded_Top_Level_Scenarios_Max : constant := 503; 1029 1030 type Recorded_Top_Level_Scenarios_Index is 1031 range 0 .. Recorded_Top_Level_Scenarios_Max - 1; 1032 1033 function Recorded_Top_Level_Scenarios_Hash 1034 (Key : Node_Id) return Recorded_Top_Level_Scenarios_Index; 1035 -- Obtain the hash value of entity Key 1036 1037 Recorded_Top_Level_Scenarios_In_Use : Boolean := False; 1038 -- This flag flag determines whether table Recorded_Top_Level_Scenarios 1039 -- contains at least one key/value pair. 1040 1041 Recorded_Top_Level_Scenarios_No_Element : constant Boolean := False; 1042 1043 package Recorded_Top_Level_Scenarios is new Simple_HTable 1044 (Header_Num => Recorded_Top_Level_Scenarios_Index, 1045 Element => Boolean, 1046 No_Element => Recorded_Top_Level_Scenarios_No_Element, 1047 Key => Node_Id, 1048 Hash => Recorded_Top_Level_Scenarios_Hash, 1049 Equal => "="); 1050 1051 -- The following table stores all active scenarios in a recursive traversal 1052 -- starting from a top-level scenario. This table must be maintained in a 1053 -- FIFO fashion. 1054 1055 package Scenario_Stack is new Table.Table 1056 (Table_Component_Type => Node_Id, 1057 Table_Index_Type => Int, 1058 Table_Low_Bound => 1, 1059 Table_Initial => 50, 1060 Table_Increment => 100, 1061 Table_Name => "Scenario_Stack"); 1062 1063 -- The following table stores SPARK scenarios which are not necessarily 1064 -- executable during elaboration, but still require elaboration-related 1065 -- checks. 1066 1067 package SPARK_Scenarios is new Table.Table 1068 (Table_Component_Type => Node_Id, 1069 Table_Index_Type => Int, 1070 Table_Low_Bound => 1, 1071 Table_Initial => 50, 1072 Table_Increment => 100, 1073 Table_Name => "SPARK_Scenarios"); 1074 1075 -- The following table stores all top-level scenario saved during the 1076 -- Recording phase. The contents of this table act as traversal roots 1077 -- later in the Processing phase. This table must be maintained in a 1078 -- LIFO fashion. 1079 1080 package Top_Level_Scenarios is new Table.Table 1081 (Table_Component_Type => Node_Id, 1082 Table_Index_Type => Int, 1083 Table_Low_Bound => 1, 1084 Table_Initial => 1000, 1085 Table_Increment => 100, 1086 Table_Name => "Top_Level_Scenarios"); 1087 1088 -- The following table stores the bodies of all eligible scenarios visited 1089 -- during a traversal starting from a top-level scenario. The contents of 1090 -- this table must be reset upon each new traversal. 1091 1092 Visited_Bodies_Max : constant := 511; 1093 1094 type Visited_Bodies_Index is range 0 .. Visited_Bodies_Max - 1; 1095 1096 function Visited_Bodies_Hash (Key : Node_Id) return Visited_Bodies_Index; 1097 -- Obtain the hash value of node Key 1098 1099 Visited_Bodies_In_Use : Boolean := False; 1100 -- This flag determines whether table Visited_Bodies contains at least one 1101 -- key/value pair. 1102 1103 Visited_Bodies_No_Element : constant Boolean := False; 1104 1105 package Visited_Bodies is new Simple_HTable 1106 (Header_Num => Visited_Bodies_Index, 1107 Element => Boolean, 1108 No_Element => Visited_Bodies_No_Element, 1109 Key => Node_Id, 1110 Hash => Visited_Bodies_Hash, 1111 Equal => "="); 1112 1113 ----------------------- 1114 -- Local subprograms -- 1115 ----------------------- 1116 1117 -- Multiple local subprograms are utilized to lower the semantic complexity 1118 -- of the Recording and Processing phase. 1119 1120 procedure Check_Preelaborated_Call (Call : Node_Id); 1121 pragma Inline (Check_Preelaborated_Call); 1122 -- Verify that entry, operator, or subprogram call Call does not appear at 1123 -- the library level of a preelaborated unit. 1124 1125 procedure Check_SPARK_Derived_Type (Typ_Decl : Node_Id); 1126 pragma Inline (Check_SPARK_Derived_Type); 1127 -- Verify that the freeze node of a derived type denoted by declaration 1128 -- Typ_Decl is within the early call region of each overriding primitive 1129 -- body that belongs to the derived type (SPARK RM 7.7(8)). 1130 1131 procedure Check_SPARK_Instantiation (Exp_Inst : Node_Id); 1132 pragma Inline (Check_SPARK_Instantiation); 1133 -- Verify that expanded instance Exp_Inst does not precede the generic body 1134 -- it instantiates (SPARK RM 7.7(6)). 1135 1136 procedure Check_SPARK_Model_In_Effect (N : Node_Id); 1137 pragma Inline (Check_SPARK_Model_In_Effect); 1138 -- Determine whether a suitable elaboration model is currently in effect 1139 -- for verifying the SPARK rules of scenario N. Emit a warning if this is 1140 -- not the case. 1141 1142 procedure Check_SPARK_Scenario (N : Node_Id); 1143 pragma Inline (Check_SPARK_Scenario); 1144 -- Top-level dispatcher for verifying SPARK scenarios which are not always 1145 -- executable during elaboration but still need elaboration-related checks. 1146 1147 procedure Check_SPARK_Refined_State_Pragma (N : Node_Id); 1148 pragma Inline (Check_SPARK_Refined_State_Pragma); 1149 -- Verify that each constituent of Refined_State pragma N which belongs to 1150 -- an abstract state mentioned in pragma Initializes has prior elaboration 1151 -- with respect to the main unit (SPARK RM 7.7.1(7)). 1152 1153 function Compilation_Unit (Unit_Id : Entity_Id) return Node_Id; 1154 pragma Inline (Compilation_Unit); 1155 -- Return the N_Compilation_Unit node of unit Unit_Id 1156 1157 function Early_Call_Region (Body_Id : Entity_Id) return Node_Id; 1158 pragma Inline (Early_Call_Region); 1159 -- Return the early call region associated with entry or subprogram body 1160 -- Body_Id. IMPORTANT: This routine does not find the early call region. 1161 -- To compute it, use routine Find_Early_Call_Region. 1162 1163 procedure Elab_Msg_NE 1164 (Msg : String; 1165 N : Node_Id; 1166 Id : Entity_Id; 1167 Info_Msg : Boolean; 1168 In_SPARK : Boolean); 1169 pragma Inline (Elab_Msg_NE); 1170 -- Wrapper around Error_Msg_NE. Emit message Msg concerning arbitrary node 1171 -- N and entity. If flag Info_Msg is set, the routine emits an information 1172 -- message, otherwise it emits an error. If flag In_SPARK is set, then 1173 -- string " in SPARK" is added to the end of the message. 1174 1175 function Elaboration_Status 1176 (Unit_Id : Entity_Id) return Elaboration_Attributes; 1177 pragma Inline (Elaboration_Status); 1178 -- Return the set of elaboration attributes associated with unit Unit_Id 1179 1180 procedure Ensure_Prior_Elaboration 1181 (N : Node_Id; 1182 Unit_Id : Entity_Id; 1183 Prag_Nam : Name_Id; 1184 State : Processing_Attributes); 1185 -- Guarantee the elaboration of unit Unit_Id with respect to the main unit 1186 -- by installing pragma Elaborate or Elaborate_All denoted by Prag_Nam. N 1187 -- denotes the related scenario. State denotes the current state of the 1188 -- Processing phase. 1189 1190 procedure Ensure_Prior_Elaboration_Dynamic 1191 (N : Node_Id; 1192 Unit_Id : Entity_Id; 1193 Prag_Nam : Name_Id); 1194 -- Guarantee the elaboration of unit Unit_Id with respect to the main unit 1195 -- by suggesting the use of Elaborate[_All] with name Prag_Nam. N denotes 1196 -- the related scenario. 1197 1198 procedure Ensure_Prior_Elaboration_Static 1199 (N : Node_Id; 1200 Unit_Id : Entity_Id; 1201 Prag_Nam : Name_Id); 1202 -- Guarantee the elaboration of unit Unit_Id with respect to the main unit 1203 -- by installing an implicit Elaborate[_All] pragma with name Prag_Nam. N 1204 -- denotes the related scenario. 1205 1206 function Extract_Assignment_Name (Asmt : Node_Id) return Node_Id; 1207 pragma Inline (Extract_Assignment_Name); 1208 -- Obtain the Name attribute of assignment statement Asmt 1209 1210 procedure Extract_Call_Attributes 1211 (Call : Node_Id; 1212 Target_Id : out Entity_Id; 1213 Attrs : out Call_Attributes); 1214 pragma Inline (Extract_Call_Attributes); 1215 -- Obtain attributes Attrs associated with call Call. Target_Id is the 1216 -- entity of the call target. 1217 1218 function Extract_Call_Name (Call : Node_Id) return Node_Id; 1219 pragma Inline (Extract_Call_Name); 1220 -- Obtain the Name attribute of entry or subprogram call Call 1221 1222 procedure Extract_Instance_Attributes 1223 (Exp_Inst : Node_Id; 1224 Inst_Body : out Node_Id; 1225 Inst_Decl : out Node_Id); 1226 pragma Inline (Extract_Instance_Attributes); 1227 -- Obtain body Inst_Body and spec Inst_Decl of expanded instance Exp_Inst 1228 1229 procedure Extract_Instantiation_Attributes 1230 (Exp_Inst : Node_Id; 1231 Inst : out Node_Id; 1232 Inst_Id : out Entity_Id; 1233 Gen_Id : out Entity_Id; 1234 Attrs : out Instantiation_Attributes); 1235 pragma Inline (Extract_Instantiation_Attributes); 1236 -- Obtain attributes Attrs associated with expanded instantiation Exp_Inst. 1237 -- Inst is the instantiation. Inst_Id is the entity of the instance. Gen_Id 1238 -- is the entity of the generic unit being instantiated. 1239 1240 procedure Extract_Target_Attributes 1241 (Target_Id : Entity_Id; 1242 Attrs : out Target_Attributes); 1243 -- Obtain attributes Attrs associated with an entry, package, or subprogram 1244 -- denoted by Target_Id. 1245 1246 procedure Extract_Task_Attributes 1247 (Typ : Entity_Id; 1248 Attrs : out Task_Attributes); 1249 pragma Inline (Extract_Task_Attributes); 1250 -- Obtain attributes Attrs associated with task type Typ 1251 1252 procedure Extract_Variable_Reference_Attributes 1253 (Ref : Node_Id; 1254 Var_Id : out Entity_Id; 1255 Attrs : out Variable_Attributes); 1256 pragma Inline (Extract_Variable_Reference_Attributes); 1257 -- Obtain attributes Attrs associated with reference Ref that mentions 1258 -- variable Var_Id. 1259 1260 function Find_Code_Unit (N : Node_Or_Entity_Id) return Entity_Id; 1261 pragma Inline (Find_Code_Unit); 1262 -- Return the code unit which contains arbitrary node or entity N. This 1263 -- is the unit of the file which physically contains the related construct 1264 -- denoted by N except when N is within an instantiation. In that case the 1265 -- unit is that of the top-level instantiation. 1266 1267 function Find_Early_Call_Region 1268 (Body_Decl : Node_Id; 1269 Assume_Elab_Body : Boolean := False; 1270 Skip_Memoization : Boolean := False) return Node_Id; 1271 -- Find the start of the early call region which belongs to subprogram body 1272 -- Body_Decl as defined in SPARK RM 7.7. The behavior of the routine is to 1273 -- find the early call region, memoize it, and return it, but this behavior 1274 -- can be altered. Flag Assume_Elab_Body should be set when a package spec 1275 -- may lack pragma Elaborate_Body, but the routine must still examine that 1276 -- spec. Flag Skip_Memoization should be set when the routine must avoid 1277 -- memoizing the region. 1278 1279 procedure Find_Elaborated_Units; 1280 -- Populate table Elaboration_Statuses with all units which have prior 1281 -- elaboration with respect to the main unit. 1282 1283 function Find_Enclosing_Instance (N : Node_Id) return Node_Id; 1284 pragma Inline (Find_Enclosing_Instance); 1285 -- Find the declaration or body of the nearest expanded instance which 1286 -- encloses arbitrary node N. Return Empty if no such instance exists. 1287 1288 function Find_Top_Unit (N : Node_Or_Entity_Id) return Entity_Id; 1289 pragma Inline (Find_Top_Unit); 1290 -- Return the top unit which contains arbitrary node or entity N. The unit 1291 -- is obtained by logically unwinding instantiations and subunits when N 1292 -- resides within one. 1293 1294 function Find_Unit_Entity (N : Node_Id) return Entity_Id; 1295 pragma Inline (Find_Unit_Entity); 1296 -- Return the entity of unit N 1297 1298 function First_Formal_Type (Subp_Id : Entity_Id) return Entity_Id; 1299 pragma Inline (First_Formal_Type); 1300 -- Return the type of subprogram Subp_Id's first formal parameter. If the 1301 -- subprogram lacks formal parameters, return Empty. 1302 1303 function Has_Body (Pack_Decl : Node_Id) return Boolean; 1304 -- Determine whether package declaration Pack_Decl has a corresponding body 1305 -- or would eventually have one. 1306 1307 function Has_Prior_Elaboration 1308 (Unit_Id : Entity_Id; 1309 Context_OK : Boolean := False; 1310 Elab_Body_OK : Boolean := False; 1311 Same_Unit_OK : Boolean := False) return Boolean; 1312 pragma Inline (Has_Prior_Elaboration); 1313 -- Determine whether unit Unit_Id is elaborated prior to the main unit. 1314 -- If flag Context_OK is set, the routine considers the following case 1315 -- as valid prior elaboration: 1316 -- 1317 -- * Unit_Id is in the elaboration context of the main unit 1318 -- 1319 -- If flag Elab_Body_OK is set, the routine considers the following case 1320 -- as valid prior elaboration: 1321 -- 1322 -- * Unit_Id has pragma Elaborate_Body and is not the main unit 1323 -- 1324 -- If flag Same_Unit_OK is set, the routine considers the following cases 1325 -- as valid prior elaboration: 1326 -- 1327 -- * Unit_Id is the main unit 1328 -- 1329 -- * Unit_Id denotes the spec of the main unit body 1330 1331 function In_External_Instance 1332 (N : Node_Id; 1333 Target_Decl : Node_Id) return Boolean; 1334 pragma Inline (In_External_Instance); 1335 -- Determine whether a target desctibed by its declaration Target_Decl 1336 -- resides in a package instance which is external to scenario N. 1337 1338 function In_Main_Context (N : Node_Id) return Boolean; 1339 pragma Inline (In_Main_Context); 1340 -- Determine whether arbitrary node N appears within the main compilation 1341 -- unit. 1342 1343 function In_Same_Context 1344 (N1 : Node_Id; 1345 N2 : Node_Id; 1346 Nested_OK : Boolean := False) return Boolean; 1347 -- Determine whether two arbitrary nodes N1 and N2 appear within the same 1348 -- context ignoring enclosing library levels. Nested_OK should be set when 1349 -- the context of N1 can enclose that of N2. 1350 1351 function In_Task_Body (N : Node_Id) return Boolean; 1352 pragma Inline (In_Task_Body); 1353 -- Determine whether arbitrary node N appears within a task body 1354 1355 procedure Info_Call 1356 (Call : Node_Id; 1357 Target_Id : Entity_Id; 1358 Info_Msg : Boolean; 1359 In_SPARK : Boolean); 1360 -- Output information concerning call Call which invokes target Target_Id. 1361 -- If flag Info_Msg is set, the routine emits an information message, 1362 -- otherwise it emits an error. If flag In_SPARK is set, then the string 1363 -- " in SPARK" is added to the end of the message. 1364 1365 procedure Info_Instantiation 1366 (Inst : Node_Id; 1367 Gen_Id : Entity_Id; 1368 Info_Msg : Boolean; 1369 In_SPARK : Boolean); 1370 pragma Inline (Info_Instantiation); 1371 -- Output information concerning instantiation Inst which instantiates 1372 -- generic unit Gen_Id. If flag Info_Msg is set, the routine emits an 1373 -- information message, otherwise it emits an error. If flag In_SPARK 1374 -- is set, then string " in SPARK" is added to the end of the message. 1375 1376 procedure Info_Variable_Reference 1377 (Ref : Node_Id; 1378 Var_Id : Entity_Id; 1379 Info_Msg : Boolean; 1380 In_SPARK : Boolean); 1381 pragma Inline (Info_Variable_Reference); 1382 -- Output information concerning reference Ref which mentions variable 1383 -- Var_Id. If flag Info_Msg is set, the routine emits an information 1384 -- message, otherwise it emits an error. If flag In_SPARK is set, then 1385 -- string " in SPARK" is added to the end of the message. 1386 1387 function Insertion_Node (N : Node_Id; Ins_Nod : Node_Id) return Node_Id; 1388 pragma Inline (Insertion_Node); 1389 -- Obtain the proper insertion node of an ABE check or failure for scenario 1390 -- N and candidate insertion node Ins_Nod. 1391 1392 procedure Install_ABE_Check 1393 (N : Node_Id; 1394 Id : Entity_Id; 1395 Ins_Nod : Node_Id); 1396 -- Insert a run-time ABE check for elaboration scenario N which verifies 1397 -- whether arbitrary entity Id is elaborated. The check in inserted prior 1398 -- to node Ins_Nod. 1399 1400 procedure Install_ABE_Check 1401 (N : Node_Id; 1402 Target_Id : Entity_Id; 1403 Target_Decl : Node_Id; 1404 Target_Body : Node_Id; 1405 Ins_Nod : Node_Id); 1406 -- Insert a run-time ABE check for elaboration scenario N which verifies 1407 -- whether target Target_Id with initial declaration Target_Decl and body 1408 -- Target_Body is elaborated. The check is inserted prior to node Ins_Nod. 1409 1410 procedure Install_ABE_Failure (N : Node_Id; Ins_Nod : Node_Id); 1411 -- Insert a Program_Error concerning a guaranteed ABE for elaboration 1412 -- scenario N. The failure is inserted prior to node Node_Id. 1413 1414 function Is_Accept_Alternative_Proc (Id : Entity_Id) return Boolean; 1415 pragma Inline (Is_Accept_Alternative_Proc); 1416 -- Determine whether arbitrary entity Id denotes an internally generated 1417 -- procedure which encapsulates the statements of an accept alternative. 1418 1419 function Is_Activation_Proc (Id : Entity_Id) return Boolean; 1420 pragma Inline (Is_Activation_Proc); 1421 -- Determine whether arbitrary entity Id denotes a runtime procedure in 1422 -- charge with activating tasks. 1423 1424 function Is_Ada_Semantic_Target (Id : Entity_Id) return Boolean; 1425 pragma Inline (Is_Ada_Semantic_Target); 1426 -- Determine whether arbitrary entity Id denodes a source or internally 1427 -- generated subprogram which emulates Ada semantics. 1428 1429 function Is_Assertion_Pragma_Target (Id : Entity_Id) return Boolean; 1430 pragma Inline (Is_Assertion_Pragma_Target); 1431 -- Determine whether arbitrary entity Id denotes a procedure which varifies 1432 -- the run-time semantics of an assertion pragma. 1433 1434 function Is_Bodiless_Subprogram (Subp_Id : Entity_Id) return Boolean; 1435 pragma Inline (Is_Bodiless_Subprogram); 1436 -- Determine whether subprogram Subp_Id will never have a body 1437 1438 function Is_Controlled_Proc 1439 (Subp_Id : Entity_Id; 1440 Subp_Nam : Name_Id) return Boolean; 1441 pragma Inline (Is_Controlled_Proc); 1442 -- Determine whether subprogram Subp_Id denotes controlled type primitives 1443 -- Adjust, Finalize, or Initialize as denoted by name Subp_Nam. 1444 1445 function Is_Default_Initial_Condition_Proc (Id : Entity_Id) return Boolean; 1446 pragma Inline (Is_Default_Initial_Condition_Proc); 1447 -- Determine whether arbitrary entity Id denotes internally generated 1448 -- routine Default_Initial_Condition. 1449 1450 function Is_Finalizer_Proc (Id : Entity_Id) return Boolean; 1451 pragma Inline (Is_Finalizer_Proc); 1452 -- Determine whether arbitrary entity Id denotes internally generated 1453 -- routine _Finalizer. 1454 1455 function Is_Guaranteed_ABE 1456 (N : Node_Id; 1457 Target_Decl : Node_Id; 1458 Target_Body : Node_Id) return Boolean; 1459 pragma Inline (Is_Guaranteed_ABE); 1460 -- Determine whether scenario N with a target described by its initial 1461 -- declaration Target_Decl and body Target_Decl results in a guaranteed 1462 -- ABE. 1463 1464 function Is_Initial_Condition_Proc (Id : Entity_Id) return Boolean; 1465 pragma Inline (Is_Initial_Condition_Proc); 1466 -- Determine whether arbitrary entity Id denotes internally generated 1467 -- routine Initial_Condition. 1468 1469 function Is_Initialized (Obj_Decl : Node_Id) return Boolean; 1470 pragma Inline (Is_Initialized); 1471 -- Determine whether object declaration Obj_Decl is initialized 1472 1473 function Is_Invariant_Proc (Id : Entity_Id) return Boolean; 1474 pragma Inline (Is_Invariant_Proc); 1475 -- Determine whether arbitrary entity Id denotes an invariant procedure 1476 1477 function Is_Non_Library_Level_Encapsulator (N : Node_Id) return Boolean; 1478 pragma Inline (Is_Non_Library_Level_Encapsulator); 1479 -- Determine whether arbitrary node N is a non-library encapsulator 1480 1481 function Is_Partial_Invariant_Proc (Id : Entity_Id) return Boolean; 1482 pragma Inline (Is_Partial_Invariant_Proc); 1483 -- Determine whether arbitrary entity Id denotes a partial invariant 1484 -- procedure. 1485 1486 function Is_Postconditions_Proc (Id : Entity_Id) return Boolean; 1487 pragma Inline (Is_Postconditions_Proc); 1488 -- Determine whether arbitrary entity Id denotes internally generated 1489 -- routine _Postconditions. 1490 1491 function Is_Preelaborated_Unit (Id : Entity_Id) return Boolean; 1492 pragma Inline (Is_Preelaborated_Unit); 1493 -- Determine whether arbitrary entity Id denotes a unit which is subject to 1494 -- one of the following pragmas: 1495 -- 1496 -- * Preelaborable 1497 -- * Pure 1498 -- * Remote_Call_Interface 1499 -- * Remote_Types 1500 -- * Shared_Passive 1501 1502 function Is_Protected_Entry (Id : Entity_Id) return Boolean; 1503 pragma Inline (Is_Protected_Entry); 1504 -- Determine whether arbitrary entity Id denotes a protected entry 1505 1506 function Is_Protected_Subp (Id : Entity_Id) return Boolean; 1507 pragma Inline (Is_Protected_Subp); 1508 -- Determine whether entity Id denotes a protected subprogram 1509 1510 function Is_Protected_Body_Subp (Id : Entity_Id) return Boolean; 1511 pragma Inline (Is_Protected_Body_Subp); 1512 -- Determine whether entity Id denotes the protected or unprotected version 1513 -- of a protected subprogram. 1514 1515 function Is_Recorded_SPARK_Scenario (N : Node_Id) return Boolean; 1516 pragma Inline (Is_Recorded_SPARK_Scenario); 1517 -- Determine whether arbitrary node N is a recorded SPARK scenario which 1518 -- appears in table SPARK_Scenarios. 1519 1520 function Is_Recorded_Top_Level_Scenario (N : Node_Id) return Boolean; 1521 pragma Inline (Is_Recorded_Top_Level_Scenario); 1522 -- Determine whether arbitrary node N is a recorded top-level scenario 1523 -- which appears in table Top_Level_Scenarios. 1524 1525 function Is_Safe_Activation 1526 (Call : Node_Id; 1527 Task_Decl : Node_Id) return Boolean; 1528 pragma Inline (Is_Safe_Activation); 1529 -- Determine whether call Call which activates a task object described by 1530 -- declaration Task_Decl is always ABE-safe. 1531 1532 function Is_Safe_Call 1533 (Call : Node_Id; 1534 Target_Attrs : Target_Attributes) return Boolean; 1535 pragma Inline (Is_Safe_Call); 1536 -- Determine whether call Call which invokes a target described by 1537 -- attributes Target_Attrs is always ABE-safe. 1538 1539 function Is_Safe_Instantiation 1540 (Inst : Node_Id; 1541 Gen_Attrs : Target_Attributes) return Boolean; 1542 pragma Inline (Is_Safe_Instantiation); 1543 -- Determine whether instance Inst which instantiates a generic unit 1544 -- described by attributes Gen_Attrs is always ABE-safe. 1545 1546 function Is_Same_Unit 1547 (Unit_1 : Entity_Id; 1548 Unit_2 : Entity_Id) return Boolean; 1549 pragma Inline (Is_Same_Unit); 1550 -- Determine whether entities Unit_1 and Unit_2 denote the same unit 1551 1552 function Is_Scenario (N : Node_Id) return Boolean; 1553 pragma Inline (Is_Scenario); 1554 -- Determine whether attribute node N denotes a scenario. The scenario may 1555 -- not necessarily be eligible for ABE processing. 1556 1557 function Is_SPARK_Semantic_Target (Id : Entity_Id) return Boolean; 1558 pragma Inline (Is_SPARK_Semantic_Target); 1559 -- Determine whether arbitrary entity Id nodes a source or internally 1560 -- generated subprogram which emulates SPARK semantics. 1561 1562 function Is_Suitable_Access (N : Node_Id) return Boolean; 1563 pragma Inline (Is_Suitable_Access); 1564 -- Determine whether arbitrary node N denotes a suitable attribute for ABE 1565 -- processing. 1566 1567 function Is_Suitable_Call (N : Node_Id) return Boolean; 1568 pragma Inline (Is_Suitable_Call); 1569 -- Determine whether arbitrary node N denotes a suitable call for ABE 1570 -- processing. 1571 1572 function Is_Suitable_Instantiation (N : Node_Id) return Boolean; 1573 pragma Inline (Is_Suitable_Instantiation); 1574 -- Determine whether arbitrary node N is a suitable instantiation for ABE 1575 -- processing. 1576 1577 function Is_Suitable_Scenario (N : Node_Id) return Boolean; 1578 pragma Inline (Is_Suitable_Scenario); 1579 -- Determine whether arbitrary node N is a suitable scenario for ABE 1580 -- processing. 1581 1582 function Is_Suitable_SPARK_Derived_Type (N : Node_Id) return Boolean; 1583 pragma Inline (Is_Suitable_SPARK_Derived_Type); 1584 -- Determine whether arbitrary node N denotes a suitable derived type 1585 -- declaration for ABE processing using the SPARK rules. 1586 1587 function Is_Suitable_SPARK_Instantiation (N : Node_Id) return Boolean; 1588 pragma Inline (Is_Suitable_SPARK_Instantiation); 1589 -- Determine whether arbitrary node N denotes a suitable instantiation for 1590 -- ABE processing using the SPARK rules. 1591 1592 function Is_Suitable_SPARK_Refined_State_Pragma 1593 (N : Node_Id) return Boolean; 1594 pragma Inline (Is_Suitable_SPARK_Refined_State_Pragma); 1595 -- Determine whether arbitrary node N denotes a suitable Refined_State 1596 -- pragma for ABE processing using the SPARK rules. 1597 1598 function Is_Suitable_Variable_Assignment (N : Node_Id) return Boolean; 1599 pragma Inline (Is_Suitable_Variable_Assignment); 1600 -- Determine whether arbitrary node N denotes a suitable assignment for ABE 1601 -- processing. 1602 1603 function Is_Suitable_Variable_Reference (N : Node_Id) return Boolean; 1604 pragma Inline (Is_Suitable_Variable_Reference); 1605 -- Determine whether arbitrary node N is a suitable variable reference for 1606 -- ABE processing. 1607 1608 function Is_Synchronous_Suspension_Call (N : Node_Id) return Boolean; 1609 pragma Inline (Is_Synchronous_Suspension_Call); 1610 -- Determine whether arbitrary node N denotes a call to one the following 1611 -- routines: 1612 -- 1613 -- Ada.Synchronous_Barriers.Wait_For_Release 1614 -- Ada.Synchronous_Task_Control.Suspend_Until_True 1615 1616 function Is_Task_Entry (Id : Entity_Id) return Boolean; 1617 pragma Inline (Is_Task_Entry); 1618 -- Determine whether arbitrary entity Id denotes a task entry 1619 1620 function Is_Up_Level_Target (Target_Decl : Node_Id) return Boolean; 1621 pragma Inline (Is_Up_Level_Target); 1622 -- Determine whether the current root resides at the declaration level. If 1623 -- this is the case, determine whether a target described by declaration 1624 -- Target_Decl is within a context which encloses the current root or is in 1625 -- a different unit. 1626 1627 function Is_Visited_Body (Body_Decl : Node_Id) return Boolean; 1628 pragma Inline (Is_Visited_Body); 1629 -- Determine whether subprogram body Body_Decl is already visited during a 1630 -- recursive traversal started from a top-level scenario. 1631 1632 procedure Meet_Elaboration_Requirement 1633 (N : Node_Id; 1634 Target_Id : Entity_Id; 1635 Req_Nam : Name_Id); 1636 -- Determine whether elaboration requirement Req_Nam for scenario N with 1637 -- target Target_Id is met by the context of the main unit using the SPARK 1638 -- rules. Req_Nam must denote either Elaborate or Elaborate_All. Emit an 1639 -- error if this is not the case. 1640 1641 function Non_Private_View (Typ : Entity_Id) return Entity_Id; 1642 pragma Inline (Non_Private_View); 1643 -- Return the full view of private type Typ if available, otherwise return 1644 -- type Typ. 1645 1646 procedure Output_Active_Scenarios (Error_Nod : Node_Id); 1647 -- Output the contents of the active scenario stack from earliest to latest 1648 -- to supplement an earlier error emitted for node Error_Nod. 1649 1650 procedure Pop_Active_Scenario (N : Node_Id); 1651 pragma Inline (Pop_Active_Scenario); 1652 -- Pop the top of the scenario stack. A check is made to ensure that the 1653 -- scenario being removed is the same as N. 1654 1655 generic 1656 with procedure Process_Single_Activation 1657 (Call : Node_Id; 1658 Call_Attrs : Call_Attributes; 1659 Obj_Id : Entity_Id; 1660 Task_Attrs : Task_Attributes; 1661 State : Processing_Attributes); 1662 -- Perform ABE checks and diagnostics for task activation call Call 1663 -- which activates task Obj_Id. Call_Attrs are the attributes of the 1664 -- activation call. Task_Attrs are the attributes of the task type. 1665 -- State is the current state of the Processing phase. 1666 1667 procedure Process_Activation_Generic 1668 (Call : Node_Id; 1669 Call_Attrs : Call_Attributes; 1670 State : Processing_Attributes); 1671 -- Perform ABE checks and diagnostics for activation call Call by invoking 1672 -- routine Process_Single_Activation on each task object being activated. 1673 -- Call_Attrs are the attributes of the activation call. State is the 1674 -- current state of the Processing phase. 1675 1676 procedure Process_Conditional_ABE 1677 (N : Node_Id; 1678 State : Processing_Attributes := Initial_State); 1679 -- Top-level dispatcher for processing of various elaboration scenarios. 1680 -- Perform conditional ABE checks and diagnostics for scenario N. State 1681 -- is the current state of the Processing phase. 1682 1683 procedure Process_Conditional_ABE_Access 1684 (Attr : Node_Id; 1685 State : Processing_Attributes); 1686 -- Perform ABE checks and diagnostics for 'Access to entry, operator, or 1687 -- subprogram denoted by Attr. State is the current state of the Processing 1688 -- phase. 1689 1690 procedure Process_Conditional_ABE_Activation_Impl 1691 (Call : Node_Id; 1692 Call_Attrs : Call_Attributes; 1693 Obj_Id : Entity_Id; 1694 Task_Attrs : Task_Attributes; 1695 State : Processing_Attributes); 1696 -- Perform common conditional ABE checks and diagnostics for call Call 1697 -- which activates task Obj_Id ignoring the Ada or SPARK rules. Call_Attrs 1698 -- are the attributes of the activation call. Task_Attrs are the attributes 1699 -- of the task type. State is the current state of the Processing phase. 1700 1701 procedure Process_Conditional_ABE_Call 1702 (Call : Node_Id; 1703 Call_Attrs : Call_Attributes; 1704 Target_Id : Entity_Id; 1705 State : Processing_Attributes); 1706 -- Top-level dispatcher for processing of calls. Perform ABE checks and 1707 -- diagnostics for call Call which invokes target Target_Id. Call_Attrs 1708 -- are the attributes of the call. State is the current state of the 1709 -- Processing phase. 1710 1711 procedure Process_Conditional_ABE_Call_Ada 1712 (Call : Node_Id; 1713 Call_Attrs : Call_Attributes; 1714 Target_Id : Entity_Id; 1715 Target_Attrs : Target_Attributes; 1716 State : Processing_Attributes); 1717 -- Perform ABE checks and diagnostics for call Call which invokes target 1718 -- Target_Id using the Ada rules. Call_Attrs are the attributes of the 1719 -- call. Target_Attrs are attributes of the target. State is the current 1720 -- state of the Processing phase. 1721 1722 procedure Process_Conditional_ABE_Call_SPARK 1723 (Call : Node_Id; 1724 Target_Id : Entity_Id; 1725 Target_Attrs : Target_Attributes; 1726 State : Processing_Attributes); 1727 -- Perform ABE checks and diagnostics for call Call which invokes target 1728 -- Target_Id using the SPARK rules. Target_Attrs denotes the attributes of 1729 -- the target. State is the current state of the Processing phase. 1730 1731 procedure Process_Conditional_ABE_Instantiation 1732 (Exp_Inst : Node_Id; 1733 State : Processing_Attributes); 1734 -- Top-level dispatcher for processing of instantiations. Perform ABE 1735 -- checks and diagnostics for expanded instantiation Exp_Inst. State is 1736 -- the current state of the Processing phase. 1737 1738 procedure Process_Conditional_ABE_Instantiation_Ada 1739 (Exp_Inst : Node_Id; 1740 Inst : Node_Id; 1741 Inst_Attrs : Instantiation_Attributes; 1742 Gen_Id : Entity_Id; 1743 Gen_Attrs : Target_Attributes; 1744 State : Processing_Attributes); 1745 -- Perform ABE checks and diagnostics for expanded instantiation Exp_Inst 1746 -- of generic Gen_Id using the Ada rules. Inst is the instantiation node. 1747 -- Inst_Attrs are the attributes of the instance. Gen_Attrs denotes the 1748 -- attributes of the generic. State is the current state of the Processing 1749 -- phase. 1750 1751 procedure Process_Conditional_ABE_Instantiation_SPARK 1752 (Inst : Node_Id; 1753 Gen_Id : Entity_Id; 1754 Gen_Attrs : Target_Attributes; 1755 State : Processing_Attributes); 1756 -- Perform ABE checks and diagnostics for instantiation Inst of generic 1757 -- Gen_Id using the SPARK rules. Gen_Attrs denotes the attributes of the 1758 -- generic. State is the current state of the Processing phase. 1759 1760 procedure Process_Conditional_ABE_Variable_Assignment (Asmt : Node_Id); 1761 -- Top-level dispatcher for processing of variable assignments. Perform ABE 1762 -- checks and diagnostics for assignment statement Asmt. 1763 1764 procedure Process_Conditional_ABE_Variable_Assignment_Ada 1765 (Asmt : Node_Id; 1766 Var_Id : Entity_Id); 1767 -- Perform ABE checks and diagnostics for assignment statement Asmt that 1768 -- updates the value of variable Var_Id using the Ada rules. 1769 1770 procedure Process_Conditional_ABE_Variable_Assignment_SPARK 1771 (Asmt : Node_Id; 1772 Var_Id : Entity_Id); 1773 -- Perform ABE checks and diagnostics for assignment statement Asmt that 1774 -- updates the value of variable Var_Id using the SPARK rules. 1775 1776 procedure Process_Conditional_ABE_Variable_Reference (Ref : Node_Id); 1777 -- Top-level dispatcher for processing of variable references. Perform ABE 1778 -- checks and diagnostics for variable reference Ref. 1779 1780 procedure Process_Conditional_ABE_Variable_Reference_Read 1781 (Ref : Node_Id; 1782 Var_Id : Entity_Id; 1783 Attrs : Variable_Attributes); 1784 -- Perform ABE checks and diagnostics for reference Ref described by its 1785 -- attributes Attrs, that reads variable Var_Id. 1786 1787 procedure Process_Guaranteed_ABE (N : Node_Id); 1788 -- Top-level dispatcher for processing of scenarios which result in a 1789 -- guaranteed ABE. 1790 1791 procedure Process_Guaranteed_ABE_Activation_Impl 1792 (Call : Node_Id; 1793 Call_Attrs : Call_Attributes; 1794 Obj_Id : Entity_Id; 1795 Task_Attrs : Task_Attributes; 1796 State : Processing_Attributes); 1797 -- Perform common guaranteed ABE checks and diagnostics for call Call which 1798 -- activates task Obj_Id ignoring the Ada or SPARK rules. Call_Attrs are 1799 -- the attributes of the activation call. Task_Attrs are the attributes of 1800 -- the task type. State is provided for compatibility and is not used. 1801 1802 procedure Process_Guaranteed_ABE_Call 1803 (Call : Node_Id; 1804 Call_Attrs : Call_Attributes; 1805 Target_Id : Entity_Id); 1806 -- Perform common guaranteed ABE checks and diagnostics for call Call which 1807 -- invokes target Target_Id ignoring the Ada or SPARK rules. Call_Attrs are 1808 -- the attributes of the call. 1809 1810 procedure Process_Guaranteed_ABE_Instantiation (Exp_Inst : Node_Id); 1811 -- Perform common guaranteed ABE checks and diagnostics for expanded 1812 -- instantiation Exp_Inst of generic Gen_Id ignoring the Ada or SPARK 1813 -- rules. 1814 1815 procedure Push_Active_Scenario (N : Node_Id); 1816 pragma Inline (Push_Active_Scenario); 1817 -- Push scenario N on top of the scenario stack 1818 1819 procedure Record_SPARK_Elaboration_Scenario (N : Node_Id); 1820 pragma Inline (Record_SPARK_Elaboration_Scenario); 1821 -- Save SPARK scenario N in table SPARK_Scenarios for later processing 1822 1823 procedure Reset_Visited_Bodies; 1824 pragma Inline (Reset_Visited_Bodies); 1825 -- Clear the contents of table Visited_Bodies 1826 1827 function Root_Scenario return Node_Id; 1828 pragma Inline (Root_Scenario); 1829 -- Return the top-level scenario which started a recursive search for other 1830 -- scenarios. It is assumed that there is a valid top-level scenario on the 1831 -- active scenario stack. 1832 1833 procedure Set_Early_Call_Region (Body_Id : Entity_Id; Start : Node_Id); 1834 pragma Inline (Set_Early_Call_Region); 1835 -- Associate an early call region with begins at construct Start with entry 1836 -- or subprogram body Body_Id. 1837 1838 procedure Set_Elaboration_Status 1839 (Unit_Id : Entity_Id; 1840 Val : Elaboration_Attributes); 1841 pragma Inline (Set_Elaboration_Status); 1842 -- Associate an set of elaboration attributes with unit Unit_Id 1843 1844 procedure Set_Is_Recorded_SPARK_Scenario 1845 (N : Node_Id; 1846 Val : Boolean := True); 1847 pragma Inline (Set_Is_Recorded_SPARK_Scenario); 1848 -- Mark scenario N as being recorded in table SPARK_Scenarios 1849 1850 procedure Set_Is_Recorded_Top_Level_Scenario 1851 (N : Node_Id; 1852 Val : Boolean := True); 1853 pragma Inline (Set_Is_Recorded_Top_Level_Scenario); 1854 -- Mark scenario N as being recorded in table Top_Level_Scenarios 1855 1856 procedure Set_Is_Visited_Body (Subp_Body : Node_Id); 1857 pragma Inline (Set_Is_Visited_Body); 1858 -- Mark subprogram body Subp_Body as being visited during a recursive 1859 -- traversal started from a top-level scenario. 1860 1861 function Static_Elaboration_Checks return Boolean; 1862 pragma Inline (Static_Elaboration_Checks); 1863 -- Determine whether the static model is in effect 1864 1865 procedure Traverse_Body (N : Node_Id; State : Processing_Attributes); 1866 -- Inspect the declarative and statement lists of subprogram body N for 1867 -- suitable elaboration scenarios and process them. State is the current 1868 -- state of the Processing phase. 1869 1870 function Unit_Entity (Unit_Id : Entity_Id) return Entity_Id; 1871 pragma Inline (Unit_Entity); 1872 -- Return the entity of the initial declaration for unit Unit_Id 1873 1874 procedure Update_Elaboration_Scenario (New_N : Node_Id; Old_N : Node_Id); 1875 pragma Inline (Update_Elaboration_Scenario); 1876 -- Update all relevant internal data structures when scenario Old_N is 1877 -- transformed into scenario New_N by Atree.Rewrite. 1878 1879 ----------------------- 1880 -- Build_Call_Marker -- 1881 ----------------------- 1882 1883 procedure Build_Call_Marker (N : Node_Id) is 1884 function In_External_Context 1885 (Call : Node_Id; 1886 Target_Attrs : Target_Attributes) return Boolean; 1887 pragma Inline (In_External_Context); 1888 -- Determine whether a target described by attributes Target_Attrs is 1889 -- external to call Call which must reside within an instance. 1890 1891 function In_Premature_Context (Call : Node_Id) return Boolean; 1892 -- Determine whether call Call appears within a premature context 1893 1894 function Is_Bridge_Target (Id : Entity_Id) return Boolean; 1895 pragma Inline (Is_Bridge_Target); 1896 -- Determine whether arbitrary entity Id denotes a bridge target 1897 1898 function Is_Default_Expression (Call : Node_Id) return Boolean; 1899 pragma Inline (Is_Default_Expression); 1900 -- Determine whether call Call acts as the expression of a defaulted 1901 -- parameter within a source call. 1902 1903 function Is_Generic_Formal_Subp (Subp_Id : Entity_Id) return Boolean; 1904 pragma Inline (Is_Generic_Formal_Subp); 1905 -- Determine whether subprogram Subp_Id denotes a generic formal 1906 -- subprogram which appears in the "prologue" of an instantiation. 1907 1908 ------------------------- 1909 -- In_External_Context -- 1910 ------------------------- 1911 1912 function In_External_Context 1913 (Call : Node_Id; 1914 Target_Attrs : Target_Attributes) return Boolean 1915 is 1916 Inst : Node_Id; 1917 Inst_Body : Node_Id; 1918 Inst_Decl : Node_Id; 1919 1920 begin 1921 -- Performance note: parent traversal 1922 1923 Inst := Find_Enclosing_Instance (Call); 1924 1925 -- The call appears within an instance 1926 1927 if Present (Inst) then 1928 1929 -- The call comes from the main unit and the target does not 1930 1931 if In_Extended_Main_Code_Unit (Call) 1932 and then not In_Extended_Main_Code_Unit (Target_Attrs.Spec_Decl) 1933 then 1934 return True; 1935 1936 -- Otherwise the target declaration must not appear within the 1937 -- instance spec or body. 1938 1939 else 1940 Extract_Instance_Attributes 1941 (Exp_Inst => Inst, 1942 Inst_Decl => Inst_Decl, 1943 Inst_Body => Inst_Body); 1944 1945 -- Performance note: parent traversal 1946 1947 return not In_Subtree 1948 (N => Target_Attrs.Spec_Decl, 1949 Root1 => Inst_Decl, 1950 Root2 => Inst_Body); 1951 end if; 1952 end if; 1953 1954 return False; 1955 end In_External_Context; 1956 1957 -------------------------- 1958 -- In_Premature_Context -- 1959 -------------------------- 1960 1961 function In_Premature_Context (Call : Node_Id) return Boolean is 1962 Par : Node_Id; 1963 1964 begin 1965 -- Climb the parent chain looking for premature contexts 1966 1967 Par := Parent (Call); 1968 while Present (Par) loop 1969 1970 -- Aspect specifications and generic associations are premature 1971 -- contexts because nested calls has not been relocated to their 1972 -- final context. 1973 1974 if Nkind_In (Par, N_Aspect_Specification, 1975 N_Generic_Association) 1976 then 1977 return True; 1978 1979 -- Prevent the search from going too far 1980 1981 elsif Is_Body_Or_Package_Declaration (Par) then 1982 exit; 1983 end if; 1984 1985 Par := Parent (Par); 1986 end loop; 1987 1988 return False; 1989 end In_Premature_Context; 1990 1991 ---------------------- 1992 -- Is_Bridge_Target -- 1993 ---------------------- 1994 1995 function Is_Bridge_Target (Id : Entity_Id) return Boolean is 1996 begin 1997 return 1998 Is_Accept_Alternative_Proc (Id) 1999 or else Is_Finalizer_Proc (Id) 2000 or else Is_Partial_Invariant_Proc (Id) 2001 or else Is_Postconditions_Proc (Id) 2002 or else Is_TSS (Id, TSS_Deep_Adjust) 2003 or else Is_TSS (Id, TSS_Deep_Finalize) 2004 or else Is_TSS (Id, TSS_Deep_Initialize); 2005 end Is_Bridge_Target; 2006 2007 --------------------------- 2008 -- Is_Default_Expression -- 2009 --------------------------- 2010 2011 function Is_Default_Expression (Call : Node_Id) return Boolean is 2012 Outer_Call : constant Node_Id := Parent (Call); 2013 Outer_Nam : Node_Id; 2014 2015 begin 2016 -- To qualify, the node must appear immediately within a source call 2017 -- which invokes a source target. 2018 2019 if Nkind_In (Outer_Call, N_Entry_Call_Statement, 2020 N_Function_Call, 2021 N_Procedure_Call_Statement) 2022 and then Comes_From_Source (Outer_Call) 2023 then 2024 Outer_Nam := Extract_Call_Name (Outer_Call); 2025 2026 return 2027 Is_Entity_Name (Outer_Nam) 2028 and then Present (Entity (Outer_Nam)) 2029 and then Is_Subprogram_Or_Entry (Entity (Outer_Nam)) 2030 and then Comes_From_Source (Entity (Outer_Nam)); 2031 end if; 2032 2033 return False; 2034 end Is_Default_Expression; 2035 2036 ---------------------------- 2037 -- Is_Generic_Formal_Subp -- 2038 ---------------------------- 2039 2040 function Is_Generic_Formal_Subp (Subp_Id : Entity_Id) return Boolean is 2041 Subp_Decl : constant Node_Id := Unit_Declaration_Node (Subp_Id); 2042 Context : constant Node_Id := Parent (Subp_Decl); 2043 2044 begin 2045 -- To qualify, the subprogram must rename a generic actual subprogram 2046 -- where the enclosing context is an instantiation. 2047 2048 return 2049 Nkind (Subp_Decl) = N_Subprogram_Renaming_Declaration 2050 and then not Comes_From_Source (Subp_Decl) 2051 and then Nkind_In (Context, N_Function_Specification, 2052 N_Package_Specification, 2053 N_Procedure_Specification) 2054 and then Present (Generic_Parent (Context)); 2055 end Is_Generic_Formal_Subp; 2056 2057 -- Local variables 2058 2059 Call_Attrs : Call_Attributes; 2060 Call_Nam : Node_Id; 2061 Marker : Node_Id; 2062 Target_Attrs : Target_Attributes; 2063 Target_Id : Entity_Id; 2064 2065 -- Start of processing for Build_Call_Marker 2066 2067 begin 2068 -- Nothing to do when switch -gnatH (legacy elaboration checking mode 2069 -- enabled) is in effect because the legacy ABE mechanism does not need 2070 -- to carry out this action. 2071 2072 if Legacy_Elaboration_Checks then 2073 return; 2074 2075 -- Nothing to do for ASIS because ABE checks and diagnostics are not 2076 -- performed in this mode. 2077 2078 elsif ASIS_Mode then 2079 return; 2080 2081 -- Nothing to do when the call is being preanalyzed as the marker will 2082 -- be inserted in the wrong place. 2083 2084 elsif Preanalysis_Active then 2085 return; 2086 2087 -- Nothing to do when the input does not denote a call or a requeue 2088 2089 elsif not Nkind_In (N, N_Entry_Call_Statement, 2090 N_Function_Call, 2091 N_Procedure_Call_Statement, 2092 N_Requeue_Statement) 2093 then 2094 return; 2095 2096 -- Nothing to do when the input denotes entry call or requeue statement, 2097 -- and switch -gnatd_e (ignore entry calls and requeue statements for 2098 -- elaboration) is in effect. 2099 2100 elsif Debug_Flag_Underscore_E 2101 and then Nkind_In (N, N_Entry_Call_Statement, N_Requeue_Statement) 2102 then 2103 return; 2104 end if; 2105 2106 Call_Nam := Extract_Call_Name (N); 2107 2108 -- Nothing to do when the call is erroneous or left in a bad state 2109 2110 if not (Is_Entity_Name (Call_Nam) 2111 and then Present (Entity (Call_Nam)) 2112 and then Is_Subprogram_Or_Entry (Entity (Call_Nam))) 2113 then 2114 return; 2115 2116 -- Nothing to do when the call invokes a generic formal subprogram and 2117 -- switch -gnatd.G (ignore calls through generic formal parameters for 2118 -- elaboration) is in effect. This check must be performed with the 2119 -- direct target of the call to avoid the side effects of mapping 2120 -- actuals to formals using renamings. 2121 2122 elsif Debug_Flag_Dot_GG 2123 and then Is_Generic_Formal_Subp (Entity (Call_Nam)) 2124 then 2125 return; 2126 2127 -- Nothing to do when the call is analyzed/resolved too early within an 2128 -- intermediate context. This check is saved for last because it incurs 2129 -- a performance penalty. 2130 2131 -- Performance note: parent traversal 2132 2133 elsif In_Premature_Context (N) then 2134 return; 2135 end if; 2136 2137 Extract_Call_Attributes 2138 (Call => N, 2139 Target_Id => Target_Id, 2140 Attrs => Call_Attrs); 2141 2142 Extract_Target_Attributes 2143 (Target_Id => Target_Id, 2144 Attrs => Target_Attrs); 2145 2146 -- Nothing to do when the call appears within the expanded spec or 2147 -- body of an instantiated generic, the call does not invoke a generic 2148 -- formal subprogram, the target is external to the instance, and switch 2149 -- -gnatdL (ignore external calls from instances for elaboration) is in 2150 -- effect. 2151 2152 if Debug_Flag_LL 2153 and then not Is_Generic_Formal_Subp (Entity (Call_Nam)) 2154 2155 -- Performance note: parent traversal 2156 2157 and then In_External_Context 2158 (Call => N, 2159 Target_Attrs => Target_Attrs) 2160 then 2161 return; 2162 2163 -- Nothing to do when the call invokes an assertion pragma procedure 2164 -- and switch -gnatd_p (ignore assertion pragmas for elaboration) is 2165 -- in effect. 2166 2167 elsif Debug_Flag_Underscore_P 2168 and then Is_Assertion_Pragma_Target (Target_Id) 2169 then 2170 return; 2171 2172 -- Source calls to source targets are always considered because they 2173 -- reflect the original call graph. 2174 2175 elsif Target_Attrs.From_Source and then Call_Attrs.From_Source then 2176 null; 2177 2178 -- A call to a source function which acts as the default expression in 2179 -- another call requires special detection. 2180 2181 elsif Target_Attrs.From_Source 2182 and then Nkind (N) = N_Function_Call 2183 and then Is_Default_Expression (N) 2184 then 2185 null; 2186 2187 -- The target emulates Ada semantics 2188 2189 elsif Is_Ada_Semantic_Target (Target_Id) then 2190 null; 2191 2192 -- The target acts as a link between scenarios 2193 2194 elsif Is_Bridge_Target (Target_Id) then 2195 null; 2196 2197 -- The target emulates SPARK semantics 2198 2199 elsif Is_SPARK_Semantic_Target (Target_Id) then 2200 null; 2201 2202 -- Otherwise the call is not suitable for ABE processing. This prevents 2203 -- the generation of call markers which will never play a role in ABE 2204 -- diagnostics. 2205 2206 else 2207 return; 2208 end if; 2209 2210 -- At this point it is known that the call will play some role in ABE 2211 -- checks and diagnostics. Create a corresponding call marker in case 2212 -- the original call is heavily transformed by expansion later on. 2213 2214 Marker := Make_Call_Marker (Sloc (N)); 2215 2216 -- Inherit the attributes of the original call 2217 2218 Set_Target (Marker, Target_Id); 2219 Set_Is_Declaration_Level_Node (Marker, Call_Attrs.In_Declarations); 2220 Set_Is_Dispatching_Call (Marker, Call_Attrs.Is_Dispatching); 2221 Set_Is_Elaboration_Checks_OK_Node 2222 (Marker, Call_Attrs.Elab_Checks_OK); 2223 Set_Is_Elaboration_Warnings_OK_Node 2224 (Marker, Call_Attrs.Elab_Warnings_OK); 2225 Set_Is_Ignored_Ghost_Node (Marker, Call_Attrs.Ghost_Mode_Ignore); 2226 Set_Is_Source_Call (Marker, Call_Attrs.From_Source); 2227 Set_Is_SPARK_Mode_On_Node (Marker, Call_Attrs.SPARK_Mode_On); 2228 2229 -- The marker is inserted prior to the original call. This placement has 2230 -- several desirable effects: 2231 2232 -- 1) The marker appears in the same context, in close proximity to 2233 -- the call. 2234 2235 -- <marker> 2236 -- <call> 2237 2238 -- 2) Inserting the marker prior to the call ensures that an ABE check 2239 -- will take effect prior to the call. 2240 2241 -- <ABE check> 2242 -- <marker> 2243 -- <call> 2244 2245 -- 3) The above two properties are preserved even when the call is a 2246 -- function which is subsequently relocated in order to capture its 2247 -- result. Note that if the call is relocated to a new context, the 2248 -- relocated call will receive a marker of its own. 2249 2250 -- <ABE check> 2251 -- <maker> 2252 -- Temp : ... := Func_Call ...; 2253 -- ... Temp ... 2254 2255 -- The insertion must take place even when the call does not occur in 2256 -- the main unit to keep the tree symmetric. This ensures that internal 2257 -- name serialization is consistent in case the call marker causes the 2258 -- tree to transform in some way. 2259 2260 Insert_Action (N, Marker); 2261 2262 -- The marker becomes the "corresponding" scenario for the call. Save 2263 -- the marker for later processing by the ABE phase. 2264 2265 Record_Elaboration_Scenario (Marker); 2266 end Build_Call_Marker; 2267 2268 ------------------------------------- 2269 -- Build_Variable_Reference_Marker -- 2270 ------------------------------------- 2271 2272 procedure Build_Variable_Reference_Marker 2273 (N : Node_Id; 2274 Read : Boolean; 2275 Write : Boolean) 2276 is 2277 Marker : Node_Id; 2278 Var_Attrs : Variable_Attributes; 2279 Var_Id : Entity_Id; 2280 2281 begin 2282 Extract_Variable_Reference_Attributes 2283 (Ref => N, 2284 Var_Id => Var_Id, 2285 Attrs => Var_Attrs); 2286 2287 Marker := Make_Variable_Reference_Marker (Sloc (N)); 2288 2289 -- Inherit the attributes of the original variable reference 2290 2291 Set_Target (Marker, Var_Id); 2292 Set_Is_Read (Marker, Read); 2293 Set_Is_Write (Marker, Write); 2294 2295 -- The marker is inserted prior to the original variable reference. The 2296 -- insertion must take place even when the reference does not occur in 2297 -- the main unit to keep the tree symmetric. This ensures that internal 2298 -- name serialization is consistent in case the variable marker causes 2299 -- the tree to transform in some way. 2300 2301 Insert_Action (N, Marker); 2302 2303 -- The marker becomes the "corresponding" scenario for the reference. 2304 -- Save the marker for later processing for the ABE phase. 2305 2306 Record_Elaboration_Scenario (Marker); 2307 end Build_Variable_Reference_Marker; 2308 2309 --------------------------------- 2310 -- Check_Elaboration_Scenarios -- 2311 --------------------------------- 2312 2313 procedure Check_Elaboration_Scenarios is 2314 begin 2315 -- Nothing to do when switch -gnatH (legacy elaboration checking mode 2316 -- enabled) is in effect because the legacy ABE mechanism does not need 2317 -- to carry out this action. 2318 2319 if Legacy_Elaboration_Checks then 2320 return; 2321 2322 -- Nothing to do for ASIS because ABE checks and diagnostics are not 2323 -- performed in this mode. 2324 2325 elsif ASIS_Mode then 2326 return; 2327 end if; 2328 2329 -- Restore the original elaboration model which was in effect when the 2330 -- scenarios were first recorded. The model may be specified by pragma 2331 -- Elaboration_Checks which appears on the initial declaration of the 2332 -- main unit. 2333 2334 Install_Elaboration_Model (Unit_Entity (Cunit_Entity (Main_Unit))); 2335 2336 -- Examine the context of the main unit and record all units with prior 2337 -- elaboration with respect to it. 2338 2339 Find_Elaborated_Units; 2340 2341 -- Examine each top-level scenario saved during the Recording phase for 2342 -- conditional ABEs and perform various actions depending on the model 2343 -- in effect. The table of visited bodies is created for each new top- 2344 -- level scenario. 2345 2346 for Index in Top_Level_Scenarios.First .. Top_Level_Scenarios.Last loop 2347 Reset_Visited_Bodies; 2348 2349 Process_Conditional_ABE (Top_Level_Scenarios.Table (Index)); 2350 end loop; 2351 2352 -- Examine each SPARK scenario saved during the Recording phase which 2353 -- is not necessarily executable during elaboration, but still requires 2354 -- elaboration-related checks. 2355 2356 for Index in SPARK_Scenarios.First .. SPARK_Scenarios.Last loop 2357 Check_SPARK_Scenario (SPARK_Scenarios.Table (Index)); 2358 end loop; 2359 end Check_Elaboration_Scenarios; 2360 2361 ------------------------------ 2362 -- Check_Preelaborated_Call -- 2363 ------------------------------ 2364 2365 procedure Check_Preelaborated_Call (Call : Node_Id) is 2366 function In_Preelaborated_Context (N : Node_Id) return Boolean; 2367 -- Determine whether arbitrary node appears in a preelaborated context 2368 2369 ------------------------------ 2370 -- In_Preelaborated_Context -- 2371 ------------------------------ 2372 2373 function In_Preelaborated_Context (N : Node_Id) return Boolean is 2374 Body_Id : constant Entity_Id := Find_Code_Unit (N); 2375 Spec_Id : constant Entity_Id := Unique_Entity (Body_Id); 2376 2377 begin 2378 -- The node appears within a package body whose corresponding spec is 2379 -- subject to pragma Remote_Call_Interface or Remote_Types. This does 2380 -- not result in a preelaborated context because the package body may 2381 -- be on another machine. 2382 2383 if Ekind (Body_Id) = E_Package_Body 2384 and then Ekind_In (Spec_Id, E_Generic_Package, E_Package) 2385 and then (Is_Remote_Call_Interface (Spec_Id) 2386 or else Is_Remote_Types (Spec_Id)) 2387 then 2388 return False; 2389 2390 -- Otherwise the node appears within a preelaborated context when the 2391 -- associated unit is preelaborated. 2392 2393 else 2394 return Is_Preelaborated_Unit (Spec_Id); 2395 end if; 2396 end In_Preelaborated_Context; 2397 2398 -- Local variables 2399 2400 Call_Attrs : Call_Attributes; 2401 Level : Enclosing_Level_Kind; 2402 Target_Id : Entity_Id; 2403 2404 -- Start of processing for Check_Preelaborated_Call 2405 2406 begin 2407 Extract_Call_Attributes 2408 (Call => Call, 2409 Target_Id => Target_Id, 2410 Attrs => Call_Attrs); 2411 2412 -- Nothing to do when the call is internally generated because it is 2413 -- assumed that it will never violate preelaboration. 2414 2415 if not Call_Attrs.From_Source then 2416 return; 2417 end if; 2418 2419 -- Performance note: parent traversal 2420 2421 Level := Find_Enclosing_Level (Call); 2422 2423 -- Library-level calls are always considered because they are part of 2424 -- the associated unit's elaboration actions. 2425 2426 if Level in Library_Level then 2427 null; 2428 2429 -- Calls at the library level of a generic package body must be checked 2430 -- because they would render an instantiation illegal if the template is 2431 -- marked as preelaborated. Note that this does not apply to calls at 2432 -- the library level of a generic package spec. 2433 2434 elsif Level = Generic_Package_Body then 2435 null; 2436 2437 -- Otherwise the call does not appear at the proper level and must not 2438 -- be considered for this check. 2439 2440 else 2441 return; 2442 end if; 2443 2444 -- The call appears within a preelaborated unit. Emit a warning only for 2445 -- internal uses, otherwise this is an error. 2446 2447 if In_Preelaborated_Context (Call) then 2448 Error_Msg_Warn := GNAT_Mode; 2449 Error_Msg_N 2450 ("<<non-static call not allowed in preelaborated unit", Call); 2451 end if; 2452 end Check_Preelaborated_Call; 2453 2454 ------------------------------ 2455 -- Check_SPARK_Derived_Type -- 2456 ------------------------------ 2457 2458 procedure Check_SPARK_Derived_Type (Typ_Decl : Node_Id) is 2459 Typ : constant Entity_Id := Defining_Entity (Typ_Decl); 2460 2461 -- NOTE: The routines within Check_SPARK_Derived_Type are intentionally 2462 -- unnested to avoid deep indentation of code. 2463 2464 Stop_Check : exception; 2465 -- This exception is raised when the freeze node violates the placement 2466 -- rules. 2467 2468 procedure Check_Overriding_Primitive 2469 (Prim : Entity_Id; 2470 FNode : Node_Id); 2471 pragma Inline (Check_Overriding_Primitive); 2472 -- Verify that freeze node FNode is within the early call region of 2473 -- overriding primitive Prim's body. 2474 2475 function Freeze_Node_Location (FNode : Node_Id) return Source_Ptr; 2476 pragma Inline (Freeze_Node_Location); 2477 -- Return a more accurate source location associated with freeze node 2478 -- FNode. 2479 2480 function Precedes_Source_Construct (N : Node_Id) return Boolean; 2481 pragma Inline (Precedes_Source_Construct); 2482 -- Determine whether arbitrary node N appears prior to some source 2483 -- construct. 2484 2485 procedure Suggest_Elaborate_Body 2486 (N : Node_Id; 2487 Body_Decl : Node_Id; 2488 Error_Nod : Node_Id); 2489 pragma Inline (Suggest_Elaborate_Body); 2490 -- Suggest the use of pragma Elaborate_Body when the pragma will allow 2491 -- for node N to appear within the early call region of subprogram body 2492 -- Body_Decl. The suggestion is attached to Error_Nod as a continuation 2493 -- error. 2494 2495 -------------------------------- 2496 -- Check_Overriding_Primitive -- 2497 -------------------------------- 2498 2499 procedure Check_Overriding_Primitive 2500 (Prim : Entity_Id; 2501 FNode : Node_Id) 2502 is 2503 Prim_Decl : constant Node_Id := Unit_Declaration_Node (Prim); 2504 Body_Decl : Node_Id; 2505 Body_Id : Entity_Id; 2506 Region : Node_Id; 2507 2508 begin 2509 -- Nothing to do for predefined primitives because they are artifacts 2510 -- of tagged type expansion and cannot override source primitives. 2511 2512 if Is_Predefined_Dispatching_Operation (Prim) then 2513 return; 2514 end if; 2515 2516 Body_Id := Corresponding_Body (Prim_Decl); 2517 2518 -- Nothing to do when the primitive does not have a corresponding 2519 -- body. This can happen when the unit with the bodies is not the 2520 -- main unit subjected to ABE checks. 2521 2522 if No (Body_Id) then 2523 return; 2524 2525 -- The primitive overrides a parent or progenitor primitive 2526 2527 elsif Present (Overridden_Operation (Prim)) then 2528 2529 -- Nothing to do when overriding an interface primitive happens by 2530 -- inheriting a non-interface primitive as the check would be done 2531 -- on the parent primitive. 2532 2533 if Present (Alias (Prim)) then 2534 return; 2535 end if; 2536 2537 -- Nothing to do when the primitive is not overriding. The body of 2538 -- such a primitive cannot be targeted by a dispatching call which 2539 -- is executable during elaboration, and cannot cause an ABE. 2540 2541 else 2542 return; 2543 end if; 2544 2545 Body_Decl := Unit_Declaration_Node (Body_Id); 2546 Region := Find_Early_Call_Region (Body_Decl); 2547 2548 -- The freeze node appears prior to the early call region of the 2549 -- primitive body. 2550 2551 -- IMPORTANT: This check must always be performed even when -gnatd.v 2552 -- (enforce SPARK elaboration rules in SPARK code) is not specified 2553 -- because the static model cannot guarantee the absence of ABEs in 2554 -- in the presence of dispatching calls. 2555 2556 if Earlier_In_Extended_Unit (FNode, Region) then 2557 Error_Msg_Node_2 := Prim; 2558 Error_Msg_NE 2559 ("first freezing point of type & must appear within early call " 2560 & "region of primitive body & (SPARK RM 7.7(8))", 2561 Typ_Decl, Typ); 2562 2563 Error_Msg_Sloc := Sloc (Region); 2564 Error_Msg_N ("\region starts #", Typ_Decl); 2565 2566 Error_Msg_Sloc := Sloc (Body_Decl); 2567 Error_Msg_N ("\region ends #", Typ_Decl); 2568 2569 Error_Msg_Sloc := Freeze_Node_Location (FNode); 2570 Error_Msg_N ("\first freezing point #", Typ_Decl); 2571 2572 -- If applicable, suggest the use of pragma Elaborate_Body in the 2573 -- associated package spec. 2574 2575 Suggest_Elaborate_Body 2576 (N => FNode, 2577 Body_Decl => Body_Decl, 2578 Error_Nod => Typ_Decl); 2579 2580 raise Stop_Check; 2581 end if; 2582 end Check_Overriding_Primitive; 2583 2584 -------------------------- 2585 -- Freeze_Node_Location -- 2586 -------------------------- 2587 2588 function Freeze_Node_Location (FNode : Node_Id) return Source_Ptr is 2589 Context : constant Node_Id := Parent (FNode); 2590 Loc : constant Source_Ptr := Sloc (FNode); 2591 2592 Prv_Decls : List_Id; 2593 Vis_Decls : List_Id; 2594 2595 begin 2596 -- In general, the source location of the freeze node is as close as 2597 -- possible to the real freeze point, except when the freeze node is 2598 -- at the "bottom" of a package spec. 2599 2600 if Nkind (Context) = N_Package_Specification then 2601 Prv_Decls := Private_Declarations (Context); 2602 Vis_Decls := Visible_Declarations (Context); 2603 2604 -- The freeze node appears in the private declarations of the 2605 -- package. 2606 2607 if Present (Prv_Decls) 2608 and then List_Containing (FNode) = Prv_Decls 2609 then 2610 null; 2611 2612 -- The freeze node appears in the visible declarations of the 2613 -- package and there are no private declarations. 2614 2615 elsif Present (Vis_Decls) 2616 and then List_Containing (FNode) = Vis_Decls 2617 and then (No (Prv_Decls) or else Is_Empty_List (Prv_Decls)) 2618 then 2619 null; 2620 2621 -- Otherwise the freeze node is not in the "last" declarative list 2622 -- of the package. Use the existing source location of the freeze 2623 -- node. 2624 2625 else 2626 return Loc; 2627 end if; 2628 2629 -- The freeze node appears at the "bottom" of the package when it 2630 -- is in the "last" declarative list and is either the last in the 2631 -- list or is followed by internal constructs only. In that case 2632 -- the more appropriate source location is that of the package end 2633 -- label. 2634 2635 if not Precedes_Source_Construct (FNode) then 2636 return Sloc (End_Label (Context)); 2637 end if; 2638 end if; 2639 2640 return Loc; 2641 end Freeze_Node_Location; 2642 2643 ------------------------------- 2644 -- Precedes_Source_Construct -- 2645 ------------------------------- 2646 2647 function Precedes_Source_Construct (N : Node_Id) return Boolean is 2648 Decl : Node_Id; 2649 2650 begin 2651 Decl := Next (N); 2652 while Present (Decl) loop 2653 if Comes_From_Source (Decl) then 2654 return True; 2655 2656 -- A generated body for a source expression function is treated as 2657 -- a source construct. 2658 2659 elsif Nkind (Decl) = N_Subprogram_Body 2660 and then Was_Expression_Function (Decl) 2661 and then Comes_From_Source (Original_Node (Decl)) 2662 then 2663 return True; 2664 end if; 2665 2666 Next (Decl); 2667 end loop; 2668 2669 return False; 2670 end Precedes_Source_Construct; 2671 2672 ---------------------------- 2673 -- Suggest_Elaborate_Body -- 2674 ---------------------------- 2675 2676 procedure Suggest_Elaborate_Body 2677 (N : Node_Id; 2678 Body_Decl : Node_Id; 2679 Error_Nod : Node_Id) 2680 is 2681 Unt : constant Node_Id := Unit (Cunit (Main_Unit)); 2682 Region : Node_Id; 2683 2684 begin 2685 -- The suggestion applies only when the subprogram body resides in a 2686 -- compilation package body, and a pragma Elaborate_Body would allow 2687 -- for the node to appear in the early call region of the subprogram 2688 -- body. This implies that all code from the subprogram body up to 2689 -- the node is preelaborable. 2690 2691 if Nkind (Unt) = N_Package_Body then 2692 2693 -- Find the start of the early call region again assuming that the 2694 -- package spec has pragma Elaborate_Body. Note that the internal 2695 -- data structures are intentionally not updated because this is a 2696 -- speculative search. 2697 2698 Region := 2699 Find_Early_Call_Region 2700 (Body_Decl => Body_Decl, 2701 Assume_Elab_Body => True, 2702 Skip_Memoization => True); 2703 2704 -- If the node appears within the early call region, assuming that 2705 -- the package spec carries pragma Elaborate_Body, then it is safe 2706 -- to suggest the pragma. 2707 2708 if Earlier_In_Extended_Unit (Region, N) then 2709 Error_Msg_Name_1 := Name_Elaborate_Body; 2710 Error_Msg_NE 2711 ("\consider adding pragma % in spec of unit &", 2712 Error_Nod, Defining_Entity (Unt)); 2713 end if; 2714 end if; 2715 end Suggest_Elaborate_Body; 2716 2717 -- Local variables 2718 2719 FNode : constant Node_Id := Freeze_Node (Typ); 2720 Prims : constant Elist_Id := Direct_Primitive_Operations (Typ); 2721 2722 Prim_Elmt : Elmt_Id; 2723 2724 -- Start of processing for Check_SPARK_Derived_Type 2725 2726 begin 2727 -- A type should have its freeze node set by the time SPARK scenarios 2728 -- are being verified. 2729 2730 pragma Assert (Present (FNode)); 2731 2732 -- Verify that the freeze node of the derived type is within the early 2733 -- call region of each overriding primitive body (SPARK RM 7.7(8)). 2734 2735 if Present (Prims) then 2736 Prim_Elmt := First_Elmt (Prims); 2737 while Present (Prim_Elmt) loop 2738 Check_Overriding_Primitive 2739 (Prim => Node (Prim_Elmt), 2740 FNode => FNode); 2741 2742 Next_Elmt (Prim_Elmt); 2743 end loop; 2744 end if; 2745 2746 exception 2747 when Stop_Check => 2748 null; 2749 end Check_SPARK_Derived_Type; 2750 2751 ------------------------------- 2752 -- Check_SPARK_Instantiation -- 2753 ------------------------------- 2754 2755 procedure Check_SPARK_Instantiation (Exp_Inst : Node_Id) is 2756 Gen_Attrs : Target_Attributes; 2757 Gen_Id : Entity_Id; 2758 Inst : Node_Id; 2759 Inst_Attrs : Instantiation_Attributes; 2760 Inst_Id : Entity_Id; 2761 2762 begin 2763 Extract_Instantiation_Attributes 2764 (Exp_Inst => Exp_Inst, 2765 Inst => Inst, 2766 Inst_Id => Inst_Id, 2767 Gen_Id => Gen_Id, 2768 Attrs => Inst_Attrs); 2769 2770 Extract_Target_Attributes (Gen_Id, Gen_Attrs); 2771 2772 -- The instantiation and the generic body are both in the main unit 2773 2774 if Present (Gen_Attrs.Body_Decl) 2775 and then In_Extended_Main_Code_Unit (Gen_Attrs.Body_Decl) 2776 2777 -- If the instantiation appears prior to the generic body, then the 2778 -- instantiation is illegal (SPARK RM 7.7(6)). 2779 2780 -- IMPORTANT: This check must always be performed even when -gnatd.v 2781 -- (enforce SPARK elaboration rules in SPARK code) is not specified 2782 -- because the rule prevents use-before-declaration of objects that 2783 -- may precede the generic body. 2784 2785 and then Earlier_In_Extended_Unit (Inst, Gen_Attrs.Body_Decl) 2786 then 2787 Error_Msg_NE ("cannot instantiate & before body seen", Inst, Gen_Id); 2788 end if; 2789 end Check_SPARK_Instantiation; 2790 2791 --------------------------------- 2792 -- Check_SPARK_Model_In_Effect -- 2793 --------------------------------- 2794 2795 SPARK_Model_Warning_Posted : Boolean := False; 2796 -- This flag prevents the same SPARK model-related warning from being 2797 -- emitted multiple times. 2798 2799 procedure Check_SPARK_Model_In_Effect (N : Node_Id) is 2800 begin 2801 -- Do not emit the warning multiple times as this creates useless noise 2802 2803 if SPARK_Model_Warning_Posted then 2804 null; 2805 2806 -- SPARK rule verification requires the "strict" static model 2807 2808 elsif Static_Elaboration_Checks and not Relaxed_Elaboration_Checks then 2809 null; 2810 2811 -- Any other combination of models does not guarantee the absence of ABE 2812 -- problems for SPARK rule verification purposes. Note that there is no 2813 -- need to check for the legacy ABE mechanism because the legacy code 2814 -- has its own orthogonal processing for SPARK rules. 2815 2816 else 2817 SPARK_Model_Warning_Posted := True; 2818 2819 Error_Msg_N 2820 ("??SPARK elaboration checks require static elaboration model", N); 2821 2822 if Dynamic_Elaboration_Checks then 2823 Error_Msg_N ("\dynamic elaboration model is in effect", N); 2824 else 2825 pragma Assert (Relaxed_Elaboration_Checks); 2826 Error_Msg_N ("\relaxed elaboration model is in effect", N); 2827 end if; 2828 end if; 2829 end Check_SPARK_Model_In_Effect; 2830 2831 -------------------------- 2832 -- Check_SPARK_Scenario -- 2833 -------------------------- 2834 2835 procedure Check_SPARK_Scenario (N : Node_Id) is 2836 begin 2837 -- Ensure that a suitable elaboration model is in effect for SPARK rule 2838 -- verification. 2839 2840 Check_SPARK_Model_In_Effect (N); 2841 2842 -- Add the current scenario to the stack of active scenarios 2843 2844 Push_Active_Scenario (N); 2845 2846 if Is_Suitable_SPARK_Derived_Type (N) then 2847 Check_SPARK_Derived_Type (N); 2848 2849 elsif Is_Suitable_SPARK_Instantiation (N) then 2850 Check_SPARK_Instantiation (N); 2851 2852 elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then 2853 Check_SPARK_Refined_State_Pragma (N); 2854 end if; 2855 2856 -- Remove the current scenario from the stack of active scenarios once 2857 -- all ABE diagnostics and checks have been performed. 2858 2859 Pop_Active_Scenario (N); 2860 end Check_SPARK_Scenario; 2861 2862 -------------------------------------- 2863 -- Check_SPARK_Refined_State_Pragma -- 2864 -------------------------------------- 2865 2866 procedure Check_SPARK_Refined_State_Pragma (N : Node_Id) is 2867 2868 -- NOTE: The routines within Check_SPARK_Refined_State_Pragma are 2869 -- intentionally unnested to avoid deep indentation of code. 2870 2871 procedure Check_SPARK_Constituent (Constit_Id : Entity_Id); 2872 pragma Inline (Check_SPARK_Constituent); 2873 -- Ensure that a single constituent Constit_Id is elaborated prior to 2874 -- the main unit. 2875 2876 procedure Check_SPARK_Constituents (Constits : Elist_Id); 2877 pragma Inline (Check_SPARK_Constituents); 2878 -- Ensure that all constituents found in list Constits are elaborated 2879 -- prior to the main unit. 2880 2881 procedure Check_SPARK_Initialized_State (State : Node_Id); 2882 pragma Inline (Check_SPARK_Initialized_State); 2883 -- Ensure that the constituents of single abstract state State are 2884 -- elaborated prior to the main unit. 2885 2886 procedure Check_SPARK_Initialized_States (Pack_Id : Entity_Id); 2887 pragma Inline (Check_SPARK_Initialized_States); 2888 -- Ensure that the constituents of all abstract states which appear in 2889 -- the Initializes pragma of package Pack_Id are elaborated prior to the 2890 -- main unit. 2891 2892 ----------------------------- 2893 -- Check_SPARK_Constituent -- 2894 ----------------------------- 2895 2896 procedure Check_SPARK_Constituent (Constit_Id : Entity_Id) is 2897 Prag : Node_Id; 2898 2899 begin 2900 -- Nothing to do for "null" constituents 2901 2902 if Nkind (Constit_Id) = N_Null then 2903 return; 2904 2905 -- Nothing to do for illegal constituents 2906 2907 elsif Error_Posted (Constit_Id) then 2908 return; 2909 end if; 2910 2911 Prag := SPARK_Pragma (Constit_Id); 2912 2913 -- The check applies only when the constituent is subject to pragma 2914 -- SPARK_Mode On. 2915 2916 if Present (Prag) 2917 and then Get_SPARK_Mode_From_Annotation (Prag) = On 2918 then 2919 -- An external constituent of an abstract state which appears in 2920 -- the Initializes pragma of a package spec imposes an Elaborate 2921 -- requirement on the context of the main unit. Determine whether 2922 -- the context has a pragma strong enough to meet the requirement. 2923 2924 -- IMPORTANT: This check is performed only when -gnatd.v (enforce 2925 -- SPARK elaboration rules in SPARK code) is in effect because the 2926 -- static model can ensure the prior elaboration of the unit which 2927 -- contains a constituent by installing implicit Elaborate pragma. 2928 2929 if Debug_Flag_Dot_V then 2930 Meet_Elaboration_Requirement 2931 (N => N, 2932 Target_Id => Constit_Id, 2933 Req_Nam => Name_Elaborate); 2934 2935 -- Otherwise ensure that the unit with the external constituent is 2936 -- elaborated prior to the main unit. 2937 2938 else 2939 Ensure_Prior_Elaboration 2940 (N => N, 2941 Unit_Id => Find_Top_Unit (Constit_Id), 2942 Prag_Nam => Name_Elaborate, 2943 State => Initial_State); 2944 end if; 2945 end if; 2946 end Check_SPARK_Constituent; 2947 2948 ------------------------------ 2949 -- Check_SPARK_Constituents -- 2950 ------------------------------ 2951 2952 procedure Check_SPARK_Constituents (Constits : Elist_Id) is 2953 Constit_Elmt : Elmt_Id; 2954 2955 begin 2956 if Present (Constits) then 2957 Constit_Elmt := First_Elmt (Constits); 2958 while Present (Constit_Elmt) loop 2959 Check_SPARK_Constituent (Node (Constit_Elmt)); 2960 Next_Elmt (Constit_Elmt); 2961 end loop; 2962 end if; 2963 end Check_SPARK_Constituents; 2964 2965 ----------------------------------- 2966 -- Check_SPARK_Initialized_State -- 2967 ----------------------------------- 2968 2969 procedure Check_SPARK_Initialized_State (State : Node_Id) is 2970 Prag : Node_Id; 2971 State_Id : Entity_Id; 2972 2973 begin 2974 -- Nothing to do for "null" initialization items 2975 2976 if Nkind (State) = N_Null then 2977 return; 2978 2979 -- Nothing to do for illegal states 2980 2981 elsif Error_Posted (State) then 2982 return; 2983 end if; 2984 2985 State_Id := Entity_Of (State); 2986 2987 -- Sanitize the state 2988 2989 if No (State_Id) then 2990 return; 2991 2992 elsif Error_Posted (State_Id) then 2993 return; 2994 2995 elsif Ekind (State_Id) /= E_Abstract_State then 2996 return; 2997 end if; 2998 2999 -- The check is performed only when the abstract state is subject to 3000 -- SPARK_Mode On. 3001 3002 Prag := SPARK_Pragma (State_Id); 3003 3004 if Present (Prag) 3005 and then Get_SPARK_Mode_From_Annotation (Prag) = On 3006 then 3007 Check_SPARK_Constituents (Refinement_Constituents (State_Id)); 3008 end if; 3009 end Check_SPARK_Initialized_State; 3010 3011 ------------------------------------ 3012 -- Check_SPARK_Initialized_States -- 3013 ------------------------------------ 3014 3015 procedure Check_SPARK_Initialized_States (Pack_Id : Entity_Id) is 3016 Prag : constant Node_Id := Get_Pragma (Pack_Id, Pragma_Initializes); 3017 Init : Node_Id; 3018 Inits : Node_Id; 3019 3020 begin 3021 if Present (Prag) then 3022 Inits := Expression (Get_Argument (Prag, Pack_Id)); 3023 3024 -- Avoid processing a "null" initialization list. The only other 3025 -- alternative is an aggregate. 3026 3027 if Nkind (Inits) = N_Aggregate then 3028 3029 -- The initialization items appear in list form: 3030 -- 3031 -- (state1, state2) 3032 3033 if Present (Expressions (Inits)) then 3034 Init := First (Expressions (Inits)); 3035 while Present (Init) loop 3036 Check_SPARK_Initialized_State (Init); 3037 Next (Init); 3038 end loop; 3039 end if; 3040 3041 -- The initialization items appear in associated form: 3042 -- 3043 -- (state1 => item1, 3044 -- state2 => (item2, item3)) 3045 3046 if Present (Component_Associations (Inits)) then 3047 Init := First (Component_Associations (Inits)); 3048 while Present (Init) loop 3049 Check_SPARK_Initialized_State (Init); 3050 Next (Init); 3051 end loop; 3052 end if; 3053 end if; 3054 end if; 3055 end Check_SPARK_Initialized_States; 3056 3057 -- Local variables 3058 3059 Pack_Body : constant Node_Id := Find_Related_Package_Or_Body (N); 3060 3061 -- Start of processing for Check_SPARK_Refined_State_Pragma 3062 3063 begin 3064 -- Pragma Refined_State must be associated with a package body 3065 3066 pragma Assert 3067 (Present (Pack_Body) and then Nkind (Pack_Body) = N_Package_Body); 3068 3069 -- Verify that each external contitunent of an abstract state mentioned 3070 -- in pragma Initializes is properly elaborated. 3071 3072 Check_SPARK_Initialized_States (Unique_Defining_Entity (Pack_Body)); 3073 end Check_SPARK_Refined_State_Pragma; 3074 3075 ---------------------- 3076 -- Compilation_Unit -- 3077 ---------------------- 3078 3079 function Compilation_Unit (Unit_Id : Entity_Id) return Node_Id is 3080 Comp_Unit : Node_Id; 3081 3082 begin 3083 Comp_Unit := Parent (Unit_Id); 3084 3085 -- Handle the case where a concurrent subunit is rewritten as a null 3086 -- statement due to expansion activities. 3087 3088 if Nkind (Comp_Unit) = N_Null_Statement 3089 and then Nkind_In (Original_Node (Comp_Unit), N_Protected_Body, 3090 N_Task_Body) 3091 then 3092 Comp_Unit := Parent (Comp_Unit); 3093 pragma Assert (Nkind (Comp_Unit) = N_Subunit); 3094 3095 -- Otherwise use the declaration node of the unit 3096 3097 else 3098 Comp_Unit := Parent (Unit_Declaration_Node (Unit_Id)); 3099 end if; 3100 3101 -- Handle the case where a subprogram instantiation which acts as a 3102 -- compilation unit is expanded into an anonymous package that wraps 3103 -- the instantiated subprogram. 3104 3105 if Nkind (Comp_Unit) = N_Package_Specification 3106 and then Nkind_In (Original_Node (Parent (Comp_Unit)), 3107 N_Function_Instantiation, 3108 N_Procedure_Instantiation) 3109 then 3110 Comp_Unit := Parent (Parent (Comp_Unit)); 3111 3112 -- Handle the case where the compilation unit is a subunit 3113 3114 elsif Nkind (Comp_Unit) = N_Subunit then 3115 Comp_Unit := Parent (Comp_Unit); 3116 end if; 3117 3118 pragma Assert (Nkind (Comp_Unit) = N_Compilation_Unit); 3119 3120 return Comp_Unit; 3121 end Compilation_Unit; 3122 3123 ----------------------- 3124 -- Early_Call_Region -- 3125 ----------------------- 3126 3127 function Early_Call_Region (Body_Id : Entity_Id) return Node_Id is 3128 begin 3129 pragma Assert (Ekind_In (Body_Id, E_Entry, 3130 E_Entry_Family, 3131 E_Function, 3132 E_Procedure, 3133 E_Subprogram_Body)); 3134 3135 if Early_Call_Regions_In_Use then 3136 return Early_Call_Regions.Get (Body_Id); 3137 end if; 3138 3139 return Early_Call_Regions_No_Element; 3140 end Early_Call_Region; 3141 3142 ----------------------------- 3143 -- Early_Call_Regions_Hash -- 3144 ----------------------------- 3145 3146 function Early_Call_Regions_Hash 3147 (Key : Entity_Id) return Early_Call_Regions_Index 3148 is 3149 begin 3150 return Early_Call_Regions_Index (Key mod Early_Call_Regions_Max); 3151 end Early_Call_Regions_Hash; 3152 3153 ----------------- 3154 -- Elab_Msg_NE -- 3155 ----------------- 3156 3157 procedure Elab_Msg_NE 3158 (Msg : String; 3159 N : Node_Id; 3160 Id : Entity_Id; 3161 Info_Msg : Boolean; 3162 In_SPARK : Boolean) 3163 is 3164 function Prefix return String; 3165 -- Obtain the prefix of the message 3166 3167 function Suffix return String; 3168 -- Obtain the suffix of the message 3169 3170 ------------ 3171 -- Prefix -- 3172 ------------ 3173 3174 function Prefix return String is 3175 begin 3176 if Info_Msg then 3177 return "info: "; 3178 else 3179 return ""; 3180 end if; 3181 end Prefix; 3182 3183 ------------ 3184 -- Suffix -- 3185 ------------ 3186 3187 function Suffix return String is 3188 begin 3189 if In_SPARK then 3190 return " in SPARK"; 3191 else 3192 return ""; 3193 end if; 3194 end Suffix; 3195 3196 -- Start of processing for Elab_Msg_NE 3197 3198 begin 3199 Error_Msg_NE (Prefix & Msg & Suffix, N, Id); 3200 end Elab_Msg_NE; 3201 3202 ------------------------ 3203 -- Elaboration_Status -- 3204 ------------------------ 3205 3206 function Elaboration_Status 3207 (Unit_Id : Entity_Id) return Elaboration_Attributes 3208 is 3209 begin 3210 if Elaboration_Statuses_In_Use then 3211 return Elaboration_Statuses.Get (Unit_Id); 3212 end if; 3213 3214 return Elaboration_Statuses_No_Element; 3215 end Elaboration_Status; 3216 3217 ------------------------------- 3218 -- Elaboration_Statuses_Hash -- 3219 ------------------------------- 3220 3221 function Elaboration_Statuses_Hash 3222 (Key : Entity_Id) return Elaboration_Statuses_Index 3223 is 3224 begin 3225 return Elaboration_Statuses_Index (Key mod Elaboration_Statuses_Max); 3226 end Elaboration_Statuses_Hash; 3227 3228 ------------------------------ 3229 -- Ensure_Prior_Elaboration -- 3230 ------------------------------ 3231 3232 procedure Ensure_Prior_Elaboration 3233 (N : Node_Id; 3234 Unit_Id : Entity_Id; 3235 Prag_Nam : Name_Id; 3236 State : Processing_Attributes) 3237 is 3238 begin 3239 pragma Assert (Nam_In (Prag_Nam, Name_Elaborate, Name_Elaborate_All)); 3240 3241 -- Nothing to do when the caller has suppressed the generation of 3242 -- implicit Elaborate[_All] pragmas. 3243 3244 if State.Suppress_Implicit_Pragmas then 3245 return; 3246 3247 -- Nothing to do when the need for prior elaboration came from a partial 3248 -- finalization routine which occurs in an initialization context. This 3249 -- behaviour parallels that of the old ABE mechanism. 3250 3251 elsif State.Within_Partial_Finalization then 3252 return; 3253 3254 -- Nothing to do when the need for prior elaboration came from a task 3255 -- body and switch -gnatd.y (disable implicit pragma Elaborate_All on 3256 -- task bodies) is in effect. 3257 3258 elsif Debug_Flag_Dot_Y and then State.Within_Task_Body then 3259 return; 3260 3261 -- Nothing to do when the unit is elaborated prior to the main unit. 3262 -- This check must also consider the following cases: 3263 3264 -- * No check is made against the context of the main unit because this 3265 -- is specific to the elaboration model in effect and requires custom 3266 -- handling (see Ensure_xxx_Prior_Elaboration). 3267 3268 -- * Unit_Id is subject to pragma Elaborate_Body. An implicit pragma 3269 -- Elaborate[_All] MUST be generated even though Unit_Id is always 3270 -- elaborated prior to the main unit. This is a conservative strategy 3271 -- which ensures that other units withed by Unit_Id will not lead to 3272 -- an ABE. 3273 3274 -- package A is package body A is 3275 -- procedure ABE; procedure ABE is ... end ABE; 3276 -- end A; end A; 3277 3278 -- with A; 3279 -- package B is package body B is 3280 -- pragma Elaborate_Body; procedure Proc is 3281 -- begin 3282 -- procedure Proc; A.ABE; 3283 -- package B; end Proc; 3284 -- end B; 3285 3286 -- with B; 3287 -- package C is package body C is 3288 -- ... ... 3289 -- end C; begin 3290 -- B.Proc; 3291 -- end C; 3292 3293 -- In the example above, the elaboration of C invokes B.Proc. B is 3294 -- subject to pragma Elaborate_Body. If no pragma Elaborate[_All] is 3295 -- generated for B in C, then the following elaboratio order will lead 3296 -- to an ABE: 3297 3298 -- spec of A elaborated 3299 -- spec of B elaborated 3300 -- body of B elaborated 3301 -- spec of C elaborated 3302 -- body of C elaborated <-- calls B.Proc which calls A.ABE 3303 -- body of A elaborated <-- problem 3304 3305 -- The generation of an implicit pragma Elaborate_All (B) ensures that 3306 -- the elaboration order mechanism will not pick the above order. 3307 3308 -- An implicit Elaborate is NOT generated when the unit is subject to 3309 -- Elaborate_Body because both pragmas have the exact same effect. 3310 3311 -- * Unit_Id is the main unit. An implicit pragma Elaborate[_All] MUST 3312 -- NOT be generated in this case because a unit cannot depend on its 3313 -- own elaboration. This case is therefore treated as valid prior 3314 -- elaboration. 3315 3316 elsif Has_Prior_Elaboration 3317 (Unit_Id => Unit_Id, 3318 Same_Unit_OK => True, 3319 Elab_Body_OK => Prag_Nam = Name_Elaborate) 3320 then 3321 return; 3322 3323 -- Suggest the use of pragma Prag_Nam when the dynamic model is in 3324 -- effect. 3325 3326 elsif Dynamic_Elaboration_Checks then 3327 Ensure_Prior_Elaboration_Dynamic 3328 (N => N, 3329 Unit_Id => Unit_Id, 3330 Prag_Nam => Prag_Nam); 3331 3332 -- Install an implicit pragma Prag_Nam when the static model is in 3333 -- effect. 3334 3335 else 3336 pragma Assert (Static_Elaboration_Checks); 3337 3338 Ensure_Prior_Elaboration_Static 3339 (N => N, 3340 Unit_Id => Unit_Id, 3341 Prag_Nam => Prag_Nam); 3342 end if; 3343 end Ensure_Prior_Elaboration; 3344 3345 -------------------------------------- 3346 -- Ensure_Prior_Elaboration_Dynamic -- 3347 -------------------------------------- 3348 3349 procedure Ensure_Prior_Elaboration_Dynamic 3350 (N : Node_Id; 3351 Unit_Id : Entity_Id; 3352 Prag_Nam : Name_Id) 3353 is 3354 procedure Info_Missing_Pragma; 3355 pragma Inline (Info_Missing_Pragma); 3356 -- Output information concerning missing Elaborate or Elaborate_All 3357 -- pragma with name Prag_Nam for scenario N, which would ensure the 3358 -- prior elaboration of Unit_Id. 3359 3360 ------------------------- 3361 -- Info_Missing_Pragma -- 3362 ------------------------- 3363 3364 procedure Info_Missing_Pragma is 3365 begin 3366 -- Internal units are ignored as they cause unnecessary noise 3367 3368 if not In_Internal_Unit (Unit_Id) then 3369 3370 -- The name of the unit subjected to the elaboration pragma is 3371 -- fully qualified to improve the clarity of the info message. 3372 3373 Error_Msg_Name_1 := Prag_Nam; 3374 Error_Msg_Qual_Level := Nat'Last; 3375 3376 Error_Msg_NE ("info: missing pragma % for unit &", N, Unit_Id); 3377 Error_Msg_Qual_Level := 0; 3378 end if; 3379 end Info_Missing_Pragma; 3380 3381 -- Local variables 3382 3383 Elab_Attrs : Elaboration_Attributes; 3384 Level : Enclosing_Level_Kind; 3385 3386 -- Start of processing for Ensure_Prior_Elaboration_Dynamic 3387 3388 begin 3389 Elab_Attrs := Elaboration_Status (Unit_Id); 3390 3391 -- Nothing to do when the unit is guaranteed prior elaboration by means 3392 -- of a source Elaborate[_All] pragma. 3393 3394 if Present (Elab_Attrs.Source_Pragma) then 3395 return; 3396 end if; 3397 3398 -- Output extra information on a missing Elaborate[_All] pragma when 3399 -- switch -gnatel (info messages on implicit Elaborate[_All] pragmas 3400 -- is in effect. 3401 3402 if Elab_Info_Messages then 3403 3404 -- Performance note: parent traversal 3405 3406 Level := Find_Enclosing_Level (N); 3407 3408 -- Declaration-level scenario 3409 3410 if (Is_Suitable_Call (N) or else Is_Suitable_Instantiation (N)) 3411 and then Level = Declaration_Level 3412 then 3413 null; 3414 3415 -- Library-level scenario 3416 3417 elsif Level in Library_Level then 3418 null; 3419 3420 -- Instantiation library-level scenario 3421 3422 elsif Level = Instantiation then 3423 null; 3424 3425 -- Otherwise the scenario does not appear at the proper level and 3426 -- cannot possibly act as a top-level scenario. 3427 3428 else 3429 return; 3430 end if; 3431 3432 Info_Missing_Pragma; 3433 end if; 3434 end Ensure_Prior_Elaboration_Dynamic; 3435 3436 ------------------------------------- 3437 -- Ensure_Prior_Elaboration_Static -- 3438 ------------------------------------- 3439 3440 procedure Ensure_Prior_Elaboration_Static 3441 (N : Node_Id; 3442 Unit_Id : Entity_Id; 3443 Prag_Nam : Name_Id) 3444 is 3445 function Find_With_Clause 3446 (Items : List_Id; 3447 Withed_Id : Entity_Id) return Node_Id; 3448 pragma Inline (Find_With_Clause); 3449 -- Find a nonlimited with clause in the list of context items Items 3450 -- that withs unit Withed_Id. Return Empty if no such clause is found. 3451 3452 procedure Info_Implicit_Pragma; 3453 pragma Inline (Info_Implicit_Pragma); 3454 -- Output information concerning an implicitly generated Elaborate or 3455 -- Elaborate_All pragma with name Prag_Nam for scenario N which ensures 3456 -- the prior elaboration of unit Unit_Id. 3457 3458 ---------------------- 3459 -- Find_With_Clause -- 3460 ---------------------- 3461 3462 function Find_With_Clause 3463 (Items : List_Id; 3464 Withed_Id : Entity_Id) return Node_Id 3465 is 3466 Item : Node_Id; 3467 3468 begin 3469 -- Examine the context clauses looking for a suitable with. Note that 3470 -- limited clauses do not affect the elaboration order. 3471 3472 Item := First (Items); 3473 while Present (Item) loop 3474 if Nkind (Item) = N_With_Clause 3475 and then not Error_Posted (Item) 3476 and then not Limited_Present (Item) 3477 and then Entity (Name (Item)) = Withed_Id 3478 then 3479 return Item; 3480 end if; 3481 3482 Next (Item); 3483 end loop; 3484 3485 return Empty; 3486 end Find_With_Clause; 3487 3488 -------------------------- 3489 -- Info_Implicit_Pragma -- 3490 -------------------------- 3491 3492 procedure Info_Implicit_Pragma is 3493 begin 3494 -- Internal units are ignored as they cause unnecessary noise 3495 3496 if not In_Internal_Unit (Unit_Id) then 3497 3498 -- The name of the unit subjected to the elaboration pragma is 3499 -- fully qualified to improve the clarity of the info message. 3500 3501 Error_Msg_Name_1 := Prag_Nam; 3502 Error_Msg_Qual_Level := Nat'Last; 3503 3504 Error_Msg_NE 3505 ("info: implicit pragma % generated for unit &", N, Unit_Id); 3506 3507 Error_Msg_Qual_Level := 0; 3508 Output_Active_Scenarios (N); 3509 end if; 3510 end Info_Implicit_Pragma; 3511 3512 -- Local variables 3513 3514 Main_Cunit : constant Node_Id := Cunit (Main_Unit); 3515 Loc : constant Source_Ptr := Sloc (Main_Cunit); 3516 Unit_Cunit : constant Node_Id := Compilation_Unit (Unit_Id); 3517 3518 Clause : Node_Id; 3519 Elab_Attrs : Elaboration_Attributes; 3520 Items : List_Id; 3521 3522 -- Start of processing for Ensure_Prior_Elaboration_Static 3523 3524 begin 3525 Elab_Attrs := Elaboration_Status (Unit_Id); 3526 3527 -- Nothing to do when the unit is guaranteed prior elaboration by means 3528 -- of a source Elaborate[_All] pragma. 3529 3530 if Present (Elab_Attrs.Source_Pragma) then 3531 return; 3532 3533 -- Nothing to do when the unit has an existing implicit Elaborate[_All] 3534 -- pragma installed by a previous scenario. 3535 3536 elsif Present (Elab_Attrs.With_Clause) then 3537 3538 -- The unit is already guaranteed prior elaboration by means of an 3539 -- implicit Elaborate pragma, however the current scenario imposes 3540 -- a stronger requirement of Elaborate_All. "Upgrade" the existing 3541 -- pragma to match this new requirement. 3542 3543 if Elaborate_Desirable (Elab_Attrs.With_Clause) 3544 and then Prag_Nam = Name_Elaborate_All 3545 then 3546 Set_Elaborate_All_Desirable (Elab_Attrs.With_Clause); 3547 Set_Elaborate_Desirable (Elab_Attrs.With_Clause, False); 3548 end if; 3549 3550 return; 3551 end if; 3552 3553 -- At this point it is known that the unit has no prior elaboration 3554 -- according to pragmas and hierarchical relationships. 3555 3556 Items := Context_Items (Main_Cunit); 3557 3558 if No (Items) then 3559 Items := New_List; 3560 Set_Context_Items (Main_Cunit, Items); 3561 end if; 3562 3563 -- Locate the with clause for the unit. Note that there may not be a 3564 -- clause if the unit is visible through a subunit-body, body-spec, or 3565 -- spec-parent relationship. 3566 3567 Clause := 3568 Find_With_Clause 3569 (Items => Items, 3570 Withed_Id => Unit_Id); 3571 3572 -- Generate: 3573 -- with Id; 3574 3575 -- Note that adding implicit with clauses is safe because analysis, 3576 -- resolution, and expansion have already taken place and it is not 3577 -- possible to interfere with visibility. 3578 3579 if No (Clause) then 3580 Clause := 3581 Make_With_Clause (Loc, 3582 Name => New_Occurrence_Of (Unit_Id, Loc)); 3583 3584 Set_Implicit_With (Clause); 3585 Set_Library_Unit (Clause, Unit_Cunit); 3586 3587 Append_To (Items, Clause); 3588 end if; 3589 3590 -- Mark the with clause depending on the pragma required 3591 3592 if Prag_Nam = Name_Elaborate then 3593 Set_Elaborate_Desirable (Clause); 3594 else 3595 Set_Elaborate_All_Desirable (Clause); 3596 end if; 3597 3598 -- The implicit Elaborate[_All] ensures the prior elaboration of the 3599 -- unit. Include the unit in the elaboration context of the main unit. 3600 3601 Set_Elaboration_Status 3602 (Unit_Id => Unit_Id, 3603 Val => Elaboration_Attributes'(Source_Pragma => Empty, 3604 With_Clause => Clause)); 3605 3606 -- Output extra information on an implicit Elaborate[_All] pragma when 3607 -- switch -gnatel (info messages on implicit Elaborate[_All] pragmas is 3608 -- in effect. 3609 3610 if Elab_Info_Messages then 3611 Info_Implicit_Pragma; 3612 end if; 3613 end Ensure_Prior_Elaboration_Static; 3614 3615 ----------------------------- 3616 -- Extract_Assignment_Name -- 3617 ----------------------------- 3618 3619 function Extract_Assignment_Name (Asmt : Node_Id) return Node_Id is 3620 Nam : Node_Id; 3621 3622 begin 3623 Nam := Name (Asmt); 3624 3625 -- When the name denotes an array or record component, find the whole 3626 -- object. 3627 3628 while Nkind_In (Nam, N_Explicit_Dereference, 3629 N_Indexed_Component, 3630 N_Selected_Component, 3631 N_Slice) 3632 loop 3633 Nam := Prefix (Nam); 3634 end loop; 3635 3636 return Nam; 3637 end Extract_Assignment_Name; 3638 3639 ----------------------------- 3640 -- Extract_Call_Attributes -- 3641 ----------------------------- 3642 3643 procedure Extract_Call_Attributes 3644 (Call : Node_Id; 3645 Target_Id : out Entity_Id; 3646 Attrs : out Call_Attributes) 3647 is 3648 From_Source : Boolean; 3649 In_Declarations : Boolean; 3650 Is_Dispatching : Boolean; 3651 3652 begin 3653 -- Extraction for call markers 3654 3655 if Nkind (Call) = N_Call_Marker then 3656 Target_Id := Target (Call); 3657 From_Source := Is_Source_Call (Call); 3658 In_Declarations := Is_Declaration_Level_Node (Call); 3659 Is_Dispatching := Is_Dispatching_Call (Call); 3660 3661 -- Extraction for entry calls, requeue, and subprogram calls 3662 3663 else 3664 pragma Assert (Nkind_In (Call, N_Entry_Call_Statement, 3665 N_Function_Call, 3666 N_Procedure_Call_Statement, 3667 N_Requeue_Statement)); 3668 3669 Target_Id := Entity (Extract_Call_Name (Call)); 3670 From_Source := Comes_From_Source (Call); 3671 3672 -- Performance note: parent traversal 3673 3674 In_Declarations := Find_Enclosing_Level (Call) = Declaration_Level; 3675 Is_Dispatching := 3676 Nkind_In (Call, N_Function_Call, N_Procedure_Call_Statement) 3677 and then Present (Controlling_Argument (Call)); 3678 end if; 3679 3680 -- Obtain the original entry or subprogram which the target may rename 3681 -- except when the target is an instantiation. In this case the alias 3682 -- is the internally generated subprogram which appears within the the 3683 -- anonymous package created for the instantiation. Such an alias is not 3684 -- a suitable target. 3685 3686 if not (Is_Subprogram (Target_Id) 3687 and then Is_Generic_Instance (Target_Id)) 3688 then 3689 Target_Id := Get_Renamed_Entity (Target_Id); 3690 end if; 3691 3692 -- Set all attributes 3693 3694 Attrs.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Call); 3695 Attrs.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Node (Call); 3696 Attrs.From_Source := From_Source; 3697 Attrs.Ghost_Mode_Ignore := Is_Ignored_Ghost_Node (Call); 3698 Attrs.In_Declarations := In_Declarations; 3699 Attrs.Is_Dispatching := Is_Dispatching; 3700 Attrs.SPARK_Mode_On := Is_SPARK_Mode_On_Node (Call); 3701 end Extract_Call_Attributes; 3702 3703 ----------------------- 3704 -- Extract_Call_Name -- 3705 ----------------------- 3706 3707 function Extract_Call_Name (Call : Node_Id) return Node_Id is 3708 Nam : Node_Id; 3709 3710 begin 3711 Nam := Name (Call); 3712 3713 -- When the call invokes an entry family, the name appears as an indexed 3714 -- component. 3715 3716 if Nkind (Nam) = N_Indexed_Component then 3717 Nam := Prefix (Nam); 3718 end if; 3719 3720 -- When the call employs the object.operation form, the name appears as 3721 -- a selected component. 3722 3723 if Nkind (Nam) = N_Selected_Component then 3724 Nam := Selector_Name (Nam); 3725 end if; 3726 3727 return Nam; 3728 end Extract_Call_Name; 3729 3730 --------------------------------- 3731 -- Extract_Instance_Attributes -- 3732 --------------------------------- 3733 3734 procedure Extract_Instance_Attributes 3735 (Exp_Inst : Node_Id; 3736 Inst_Body : out Node_Id; 3737 Inst_Decl : out Node_Id) 3738 is 3739 Body_Id : Entity_Id; 3740 3741 begin 3742 -- Assume that the attributes are unavailable 3743 3744 Inst_Body := Empty; 3745 Inst_Decl := Empty; 3746 3747 -- Generic package or subprogram spec 3748 3749 if Nkind_In (Exp_Inst, N_Package_Declaration, 3750 N_Subprogram_Declaration) 3751 then 3752 Inst_Decl := Exp_Inst; 3753 Body_Id := Corresponding_Body (Inst_Decl); 3754 3755 if Present (Body_Id) then 3756 Inst_Body := Unit_Declaration_Node (Body_Id); 3757 end if; 3758 3759 -- Generic package or subprogram body 3760 3761 else 3762 pragma Assert 3763 (Nkind_In (Exp_Inst, N_Package_Body, N_Subprogram_Body)); 3764 3765 Inst_Body := Exp_Inst; 3766 Inst_Decl := Unit_Declaration_Node (Corresponding_Spec (Inst_Body)); 3767 end if; 3768 end Extract_Instance_Attributes; 3769 3770 -------------------------------------- 3771 -- Extract_Instantiation_Attributes -- 3772 -------------------------------------- 3773 3774 procedure Extract_Instantiation_Attributes 3775 (Exp_Inst : Node_Id; 3776 Inst : out Node_Id; 3777 Inst_Id : out Entity_Id; 3778 Gen_Id : out Entity_Id; 3779 Attrs : out Instantiation_Attributes) 3780 is 3781 begin 3782 Inst := Original_Node (Exp_Inst); 3783 Inst_Id := Defining_Entity (Inst); 3784 3785 -- Traverse a possible chain of renamings to obtain the original generic 3786 -- being instantiatied. 3787 3788 Gen_Id := Get_Renamed_Entity (Entity (Name (Inst))); 3789 3790 -- Set all attributes 3791 3792 Attrs.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Inst); 3793 Attrs.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Node (Inst); 3794 Attrs.Ghost_Mode_Ignore := Is_Ignored_Ghost_Node (Inst); 3795 Attrs.In_Declarations := Is_Declaration_Level_Node (Inst); 3796 Attrs.SPARK_Mode_On := Is_SPARK_Mode_On_Node (Inst); 3797 end Extract_Instantiation_Attributes; 3798 3799 ------------------------------- 3800 -- Extract_Target_Attributes -- 3801 ------------------------------- 3802 3803 procedure Extract_Target_Attributes 3804 (Target_Id : Entity_Id; 3805 Attrs : out Target_Attributes) 3806 is 3807 procedure Extract_Package_Or_Subprogram_Attributes 3808 (Spec_Id : out Entity_Id; 3809 Body_Decl : out Node_Id); 3810 -- Obtain the attributes associated with a package or a subprogram. 3811 -- Spec_Id is the package or subprogram. Body_Decl is the declaration 3812 -- of the corresponding package or subprogram body. 3813 3814 procedure Extract_Protected_Entry_Attributes 3815 (Spec_Id : out Entity_Id; 3816 Body_Decl : out Node_Id; 3817 Body_Barf : out Node_Id); 3818 -- Obtain the attributes associated with a protected entry [family]. 3819 -- Spec_Id is the entity of the protected body subprogram. Body_Decl 3820 -- is the declaration of Spec_Id's corresponding body. Body_Barf is 3821 -- the declaration of the barrier function body. 3822 3823 procedure Extract_Protected_Subprogram_Attributes 3824 (Spec_Id : out Entity_Id; 3825 Body_Decl : out Node_Id); 3826 -- Obtain the attributes associated with a protected subprogram. Formal 3827 -- Spec_Id is the entity of the protected body subprogram. Body_Decl is 3828 -- the declaration of Spec_Id's corresponding body. 3829 3830 procedure Extract_Task_Entry_Attributes 3831 (Spec_Id : out Entity_Id; 3832 Body_Decl : out Node_Id); 3833 -- Obtain the attributes associated with a task entry [family]. Formal 3834 -- Spec_Id is the entity of the task body procedure. Body_Decl is the 3835 -- declaration of Spec_Id's corresponding body. 3836 3837 ---------------------------------------------- 3838 -- Extract_Package_Or_Subprogram_Attributes -- 3839 ---------------------------------------------- 3840 3841 procedure Extract_Package_Or_Subprogram_Attributes 3842 (Spec_Id : out Entity_Id; 3843 Body_Decl : out Node_Id) 3844 is 3845 Body_Id : Entity_Id; 3846 Init_Id : Entity_Id; 3847 Spec_Decl : Node_Id; 3848 3849 begin 3850 -- Assume that the body is not available 3851 3852 Body_Decl := Empty; 3853 Spec_Id := Target_Id; 3854 3855 -- For body retrieval purposes, the entity of the initial declaration 3856 -- is that of the spec. 3857 3858 Init_Id := Spec_Id; 3859 3860 -- The only exception to the above is a function which returns a 3861 -- constrained array type in a SPARK-to-C compilation. In this case 3862 -- the function receives a corresponding procedure which has an out 3863 -- parameter. The proper body for ABE checks and diagnostics is that 3864 -- of the procedure. 3865 3866 if Ekind (Init_Id) = E_Function 3867 and then Rewritten_For_C (Init_Id) 3868 then 3869 Init_Id := Corresponding_Procedure (Init_Id); 3870 end if; 3871 3872 -- Extract the attributes of the body 3873 3874 Spec_Decl := Unit_Declaration_Node (Init_Id); 3875 3876 -- The initial declaration is a stand alone subprogram body 3877 3878 if Nkind (Spec_Decl) = N_Subprogram_Body then 3879 Body_Decl := Spec_Decl; 3880 3881 -- Otherwise the package or subprogram has a spec and a completing 3882 -- body. 3883 3884 elsif Nkind_In (Spec_Decl, N_Generic_Package_Declaration, 3885 N_Generic_Subprogram_Declaration, 3886 N_Package_Declaration, 3887 N_Subprogram_Body_Stub, 3888 N_Subprogram_Declaration) 3889 then 3890 Body_Id := Corresponding_Body (Spec_Decl); 3891 3892 if Present (Body_Id) then 3893 Body_Decl := Unit_Declaration_Node (Body_Id); 3894 end if; 3895 end if; 3896 end Extract_Package_Or_Subprogram_Attributes; 3897 3898 ---------------------------------------- 3899 -- Extract_Protected_Entry_Attributes -- 3900 ---------------------------------------- 3901 3902 procedure Extract_Protected_Entry_Attributes 3903 (Spec_Id : out Entity_Id; 3904 Body_Decl : out Node_Id; 3905 Body_Barf : out Node_Id) 3906 is 3907 Barf_Id : Entity_Id; 3908 Body_Id : Entity_Id; 3909 3910 begin 3911 -- Assume that the bodies are not available 3912 3913 Body_Barf := Empty; 3914 Body_Decl := Empty; 3915 3916 -- When the entry [family] has already been expanded, it carries both 3917 -- the procedure which emulates the behavior of the entry [family] as 3918 -- well as the barrier function. 3919 3920 if Present (Protected_Body_Subprogram (Target_Id)) then 3921 Spec_Id := Protected_Body_Subprogram (Target_Id); 3922 3923 -- Extract the attributes of the barrier function 3924 3925 Barf_Id := 3926 Corresponding_Body 3927 (Unit_Declaration_Node (Barrier_Function (Target_Id))); 3928 3929 if Present (Barf_Id) then 3930 Body_Barf := Unit_Declaration_Node (Barf_Id); 3931 end if; 3932 3933 -- Otherwise no expansion took place 3934 3935 else 3936 Spec_Id := Target_Id; 3937 end if; 3938 3939 -- Extract the attributes of the entry body 3940 3941 Body_Id := Corresponding_Body (Unit_Declaration_Node (Spec_Id)); 3942 3943 if Present (Body_Id) then 3944 Body_Decl := Unit_Declaration_Node (Body_Id); 3945 end if; 3946 end Extract_Protected_Entry_Attributes; 3947 3948 --------------------------------------------- 3949 -- Extract_Protected_Subprogram_Attributes -- 3950 --------------------------------------------- 3951 3952 procedure Extract_Protected_Subprogram_Attributes 3953 (Spec_Id : out Entity_Id; 3954 Body_Decl : out Node_Id) 3955 is 3956 Body_Id : Entity_Id; 3957 3958 begin 3959 -- Assume that the body is not available 3960 3961 Body_Decl := Empty; 3962 3963 -- When the protected subprogram has already been expanded, it 3964 -- carries the subprogram which seizes the lock and invokes the 3965 -- original statements. 3966 3967 if Present (Protected_Subprogram (Target_Id)) then 3968 Spec_Id := 3969 Protected_Body_Subprogram (Protected_Subprogram (Target_Id)); 3970 3971 -- Otherwise no expansion took place 3972 3973 else 3974 Spec_Id := Target_Id; 3975 end if; 3976 3977 -- Extract the attributes of the body 3978 3979 Body_Id := Corresponding_Body (Unit_Declaration_Node (Spec_Id)); 3980 3981 if Present (Body_Id) then 3982 Body_Decl := Unit_Declaration_Node (Body_Id); 3983 end if; 3984 end Extract_Protected_Subprogram_Attributes; 3985 3986 ----------------------------------- 3987 -- Extract_Task_Entry_Attributes -- 3988 ----------------------------------- 3989 3990 procedure Extract_Task_Entry_Attributes 3991 (Spec_Id : out Entity_Id; 3992 Body_Decl : out Node_Id) 3993 is 3994 Task_Typ : constant Entity_Id := Non_Private_View (Scope (Target_Id)); 3995 Body_Id : Entity_Id; 3996 3997 begin 3998 -- Assume that the body is not available 3999 4000 Body_Decl := Empty; 4001 4002 -- The the task type has already been expanded, it carries the 4003 -- procedure which emulates the behavior of the task body. 4004 4005 if Present (Task_Body_Procedure (Task_Typ)) then 4006 Spec_Id := Task_Body_Procedure (Task_Typ); 4007 4008 -- Otherwise no expansion took place 4009 4010 else 4011 Spec_Id := Task_Typ; 4012 end if; 4013 4014 -- Extract the attributes of the body 4015 4016 Body_Id := Corresponding_Body (Unit_Declaration_Node (Spec_Id)); 4017 4018 if Present (Body_Id) then 4019 Body_Decl := Unit_Declaration_Node (Body_Id); 4020 end if; 4021 end Extract_Task_Entry_Attributes; 4022 4023 -- Local variables 4024 4025 Prag : constant Node_Id := SPARK_Pragma (Target_Id); 4026 Body_Barf : Node_Id; 4027 Body_Decl : Node_Id; 4028 Spec_Id : Entity_Id; 4029 4030 -- Start of processing for Extract_Target_Attributes 4031 4032 begin 4033 -- Assume that the body of the barrier function is not available 4034 4035 Body_Barf := Empty; 4036 4037 -- The target is a protected entry [family] 4038 4039 if Is_Protected_Entry (Target_Id) then 4040 Extract_Protected_Entry_Attributes 4041 (Spec_Id => Spec_Id, 4042 Body_Decl => Body_Decl, 4043 Body_Barf => Body_Barf); 4044 4045 -- The target is a protected subprogram 4046 4047 elsif Is_Protected_Subp (Target_Id) 4048 or else Is_Protected_Body_Subp (Target_Id) 4049 then 4050 Extract_Protected_Subprogram_Attributes 4051 (Spec_Id => Spec_Id, 4052 Body_Decl => Body_Decl); 4053 4054 -- The target is a task entry [family] 4055 4056 elsif Is_Task_Entry (Target_Id) then 4057 Extract_Task_Entry_Attributes 4058 (Spec_Id => Spec_Id, 4059 Body_Decl => Body_Decl); 4060 4061 -- Otherwise the target is a package or a subprogram 4062 4063 else 4064 Extract_Package_Or_Subprogram_Attributes 4065 (Spec_Id => Spec_Id, 4066 Body_Decl => Body_Decl); 4067 end if; 4068 4069 -- Set all attributes 4070 4071 Attrs.Body_Barf := Body_Barf; 4072 Attrs.Body_Decl := Body_Decl; 4073 Attrs.Elab_Checks_OK := Is_Elaboration_Checks_OK_Id (Target_Id); 4074 Attrs.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Id (Target_Id); 4075 Attrs.From_Source := Comes_From_Source (Target_Id); 4076 Attrs.Ghost_Mode_Ignore := Is_Ignored_Ghost_Entity (Target_Id); 4077 Attrs.SPARK_Mode_On := 4078 Present (Prag) and then Get_SPARK_Mode_From_Annotation (Prag) = On; 4079 Attrs.Spec_Decl := Unit_Declaration_Node (Spec_Id); 4080 Attrs.Spec_Id := Spec_Id; 4081 Attrs.Unit_Id := Find_Top_Unit (Target_Id); 4082 4083 -- At this point certain attributes should always be available 4084 4085 pragma Assert (Present (Attrs.Spec_Decl)); 4086 pragma Assert (Present (Attrs.Spec_Id)); 4087 pragma Assert (Present (Attrs.Unit_Id)); 4088 end Extract_Target_Attributes; 4089 4090 ----------------------------- 4091 -- Extract_Task_Attributes -- 4092 ----------------------------- 4093 4094 procedure Extract_Task_Attributes 4095 (Typ : Entity_Id; 4096 Attrs : out Task_Attributes) 4097 is 4098 Task_Typ : constant Entity_Id := Non_Private_View (Typ); 4099 4100 Body_Decl : Node_Id; 4101 Body_Id : Entity_Id; 4102 Prag : Node_Id; 4103 Spec_Id : Entity_Id; 4104 4105 begin 4106 -- Assume that the body of the task procedure is not available 4107 4108 Body_Decl := Empty; 4109 4110 -- The initial declaration is that of the task body procedure 4111 4112 Spec_Id := Get_Task_Body_Procedure (Task_Typ); 4113 Body_Id := Corresponding_Body (Unit_Declaration_Node (Spec_Id)); 4114 4115 if Present (Body_Id) then 4116 Body_Decl := Unit_Declaration_Node (Body_Id); 4117 end if; 4118 4119 Prag := SPARK_Pragma (Task_Typ); 4120 4121 -- Set all attributes 4122 4123 Attrs.Body_Decl := Body_Decl; 4124 Attrs.Elab_Checks_OK := Is_Elaboration_Checks_OK_Id (Task_Typ); 4125 Attrs.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Id (Task_Typ); 4126 Attrs.Ghost_Mode_Ignore := Is_Ignored_Ghost_Entity (Task_Typ); 4127 Attrs.SPARK_Mode_On := 4128 Present (Prag) and then Get_SPARK_Mode_From_Annotation (Prag) = On; 4129 Attrs.Spec_Id := Spec_Id; 4130 Attrs.Task_Decl := Declaration_Node (Task_Typ); 4131 Attrs.Unit_Id := Find_Top_Unit (Task_Typ); 4132 4133 -- At this point certain attributes should always be available 4134 4135 pragma Assert (Present (Attrs.Spec_Id)); 4136 pragma Assert (Present (Attrs.Task_Decl)); 4137 pragma Assert (Present (Attrs.Unit_Id)); 4138 end Extract_Task_Attributes; 4139 4140 ------------------------------------------- 4141 -- Extract_Variable_Reference_Attributes -- 4142 ------------------------------------------- 4143 4144 procedure Extract_Variable_Reference_Attributes 4145 (Ref : Node_Id; 4146 Var_Id : out Entity_Id; 4147 Attrs : out Variable_Attributes) 4148 is 4149 function Get_Renamed_Variable (Id : Entity_Id) return Entity_Id; 4150 -- Obtain the ultimate renamed variable of variable Id 4151 4152 -------------------------- 4153 -- Get_Renamed_Variable -- 4154 -------------------------- 4155 4156 function Get_Renamed_Variable (Id : Entity_Id) return Entity_Id is 4157 Ren_Id : Entity_Id; 4158 4159 begin 4160 Ren_Id := Id; 4161 while Present (Renamed_Entity (Ren_Id)) 4162 and then Nkind (Renamed_Entity (Ren_Id)) in N_Entity 4163 loop 4164 Ren_Id := Renamed_Entity (Ren_Id); 4165 end loop; 4166 4167 return Ren_Id; 4168 end Get_Renamed_Variable; 4169 4170 -- Start of processing for Extract_Variable_Reference_Attributes 4171 4172 begin 4173 -- Extraction for variable reference markers 4174 4175 if Nkind (Ref) = N_Variable_Reference_Marker then 4176 Var_Id := Target (Ref); 4177 4178 -- Extraction for expanded names and identifiers 4179 4180 else 4181 Var_Id := Entity (Ref); 4182 end if; 4183 4184 -- Obtain the original variable which the reference mentions 4185 4186 Var_Id := Get_Renamed_Variable (Var_Id); 4187 Attrs.Unit_Id := Find_Top_Unit (Var_Id); 4188 4189 -- At this point certain attributes should always be available 4190 4191 pragma Assert (Present (Attrs.Unit_Id)); 4192 end Extract_Variable_Reference_Attributes; 4193 4194 -------------------- 4195 -- Find_Code_Unit -- 4196 -------------------- 4197 4198 function Find_Code_Unit (N : Node_Or_Entity_Id) return Entity_Id is 4199 begin 4200 return Find_Unit_Entity (Unit (Cunit (Get_Code_Unit (N)))); 4201 end Find_Code_Unit; 4202 4203 ---------------------------- 4204 -- Find_Early_Call_Region -- 4205 ---------------------------- 4206 4207 function Find_Early_Call_Region 4208 (Body_Decl : Node_Id; 4209 Assume_Elab_Body : Boolean := False; 4210 Skip_Memoization : Boolean := False) return Node_Id 4211 is 4212 -- NOTE: The routines within Find_Early_Call_Region are intentionally 4213 -- unnested to avoid deep indentation of code. 4214 4215 ECR_Found : exception; 4216 -- This exception is raised when the early call region has been found 4217 4218 Start : Node_Id := Empty; 4219 -- The start of the early call region. This variable is updated by the 4220 -- various nested routines. Due to the use of exceptions, the variable 4221 -- must be global to the nested routines. 4222 4223 -- The algorithm implemented in this routine attempts to find the early 4224 -- call region of a subprogram body by inspecting constructs in reverse 4225 -- declarative order, while navigating the tree. The algorithm consists 4226 -- of an Inspection phase and an Advancement phase. The pseudocode is as 4227 -- follows: 4228 -- 4229 -- loop 4230 -- inspection phase 4231 -- advancement phase 4232 -- end loop 4233 -- 4234 -- The infinite loop is terminated by raising exception ECR_Found. The 4235 -- algorithm utilizes two pointers, Curr and Start, to represent the 4236 -- current construct to inspect and the start of the early call region. 4237 -- 4238 -- IMPORTANT: The algorithm must maintain the following invariant at all 4239 -- time for it to function properly - a nested construct is entered only 4240 -- when it contains suitable constructs. This guarantees that leaving a 4241 -- nested or encapsulating construct functions properly. 4242 -- 4243 -- The Inspection phase determines whether the current construct is non- 4244 -- preelaborable, and if it is, the algorithm terminates. 4245 -- 4246 -- The Advancement phase walks the tree in reverse declarative order, 4247 -- while entering and leaving nested and encapsulating constructs. It 4248 -- may also terminate the elaborithm. There are several special cases 4249 -- of advancement. 4250 -- 4251 -- 1) General case: 4252 -- 4253 -- <construct 1> 4254 -- ... 4255 -- <construct N-1> <- Curr 4256 -- <construct N> <- Start 4257 -- <subprogram body> 4258 -- 4259 -- In the general case, a declarative or statement list is traversed in 4260 -- reverse order where Curr is the lead pointer, and Start indicates the 4261 -- last preelaborable construct. 4262 -- 4263 -- 2) Entering handled bodies 4264 -- 4265 -- package body Nested is <- Curr (2.3) 4266 -- <declarations> <- Curr (2.2) 4267 -- begin 4268 -- <statements> <- Curr (2.1) 4269 -- end Nested; 4270 -- <construct> <- Start 4271 -- 4272 -- In this case, the algorithm enters a handled body by starting from 4273 -- the last statement (2.1), or the last declaration (2.2), or the body 4274 -- is consumed (2.3) because it is empty and thus preelaborable. 4275 -- 4276 -- 3) Entering package declarations 4277 -- 4278 -- package Nested is <- Curr (2.3) 4279 -- <visible declarations> <- Curr (2.2) 4280 -- private 4281 -- <private declarations> <- Curr (2.1) 4282 -- end Nested; 4283 -- <construct> <- Start 4284 -- 4285 -- In this case, the algorithm enters a package declaration by starting 4286 -- from the last private declaration (2.1), the last visible declaration 4287 -- (2.2), or the package is consumed (2.3) because it is empty and thus 4288 -- preelaborable. 4289 -- 4290 -- 4) Transitioning from list to list of the same construct 4291 -- 4292 -- Certain constructs have two eligible lists. The algorithm must thus 4293 -- transition from the second to the first list when the second list is 4294 -- exhausted. 4295 -- 4296 -- declare <- Curr (4.2) 4297 -- <declarations> <- Curr (4.1) 4298 -- begin 4299 -- <statements> <- Start 4300 -- end; 4301 -- 4302 -- In this case, the algorithm has exhausted the second list (statements 4303 -- in the example), and continues with the last declaration (4.1) or the 4304 -- construct is consumed (4.2) because it contains only preelaborable 4305 -- code. 4306 -- 4307 -- 5) Transitioning from list to construct 4308 -- 4309 -- tack body Task is <- Curr (5.1) 4310 -- <- Curr (Empty) 4311 -- <construct 1> <- Start 4312 -- 4313 -- In this case, the algorithm has exhausted a list, Curr is Empty, and 4314 -- the owner of the list is consumed (5.1). 4315 -- 4316 -- 6) Transitioning from unit to unit 4317 -- 4318 -- A package body with a spec subject to pragma Elaborate_Body extends 4319 -- the possible range of the early call region to the package spec. 4320 -- 4321 -- package Pack is <- Curr (6.3) 4322 -- pragma Elaborate_Body; <- Curr (6.2) 4323 -- <visible declarations> <- Curr (6.2) 4324 -- private 4325 -- <private declarations> <- Curr (6.1) 4326 -- end Pack; 4327 -- 4328 -- package body Pack is <- Curr, Start 4329 -- 4330 -- In this case, the algorithm has reached a package body compilation 4331 -- unit whose spec is subject to pragma Elaborate_Body, or the caller 4332 -- of the algorithm has specified this behavior. This transition is 4333 -- equivalent to 3). 4334 -- 4335 -- 7) Transitioning from unit to termination 4336 -- 4337 -- Reaching a compilation unit always terminates the algorithm as there 4338 -- are no more lists to examine. This must take 6) into account. 4339 -- 4340 -- 8) Transitioning from subunit to stub 4341 -- 4342 -- package body Pack is separate; <- Curr (8.1) 4343 -- 4344 -- separate (...) 4345 -- package body Pack is <- Curr, Start 4346 -- 4347 -- Reaching a subunit continues the search from the corresponding stub 4348 -- (8.1). 4349 4350 procedure Advance (Curr : in out Node_Id); 4351 pragma Inline (Advance); 4352 -- Update the Curr and Start pointers depending on their location in the 4353 -- tree to the next eligible construct. This routine raises ECR_Found. 4354 4355 procedure Enter_Handled_Body (Curr : in out Node_Id); 4356 pragma Inline (Enter_Handled_Body); 4357 -- Update the Curr and Start pointers to enter a nested handled body if 4358 -- applicable. This routine raises ECR_Found. 4359 4360 procedure Enter_Package_Declaration (Curr : in out Node_Id); 4361 pragma Inline (Enter_Package_Declaration); 4362 -- Update the Curr and Start pointers to enter a nested package spec if 4363 -- applicable. This routine raises ECR_Found. 4364 4365 function Find_ECR (N : Node_Id) return Node_Id; 4366 pragma Inline (Find_ECR); 4367 -- Find an early call region starting from arbitrary node N 4368 4369 function Has_Suitable_Construct (List : List_Id) return Boolean; 4370 pragma Inline (Has_Suitable_Construct); 4371 -- Determine whether list List contains at least one suitable construct 4372 -- for inclusion into an early call region. 4373 4374 procedure Include (N : Node_Id; Curr : out Node_Id); 4375 pragma Inline (Include); 4376 -- Update the Curr and Start pointers to include arbitrary construct N 4377 -- in the early call region. This routine raises ECR_Found. 4378 4379 function Is_OK_Preelaborable_Construct (N : Node_Id) return Boolean; 4380 pragma Inline (Is_OK_Preelaborable_Construct); 4381 -- Determine whether arbitrary node N denotes a preelaboration-safe 4382 -- construct. 4383 4384 function Is_Suitable_Construct (N : Node_Id) return Boolean; 4385 pragma Inline (Is_Suitable_Construct); 4386 -- Determine whether arbitrary node N denotes a suitable construct for 4387 -- inclusion into the early call region. 4388 4389 procedure Transition_Body_Declarations 4390 (Bod : Node_Id; 4391 Curr : out Node_Id); 4392 pragma Inline (Transition_Body_Declarations); 4393 -- Update the Curr and Start pointers when construct Bod denotes a block 4394 -- statement or a suitable body. This routine raises ECR_Found. 4395 4396 procedure Transition_Handled_Statements 4397 (HSS : Node_Id; 4398 Curr : out Node_Id); 4399 pragma Inline (Transition_Handled_Statements); 4400 -- Update the Curr and Start pointers when node HSS denotes a handled 4401 -- sequence of statements. This routine raises ECR_Found. 4402 4403 procedure Transition_Spec_Declarations 4404 (Spec : Node_Id; 4405 Curr : out Node_Id); 4406 pragma Inline (Transition_Spec_Declarations); 4407 -- Update the Curr and Start pointers when construct Spec denotes 4408 -- a concurrent definition or a package spec. This routine raises 4409 -- ECR_Found. 4410 4411 procedure Transition_Unit (Unit : Node_Id; Curr : out Node_Id); 4412 pragma Inline (Transition_Unit); 4413 -- Update the Curr and Start pointers when node Unit denotes a potential 4414 -- compilation unit. This routine raises ECR_Found. 4415 4416 ------------- 4417 -- Advance -- 4418 ------------- 4419 4420 procedure Advance (Curr : in out Node_Id) is 4421 Context : Node_Id; 4422 4423 begin 4424 -- Curr denotes one of the following cases upon entry into this 4425 -- routine: 4426 -- 4427 -- * Empty - There is no current construct when a declarative or a 4428 -- statement list has been exhausted. This does not necessarily 4429 -- indicate that the early call region has been computed as it 4430 -- may still be possible to transition to another list. 4431 -- 4432 -- * Encapsulator - The current construct encapsulates declarations 4433 -- and/or statements. This indicates that the early call region 4434 -- may extend within the nested construct. 4435 -- 4436 -- * Preelaborable - The current construct is always preelaborable 4437 -- because Find_ECR would not invoke Advance if this was not the 4438 -- case. 4439 4440 -- The current construct is an encapsulator or is preelaborable 4441 4442 if Present (Curr) then 4443 4444 -- Enter encapsulators by inspecting their declarations and/or 4445 -- statements. 4446 4447 if Nkind_In (Curr, N_Block_Statement, N_Package_Body) then 4448 Enter_Handled_Body (Curr); 4449 4450 elsif Nkind (Curr) = N_Package_Declaration then 4451 Enter_Package_Declaration (Curr); 4452 4453 -- Early call regions have a property which can be exploited to 4454 -- optimize the algorithm. 4455 -- 4456 -- <preceding subprogram body> 4457 -- <preelaborable construct 1> 4458 -- ... 4459 -- <preelaborable construct N> 4460 -- <initiating subprogram body> 4461 -- 4462 -- If a traversal initiated from a subprogram body reaches a 4463 -- preceding subprogram body, then both bodies share the same 4464 -- early call region. 4465 -- 4466 -- The property results in the following desirable effects: 4467 -- 4468 -- * If the preceding body already has an early call region, then 4469 -- the initiating body can reuse it. This minimizes the amount 4470 -- of processing performed by the algorithm. 4471 -- 4472 -- * If the preceding body lack an early call region, then the 4473 -- algorithm can compute the early call region, and reuse it 4474 -- for the initiating body. This processing performs the same 4475 -- amount of work, but has the beneficial effect of computing 4476 -- the early call regions of all preceding bodies. 4477 4478 elsif Nkind_In (Curr, N_Entry_Body, N_Subprogram_Body) then 4479 Start := 4480 Find_Early_Call_Region 4481 (Body_Decl => Curr, 4482 Assume_Elab_Body => Assume_Elab_Body, 4483 Skip_Memoization => Skip_Memoization); 4484 4485 raise ECR_Found; 4486 4487 -- Otherwise current construct is preelaborable. Unpdate the early 4488 -- call region to include it. 4489 4490 else 4491 Include (Curr, Curr); 4492 end if; 4493 4494 -- Otherwise the current construct is missing, indicating that the 4495 -- current list has been exhausted. Depending on the context of the 4496 -- list, several transitions are possible. 4497 4498 else 4499 -- The invariant of the algorithm ensures that Curr and Start are 4500 -- at the same level of nesting at the point of a transition. The 4501 -- algorithm can determine which list the traversal came from by 4502 -- examining Start. 4503 4504 Context := Parent (Start); 4505 4506 -- Attempt the following transitions: 4507 -- 4508 -- private declarations -> visible declarations 4509 -- private declarations -> upper level 4510 -- private declarations -> terminate 4511 -- visible declarations -> upper level 4512 -- visible declarations -> terminate 4513 4514 if Nkind_In (Context, N_Package_Specification, 4515 N_Protected_Definition, 4516 N_Task_Definition) 4517 then 4518 Transition_Spec_Declarations (Context, Curr); 4519 4520 -- Attempt the following transitions: 4521 -- 4522 -- statements -> declarations 4523 -- statements -> upper level 4524 -- statements -> corresponding package spec (Elab_Body) 4525 -- statements -> terminate 4526 4527 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements then 4528 Transition_Handled_Statements (Context, Curr); 4529 4530 -- Attempt the following transitions: 4531 -- 4532 -- declarations -> upper level 4533 -- declarations -> corresponding package spec (Elab_Body) 4534 -- declarations -> terminate 4535 4536 elsif Nkind_In (Context, N_Block_Statement, 4537 N_Entry_Body, 4538 N_Package_Body, 4539 N_Protected_Body, 4540 N_Subprogram_Body, 4541 N_Task_Body) 4542 then 4543 Transition_Body_Declarations (Context, Curr); 4544 4545 -- Otherwise it is not possible to transition. Stop the search 4546 -- because there are no more declarations or statements to check. 4547 4548 else 4549 raise ECR_Found; 4550 end if; 4551 end if; 4552 end Advance; 4553 4554 -------------------------- 4555 -- Enter_Handled_Body -- 4556 -------------------------- 4557 4558 procedure Enter_Handled_Body (Curr : in out Node_Id) is 4559 Decls : constant List_Id := Declarations (Curr); 4560 HSS : constant Node_Id := Handled_Statement_Sequence (Curr); 4561 Stmts : List_Id := No_List; 4562 4563 begin 4564 if Present (HSS) then 4565 Stmts := Statements (HSS); 4566 end if; 4567 4568 -- The handled body has a non-empty statement sequence. The construct 4569 -- to inspect is the last statement. 4570 4571 if Has_Suitable_Construct (Stmts) then 4572 Curr := Last (Stmts); 4573 4574 -- The handled body lacks statements, but has non-empty declarations. 4575 -- The construct to inspect is the last declaration. 4576 4577 elsif Has_Suitable_Construct (Decls) then 4578 Curr := Last (Decls); 4579 4580 -- Otherwise the handled body lacks both declarations and statements. 4581 -- The construct to inspect is the node which precedes the handled 4582 -- body. Update the early call region to include the handled body. 4583 4584 else 4585 Include (Curr, Curr); 4586 end if; 4587 end Enter_Handled_Body; 4588 4589 ------------------------------- 4590 -- Enter_Package_Declaration -- 4591 ------------------------------- 4592 4593 procedure Enter_Package_Declaration (Curr : in out Node_Id) is 4594 Pack_Spec : constant Node_Id := Specification (Curr); 4595 Prv_Decls : constant List_Id := Private_Declarations (Pack_Spec); 4596 Vis_Decls : constant List_Id := Visible_Declarations (Pack_Spec); 4597 4598 begin 4599 -- The package has a non-empty private declarations. The construct to 4600 -- inspect is the last private declaration. 4601 4602 if Has_Suitable_Construct (Prv_Decls) then 4603 Curr := Last (Prv_Decls); 4604 4605 -- The package lacks private declarations, but has non-empty visible 4606 -- declarations. In this case the construct to inspect is the last 4607 -- visible declaration. 4608 4609 elsif Has_Suitable_Construct (Vis_Decls) then 4610 Curr := Last (Vis_Decls); 4611 4612 -- Otherwise the package lacks any declarations. The construct to 4613 -- inspect is the node which precedes the package. Update the early 4614 -- call region to include the package declaration. 4615 4616 else 4617 Include (Curr, Curr); 4618 end if; 4619 end Enter_Package_Declaration; 4620 4621 -------------- 4622 -- Find_ECR -- 4623 -------------- 4624 4625 function Find_ECR (N : Node_Id) return Node_Id is 4626 Curr : Node_Id; 4627 4628 begin 4629 -- The early call region starts at N 4630 4631 Curr := Prev (N); 4632 Start := N; 4633 4634 -- Inspect each node in reverse declarative order while going in and 4635 -- out of nested and enclosing constructs. Note that the only way to 4636 -- terminate this infinite loop is to raise exception ECR_Found. 4637 4638 loop 4639 -- The current construct is not preelaboration-safe. Terminate the 4640 -- traversal. 4641 4642 if Present (Curr) 4643 and then not Is_OK_Preelaborable_Construct (Curr) 4644 then 4645 raise ECR_Found; 4646 end if; 4647 4648 -- Advance to the next suitable construct. This may terminate the 4649 -- traversal by raising ECR_Found. 4650 4651 Advance (Curr); 4652 end loop; 4653 4654 exception 4655 when ECR_Found => 4656 return Start; 4657 end Find_ECR; 4658 4659 ---------------------------- 4660 -- Has_Suitable_Construct -- 4661 ---------------------------- 4662 4663 function Has_Suitable_Construct (List : List_Id) return Boolean is 4664 Item : Node_Id; 4665 4666 begin 4667 -- Examine the list in reverse declarative order, looking for a 4668 -- suitable construct. 4669 4670 if Present (List) then 4671 Item := Last (List); 4672 while Present (Item) loop 4673 if Is_Suitable_Construct (Item) then 4674 return True; 4675 end if; 4676 4677 Prev (Item); 4678 end loop; 4679 end if; 4680 4681 return False; 4682 end Has_Suitable_Construct; 4683 4684 ------------- 4685 -- Include -- 4686 ------------- 4687 4688 procedure Include (N : Node_Id; Curr : out Node_Id) is 4689 begin 4690 Start := N; 4691 4692 -- The input node is a compilation unit. This terminates the search 4693 -- because there are no more lists to inspect and there are no more 4694 -- enclosing constructs to climb up to. The transitions are: 4695 -- 4696 -- private declarations -> terminate 4697 -- visible declarations -> terminate 4698 -- statements -> terminate 4699 -- declarations -> terminate 4700 4701 if Nkind (Parent (Start)) = N_Compilation_Unit then 4702 raise ECR_Found; 4703 4704 -- Otherwise the input node is still within some list 4705 4706 else 4707 Curr := Prev (Start); 4708 end if; 4709 end Include; 4710 4711 ----------------------------------- 4712 -- Is_OK_Preelaborable_Construct -- 4713 ----------------------------------- 4714 4715 function Is_OK_Preelaborable_Construct (N : Node_Id) return Boolean is 4716 begin 4717 -- Assignment statements are acceptable as long as they were produced 4718 -- by the ABE mechanism to update elaboration flags. 4719 4720 if Nkind (N) = N_Assignment_Statement then 4721 return Is_Elaboration_Code (N); 4722 4723 -- Block statements are acceptable even though they directly violate 4724 -- preelaborability. The intention is not to penalize the early call 4725 -- region when a block contains only preelaborable constructs. 4726 -- 4727 -- declare 4728 -- Val : constant Integer := 1; 4729 -- begin 4730 -- pragma Assert (Val = 1); 4731 -- null; 4732 -- end; 4733 -- 4734 -- Note that the Advancement phase does enter blocks, and will detect 4735 -- any non-preelaborable declarations or statements within. 4736 4737 elsif Nkind (N) = N_Block_Statement then 4738 return True; 4739 end if; 4740 4741 -- Otherwise the construct must be preelaborable. The check must take 4742 -- the syntactic and semantic structure of the construct. DO NOT use 4743 -- Is_Preelaborable_Construct here. 4744 4745 return not Is_Non_Preelaborable_Construct (N); 4746 end Is_OK_Preelaborable_Construct; 4747 4748 --------------------------- 4749 -- Is_Suitable_Construct -- 4750 --------------------------- 4751 4752 function Is_Suitable_Construct (N : Node_Id) return Boolean is 4753 Context : constant Node_Id := Parent (N); 4754 4755 begin 4756 -- An internally-generated statement sequence which contains only a 4757 -- single null statement is not a suitable construct because it is a 4758 -- byproduct of the parser. Such a null statement should be excluded 4759 -- from the early call region because it carries the source location 4760 -- of the "end" keyword, and may lead to confusing diagnistics. 4761 4762 if Nkind (N) = N_Null_Statement 4763 and then not Comes_From_Source (N) 4764 and then Present (Context) 4765 and then Nkind (Context) = N_Handled_Sequence_Of_Statements 4766 then 4767 return False; 4768 end if; 4769 4770 -- Otherwise only constructs which correspond to pure Ada constructs 4771 -- are considered suitable. 4772 4773 case Nkind (N) is 4774 when N_Call_Marker 4775 | N_Freeze_Entity 4776 | N_Freeze_Generic_Entity 4777 | N_Implicit_Label_Declaration 4778 | N_Itype_Reference 4779 | N_Pop_Constraint_Error_Label 4780 | N_Pop_Program_Error_Label 4781 | N_Pop_Storage_Error_Label 4782 | N_Push_Constraint_Error_Label 4783 | N_Push_Program_Error_Label 4784 | N_Push_Storage_Error_Label 4785 | N_SCIL_Dispatch_Table_Tag_Init 4786 | N_SCIL_Dispatching_Call 4787 | N_SCIL_Membership_Test 4788 | N_Variable_Reference_Marker 4789 => 4790 return False; 4791 4792 when others => 4793 return True; 4794 end case; 4795 end Is_Suitable_Construct; 4796 4797 ---------------------------------- 4798 -- Transition_Body_Declarations -- 4799 ---------------------------------- 4800 4801 procedure Transition_Body_Declarations 4802 (Bod : Node_Id; 4803 Curr : out Node_Id) 4804 is 4805 Decls : constant List_Id := Declarations (Bod); 4806 4807 begin 4808 -- The search must come from the declarations of the body 4809 4810 pragma Assert 4811 (Is_Non_Empty_List (Decls) 4812 and then List_Containing (Start) = Decls); 4813 4814 -- The search finished inspecting the declarations. The construct 4815 -- to inspect is the node which precedes the handled body, unless 4816 -- the body is a compilation unit. The transitions are: 4817 -- 4818 -- declarations -> upper level 4819 -- declarations -> corresponding package spec (Elab_Body) 4820 -- declarations -> terminate 4821 4822 Transition_Unit (Bod, Curr); 4823 end Transition_Body_Declarations; 4824 4825 ----------------------------------- 4826 -- Transition_Handled_Statements -- 4827 ----------------------------------- 4828 4829 procedure Transition_Handled_Statements 4830 (HSS : Node_Id; 4831 Curr : out Node_Id) 4832 is 4833 Bod : constant Node_Id := Parent (HSS); 4834 Decls : constant List_Id := Declarations (Bod); 4835 Stmts : constant List_Id := Statements (HSS); 4836 4837 begin 4838 -- The search must come from the statements of certain bodies or 4839 -- statements. 4840 4841 pragma Assert (Nkind_In (Bod, N_Block_Statement, 4842 N_Entry_Body, 4843 N_Package_Body, 4844 N_Protected_Body, 4845 N_Subprogram_Body, 4846 N_Task_Body)); 4847 4848 -- The search must come from the statements of the handled sequence 4849 4850 pragma Assert 4851 (Is_Non_Empty_List (Stmts) 4852 and then List_Containing (Start) = Stmts); 4853 4854 -- The search finished inspecting the statements. The handled body 4855 -- has non-empty declarations. The construct to inspect is the last 4856 -- declaration. The transitions are: 4857 -- 4858 -- statements -> declarations 4859 4860 if Has_Suitable_Construct (Decls) then 4861 Curr := Last (Decls); 4862 4863 -- Otherwise the handled body lacks declarations. The construct to 4864 -- inspect is the node which precedes the handled body, unless the 4865 -- body is a compilation unit. The transitions are: 4866 -- 4867 -- statements -> upper level 4868 -- statements -> corresponding package spec (Elab_Body) 4869 -- statements -> terminate 4870 4871 else 4872 Transition_Unit (Bod, Curr); 4873 end if; 4874 end Transition_Handled_Statements; 4875 4876 ---------------------------------- 4877 -- Transition_Spec_Declarations -- 4878 ---------------------------------- 4879 4880 procedure Transition_Spec_Declarations 4881 (Spec : Node_Id; 4882 Curr : out Node_Id) 4883 is 4884 Prv_Decls : constant List_Id := Private_Declarations (Spec); 4885 Vis_Decls : constant List_Id := Visible_Declarations (Spec); 4886 4887 begin 4888 pragma Assert (Present (Start) and then Is_List_Member (Start)); 4889 4890 -- The search came from the private declarations and finished their 4891 -- inspection. 4892 4893 if Has_Suitable_Construct (Prv_Decls) 4894 and then List_Containing (Start) = Prv_Decls 4895 then 4896 -- The context has non-empty visible declarations. The node to 4897 -- inspect is the last visible declaration. The transitions are: 4898 -- 4899 -- private declarations -> visible declarations 4900 4901 if Has_Suitable_Construct (Vis_Decls) then 4902 Curr := Last (Vis_Decls); 4903 4904 -- Otherwise the context lacks visible declarations. The construct 4905 -- to inspect is the node which precedes the context unless the 4906 -- context is a compilation unit. The transitions are: 4907 -- 4908 -- private declarations -> upper level 4909 -- private declarations -> terminate 4910 4911 else 4912 Transition_Unit (Parent (Spec), Curr); 4913 end if; 4914 4915 -- The search came from the visible declarations and finished their 4916 -- inspections. The construct to inspect is the node which precedes 4917 -- the context, unless the context is a compilaton unit. The 4918 -- transitions are: 4919 -- 4920 -- visible declarations -> upper level 4921 -- visible declarations -> terminate 4922 4923 elsif Has_Suitable_Construct (Vis_Decls) 4924 and then List_Containing (Start) = Vis_Decls 4925 then 4926 Transition_Unit (Parent (Spec), Curr); 4927 4928 -- At this point both declarative lists are empty, but the traversal 4929 -- still came from within the spec. This indicates that the invariant 4930 -- of the algorithm has been violated. 4931 4932 else 4933 pragma Assert (False); 4934 raise ECR_Found; 4935 end if; 4936 end Transition_Spec_Declarations; 4937 4938 --------------------- 4939 -- Transition_Unit -- 4940 --------------------- 4941 4942 procedure Transition_Unit 4943 (Unit : Node_Id; 4944 Curr : out Node_Id) 4945 is 4946 Context : constant Node_Id := Parent (Unit); 4947 4948 begin 4949 -- The unit is a compilation unit. This terminates the search because 4950 -- there are no more lists to inspect and there are no more enclosing 4951 -- constructs to climb up to. 4952 4953 if Nkind (Context) = N_Compilation_Unit then 4954 4955 -- A package body with a corresponding spec subject to pragma 4956 -- Elaborate_Body is an exception to the above. The annotation 4957 -- allows the search to continue into the package declaration. 4958 -- The transitions are: 4959 -- 4960 -- statements -> corresponding package spec (Elab_Body) 4961 -- declarations -> corresponding package spec (Elab_Body) 4962 4963 if Nkind (Unit) = N_Package_Body 4964 and then (Assume_Elab_Body 4965 or else Has_Pragma_Elaborate_Body 4966 (Corresponding_Spec (Unit))) 4967 then 4968 Curr := Unit_Declaration_Node (Corresponding_Spec (Unit)); 4969 Enter_Package_Declaration (Curr); 4970 4971 -- Otherwise terminate the search. The transitions are: 4972 -- 4973 -- private declarations -> terminate 4974 -- visible declarations -> terminate 4975 -- statements -> terminate 4976 -- declarations -> terminate 4977 4978 else 4979 raise ECR_Found; 4980 end if; 4981 4982 -- The unit is a subunit. The construct to inspect is the node which 4983 -- precedes the corresponding stub. Update the early call region to 4984 -- include the unit. 4985 4986 elsif Nkind (Context) = N_Subunit then 4987 Start := Unit; 4988 Curr := Corresponding_Stub (Context); 4989 4990 -- Otherwise the unit is nested. The construct to inspect is the node 4991 -- which precedes the unit. Update the early call region to include 4992 -- the unit. 4993 4994 else 4995 Include (Unit, Curr); 4996 end if; 4997 end Transition_Unit; 4998 4999 -- Local variables 5000 5001 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl); 5002 Region : Node_Id; 5003 5004 -- Start of processing for Find_Early_Call_Region 5005 5006 begin 5007 -- The caller demands the start of the early call region without saving 5008 -- or retrieving it to/from internal data structures. 5009 5010 if Skip_Memoization then 5011 Region := Find_ECR (Body_Decl); 5012 5013 -- Default behavior 5014 5015 else 5016 -- Check whether the early call region of the subprogram body is 5017 -- available. 5018 5019 Region := Early_Call_Region (Body_Id); 5020 5021 if No (Region) then 5022 5023 -- Traverse the declarations in reverse order, starting from the 5024 -- subprogram body, searching for the nearest non-preelaborable 5025 -- construct. The early call region starts after this construct 5026 -- and ends at the subprogram body. 5027 5028 Region := Find_ECR (Body_Decl); 5029 5030 -- Associate the early call region with the subprogram body in 5031 -- case other scenarios need it. 5032 5033 Set_Early_Call_Region (Body_Id, Region); 5034 end if; 5035 end if; 5036 5037 -- A subprogram body must always have an early call region 5038 5039 pragma Assert (Present (Region)); 5040 5041 return Region; 5042 end Find_Early_Call_Region; 5043 5044 --------------------------- 5045 -- Find_Elaborated_Units -- 5046 --------------------------- 5047 5048 procedure Find_Elaborated_Units is 5049 procedure Add_Pragma (Prag : Node_Id); 5050 -- Determine whether pragma Prag denotes a legal Elaborate[_All] pragma. 5051 -- If this is the case, add the related unit to the elaboration context. 5052 -- For pragma Elaborate_All, include recursively all units withed by the 5053 -- related unit. 5054 5055 procedure Add_Unit 5056 (Unit_Id : Entity_Id; 5057 Prag : Node_Id; 5058 Full_Context : Boolean); 5059 -- Add unit Unit_Id to the elaboration context. Prag denotes the pragma 5060 -- which prompted the inclusion of the unit to the elaboration context. 5061 -- If flag Full_Context is set, examine the nonlimited clauses of unit 5062 -- Unit_Id and add each withed unit to the context. 5063 5064 procedure Find_Elaboration_Context (Comp_Unit : Node_Id); 5065 -- Examine the context items of compilation unit Comp_Unit for suitable 5066 -- elaboration-related pragmas and add all related units to the context. 5067 5068 ---------------- 5069 -- Add_Pragma -- 5070 ---------------- 5071 5072 procedure Add_Pragma (Prag : Node_Id) is 5073 Prag_Args : constant List_Id := Pragma_Argument_Associations (Prag); 5074 Prag_Nam : constant Name_Id := Pragma_Name (Prag); 5075 Unit_Arg : Node_Id; 5076 5077 begin 5078 -- Nothing to do if the pragma is not related to elaboration 5079 5080 if not Nam_In (Prag_Nam, Name_Elaborate, Name_Elaborate_All) then 5081 return; 5082 5083 -- Nothing to do when the pragma is illegal 5084 5085 elsif Error_Posted (Prag) then 5086 return; 5087 end if; 5088 5089 Unit_Arg := Get_Pragma_Arg (First (Prag_Args)); 5090 5091 -- The argument of the pragma may appear in package.package form 5092 5093 if Nkind (Unit_Arg) = N_Selected_Component then 5094 Unit_Arg := Selector_Name (Unit_Arg); 5095 end if; 5096 5097 Add_Unit 5098 (Unit_Id => Entity (Unit_Arg), 5099 Prag => Prag, 5100 Full_Context => Prag_Nam = Name_Elaborate_All); 5101 end Add_Pragma; 5102 5103 -------------- 5104 -- Add_Unit -- 5105 -------------- 5106 5107 procedure Add_Unit 5108 (Unit_Id : Entity_Id; 5109 Prag : Node_Id; 5110 Full_Context : Boolean) 5111 is 5112 Clause : Node_Id; 5113 Elab_Attrs : Elaboration_Attributes; 5114 5115 begin 5116 -- Nothing to do when some previous error left a with clause or a 5117 -- pragma in a bad state. 5118 5119 if No (Unit_Id) then 5120 return; 5121 end if; 5122 5123 Elab_Attrs := Elaboration_Status (Unit_Id); 5124 5125 -- The unit is already included in the context by means of pragma 5126 -- Elaborate[_All]. 5127 5128 if Present (Elab_Attrs.Source_Pragma) then 5129 5130 -- Upgrade an existing pragma Elaborate when the unit is subject 5131 -- to Elaborate_All because the new pragma covers a larger set of 5132 -- units. 5133 5134 if Pragma_Name (Elab_Attrs.Source_Pragma) = Name_Elaborate 5135 and then Pragma_Name (Prag) = Name_Elaborate_All 5136 then 5137 Elab_Attrs.Source_Pragma := Prag; 5138 5139 -- Otherwise the unit retains its existing pragma and does not 5140 -- need to be included in the context again. 5141 5142 else 5143 return; 5144 end if; 5145 5146 -- The current unit is not part of the context. Prepare a new set of 5147 -- attributes. 5148 5149 else 5150 Elab_Attrs := 5151 Elaboration_Attributes'(Source_Pragma => Prag, 5152 With_Clause => Empty); 5153 end if; 5154 5155 -- Add or update the attributes of the unit 5156 5157 Set_Elaboration_Status (Unit_Id, Elab_Attrs); 5158 5159 -- Includes all units withed by the current one when computing the 5160 -- full context. 5161 5162 if Full_Context then 5163 5164 -- Process all nonlimited with clauses found in the context of 5165 -- the current unit. Note that limited clauses do not impose an 5166 -- elaboration order. 5167 5168 Clause := First (Context_Items (Compilation_Unit (Unit_Id))); 5169 while Present (Clause) loop 5170 if Nkind (Clause) = N_With_Clause 5171 and then not Error_Posted (Clause) 5172 and then not Limited_Present (Clause) 5173 then 5174 Add_Unit 5175 (Unit_Id => Entity (Name (Clause)), 5176 Prag => Prag, 5177 Full_Context => Full_Context); 5178 end if; 5179 5180 Next (Clause); 5181 end loop; 5182 end if; 5183 end Add_Unit; 5184 5185 ------------------------------ 5186 -- Find_Elaboration_Context -- 5187 ------------------------------ 5188 5189 procedure Find_Elaboration_Context (Comp_Unit : Node_Id) is 5190 Prag : Node_Id; 5191 5192 begin 5193 pragma Assert (Nkind (Comp_Unit) = N_Compilation_Unit); 5194 5195 -- Process all elaboration-related pragmas found in the context of 5196 -- the compilation unit. 5197 5198 Prag := First (Context_Items (Comp_Unit)); 5199 while Present (Prag) loop 5200 if Nkind (Prag) = N_Pragma then 5201 Add_Pragma (Prag); 5202 end if; 5203 5204 Next (Prag); 5205 end loop; 5206 end Find_Elaboration_Context; 5207 5208 -- Local variables 5209 5210 Par_Id : Entity_Id; 5211 Unt : Node_Id; 5212 5213 -- Start of processing for Find_Elaborated_Units 5214 5215 begin 5216 -- Perform a traversal which examines the context of the main unit and 5217 -- populates the Elaboration_Context table with all units elaborated 5218 -- prior to the main unit. The traversal performs the following jumps: 5219 5220 -- subunit -> parent subunit 5221 -- parent subunit -> body 5222 -- body -> spec 5223 -- spec -> parent spec 5224 -- parent spec -> grandparent spec and so on 5225 5226 -- The traversal relies on units rather than scopes because the scope of 5227 -- a subunit is some spec, while this traversal must process the body as 5228 -- well. Given that protected and task bodies can also be subunits, this 5229 -- complicates the scope approach even further. 5230 5231 Unt := Unit (Cunit (Main_Unit)); 5232 5233 -- Perform the following traversals when the main unit is a subunit 5234 5235 -- subunit -> parent subunit 5236 -- parent subunit -> body 5237 5238 while Present (Unt) and then Nkind (Unt) = N_Subunit loop 5239 Find_Elaboration_Context (Parent (Unt)); 5240 5241 -- Continue the traversal by going to the unit which contains the 5242 -- corresponding stub. 5243 5244 if Present (Corresponding_Stub (Unt)) then 5245 Unt := Unit (Cunit (Get_Source_Unit (Corresponding_Stub (Unt)))); 5246 5247 -- Otherwise the subunit may be erroneous or left in a bad state 5248 5249 else 5250 exit; 5251 end if; 5252 end loop; 5253 5254 -- Perform the following traversal now that subunits have been taken 5255 -- care of, or the main unit is a body. 5256 5257 -- body -> spec 5258 5259 if Present (Unt) 5260 and then Nkind_In (Unt, N_Package_Body, N_Subprogram_Body) 5261 then 5262 Find_Elaboration_Context (Parent (Unt)); 5263 5264 -- Continue the traversal by going to the unit which contains the 5265 -- corresponding spec. 5266 5267 if Present (Corresponding_Spec (Unt)) then 5268 Unt := Unit (Cunit (Get_Source_Unit (Corresponding_Spec (Unt)))); 5269 end if; 5270 end if; 5271 5272 -- Perform the following traversals now that the body has been taken 5273 -- care of, or the main unit is a spec. 5274 5275 -- spec -> parent spec 5276 -- parent spec -> grandparent spec and so on 5277 5278 if Present (Unt) 5279 and then Nkind_In (Unt, N_Generic_Package_Declaration, 5280 N_Generic_Subprogram_Declaration, 5281 N_Package_Declaration, 5282 N_Subprogram_Declaration) 5283 then 5284 Find_Elaboration_Context (Parent (Unt)); 5285 5286 -- Process a potential chain of parent units which ends with the 5287 -- main unit spec. The traversal can now safely rely on the scope 5288 -- chain. 5289 5290 Par_Id := Scope (Defining_Entity (Unt)); 5291 while Present (Par_Id) and then Par_Id /= Standard_Standard loop 5292 Find_Elaboration_Context (Compilation_Unit (Par_Id)); 5293 5294 Par_Id := Scope (Par_Id); 5295 end loop; 5296 end if; 5297 end Find_Elaborated_Units; 5298 5299 ----------------------------- 5300 -- Find_Enclosing_Instance -- 5301 ----------------------------- 5302 5303 function Find_Enclosing_Instance (N : Node_Id) return Node_Id is 5304 Par : Node_Id; 5305 Spec_Id : Entity_Id; 5306 5307 begin 5308 -- Climb the parent chain looking for an enclosing instance spec or body 5309 5310 Par := N; 5311 while Present (Par) loop 5312 5313 -- Generic package or subprogram spec 5314 5315 if Nkind_In (Par, N_Package_Declaration, 5316 N_Subprogram_Declaration) 5317 and then Is_Generic_Instance (Defining_Entity (Par)) 5318 then 5319 return Par; 5320 5321 -- Generic package or subprogram body 5322 5323 elsif Nkind_In (Par, N_Package_Body, N_Subprogram_Body) then 5324 Spec_Id := Corresponding_Spec (Par); 5325 5326 if Present (Spec_Id) and then Is_Generic_Instance (Spec_Id) then 5327 return Par; 5328 end if; 5329 end if; 5330 5331 Par := Parent (Par); 5332 end loop; 5333 5334 return Empty; 5335 end Find_Enclosing_Instance; 5336 5337 -------------------------- 5338 -- Find_Enclosing_Level -- 5339 -------------------------- 5340 5341 function Find_Enclosing_Level (N : Node_Id) return Enclosing_Level_Kind is 5342 function Level_Of (Unit : Node_Id) return Enclosing_Level_Kind; 5343 -- Obtain the corresponding level of unit Unit 5344 5345 -------------- 5346 -- Level_Of -- 5347 -------------- 5348 5349 function Level_Of (Unit : Node_Id) return Enclosing_Level_Kind is 5350 Spec_Id : Entity_Id; 5351 5352 begin 5353 if Nkind (Unit) in N_Generic_Instantiation then 5354 return Instantiation; 5355 5356 elsif Nkind (Unit) = N_Generic_Package_Declaration then 5357 return Generic_Package_Spec; 5358 5359 elsif Nkind (Unit) = N_Package_Declaration then 5360 return Package_Spec; 5361 5362 elsif Nkind (Unit) = N_Package_Body then 5363 Spec_Id := Corresponding_Spec (Unit); 5364 5365 -- The body belongs to a generic package 5366 5367 if Present (Spec_Id) 5368 and then Ekind (Spec_Id) = E_Generic_Package 5369 then 5370 return Generic_Package_Body; 5371 5372 -- Otherwise the body belongs to a non-generic package. This also 5373 -- treats an illegal package body without a corresponding spec as 5374 -- a non-generic package body. 5375 5376 else 5377 return Package_Body; 5378 end if; 5379 end if; 5380 5381 return No_Level; 5382 end Level_Of; 5383 5384 -- Local variables 5385 5386 Context : Node_Id; 5387 Curr : Node_Id; 5388 Prev : Node_Id; 5389 5390 -- Start of processing for Find_Enclosing_Level 5391 5392 begin 5393 -- Call markers and instantiations which appear at the declaration level 5394 -- but are later relocated in a different context retain their original 5395 -- declaration level. 5396 5397 if Nkind_In (N, N_Call_Marker, 5398 N_Function_Instantiation, 5399 N_Package_Instantiation, 5400 N_Procedure_Instantiation) 5401 and then Is_Declaration_Level_Node (N) 5402 then 5403 return Declaration_Level; 5404 end if; 5405 5406 -- Climb the parent chain looking at the enclosing levels 5407 5408 Prev := N; 5409 Curr := Parent (Prev); 5410 while Present (Curr) loop 5411 5412 -- A traversal from a subunit continues via the corresponding stub 5413 5414 if Nkind (Curr) = N_Subunit then 5415 Curr := Corresponding_Stub (Curr); 5416 5417 -- The current construct is a package. Packages are ignored because 5418 -- they are always elaborated when the enclosing context is invoked 5419 -- or elaborated. 5420 5421 elsif Nkind_In (Curr, N_Package_Body, N_Package_Declaration) then 5422 null; 5423 5424 -- The current construct is a block statement 5425 5426 elsif Nkind (Curr) = N_Block_Statement then 5427 5428 -- Ignore internally generated blocks created by the expander for 5429 -- various purposes such as abort defer/undefer. 5430 5431 if not Comes_From_Source (Curr) then 5432 null; 5433 5434 -- If the traversal came from the handled sequence of statments, 5435 -- then the node appears at the level of the enclosing construct. 5436 -- This is a more reliable test because transients scopes within 5437 -- the declarative region of the encapsulator are hard to detect. 5438 5439 elsif Nkind (Prev) = N_Handled_Sequence_Of_Statements 5440 and then Handled_Statement_Sequence (Curr) = Prev 5441 then 5442 return Find_Enclosing_Level (Parent (Curr)); 5443 5444 -- Otherwise the traversal came from the declarations, the node is 5445 -- at the declaration level. 5446 5447 else 5448 return Declaration_Level; 5449 end if; 5450 5451 -- The current construct is a declaration-level encapsulator 5452 5453 elsif Nkind_In (Curr, N_Entry_Body, 5454 N_Subprogram_Body, 5455 N_Task_Body) 5456 then 5457 -- If the traversal came from the handled sequence of statments, 5458 -- then the node cannot possibly appear at any level. This is 5459 -- a more reliable test because transients scopes within the 5460 -- declarative region of the encapsulator are hard to detect. 5461 5462 if Nkind (Prev) = N_Handled_Sequence_Of_Statements 5463 and then Handled_Statement_Sequence (Curr) = Prev 5464 then 5465 return No_Level; 5466 5467 -- Otherwise the traversal came from the declarations, the node is 5468 -- at the declaration level. 5469 5470 else 5471 return Declaration_Level; 5472 end if; 5473 5474 -- The current construct is a non-library-level encapsulator which 5475 -- indicates that the node cannot possibly appear at any level. 5476 -- Note that this check must come after the declaration-level check 5477 -- because both predicates share certain nodes. 5478 5479 elsif Is_Non_Library_Level_Encapsulator (Curr) then 5480 Context := Parent (Curr); 5481 5482 -- The sole exception is when the encapsulator is the compilation 5483 -- utit itself because the compilation unit node requires special 5484 -- processing (see below). 5485 5486 if Present (Context) 5487 and then Nkind (Context) = N_Compilation_Unit 5488 then 5489 null; 5490 5491 -- Otherwise the node is not at any level 5492 5493 else 5494 return No_Level; 5495 end if; 5496 5497 -- The current construct is a compilation unit. The node appears at 5498 -- the [generic] library level when the unit is a [generic] package. 5499 5500 elsif Nkind (Curr) = N_Compilation_Unit then 5501 return Level_Of (Unit (Curr)); 5502 end if; 5503 5504 Prev := Curr; 5505 Curr := Parent (Prev); 5506 end loop; 5507 5508 return No_Level; 5509 end Find_Enclosing_Level; 5510 5511 ------------------- 5512 -- Find_Top_Unit -- 5513 ------------------- 5514 5515 function Find_Top_Unit (N : Node_Or_Entity_Id) return Entity_Id is 5516 begin 5517 return Find_Unit_Entity (Unit (Cunit (Get_Top_Level_Code_Unit (N)))); 5518 end Find_Top_Unit; 5519 5520 ---------------------- 5521 -- Find_Unit_Entity -- 5522 ---------------------- 5523 5524 function Find_Unit_Entity (N : Node_Id) return Entity_Id is 5525 Context : constant Node_Id := Parent (N); 5526 Orig_N : constant Node_Id := Original_Node (N); 5527 5528 begin 5529 -- The unit denotes a package body of an instantiation which acts as 5530 -- a compilation unit. The proper entity is that of the package spec. 5531 5532 if Nkind (N) = N_Package_Body 5533 and then Nkind (Orig_N) = N_Package_Instantiation 5534 and then Nkind (Context) = N_Compilation_Unit 5535 then 5536 return Corresponding_Spec (N); 5537 5538 -- The unit denotes an anonymous package created to wrap a subprogram 5539 -- instantiation which acts as a compilation unit. The proper entity is 5540 -- that of the "related instance". 5541 5542 elsif Nkind (N) = N_Package_Declaration 5543 and then Nkind_In (Orig_N, N_Function_Instantiation, 5544 N_Procedure_Instantiation) 5545 and then Nkind (Context) = N_Compilation_Unit 5546 then 5547 return 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 -- In_Task_Body -- 6099 ------------------ 6100 6101 function In_Task_Body (N : Node_Id) return Boolean is 6102 Par : Node_Id; 6103 6104 begin 6105 -- Climb the parent chain looking for a task body [procedure] 6106 6107 Par := N; 6108 while Present (Par) loop 6109 if Nkind (Par) = N_Task_Body then 6110 return True; 6111 6112 elsif Nkind (Par) = N_Subprogram_Body 6113 and then Is_Task_Body_Procedure (Par) 6114 then 6115 return True; 6116 6117 -- Prevent the search from going too far. Note that this predicate 6118 -- shares nodes with the two cases above, and must come last. 6119 6120 elsif Is_Body_Or_Package_Declaration (Par) then 6121 return False; 6122 end if; 6123 6124 Par := Parent (Par); 6125 end loop; 6126 6127 return False; 6128 end In_Task_Body; 6129 6130 ---------------- 6131 -- Initialize -- 6132 ---------------- 6133 6134 procedure Initialize is 6135 begin 6136 -- Set the soft link which enables Atree.Rewrite to update a top-level 6137 -- scenario each time it is transformed into another node. 6138 6139 Set_Rewriting_Proc (Update_Elaboration_Scenario'Access); 6140 end Initialize; 6141 6142 --------------- 6143 -- Info_Call -- 6144 --------------- 6145 6146 procedure Info_Call 6147 (Call : Node_Id; 6148 Target_Id : Entity_Id; 6149 Info_Msg : Boolean; 6150 In_SPARK : Boolean) 6151 is 6152 procedure Info_Accept_Alternative; 6153 pragma Inline (Info_Accept_Alternative); 6154 -- Output information concerning an accept alternative 6155 6156 procedure Info_Simple_Call; 6157 pragma Inline (Info_Simple_Call); 6158 -- Output information concerning the call 6159 6160 procedure Info_Type_Actions (Action : String); 6161 pragma Inline (Info_Type_Actions); 6162 -- Output information concerning action Action of a type 6163 6164 procedure Info_Verification_Call 6165 (Pred : String; 6166 Id : Entity_Id; 6167 Id_Kind : String); 6168 pragma Inline (Info_Verification_Call); 6169 -- Output information concerning the verification of predicate Pred 6170 -- applied to related entity Id with kind Id_Kind. 6171 6172 ----------------------------- 6173 -- Info_Accept_Alternative -- 6174 ----------------------------- 6175 6176 procedure Info_Accept_Alternative is 6177 Entry_Id : constant Entity_Id := Receiving_Entry (Target_Id); 6178 6179 begin 6180 pragma Assert (Present (Entry_Id)); 6181 6182 Elab_Msg_NE 6183 (Msg => "accept for entry & during elaboration", 6184 N => Call, 6185 Id => Entry_Id, 6186 Info_Msg => Info_Msg, 6187 In_SPARK => In_SPARK); 6188 end Info_Accept_Alternative; 6189 6190 ---------------------- 6191 -- Info_Simple_Call -- 6192 ---------------------- 6193 6194 procedure Info_Simple_Call is 6195 begin 6196 Elab_Msg_NE 6197 (Msg => "call to & during elaboration", 6198 N => Call, 6199 Id => Target_Id, 6200 Info_Msg => Info_Msg, 6201 In_SPARK => In_SPARK); 6202 end Info_Simple_Call; 6203 6204 ----------------------- 6205 -- Info_Type_Actions -- 6206 ----------------------- 6207 6208 procedure Info_Type_Actions (Action : String) is 6209 Typ : constant Entity_Id := First_Formal_Type (Target_Id); 6210 6211 begin 6212 pragma Assert (Present (Typ)); 6213 6214 Elab_Msg_NE 6215 (Msg => Action & " actions for type & during elaboration", 6216 N => Call, 6217 Id => Typ, 6218 Info_Msg => Info_Msg, 6219 In_SPARK => In_SPARK); 6220 end Info_Type_Actions; 6221 6222 ---------------------------- 6223 -- Info_Verification_Call -- 6224 ---------------------------- 6225 6226 procedure Info_Verification_Call 6227 (Pred : String; 6228 Id : Entity_Id; 6229 Id_Kind : String) 6230 is 6231 begin 6232 pragma Assert (Present (Id)); 6233 6234 Elab_Msg_NE 6235 (Msg => 6236 "verification of " & Pred & " of " & Id_Kind & " & during " 6237 & "elaboration", 6238 N => Call, 6239 Id => Id, 6240 Info_Msg => Info_Msg, 6241 In_SPARK => In_SPARK); 6242 end Info_Verification_Call; 6243 6244 -- Start of processing for Info_Call 6245 6246 begin 6247 -- Do not output anything for targets defined in internal units because 6248 -- this creates noise. 6249 6250 if not In_Internal_Unit (Target_Id) then 6251 6252 -- Accept alternative 6253 6254 if Is_Accept_Alternative_Proc (Target_Id) then 6255 Info_Accept_Alternative; 6256 6257 -- Adjustment 6258 6259 elsif Is_TSS (Target_Id, TSS_Deep_Adjust) then 6260 Info_Type_Actions ("adjustment"); 6261 6262 -- Default_Initial_Condition 6263 6264 elsif Is_Default_Initial_Condition_Proc (Target_Id) then 6265 Info_Verification_Call 6266 (Pred => "Default_Initial_Condition", 6267 Id => First_Formal_Type (Target_Id), 6268 Id_Kind => "type"); 6269 6270 -- Entries 6271 6272 elsif Is_Protected_Entry (Target_Id) then 6273 Info_Simple_Call; 6274 6275 -- Task entry calls are never processed because the entry being 6276 -- invoked does not have a corresponding "body", it has a select. 6277 6278 elsif Is_Task_Entry (Target_Id) then 6279 null; 6280 6281 -- Finalization 6282 6283 elsif Is_TSS (Target_Id, TSS_Deep_Finalize) then 6284 Info_Type_Actions ("finalization"); 6285 6286 -- Calls to _Finalizer procedures must not appear in the output 6287 -- because this creates confusing noise. 6288 6289 elsif Is_Finalizer_Proc (Target_Id) then 6290 null; 6291 6292 -- Initial_Condition 6293 6294 elsif Is_Initial_Condition_Proc (Target_Id) then 6295 Info_Verification_Call 6296 (Pred => "Initial_Condition", 6297 Id => Find_Enclosing_Scope (Call), 6298 Id_Kind => "package"); 6299 6300 -- Initialization 6301 6302 elsif Is_Init_Proc (Target_Id) 6303 or else Is_TSS (Target_Id, TSS_Deep_Initialize) 6304 then 6305 Info_Type_Actions ("initialization"); 6306 6307 -- Invariant 6308 6309 elsif Is_Invariant_Proc (Target_Id) then 6310 Info_Verification_Call 6311 (Pred => "invariants", 6312 Id => First_Formal_Type (Target_Id), 6313 Id_Kind => "type"); 6314 6315 -- Partial invariant calls must not appear in the output because this 6316 -- creates confusing noise. 6317 6318 elsif Is_Partial_Invariant_Proc (Target_Id) then 6319 null; 6320 6321 -- _Postconditions 6322 6323 elsif Is_Postconditions_Proc (Target_Id) then 6324 Info_Verification_Call 6325 (Pred => "postconditions", 6326 Id => Find_Enclosing_Scope (Call), 6327 Id_Kind => "subprogram"); 6328 6329 -- Subprograms must come last because some of the previous cases fall 6330 -- under this category. 6331 6332 elsif Ekind (Target_Id) = E_Function then 6333 Info_Simple_Call; 6334 6335 elsif Ekind (Target_Id) = E_Procedure then 6336 Info_Simple_Call; 6337 6338 else 6339 pragma Assert (False); 6340 null; 6341 end if; 6342 end if; 6343 end Info_Call; 6344 6345 ------------------------ 6346 -- Info_Instantiation -- 6347 ------------------------ 6348 6349 procedure Info_Instantiation 6350 (Inst : Node_Id; 6351 Gen_Id : Entity_Id; 6352 Info_Msg : Boolean; 6353 In_SPARK : Boolean) 6354 is 6355 begin 6356 Elab_Msg_NE 6357 (Msg => "instantiation of & during elaboration", 6358 N => Inst, 6359 Id => Gen_Id, 6360 Info_Msg => Info_Msg, 6361 In_SPARK => In_SPARK); 6362 end Info_Instantiation; 6363 6364 ----------------------------- 6365 -- Info_Variable_Reference -- 6366 ----------------------------- 6367 6368 procedure Info_Variable_Reference 6369 (Ref : Node_Id; 6370 Var_Id : Entity_Id; 6371 Info_Msg : Boolean; 6372 In_SPARK : Boolean) 6373 is 6374 begin 6375 if Is_Read (Ref) then 6376 Elab_Msg_NE 6377 (Msg => "read of variable & during elaboration", 6378 N => Ref, 6379 Id => Var_Id, 6380 Info_Msg => Info_Msg, 6381 In_SPARK => In_SPARK); 6382 end if; 6383 end Info_Variable_Reference; 6384 6385 -------------------- 6386 -- Insertion_Node -- 6387 -------------------- 6388 6389 function Insertion_Node (N : Node_Id; Ins_Nod : Node_Id) return Node_Id is 6390 begin 6391 -- When the scenario denotes an instantiation, the proper insertion node 6392 -- is the instance spec. This ensures that the generic actuals will not 6393 -- be evaluated prior to a potential ABE. 6394 6395 if Nkind (N) in N_Generic_Instantiation 6396 and then Present (Instance_Spec (N)) 6397 then 6398 return Instance_Spec (N); 6399 6400 -- Otherwise the proper insertion node is the candidate insertion node 6401 6402 else 6403 return Ins_Nod; 6404 end if; 6405 end Insertion_Node; 6406 6407 ----------------------- 6408 -- Install_ABE_Check -- 6409 ----------------------- 6410 6411 procedure Install_ABE_Check 6412 (N : Node_Id; 6413 Id : Entity_Id; 6414 Ins_Nod : Node_Id) 6415 is 6416 Check_Ins_Nod : constant Node_Id := Insertion_Node (N, Ins_Nod); 6417 -- Insert the check prior to this node 6418 6419 Loc : constant Source_Ptr := Sloc (N); 6420 Spec_Id : constant Entity_Id := Unique_Entity (Id); 6421 Unit_Id : constant Entity_Id := Find_Top_Unit (Id); 6422 Scop_Id : Entity_Id; 6423 6424 begin 6425 -- Nothing to do when compiling for GNATprove because raise statements 6426 -- are not supported. 6427 6428 if GNATprove_Mode then 6429 return; 6430 6431 -- Nothing to do when the compilation will not produce an executable 6432 6433 elsif Serious_Errors_Detected > 0 then 6434 return; 6435 6436 -- Nothing to do for a compilation unit because there is no executable 6437 -- environment at that level. 6438 6439 elsif Nkind (Parent (Check_Ins_Nod)) = N_Compilation_Unit then 6440 return; 6441 6442 -- Nothing to do when the unit is elaborated prior to the main unit. 6443 -- This check must also consider the following cases: 6444 6445 -- * Id's unit appears in the context of the main unit 6446 6447 -- * Id's unit is subject to pragma Elaborate_Body. An ABE check MUST 6448 -- NOT be generated because Id's unit is always elaborated prior to 6449 -- the main unit. 6450 6451 -- * Id's unit is the main unit. An ABE check MUST be generated in this 6452 -- case because a conditional ABE may be raised depending on the flow 6453 -- of execution within the main unit (flag Same_Unit_OK is False). 6454 6455 elsif Has_Prior_Elaboration 6456 (Unit_Id => Unit_Id, 6457 Context_OK => True, 6458 Elab_Body_OK => True) 6459 then 6460 return; 6461 end if; 6462 6463 -- Prevent multiple scenarios from installing the same ABE check 6464 6465 Set_Is_Elaboration_Checks_OK_Node (N, False); 6466 6467 -- Install the nearest enclosing scope of the scenario as there must be 6468 -- something on the scope stack. 6469 6470 -- Performance note: parent traversal 6471 6472 Scop_Id := Find_Enclosing_Scope (Check_Ins_Nod); 6473 pragma Assert (Present (Scop_Id)); 6474 6475 Push_Scope (Scop_Id); 6476 6477 -- Generate: 6478 -- if not Spec_Id'Elaborated then 6479 -- raise Program_Error with "access before elaboration"; 6480 -- end if; 6481 6482 Insert_Action (Check_Ins_Nod, 6483 Make_Raise_Program_Error (Loc, 6484 Condition => 6485 Make_Op_Not (Loc, 6486 Right_Opnd => 6487 Make_Attribute_Reference (Loc, 6488 Prefix => New_Occurrence_Of (Spec_Id, Loc), 6489 Attribute_Name => Name_Elaborated)), 6490 Reason => PE_Access_Before_Elaboration)); 6491 6492 Pop_Scope; 6493 end Install_ABE_Check; 6494 6495 ----------------------- 6496 -- Install_ABE_Check -- 6497 ----------------------- 6498 6499 procedure Install_ABE_Check 6500 (N : Node_Id; 6501 Target_Id : Entity_Id; 6502 Target_Decl : Node_Id; 6503 Target_Body : Node_Id; 6504 Ins_Nod : Node_Id) 6505 is 6506 procedure Build_Elaboration_Entity; 6507 pragma Inline (Build_Elaboration_Entity); 6508 -- Create a new elaboration flag for Target_Id, insert it prior to 6509 -- Target_Decl, and set it after Body_Decl. 6510 6511 ------------------------------ 6512 -- Build_Elaboration_Entity -- 6513 ------------------------------ 6514 6515 procedure Build_Elaboration_Entity is 6516 Loc : constant Source_Ptr := Sloc (Target_Id); 6517 Flag_Id : Entity_Id; 6518 6519 begin 6520 -- Create the declaration of the elaboration flag. The name carries a 6521 -- unique counter in case of name overloading. 6522 6523 Flag_Id := 6524 Make_Defining_Identifier (Loc, 6525 Chars => New_External_Name (Chars (Target_Id), 'E', -1)); 6526 6527 Set_Elaboration_Entity (Target_Id, Flag_Id); 6528 Set_Elaboration_Entity_Required (Target_Id); 6529 6530 Push_Scope (Scope (Target_Id)); 6531 6532 -- Generate: 6533 -- Enn : Short_Integer := 0; 6534 6535 Insert_Action (Target_Decl, 6536 Make_Object_Declaration (Loc, 6537 Defining_Identifier => Flag_Id, 6538 Object_Definition => 6539 New_Occurrence_Of (Standard_Short_Integer, Loc), 6540 Expression => Make_Integer_Literal (Loc, Uint_0))); 6541 6542 -- Generate: 6543 -- Enn := 1; 6544 6545 Set_Elaboration_Flag (Target_Body, Target_Id); 6546 6547 Pop_Scope; 6548 end Build_Elaboration_Entity; 6549 6550 -- Local variables 6551 6552 Target_Unit_Id : constant Entity_Id := Find_Top_Unit (Target_Id); 6553 6554 -- Start for processing for Install_ABE_Check 6555 6556 begin 6557 -- Nothing to do when compiling for GNATprove because raise statements 6558 -- are not supported. 6559 6560 if GNATprove_Mode then 6561 return; 6562 6563 -- Nothing to do when the compilation will not produce an executable 6564 6565 elsif Serious_Errors_Detected > 0 then 6566 return; 6567 6568 -- Nothing to do when the target is a protected subprogram because the 6569 -- check is associated with the protected body subprogram. 6570 6571 elsif Is_Protected_Subp (Target_Id) then 6572 return; 6573 6574 -- Nothing to do when the target is elaborated prior to the main unit. 6575 -- This check must also consider the following cases: 6576 6577 -- * The unit of the target appears in the context of the main unit 6578 6579 -- * The unit of the target is subject to pragma Elaborate_Body. An ABE 6580 -- check MUST NOT be generated because the unit is always elaborated 6581 -- prior to the main unit. 6582 6583 -- * The unit of the target is the main unit. An ABE check MUST be added 6584 -- in this case because a conditional ABE may be raised depending on 6585 -- the flow of execution within the main unit (flag Same_Unit_OK is 6586 -- False). 6587 6588 elsif Has_Prior_Elaboration 6589 (Unit_Id => Target_Unit_Id, 6590 Context_OK => True, 6591 Elab_Body_OK => True) 6592 then 6593 return; 6594 6595 -- Create an elaboration flag for the target when it does not have one 6596 6597 elsif No (Elaboration_Entity (Target_Id)) then 6598 Build_Elaboration_Entity; 6599 end if; 6600 6601 Install_ABE_Check 6602 (N => N, 6603 Ins_Nod => Ins_Nod, 6604 Id => Target_Id); 6605 end Install_ABE_Check; 6606 6607 ------------------------- 6608 -- Install_ABE_Failure -- 6609 ------------------------- 6610 6611 procedure Install_ABE_Failure (N : Node_Id; Ins_Nod : Node_Id) is 6612 Fail_Ins_Nod : constant Node_Id := Insertion_Node (N, Ins_Nod); 6613 -- Insert the failure prior to this node 6614 6615 Loc : constant Source_Ptr := Sloc (N); 6616 Scop_Id : Entity_Id; 6617 6618 begin 6619 -- Nothing to do when compiling for GNATprove because raise statements 6620 -- are not supported. 6621 6622 if GNATprove_Mode then 6623 return; 6624 6625 -- Nothing to do when the compilation will not produce an executable 6626 6627 elsif Serious_Errors_Detected > 0 then 6628 return; 6629 6630 -- Do not install an ABE check for a compilation unit because there is 6631 -- no executable environment at that level. 6632 6633 elsif Nkind (Parent (Fail_Ins_Nod)) = N_Compilation_Unit then 6634 return; 6635 end if; 6636 6637 -- Prevent multiple scenarios from installing the same ABE failure 6638 6639 Set_Is_Elaboration_Checks_OK_Node (N, False); 6640 6641 -- Install the nearest enclosing scope of the scenario as there must be 6642 -- something on the scope stack. 6643 6644 -- Performance note: parent traversal 6645 6646 Scop_Id := Find_Enclosing_Scope (Fail_Ins_Nod); 6647 pragma Assert (Present (Scop_Id)); 6648 6649 Push_Scope (Scop_Id); 6650 6651 -- Generate: 6652 -- raise Program_Error with "access before elaboration"; 6653 6654 Insert_Action (Fail_Ins_Nod, 6655 Make_Raise_Program_Error (Loc, 6656 Reason => PE_Access_Before_Elaboration)); 6657 6658 Pop_Scope; 6659 end Install_ABE_Failure; 6660 6661 -------------------------------- 6662 -- Is_Accept_Alternative_Proc -- 6663 -------------------------------- 6664 6665 function Is_Accept_Alternative_Proc (Id : Entity_Id) return Boolean is 6666 begin 6667 -- To qualify, the entity must denote a procedure with a receiving entry 6668 6669 return Ekind (Id) = E_Procedure and then Present (Receiving_Entry (Id)); 6670 end Is_Accept_Alternative_Proc; 6671 6672 ------------------------ 6673 -- Is_Activation_Proc -- 6674 ------------------------ 6675 6676 function Is_Activation_Proc (Id : Entity_Id) return Boolean is 6677 begin 6678 -- To qualify, the entity must denote one of the runtime procedures in 6679 -- charge of task activation. 6680 6681 if Ekind (Id) = E_Procedure then 6682 if Restricted_Profile then 6683 return Is_RTE (Id, RE_Activate_Restricted_Tasks); 6684 else 6685 return Is_RTE (Id, RE_Activate_Tasks); 6686 end if; 6687 end if; 6688 6689 return False; 6690 end Is_Activation_Proc; 6691 6692 ---------------------------- 6693 -- Is_Ada_Semantic_Target -- 6694 ---------------------------- 6695 6696 function Is_Ada_Semantic_Target (Id : Entity_Id) return Boolean is 6697 begin 6698 return 6699 Is_Activation_Proc (Id) 6700 or else Is_Controlled_Proc (Id, Name_Adjust) 6701 or else Is_Controlled_Proc (Id, Name_Finalize) 6702 or else Is_Controlled_Proc (Id, Name_Initialize) 6703 or else Is_Init_Proc (Id) 6704 or else Is_Invariant_Proc (Id) 6705 or else Is_Protected_Entry (Id) 6706 or else Is_Protected_Subp (Id) 6707 or else Is_Protected_Body_Subp (Id) 6708 or else Is_Task_Entry (Id); 6709 end Is_Ada_Semantic_Target; 6710 6711 -------------------------------- 6712 -- Is_Assertion_Pragma_Target -- 6713 -------------------------------- 6714 6715 function Is_Assertion_Pragma_Target (Id : Entity_Id) return Boolean is 6716 begin 6717 return 6718 Is_Default_Initial_Condition_Proc (Id) 6719 or else Is_Initial_Condition_Proc (Id) 6720 or else Is_Invariant_Proc (Id) 6721 or else Is_Partial_Invariant_Proc (Id) 6722 or else Is_Postconditions_Proc (Id); 6723 end Is_Assertion_Pragma_Target; 6724 6725 ---------------------------- 6726 -- Is_Bodiless_Subprogram -- 6727 ---------------------------- 6728 6729 function Is_Bodiless_Subprogram (Subp_Id : Entity_Id) return Boolean is 6730 begin 6731 -- An abstract subprogram does not have a body 6732 6733 if Ekind_In (Subp_Id, E_Function, 6734 E_Operator, 6735 E_Procedure) 6736 and then Is_Abstract_Subprogram (Subp_Id) 6737 then 6738 return True; 6739 6740 -- A formal subprogram does not have a body 6741 6742 elsif Is_Formal_Subprogram (Subp_Id) then 6743 return True; 6744 6745 -- An imported subprogram may have a body, however it is not known at 6746 -- compile or bind time where the body resides and whether it will be 6747 -- elaborated on time. 6748 6749 elsif Is_Imported (Subp_Id) then 6750 return True; 6751 end if; 6752 6753 return False; 6754 end Is_Bodiless_Subprogram; 6755 6756 ------------------------ 6757 -- Is_Controlled_Proc -- 6758 ------------------------ 6759 6760 function Is_Controlled_Proc 6761 (Subp_Id : Entity_Id; 6762 Subp_Nam : Name_Id) return Boolean 6763 is 6764 Formal_Id : Entity_Id; 6765 6766 begin 6767 pragma Assert (Nam_In (Subp_Nam, Name_Adjust, 6768 Name_Finalize, 6769 Name_Initialize)); 6770 6771 -- To qualify, the subprogram must denote a source procedure with name 6772 -- Adjust, Finalize, or Initialize where the sole formal is controlled. 6773 6774 if Comes_From_Source (Subp_Id) 6775 and then Ekind (Subp_Id) = E_Procedure 6776 and then Chars (Subp_Id) = Subp_Nam 6777 then 6778 Formal_Id := First_Formal (Subp_Id); 6779 6780 return 6781 Present (Formal_Id) 6782 and then Is_Controlled (Etype (Formal_Id)) 6783 and then No (Next_Formal (Formal_Id)); 6784 end if; 6785 6786 return False; 6787 end Is_Controlled_Proc; 6788 6789 --------------------------------------- 6790 -- Is_Default_Initial_Condition_Proc -- 6791 --------------------------------------- 6792 6793 function Is_Default_Initial_Condition_Proc 6794 (Id : Entity_Id) return Boolean 6795 is 6796 begin 6797 -- To qualify, the entity must denote a Default_Initial_Condition 6798 -- procedure. 6799 6800 return Ekind (Id) = E_Procedure and then Is_DIC_Procedure (Id); 6801 end Is_Default_Initial_Condition_Proc; 6802 6803 ----------------------- 6804 -- Is_Finalizer_Proc -- 6805 ----------------------- 6806 6807 function Is_Finalizer_Proc (Id : Entity_Id) return Boolean is 6808 begin 6809 -- To qualify, the entity must denote a _Finalizer procedure 6810 6811 return Ekind (Id) = E_Procedure and then Chars (Id) = Name_uFinalizer; 6812 end Is_Finalizer_Proc; 6813 6814 ----------------------- 6815 -- Is_Guaranteed_ABE -- 6816 ----------------------- 6817 6818 function Is_Guaranteed_ABE 6819 (N : Node_Id; 6820 Target_Decl : Node_Id; 6821 Target_Body : Node_Id) return Boolean 6822 is 6823 begin 6824 -- Avoid cascaded errors if there were previous serious infractions. 6825 -- As a result the scenario will not be treated as a guaranteed ABE. 6826 -- This behaviour parallels that of the old ABE mechanism. 6827 6828 if Serious_Errors_Detected > 0 then 6829 return False; 6830 6831 -- The scenario and the target appear within the same context ignoring 6832 -- enclosing library levels. 6833 6834 -- Performance note: parent traversal 6835 6836 elsif In_Same_Context (N, Target_Decl) then 6837 6838 -- The target body has already been encountered. The scenario results 6839 -- in a guaranteed ABE if it appears prior to the body. 6840 6841 if Present (Target_Body) then 6842 return Earlier_In_Extended_Unit (N, Target_Body); 6843 6844 -- Otherwise the body has not been encountered yet. The scenario is 6845 -- a guaranteed ABE since the body will appear later. It is assumed 6846 -- that the caller has already checked whether the scenario is ABE- 6847 -- safe as optional bodies are not considered here. 6848 6849 else 6850 return True; 6851 end if; 6852 end if; 6853 6854 return False; 6855 end Is_Guaranteed_ABE; 6856 6857 ------------------------------- 6858 -- Is_Initial_Condition_Proc -- 6859 ------------------------------- 6860 6861 function Is_Initial_Condition_Proc (Id : Entity_Id) return Boolean is 6862 begin 6863 -- To qualify, the entity must denote an Initial_Condition procedure 6864 6865 return 6866 Ekind (Id) = E_Procedure and then Is_Initial_Condition_Procedure (Id); 6867 end Is_Initial_Condition_Proc; 6868 6869 -------------------- 6870 -- Is_Initialized -- 6871 -------------------- 6872 6873 function Is_Initialized (Obj_Decl : Node_Id) return Boolean is 6874 begin 6875 -- To qualify, the object declaration must have an expression 6876 6877 return 6878 Present (Expression (Obj_Decl)) or else Has_Init_Expression (Obj_Decl); 6879 end Is_Initialized; 6880 6881 ----------------------- 6882 -- Is_Invariant_Proc -- 6883 ----------------------- 6884 6885 function Is_Invariant_Proc (Id : Entity_Id) return Boolean is 6886 begin 6887 -- To qualify, the entity must denote the "full" invariant procedure 6888 6889 return Ekind (Id) = E_Procedure and then Is_Invariant_Procedure (Id); 6890 end Is_Invariant_Proc; 6891 6892 --------------------------------------- 6893 -- Is_Non_Library_Level_Encapsulator -- 6894 --------------------------------------- 6895 6896 function Is_Non_Library_Level_Encapsulator (N : Node_Id) return Boolean is 6897 begin 6898 case Nkind (N) is 6899 when N_Abstract_Subprogram_Declaration 6900 | N_Aspect_Specification 6901 | N_Component_Declaration 6902 | N_Entry_Body 6903 | N_Entry_Declaration 6904 | N_Expression_Function 6905 | N_Formal_Abstract_Subprogram_Declaration 6906 | N_Formal_Concrete_Subprogram_Declaration 6907 | N_Formal_Object_Declaration 6908 | N_Formal_Package_Declaration 6909 | N_Formal_Type_Declaration 6910 | N_Generic_Association 6911 | N_Implicit_Label_Declaration 6912 | N_Incomplete_Type_Declaration 6913 | N_Private_Extension_Declaration 6914 | N_Private_Type_Declaration 6915 | N_Protected_Body 6916 | N_Protected_Type_Declaration 6917 | N_Single_Protected_Declaration 6918 | N_Single_Task_Declaration 6919 | N_Subprogram_Body 6920 | N_Subprogram_Declaration 6921 | N_Task_Body 6922 | N_Task_Type_Declaration 6923 => 6924 return True; 6925 6926 when others => 6927 return Is_Generic_Declaration_Or_Body (N); 6928 end case; 6929 end Is_Non_Library_Level_Encapsulator; 6930 6931 ------------------------------- 6932 -- Is_Partial_Invariant_Proc -- 6933 ------------------------------- 6934 6935 function Is_Partial_Invariant_Proc (Id : Entity_Id) return Boolean is 6936 begin 6937 -- To qualify, the entity must denote the "partial" invariant procedure 6938 6939 return 6940 Ekind (Id) = E_Procedure and then Is_Partial_Invariant_Procedure (Id); 6941 end Is_Partial_Invariant_Proc; 6942 6943 ---------------------------- 6944 -- Is_Postconditions_Proc -- 6945 ---------------------------- 6946 6947 function Is_Postconditions_Proc (Id : Entity_Id) return Boolean is 6948 begin 6949 -- To qualify, the entity must denote a _Postconditions procedure 6950 6951 return 6952 Ekind (Id) = E_Procedure and then Chars (Id) = Name_uPostconditions; 6953 end Is_Postconditions_Proc; 6954 6955 --------------------------- 6956 -- Is_Preelaborated_Unit -- 6957 --------------------------- 6958 6959 function Is_Preelaborated_Unit (Id : Entity_Id) return Boolean is 6960 begin 6961 return 6962 Is_Preelaborated (Id) 6963 or else Is_Pure (Id) 6964 or else Is_Remote_Call_Interface (Id) 6965 or else Is_Remote_Types (Id) 6966 or else Is_Shared_Passive (Id); 6967 end Is_Preelaborated_Unit; 6968 6969 ------------------------ 6970 -- Is_Protected_Entry -- 6971 ------------------------ 6972 6973 function Is_Protected_Entry (Id : Entity_Id) return Boolean is 6974 begin 6975 -- To qualify, the entity must denote an entry defined in a protected 6976 -- type. 6977 6978 return 6979 Is_Entry (Id) 6980 and then Is_Protected_Type (Non_Private_View (Scope (Id))); 6981 end Is_Protected_Entry; 6982 6983 ----------------------- 6984 -- Is_Protected_Subp -- 6985 ----------------------- 6986 6987 function Is_Protected_Subp (Id : Entity_Id) return Boolean is 6988 begin 6989 -- To qualify, the entity must denote a subprogram defined within a 6990 -- protected type. 6991 6992 return 6993 Ekind_In (Id, E_Function, E_Procedure) 6994 and then Is_Protected_Type (Non_Private_View (Scope (Id))); 6995 end Is_Protected_Subp; 6996 6997 ---------------------------- 6998 -- Is_Protected_Body_Subp -- 6999 ---------------------------- 7000 7001 function Is_Protected_Body_Subp (Id : Entity_Id) return Boolean is 7002 begin 7003 -- To qualify, the entity must denote a subprogram with attribute 7004 -- Protected_Subprogram set. 7005 7006 return 7007 Ekind_In (Id, E_Function, E_Procedure) 7008 and then Present (Protected_Subprogram (Id)); 7009 end Is_Protected_Body_Subp; 7010 7011 -------------------------------- 7012 -- Is_Recorded_SPARK_Scenario -- 7013 -------------------------------- 7014 7015 function Is_Recorded_SPARK_Scenario (N : Node_Id) return Boolean is 7016 begin 7017 if Recorded_SPARK_Scenarios_In_Use then 7018 return Recorded_SPARK_Scenarios.Get (N); 7019 end if; 7020 7021 return Recorded_SPARK_Scenarios_No_Element; 7022 end Is_Recorded_SPARK_Scenario; 7023 7024 ------------------------------------ 7025 -- Is_Recorded_Top_Level_Scenario -- 7026 ------------------------------------ 7027 7028 function Is_Recorded_Top_Level_Scenario (N : Node_Id) return Boolean is 7029 begin 7030 if Recorded_Top_Level_Scenarios_In_Use then 7031 return Recorded_Top_Level_Scenarios.Get (N); 7032 end if; 7033 7034 return Recorded_Top_Level_Scenarios_No_Element; 7035 end Is_Recorded_Top_Level_Scenario; 7036 7037 ------------------------ 7038 -- Is_Safe_Activation -- 7039 ------------------------ 7040 7041 function Is_Safe_Activation 7042 (Call : Node_Id; 7043 Task_Decl : Node_Id) return Boolean 7044 is 7045 begin 7046 -- The activation of a task coming from an external instance cannot 7047 -- cause an ABE because the generic was already instantiated. Note 7048 -- that the instantiation itself may lead to an ABE. 7049 7050 return 7051 In_External_Instance 7052 (N => Call, 7053 Target_Decl => Task_Decl); 7054 end Is_Safe_Activation; 7055 7056 ------------------ 7057 -- Is_Safe_Call -- 7058 ------------------ 7059 7060 function Is_Safe_Call 7061 (Call : Node_Id; 7062 Target_Attrs : Target_Attributes) return Boolean 7063 is 7064 begin 7065 -- The target is either an abstract subprogram, formal subprogram, or 7066 -- imported, in which case it does not have a body at compile or bind 7067 -- time. Assume that the call is ABE-safe. 7068 7069 if Is_Bodiless_Subprogram (Target_Attrs.Spec_Id) then 7070 return True; 7071 7072 -- The target is an instantiation of a generic subprogram. The call 7073 -- cannot cause an ABE because the generic was already instantiated. 7074 -- Note that the instantiation itself may lead to an ABE. 7075 7076 elsif Is_Generic_Instance (Target_Attrs.Spec_Id) then 7077 return True; 7078 7079 -- The invocation of a target coming from an external instance cannot 7080 -- cause an ABE because the generic was already instantiated. Note that 7081 -- the instantiation itself may lead to an ABE. 7082 7083 elsif In_External_Instance 7084 (N => Call, 7085 Target_Decl => Target_Attrs.Spec_Decl) 7086 then 7087 return True; 7088 7089 -- The target is a subprogram body without a previous declaration. The 7090 -- call cannot cause an ABE because the body has already been seen. 7091 7092 elsif Nkind (Target_Attrs.Spec_Decl) = N_Subprogram_Body 7093 and then No (Corresponding_Spec (Target_Attrs.Spec_Decl)) 7094 then 7095 return True; 7096 7097 -- The target is a subprogram body stub without a prior declaration. 7098 -- The call cannot cause an ABE because the proper body substitutes 7099 -- the stub. 7100 7101 elsif Nkind (Target_Attrs.Spec_Decl) = N_Subprogram_Body_Stub 7102 and then No (Corresponding_Spec_Of_Stub (Target_Attrs.Spec_Decl)) 7103 then 7104 return True; 7105 7106 -- Subprogram bodies which wrap attribute references used as actuals 7107 -- in instantiations are always ABE-safe. These bodies are artifacts 7108 -- of expansion. 7109 7110 elsif Present (Target_Attrs.Body_Decl) 7111 and then Nkind (Target_Attrs.Body_Decl) = N_Subprogram_Body 7112 and then Was_Attribute_Reference (Target_Attrs.Body_Decl) 7113 then 7114 return True; 7115 end if; 7116 7117 return False; 7118 end Is_Safe_Call; 7119 7120 --------------------------- 7121 -- Is_Safe_Instantiation -- 7122 --------------------------- 7123 7124 function Is_Safe_Instantiation 7125 (Inst : Node_Id; 7126 Gen_Attrs : Target_Attributes) return Boolean 7127 is 7128 begin 7129 -- The generic is an intrinsic subprogram in which case it does not 7130 -- have a body at compile or bind time. Assume that the instantiation 7131 -- is ABE-safe. 7132 7133 if Is_Bodiless_Subprogram (Gen_Attrs.Spec_Id) then 7134 return True; 7135 7136 -- The instantiation of an external nested generic cannot cause an ABE 7137 -- if the outer generic was already instantiated. Note that the instance 7138 -- of the outer generic may lead to an ABE. 7139 7140 elsif In_External_Instance 7141 (N => Inst, 7142 Target_Decl => Gen_Attrs.Spec_Decl) 7143 then 7144 return True; 7145 7146 -- The generic is a package. The instantiation cannot cause an ABE when 7147 -- the package has no body. 7148 7149 elsif Ekind (Gen_Attrs.Spec_Id) = E_Generic_Package 7150 and then not Has_Body (Gen_Attrs.Spec_Decl) 7151 then 7152 return True; 7153 end if; 7154 7155 return False; 7156 end Is_Safe_Instantiation; 7157 7158 ------------------ 7159 -- Is_Same_Unit -- 7160 ------------------ 7161 7162 function Is_Same_Unit 7163 (Unit_1 : Entity_Id; 7164 Unit_2 : Entity_Id) return Boolean 7165 is 7166 begin 7167 return Unit_Entity (Unit_1) = Unit_Entity (Unit_2); 7168 end Is_Same_Unit; 7169 7170 ----------------- 7171 -- Is_Scenario -- 7172 ----------------- 7173 7174 function Is_Scenario (N : Node_Id) return Boolean is 7175 begin 7176 case Nkind (N) is 7177 when N_Assignment_Statement 7178 | N_Attribute_Reference 7179 | N_Call_Marker 7180 | N_Entry_Call_Statement 7181 | N_Expanded_Name 7182 | N_Function_Call 7183 | N_Function_Instantiation 7184 | N_Identifier 7185 | N_Package_Instantiation 7186 | N_Procedure_Call_Statement 7187 | N_Procedure_Instantiation 7188 | N_Requeue_Statement 7189 => 7190 return True; 7191 7192 when others => 7193 return False; 7194 end case; 7195 end Is_Scenario; 7196 7197 ------------------------------ 7198 -- Is_SPARK_Semantic_Target -- 7199 ------------------------------ 7200 7201 function Is_SPARK_Semantic_Target (Id : Entity_Id) return Boolean is 7202 begin 7203 return 7204 Is_Default_Initial_Condition_Proc (Id) 7205 or else Is_Initial_Condition_Proc (Id); 7206 end Is_SPARK_Semantic_Target; 7207 7208 ------------------------ 7209 -- Is_Suitable_Access -- 7210 ------------------------ 7211 7212 function Is_Suitable_Access (N : Node_Id) return Boolean is 7213 Nam : Name_Id; 7214 Pref : Node_Id; 7215 Subp_Id : Entity_Id; 7216 7217 begin 7218 -- This scenario is relevant only when the static model is in effect 7219 -- because it is graph-dependent and does not involve any run-time 7220 -- checks. Allowing it in the dynamic model would create confusing 7221 -- noise. 7222 7223 if not Static_Elaboration_Checks then 7224 return False; 7225 7226 -- Nothing to do when switch -gnatd.U (ignore 'Access) is in effect 7227 7228 elsif Debug_Flag_Dot_UU then 7229 return False; 7230 7231 -- Nothing to do when the scenario is not an attribute reference 7232 7233 elsif Nkind (N) /= N_Attribute_Reference then 7234 return False; 7235 7236 -- Nothing to do for internally-generated attributes because they are 7237 -- assumed to be ABE safe. 7238 7239 elsif not Comes_From_Source (N) then 7240 return False; 7241 end if; 7242 7243 Nam := Attribute_Name (N); 7244 Pref := Prefix (N); 7245 7246 -- Sanitize the prefix of the attribute 7247 7248 if not Is_Entity_Name (Pref) then 7249 return False; 7250 7251 elsif No (Entity (Pref)) then 7252 return False; 7253 end if; 7254 7255 Subp_Id := Entity (Pref); 7256 7257 if not Is_Subprogram_Or_Entry (Subp_Id) then 7258 return False; 7259 end if; 7260 7261 -- Traverse a possible chain of renamings to obtain the original entry 7262 -- or subprogram which the prefix may rename. 7263 7264 Subp_Id := Get_Renamed_Entity (Subp_Id); 7265 7266 -- To qualify, the attribute must meet the following prerequisites: 7267 7268 return 7269 7270 -- The prefix must denote a source entry, operator, or subprogram 7271 -- which is not imported. 7272 7273 Comes_From_Source (Subp_Id) 7274 and then Is_Subprogram_Or_Entry (Subp_Id) 7275 and then not Is_Bodiless_Subprogram (Subp_Id) 7276 7277 -- The attribute name must be one of the 'Access forms. Note that 7278 -- 'Unchecked_Access cannot apply to a subprogram. 7279 7280 and then Nam_In (Nam, Name_Access, Name_Unrestricted_Access); 7281 end Is_Suitable_Access; 7282 7283 ---------------------- 7284 -- Is_Suitable_Call -- 7285 ---------------------- 7286 7287 function Is_Suitable_Call (N : Node_Id) return Boolean is 7288 begin 7289 -- Entry and subprogram calls are intentionally ignored because they 7290 -- may undergo expansion depending on the compilation mode, previous 7291 -- errors, generic context, etc. Call markers play the role of calls 7292 -- and provide a uniform foundation for ABE processing. 7293 7294 return Nkind (N) = N_Call_Marker; 7295 end Is_Suitable_Call; 7296 7297 ------------------------------- 7298 -- Is_Suitable_Instantiation -- 7299 ------------------------------- 7300 7301 function Is_Suitable_Instantiation (N : Node_Id) return Boolean is 7302 Orig_N : constant Node_Id := Original_Node (N); 7303 -- Use the original node in case an instantiation library unit is 7304 -- rewritten as a package or subprogram. 7305 7306 begin 7307 -- To qualify, the instantiation must come from source 7308 7309 return 7310 Comes_From_Source (Orig_N) 7311 and then Nkind (Orig_N) in N_Generic_Instantiation; 7312 end Is_Suitable_Instantiation; 7313 7314 -------------------------- 7315 -- Is_Suitable_Scenario -- 7316 -------------------------- 7317 7318 function Is_Suitable_Scenario (N : Node_Id) return Boolean is 7319 begin 7320 -- NOTE: Derived types and pragma Refined_State are intentionally left 7321 -- out because they are not executable during elaboration. 7322 7323 return 7324 Is_Suitable_Access (N) 7325 or else Is_Suitable_Call (N) 7326 or else Is_Suitable_Instantiation (N) 7327 or else Is_Suitable_Variable_Assignment (N) 7328 or else Is_Suitable_Variable_Reference (N); 7329 end Is_Suitable_Scenario; 7330 7331 ------------------------------------ 7332 -- Is_Suitable_SPARK_Derived_Type -- 7333 ------------------------------------ 7334 7335 function Is_Suitable_SPARK_Derived_Type (N : Node_Id) return Boolean is 7336 Prag : Node_Id; 7337 Typ : Entity_Id; 7338 7339 begin 7340 -- To qualify, the type declaration must denote a derived tagged type 7341 -- with primitive operations, subject to pragma SPARK_Mode On. 7342 7343 if Nkind (N) = N_Full_Type_Declaration 7344 and then Nkind (Type_Definition (N)) = N_Derived_Type_Definition 7345 then 7346 Typ := Defining_Entity (N); 7347 Prag := SPARK_Pragma (Typ); 7348 7349 return 7350 Is_Tagged_Type (Typ) 7351 and then Has_Primitive_Operations (Typ) 7352 and then Present (Prag) 7353 and then Get_SPARK_Mode_From_Annotation (Prag) = On; 7354 end if; 7355 7356 return False; 7357 end Is_Suitable_SPARK_Derived_Type; 7358 7359 ------------------------------------- 7360 -- Is_Suitable_SPARK_Instantiation -- 7361 ------------------------------------- 7362 7363 function Is_Suitable_SPARK_Instantiation (N : Node_Id) return Boolean is 7364 Gen_Attrs : Target_Attributes; 7365 Gen_Id : Entity_Id; 7366 Inst : Node_Id; 7367 Inst_Attrs : Instantiation_Attributes; 7368 Inst_Id : Entity_Id; 7369 7370 begin 7371 -- To qualify, both the instantiation and the generic must be subject to 7372 -- SPARK_Mode On. 7373 7374 if Is_Suitable_Instantiation (N) then 7375 Extract_Instantiation_Attributes 7376 (Exp_Inst => N, 7377 Inst => Inst, 7378 Inst_Id => Inst_Id, 7379 Gen_Id => Gen_Id, 7380 Attrs => Inst_Attrs); 7381 7382 Extract_Target_Attributes (Gen_Id, Gen_Attrs); 7383 7384 return Inst_Attrs.SPARK_Mode_On and Gen_Attrs.SPARK_Mode_On; 7385 end if; 7386 7387 return False; 7388 end Is_Suitable_SPARK_Instantiation; 7389 7390 -------------------------------------------- 7391 -- Is_Suitable_SPARK_Refined_State_Pragma -- 7392 -------------------------------------------- 7393 7394 function Is_Suitable_SPARK_Refined_State_Pragma 7395 (N : Node_Id) return Boolean 7396 is 7397 begin 7398 -- To qualfy, the pragma must denote Refined_State 7399 7400 return 7401 Nkind (N) = N_Pragma 7402 and then Pragma_Name (N) = Name_Refined_State; 7403 end Is_Suitable_SPARK_Refined_State_Pragma; 7404 7405 ------------------------------------- 7406 -- Is_Suitable_Variable_Assignment -- 7407 ------------------------------------- 7408 7409 function Is_Suitable_Variable_Assignment (N : Node_Id) return Boolean is 7410 N_Unit : Node_Id; 7411 N_Unit_Id : Entity_Id; 7412 Nam : Node_Id; 7413 Var_Decl : Node_Id; 7414 Var_Id : Entity_Id; 7415 Var_Unit : Node_Id; 7416 Var_Unit_Id : Entity_Id; 7417 7418 begin 7419 -- This scenario is relevant only when the static model is in effect 7420 -- because it is graph-dependent and does not involve any run-time 7421 -- checks. Allowing it in the dynamic model would create confusing 7422 -- noise. 7423 7424 if not Static_Elaboration_Checks then 7425 return False; 7426 7427 -- Nothing to do when the scenario is not an assignment 7428 7429 elsif Nkind (N) /= N_Assignment_Statement then 7430 return False; 7431 7432 -- Nothing to do for internally-generated assignments because they are 7433 -- assumed to be ABE safe. 7434 7435 elsif not Comes_From_Source (N) then 7436 return False; 7437 7438 -- Assignments are ignored in GNAT mode on the assumption that they are 7439 -- ABE-safe. This behaviour parallels that of the old ABE mechanism. 7440 7441 elsif GNAT_Mode then 7442 return False; 7443 end if; 7444 7445 Nam := Extract_Assignment_Name (N); 7446 7447 -- Sanitize the left hand side of the assignment 7448 7449 if not Is_Entity_Name (Nam) then 7450 return False; 7451 7452 elsif No (Entity (Nam)) then 7453 return False; 7454 end if; 7455 7456 Var_Id := Entity (Nam); 7457 7458 -- Sanitize the variable 7459 7460 if Var_Id = Any_Id then 7461 return False; 7462 7463 elsif Ekind (Var_Id) /= E_Variable then 7464 return False; 7465 end if; 7466 7467 Var_Decl := Declaration_Node (Var_Id); 7468 7469 if Nkind (Var_Decl) /= N_Object_Declaration then 7470 return False; 7471 end if; 7472 7473 N_Unit_Id := Find_Top_Unit (N); 7474 N_Unit := Unit_Declaration_Node (N_Unit_Id); 7475 7476 Var_Unit_Id := Find_Top_Unit (Var_Decl); 7477 Var_Unit := Unit_Declaration_Node (Var_Unit_Id); 7478 7479 -- To qualify, the assignment must meet the following prerequisites: 7480 7481 return 7482 Comes_From_Source (Var_Id) 7483 7484 -- The variable must be declared in the spec of compilation unit U 7485 7486 and then Nkind (Var_Unit) = N_Package_Declaration 7487 7488 -- Performance note: parent traversal 7489 7490 and then Find_Enclosing_Level (Var_Decl) = Package_Spec 7491 7492 -- The assignment must occur in the body of compilation unit U 7493 7494 and then Nkind (N_Unit) = N_Package_Body 7495 and then Present (Corresponding_Body (Var_Unit)) 7496 and then Corresponding_Body (Var_Unit) = N_Unit_Id; 7497 end Is_Suitable_Variable_Assignment; 7498 7499 ------------------------------------ 7500 -- Is_Suitable_Variable_Reference -- 7501 ------------------------------------ 7502 7503 function Is_Suitable_Variable_Reference (N : Node_Id) return Boolean is 7504 begin 7505 -- Expanded names and identifiers are intentionally ignored because they 7506 -- be folded, optimized away, etc. Variable references markers play the 7507 -- role of variable references and provide a uniform foundation for ABE 7508 -- processing. 7509 7510 return Nkind (N) = N_Variable_Reference_Marker; 7511 end Is_Suitable_Variable_Reference; 7512 7513 ------------------------------------ 7514 -- Is_Synchronous_Suspension_Call -- 7515 ------------------------------------ 7516 7517 function Is_Synchronous_Suspension_Call (N : Node_Id) return Boolean is 7518 Call_Attrs : Call_Attributes; 7519 Target_Id : Entity_Id; 7520 7521 begin 7522 -- To qualify, the call must invoke one of the runtime routines which 7523 -- perform synchronous suspension. 7524 7525 if Is_Suitable_Call (N) then 7526 Extract_Call_Attributes 7527 (Call => N, 7528 Target_Id => Target_Id, 7529 Attrs => Call_Attrs); 7530 7531 return 7532 Is_RTE (Target_Id, RE_Suspend_Until_True) 7533 or else 7534 Is_RTE (Target_Id, RE_Wait_For_Release); 7535 end if; 7536 7537 return False; 7538 end Is_Synchronous_Suspension_Call; 7539 7540 ------------------- 7541 -- Is_Task_Entry -- 7542 ------------------- 7543 7544 function Is_Task_Entry (Id : Entity_Id) return Boolean is 7545 begin 7546 -- To qualify, the entity must denote an entry defined in a task type 7547 7548 return 7549 Is_Entry (Id) and then Is_Task_Type (Non_Private_View (Scope (Id))); 7550 end Is_Task_Entry; 7551 7552 ------------------------ 7553 -- Is_Up_Level_Target -- 7554 ------------------------ 7555 7556 function Is_Up_Level_Target (Target_Decl : Node_Id) return Boolean is 7557 Root : constant Node_Id := Root_Scenario; 7558 7559 begin 7560 -- The root appears within the declaratons of a block statement, entry 7561 -- body, subprogram body, or task body ignoring enclosing packages. The 7562 -- root is always within the main unit. An up-level target is a notion 7563 -- applicable only to the static model because scenarios are reached by 7564 -- means of graph traversal started from a fixed declarative or library 7565 -- level. 7566 7567 -- Performance note: parent traversal 7568 7569 if Static_Elaboration_Checks 7570 and then Find_Enclosing_Level (Root) = Declaration_Level 7571 then 7572 -- The target is within the main unit. It acts as an up-level target 7573 -- when it appears within a context which encloses the root. 7574 7575 -- package body Main_Unit is 7576 -- function Func ...; -- target 7577 7578 -- procedure Proc is 7579 -- X : ... := Func; -- root scenario 7580 7581 if In_Extended_Main_Code_Unit (Target_Decl) then 7582 7583 -- Performance note: parent traversal 7584 7585 return not In_Same_Context (Root, Target_Decl, Nested_OK => True); 7586 7587 -- Otherwise the target is external to the main unit which makes it 7588 -- an up-level target. 7589 7590 else 7591 return True; 7592 end if; 7593 end if; 7594 7595 return False; 7596 end Is_Up_Level_Target; 7597 7598 --------------------- 7599 -- Is_Visited_Body -- 7600 --------------------- 7601 7602 function Is_Visited_Body (Body_Decl : Node_Id) return Boolean is 7603 begin 7604 if Visited_Bodies_In_Use then 7605 return Visited_Bodies.Get (Body_Decl); 7606 end if; 7607 7608 return Visited_Bodies_No_Element; 7609 end Is_Visited_Body; 7610 7611 ------------------------------- 7612 -- Kill_Elaboration_Scenario -- 7613 ------------------------------- 7614 7615 procedure Kill_Elaboration_Scenario (N : Node_Id) is 7616 procedure Kill_SPARK_Scenario; 7617 pragma Inline (Kill_SPARK_Scenario); 7618 -- Eliminate scenario N from table SPARK_Scenarios if it is recorded 7619 -- there. 7620 7621 procedure Kill_Top_Level_Scenario; 7622 pragma Inline (Kill_Top_Level_Scenario); 7623 -- Eliminate scenario N from table Top_Level_Scenarios if it is recorded 7624 -- there. 7625 7626 ------------------------- 7627 -- Kill_SPARK_Scenario -- 7628 ------------------------- 7629 7630 procedure Kill_SPARK_Scenario is 7631 package Scenarios renames SPARK_Scenarios; 7632 7633 begin 7634 if Is_Recorded_SPARK_Scenario (N) then 7635 7636 -- Performance note: list traversal 7637 7638 for Index in Scenarios.First .. Scenarios.Last loop 7639 if Scenarios.Table (Index) = N then 7640 Scenarios.Table (Index) := Empty; 7641 7642 -- The SPARK scenario is no longer recorded 7643 7644 Set_Is_Recorded_SPARK_Scenario (N, False); 7645 return; 7646 end if; 7647 end loop; 7648 7649 -- A recorded SPARK scenario must be in the table of recorded 7650 -- SPARK scenarios. 7651 7652 pragma Assert (False); 7653 end if; 7654 end Kill_SPARK_Scenario; 7655 7656 ----------------------------- 7657 -- Kill_Top_Level_Scenario -- 7658 ----------------------------- 7659 7660 procedure Kill_Top_Level_Scenario is 7661 package Scenarios renames Top_Level_Scenarios; 7662 7663 begin 7664 if Is_Recorded_Top_Level_Scenario (N) then 7665 7666 -- Performance node: list traversal 7667 7668 for Index in Scenarios.First .. Scenarios.Last loop 7669 if Scenarios.Table (Index) = N then 7670 Scenarios.Table (Index) := Empty; 7671 7672 -- The top-level scenario is no longer recorded 7673 7674 Set_Is_Recorded_Top_Level_Scenario (N, False); 7675 return; 7676 end if; 7677 end loop; 7678 7679 -- A recorded top-level scenario must be in the table of recorded 7680 -- top-level scenarios. 7681 7682 pragma Assert (False); 7683 end if; 7684 end Kill_Top_Level_Scenario; 7685 7686 -- Start of processing for Kill_Elaboration_Scenario 7687 7688 begin 7689 -- Nothing to do when switch -gnatH (legacy elaboration checking mode 7690 -- enabled) is in effect because the legacy ABE lechanism does not need 7691 -- to carry out this action. 7692 7693 if Legacy_Elaboration_Checks then 7694 return; 7695 end if; 7696 7697 -- Eliminate a recorded scenario when it appears within dead code 7698 -- because it will not be executed at elaboration time. 7699 7700 if Is_Scenario (N) then 7701 Kill_SPARK_Scenario; 7702 Kill_Top_Level_Scenario; 7703 end if; 7704 end Kill_Elaboration_Scenario; 7705 7706 ---------------------------------- 7707 -- Meet_Elaboration_Requirement -- 7708 ---------------------------------- 7709 7710 procedure Meet_Elaboration_Requirement 7711 (N : Node_Id; 7712 Target_Id : Entity_Id; 7713 Req_Nam : Name_Id) 7714 is 7715 Main_Id : constant Entity_Id := Cunit_Entity (Main_Unit); 7716 Unit_Id : constant Entity_Id := Find_Top_Unit (Target_Id); 7717 7718 function Find_Preelaboration_Pragma 7719 (Prag_Nam : Name_Id) return Node_Id; 7720 pragma Inline (Find_Preelaboration_Pragma); 7721 -- Traverse the visible declarations of unit Unit_Id and locate a source 7722 -- preelaboration-related pragma with name Prag_Nam. 7723 7724 procedure Info_Requirement_Met (Prag : Node_Id); 7725 pragma Inline (Info_Requirement_Met); 7726 -- Output information concerning pragma Prag which meets requirement 7727 -- Req_Nam. 7728 7729 procedure Info_Scenario; 7730 pragma Inline (Info_Scenario); 7731 -- Output information concerning scenario N 7732 7733 -------------------------------- 7734 -- Find_Preelaboration_Pragma -- 7735 -------------------------------- 7736 7737 function Find_Preelaboration_Pragma 7738 (Prag_Nam : Name_Id) return Node_Id 7739 is 7740 Spec : constant Node_Id := Parent (Unit_Id); 7741 Decl : Node_Id; 7742 7743 begin 7744 -- A preelaboration-related pragma comes from source and appears at 7745 -- the top of the visible declarations of a package. 7746 7747 if Nkind (Spec) = N_Package_Specification then 7748 Decl := First (Visible_Declarations (Spec)); 7749 while Present (Decl) loop 7750 if Comes_From_Source (Decl) then 7751 if Nkind (Decl) = N_Pragma 7752 and then Pragma_Name (Decl) = Prag_Nam 7753 then 7754 return Decl; 7755 7756 -- Otherwise the construct terminates the region where the 7757 -- preelaboration-related pragma may appear. 7758 7759 else 7760 exit; 7761 end if; 7762 end if; 7763 7764 Next (Decl); 7765 end loop; 7766 end if; 7767 7768 return Empty; 7769 end Find_Preelaboration_Pragma; 7770 7771 -------------------------- 7772 -- Info_Requirement_Met -- 7773 -------------------------- 7774 7775 procedure Info_Requirement_Met (Prag : Node_Id) is 7776 begin 7777 pragma Assert (Present (Prag)); 7778 7779 Error_Msg_Name_1 := Req_Nam; 7780 Error_Msg_Sloc := Sloc (Prag); 7781 Error_Msg_NE 7782 ("\\% requirement for unit & met by pragma #", N, Unit_Id); 7783 end Info_Requirement_Met; 7784 7785 ------------------- 7786 -- Info_Scenario -- 7787 ------------------- 7788 7789 procedure Info_Scenario is 7790 begin 7791 if Is_Suitable_Call (N) then 7792 Info_Call 7793 (Call => N, 7794 Target_Id => Target_Id, 7795 Info_Msg => False, 7796 In_SPARK => True); 7797 7798 elsif Is_Suitable_Instantiation (N) then 7799 Info_Instantiation 7800 (Inst => N, 7801 Gen_Id => Target_Id, 7802 Info_Msg => False, 7803 In_SPARK => True); 7804 7805 elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then 7806 Error_Msg_N 7807 ("read of refinement constituents during elaboration in SPARK", 7808 N); 7809 7810 elsif Is_Suitable_Variable_Reference (N) then 7811 Info_Variable_Reference 7812 (Ref => N, 7813 Var_Id => Target_Id, 7814 Info_Msg => False, 7815 In_SPARK => True); 7816 7817 -- No other scenario may impose a requirement on the context of the 7818 -- main unit. 7819 7820 else 7821 pragma Assert (False); 7822 null; 7823 end if; 7824 end Info_Scenario; 7825 7826 -- Local variables 7827 7828 Elab_Attrs : Elaboration_Attributes; 7829 Elab_Nam : Name_Id; 7830 Req_Met : Boolean; 7831 7832 -- Start of processing for Meet_Elaboration_Requirement 7833 7834 begin 7835 pragma Assert (Nam_In (Req_Nam, Name_Elaborate, Name_Elaborate_All)); 7836 7837 -- Assume that the requirement has not been met 7838 7839 Req_Met := False; 7840 7841 -- Elaboration requirements are verified only when the static model is 7842 -- in effect because this diagnostic is graph-dependent. 7843 7844 if not Static_Elaboration_Checks then 7845 return; 7846 7847 -- If the target is within the main unit, either at the source level or 7848 -- through an instantiation, then there is no real requirement to meet 7849 -- because the main unit cannot force its own elaboration by means of an 7850 -- Elaborate[_All] pragma. Treat this case as valid coverage. 7851 7852 elsif In_Extended_Main_Code_Unit (Target_Id) then 7853 Req_Met := True; 7854 7855 -- Otherwise the target resides in an external unit 7856 7857 -- The requirement is met when the target comes from an internal unit 7858 -- because such a unit is elaborated prior to a non-internal unit. 7859 7860 elsif In_Internal_Unit (Unit_Id) 7861 and then not In_Internal_Unit (Main_Id) 7862 then 7863 Req_Met := True; 7864 7865 -- The requirement is met when the target comes from a preelaborated 7866 -- unit. This portion must parallel predicate Is_Preelaborated_Unit. 7867 7868 elsif Is_Preelaborated_Unit (Unit_Id) then 7869 Req_Met := True; 7870 7871 -- Output extra information when switch -gnatel (info messages on 7872 -- implicit Elaborate[_All] pragmas. 7873 7874 if Elab_Info_Messages then 7875 if Is_Preelaborated (Unit_Id) then 7876 Elab_Nam := Name_Preelaborate; 7877 7878 elsif Is_Pure (Unit_Id) then 7879 Elab_Nam := Name_Pure; 7880 7881 elsif Is_Remote_Call_Interface (Unit_Id) then 7882 Elab_Nam := Name_Remote_Call_Interface; 7883 7884 elsif Is_Remote_Types (Unit_Id) then 7885 Elab_Nam := Name_Remote_Types; 7886 7887 else 7888 pragma Assert (Is_Shared_Passive (Unit_Id)); 7889 Elab_Nam := Name_Shared_Passive; 7890 end if; 7891 7892 Info_Requirement_Met (Find_Preelaboration_Pragma (Elab_Nam)); 7893 end if; 7894 7895 -- Determine whether the context of the main unit has a pragma strong 7896 -- enough to meet the requirement. 7897 7898 else 7899 Elab_Attrs := Elaboration_Status (Unit_Id); 7900 7901 -- The pragma must be either Elaborate_All or be as strong as the 7902 -- requirement. 7903 7904 if Present (Elab_Attrs.Source_Pragma) 7905 and then Nam_In (Pragma_Name (Elab_Attrs.Source_Pragma), 7906 Name_Elaborate_All, 7907 Req_Nam) 7908 then 7909 Req_Met := True; 7910 7911 -- Output extra information when switch -gnatel (info messages on 7912 -- implicit Elaborate[_All] pragmas. 7913 7914 if Elab_Info_Messages then 7915 Info_Requirement_Met (Elab_Attrs.Source_Pragma); 7916 end if; 7917 end if; 7918 end if; 7919 7920 -- The requirement was not met by the context of the main unit, issue an 7921 -- error. 7922 7923 if not Req_Met then 7924 Info_Scenario; 7925 7926 Error_Msg_Name_1 := Req_Nam; 7927 Error_Msg_Node_2 := Unit_Id; 7928 Error_Msg_NE ("\\unit & requires pragma % for &", N, Main_Id); 7929 7930 Output_Active_Scenarios (N); 7931 end if; 7932 end Meet_Elaboration_Requirement; 7933 7934 ---------------------- 7935 -- Non_Private_View -- 7936 ---------------------- 7937 7938 function Non_Private_View (Typ : Entity_Id) return Entity_Id is 7939 begin 7940 if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then 7941 return Full_View (Typ); 7942 else 7943 return Typ; 7944 end if; 7945 end Non_Private_View; 7946 7947 ----------------------------- 7948 -- Output_Active_Scenarios -- 7949 ----------------------------- 7950 7951 procedure Output_Active_Scenarios (Error_Nod : Node_Id) is 7952 procedure Output_Access (N : Node_Id); 7953 -- Emit a specific diagnostic message for 'Access denote by N 7954 7955 procedure Output_Activation_Call (N : Node_Id); 7956 -- Emit a specific diagnostic message for task activation N 7957 7958 procedure Output_Call (N : Node_Id; Target_Id : Entity_Id); 7959 -- Emit a specific diagnostic message for call N which invokes target 7960 -- Target_Id. 7961 7962 procedure Output_Header; 7963 -- Emit a specific diagnostic message for the unit of the root scenario 7964 7965 procedure Output_Instantiation (N : Node_Id); 7966 -- Emit a specific diagnostic message for instantiation N 7967 7968 procedure Output_SPARK_Refined_State_Pragma (N : Node_Id); 7969 -- Emit a specific diagnostic message for Refined_State pragma N 7970 7971 procedure Output_Variable_Assignment (N : Node_Id); 7972 -- Emit a specific diagnostic message for assignment statement N 7973 7974 procedure Output_Variable_Reference (N : Node_Id); 7975 -- Emit a specific diagnostic message for reference N which mentions a 7976 -- variable. 7977 7978 ------------------- 7979 -- Output_Access -- 7980 ------------------- 7981 7982 procedure Output_Access (N : Node_Id) is 7983 Subp_Id : constant Entity_Id := Entity (Prefix (N)); 7984 7985 begin 7986 Error_Msg_Name_1 := Attribute_Name (N); 7987 Error_Msg_Sloc := Sloc (N); 7988 Error_Msg_NE ("\\ % of & taken #", Error_Nod, Subp_Id); 7989 end Output_Access; 7990 7991 ---------------------------- 7992 -- Output_Activation_Call -- 7993 ---------------------------- 7994 7995 procedure Output_Activation_Call (N : Node_Id) is 7996 function Find_Activator (Call : Node_Id) return Entity_Id; 7997 -- Find the nearest enclosing construct which houses call Call 7998 7999 -------------------- 8000 -- Find_Activator -- 8001 -------------------- 8002 8003 function Find_Activator (Call : Node_Id) return Entity_Id is 8004 Par : Node_Id; 8005 8006 begin 8007 -- Climb the parent chain looking for a package [body] or a 8008 -- construct with a statement sequence. 8009 8010 Par := Parent (Call); 8011 while Present (Par) loop 8012 if Nkind_In (Par, N_Package_Body, N_Package_Declaration) then 8013 return Defining_Entity (Par); 8014 8015 elsif Nkind (Par) = N_Handled_Sequence_Of_Statements then 8016 return Defining_Entity (Parent (Par)); 8017 end if; 8018 8019 Par := Parent (Par); 8020 end loop; 8021 8022 return Empty; 8023 end Find_Activator; 8024 8025 -- Local variables 8026 8027 Activator : constant Entity_Id := Find_Activator (N); 8028 8029 -- Start of processing for Output_Activation_Call 8030 8031 begin 8032 pragma Assert (Present (Activator)); 8033 8034 Error_Msg_NE ("\\ local tasks of & activated", Error_Nod, Activator); 8035 end Output_Activation_Call; 8036 8037 ----------------- 8038 -- Output_Call -- 8039 ----------------- 8040 8041 procedure Output_Call (N : Node_Id; Target_Id : Entity_Id) is 8042 procedure Output_Accept_Alternative; 8043 pragma Inline (Output_Accept_Alternative); 8044 -- Emit a specific diagnostic message concerning an accept 8045 -- alternative. 8046 8047 procedure Output_Call (Kind : String); 8048 pragma Inline (Output_Call); 8049 -- Emit a specific diagnostic message concerning a call of kind Kind 8050 8051 procedure Output_Type_Actions (Action : String); 8052 pragma Inline (Output_Type_Actions); 8053 -- Emit a specific diagnostic message concerning action Action of a 8054 -- type. 8055 8056 procedure Output_Verification_Call 8057 (Pred : String; 8058 Id : Entity_Id; 8059 Id_Kind : String); 8060 pragma Inline (Output_Verification_Call); 8061 -- Emit a specific diagnostic message concerning the verification of 8062 -- predicate Pred applied to related entity Id with kind Id_Kind. 8063 8064 ------------------------------- 8065 -- Output_Accept_Alternative -- 8066 ------------------------------- 8067 8068 procedure Output_Accept_Alternative is 8069 Entry_Id : constant Entity_Id := Receiving_Entry (Target_Id); 8070 8071 begin 8072 pragma Assert (Present (Entry_Id)); 8073 8074 Error_Msg_NE ("\\ entry & selected #", Error_Nod, Entry_Id); 8075 end Output_Accept_Alternative; 8076 8077 ----------------- 8078 -- Output_Call -- 8079 ----------------- 8080 8081 procedure Output_Call (Kind : String) is 8082 begin 8083 Error_Msg_NE ("\\ " & Kind & " & called #", Error_Nod, Target_Id); 8084 end Output_Call; 8085 8086 ------------------------- 8087 -- Output_Type_Actions -- 8088 ------------------------- 8089 8090 procedure Output_Type_Actions (Action : String) is 8091 Typ : constant Entity_Id := First_Formal_Type (Target_Id); 8092 8093 begin 8094 pragma Assert (Present (Typ)); 8095 8096 Error_Msg_NE 8097 ("\\ " & Action & " actions for type & #", Error_Nod, Typ); 8098 end Output_Type_Actions; 8099 8100 ------------------------------ 8101 -- Output_Verification_Call -- 8102 ------------------------------ 8103 8104 procedure Output_Verification_Call 8105 (Pred : String; 8106 Id : Entity_Id; 8107 Id_Kind : String) 8108 is 8109 begin 8110 pragma Assert (Present (Id)); 8111 8112 Error_Msg_NE 8113 ("\\ " & Pred & " of " & Id_Kind & " & verified #", 8114 Error_Nod, Id); 8115 end Output_Verification_Call; 8116 8117 -- Start of processing for Output_Call 8118 8119 begin 8120 Error_Msg_Sloc := Sloc (N); 8121 8122 -- Accept alternative 8123 8124 if Is_Accept_Alternative_Proc (Target_Id) then 8125 Output_Accept_Alternative; 8126 8127 -- Adjustment 8128 8129 elsif Is_TSS (Target_Id, TSS_Deep_Adjust) then 8130 Output_Type_Actions ("adjustment"); 8131 8132 -- Default_Initial_Condition 8133 8134 elsif Is_Default_Initial_Condition_Proc (Target_Id) then 8135 Output_Verification_Call 8136 (Pred => "Default_Initial_Condition", 8137 Id => First_Formal_Type (Target_Id), 8138 Id_Kind => "type"); 8139 8140 -- Entries 8141 8142 elsif Is_Protected_Entry (Target_Id) then 8143 Output_Call ("entry"); 8144 8145 -- Task entry calls are never processed because the entry being 8146 -- invoked does not have a corresponding "body", it has a select. A 8147 -- task entry call appears in the stack of active scenarios for the 8148 -- sole purpose of checking No_Entry_Calls_In_Elaboration_Code and 8149 -- nothing more. 8150 8151 elsif Is_Task_Entry (Target_Id) then 8152 null; 8153 8154 -- Finalization 8155 8156 elsif Is_TSS (Target_Id, TSS_Deep_Finalize) then 8157 Output_Type_Actions ("finalization"); 8158 8159 -- Calls to _Finalizer procedures must not appear in the output 8160 -- because this creates confusing noise. 8161 8162 elsif Is_Finalizer_Proc (Target_Id) then 8163 null; 8164 8165 -- Initial_Condition 8166 8167 elsif Is_Initial_Condition_Proc (Target_Id) then 8168 Output_Verification_Call 8169 (Pred => "Initial_Condition", 8170 Id => Find_Enclosing_Scope (N), 8171 Id_Kind => "package"); 8172 8173 -- Initialization 8174 8175 elsif Is_Init_Proc (Target_Id) 8176 or else Is_TSS (Target_Id, TSS_Deep_Initialize) 8177 then 8178 Output_Type_Actions ("initialization"); 8179 8180 -- Invariant 8181 8182 elsif Is_Invariant_Proc (Target_Id) then 8183 Output_Verification_Call 8184 (Pred => "invariants", 8185 Id => First_Formal_Type (Target_Id), 8186 Id_Kind => "type"); 8187 8188 -- Partial invariant calls must not appear in the output because this 8189 -- creates confusing noise. Note that a partial invariant is always 8190 -- invoked by the "full" invariant which is already placed on the 8191 -- stack. 8192 8193 elsif Is_Partial_Invariant_Proc (Target_Id) then 8194 null; 8195 8196 -- _Postconditions 8197 8198 elsif Is_Postconditions_Proc (Target_Id) then 8199 Output_Verification_Call 8200 (Pred => "postconditions", 8201 Id => Find_Enclosing_Scope (N), 8202 Id_Kind => "subprogram"); 8203 8204 -- Subprograms must come last because some of the previous cases fall 8205 -- under this category. 8206 8207 elsif Ekind (Target_Id) = E_Function then 8208 Output_Call ("function"); 8209 8210 elsif Ekind (Target_Id) = E_Procedure then 8211 Output_Call ("procedure"); 8212 8213 else 8214 pragma Assert (False); 8215 null; 8216 end if; 8217 end Output_Call; 8218 8219 ------------------- 8220 -- Output_Header -- 8221 ------------------- 8222 8223 procedure Output_Header is 8224 Unit_Id : constant Entity_Id := Find_Top_Unit (Root_Scenario); 8225 8226 begin 8227 if Ekind (Unit_Id) = E_Package then 8228 Error_Msg_NE ("\\ spec of unit & elaborated", Error_Nod, Unit_Id); 8229 8230 elsif Ekind (Unit_Id) = E_Package_Body then 8231 Error_Msg_NE ("\\ body of unit & elaborated", Error_Nod, Unit_Id); 8232 8233 else 8234 Error_Msg_NE ("\\ in body of unit &", Error_Nod, Unit_Id); 8235 end if; 8236 end Output_Header; 8237 8238 -------------------------- 8239 -- Output_Instantiation -- 8240 -------------------------- 8241 8242 procedure Output_Instantiation (N : Node_Id) is 8243 procedure Output_Instantiation (Gen_Id : Entity_Id; Kind : String); 8244 pragma Inline (Output_Instantiation); 8245 -- Emit a specific diagnostic message concerning an instantiation of 8246 -- generic unit Gen_Id. Kind denotes the kind of the instantiation. 8247 8248 -------------------------- 8249 -- Output_Instantiation -- 8250 -------------------------- 8251 8252 procedure Output_Instantiation (Gen_Id : Entity_Id; Kind : String) is 8253 begin 8254 Error_Msg_NE 8255 ("\\ " & Kind & " & instantiated as & #", Error_Nod, Gen_Id); 8256 end Output_Instantiation; 8257 8258 -- Local variables 8259 8260 Inst : Node_Id; 8261 Inst_Attrs : Instantiation_Attributes; 8262 Inst_Id : Entity_Id; 8263 Gen_Id : Entity_Id; 8264 8265 -- Start of processing for Output_Instantiation 8266 8267 begin 8268 Extract_Instantiation_Attributes 8269 (Exp_Inst => N, 8270 Inst => Inst, 8271 Inst_Id => Inst_Id, 8272 Gen_Id => Gen_Id, 8273 Attrs => Inst_Attrs); 8274 8275 Error_Msg_Node_2 := Inst_Id; 8276 Error_Msg_Sloc := Sloc (Inst); 8277 8278 if Nkind (Inst) = N_Function_Instantiation then 8279 Output_Instantiation (Gen_Id, "function"); 8280 8281 elsif Nkind (Inst) = N_Package_Instantiation then 8282 Output_Instantiation (Gen_Id, "package"); 8283 8284 elsif Nkind (Inst) = N_Procedure_Instantiation then 8285 Output_Instantiation (Gen_Id, "procedure"); 8286 8287 else 8288 pragma Assert (False); 8289 null; 8290 end if; 8291 end Output_Instantiation; 8292 8293 --------------------------------------- 8294 -- Output_SPARK_Refined_State_Pragma -- 8295 --------------------------------------- 8296 8297 procedure Output_SPARK_Refined_State_Pragma (N : Node_Id) is 8298 begin 8299 Error_Msg_Sloc := Sloc (N); 8300 Error_Msg_N ("\\ refinement constituents read #", Error_Nod); 8301 end Output_SPARK_Refined_State_Pragma; 8302 8303 -------------------------------- 8304 -- Output_Variable_Assignment -- 8305 -------------------------------- 8306 8307 procedure Output_Variable_Assignment (N : Node_Id) is 8308 Var_Id : constant Entity_Id := Entity (Extract_Assignment_Name (N)); 8309 8310 begin 8311 Error_Msg_Sloc := Sloc (N); 8312 Error_Msg_NE ("\\ variable & assigned #", Error_Nod, Var_Id); 8313 end Output_Variable_Assignment; 8314 8315 ------------------------------- 8316 -- Output_Variable_Reference -- 8317 ------------------------------- 8318 8319 procedure Output_Variable_Reference (N : Node_Id) is 8320 Dummy : Variable_Attributes; 8321 Var_Id : Entity_Id; 8322 8323 begin 8324 Extract_Variable_Reference_Attributes 8325 (Ref => N, 8326 Var_Id => Var_Id, 8327 Attrs => Dummy); 8328 8329 Error_Msg_Sloc := Sloc (N); 8330 8331 if Is_Read (N) then 8332 Error_Msg_NE ("\\ variable & read #", Error_Nod, Var_Id); 8333 8334 else 8335 pragma Assert (False); 8336 null; 8337 end if; 8338 end Output_Variable_Reference; 8339 8340 -- Local variables 8341 8342 package Stack renames Scenario_Stack; 8343 8344 Dummy : Call_Attributes; 8345 N : Node_Id; 8346 Posted : Boolean; 8347 Target_Id : Entity_Id; 8348 8349 -- Start of processing for Output_Active_Scenarios 8350 8351 begin 8352 -- Active scenarios are emitted only when the static model is in effect 8353 -- because there is an inherent order by which all these scenarios were 8354 -- reached from the declaration or library level. 8355 8356 if not Static_Elaboration_Checks then 8357 return; 8358 end if; 8359 8360 Posted := False; 8361 8362 for Index in Stack.First .. Stack.Last loop 8363 N := Stack.Table (Index); 8364 8365 if not Posted then 8366 Posted := True; 8367 Output_Header; 8368 end if; 8369 8370 -- 'Access 8371 8372 if Nkind (N) = N_Attribute_Reference then 8373 Output_Access (N); 8374 8375 -- Calls 8376 8377 elsif Is_Suitable_Call (N) then 8378 Extract_Call_Attributes 8379 (Call => N, 8380 Target_Id => Target_Id, 8381 Attrs => Dummy); 8382 8383 if Is_Activation_Proc (Target_Id) then 8384 Output_Activation_Call (N); 8385 else 8386 Output_Call (N, Target_Id); 8387 end if; 8388 8389 -- Instantiations 8390 8391 elsif Is_Suitable_Instantiation (N) then 8392 Output_Instantiation (N); 8393 8394 -- Pragma Refined_State 8395 8396 elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then 8397 Output_SPARK_Refined_State_Pragma (N); 8398 8399 -- Variable assignments 8400 8401 elsif Nkind (N) = N_Assignment_Statement then 8402 Output_Variable_Assignment (N); 8403 8404 -- Variable references 8405 8406 elsif Is_Suitable_Variable_Reference (N) then 8407 Output_Variable_Reference (N); 8408 8409 else 8410 pragma Assert (False); 8411 null; 8412 end if; 8413 end loop; 8414 end Output_Active_Scenarios; 8415 8416 ------------------------- 8417 -- Pop_Active_Scenario -- 8418 ------------------------- 8419 8420 procedure Pop_Active_Scenario (N : Node_Id) is 8421 Top : Node_Id renames Scenario_Stack.Table (Scenario_Stack.Last); 8422 8423 begin 8424 pragma Assert (Top = N); 8425 Scenario_Stack.Decrement_Last; 8426 end Pop_Active_Scenario; 8427 8428 -------------------------------- 8429 -- Process_Activation_Generic -- 8430 -------------------------------- 8431 8432 procedure Process_Activation_Generic 8433 (Call : Node_Id; 8434 Call_Attrs : Call_Attributes; 8435 State : Processing_Attributes) 8436 is 8437 procedure Process_Task_Object (Obj_Id : Entity_Id; Typ : Entity_Id); 8438 -- Perform ABE checks and diagnostics for object Obj_Id with type Typ. 8439 -- Typ may be a task type or a composite type with at least one task 8440 -- component. 8441 8442 procedure Process_Task_Objects (List : List_Id); 8443 -- Perform ABE checks and diagnostics for all task objects found in the 8444 -- list List. 8445 8446 ------------------------- 8447 -- Process_Task_Object -- 8448 ------------------------- 8449 8450 procedure Process_Task_Object (Obj_Id : Entity_Id; Typ : Entity_Id) is 8451 Base_Typ : constant Entity_Id := Base_Type (Typ); 8452 8453 Comp_Id : Entity_Id; 8454 Task_Attrs : Task_Attributes; 8455 8456 New_State : Processing_Attributes := State; 8457 -- Each step of the Processing phase constitutes a new state 8458 8459 begin 8460 if Is_Task_Type (Typ) then 8461 Extract_Task_Attributes 8462 (Typ => Base_Typ, 8463 Attrs => Task_Attrs); 8464 8465 -- Warnings are suppressed when a prior scenario is already in 8466 -- that mode, or when the object, activation call, or task type 8467 -- have warnings suppressed. Update the state of the Processing 8468 -- phase to reflect this. 8469 8470 New_State.Suppress_Warnings := 8471 New_State.Suppress_Warnings 8472 or else not Is_Elaboration_Warnings_OK_Id (Obj_Id) 8473 or else not Call_Attrs.Elab_Warnings_OK 8474 or else not Task_Attrs.Elab_Warnings_OK; 8475 8476 -- Update the state of the Processing phase to indicate that any 8477 -- further traversal is now within a task body. 8478 8479 New_State.Within_Task_Body := True; 8480 8481 Process_Single_Activation 8482 (Call => Call, 8483 Call_Attrs => Call_Attrs, 8484 Obj_Id => Obj_Id, 8485 Task_Attrs => Task_Attrs, 8486 State => New_State); 8487 8488 -- Examine the component type when the object is an array 8489 8490 elsif Is_Array_Type (Typ) and then Has_Task (Base_Typ) then 8491 Process_Task_Object 8492 (Obj_Id => Obj_Id, 8493 Typ => Component_Type (Typ)); 8494 8495 -- Examine individual component types when the object is a record 8496 8497 elsif Is_Record_Type (Typ) and then Has_Task (Base_Typ) then 8498 Comp_Id := First_Component (Typ); 8499 while Present (Comp_Id) loop 8500 Process_Task_Object 8501 (Obj_Id => Obj_Id, 8502 Typ => Etype (Comp_Id)); 8503 8504 Next_Component (Comp_Id); 8505 end loop; 8506 end if; 8507 end Process_Task_Object; 8508 8509 -------------------------- 8510 -- Process_Task_Objects -- 8511 -------------------------- 8512 8513 procedure Process_Task_Objects (List : List_Id) is 8514 Item : Node_Id; 8515 Item_Id : Entity_Id; 8516 Item_Typ : Entity_Id; 8517 8518 begin 8519 -- Examine the contents of the list looking for an object declaration 8520 -- of a task type or one that contains a task within. 8521 8522 Item := First (List); 8523 while Present (Item) loop 8524 if Nkind (Item) = N_Object_Declaration then 8525 Item_Id := Defining_Entity (Item); 8526 Item_Typ := Etype (Item_Id); 8527 8528 if Has_Task (Item_Typ) then 8529 Process_Task_Object 8530 (Obj_Id => Item_Id, 8531 Typ => Item_Typ); 8532 end if; 8533 end if; 8534 8535 Next (Item); 8536 end loop; 8537 end Process_Task_Objects; 8538 8539 -- Local variables 8540 8541 Context : Node_Id; 8542 Spec : Node_Id; 8543 8544 -- Start of processing for Process_Activation_Generic 8545 8546 begin 8547 -- Nothing to do when the activation is a guaranteed ABE 8548 8549 if Is_Known_Guaranteed_ABE (Call) then 8550 return; 8551 end if; 8552 8553 -- Find the proper context of the activation call where all task objects 8554 -- being activated are declared. This is usually the immediate parent of 8555 -- the call. 8556 8557 Context := Parent (Call); 8558 8559 -- In the case of package bodies, the activation call is in the handled 8560 -- sequence of statements, but the task objects are in the declaration 8561 -- list of the body. 8562 8563 if Nkind (Context) = N_Handled_Sequence_Of_Statements 8564 and then Nkind (Parent (Context)) = N_Package_Body 8565 then 8566 Context := Parent (Context); 8567 end if; 8568 8569 -- Process all task objects defined in both the spec and body when the 8570 -- activation call precedes the "begin" of a package body. 8571 8572 if Nkind (Context) = N_Package_Body then 8573 Spec := 8574 Specification 8575 (Unit_Declaration_Node (Corresponding_Spec (Context))); 8576 8577 Process_Task_Objects (Visible_Declarations (Spec)); 8578 Process_Task_Objects (Private_Declarations (Spec)); 8579 Process_Task_Objects (Declarations (Context)); 8580 8581 -- Process all task objects defined in the spec when the activation call 8582 -- appears at the end of a package spec. 8583 8584 elsif Nkind (Context) = N_Package_Specification then 8585 Process_Task_Objects (Visible_Declarations (Context)); 8586 Process_Task_Objects (Private_Declarations (Context)); 8587 8588 -- Otherwise the context of the activation is some construct with a 8589 -- declarative part. Note that the corresponding record type of a task 8590 -- type is controlled. Because of this, the finalization machinery must 8591 -- relocate the task object to the handled statements of the construct 8592 -- to perform proper finalization in case of an exception. Examine the 8593 -- statements of the construct rather than the declarations. 8594 8595 else 8596 pragma Assert (Nkind (Context) = N_Handled_Sequence_Of_Statements); 8597 8598 Process_Task_Objects (Statements (Context)); 8599 end if; 8600 end Process_Activation_Generic; 8601 8602 ------------------------------------ 8603 -- Process_Conditional_ABE_Access -- 8604 ------------------------------------ 8605 8606 procedure Process_Conditional_ABE_Access 8607 (Attr : Node_Id; 8608 State : Processing_Attributes) 8609 is 8610 function Build_Access_Marker (Target_Id : Entity_Id) return Node_Id; 8611 pragma Inline (Build_Access_Marker); 8612 -- Create a suitable call marker which invokes target Target_Id 8613 8614 ------------------------- 8615 -- Build_Access_Marker -- 8616 ------------------------- 8617 8618 function Build_Access_Marker (Target_Id : Entity_Id) return Node_Id is 8619 Marker : Node_Id; 8620 8621 begin 8622 Marker := Make_Call_Marker (Sloc (Attr)); 8623 8624 -- Inherit relevant attributes from the attribute 8625 8626 -- Performance note: parent traversal 8627 8628 Set_Target (Marker, Target_Id); 8629 Set_Is_Declaration_Level_Node 8630 (Marker, Find_Enclosing_Level (Attr) = Declaration_Level); 8631 Set_Is_Dispatching_Call 8632 (Marker, False); 8633 Set_Is_Elaboration_Checks_OK_Node 8634 (Marker, Is_Elaboration_Checks_OK_Node (Attr)); 8635 Set_Is_Elaboration_Warnings_OK_Node 8636 (Marker, Is_Elaboration_Warnings_OK_Node (Attr)); 8637 Set_Is_Source_Call 8638 (Marker, Comes_From_Source (Attr)); 8639 Set_Is_SPARK_Mode_On_Node 8640 (Marker, Is_SPARK_Mode_On_Node (Attr)); 8641 8642 -- Partially insert the call marker into the tree by setting its 8643 -- parent pointer. 8644 8645 Set_Parent (Marker, Attr); 8646 8647 return Marker; 8648 end Build_Access_Marker; 8649 8650 -- Local variables 8651 8652 Root : constant Node_Id := Root_Scenario; 8653 Target_Id : constant Entity_Id := Entity (Prefix (Attr)); 8654 8655 Target_Attrs : Target_Attributes; 8656 8657 New_State : Processing_Attributes := State; 8658 -- Each step of the Processing phase constitutes a new state 8659 8660 -- Start of processing for Process_Conditional_ABE_Access 8661 8662 begin 8663 -- Output relevant information when switch -gnatel (info messages on 8664 -- implicit Elaborate[_All] pragmas) is in effect. 8665 8666 if Elab_Info_Messages then 8667 Error_Msg_NE 8668 ("info: access to & during elaboration", Attr, Target_Id); 8669 end if; 8670 8671 Extract_Target_Attributes 8672 (Target_Id => Target_Id, 8673 Attrs => Target_Attrs); 8674 8675 -- Warnings are suppressed when a prior scenario is already in that 8676 -- mode, or when the attribute or the target have warnings suppressed. 8677 -- Update the state of the Processing phase to reflect this. 8678 8679 New_State.Suppress_Warnings := 8680 New_State.Suppress_Warnings 8681 or else not Is_Elaboration_Warnings_OK_Node (Attr) 8682 or else not Target_Attrs.Elab_Warnings_OK; 8683 8684 -- Do not emit any ABE diagnostics when the current or previous scenario 8685 -- in this traversal has suppressed elaboration warnings. 8686 8687 if New_State.Suppress_Warnings then 8688 null; 8689 8690 -- Both the attribute and the corresponding body are in the same unit. 8691 -- The corresponding body must appear prior to the root scenario which 8692 -- started the recursive search. If this is not the case, then there is 8693 -- a potential ABE if the access value is used to call the subprogram. 8694 -- Emit a warning only when switch -gnatw.f (warnings on suspucious 8695 -- 'Access) is in effect. 8696 8697 elsif Warn_On_Elab_Access 8698 and then Present (Target_Attrs.Body_Decl) 8699 and then In_Extended_Main_Code_Unit (Target_Attrs.Body_Decl) 8700 and then Earlier_In_Extended_Unit (Root, Target_Attrs.Body_Decl) 8701 then 8702 Error_Msg_Name_1 := Attribute_Name (Attr); 8703 Error_Msg_NE ("??% attribute of & before body seen", Attr, Target_Id); 8704 Error_Msg_N ("\possible Program_Error on later references", Attr); 8705 8706 Output_Active_Scenarios (Attr); 8707 end if; 8708 8709 -- Treat the attribute as an immediate invocation of the target when 8710 -- switch -gnatd.o (conservative elaboration order for indirect calls) 8711 -- is in effect. Note that the prior elaboration of the unit containing 8712 -- the target is ensured processing the corresponding call marker. 8713 8714 if Debug_Flag_Dot_O then 8715 Process_Conditional_ABE 8716 (N => Build_Access_Marker (Target_Id), 8717 State => New_State); 8718 8719 -- Otherwise ensure that the unit with the corresponding body is 8720 -- elaborated prior to the main unit. 8721 8722 else 8723 Ensure_Prior_Elaboration 8724 (N => Attr, 8725 Unit_Id => Target_Attrs.Unit_Id, 8726 Prag_Nam => Name_Elaborate_All, 8727 State => New_State); 8728 end if; 8729 end Process_Conditional_ABE_Access; 8730 8731 --------------------------------------------- 8732 -- Process_Conditional_ABE_Activation_Impl -- 8733 --------------------------------------------- 8734 8735 procedure Process_Conditional_ABE_Activation_Impl 8736 (Call : Node_Id; 8737 Call_Attrs : Call_Attributes; 8738 Obj_Id : Entity_Id; 8739 Task_Attrs : Task_Attributes; 8740 State : Processing_Attributes) 8741 is 8742 Check_OK : constant Boolean := 8743 not Is_Ignored_Ghost_Entity (Obj_Id) 8744 and then not Task_Attrs.Ghost_Mode_Ignore 8745 and then Is_Elaboration_Checks_OK_Id (Obj_Id) 8746 and then Task_Attrs.Elab_Checks_OK; 8747 -- A run-time ABE check may be installed only when the object and the 8748 -- task type have active elaboration checks, and both are not ignored 8749 -- Ghost constructs. 8750 8751 Root : constant Node_Id := Root_Scenario; 8752 8753 New_State : Processing_Attributes := State; 8754 -- Each step of the Processing phase constitutes a new state 8755 8756 begin 8757 -- Output relevant information when switch -gnatel (info messages on 8758 -- implicit Elaborate[_All] pragmas) is in effect. 8759 8760 if Elab_Info_Messages then 8761 Error_Msg_NE 8762 ("info: activation of & during elaboration", Call, Obj_Id); 8763 end if; 8764 8765 -- Nothing to do when the call activates a task whose type is defined 8766 -- within an instance and switch -gnatd_i (ignore activations and calls 8767 -- to instances for elaboration) is in effect. 8768 8769 if Debug_Flag_Underscore_I 8770 and then In_External_Instance 8771 (N => Call, 8772 Target_Decl => Task_Attrs.Task_Decl) 8773 then 8774 return; 8775 8776 -- Nothing to do when the activation is a guaranteed ABE 8777 8778 elsif Is_Known_Guaranteed_ABE (Call) then 8779 return; 8780 8781 -- Nothing to do when the root scenario appears at the declaration 8782 -- level and the task is in the same unit, but outside this context. 8783 -- 8784 -- task type Task_Typ; -- task declaration 8785 -- 8786 -- procedure Proc is 8787 -- function A ... is 8788 -- begin 8789 -- if Some_Condition then 8790 -- declare 8791 -- T : Task_Typ; 8792 -- begin 8793 -- <activation call> -- activation site 8794 -- end; 8795 -- ... 8796 -- end A; 8797 -- 8798 -- X : ... := A; -- root scenario 8799 -- ... 8800 -- 8801 -- task body Task_Typ is 8802 -- ... 8803 -- end Task_Typ; 8804 -- 8805 -- In the example above, the context of X is the declarative list of 8806 -- Proc. The "elaboration" of X may reach the activation of T whose body 8807 -- is defined outside of X's context. The task body is relevant only 8808 -- when Proc is invoked, but this happens only in "normal" elaboration, 8809 -- therefore the task body must not be considered if this is not the 8810 -- case. 8811 8812 -- Performance note: parent traversal 8813 8814 elsif Is_Up_Level_Target (Task_Attrs.Task_Decl) then 8815 return; 8816 8817 -- Nothing to do when the activation is ABE-safe 8818 -- 8819 -- generic 8820 -- package Gen is 8821 -- task type Task_Typ; 8822 -- end Gen; 8823 -- 8824 -- package body Gen is 8825 -- task body Task_Typ is 8826 -- begin 8827 -- ... 8828 -- end Task_Typ; 8829 -- end Gen; 8830 -- 8831 -- with Gen; 8832 -- procedure Main is 8833 -- package Nested is 8834 -- package Inst is new Gen; 8835 -- T : Inst.Task_Typ; 8836 -- <activation call> -- safe activation 8837 -- end Nested; 8838 -- ... 8839 8840 elsif Is_Safe_Activation (Call, Task_Attrs.Task_Decl) then 8841 8842 -- Note that the task body must still be examined for any nested 8843 -- scenarios. 8844 8845 null; 8846 8847 -- The activation call and the task body are both in the main unit 8848 8849 elsif Present (Task_Attrs.Body_Decl) 8850 and then In_Extended_Main_Code_Unit (Task_Attrs.Body_Decl) 8851 then 8852 -- If the root scenario appears prior to the task body, then this is 8853 -- a possible ABE with respect to the root scenario. 8854 -- 8855 -- task type Task_Typ; 8856 -- 8857 -- function A ... is 8858 -- begin 8859 -- if Some_Condition then 8860 -- declare 8861 -- package Pack is 8862 -- T : Task_Typ; 8863 -- end Pack; -- activation of T 8864 -- ... 8865 -- end A; 8866 -- 8867 -- X : ... := A; -- root scenario 8868 -- 8869 -- task body Task_Typ is -- task body 8870 -- ... 8871 -- end Task_Typ; 8872 -- 8873 -- Y : ... := A; -- root scenario 8874 -- 8875 -- IMPORTANT: The activation of T is a possible ABE for X, but 8876 -- not for Y. Intalling an unconditional ABE raise prior to the 8877 -- activation call would be wrong as it will fail for Y as well 8878 -- but in Y's case the activation of T is never an ABE. 8879 8880 if Earlier_In_Extended_Unit (Root, Task_Attrs.Body_Decl) then 8881 8882 -- Do not emit any ABE diagnostics when a previous scenario in 8883 -- this traversal has suppressed elaboration warnings. 8884 8885 if State.Suppress_Warnings then 8886 null; 8887 8888 -- Do not emit any ABE diagnostics when the activation occurs in 8889 -- a partial finalization context because this leads to confusing 8890 -- noise. 8891 8892 elsif State.Within_Partial_Finalization then 8893 null; 8894 8895 -- ABE diagnostics are emitted only in the static model because 8896 -- there is a well-defined order to visiting scenarios. Without 8897 -- this order diagnostics appear jumbled and result in unwanted 8898 -- noise. 8899 8900 elsif Static_Elaboration_Checks then 8901 Error_Msg_Sloc := Sloc (Call); 8902 Error_Msg_N 8903 ("??task & will be activated # before elaboration of its " 8904 & "body", Obj_Id); 8905 Error_Msg_N 8906 ("\Program_Error may be raised at run time", Obj_Id); 8907 8908 Output_Active_Scenarios (Obj_Id); 8909 end if; 8910 8911 -- Install a conditional run-time ABE check to verify that the 8912 -- task body has been elaborated prior to the activation call. 8913 8914 if Check_OK then 8915 Install_ABE_Check 8916 (N => Call, 8917 Ins_Nod => Call, 8918 Target_Id => Task_Attrs.Spec_Id, 8919 Target_Decl => Task_Attrs.Task_Decl, 8920 Target_Body => Task_Attrs.Body_Decl); 8921 8922 -- Update the state of the Processing phase to indicate that 8923 -- no implicit Elaborate[_All] pragmas must be generated from 8924 -- this point on. 8925 -- 8926 -- task type Task_Typ; 8927 -- 8928 -- function A ... is 8929 -- begin 8930 -- if Some_Condition then 8931 -- declare 8932 -- package Pack is 8933 -- <ABE check> 8934 -- T : Task_Typ; 8935 -- end Pack; -- activation of T 8936 -- ... 8937 -- end A; 8938 -- 8939 -- X : ... := A; 8940 -- 8941 -- task body Task_Typ is 8942 -- begin 8943 -- External.Subp; -- imparts Elaborate_All 8944 -- end Task_Typ; 8945 -- 8946 -- If Some_Condition is True, then the ABE check will fail at 8947 -- runtime and the call to External.Subp will never take place, 8948 -- rendering the implicit Elaborate_All useless. 8949 -- 8950 -- If Some_Condition is False, then the call to External.Subp 8951 -- will never take place, rendering the implicit Elaborate_All 8952 -- useless. 8953 8954 New_State.Suppress_Implicit_Pragmas := True; 8955 end if; 8956 end if; 8957 8958 -- Otherwise the task body is not available in this compilation or it 8959 -- resides in an external unit. Install a run-time ABE check to verify 8960 -- that the task body has been elaborated prior to the activation call 8961 -- when the dynamic model is in effect. 8962 8963 elsif Dynamic_Elaboration_Checks and then Check_OK then 8964 Install_ABE_Check 8965 (N => Call, 8966 Ins_Nod => Call, 8967 Id => Task_Attrs.Unit_Id); 8968 end if; 8969 8970 -- Both the activation call and task type are subject to SPARK_Mode 8971 -- On, this triggers the SPARK rules for task activation. Compared to 8972 -- calls and instantiations, task activation in SPARK does not require 8973 -- the presence of Elaborate[_All] pragmas in case the task type is 8974 -- defined outside the main unit. This is because SPARK utilizes a 8975 -- special policy which activates all tasks after the main unit has 8976 -- finished its elaboration. 8977 8978 if Call_Attrs.SPARK_Mode_On and Task_Attrs.SPARK_Mode_On then 8979 null; 8980 8981 -- Otherwise the Ada rules are in effect. Ensure that the unit with the 8982 -- task body is elaborated prior to the main unit. 8983 8984 else 8985 Ensure_Prior_Elaboration 8986 (N => Call, 8987 Unit_Id => Task_Attrs.Unit_Id, 8988 Prag_Nam => Name_Elaborate_All, 8989 State => New_State); 8990 end if; 8991 8992 Traverse_Body 8993 (N => Task_Attrs.Body_Decl, 8994 State => New_State); 8995 end Process_Conditional_ABE_Activation_Impl; 8996 8997 procedure Process_Conditional_ABE_Activation is 8998 new Process_Activation_Generic (Process_Conditional_ABE_Activation_Impl); 8999 9000 ---------------------------------- 9001 -- Process_Conditional_ABE_Call -- 9002 ---------------------------------- 9003 9004 procedure Process_Conditional_ABE_Call 9005 (Call : Node_Id; 9006 Call_Attrs : Call_Attributes; 9007 Target_Id : Entity_Id; 9008 State : Processing_Attributes) 9009 is 9010 function In_Initialization_Context (N : Node_Id) return Boolean; 9011 -- Determine whether arbitrary node N appears within a type init proc, 9012 -- primitive [Deep_]Initialize, or a block created for initialization 9013 -- purposes. 9014 9015 function Is_Partial_Finalization_Proc return Boolean; 9016 pragma Inline (Is_Partial_Finalization_Proc); 9017 -- Determine whether call Call with target Target_Id invokes a partial 9018 -- finalization procedure. 9019 9020 ------------------------------- 9021 -- In_Initialization_Context -- 9022 ------------------------------- 9023 9024 function In_Initialization_Context (N : Node_Id) return Boolean is 9025 Par : Node_Id; 9026 Spec_Id : Entity_Id; 9027 9028 begin 9029 -- Climb the parent chain looking for initialization actions 9030 9031 Par := Parent (N); 9032 while Present (Par) loop 9033 9034 -- A block may be part of the initialization actions of a default 9035 -- initialized object. 9036 9037 if Nkind (Par) = N_Block_Statement 9038 and then Is_Initialization_Block (Par) 9039 then 9040 return True; 9041 9042 -- A subprogram body may denote an initialization routine 9043 9044 elsif Nkind (Par) = N_Subprogram_Body then 9045 Spec_Id := Unique_Defining_Entity (Par); 9046 9047 -- The current subprogram body denotes a type init proc or 9048 -- primitive [Deep_]Initialize. 9049 9050 if Is_Init_Proc (Spec_Id) 9051 or else Is_Controlled_Proc (Spec_Id, Name_Initialize) 9052 or else Is_TSS (Spec_Id, TSS_Deep_Initialize) 9053 then 9054 return True; 9055 end if; 9056 9057 -- Prevent the search from going too far 9058 9059 elsif Is_Body_Or_Package_Declaration (Par) then 9060 exit; 9061 end if; 9062 9063 Par := Parent (Par); 9064 end loop; 9065 9066 return False; 9067 end In_Initialization_Context; 9068 9069 ---------------------------------- 9070 -- Is_Partial_Finalization_Proc -- 9071 ---------------------------------- 9072 9073 function Is_Partial_Finalization_Proc return Boolean is 9074 begin 9075 -- To qualify, the target must denote primitive [Deep_]Finalize or a 9076 -- finalizer procedure, and the call must appear in an initialization 9077 -- context. 9078 9079 return 9080 (Is_Controlled_Proc (Target_Id, Name_Finalize) 9081 or else Is_Finalizer_Proc (Target_Id) 9082 or else Is_TSS (Target_Id, TSS_Deep_Finalize)) 9083 and then In_Initialization_Context (Call); 9084 end Is_Partial_Finalization_Proc; 9085 9086 -- Local variables 9087 9088 SPARK_Rules_On : Boolean; 9089 Target_Attrs : Target_Attributes; 9090 9091 New_State : Processing_Attributes := State; 9092 -- Each step of the Processing phase constitutes a new state 9093 9094 -- Start of processing for Process_Conditional_ABE_Call 9095 9096 begin 9097 Extract_Target_Attributes 9098 (Target_Id => Target_Id, 9099 Attrs => Target_Attrs); 9100 9101 -- The SPARK rules are in effect when both the call and target are 9102 -- subject to SPARK_Mode On. 9103 9104 SPARK_Rules_On := 9105 Call_Attrs.SPARK_Mode_On and Target_Attrs.SPARK_Mode_On; 9106 9107 -- Output relevant information when switch -gnatel (info messages on 9108 -- implicit Elaborate[_All] pragmas) is in effect. 9109 9110 if Elab_Info_Messages then 9111 Info_Call 9112 (Call => Call, 9113 Target_Id => Target_Id, 9114 Info_Msg => True, 9115 In_SPARK => SPARK_Rules_On); 9116 end if; 9117 9118 -- Check whether the invocation of an entry clashes with an existing 9119 -- restriction. 9120 9121 if Is_Protected_Entry (Target_Id) then 9122 Check_Restriction (No_Entry_Calls_In_Elaboration_Code, Call); 9123 9124 elsif Is_Task_Entry (Target_Id) then 9125 Check_Restriction (No_Entry_Calls_In_Elaboration_Code, Call); 9126 9127 -- Task entry calls are never processed because the entry being 9128 -- invoked does not have a corresponding "body", it has a select. 9129 9130 return; 9131 end if; 9132 9133 -- Nothing to do when the call invokes a target defined within an 9134 -- instance and switch -gnatd_i (ignore activations and calls to 9135 -- instances for elaboration) is in effect. 9136 9137 if Debug_Flag_Underscore_I 9138 and then In_External_Instance 9139 (N => Call, 9140 Target_Decl => Target_Attrs.Spec_Decl) 9141 then 9142 return; 9143 9144 -- Nothing to do when the call is a guaranteed ABE 9145 9146 elsif Is_Known_Guaranteed_ABE (Call) then 9147 return; 9148 9149 -- Nothing to do when the root scenario appears at the declaration level 9150 -- and the target is in the same unit, but outside this context. 9151 -- 9152 -- function B ...; -- target declaration 9153 -- 9154 -- procedure Proc is 9155 -- function A ... is 9156 -- begin 9157 -- if Some_Condition then 9158 -- return B; -- call site 9159 -- ... 9160 -- end A; 9161 -- 9162 -- X : ... := A; -- root scenario 9163 -- ... 9164 -- 9165 -- function B ... is 9166 -- ... 9167 -- end B; 9168 -- 9169 -- In the example above, the context of X is the declarative region of 9170 -- Proc. The "elaboration" of X may eventually reach B which is defined 9171 -- outside of X's context. B is relevant only when Proc is invoked, but 9172 -- this happens only by means of "normal" elaboration, therefore B must 9173 -- not be considered if this is not the case. 9174 9175 -- Performance note: parent traversal 9176 9177 elsif Is_Up_Level_Target (Target_Attrs.Spec_Decl) then 9178 return; 9179 end if; 9180 9181 -- Warnings are suppressed when a prior scenario is already in that 9182 -- mode, or the call or target have warnings suppressed. Update the 9183 -- state of the Processing phase to reflect this. 9184 9185 New_State.Suppress_Warnings := 9186 New_State.Suppress_Warnings 9187 or else not Call_Attrs.Elab_Warnings_OK 9188 or else not Target_Attrs.Elab_Warnings_OK; 9189 9190 -- The call occurs in an initial condition context when a prior scenario 9191 -- is already in that mode, or when the target is an Initial_Condition 9192 -- procedure. Update the state of the Processing phase to reflect this. 9193 9194 New_State.Within_Initial_Condition := 9195 New_State.Within_Initial_Condition 9196 or else Is_Initial_Condition_Proc (Target_Id); 9197 9198 -- The call occurs in a partial finalization context when a prior 9199 -- scenario is already in that mode, or when the target denotes a 9200 -- [Deep_]Finalize primitive or a finalizer within an initialization 9201 -- context. Update the state of the Processing phase to reflect this. 9202 9203 New_State.Within_Partial_Finalization := 9204 New_State.Within_Partial_Finalization 9205 or else Is_Partial_Finalization_Proc; 9206 9207 -- The SPARK rules are in effect. Note that -gnatd.v (enforce SPARK 9208 -- elaboration rules in SPARK code) is intentionally not taken into 9209 -- account here because Process_Conditional_ABE_Call_SPARK has two 9210 -- separate modes of operation. 9211 9212 if SPARK_Rules_On then 9213 Process_Conditional_ABE_Call_SPARK 9214 (Call => Call, 9215 Target_Id => Target_Id, 9216 Target_Attrs => Target_Attrs, 9217 State => New_State); 9218 9219 -- Otherwise the Ada rules are in effect 9220 9221 else 9222 Process_Conditional_ABE_Call_Ada 9223 (Call => Call, 9224 Call_Attrs => Call_Attrs, 9225 Target_Id => Target_Id, 9226 Target_Attrs => Target_Attrs, 9227 State => New_State); 9228 end if; 9229 9230 -- Inspect the target body (and barried function) for other suitable 9231 -- elaboration scenarios. 9232 9233 Traverse_Body 9234 (N => Target_Attrs.Body_Barf, 9235 State => New_State); 9236 9237 Traverse_Body 9238 (N => Target_Attrs.Body_Decl, 9239 State => New_State); 9240 end Process_Conditional_ABE_Call; 9241 9242 -------------------------------------- 9243 -- Process_Conditional_ABE_Call_Ada -- 9244 -------------------------------------- 9245 9246 procedure Process_Conditional_ABE_Call_Ada 9247 (Call : Node_Id; 9248 Call_Attrs : Call_Attributes; 9249 Target_Id : Entity_Id; 9250 Target_Attrs : Target_Attributes; 9251 State : Processing_Attributes) 9252 is 9253 Check_OK : constant Boolean := 9254 not Call_Attrs.Ghost_Mode_Ignore 9255 and then not Target_Attrs.Ghost_Mode_Ignore 9256 and then Call_Attrs.Elab_Checks_OK 9257 and then Target_Attrs.Elab_Checks_OK; 9258 -- A run-time ABE check may be installed only when both the call and the 9259 -- target have active elaboration checks, and both are not ignored Ghost 9260 -- constructs. 9261 9262 Root : constant Node_Id := Root_Scenario; 9263 9264 New_State : Processing_Attributes := State; 9265 -- Each step of the Processing phase constitutes a new state 9266 9267 begin 9268 -- Nothing to do for an Ada dispatching call because there are no ABE 9269 -- diagnostics for either models. ABE checks for the dynamic model are 9270 -- handled by Install_Primitive_Elaboration_Check. 9271 9272 if Call_Attrs.Is_Dispatching then 9273 return; 9274 9275 -- Nothing to do when the call is ABE-safe 9276 -- 9277 -- generic 9278 -- function Gen ...; 9279 -- 9280 -- function Gen ... is 9281 -- begin 9282 -- ... 9283 -- end Gen; 9284 -- 9285 -- with Gen; 9286 -- procedure Main is 9287 -- function Inst is new Gen; 9288 -- X : ... := Inst; -- safe call 9289 -- ... 9290 9291 elsif Is_Safe_Call (Call, Target_Attrs) then 9292 return; 9293 9294 -- The call and the target body are both in the main unit 9295 9296 elsif Present (Target_Attrs.Body_Decl) 9297 and then In_Extended_Main_Code_Unit (Target_Attrs.Body_Decl) 9298 then 9299 -- If the root scenario appears prior to the target body, then this 9300 -- is a possible ABE with respect to the root scenario. 9301 -- 9302 -- function B ...; 9303 -- 9304 -- function A ... is 9305 -- begin 9306 -- if Some_Condition then 9307 -- return B; -- call site 9308 -- ... 9309 -- end A; 9310 -- 9311 -- X : ... := A; -- root scenario 9312 -- 9313 -- function B ... is -- target body 9314 -- ... 9315 -- end B; 9316 -- 9317 -- Y : ... := A; -- root scenario 9318 -- 9319 -- IMPORTANT: The call to B from A is a possible ABE for X, but not 9320 -- for Y. Installing an unconditional ABE raise prior to the call to 9321 -- B would be wrong as it will fail for Y as well, but in Y's case 9322 -- the call to B is never an ABE. 9323 9324 if Earlier_In_Extended_Unit (Root, Target_Attrs.Body_Decl) then 9325 9326 -- Do not emit any ABE diagnostics when a previous scenario in 9327 -- this traversal has suppressed elaboration warnings. 9328 9329 if State.Suppress_Warnings then 9330 null; 9331 9332 -- Do not emit any ABE diagnostics when the call occurs in a 9333 -- partial finalization context because this leads to confusing 9334 -- noise. 9335 9336 elsif State.Within_Partial_Finalization then 9337 null; 9338 9339 -- ABE diagnostics are emitted only in the static model because 9340 -- there is a well-defined order to visiting scenarios. Without 9341 -- this order diagnostics appear jumbled and result in unwanted 9342 -- noise. 9343 9344 elsif Static_Elaboration_Checks then 9345 Error_Msg_NE 9346 ("??cannot call & before body seen", Call, Target_Id); 9347 Error_Msg_N ("\Program_Error may be raised at run time", Call); 9348 9349 Output_Active_Scenarios (Call); 9350 end if; 9351 9352 -- Install a conditional run-time ABE check to verify that the 9353 -- target body has been elaborated prior to the call. 9354 9355 if Check_OK then 9356 Install_ABE_Check 9357 (N => Call, 9358 Ins_Nod => Call, 9359 Target_Id => Target_Attrs.Spec_Id, 9360 Target_Decl => Target_Attrs.Spec_Decl, 9361 Target_Body => Target_Attrs.Body_Decl); 9362 9363 -- Update the state of the Processing phase to indicate that 9364 -- no implicit Elaborate[_All] pragmas must be generated from 9365 -- this point on. 9366 -- 9367 -- function B ...; 9368 -- 9369 -- function A ... is 9370 -- begin 9371 -- if Some_Condition then 9372 -- <ABE check> 9373 -- return B; 9374 -- ... 9375 -- end A; 9376 -- 9377 -- X : ... := A; 9378 -- 9379 -- function B ... is 9380 -- External.Subp; -- imparts Elaborate_All 9381 -- end B; 9382 -- 9383 -- If Some_Condition is True, then the ABE check will fail at 9384 -- runtime and the call to External.Subp will never take place, 9385 -- rendering the implicit Elaborate_All useless. 9386 -- 9387 -- If Some_Condition is False, then the call to External.Subp 9388 -- will never take place, rendering the implicit Elaborate_All 9389 -- useless. 9390 9391 New_State.Suppress_Implicit_Pragmas := True; 9392 end if; 9393 end if; 9394 9395 -- Otherwise the target body is not available in this compilation or it 9396 -- resides in an external unit. Install a run-time ABE check to verify 9397 -- that the target body has been elaborated prior to the call site when 9398 -- the dynamic model is in effect. 9399 9400 elsif Dynamic_Elaboration_Checks and then Check_OK then 9401 Install_ABE_Check 9402 (N => Call, 9403 Ins_Nod => Call, 9404 Id => Target_Attrs.Unit_Id); 9405 end if; 9406 9407 -- Ensure that the unit with the target body is elaborated prior to the 9408 -- main unit. The implicit Elaborate[_All] is generated only when the 9409 -- call has elaboration checks enabled. This behaviour parallels that of 9410 -- the old ABE mechanism. 9411 9412 if Call_Attrs.Elab_Checks_OK then 9413 Ensure_Prior_Elaboration 9414 (N => Call, 9415 Unit_Id => Target_Attrs.Unit_Id, 9416 Prag_Nam => Name_Elaborate_All, 9417 State => New_State); 9418 end if; 9419 end Process_Conditional_ABE_Call_Ada; 9420 9421 ---------------------------------------- 9422 -- Process_Conditional_ABE_Call_SPARK -- 9423 ---------------------------------------- 9424 9425 procedure Process_Conditional_ABE_Call_SPARK 9426 (Call : Node_Id; 9427 Target_Id : Entity_Id; 9428 Target_Attrs : Target_Attributes; 9429 State : Processing_Attributes) 9430 is 9431 Region : Node_Id; 9432 9433 begin 9434 -- Ensure that a suitable elaboration model is in effect for SPARK rule 9435 -- verification. 9436 9437 Check_SPARK_Model_In_Effect (Call); 9438 9439 -- The call and the target body are both in the main unit 9440 9441 if Present (Target_Attrs.Body_Decl) 9442 and then In_Extended_Main_Code_Unit (Target_Attrs.Body_Decl) 9443 then 9444 -- If the call appears prior to the target body, then the call must 9445 -- appear within the early call region of the target body. 9446 -- 9447 -- function B ...; 9448 -- 9449 -- X : ... := B; -- call site 9450 -- 9451 -- <preelaborable construct 1> --+ 9452 -- ... | early call region 9453 -- <preelaborable construct N> --+ 9454 -- 9455 -- function B ... is -- target body 9456 -- ... 9457 -- end B; 9458 -- 9459 -- When the call to B is not nested within some other scenario, the 9460 -- call is automatically illegal because it can never appear in the 9461 -- early call region of B's body. This is equivalent to a guaranteed 9462 -- ABE. 9463 -- 9464 -- <preelaborable construct 1> --+ 9465 -- | 9466 -- function B ...; | 9467 -- | 9468 -- function A ... is | 9469 -- begin | early call region 9470 -- if Some_Condition then 9471 -- return B; -- call site 9472 -- ... 9473 -- end A; | 9474 -- | 9475 -- <preelaborable construct N> --+ 9476 -- 9477 -- function B ... is -- target body 9478 -- ... 9479 -- end B; 9480 -- 9481 -- When the call to B is nested within some other scenario, the call 9482 -- is always ABE-safe. It is not immediately obvious why this is the 9483 -- case. The elaboration safety follows from the early call region 9484 -- rule being applied to ALL calls preceding their associated bodies. 9485 -- 9486 -- In the example above, the call to B is safe as long as the call to 9487 -- A is safe. There are several cases to consider: 9488 -- 9489 -- <call 1 to A> 9490 -- function B ...; 9491 -- 9492 -- <call 2 to A> 9493 -- function A ... is 9494 -- begin 9495 -- if Some_Condition then 9496 -- return B; 9497 -- ... 9498 -- end A; 9499 -- 9500 -- <call 3 to A> 9501 -- function B ... is 9502 -- ... 9503 -- end B; 9504 -- 9505 -- * Call 1 - This call is either nested within some scenario or not, 9506 -- which falls under the two general cases outlined above. 9507 -- 9508 -- * Call 2 - This is the same case as Call 1. 9509 -- 9510 -- * Call 3 - The placement of this call limits the range of B's 9511 -- early call region unto call 3, therefore the call to B is no 9512 -- longer within the early call region of B's body, making it ABE- 9513 -- unsafe and therefore illegal. 9514 9515 if Earlier_In_Extended_Unit (Call, Target_Attrs.Body_Decl) then 9516 9517 -- Do not emit any ABE diagnostics when a previous scenario in 9518 -- this traversal has suppressed elaboration warnings. 9519 9520 if State.Suppress_Warnings then 9521 null; 9522 9523 -- Do not emit any ABE diagnostics when the call occurs in an 9524 -- initial condition context because this leads to incorrect 9525 -- diagnostics. 9526 9527 elsif State.Within_Initial_Condition then 9528 null; 9529 9530 -- Do not emit any ABE diagnostics when the call occurs in a 9531 -- partial finalization context because this leads to confusing 9532 -- noise. 9533 9534 elsif State.Within_Partial_Finalization then 9535 null; 9536 9537 -- ABE diagnostics are emitted only in the static model because 9538 -- there is a well-defined order to visiting scenarios. Without 9539 -- this order diagnostics appear jumbled and result in unwanted 9540 -- noise. 9541 9542 elsif Static_Elaboration_Checks then 9543 9544 -- Ensure that a call which textually precedes the subprogram 9545 -- body it invokes appears within the early call region of the 9546 -- subprogram body. 9547 9548 -- IMPORTANT: This check must always be performed even when 9549 -- -gnatd.v (enforce SPARK elaboration rules in SPARK code) is 9550 -- not specified because the static model cannot guarantee the 9551 -- absence of elaboration issues in the presence of dispatching 9552 -- calls. 9553 9554 Region := Find_Early_Call_Region (Target_Attrs.Body_Decl); 9555 9556 if Earlier_In_Extended_Unit (Call, Region) then 9557 Error_Msg_NE 9558 ("call must appear within early call region of subprogram " 9559 & "body & (SPARK RM 7.7(3))", Call, Target_Id); 9560 9561 Error_Msg_Sloc := Sloc (Region); 9562 Error_Msg_N ("\region starts #", Call); 9563 9564 Error_Msg_Sloc := Sloc (Target_Attrs.Body_Decl); 9565 Error_Msg_N ("\region ends #", Call); 9566 9567 Output_Active_Scenarios (Call); 9568 end if; 9569 end if; 9570 9571 -- Otherwise the call appears after the target body. The call is 9572 -- ABE-safe as a consequence of applying the early call region rule 9573 -- to ALL calls preceding their associated bodies. 9574 9575 else 9576 null; 9577 end if; 9578 end if; 9579 9580 -- A call to a source target or to a target which emulates Ada or SPARK 9581 -- semantics imposes an Elaborate_All requirement on the context of the 9582 -- main unit. Determine whether the context has a pragma strong enough 9583 -- to meet the requirement. 9584 9585 -- IMPORTANT: This check must be performed only when -gnatd.v (enforce 9586 -- SPARK elaboration rules in SPARK code) is active because the static 9587 -- model can ensure the prior elaboration of the unit which contains a 9588 -- body by installing an implicit Elaborate[_All] pragma. 9589 9590 if Debug_Flag_Dot_V then 9591 if Target_Attrs.From_Source 9592 or else Is_Ada_Semantic_Target (Target_Id) 9593 or else Is_SPARK_Semantic_Target (Target_Id) 9594 then 9595 Meet_Elaboration_Requirement 9596 (N => Call, 9597 Target_Id => Target_Id, 9598 Req_Nam => Name_Elaborate_All); 9599 end if; 9600 9601 -- Otherwise ensure that the unit with the target body is elaborated 9602 -- prior to the main unit. 9603 9604 else 9605 Ensure_Prior_Elaboration 9606 (N => Call, 9607 Unit_Id => Target_Attrs.Unit_Id, 9608 Prag_Nam => Name_Elaborate_All, 9609 State => State); 9610 end if; 9611 end Process_Conditional_ABE_Call_SPARK; 9612 9613 ------------------------------------------- 9614 -- Process_Conditional_ABE_Instantiation -- 9615 ------------------------------------------- 9616 9617 procedure Process_Conditional_ABE_Instantiation 9618 (Exp_Inst : Node_Id; 9619 State : Processing_Attributes) 9620 is 9621 Gen_Attrs : Target_Attributes; 9622 Gen_Id : Entity_Id; 9623 Inst : Node_Id; 9624 Inst_Attrs : Instantiation_Attributes; 9625 Inst_Id : Entity_Id; 9626 9627 SPARK_Rules_On : Boolean; 9628 -- This flag is set when the SPARK rules are in effect 9629 9630 New_State : Processing_Attributes := State; 9631 -- Each step of the Processing phase constitutes a new state 9632 9633 begin 9634 Extract_Instantiation_Attributes 9635 (Exp_Inst => Exp_Inst, 9636 Inst => Inst, 9637 Inst_Id => Inst_Id, 9638 Gen_Id => Gen_Id, 9639 Attrs => Inst_Attrs); 9640 9641 Extract_Target_Attributes (Gen_Id, Gen_Attrs); 9642 9643 -- The SPARK rules are in effect when both the instantiation and generic 9644 -- are subject to SPARK_Mode On. 9645 9646 SPARK_Rules_On := Inst_Attrs.SPARK_Mode_On and Gen_Attrs.SPARK_Mode_On; 9647 9648 -- Output relevant information when switch -gnatel (info messages on 9649 -- implicit Elaborate[_All] pragmas) is in effect. 9650 9651 if Elab_Info_Messages then 9652 Info_Instantiation 9653 (Inst => Inst, 9654 Gen_Id => Gen_Id, 9655 Info_Msg => True, 9656 In_SPARK => SPARK_Rules_On); 9657 end if; 9658 9659 -- Nothing to do when the instantiation is a guaranteed ABE 9660 9661 if Is_Known_Guaranteed_ABE (Inst) then 9662 return; 9663 9664 -- Nothing to do when the root scenario appears at the declaration level 9665 -- and the generic is in the same unit, but outside this context. 9666 -- 9667 -- generic 9668 -- procedure Gen is ...; -- generic declaration 9669 -- 9670 -- procedure Proc is 9671 -- function A ... is 9672 -- begin 9673 -- if Some_Condition then 9674 -- declare 9675 -- procedure I is new Gen; -- instantiation site 9676 -- ... 9677 -- ... 9678 -- end A; 9679 -- 9680 -- X : ... := A; -- root scenario 9681 -- ... 9682 -- 9683 -- procedure Gen is 9684 -- ... 9685 -- end Gen; 9686 -- 9687 -- In the example above, the context of X is the declarative region of 9688 -- Proc. The "elaboration" of X may eventually reach Gen which appears 9689 -- outside of X's context. Gen is relevant only when Proc is invoked, 9690 -- but this happens only by means of "normal" elaboration, therefore 9691 -- Gen must not be considered if this is not the case. 9692 9693 -- Performance note: parent traversal 9694 9695 elsif Is_Up_Level_Target (Gen_Attrs.Spec_Decl) then 9696 return; 9697 end if; 9698 9699 -- Warnings are suppressed when a prior scenario is already in that 9700 -- mode, or when the instantiation has warnings suppressed. Update 9701 -- the state of the processing phase to reflect this. 9702 9703 New_State.Suppress_Warnings := 9704 New_State.Suppress_Warnings or else not Inst_Attrs.Elab_Warnings_OK; 9705 9706 -- The SPARK rules are in effect 9707 9708 if SPARK_Rules_On then 9709 Process_Conditional_ABE_Instantiation_SPARK 9710 (Inst => Inst, 9711 Gen_Id => Gen_Id, 9712 Gen_Attrs => Gen_Attrs, 9713 State => New_State); 9714 9715 -- Otherwise the Ada rules are in effect, or SPARK code is allowed to 9716 -- violate the SPARK rules. 9717 9718 else 9719 Process_Conditional_ABE_Instantiation_Ada 9720 (Exp_Inst => Exp_Inst, 9721 Inst => Inst, 9722 Inst_Attrs => Inst_Attrs, 9723 Gen_Id => Gen_Id, 9724 Gen_Attrs => Gen_Attrs, 9725 State => New_State); 9726 end if; 9727 end Process_Conditional_ABE_Instantiation; 9728 9729 ----------------------------------------------- 9730 -- Process_Conditional_ABE_Instantiation_Ada -- 9731 ----------------------------------------------- 9732 9733 procedure Process_Conditional_ABE_Instantiation_Ada 9734 (Exp_Inst : Node_Id; 9735 Inst : Node_Id; 9736 Inst_Attrs : Instantiation_Attributes; 9737 Gen_Id : Entity_Id; 9738 Gen_Attrs : Target_Attributes; 9739 State : Processing_Attributes) 9740 is 9741 Check_OK : constant Boolean := 9742 not Inst_Attrs.Ghost_Mode_Ignore 9743 and then not Gen_Attrs.Ghost_Mode_Ignore 9744 and then Inst_Attrs.Elab_Checks_OK 9745 and then Gen_Attrs.Elab_Checks_OK; 9746 -- A run-time ABE check may be installed only when both the instance and 9747 -- the generic have active elaboration checks and both are not ignored 9748 -- Ghost constructs. 9749 9750 Root : constant Node_Id := Root_Scenario; 9751 9752 New_State : Processing_Attributes := State; 9753 -- Each step of the Processing phase constitutes a new state 9754 9755 begin 9756 -- Nothing to do when the instantiation is ABE-safe 9757 -- 9758 -- generic 9759 -- package Gen is 9760 -- ... 9761 -- end Gen; 9762 -- 9763 -- package body Gen is 9764 -- ... 9765 -- end Gen; 9766 -- 9767 -- with Gen; 9768 -- procedure Main is 9769 -- package Inst is new Gen (ABE); -- safe instantiation 9770 -- ... 9771 9772 if Is_Safe_Instantiation (Inst, Gen_Attrs) then 9773 return; 9774 9775 -- The instantiation and the generic body are both in the main unit 9776 9777 elsif Present (Gen_Attrs.Body_Decl) 9778 and then In_Extended_Main_Code_Unit (Gen_Attrs.Body_Decl) 9779 then 9780 -- If the root scenario appears prior to the generic body, then this 9781 -- is a possible ABE with respect to the root scenario. 9782 -- 9783 -- generic 9784 -- package Gen is 9785 -- ... 9786 -- end Gen; 9787 -- 9788 -- function A ... is 9789 -- begin 9790 -- if Some_Condition then 9791 -- declare 9792 -- package Inst is new Gen; -- instantiation site 9793 -- ... 9794 -- end A; 9795 -- 9796 -- X : ... := A; -- root scenario 9797 -- 9798 -- package body Gen is -- generic body 9799 -- ... 9800 -- end Gen; 9801 -- 9802 -- Y : ... := A; -- root scenario 9803 -- 9804 -- IMPORTANT: The instantiation of Gen is a possible ABE for X, but 9805 -- not for Y. Installing an unconditional ABE raise prior to the 9806 -- instance site would be wrong as it will fail for Y as well, but in 9807 -- Y's case the instantiation of Gen is never an ABE. 9808 9809 if Earlier_In_Extended_Unit (Root, Gen_Attrs.Body_Decl) then 9810 9811 -- Do not emit any ABE diagnostics when a previous scenario in 9812 -- this traversal has suppressed elaboration warnings. 9813 9814 if State.Suppress_Warnings then 9815 null; 9816 9817 -- Do not emit any ABE diagnostics when the instantiation occurs 9818 -- in partial finalization context because this leads to unwanted 9819 -- noise. 9820 9821 elsif State.Within_Partial_Finalization then 9822 null; 9823 9824 -- ABE diagnostics are emitted only in the static model because 9825 -- there is a well-defined order to visiting scenarios. Without 9826 -- this order diagnostics appear jumbled and result in unwanted 9827 -- noise. 9828 9829 elsif Static_Elaboration_Checks then 9830 Error_Msg_NE 9831 ("??cannot instantiate & before body seen", Inst, Gen_Id); 9832 Error_Msg_N ("\Program_Error may be raised at run time", Inst); 9833 9834 Output_Active_Scenarios (Inst); 9835 end if; 9836 9837 -- Install a conditional run-time ABE check to verify that the 9838 -- generic body has been elaborated prior to the instantiation. 9839 9840 if Check_OK then 9841 Install_ABE_Check 9842 (N => Inst, 9843 Ins_Nod => Exp_Inst, 9844 Target_Id => Gen_Attrs.Spec_Id, 9845 Target_Decl => Gen_Attrs.Spec_Decl, 9846 Target_Body => Gen_Attrs.Body_Decl); 9847 9848 -- Update the state of the Processing phase to indicate that 9849 -- no implicit Elaborate[_All] pragmas must be generated from 9850 -- this point on. 9851 -- 9852 -- generic 9853 -- package Gen is 9854 -- ... 9855 -- end Gen; 9856 -- 9857 -- function A ... is 9858 -- begin 9859 -- if Some_Condition then 9860 -- <ABE check> 9861 -- declare Inst is new Gen; 9862 -- ... 9863 -- end A; 9864 -- 9865 -- X : ... := A; 9866 -- 9867 -- package body Gen is 9868 -- begin 9869 -- External.Subp; -- imparts Elaborate_All 9870 -- end Gen; 9871 -- 9872 -- If Some_Condition is True, then the ABE check will fail at 9873 -- runtime and the call to External.Subp will never take place, 9874 -- rendering the implicit Elaborate_All useless. 9875 -- 9876 -- If Some_Condition is False, then the call to External.Subp 9877 -- will never take place, rendering the implicit Elaborate_All 9878 -- useless. 9879 9880 New_State.Suppress_Implicit_Pragmas := True; 9881 end if; 9882 end if; 9883 9884 -- Otherwise the generic body is not available in this compilation or it 9885 -- resides in an external unit. Install a run-time ABE check to verify 9886 -- that the generic body has been elaborated prior to the instantiation 9887 -- when the dynamic model is in effect. 9888 9889 elsif Dynamic_Elaboration_Checks and then Check_OK then 9890 Install_ABE_Check 9891 (N => Inst, 9892 Ins_Nod => Exp_Inst, 9893 Id => Gen_Attrs.Unit_Id); 9894 end if; 9895 9896 -- Ensure that the unit with the generic body is elaborated prior to 9897 -- the main unit. No implicit pragma is generated if the instantiation 9898 -- has elaboration checks suppressed. This behaviour parallels that of 9899 -- the old ABE mechanism. 9900 9901 if Inst_Attrs.Elab_Checks_OK then 9902 Ensure_Prior_Elaboration 9903 (N => Inst, 9904 Unit_Id => Gen_Attrs.Unit_Id, 9905 Prag_Nam => Name_Elaborate, 9906 State => New_State); 9907 end if; 9908 end Process_Conditional_ABE_Instantiation_Ada; 9909 9910 ------------------------------------------------- 9911 -- Process_Conditional_ABE_Instantiation_SPARK -- 9912 ------------------------------------------------- 9913 9914 procedure Process_Conditional_ABE_Instantiation_SPARK 9915 (Inst : Node_Id; 9916 Gen_Id : Entity_Id; 9917 Gen_Attrs : Target_Attributes; 9918 State : Processing_Attributes) 9919 is 9920 Req_Nam : Name_Id; 9921 9922 begin 9923 -- Ensure that a suitable elaboration model is in effect for SPARK rule 9924 -- verification. 9925 9926 Check_SPARK_Model_In_Effect (Inst); 9927 9928 -- A source instantiation imposes an Elaborate[_All] requirement on the 9929 -- context of the main unit. Determine whether the context has a pragma 9930 -- strong enough to meet the requirement. The check is orthogonal to the 9931 -- ABE ramifications of the instantiation. 9932 9933 -- IMPORTANT: This check must be performed only when -gnatd.v (enforce 9934 -- SPARK elaboration rules in SPARK code) is active because the static 9935 -- model can ensure the prior elaboration of the unit which contains a 9936 -- body by installing an implicit Elaborate[_All] pragma. 9937 9938 if Debug_Flag_Dot_V then 9939 if Nkind (Inst) = N_Package_Instantiation then 9940 Req_Nam := Name_Elaborate_All; 9941 else 9942 Req_Nam := Name_Elaborate; 9943 end if; 9944 9945 Meet_Elaboration_Requirement 9946 (N => Inst, 9947 Target_Id => Gen_Id, 9948 Req_Nam => Req_Nam); 9949 9950 -- Otherwise ensure that the unit with the target body is elaborated 9951 -- prior to the main unit. 9952 9953 else 9954 Ensure_Prior_Elaboration 9955 (N => Inst, 9956 Unit_Id => Gen_Attrs.Unit_Id, 9957 Prag_Nam => Name_Elaborate, 9958 State => State); 9959 end if; 9960 end Process_Conditional_ABE_Instantiation_SPARK; 9961 9962 ------------------------------------------------- 9963 -- Process_Conditional_ABE_Variable_Assignment -- 9964 ------------------------------------------------- 9965 9966 procedure Process_Conditional_ABE_Variable_Assignment (Asmt : Node_Id) is 9967 Var_Id : constant Entity_Id := Entity (Extract_Assignment_Name (Asmt)); 9968 Prag : constant Node_Id := SPARK_Pragma (Var_Id); 9969 9970 SPARK_Rules_On : Boolean; 9971 -- This flag is set when the SPARK rules are in effect 9972 9973 begin 9974 -- The SPARK rules are in effect when both the assignment and the 9975 -- variable are subject to SPARK_Mode On. 9976 9977 SPARK_Rules_On := 9978 Present (Prag) 9979 and then Get_SPARK_Mode_From_Annotation (Prag) = On 9980 and then Is_SPARK_Mode_On_Node (Asmt); 9981 9982 -- Output relevant information when switch -gnatel (info messages on 9983 -- implicit Elaborate[_All] pragmas) is in effect. 9984 9985 if Elab_Info_Messages then 9986 Elab_Msg_NE 9987 (Msg => "assignment to & during elaboration", 9988 N => Asmt, 9989 Id => Var_Id, 9990 Info_Msg => True, 9991 In_SPARK => SPARK_Rules_On); 9992 end if; 9993 9994 -- The SPARK rules are in effect. These rules are applied regardless of 9995 -- whether -gnatd.v (enforce SPARK elaboration rules in SPARK code) is 9996 -- in effect because the static model cannot ensure safe assignment of 9997 -- variables. 9998 9999 if SPARK_Rules_On then 10000 Process_Conditional_ABE_Variable_Assignment_SPARK 10001 (Asmt => Asmt, 10002 Var_Id => Var_Id); 10003 10004 -- Otherwise the Ada rules are in effect 10005 10006 else 10007 Process_Conditional_ABE_Variable_Assignment_Ada 10008 (Asmt => Asmt, 10009 Var_Id => Var_Id); 10010 end if; 10011 end Process_Conditional_ABE_Variable_Assignment; 10012 10013 ----------------------------------------------------- 10014 -- Process_Conditional_ABE_Variable_Assignment_Ada -- 10015 ----------------------------------------------------- 10016 10017 procedure Process_Conditional_ABE_Variable_Assignment_Ada 10018 (Asmt : Node_Id; 10019 Var_Id : Entity_Id) 10020 is 10021 Var_Decl : constant Node_Id := Declaration_Node (Var_Id); 10022 Spec_Id : constant Entity_Id := Find_Top_Unit (Var_Decl); 10023 10024 begin 10025 -- Emit a warning when an uninitialized variable declared in a package 10026 -- spec without a pragma Elaborate_Body is initialized by elaboration 10027 -- code within the corresponding body. 10028 10029 if Is_Elaboration_Warnings_OK_Id (Var_Id) 10030 and then not Is_Initialized (Var_Decl) 10031 and then not Has_Pragma_Elaborate_Body (Spec_Id) 10032 then 10033 Error_Msg_NE 10034 ("??variable & can be accessed by clients before this " 10035 & "initialization", Asmt, Var_Id); 10036 10037 Error_Msg_NE 10038 ("\add pragma ""Elaborate_Body"" to spec & to ensure proper " 10039 & "initialization", Asmt, Spec_Id); 10040 10041 Output_Active_Scenarios (Asmt); 10042 10043 -- Generate an implicit Elaborate_Body in the spec 10044 10045 Set_Elaborate_Body_Desirable (Spec_Id); 10046 end if; 10047 end Process_Conditional_ABE_Variable_Assignment_Ada; 10048 10049 ------------------------------------------------------- 10050 -- Process_Conditional_ABE_Variable_Assignment_SPARK -- 10051 ------------------------------------------------------- 10052 10053 procedure Process_Conditional_ABE_Variable_Assignment_SPARK 10054 (Asmt : Node_Id; 10055 Var_Id : Entity_Id) 10056 is 10057 Var_Decl : constant Node_Id := Declaration_Node (Var_Id); 10058 Spec_Id : constant Entity_Id := Find_Top_Unit (Var_Decl); 10059 10060 begin 10061 -- Ensure that a suitable elaboration model is in effect for SPARK rule 10062 -- verification. 10063 10064 Check_SPARK_Model_In_Effect (Asmt); 10065 10066 -- Emit an error when an initialized variable declared in a package spec 10067 -- without pragma Elaborate_Body is further modified by elaboration code 10068 -- within the corresponding body. 10069 10070 if Is_Elaboration_Warnings_OK_Id (Var_Id) 10071 and then Is_Initialized (Var_Decl) 10072 and then not Has_Pragma_Elaborate_Body (Spec_Id) 10073 then 10074 Error_Msg_NE 10075 ("variable & modified by elaboration code in package body", 10076 Asmt, Var_Id); 10077 10078 Error_Msg_NE 10079 ("\add pragma ""Elaborate_Body"" to spec & to ensure full " 10080 & "initialization", Asmt, Spec_Id); 10081 10082 Output_Active_Scenarios (Asmt); 10083 end if; 10084 end Process_Conditional_ABE_Variable_Assignment_SPARK; 10085 10086 ------------------------------------------------ 10087 -- Process_Conditional_ABE_Variable_Reference -- 10088 ------------------------------------------------ 10089 10090 procedure Process_Conditional_ABE_Variable_Reference (Ref : Node_Id) is 10091 Var_Attrs : Variable_Attributes; 10092 Var_Id : Entity_Id; 10093 10094 begin 10095 Extract_Variable_Reference_Attributes 10096 (Ref => Ref, 10097 Var_Id => Var_Id, 10098 Attrs => Var_Attrs); 10099 10100 if Is_Read (Ref) then 10101 Process_Conditional_ABE_Variable_Reference_Read 10102 (Ref => Ref, 10103 Var_Id => Var_Id, 10104 Attrs => Var_Attrs); 10105 end if; 10106 end Process_Conditional_ABE_Variable_Reference; 10107 10108 ----------------------------------------------------- 10109 -- Process_Conditional_ABE_Variable_Reference_Read -- 10110 ----------------------------------------------------- 10111 10112 procedure Process_Conditional_ABE_Variable_Reference_Read 10113 (Ref : Node_Id; 10114 Var_Id : Entity_Id; 10115 Attrs : Variable_Attributes) 10116 is 10117 begin 10118 -- Output relevant information when switch -gnatel (info messages on 10119 -- implicit Elaborate[_All] pragmas) is in effect. 10120 10121 if Elab_Info_Messages then 10122 Elab_Msg_NE 10123 (Msg => "read of variable & during elaboration", 10124 N => Ref, 10125 Id => Var_Id, 10126 Info_Msg => True, 10127 In_SPARK => True); 10128 end if; 10129 10130 -- Nothing to do when the variable appears within the main unit because 10131 -- diagnostics on reads are relevant only for external variables. 10132 10133 if Is_Same_Unit (Attrs.Unit_Id, Cunit_Entity (Main_Unit)) then 10134 null; 10135 10136 -- Nothing to do when the variable is already initialized. Note that the 10137 -- variable may be further modified by the external unit. 10138 10139 elsif Is_Initialized (Declaration_Node (Var_Id)) then 10140 null; 10141 10142 -- Nothing to do when the external unit guarantees the initialization of 10143 -- the variable by means of pragma Elaborate_Body. 10144 10145 elsif Has_Pragma_Elaborate_Body (Attrs.Unit_Id) then 10146 null; 10147 10148 -- A variable read imposes an Elaborate requirement on the context of 10149 -- the main unit. Determine whether the context has a pragma strong 10150 -- enough to meet the requirement. 10151 10152 else 10153 Meet_Elaboration_Requirement 10154 (N => Ref, 10155 Target_Id => Var_Id, 10156 Req_Nam => Name_Elaborate); 10157 end if; 10158 end Process_Conditional_ABE_Variable_Reference_Read; 10159 10160 ----------------------------- 10161 -- Process_Conditional_ABE -- 10162 ----------------------------- 10163 10164 -- NOTE: The body of this routine is intentionally out of order because it 10165 -- invokes an instantiated subprogram (Process_Conditional_ABE_Activation). 10166 -- Placing the body in alphabetical order will result in a guaranteed ABE. 10167 10168 procedure Process_Conditional_ABE 10169 (N : Node_Id; 10170 State : Processing_Attributes := Initial_State) 10171 is 10172 Call_Attrs : Call_Attributes; 10173 Target_Id : Entity_Id; 10174 10175 begin 10176 -- Add the current scenario to the stack of active scenarios 10177 10178 Push_Active_Scenario (N); 10179 10180 -- 'Access 10181 10182 if Is_Suitable_Access (N) then 10183 Process_Conditional_ABE_Access 10184 (Attr => N, 10185 State => State); 10186 10187 -- Activations and calls 10188 10189 elsif Is_Suitable_Call (N) then 10190 10191 -- In general, only calls found within the main unit are processed 10192 -- because the ALI information supplied to binde is for the main 10193 -- unit only. However, to preserve the consistency of the tree and 10194 -- ensure proper serialization of internal names, external calls 10195 -- also receive corresponding call markers (see Build_Call_Marker). 10196 -- Regardless of the reason, external calls must not be processed. 10197 10198 if In_Main_Context (N) then 10199 Extract_Call_Attributes 10200 (Call => N, 10201 Target_Id => Target_Id, 10202 Attrs => Call_Attrs); 10203 10204 if Is_Activation_Proc (Target_Id) then 10205 Process_Conditional_ABE_Activation 10206 (Call => N, 10207 Call_Attrs => Call_Attrs, 10208 State => State); 10209 10210 else 10211 Process_Conditional_ABE_Call 10212 (Call => N, 10213 Call_Attrs => Call_Attrs, 10214 Target_Id => Target_Id, 10215 State => State); 10216 end if; 10217 end if; 10218 10219 -- Instantiations 10220 10221 elsif Is_Suitable_Instantiation (N) then 10222 Process_Conditional_ABE_Instantiation 10223 (Exp_Inst => N, 10224 State => State); 10225 10226 -- Variable assignments 10227 10228 elsif Is_Suitable_Variable_Assignment (N) then 10229 Process_Conditional_ABE_Variable_Assignment (N); 10230 10231 -- Variable references 10232 10233 elsif Is_Suitable_Variable_Reference (N) then 10234 10235 -- In general, only variable references found within the main unit 10236 -- are processed because the ALI information supplied to binde is for 10237 -- the main unit only. However, to preserve the consistency of the 10238 -- tree and ensure proper serialization of internal names, external 10239 -- variable references also receive corresponding variable reference 10240 -- markers (see Build_Varaible_Reference_Marker). Regardless of the 10241 -- reason, external variable references must not be processed. 10242 10243 if In_Main_Context (N) then 10244 Process_Conditional_ABE_Variable_Reference (N); 10245 end if; 10246 end if; 10247 10248 -- Remove the current scenario from the stack of active scenarios once 10249 -- all ABE diagnostics and checks have been performed. 10250 10251 Pop_Active_Scenario (N); 10252 end Process_Conditional_ABE; 10253 10254 -------------------------------------------- 10255 -- Process_Guaranteed_ABE_Activation_Impl -- 10256 -------------------------------------------- 10257 10258 procedure Process_Guaranteed_ABE_Activation_Impl 10259 (Call : Node_Id; 10260 Call_Attrs : Call_Attributes; 10261 Obj_Id : Entity_Id; 10262 Task_Attrs : Task_Attributes; 10263 State : Processing_Attributes) 10264 is 10265 pragma Unreferenced (State); 10266 10267 Check_OK : constant Boolean := 10268 not Is_Ignored_Ghost_Entity (Obj_Id) 10269 and then not Task_Attrs.Ghost_Mode_Ignore 10270 and then Is_Elaboration_Checks_OK_Id (Obj_Id) 10271 and then Task_Attrs.Elab_Checks_OK; 10272 -- A run-time ABE check may be installed only when the object and the 10273 -- task type have active elaboration checks, and both are not ignored 10274 -- Ghost constructs. 10275 10276 begin 10277 -- Nothing to do when the root scenario appears at the declaration 10278 -- level and the task is in the same unit, but outside this context. 10279 -- 10280 -- task type Task_Typ; -- task declaration 10281 -- 10282 -- procedure Proc is 10283 -- function A ... is 10284 -- begin 10285 -- if Some_Condition then 10286 -- declare 10287 -- T : Task_Typ; 10288 -- begin 10289 -- <activation call> -- activation site 10290 -- end; 10291 -- ... 10292 -- end A; 10293 -- 10294 -- X : ... := A; -- root scenario 10295 -- ... 10296 -- 10297 -- task body Task_Typ is 10298 -- ... 10299 -- end Task_Typ; 10300 -- 10301 -- In the example above, the context of X is the declarative list of 10302 -- Proc. The "elaboration" of X may reach the activation of T whose body 10303 -- is defined outside of X's context. The task body is relevant only 10304 -- when Proc is invoked, but this happens only in "normal" elaboration, 10305 -- therefore the task body must not be considered if this is not the 10306 -- case. 10307 10308 -- Performance note: parent traversal 10309 10310 if Is_Up_Level_Target (Task_Attrs.Task_Decl) then 10311 return; 10312 10313 -- Nothing to do when the activation is ABE-safe 10314 -- 10315 -- generic 10316 -- package Gen is 10317 -- task type Task_Typ; 10318 -- end Gen; 10319 -- 10320 -- package body Gen is 10321 -- task body Task_Typ is 10322 -- begin 10323 -- ... 10324 -- end Task_Typ; 10325 -- end Gen; 10326 -- 10327 -- with Gen; 10328 -- procedure Main is 10329 -- package Nested is 10330 -- package Inst is new Gen; 10331 -- T : Inst.Task_Typ; 10332 -- end Nested; -- safe activation 10333 -- ... 10334 10335 elsif Is_Safe_Activation (Call, Task_Attrs.Task_Decl) then 10336 return; 10337 10338 -- An activation call leads to a guaranteed ABE when the activation 10339 -- call and the task appear within the same context ignoring library 10340 -- levels, and the body of the task has not been seen yet or appears 10341 -- after the activation call. 10342 -- 10343 -- procedure Guaranteed_ABE is 10344 -- task type Task_Typ; 10345 -- 10346 -- package Nested is 10347 -- T : Task_Typ; 10348 -- <activation call> -- guaranteed ABE 10349 -- end Nested; 10350 -- 10351 -- task body Task_Typ is 10352 -- ... 10353 -- end Task_Typ; 10354 -- ... 10355 10356 -- Performance note: parent traversal 10357 10358 elsif Is_Guaranteed_ABE 10359 (N => Call, 10360 Target_Decl => Task_Attrs.Task_Decl, 10361 Target_Body => Task_Attrs.Body_Decl) 10362 then 10363 if Call_Attrs.Elab_Warnings_OK then 10364 Error_Msg_Sloc := Sloc (Call); 10365 Error_Msg_N 10366 ("??task & will be activated # before elaboration of its body", 10367 Obj_Id); 10368 Error_Msg_N ("\Program_Error will be raised at run time", Obj_Id); 10369 end if; 10370 10371 -- Mark the activation call as a guaranteed ABE 10372 10373 Set_Is_Known_Guaranteed_ABE (Call); 10374 10375 -- Install a run-time ABE failue because this activation call will 10376 -- always result in an ABE. 10377 10378 if Check_OK then 10379 Install_ABE_Failure 10380 (N => Call, 10381 Ins_Nod => Call); 10382 end if; 10383 end if; 10384 end Process_Guaranteed_ABE_Activation_Impl; 10385 10386 procedure Process_Guaranteed_ABE_Activation is 10387 new Process_Activation_Generic (Process_Guaranteed_ABE_Activation_Impl); 10388 10389 --------------------------------- 10390 -- Process_Guaranteed_ABE_Call -- 10391 --------------------------------- 10392 10393 procedure Process_Guaranteed_ABE_Call 10394 (Call : Node_Id; 10395 Call_Attrs : Call_Attributes; 10396 Target_Id : Entity_Id) 10397 is 10398 Target_Attrs : Target_Attributes; 10399 10400 begin 10401 Extract_Target_Attributes 10402 (Target_Id => Target_Id, 10403 Attrs => Target_Attrs); 10404 10405 -- Nothing to do when the root scenario appears at the declaration level 10406 -- and the target is in the same unit, but outside this context. 10407 -- 10408 -- function B ...; -- target declaration 10409 -- 10410 -- procedure Proc is 10411 -- function A ... is 10412 -- begin 10413 -- if Some_Condition then 10414 -- return B; -- call site 10415 -- ... 10416 -- end A; 10417 -- 10418 -- X : ... := A; -- root scenario 10419 -- ... 10420 -- 10421 -- function B ... is 10422 -- ... 10423 -- end B; 10424 -- 10425 -- In the example above, the context of X is the declarative region of 10426 -- Proc. The "elaboration" of X may eventually reach B which is defined 10427 -- outside of X's context. B is relevant only when Proc is invoked, but 10428 -- this happens only by means of "normal" elaboration, therefore B must 10429 -- not be considered if this is not the case. 10430 10431 -- Performance note: parent traversal 10432 10433 if Is_Up_Level_Target (Target_Attrs.Spec_Decl) then 10434 return; 10435 10436 -- Nothing to do when the call is ABE-safe 10437 -- 10438 -- generic 10439 -- function Gen ...; 10440 -- 10441 -- function Gen ... is 10442 -- begin 10443 -- ... 10444 -- end Gen; 10445 -- 10446 -- with Gen; 10447 -- procedure Main is 10448 -- function Inst is new Gen; 10449 -- X : ... := Inst; -- safe call 10450 -- ... 10451 10452 elsif Is_Safe_Call (Call, Target_Attrs) then 10453 return; 10454 10455 -- A call leads to a guaranteed ABE when the call and the target appear 10456 -- within the same context ignoring library levels, and the body of the 10457 -- target has not been seen yet or appears after the call. 10458 -- 10459 -- procedure Guaranteed_ABE is 10460 -- function Func ...; 10461 -- 10462 -- package Nested is 10463 -- Obj : ... := Func; -- guaranteed ABE 10464 -- end Nested; 10465 -- 10466 -- function Func ... is 10467 -- ... 10468 -- end Func; 10469 -- ... 10470 10471 -- Performance note: parent traversal 10472 10473 elsif Is_Guaranteed_ABE 10474 (N => Call, 10475 Target_Decl => Target_Attrs.Spec_Decl, 10476 Target_Body => Target_Attrs.Body_Decl) 10477 then 10478 if Call_Attrs.Elab_Warnings_OK then 10479 Error_Msg_NE ("??cannot call & before body seen", Call, Target_Id); 10480 Error_Msg_N ("\Program_Error will be raised at run time", Call); 10481 end if; 10482 10483 -- Mark the call as a guarnateed ABE 10484 10485 Set_Is_Known_Guaranteed_ABE (Call); 10486 10487 -- Install a run-time ABE failure because the call will always result 10488 -- in an ABE. The failure is installed when both the call and target 10489 -- have enabled elaboration checks, and both are not ignored Ghost 10490 -- constructs. 10491 10492 if Call_Attrs.Elab_Checks_OK 10493 and then Target_Attrs.Elab_Checks_OK 10494 and then not Call_Attrs.Ghost_Mode_Ignore 10495 and then not Target_Attrs.Ghost_Mode_Ignore 10496 then 10497 Install_ABE_Failure 10498 (N => Call, 10499 Ins_Nod => Call); 10500 end if; 10501 end if; 10502 end Process_Guaranteed_ABE_Call; 10503 10504 ------------------------------------------ 10505 -- Process_Guaranteed_ABE_Instantiation -- 10506 ------------------------------------------ 10507 10508 procedure Process_Guaranteed_ABE_Instantiation (Exp_Inst : Node_Id) is 10509 Gen_Attrs : Target_Attributes; 10510 Gen_Id : Entity_Id; 10511 Inst : Node_Id; 10512 Inst_Attrs : Instantiation_Attributes; 10513 Inst_Id : Entity_Id; 10514 10515 begin 10516 Extract_Instantiation_Attributes 10517 (Exp_Inst => Exp_Inst, 10518 Inst => Inst, 10519 Inst_Id => Inst_Id, 10520 Gen_Id => Gen_Id, 10521 Attrs => Inst_Attrs); 10522 10523 Extract_Target_Attributes (Gen_Id, Gen_Attrs); 10524 10525 -- Nothing to do when the root scenario appears at the declaration level 10526 -- and the generic is in the same unit, but outside this context. 10527 -- 10528 -- generic 10529 -- procedure Gen is ...; -- generic declaration 10530 -- 10531 -- procedure Proc is 10532 -- function A ... is 10533 -- begin 10534 -- if Some_Condition then 10535 -- declare 10536 -- procedure I is new Gen; -- instantiation site 10537 -- ... 10538 -- ... 10539 -- end A; 10540 -- 10541 -- X : ... := A; -- root scenario 10542 -- ... 10543 -- 10544 -- procedure Gen is 10545 -- ... 10546 -- end Gen; 10547 -- 10548 -- In the example above, the context of X is the declarative region of 10549 -- Proc. The "elaboration" of X may eventually reach Gen which appears 10550 -- outside of X's context. Gen is relevant only when Proc is invoked, 10551 -- but this happens only by means of "normal" elaboration, therefore 10552 -- Gen must not be considered if this is not the case. 10553 10554 -- Performance note: parent traversal 10555 10556 if Is_Up_Level_Target (Gen_Attrs.Spec_Decl) then 10557 return; 10558 10559 -- Nothing to do when the instantiation is ABE-safe 10560 -- 10561 -- generic 10562 -- package Gen is 10563 -- ... 10564 -- end Gen; 10565 -- 10566 -- package body Gen is 10567 -- ... 10568 -- end Gen; 10569 -- 10570 -- with Gen; 10571 -- procedure Main is 10572 -- package Inst is new Gen (ABE); -- safe instantiation 10573 -- ... 10574 10575 elsif Is_Safe_Instantiation (Inst, Gen_Attrs) then 10576 return; 10577 10578 -- An instantiation leads to a guaranteed ABE when the instantiation and 10579 -- the generic appear within the same context ignoring library levels, 10580 -- and the body of the generic has not been seen yet or appears after 10581 -- the instantiation. 10582 -- 10583 -- procedure Guaranteed_ABE is 10584 -- generic 10585 -- procedure Gen; 10586 -- 10587 -- package Nested is 10588 -- procedure Inst is new Gen; -- guaranteed ABE 10589 -- end Nested; 10590 -- 10591 -- procedure Gen is 10592 -- ... 10593 -- end Gen; 10594 -- ... 10595 10596 -- Performance note: parent traversal 10597 10598 elsif Is_Guaranteed_ABE 10599 (N => Inst, 10600 Target_Decl => Gen_Attrs.Spec_Decl, 10601 Target_Body => Gen_Attrs.Body_Decl) 10602 then 10603 if Inst_Attrs.Elab_Warnings_OK then 10604 Error_Msg_NE 10605 ("??cannot instantiate & before body seen", Inst, Gen_Id); 10606 Error_Msg_N ("\Program_Error will be raised at run time", Inst); 10607 end if; 10608 10609 -- Mark the instantiation as a guarantee ABE. This automatically 10610 -- suppresses the instantiation of the generic body. 10611 10612 Set_Is_Known_Guaranteed_ABE (Inst); 10613 10614 -- Install a run-time ABE failure because the instantiation will 10615 -- always result in an ABE. The failure is installed when both the 10616 -- instance and the generic have enabled elaboration checks, and both 10617 -- are not ignored Ghost constructs. 10618 10619 if Inst_Attrs.Elab_Checks_OK 10620 and then Gen_Attrs.Elab_Checks_OK 10621 and then not Inst_Attrs.Ghost_Mode_Ignore 10622 and then not Gen_Attrs.Ghost_Mode_Ignore 10623 then 10624 Install_ABE_Failure 10625 (N => Inst, 10626 Ins_Nod => Exp_Inst); 10627 end if; 10628 end if; 10629 end Process_Guaranteed_ABE_Instantiation; 10630 10631 ---------------------------- 10632 -- Process_Guaranteed_ABE -- 10633 ---------------------------- 10634 10635 -- NOTE: The body of this routine is intentionally out of order because it 10636 -- invokes an instantiated subprogram (Process_Guaranteed_ABE_Activation). 10637 -- Placing the body in alphabetical order will result in a guaranteed ABE. 10638 10639 procedure Process_Guaranteed_ABE (N : Node_Id) is 10640 Call_Attrs : Call_Attributes; 10641 Target_Id : Entity_Id; 10642 10643 begin 10644 -- Add the current scenario to the stack of active scenarios 10645 10646 Push_Active_Scenario (N); 10647 10648 -- Only calls, instantiations, and task activations may result in a 10649 -- guaranteed ABE. 10650 10651 if Is_Suitable_Call (N) then 10652 Extract_Call_Attributes 10653 (Call => N, 10654 Target_Id => Target_Id, 10655 Attrs => Call_Attrs); 10656 10657 if Is_Activation_Proc (Target_Id) then 10658 Process_Guaranteed_ABE_Activation 10659 (Call => N, 10660 Call_Attrs => Call_Attrs, 10661 State => Initial_State); 10662 10663 else 10664 Process_Guaranteed_ABE_Call 10665 (Call => N, 10666 Call_Attrs => Call_Attrs, 10667 Target_Id => Target_Id); 10668 end if; 10669 10670 elsif Is_Suitable_Instantiation (N) then 10671 Process_Guaranteed_ABE_Instantiation (N); 10672 end if; 10673 10674 -- Remove the current scenario from the stack of active scenarios once 10675 -- all ABE diagnostics and checks have been performed. 10676 10677 Pop_Active_Scenario (N); 10678 end Process_Guaranteed_ABE; 10679 10680 -------------------------- 10681 -- Push_Active_Scenario -- 10682 -------------------------- 10683 10684 procedure Push_Active_Scenario (N : Node_Id) is 10685 begin 10686 Scenario_Stack.Append (N); 10687 end Push_Active_Scenario; 10688 10689 --------------------------------- 10690 -- Record_Elaboration_Scenario -- 10691 --------------------------------- 10692 10693 procedure Record_Elaboration_Scenario (N : Node_Id) is 10694 Level : Enclosing_Level_Kind; 10695 10696 Any_Level_OK : Boolean; 10697 -- This flag is set when a particular scenario is allowed to appear at 10698 -- any level. 10699 10700 Declaration_Level_OK : Boolean; 10701 -- This flag is set when a particular scenario is allowed to appear at 10702 -- the declaration level. 10703 10704 Library_Level_OK : Boolean; 10705 -- This flag is set when a particular scenario is allowed to appear at 10706 -- the library level. 10707 10708 begin 10709 -- Assume that the scenario cannot appear on any level 10710 10711 Any_Level_OK := False; 10712 Declaration_Level_OK := False; 10713 Library_Level_OK := False; 10714 10715 -- Nothing to do when switch -gnatH (legacy elaboration checking mode 10716 -- enabled) is in effect because the legacy ABE mechanism does not need 10717 -- to carry out this action. 10718 10719 if Legacy_Elaboration_Checks then 10720 return; 10721 10722 -- Nothing to do for ASIS because ABE checks and diagnostics are not 10723 -- performed in this mode. 10724 10725 elsif ASIS_Mode then 10726 return; 10727 10728 -- Nothing to do when the scenario is being preanalyzed 10729 10730 elsif Preanalysis_Active then 10731 return; 10732 end if; 10733 10734 -- Ensure that a library-level call does not appear in a preelaborated 10735 -- unit. The check must come before ignoring scenarios within external 10736 -- units or inside generics because calls in those context must also be 10737 -- verified. 10738 10739 if Is_Suitable_Call (N) then 10740 Check_Preelaborated_Call (N); 10741 end if; 10742 10743 -- Nothing to do when the scenario does not appear within the main unit 10744 10745 if not In_Main_Context (N) then 10746 return; 10747 10748 -- Scenarios within a generic unit are never considered because generics 10749 -- cannot be elaborated. 10750 10751 elsif Inside_A_Generic then 10752 return; 10753 10754 -- Scenarios which do not fall in one of the elaboration categories 10755 -- listed below are not considered. The categories are: 10756 10757 -- 'Access for entries, operators, and subprograms 10758 -- Assignments to variables 10759 -- Calls (includes task activation) 10760 -- Derived types 10761 -- Instantiations 10762 -- Pragma Refined_State 10763 -- Reads of variables 10764 10765 elsif Is_Suitable_Access (N) then 10766 Library_Level_OK := True; 10767 10768 -- Signal any enclosing local exception handlers that the 'Access may 10769 -- raise Program_Error due to a failed ABE check when switch -gnatd.o 10770 -- (conservative elaboration order for indirect calls) is in effect. 10771 -- Marking the exception handlers ensures proper expansion by both 10772 -- the front and back end restriction when No_Exception_Propagation 10773 -- is in effect. 10774 10775 if Debug_Flag_Dot_O then 10776 Possible_Local_Raise (N, Standard_Program_Error); 10777 end if; 10778 10779 elsif Is_Suitable_Call (N) or else Is_Suitable_Instantiation (N) then 10780 Declaration_Level_OK := True; 10781 Library_Level_OK := True; 10782 10783 -- Signal any enclosing local exception handlers that the call or 10784 -- instantiation may raise Program_Error due to a failed ABE check. 10785 -- Marking the exception handlers ensures proper expansion by both 10786 -- the front and back end restriction when No_Exception_Propagation 10787 -- is in effect. 10788 10789 Possible_Local_Raise (N, Standard_Program_Error); 10790 10791 elsif Is_Suitable_SPARK_Derived_Type (N) then 10792 Any_Level_OK := True; 10793 10794 elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then 10795 Library_Level_OK := True; 10796 10797 elsif Is_Suitable_Variable_Assignment (N) 10798 or else Is_Suitable_Variable_Reference (N) 10799 then 10800 Library_Level_OK := True; 10801 10802 -- Otherwise the input does not denote a suitable scenario 10803 10804 else 10805 return; 10806 end if; 10807 10808 -- The static model imposes additional restrictions on the placement of 10809 -- scenarios. In contrast, the dynamic model assumes that every scenario 10810 -- will be elaborated or invoked at some point. 10811 10812 if Static_Elaboration_Checks then 10813 10814 -- Certain scenarios are allowed to appear at any level. This check 10815 -- is performed here in order to save on a parent traversal. 10816 10817 if Any_Level_OK then 10818 null; 10819 10820 -- Otherwise the scenario must appear at a specific level 10821 10822 else 10823 -- Performance note: parent traversal 10824 10825 Level := Find_Enclosing_Level (N); 10826 10827 -- Declaration-level scenario 10828 10829 if Declaration_Level_OK and then Level = Declaration_Level then 10830 null; 10831 10832 -- Library-level or instantiation scenario 10833 10834 elsif Library_Level_OK 10835 and then Level in Library_Or_Instantiation_Level 10836 then 10837 null; 10838 10839 -- Otherwise the scenario does not appear at the proper level and 10840 -- cannot possibly act as a top-level scenario. 10841 10842 else 10843 return; 10844 end if; 10845 end if; 10846 end if; 10847 10848 -- Derived types subject to SPARK_Mode On require elaboration-related 10849 -- checks even though the type may not be declared within elaboration 10850 -- code. The types are recorded in a separate table which is examined 10851 -- during the Processing phase. Note that the checks must be delayed 10852 -- because the bodies of overriding primitives are not available yet. 10853 10854 if Is_Suitable_SPARK_Derived_Type (N) then 10855 Record_SPARK_Elaboration_Scenario (N); 10856 10857 -- Nothing left to do for derived types 10858 10859 return; 10860 10861 -- Instantiations of generics both subject to SPARK_Mode On require 10862 -- elaboration-related checks even though the instantiations may not 10863 -- appear within elaboration code. The instantiations are recored in 10864 -- a separate table which is examined during the Procesing phase. Note 10865 -- that the checks must be delayed because it is not known yet whether 10866 -- the generic unit has a body or not. 10867 10868 -- IMPORTANT: A SPARK instantiation is also a normal instantiation which 10869 -- is subject to common conditional and guaranteed ABE checks. 10870 10871 elsif Is_Suitable_SPARK_Instantiation (N) then 10872 Record_SPARK_Elaboration_Scenario (N); 10873 10874 -- External constituents that refine abstract states which appear in 10875 -- pragma Initializes require elaboration-related checks even though 10876 -- a Refined_State pragma lacks any elaboration semantic. 10877 10878 elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then 10879 Record_SPARK_Elaboration_Scenario (N); 10880 10881 -- Nothing left to do for pragma Refined_State 10882 10883 return; 10884 end if; 10885 10886 -- Perform early detection of guaranteed ABEs in order to suppress the 10887 -- instantiation of generic bodies as gigi cannot handle certain types 10888 -- of premature instantiations. 10889 10890 Process_Guaranteed_ABE (N); 10891 10892 -- At this point all checks have been performed. Record the scenario for 10893 -- later processing by the ABE phase. 10894 10895 Top_Level_Scenarios.Append (N); 10896 Set_Is_Recorded_Top_Level_Scenario (N); 10897 end Record_Elaboration_Scenario; 10898 10899 --------------------------------------- 10900 -- Record_SPARK_Elaboration_Scenario -- 10901 --------------------------------------- 10902 10903 procedure Record_SPARK_Elaboration_Scenario (N : Node_Id) is 10904 begin 10905 SPARK_Scenarios.Append (N); 10906 Set_Is_Recorded_SPARK_Scenario (N); 10907 end Record_SPARK_Elaboration_Scenario; 10908 10909 ----------------------------------- 10910 -- Recorded_SPARK_Scenarios_Hash -- 10911 ----------------------------------- 10912 10913 function Recorded_SPARK_Scenarios_Hash 10914 (Key : Node_Id) return Recorded_SPARK_Scenarios_Index 10915 is 10916 begin 10917 return 10918 Recorded_SPARK_Scenarios_Index (Key mod Recorded_SPARK_Scenarios_Max); 10919 end Recorded_SPARK_Scenarios_Hash; 10920 10921 --------------------------------------- 10922 -- Recorded_Top_Level_Scenarios_Hash -- 10923 --------------------------------------- 10924 10925 function Recorded_Top_Level_Scenarios_Hash 10926 (Key : Node_Id) return Recorded_Top_Level_Scenarios_Index 10927 is 10928 begin 10929 return 10930 Recorded_Top_Level_Scenarios_Index 10931 (Key mod Recorded_Top_Level_Scenarios_Max); 10932 end Recorded_Top_Level_Scenarios_Hash; 10933 10934 -------------------------- 10935 -- Reset_Visited_Bodies -- 10936 -------------------------- 10937 10938 procedure Reset_Visited_Bodies is 10939 begin 10940 if Visited_Bodies_In_Use then 10941 Visited_Bodies_In_Use := False; 10942 Visited_Bodies.Reset; 10943 end if; 10944 end Reset_Visited_Bodies; 10945 10946 ------------------- 10947 -- Root_Scenario -- 10948 ------------------- 10949 10950 function Root_Scenario return Node_Id is 10951 package Stack renames Scenario_Stack; 10952 10953 begin 10954 -- Ensure that the scenario stack has at least one active scenario in 10955 -- it. The one at the bottom (index First) is the root scenario. 10956 10957 pragma Assert (Stack.Last >= Stack.First); 10958 return Stack.Table (Stack.First); 10959 end Root_Scenario; 10960 10961 --------------------------- 10962 -- Set_Early_Call_Region -- 10963 --------------------------- 10964 10965 procedure Set_Early_Call_Region (Body_Id : Entity_Id; Start : Node_Id) is 10966 begin 10967 pragma Assert (Ekind_In (Body_Id, E_Entry, 10968 E_Entry_Family, 10969 E_Function, 10970 E_Procedure, 10971 E_Subprogram_Body)); 10972 10973 Early_Call_Regions_In_Use := True; 10974 Early_Call_Regions.Set (Body_Id, Start); 10975 end Set_Early_Call_Region; 10976 10977 ---------------------------- 10978 -- Set_Elaboration_Status -- 10979 ---------------------------- 10980 10981 procedure Set_Elaboration_Status 10982 (Unit_Id : Entity_Id; 10983 Val : Elaboration_Attributes) 10984 is 10985 begin 10986 Elaboration_Statuses_In_Use := True; 10987 Elaboration_Statuses.Set (Unit_Id, Val); 10988 end Set_Elaboration_Status; 10989 10990 ------------------------------------ 10991 -- Set_Is_Recorded_SPARK_Scenario -- 10992 ------------------------------------ 10993 10994 procedure Set_Is_Recorded_SPARK_Scenario 10995 (N : Node_Id; 10996 Val : Boolean := True) 10997 is 10998 begin 10999 Recorded_SPARK_Scenarios_In_Use := True; 11000 Recorded_SPARK_Scenarios.Set (N, Val); 11001 end Set_Is_Recorded_SPARK_Scenario; 11002 11003 ---------------------------------------- 11004 -- Set_Is_Recorded_Top_Level_Scenario -- 11005 ---------------------------------------- 11006 11007 procedure Set_Is_Recorded_Top_Level_Scenario 11008 (N : Node_Id; 11009 Val : Boolean := True) 11010 is 11011 begin 11012 Recorded_Top_Level_Scenarios_In_Use := True; 11013 Recorded_Top_Level_Scenarios.Set (N, Val); 11014 end Set_Is_Recorded_Top_Level_Scenario; 11015 11016 ------------------------- 11017 -- Set_Is_Visited_Body -- 11018 ------------------------- 11019 11020 procedure Set_Is_Visited_Body (Subp_Body : Node_Id) is 11021 begin 11022 Visited_Bodies_In_Use := True; 11023 Visited_Bodies.Set (Subp_Body, True); 11024 end Set_Is_Visited_Body; 11025 11026 ------------------------------- 11027 -- Static_Elaboration_Checks -- 11028 ------------------------------- 11029 11030 function Static_Elaboration_Checks return Boolean is 11031 begin 11032 return not Dynamic_Elaboration_Checks; 11033 end Static_Elaboration_Checks; 11034 11035 ------------------- 11036 -- Traverse_Body -- 11037 ------------------- 11038 11039 procedure Traverse_Body (N : Node_Id; State : Processing_Attributes) is 11040 procedure Find_And_Process_Nested_Scenarios; 11041 pragma Inline (Find_And_Process_Nested_Scenarios); 11042 -- Examine the declarations and statements of subprogram body N for 11043 -- suitable scenarios. 11044 11045 --------------------------------------- 11046 -- Find_And_Process_Nested_Scenarios -- 11047 --------------------------------------- 11048 11049 procedure Find_And_Process_Nested_Scenarios is 11050 function Is_Potential_Scenario 11051 (Nod : Node_Id) return Traverse_Result; 11052 -- Determine whether arbitrary node Nod denotes a suitable scenario. 11053 -- If it does, save it in the Nested_Scenarios list of the subprogram 11054 -- body, and process it. 11055 11056 procedure Traverse_List (List : List_Id); 11057 pragma Inline (Traverse_List); 11058 -- Invoke Traverse_Potential_Scenarios on each node in list List 11059 11060 procedure Traverse_Potential_Scenarios is 11061 new Traverse_Proc (Is_Potential_Scenario); 11062 11063 --------------------------- 11064 -- Is_Potential_Scenario -- 11065 --------------------------- 11066 11067 function Is_Potential_Scenario 11068 (Nod : Node_Id) return Traverse_Result 11069 is 11070 begin 11071 -- Special cases 11072 11073 -- Skip constructs which do not have elaboration of their own and 11074 -- need to be elaborated by other means such as invocation, task 11075 -- activation, etc. 11076 11077 if Is_Non_Library_Level_Encapsulator (Nod) then 11078 return Skip; 11079 11080 -- Terminate the traversal of a task body when encountering an 11081 -- accept or select statement, and 11082 -- 11083 -- * Entry calls during elaboration are not allowed. In this 11084 -- case the accept or select statement will cause the task 11085 -- to block at elaboration time because there are no entry 11086 -- calls to unblock it. 11087 -- 11088 -- or 11089 -- 11090 -- * Switch -gnatd_a (stop elaboration checks on accept or 11091 -- select statement) is in effect. 11092 11093 elsif (Debug_Flag_Underscore_A 11094 or else Restriction_Active 11095 (No_Entry_Calls_In_Elaboration_Code)) 11096 and then Nkind_In (Original_Node (Nod), N_Accept_Statement, 11097 N_Selective_Accept) 11098 then 11099 return Abandon; 11100 11101 -- Terminate the traversal of a task body when encountering a 11102 -- suspension call, and 11103 -- 11104 -- * Entry calls during elaboration are not allowed. In this 11105 -- case the suspension call emulates an entry call and will 11106 -- cause the task to block at elaboration time. 11107 -- 11108 -- or 11109 -- 11110 -- * Switch -gnatd_s (stop elaboration checks on synchronous 11111 -- suspension) is in effect. 11112 -- 11113 -- Note that the guard should not be checking the state of flag 11114 -- Within_Task_Body because only suspension calls which appear 11115 -- immediately within the statements of the task are supported. 11116 -- Flag Within_Task_Body carries over to deeper levels of the 11117 -- traversal. 11118 11119 elsif (Debug_Flag_Underscore_S 11120 or else Restriction_Active 11121 (No_Entry_Calls_In_Elaboration_Code)) 11122 and then Is_Synchronous_Suspension_Call (Nod) 11123 and then In_Task_Body (Nod) 11124 then 11125 return Abandon; 11126 11127 -- Certain nodes carry semantic lists which act as repositories 11128 -- until expansion transforms the node and relocates the contents. 11129 -- Examine these lists in case expansion is disabled. 11130 11131 elsif Nkind_In (Nod, N_And_Then, N_Or_Else) then 11132 Traverse_List (Actions (Nod)); 11133 11134 elsif Nkind_In (Nod, N_Elsif_Part, N_Iteration_Scheme) then 11135 Traverse_List (Condition_Actions (Nod)); 11136 11137 elsif Nkind (Nod) = N_If_Expression then 11138 Traverse_List (Then_Actions (Nod)); 11139 Traverse_List (Else_Actions (Nod)); 11140 11141 elsif Nkind_In (Nod, N_Component_Association, 11142 N_Iterated_Component_Association) 11143 then 11144 Traverse_List (Loop_Actions (Nod)); 11145 11146 -- General case 11147 11148 elsif Is_Suitable_Scenario (Nod) then 11149 Process_Conditional_ABE 11150 (N => Nod, 11151 State => State); 11152 end if; 11153 11154 return OK; 11155 end Is_Potential_Scenario; 11156 11157 ------------------- 11158 -- Traverse_List -- 11159 ------------------- 11160 11161 procedure Traverse_List (List : List_Id) is 11162 Item : Node_Id; 11163 11164 begin 11165 Item := First (List); 11166 while Present (Item) loop 11167 Traverse_Potential_Scenarios (Item); 11168 Next (Item); 11169 end loop; 11170 end Traverse_List; 11171 11172 -- Start of processing for Find_And_Process_Nested_Scenarios 11173 11174 begin 11175 -- Examine the declarations for suitable scenarios 11176 11177 Traverse_List (Declarations (N)); 11178 11179 -- Examine the handled sequence of statements. This also includes any 11180 -- exceptions handlers. 11181 11182 Traverse_Potential_Scenarios (Handled_Statement_Sequence (N)); 11183 end Find_And_Process_Nested_Scenarios; 11184 11185 -- Start of processing for Traverse_Body 11186 11187 begin 11188 -- Nothing to do when there is no body 11189 11190 if No (N) then 11191 return; 11192 11193 elsif Nkind (N) /= N_Subprogram_Body then 11194 return; 11195 end if; 11196 11197 -- Nothing to do if the body was already traversed during the processing 11198 -- of the same top-level scenario. 11199 11200 if Is_Visited_Body (N) then 11201 return; 11202 11203 -- Otherwise mark the body as traversed 11204 11205 else 11206 Set_Is_Visited_Body (N); 11207 end if; 11208 11209 -- Examine the declarations and statements of the subprogram body for 11210 -- suitable scenarios, save and process them accordingly. 11211 11212 Find_And_Process_Nested_Scenarios; 11213 end Traverse_Body; 11214 11215 ----------------- 11216 -- Unit_Entity -- 11217 ----------------- 11218 11219 function Unit_Entity (Unit_Id : Entity_Id) return Entity_Id is 11220 function Is_Subunit (Id : Entity_Id) return Boolean; 11221 pragma Inline (Is_Subunit); 11222 -- Determine whether the entity of an initial declaration denotes a 11223 -- subunit. 11224 11225 ---------------- 11226 -- Is_Subunit -- 11227 ---------------- 11228 11229 function Is_Subunit (Id : Entity_Id) return Boolean is 11230 Decl : constant Node_Id := Unit_Declaration_Node (Id); 11231 11232 begin 11233 return 11234 Nkind_In (Decl, N_Generic_Package_Declaration, 11235 N_Generic_Subprogram_Declaration, 11236 N_Package_Declaration, 11237 N_Protected_Type_Declaration, 11238 N_Subprogram_Declaration, 11239 N_Task_Type_Declaration) 11240 and then Present (Corresponding_Body (Decl)) 11241 and then Nkind (Parent (Unit_Declaration_Node 11242 (Corresponding_Body (Decl)))) = N_Subunit; 11243 end Is_Subunit; 11244 11245 -- Local variables 11246 11247 Id : Entity_Id; 11248 11249 -- Start of processing for Unit_Entity 11250 11251 begin 11252 Id := Unique_Entity (Unit_Id); 11253 11254 -- Skip all subunits found in the scope chain which ends at the input 11255 -- unit. 11256 11257 while Is_Subunit (Id) loop 11258 Id := Scope (Id); 11259 end loop; 11260 11261 return Id; 11262 end Unit_Entity; 11263 11264 --------------------------------- 11265 -- Update_Elaboration_Scenario -- 11266 --------------------------------- 11267 11268 procedure Update_Elaboration_Scenario (New_N : Node_Id; Old_N : Node_Id) is 11269 procedure Update_SPARK_Scenario; 11270 pragma Inline (Update_SPARK_Scenario); 11271 -- Update the contents of table SPARK_Scenarios if Old_N is recorded 11272 -- there. 11273 11274 procedure Update_Top_Level_Scenario; 11275 pragma Inline (Update_Top_Level_Scenario); 11276 -- Update the contexts of table Top_Level_Scenarios if Old_N is recorded 11277 -- there. 11278 11279 --------------------------- 11280 -- Update_SPARK_Scenario -- 11281 --------------------------- 11282 11283 procedure Update_SPARK_Scenario is 11284 package Scenarios renames SPARK_Scenarios; 11285 11286 begin 11287 if Is_Recorded_SPARK_Scenario (Old_N) then 11288 11289 -- Performance note: list traversal 11290 11291 for Index in Scenarios.First .. Scenarios.Last loop 11292 if Scenarios.Table (Index) = Old_N then 11293 Scenarios.Table (Index) := New_N; 11294 11295 -- The old SPARK scenario is no longer recorded, but the new 11296 -- one is. 11297 11298 Set_Is_Recorded_Top_Level_Scenario (Old_N, False); 11299 Set_Is_Recorded_Top_Level_Scenario (New_N); 11300 return; 11301 end if; 11302 end loop; 11303 11304 -- A recorded SPARK scenario must be in the table of recorded 11305 -- SPARK scenarios. 11306 11307 pragma Assert (False); 11308 end if; 11309 end Update_SPARK_Scenario; 11310 11311 ------------------------------- 11312 -- Update_Top_Level_Scenario -- 11313 ------------------------------- 11314 11315 procedure Update_Top_Level_Scenario is 11316 package Scenarios renames Top_Level_Scenarios; 11317 11318 begin 11319 if Is_Recorded_Top_Level_Scenario (Old_N) then 11320 11321 -- Performance note: list traversal 11322 11323 for Index in Scenarios.First .. Scenarios.Last loop 11324 if Scenarios.Table (Index) = Old_N then 11325 Scenarios.Table (Index) := New_N; 11326 11327 -- The old top-level scenario is no longer recorded, but the 11328 -- new one is. 11329 11330 Set_Is_Recorded_Top_Level_Scenario (Old_N, False); 11331 Set_Is_Recorded_Top_Level_Scenario (New_N); 11332 return; 11333 end if; 11334 end loop; 11335 11336 -- A recorded top-level scenario must be in the table of recorded 11337 -- top-level scenarios. 11338 11339 pragma Assert (False); 11340 end if; 11341 end Update_Top_Level_Scenario; 11342 11343 -- Start of processing for Update_Elaboration_Requirement 11344 11345 begin 11346 -- Nothing to do when the old and new scenarios are one and the same 11347 11348 if Old_N = New_N then 11349 return; 11350 11351 -- A scenario is being transformed by Atree.Rewrite. Update all relevant 11352 -- internal data structures to reflect this change. This ensures that a 11353 -- potential run-time conditional ABE check or a guaranteed ABE failure 11354 -- is inserted at the proper place in the tree. 11355 11356 elsif Is_Scenario (Old_N) then 11357 Update_SPARK_Scenario; 11358 Update_Top_Level_Scenario; 11359 end if; 11360 end Update_Elaboration_Scenario; 11361 11362 ------------------------- 11363 -- Visited_Bodies_Hash -- 11364 ------------------------- 11365 11366 function Visited_Bodies_Hash (Key : Node_Id) return Visited_Bodies_Index is 11367 begin 11368 return Visited_Bodies_Index (Key mod Visited_Bodies_Max); 11369 end Visited_Bodies_Hash; 11370 11371 --------------------------------------------------------------------------- 11372 -- -- 11373 -- 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 -- 11374 -- -- 11375 -- M E C H A N I S M -- 11376 -- -- 11377 --------------------------------------------------------------------------- 11378 11379 -- This section contains the implementation of the pre-18.x legacy ABE 11380 -- mechanism. The mechanism can be activated using switch -gnatH (legacy 11381 -- elaboration checking mode enabled). 11382 11383 ----------------------------- 11384 -- Description of Approach -- 11385 ----------------------------- 11386 11387 -- Every non-static call that is encountered by Sem_Res results in a call 11388 -- to Check_Elab_Call, with N being the call node, and Outer set to its 11389 -- default value of True. In addition X'Access is treated like a call 11390 -- for the access-to-procedure case, and in SPARK mode only we also 11391 -- check variable references. 11392 11393 -- The goal of Check_Elab_Call is to determine whether or not the reference 11394 -- in question can generate an access before elaboration error (raising 11395 -- Program_Error) either by directly calling a subprogram whose body 11396 -- has not yet been elaborated, or indirectly, by calling a subprogram 11397 -- whose body has been elaborated, but which contains a call to such a 11398 -- subprogram. 11399 11400 -- In addition, in SPARK mode, we are checking for a variable reference in 11401 -- another package, which requires an explicit Elaborate_All pragma. 11402 11403 -- The only references that we need to look at the outer level are 11404 -- references that occur in elaboration code. There are two cases. The 11405 -- reference can be at the outer level of elaboration code, or it can 11406 -- be within another unit, e.g. the elaboration code of a subprogram. 11407 11408 -- In the case of an elaboration call at the outer level, we must trace 11409 -- all calls to outer level routines either within the current unit or to 11410 -- other units that are with'ed. For calls within the current unit, we can 11411 -- determine if the body has been elaborated or not, and if it has not, 11412 -- then a warning is generated. 11413 11414 -- Note that there are two subcases. If the original call directly calls a 11415 -- subprogram whose body has not been elaborated, then we know that an ABE 11416 -- will take place, and we replace the call by a raise of Program_Error. 11417 -- If the call is indirect, then we don't know that the PE will be raised, 11418 -- since the call might be guarded by a conditional. In this case we set 11419 -- Do_Elab_Check on the call so that a dynamic check is generated, and 11420 -- output a warning. 11421 11422 -- For calls to a subprogram in a with'ed unit or a 'Access or variable 11423 -- reference (SPARK mode case), we require that a pragma Elaborate_All 11424 -- or pragma Elaborate be present, or that the referenced unit have a 11425 -- pragma Preelaborate, pragma Pure, or pragma Elaborate_Body. If none 11426 -- of these conditions is met, then a warning is generated that a pragma 11427 -- Elaborate_All may be needed (error in the SPARK case), or an implicit 11428 -- pragma is generated. 11429 11430 -- For the case of an elaboration call at some inner level, we are 11431 -- interested in tracing only calls to subprograms at the same level, i.e. 11432 -- those that can be called during elaboration. Any calls to outer level 11433 -- routines cannot cause ABE's as a result of the original call (there 11434 -- might be an outer level call to the subprogram from outside that causes 11435 -- the ABE, but that gets analyzed separately). 11436 11437 -- Note that we never trace calls to inner level subprograms, since these 11438 -- cannot result in ABE's unless there is an elaboration problem at a lower 11439 -- level, which will be separately detected. 11440 11441 -- Note on pragma Elaborate. The checking here assumes that a pragma 11442 -- Elaborate on a with'ed unit guarantees that subprograms within the unit 11443 -- can be called without causing an ABE. This is not in fact the case since 11444 -- pragma Elaborate does not guarantee the transitive coverage guaranteed 11445 -- by Elaborate_All. However, we decide to trust the user in this case. 11446 11447 -------------------------------------- 11448 -- Instantiation Elaboration Errors -- 11449 -------------------------------------- 11450 11451 -- A special case arises when an instantiation appears in a context that is 11452 -- known to be before the body is elaborated, e.g. 11453 11454 -- generic package x is ... 11455 -- ... 11456 -- package xx is new x; 11457 -- ... 11458 -- package body x is ... 11459 11460 -- In this situation it is certain that an elaboration error will occur, 11461 -- and an unconditional raise Program_Error statement is inserted before 11462 -- the instantiation, and a warning generated. 11463 11464 -- The problem is that in this case we have no place to put the body of 11465 -- the instantiation. We can't put it in the normal place, because it is 11466 -- too early, and will cause errors to occur as a result of referencing 11467 -- entities before they are declared. 11468 11469 -- Our approach in this case is simply to avoid creating the body of the 11470 -- instantiation in such a case. The instantiation spec is modified to 11471 -- include dummy bodies for all subprograms, so that the resulting code 11472 -- does not contain subprogram specs with no corresponding bodies. 11473 11474 -- The following table records the recursive call chain for output in the 11475 -- Output routine. Each entry records the call node and the entity of the 11476 -- called routine. The number of entries in the table (i.e. the value of 11477 -- Elab_Call.Last) indicates the current depth of recursion and is used to 11478 -- identify the outer level. 11479 11480 type Elab_Call_Element is record 11481 Cloc : Source_Ptr; 11482 Ent : Entity_Id; 11483 end record; 11484 11485 package Elab_Call is new Table.Table 11486 (Table_Component_Type => Elab_Call_Element, 11487 Table_Index_Type => Int, 11488 Table_Low_Bound => 1, 11489 Table_Initial => 50, 11490 Table_Increment => 100, 11491 Table_Name => "Elab_Call"); 11492 11493 -- The following table records all calls that have been processed starting 11494 -- from an outer level call. The table prevents both infinite recursion and 11495 -- useless reanalysis of calls within the same context. The use of context 11496 -- is important because it allows for proper checks in more complex code: 11497 11498 -- if ... then 11499 -- Call; -- requires a check 11500 -- Call; -- does not need a check thanks to the table 11501 -- elsif ... then 11502 -- Call; -- requires a check, different context 11503 -- end if; 11504 11505 -- Call; -- requires a check, different context 11506 11507 type Visited_Element is record 11508 Subp_Id : Entity_Id; 11509 -- The entity of the subprogram being called 11510 11511 Context : Node_Id; 11512 -- The context where the call to the subprogram occurs 11513 end record; 11514 11515 package Elab_Visited is new Table.Table 11516 (Table_Component_Type => Visited_Element, 11517 Table_Index_Type => Int, 11518 Table_Low_Bound => 1, 11519 Table_Initial => 200, 11520 Table_Increment => 100, 11521 Table_Name => "Elab_Visited"); 11522 11523 -- The following table records delayed calls which must be examined after 11524 -- all generic bodies have been instantiated. 11525 11526 type Delay_Element is record 11527 N : Node_Id; 11528 -- The parameter N from the call to Check_Internal_Call. Note that this 11529 -- node may get rewritten over the delay period by expansion in the call 11530 -- case (but not in the instantiation case). 11531 11532 E : Entity_Id; 11533 -- The parameter E from the call to Check_Internal_Call 11534 11535 Orig_Ent : Entity_Id; 11536 -- The parameter Orig_Ent from the call to Check_Internal_Call 11537 11538 Curscop : Entity_Id; 11539 -- The current scope of the call. This is restored when we complete the 11540 -- delayed call, so that we do this in the right scope. 11541 11542 Outer_Scope : Entity_Id; 11543 -- Save scope of outer level call 11544 11545 From_Elab_Code : Boolean; 11546 -- Save indication of whether this call is from elaboration code 11547 11548 In_Task_Activation : Boolean; 11549 -- Save indication of whether this call is from a task body. Tasks are 11550 -- activated at the "begin", which is after all local procedure bodies, 11551 -- so calls to those procedures can't fail, even if they occur after the 11552 -- task body. 11553 11554 From_SPARK_Code : Boolean; 11555 -- Save indication of whether this call is under SPARK_Mode => On 11556 end record; 11557 11558 package Delay_Check is new Table.Table 11559 (Table_Component_Type => Delay_Element, 11560 Table_Index_Type => Int, 11561 Table_Low_Bound => 1, 11562 Table_Initial => 1000, 11563 Table_Increment => 100, 11564 Table_Name => "Delay_Check"); 11565 11566 C_Scope : Entity_Id; 11567 -- Top-level scope of current scope. Compute this only once at the outer 11568 -- level, i.e. for a call to Check_Elab_Call from outside this unit. 11569 11570 Outer_Level_Sloc : Source_Ptr; 11571 -- Save Sloc value for outer level call node for comparisons of source 11572 -- locations. A body is too late if it appears after the *outer* level 11573 -- call, not the particular call that is being analyzed. 11574 11575 From_Elab_Code : Boolean; 11576 -- This flag shows whether the outer level call currently being examined 11577 -- is or is not in elaboration code. We are only interested in calls to 11578 -- routines in other units if this flag is True. 11579 11580 In_Task_Activation : Boolean := False; 11581 -- This flag indicates whether we are performing elaboration checks on task 11582 -- bodies, at the point of activation. If true, we do not raise 11583 -- Program_Error for calls to local procedures, because all local bodies 11584 -- are known to be elaborated. However, we still need to trace such calls, 11585 -- because a local procedure could call a procedure in another package, 11586 -- so we might need an implicit Elaborate_All. 11587 11588 Delaying_Elab_Checks : Boolean := True; 11589 -- This is set True till the compilation is complete, including the 11590 -- insertion of all instance bodies. Then when Check_Elab_Calls is called, 11591 -- the delay table is used to make the delayed calls and this flag is reset 11592 -- to False, so that the calls are processed. 11593 11594 ----------------------- 11595 -- Local Subprograms -- 11596 ----------------------- 11597 11598 -- Note: Outer_Scope in all following specs represents the scope of 11599 -- interest of the outer level call. If it is set to Standard_Standard, 11600 -- then it means the outer level call was at elaboration level, and that 11601 -- thus all calls are of interest. If it was set to some other scope, 11602 -- then the original call was an inner call, and we are not interested 11603 -- in calls that go outside this scope. 11604 11605 procedure Activate_Elaborate_All_Desirable (N : Node_Id; U : Entity_Id); 11606 -- Analysis of construct N shows that we should set Elaborate_All_Desirable 11607 -- for the WITH clause for unit U (which will always be present). A special 11608 -- case is when N is a function or procedure instantiation, in which case 11609 -- it is sufficient to set Elaborate_Desirable, since in this case there is 11610 -- no possibility of transitive elaboration issues. 11611 11612 procedure Check_A_Call 11613 (N : Node_Id; 11614 E : Entity_Id; 11615 Outer_Scope : Entity_Id; 11616 Inter_Unit_Only : Boolean; 11617 Generate_Warnings : Boolean := True; 11618 In_Init_Proc : Boolean := False); 11619 -- This is the internal recursive routine that is called to check for 11620 -- possible elaboration error. The argument N is a subprogram call or 11621 -- generic instantiation, or 'Access attribute reference to be checked, and 11622 -- E is the entity of the called subprogram, or instantiated generic unit, 11623 -- or subprogram referenced by 'Access. 11624 -- 11625 -- In SPARK mode, N can also be a variable reference, since in SPARK this 11626 -- also triggers a requirement for Elaborate_All, and in this case E is the 11627 -- entity being referenced. 11628 -- 11629 -- Outer_Scope is the outer level scope for the original reference. 11630 -- Inter_Unit_Only is set if the call is only to be checked in the 11631 -- case where it is to another unit (and skipped if within a unit). 11632 -- Generate_Warnings is set to False to suppress warning messages about 11633 -- missing pragma Elaborate_All's. These messages are not wanted for 11634 -- inner calls in the dynamic model. Note that an instance of the Access 11635 -- attribute applied to a subprogram also generates a call to this 11636 -- procedure (since the referenced subprogram may be called later 11637 -- indirectly). Flag In_Init_Proc should be set whenever the current 11638 -- context is a type init proc. 11639 -- 11640 -- Note: this might better be called Check_A_Reference to recognize the 11641 -- variable case for SPARK, but we prefer to retain the historical name 11642 -- since in practice this is mostly about checking calls for the possible 11643 -- occurrence of an access-before-elaboration exception. 11644 11645 procedure Check_Bad_Instantiation (N : Node_Id); 11646 -- N is a node for an instantiation (if called with any other node kind, 11647 -- Check_Bad_Instantiation ignores the call). This subprogram checks for 11648 -- the special case of a generic instantiation of a generic spec in the 11649 -- same declarative part as the instantiation where a body is present and 11650 -- has not yet been seen. This is an obvious error, but needs to be checked 11651 -- specially at the time of the instantiation, since it is a case where we 11652 -- cannot insert the body anywhere. If this case is detected, warnings are 11653 -- generated, and a raise of Program_Error is inserted. In addition any 11654 -- subprograms in the generic spec are stubbed, and the Bad_Instantiation 11655 -- flag is set on the instantiation node. The caller in Sem_Ch12 uses this 11656 -- flag as an indication that no attempt should be made to insert an 11657 -- instance body. 11658 11659 procedure Check_Internal_Call 11660 (N : Node_Id; 11661 E : Entity_Id; 11662 Outer_Scope : Entity_Id; 11663 Orig_Ent : Entity_Id); 11664 -- N is a function call or procedure statement call node and E is the 11665 -- entity of the called function, which is within the current compilation 11666 -- unit (where subunits count as part of the parent). This call checks if 11667 -- this call, or any call within any accessed body could cause an ABE, and 11668 -- if so, outputs a warning. Orig_Ent differs from E only in the case of 11669 -- renamings, and points to the original name of the entity. This is used 11670 -- for error messages. Outer_Scope is the outer level scope for the 11671 -- original call. 11672 11673 procedure Check_Internal_Call_Continue 11674 (N : Node_Id; 11675 E : Entity_Id; 11676 Outer_Scope : Entity_Id; 11677 Orig_Ent : Entity_Id); 11678 -- The processing for Check_Internal_Call is divided up into two phases, 11679 -- and this represents the second phase. The second phase is delayed if 11680 -- Delaying_Elab_Checks is set to True. In this delayed case, the first 11681 -- phase makes an entry in the Delay_Check table, which is processed when 11682 -- Check_Elab_Calls is called. N, E and Orig_Ent are as for the call to 11683 -- Check_Internal_Call. Outer_Scope is the outer level scope for the 11684 -- original call. 11685 11686 function Get_Referenced_Ent (N : Node_Id) return Entity_Id; 11687 -- N is either a function or procedure call or an access attribute that 11688 -- references a subprogram. This call retrieves the relevant entity. If 11689 -- this is a call to a protected subprogram, the entity is a selected 11690 -- component. The callable entity may be absent, in which case Empty is 11691 -- returned. This happens with non-analyzed calls in nested generics. 11692 -- 11693 -- If SPARK_Mode is On, then N can also be a reference to an E_Variable 11694 -- entity, in which case, the value returned is simply this entity. 11695 11696 function Has_Generic_Body (N : Node_Id) return Boolean; 11697 -- N is a generic package instantiation node, and this routine determines 11698 -- if this package spec does in fact have a generic body. If so, then 11699 -- True is returned, otherwise False. Note that this is not at all the 11700 -- same as checking if the unit requires a body, since it deals with 11701 -- the case of optional bodies accurately (i.e. if a body is optional, 11702 -- then it looks to see if a body is actually present). Note: this 11703 -- function can only do a fully correct job if in generating code mode 11704 -- where all bodies have to be present. If we are operating in semantics 11705 -- check only mode, then in some cases of optional bodies, a result of 11706 -- False may incorrectly be given. In practice this simply means that 11707 -- some cases of warnings for incorrect order of elaboration will only 11708 -- be given when generating code, which is not a big problem (and is 11709 -- inevitable, given the optional body semantics of Ada). 11710 11711 procedure Insert_Elab_Check (N : Node_Id; C : Node_Id := Empty); 11712 -- Given code for an elaboration check (or unconditional raise if the check 11713 -- is not needed), inserts the code in the appropriate place. N is the call 11714 -- or instantiation node for which the check code is required. C is the 11715 -- test whose failure triggers the raise. 11716 11717 function Is_Call_Of_Generic_Formal (N : Node_Id) return Boolean; 11718 -- Returns True if node N is a call to a generic formal subprogram 11719 11720 function Is_Finalization_Procedure (Id : Entity_Id) return Boolean; 11721 -- Determine whether entity Id denotes a [Deep_]Finalize procedure 11722 11723 procedure Output_Calls 11724 (N : Node_Id; 11725 Check_Elab_Flag : Boolean); 11726 -- Outputs chain of calls stored in the Elab_Call table. The caller has 11727 -- already generated the main warning message, so the warnings generated 11728 -- are all continuation messages. The argument is the call node at which 11729 -- the messages are to be placed. When Check_Elab_Flag is set, calls are 11730 -- enumerated only when flag Elab_Warning is set for the dynamic case or 11731 -- when flag Elab_Info_Messages is set for the static case. 11732 11733 function Same_Elaboration_Scope (Scop1, Scop2 : Entity_Id) return Boolean; 11734 -- Given two scopes, determine whether they are the same scope from an 11735 -- elaboration point of view, i.e. packages and blocks are ignored. 11736 11737 procedure Set_C_Scope; 11738 -- On entry C_Scope is set to some scope. On return, C_Scope is reset 11739 -- to be the enclosing compilation unit of this scope. 11740 11741 procedure Set_Elaboration_Constraint 11742 (Call : Node_Id; 11743 Subp : Entity_Id; 11744 Scop : Entity_Id); 11745 -- The current unit U may depend semantically on some unit P that is not 11746 -- in the current context. If there is an elaboration call that reaches P, 11747 -- we need to indicate that P requires an Elaborate_All, but this is not 11748 -- effective in U's ali file, if there is no with_clause for P. In this 11749 -- case we add the Elaborate_All on the unit Q that directly or indirectly 11750 -- makes P available. This can happen in two cases: 11751 -- 11752 -- a) Q declares a subtype of a type declared in P, and the call is an 11753 -- initialization call for an object of that subtype. 11754 -- 11755 -- b) Q declares an object of some tagged type whose root type is 11756 -- declared in P, and the initialization call uses object notation on 11757 -- that object to reach a primitive operation or a classwide operation 11758 -- declared in P. 11759 -- 11760 -- If P appears in the context of U, the current processing is correct. 11761 -- Otherwise we must identify these two cases to retrieve Q and place the 11762 -- Elaborate_All_Desirable on it. 11763 11764 function Spec_Entity (E : Entity_Id) return Entity_Id; 11765 -- Given a compilation unit entity, if it is a spec entity, it is returned 11766 -- unchanged. If it is a body entity, then the spec for the corresponding 11767 -- spec is returned 11768 11769 function Within (E1, E2 : Entity_Id) return Boolean; 11770 -- Given two scopes E1 and E2, returns True if E1 is equal to E2, or is one 11771 -- of its contained scopes, False otherwise. 11772 11773 function Within_Elaborate_All 11774 (Unit : Unit_Number_Type; 11775 E : Entity_Id) return Boolean; 11776 -- Return True if we are within the scope of an Elaborate_All for E, or if 11777 -- we are within the scope of an Elaborate_All for some other unit U, and U 11778 -- with's E. This prevents spurious warnings when the called entity is 11779 -- renamed within U, or in case of generic instances. 11780 11781 -------------------------------------- 11782 -- Activate_Elaborate_All_Desirable -- 11783 -------------------------------------- 11784 11785 procedure Activate_Elaborate_All_Desirable (N : Node_Id; U : Entity_Id) is 11786 UN : constant Unit_Number_Type := Get_Code_Unit (N); 11787 CU : constant Node_Id := Cunit (UN); 11788 UE : constant Entity_Id := Cunit_Entity (UN); 11789 Unm : constant Unit_Name_Type := Unit_Name (UN); 11790 CI : constant List_Id := Context_Items (CU); 11791 Itm : Node_Id; 11792 Ent : Entity_Id; 11793 11794 procedure Add_To_Context_And_Mark (Itm : Node_Id); 11795 -- This procedure is called when the elaborate indication must be 11796 -- applied to a unit not in the context of the referencing unit. The 11797 -- unit gets added to the context as an implicit with. 11798 11799 function In_Withs_Of (UEs : Entity_Id) return Boolean; 11800 -- UEs is the spec entity of a unit. If the unit to be marked is 11801 -- in the context item list of this unit spec, then the call returns 11802 -- True and Itm is left set to point to the relevant N_With_Clause node. 11803 11804 procedure Set_Elab_Flag (Itm : Node_Id); 11805 -- Sets Elaborate_[All_]Desirable as appropriate on Itm 11806 11807 ----------------------------- 11808 -- Add_To_Context_And_Mark -- 11809 ----------------------------- 11810 11811 procedure Add_To_Context_And_Mark (Itm : Node_Id) is 11812 CW : constant Node_Id := 11813 Make_With_Clause (Sloc (Itm), 11814 Name => Name (Itm)); 11815 11816 begin 11817 Set_Library_Unit (CW, Library_Unit (Itm)); 11818 Set_Implicit_With (CW); 11819 11820 -- Set elaborate all desirable on copy and then append the copy to 11821 -- the list of body with's and we are done. 11822 11823 Set_Elab_Flag (CW); 11824 Append_To (CI, CW); 11825 end Add_To_Context_And_Mark; 11826 11827 ----------------- 11828 -- In_Withs_Of -- 11829 ----------------- 11830 11831 function In_Withs_Of (UEs : Entity_Id) return Boolean is 11832 UNs : constant Unit_Number_Type := Get_Source_Unit (UEs); 11833 CUs : constant Node_Id := Cunit (UNs); 11834 CIs : constant List_Id := Context_Items (CUs); 11835 11836 begin 11837 Itm := First (CIs); 11838 while Present (Itm) loop 11839 if Nkind (Itm) = N_With_Clause then 11840 Ent := 11841 Cunit_Entity (Get_Cunit_Unit_Number (Library_Unit (Itm))); 11842 11843 if U = Ent then 11844 return True; 11845 end if; 11846 end if; 11847 11848 Next (Itm); 11849 end loop; 11850 11851 return False; 11852 end In_Withs_Of; 11853 11854 ------------------- 11855 -- Set_Elab_Flag -- 11856 ------------------- 11857 11858 procedure Set_Elab_Flag (Itm : Node_Id) is 11859 begin 11860 if Nkind (N) in N_Subprogram_Instantiation then 11861 Set_Elaborate_Desirable (Itm); 11862 else 11863 Set_Elaborate_All_Desirable (Itm); 11864 end if; 11865 end Set_Elab_Flag; 11866 11867 -- Start of processing for Activate_Elaborate_All_Desirable 11868 11869 begin 11870 -- Do not set binder indication if expansion is disabled, as when 11871 -- compiling a generic unit. 11872 11873 if not Expander_Active then 11874 return; 11875 end if; 11876 11877 -- If an instance of a generic package contains a controlled object (so 11878 -- we're calling Initialize at elaboration time), and the instance is in 11879 -- a package body P that says "with P;", then we need to return without 11880 -- adding "pragma Elaborate_All (P);" to P. 11881 11882 if U = Main_Unit_Entity then 11883 return; 11884 end if; 11885 11886 Itm := First (CI); 11887 while Present (Itm) loop 11888 if Nkind (Itm) = N_With_Clause then 11889 Ent := Cunit_Entity (Get_Cunit_Unit_Number (Library_Unit (Itm))); 11890 11891 -- If we find it, then mark elaborate all desirable and return 11892 11893 if U = Ent then 11894 Set_Elab_Flag (Itm); 11895 return; 11896 end if; 11897 end if; 11898 11899 Next (Itm); 11900 end loop; 11901 11902 -- If we fall through then the with clause is not present in the 11903 -- current unit. One legitimate possibility is that the with clause 11904 -- is present in the spec when we are a body. 11905 11906 if Is_Body_Name (Unm) 11907 and then In_Withs_Of (Spec_Entity (UE)) 11908 then 11909 Add_To_Context_And_Mark (Itm); 11910 return; 11911 end if; 11912 11913 -- Similarly, we may be in the spec or body of a child unit, where 11914 -- the unit in question is with'ed by some ancestor of the child unit. 11915 11916 if Is_Child_Name (Unm) then 11917 declare 11918 Pkg : Entity_Id; 11919 11920 begin 11921 Pkg := UE; 11922 loop 11923 Pkg := Scope (Pkg); 11924 exit when Pkg = Standard_Standard; 11925 11926 if In_Withs_Of (Pkg) then 11927 Add_To_Context_And_Mark (Itm); 11928 return; 11929 end if; 11930 end loop; 11931 end; 11932 end if; 11933 11934 -- Here if we do not find with clause on spec or body. We just ignore 11935 -- this case; it means that the elaboration involves some other unit 11936 -- than the unit being compiled, and will be caught elsewhere. 11937 end Activate_Elaborate_All_Desirable; 11938 11939 ------------------ 11940 -- Check_A_Call -- 11941 ------------------ 11942 11943 procedure Check_A_Call 11944 (N : Node_Id; 11945 E : Entity_Id; 11946 Outer_Scope : Entity_Id; 11947 Inter_Unit_Only : Boolean; 11948 Generate_Warnings : Boolean := True; 11949 In_Init_Proc : Boolean := False) 11950 is 11951 Access_Case : constant Boolean := Nkind (N) = N_Attribute_Reference; 11952 -- Indicates if we have Access attribute case 11953 11954 function Call_To_Instance_From_Outside (Id : Entity_Id) return Boolean; 11955 -- True if we're calling an instance of a generic subprogram, or a 11956 -- subprogram in an instance of a generic package, and the call is 11957 -- outside that instance. 11958 11959 procedure Elab_Warning 11960 (Msg_D : String; 11961 Msg_S : String; 11962 Ent : Node_Or_Entity_Id); 11963 -- Generate a call to Error_Msg_NE with parameters Msg_D or Msg_S (for 11964 -- dynamic or static elaboration model), N and Ent. Msg_D is a real 11965 -- warning (output if Msg_D is non-null and Elab_Warnings is set), 11966 -- Msg_S is an info message (output if Elab_Info_Messages is set). 11967 11968 function Find_W_Scope return Entity_Id; 11969 -- Find top-level scope for called entity (not following renamings 11970 -- or derivations). This is where the Elaborate_All will go if it is 11971 -- needed. We start with the called entity, except in the case of an 11972 -- initialization procedure outside the current package, where the init 11973 -- proc is in the root package, and we start from the entity of the name 11974 -- in the call. 11975 11976 ----------------------------------- 11977 -- Call_To_Instance_From_Outside -- 11978 ----------------------------------- 11979 11980 function Call_To_Instance_From_Outside (Id : Entity_Id) return Boolean is 11981 Scop : Entity_Id := Id; 11982 11983 begin 11984 loop 11985 if Scop = Standard_Standard then 11986 return False; 11987 end if; 11988 11989 if Is_Generic_Instance (Scop) then 11990 return not In_Open_Scopes (Scop); 11991 end if; 11992 11993 Scop := Scope (Scop); 11994 end loop; 11995 end Call_To_Instance_From_Outside; 11996 11997 ------------------ 11998 -- Elab_Warning -- 11999 ------------------ 12000 12001 procedure Elab_Warning 12002 (Msg_D : String; 12003 Msg_S : String; 12004 Ent : Node_Or_Entity_Id) 12005 is 12006 begin 12007 -- Dynamic elaboration checks, real warning 12008 12009 if Dynamic_Elaboration_Checks then 12010 if not Access_Case then 12011 if Msg_D /= "" and then Elab_Warnings then 12012 Error_Msg_NE (Msg_D, N, Ent); 12013 end if; 12014 12015 -- In the access case emit first warning message as well, 12016 -- otherwise list of calls will appear as errors. 12017 12018 elsif Elab_Warnings then 12019 Error_Msg_NE (Msg_S, N, Ent); 12020 end if; 12021 12022 -- Static elaboration checks, info message 12023 12024 else 12025 if Elab_Info_Messages then 12026 Error_Msg_NE (Msg_S, N, Ent); 12027 end if; 12028 end if; 12029 end Elab_Warning; 12030 12031 ------------------ 12032 -- Find_W_Scope -- 12033 ------------------ 12034 12035 function Find_W_Scope return Entity_Id is 12036 Refed_Ent : constant Entity_Id := Get_Referenced_Ent (N); 12037 W_Scope : Entity_Id; 12038 12039 begin 12040 if Is_Init_Proc (Refed_Ent) 12041 and then not In_Same_Extended_Unit (N, Refed_Ent) 12042 then 12043 W_Scope := Scope (Refed_Ent); 12044 else 12045 W_Scope := E; 12046 end if; 12047 12048 -- Now loop through scopes to get to the enclosing compilation unit 12049 12050 while not Is_Compilation_Unit (W_Scope) loop 12051 W_Scope := Scope (W_Scope); 12052 end loop; 12053 12054 return W_Scope; 12055 end Find_W_Scope; 12056 12057 -- Local variables 12058 12059 Inst_Case : constant Boolean := Nkind (N) in N_Generic_Instantiation; 12060 -- Indicates if we have instantiation case 12061 12062 Loc : constant Source_Ptr := Sloc (N); 12063 12064 Variable_Case : constant Boolean := 12065 Nkind (N) in N_Has_Entity 12066 and then Present (Entity (N)) 12067 and then Ekind (Entity (N)) = E_Variable; 12068 -- Indicates if we have variable reference case 12069 12070 W_Scope : constant Entity_Id := Find_W_Scope; 12071 -- Top-level scope of directly called entity for subprogram. This 12072 -- differs from E_Scope in the case where renamings or derivations 12073 -- are involved, since it does not follow these links. W_Scope is 12074 -- generally in a visible unit, and it is this scope that may require 12075 -- an Elaborate_All. However, there are some cases (initialization 12076 -- calls and calls involving object notation) where W_Scope might not 12077 -- be in the context of the current unit, and there is an intermediate 12078 -- package that is, in which case the Elaborate_All has to be placed 12079 -- on this intermediate package. These special cases are handled in 12080 -- Set_Elaboration_Constraint. 12081 12082 Ent : Entity_Id; 12083 Callee_Unit_Internal : Boolean; 12084 Caller_Unit_Internal : Boolean; 12085 Decl : Node_Id; 12086 Inst_Callee : Source_Ptr; 12087 Inst_Caller : Source_Ptr; 12088 Unit_Callee : Unit_Number_Type; 12089 Unit_Caller : Unit_Number_Type; 12090 12091 Body_Acts_As_Spec : Boolean; 12092 -- Set to true if call is to body acting as spec (no separate spec) 12093 12094 Cunit_SC : Boolean := False; 12095 -- Set to suppress dynamic elaboration checks where one of the 12096 -- enclosing scopes has Elaboration_Checks_Suppressed set, or else 12097 -- if a pragma Elaborate[_All] applies to that scope, in which case 12098 -- warnings on the scope are also suppressed. For the internal case, 12099 -- we ignore this flag. 12100 12101 E_Scope : Entity_Id; 12102 -- Top-level scope of entity for called subprogram. This value includes 12103 -- following renamings and derivations, so this scope can be in a 12104 -- non-visible unit. This is the scope that is to be investigated to 12105 -- see whether an elaboration check is required. 12106 12107 Is_DIC : Boolean; 12108 -- Flag set when the subprogram being invoked is the procedure generated 12109 -- for pragma Default_Initial_Condition. 12110 12111 SPARK_Elab_Errors : Boolean; 12112 -- Flag set when an entity is called or a variable is read during SPARK 12113 -- dynamic elaboration. 12114 12115 -- Start of processing for Check_A_Call 12116 12117 begin 12118 -- If the call is known to be within a local Suppress Elaboration 12119 -- pragma, nothing to check. This can happen in task bodies. But 12120 -- we ignore this for a call to a generic formal. 12121 12122 if Nkind (N) in N_Subprogram_Call 12123 and then No_Elaboration_Check (N) 12124 and then not Is_Call_Of_Generic_Formal (N) 12125 then 12126 return; 12127 12128 -- If this is a rewrite of a Valid_Scalars attribute, then nothing to 12129 -- check, we don't mind in this case if the call occurs before the body 12130 -- since this is all generated code. 12131 12132 elsif Nkind (Original_Node (N)) = N_Attribute_Reference 12133 and then Attribute_Name (Original_Node (N)) = Name_Valid_Scalars 12134 then 12135 return; 12136 12137 -- Intrinsics such as instances of Unchecked_Deallocation do not have 12138 -- any body, so elaboration checking is not needed, and would be wrong. 12139 12140 elsif Is_Intrinsic_Subprogram (E) then 12141 return; 12142 12143 -- Do not consider references to internal variables for SPARK semantics 12144 12145 elsif Variable_Case and then not Comes_From_Source (E) then 12146 return; 12147 end if; 12148 12149 -- Proceed with check 12150 12151 Ent := E; 12152 12153 -- For a variable reference, just set Body_Acts_As_Spec to False 12154 12155 if Variable_Case then 12156 Body_Acts_As_Spec := False; 12157 12158 -- Additional checks for all other cases 12159 12160 else 12161 -- Go to parent for derived subprogram, or to original subprogram in 12162 -- the case of a renaming (Alias covers both these cases). 12163 12164 loop 12165 if (Suppress_Elaboration_Warnings (Ent) 12166 or else Elaboration_Checks_Suppressed (Ent)) 12167 and then (Inst_Case or else No (Alias (Ent))) 12168 then 12169 return; 12170 end if; 12171 12172 -- Nothing to do for imported entities 12173 12174 if Is_Imported (Ent) then 12175 return; 12176 end if; 12177 12178 exit when Inst_Case or else No (Alias (Ent)); 12179 Ent := Alias (Ent); 12180 end loop; 12181 12182 Decl := Unit_Declaration_Node (Ent); 12183 12184 if Nkind (Decl) = N_Subprogram_Body then 12185 Body_Acts_As_Spec := True; 12186 12187 elsif Nkind_In (Decl, N_Subprogram_Declaration, 12188 N_Subprogram_Body_Stub) 12189 or else Inst_Case 12190 then 12191 Body_Acts_As_Spec := False; 12192 12193 -- If we have none of an instantiation, subprogram body or subprogram 12194 -- declaration, or in the SPARK case, a variable reference, then 12195 -- it is not a case that we want to check. (One case is a call to a 12196 -- generic formal subprogram, where we do not want the check in the 12197 -- template). 12198 12199 else 12200 return; 12201 end if; 12202 end if; 12203 12204 E_Scope := Ent; 12205 loop 12206 if Elaboration_Checks_Suppressed (E_Scope) 12207 or else Suppress_Elaboration_Warnings (E_Scope) 12208 then 12209 Cunit_SC := True; 12210 end if; 12211 12212 -- Exit when we get to compilation unit, not counting subunits 12213 12214 exit when Is_Compilation_Unit (E_Scope) 12215 and then (Is_Child_Unit (E_Scope) 12216 or else Scope (E_Scope) = Standard_Standard); 12217 12218 pragma Assert (E_Scope /= Standard_Standard); 12219 12220 -- Move up a scope looking for compilation unit 12221 12222 E_Scope := Scope (E_Scope); 12223 end loop; 12224 12225 -- No checks needed for pure or preelaborated compilation units 12226 12227 if Is_Pure (E_Scope) or else Is_Preelaborated (E_Scope) then 12228 return; 12229 end if; 12230 12231 -- If the generic entity is within a deeper instance than we are, then 12232 -- either the instantiation to which we refer itself caused an ABE, in 12233 -- which case that will be handled separately, or else we know that the 12234 -- body we need appears as needed at the point of the instantiation. 12235 -- However, this assumption is only valid if we are in static mode. 12236 12237 if not Dynamic_Elaboration_Checks 12238 and then 12239 Instantiation_Depth (Sloc (Ent)) > Instantiation_Depth (Sloc (N)) 12240 then 12241 return; 12242 end if; 12243 12244 -- Do not give a warning for a package with no body 12245 12246 if Ekind (Ent) = E_Generic_Package and then not Has_Generic_Body (N) then 12247 return; 12248 end if; 12249 12250 -- Case of entity is in same unit as call or instantiation. In the 12251 -- instantiation case, W_Scope may be different from E_Scope; we want 12252 -- the unit in which the instantiation occurs, since we're analyzing 12253 -- based on the expansion. 12254 12255 if W_Scope = C_Scope then 12256 if not Inter_Unit_Only then 12257 Check_Internal_Call (N, Ent, Outer_Scope, E); 12258 end if; 12259 12260 return; 12261 end if; 12262 12263 -- Case of entity is not in current unit (i.e. with'ed unit case) 12264 12265 -- We are only interested in such calls if the outer call was from 12266 -- elaboration code, or if we are in Dynamic_Elaboration_Checks mode. 12267 12268 if not From_Elab_Code and then not Dynamic_Elaboration_Checks then 12269 return; 12270 end if; 12271 12272 -- Nothing to do if some scope said that no checks were required 12273 12274 if Cunit_SC then 12275 return; 12276 end if; 12277 12278 -- Nothing to do for a generic instance, because a call to an instance 12279 -- cannot fail the elaboration check, because the body of the instance 12280 -- is always elaborated immediately after the spec. 12281 12282 if Call_To_Instance_From_Outside (Ent) then 12283 return; 12284 end if; 12285 12286 -- Nothing to do if subprogram with no separate spec. However, a call 12287 -- to Deep_Initialize may result in a call to a user-defined Initialize 12288 -- procedure, which imposes a body dependency. This happens only if the 12289 -- type is controlled and the Initialize procedure is not inherited. 12290 12291 if Body_Acts_As_Spec then 12292 if Is_TSS (Ent, TSS_Deep_Initialize) then 12293 declare 12294 Typ : constant Entity_Id := Etype (First_Formal (Ent)); 12295 Init : Entity_Id; 12296 12297 begin 12298 if not Is_Controlled (Typ) then 12299 return; 12300 else 12301 Init := Find_Prim_Op (Typ, Name_Initialize); 12302 12303 if Comes_From_Source (Init) then 12304 Ent := Init; 12305 else 12306 return; 12307 end if; 12308 end if; 12309 end; 12310 12311 else 12312 return; 12313 end if; 12314 end if; 12315 12316 -- Check cases of internal units 12317 12318 Callee_Unit_Internal := In_Internal_Unit (E_Scope); 12319 12320 -- Do not give a warning if the with'ed unit is internal and this is 12321 -- the generic instantiation case (this saves a lot of hassle dealing 12322 -- with the Text_IO special child units) 12323 12324 if Callee_Unit_Internal and Inst_Case then 12325 return; 12326 end if; 12327 12328 if C_Scope = Standard_Standard then 12329 Caller_Unit_Internal := False; 12330 else 12331 Caller_Unit_Internal := In_Internal_Unit (C_Scope); 12332 end if; 12333 12334 -- Do not give a warning if the with'ed unit is internal and the caller 12335 -- is not internal (since the binder always elaborates internal units 12336 -- first). 12337 12338 if Callee_Unit_Internal and not Caller_Unit_Internal then 12339 return; 12340 end if; 12341 12342 -- For now, if debug flag -gnatdE is not set, do no checking for one 12343 -- internal unit withing another. This fixes the problem with the sgi 12344 -- build and storage errors. To be resolved later ??? 12345 12346 if (Callee_Unit_Internal and Caller_Unit_Internal) 12347 and not Debug_Flag_EE 12348 then 12349 return; 12350 end if; 12351 12352 if Is_TSS (E, TSS_Deep_Initialize) then 12353 Ent := E; 12354 end if; 12355 12356 -- If the call is in an instance, and the called entity is not 12357 -- defined in the same instance, then the elaboration issue focuses 12358 -- around the unit containing the template, it is this unit that 12359 -- requires an Elaborate_All. 12360 12361 -- However, if we are doing dynamic elaboration, we need to chase the 12362 -- call in the usual manner. 12363 12364 -- We also need to chase the call in the usual manner if it is a call 12365 -- to a generic formal parameter, since that case was not handled as 12366 -- part of the processing of the template. 12367 12368 Inst_Caller := Instantiation (Get_Source_File_Index (Sloc (N))); 12369 Inst_Callee := Instantiation (Get_Source_File_Index (Sloc (Ent))); 12370 12371 if Inst_Caller = No_Location then 12372 Unit_Caller := No_Unit; 12373 else 12374 Unit_Caller := Get_Source_Unit (N); 12375 end if; 12376 12377 if Inst_Callee = No_Location then 12378 Unit_Callee := No_Unit; 12379 else 12380 Unit_Callee := Get_Source_Unit (Ent); 12381 end if; 12382 12383 if Unit_Caller /= No_Unit 12384 and then Unit_Callee /= Unit_Caller 12385 and then not Dynamic_Elaboration_Checks 12386 and then not Is_Call_Of_Generic_Formal (N) 12387 then 12388 E_Scope := Spec_Entity (Cunit_Entity (Unit_Caller)); 12389 12390 -- If we don't get a spec entity, just ignore call. Not quite 12391 -- clear why this check is necessary. ??? 12392 12393 if No (E_Scope) then 12394 return; 12395 end if; 12396 12397 -- Otherwise step to enclosing compilation unit 12398 12399 while not Is_Compilation_Unit (E_Scope) loop 12400 E_Scope := Scope (E_Scope); 12401 end loop; 12402 12403 -- For the case where N is not an instance, and is not a call within 12404 -- instance to other than a generic formal, we recompute E_Scope 12405 -- for the error message, since we do NOT want to go to the unit 12406 -- that has the ultimate declaration in the case of renaming and 12407 -- derivation and we also want to go to the generic unit in the 12408 -- case of an instance, and no further. 12409 12410 else 12411 -- Loop to carefully follow renamings and derivations one step 12412 -- outside the current unit, but not further. 12413 12414 if not (Inst_Case or Variable_Case) 12415 and then Present (Alias (Ent)) 12416 then 12417 E_Scope := Alias (Ent); 12418 else 12419 E_Scope := Ent; 12420 end if; 12421 12422 loop 12423 while not Is_Compilation_Unit (E_Scope) loop 12424 E_Scope := Scope (E_Scope); 12425 end loop; 12426 12427 -- If E_Scope is the same as C_Scope, it means that there 12428 -- definitely was a local renaming or derivation, and we 12429 -- are not yet out of the current unit. 12430 12431 exit when E_Scope /= C_Scope; 12432 Ent := Alias (Ent); 12433 E_Scope := Ent; 12434 12435 -- If no alias, there could be a previous error, but not if we've 12436 -- already reached the outermost level (Standard). 12437 12438 if No (Ent) then 12439 return; 12440 end if; 12441 end loop; 12442 end if; 12443 12444 if Within_Elaborate_All (Current_Sem_Unit, E_Scope) then 12445 return; 12446 end if; 12447 12448 -- Determine whether the Default_Initial_Condition procedure of some 12449 -- type is being invoked. 12450 12451 Is_DIC := Ekind (Ent) = E_Procedure and then Is_DIC_Procedure (Ent); 12452 12453 -- Checks related to Default_Initial_Condition fall under the SPARK 12454 -- umbrella because this is a SPARK-specific annotation. 12455 12456 SPARK_Elab_Errors := 12457 SPARK_Mode = On and (Is_DIC or Dynamic_Elaboration_Checks); 12458 12459 -- Now check if an Elaborate_All (or dynamic check) is needed 12460 12461 if (Elab_Info_Messages or Elab_Warnings or SPARK_Elab_Errors) 12462 and then Generate_Warnings 12463 and then not Suppress_Elaboration_Warnings (Ent) 12464 and then not Elaboration_Checks_Suppressed (Ent) 12465 and then not Suppress_Elaboration_Warnings (E_Scope) 12466 and then not Elaboration_Checks_Suppressed (E_Scope) 12467 then 12468 -- Instantiation case 12469 12470 if Inst_Case then 12471 if Comes_From_Source (Ent) and then SPARK_Elab_Errors then 12472 Error_Msg_NE 12473 ("instantiation of & during elaboration in SPARK", N, Ent); 12474 else 12475 Elab_Warning 12476 ("instantiation of & may raise Program_Error?l?", 12477 "info: instantiation of & during elaboration?$?", Ent); 12478 end if; 12479 12480 -- Indirect call case, info message only in static elaboration 12481 -- case, because the attribute reference itself cannot raise an 12482 -- exception. Note that SPARK does not permit indirect calls. 12483 12484 elsif Access_Case then 12485 Elab_Warning ("", "info: access to & during elaboration?$?", Ent); 12486 12487 -- Variable reference in SPARK mode 12488 12489 elsif Variable_Case then 12490 if Comes_From_Source (Ent) and then SPARK_Elab_Errors then 12491 Error_Msg_NE 12492 ("reference to & during elaboration in SPARK", N, Ent); 12493 end if; 12494 12495 -- Subprogram call case 12496 12497 else 12498 if Nkind (Name (N)) in N_Has_Entity 12499 and then Is_Init_Proc (Entity (Name (N))) 12500 and then Comes_From_Source (Ent) 12501 then 12502 Elab_Warning 12503 ("implicit call to & may raise Program_Error?l?", 12504 "info: implicit call to & during elaboration?$?", 12505 Ent); 12506 12507 elsif SPARK_Elab_Errors then 12508 12509 -- Emit a specialized error message when the elaboration of an 12510 -- object of a private type evaluates the expression of pragma 12511 -- Default_Initial_Condition. This prevents the internal name 12512 -- of the procedure from appearing in the error message. 12513 12514 if Is_DIC then 12515 Error_Msg_N 12516 ("call to Default_Initial_Condition during elaboration in " 12517 & "SPARK", N); 12518 else 12519 Error_Msg_NE 12520 ("call to & during elaboration in SPARK", N, Ent); 12521 end if; 12522 12523 else 12524 Elab_Warning 12525 ("call to & may raise Program_Error?l?", 12526 "info: call to & during elaboration?$?", 12527 Ent); 12528 end if; 12529 end if; 12530 12531 Error_Msg_Qual_Level := Nat'Last; 12532 12533 -- Case of Elaborate_All not present and required, for SPARK this 12534 -- is an error, so give an error message. 12535 12536 if SPARK_Elab_Errors then 12537 Error_Msg_NE -- CODEFIX 12538 ("\Elaborate_All pragma required for&", N, W_Scope); 12539 12540 -- Otherwise we generate an implicit pragma. For a subprogram 12541 -- instantiation, Elaborate is good enough, since no transitive 12542 -- call is possible at elaboration time in this case. 12543 12544 elsif Nkind (N) in N_Subprogram_Instantiation then 12545 Elab_Warning 12546 ("\missing pragma Elaborate for&?l?", 12547 "\implicit pragma Elaborate for& generated?$?", 12548 W_Scope); 12549 12550 -- For all other cases, we need an implicit Elaborate_All 12551 12552 else 12553 Elab_Warning 12554 ("\missing pragma Elaborate_All for&?l?", 12555 "\implicit pragma Elaborate_All for & generated?$?", 12556 W_Scope); 12557 end if; 12558 12559 Error_Msg_Qual_Level := 0; 12560 12561 -- Take into account the flags related to elaboration warning 12562 -- messages when enumerating the various calls involved. This 12563 -- ensures the proper pairing of the main warning and the 12564 -- clarification messages generated by Output_Calls. 12565 12566 Output_Calls (N, Check_Elab_Flag => True); 12567 12568 -- Set flag to prevent further warnings for same unit unless in 12569 -- All_Errors_Mode. 12570 12571 if not All_Errors_Mode and not Dynamic_Elaboration_Checks then 12572 Set_Suppress_Elaboration_Warnings (W_Scope); 12573 end if; 12574 end if; 12575 12576 -- Check for runtime elaboration check required 12577 12578 if Dynamic_Elaboration_Checks then 12579 if not Elaboration_Checks_Suppressed (Ent) 12580 and then not Elaboration_Checks_Suppressed (W_Scope) 12581 and then not Elaboration_Checks_Suppressed (E_Scope) 12582 and then not Cunit_SC 12583 then 12584 -- Runtime elaboration check required. Generate check of the 12585 -- elaboration Boolean for the unit containing the entity. 12586 12587 -- Note that for this case, we do check the real unit (the one 12588 -- from following renamings, since that is the issue). 12589 12590 -- Could this possibly miss a useless but required PE??? 12591 12592 Insert_Elab_Check (N, 12593 Make_Attribute_Reference (Loc, 12594 Attribute_Name => Name_Elaborated, 12595 Prefix => 12596 New_Occurrence_Of (Spec_Entity (E_Scope), Loc))); 12597 12598 -- Prevent duplicate elaboration checks on the same call, which 12599 -- can happen if the body enclosing the call appears itself in a 12600 -- call whose elaboration check is delayed. 12601 12602 if Nkind (N) in N_Subprogram_Call then 12603 Set_No_Elaboration_Check (N); 12604 end if; 12605 end if; 12606 12607 -- Case of static elaboration model 12608 12609 else 12610 -- Do not do anything if elaboration checks suppressed. Note that 12611 -- we check Ent here, not E, since we want the real entity for the 12612 -- body to see if checks are suppressed for it, not the dummy 12613 -- entry for renamings or derivations. 12614 12615 if Elaboration_Checks_Suppressed (Ent) 12616 or else Elaboration_Checks_Suppressed (E_Scope) 12617 or else Elaboration_Checks_Suppressed (W_Scope) 12618 then 12619 null; 12620 12621 -- Do not generate an Elaborate_All for finalization routines 12622 -- that perform partial clean up as part of initialization. 12623 12624 elsif In_Init_Proc and then Is_Finalization_Procedure (Ent) then 12625 null; 12626 12627 -- Here we need to generate an implicit elaborate all 12628 12629 else 12630 -- Generate Elaborate_All warning unless suppressed 12631 12632 if (Elab_Info_Messages and Generate_Warnings and not Inst_Case) 12633 and then not Suppress_Elaboration_Warnings (Ent) 12634 and then not Suppress_Elaboration_Warnings (E_Scope) 12635 and then not Suppress_Elaboration_Warnings (W_Scope) 12636 then 12637 Error_Msg_Node_2 := W_Scope; 12638 Error_Msg_NE 12639 ("info: call to& in elaboration code requires pragma " 12640 & "Elaborate_All on&?$?", N, E); 12641 end if; 12642 12643 -- Set indication for binder to generate Elaborate_All 12644 12645 Set_Elaboration_Constraint (N, E, W_Scope); 12646 end if; 12647 end if; 12648 end Check_A_Call; 12649 12650 ----------------------------- 12651 -- Check_Bad_Instantiation -- 12652 ----------------------------- 12653 12654 procedure Check_Bad_Instantiation (N : Node_Id) is 12655 Ent : Entity_Id; 12656 12657 begin 12658 -- Nothing to do if we do not have an instantiation (happens in some 12659 -- error cases, and also in the formal package declaration case) 12660 12661 if Nkind (N) not in N_Generic_Instantiation then 12662 return; 12663 12664 -- Nothing to do if serious errors detected (avoid cascaded errors) 12665 12666 elsif Serious_Errors_Detected /= 0 then 12667 return; 12668 12669 -- Nothing to do if not in full analysis mode 12670 12671 elsif not Full_Analysis then 12672 return; 12673 12674 -- Nothing to do if inside a generic template 12675 12676 elsif Inside_A_Generic then 12677 return; 12678 12679 -- Nothing to do if a library level instantiation 12680 12681 elsif Nkind (Parent (N)) = N_Compilation_Unit then 12682 return; 12683 12684 -- Nothing to do if we are compiling a proper body for semantic 12685 -- purposes only. The generic body may be in another proper body. 12686 12687 elsif 12688 Nkind (Parent (Unit_Declaration_Node (Main_Unit_Entity))) = N_Subunit 12689 then 12690 return; 12691 end if; 12692 12693 Ent := Get_Generic_Entity (N); 12694 12695 -- The case we are interested in is when the generic spec is in the 12696 -- current declarative part 12697 12698 if not Same_Elaboration_Scope (Current_Scope, Scope (Ent)) 12699 or else not In_Same_Extended_Unit (N, Ent) 12700 then 12701 return; 12702 end if; 12703 12704 -- If the generic entity is within a deeper instance than we are, then 12705 -- either the instantiation to which we refer itself caused an ABE, in 12706 -- which case that will be handled separately. Otherwise, we know that 12707 -- the body we need appears as needed at the point of the instantiation. 12708 -- If they are both at the same level but not within the same instance 12709 -- then the body of the generic will be in the earlier instance. 12710 12711 declare 12712 D1 : constant Nat := Instantiation_Depth (Sloc (Ent)); 12713 D2 : constant Nat := Instantiation_Depth (Sloc (N)); 12714 12715 begin 12716 if D1 > D2 then 12717 return; 12718 12719 elsif D1 = D2 12720 and then Is_Generic_Instance (Scope (Ent)) 12721 and then not In_Open_Scopes (Scope (Ent)) 12722 then 12723 return; 12724 end if; 12725 end; 12726 12727 -- Now we can proceed, if the entity being called has a completion, 12728 -- then we are definitely OK, since we have already seen the body. 12729 12730 if Has_Completion (Ent) then 12731 return; 12732 end if; 12733 12734 -- If there is no body, then nothing to do 12735 12736 if not Has_Generic_Body (N) then 12737 return; 12738 end if; 12739 12740 -- Here we definitely have a bad instantiation 12741 12742 Error_Msg_Warn := SPARK_Mode /= On; 12743 Error_Msg_NE ("cannot instantiate& before body seen<<", N, Ent); 12744 Error_Msg_N ("\Program_Error [<<", N); 12745 12746 Insert_Elab_Check (N); 12747 Set_Is_Known_Guaranteed_ABE (N); 12748 end Check_Bad_Instantiation; 12749 12750 --------------------- 12751 -- Check_Elab_Call -- 12752 --------------------- 12753 12754 procedure Check_Elab_Call 12755 (N : Node_Id; 12756 Outer_Scope : Entity_Id := Empty; 12757 In_Init_Proc : Boolean := False) 12758 is 12759 Ent : Entity_Id; 12760 P : Node_Id; 12761 12762 begin 12763 pragma Assert (Legacy_Elaboration_Checks); 12764 12765 -- If the reference is not in the main unit, there is nothing to check. 12766 -- Elaboration call from units in the context of the main unit will lead 12767 -- to semantic dependencies when those units are compiled. 12768 12769 if not In_Extended_Main_Code_Unit (N) then 12770 return; 12771 end if; 12772 12773 -- For an entry call, check relevant restriction 12774 12775 if Nkind (N) = N_Entry_Call_Statement 12776 and then not In_Subprogram_Or_Concurrent_Unit 12777 then 12778 Check_Restriction (No_Entry_Calls_In_Elaboration_Code, N); 12779 12780 -- Nothing to do if this is not an expected type of reference (happens 12781 -- in some error conditions, and in some cases where rewriting occurs). 12782 12783 elsif Nkind (N) not in N_Subprogram_Call 12784 and then Nkind (N) /= N_Attribute_Reference 12785 and then (SPARK_Mode /= On 12786 or else Nkind (N) not in N_Has_Entity 12787 or else No (Entity (N)) 12788 or else Ekind (Entity (N)) /= E_Variable) 12789 then 12790 return; 12791 12792 -- Nothing to do if this is a call already rewritten for elab checking. 12793 -- Such calls appear as the targets of If_Expressions. 12794 12795 -- This check MUST be wrong, it catches far too much 12796 12797 elsif Nkind (Parent (N)) = N_If_Expression then 12798 return; 12799 12800 -- Nothing to do if inside a generic template 12801 12802 elsif Inside_A_Generic 12803 and then No (Enclosing_Generic_Body (N)) 12804 then 12805 return; 12806 12807 -- Nothing to do if call is being preanalyzed, as when within a 12808 -- pre/postcondition, a predicate, or an invariant. 12809 12810 elsif In_Spec_Expression then 12811 return; 12812 end if; 12813 12814 -- Nothing to do if this is a call to a postcondition, which is always 12815 -- within a subprogram body, even though the current scope may be the 12816 -- enclosing scope of the subprogram. 12817 12818 if Nkind (N) = N_Procedure_Call_Statement 12819 and then Is_Entity_Name (Name (N)) 12820 and then Chars (Entity (Name (N))) = Name_uPostconditions 12821 then 12822 return; 12823 end if; 12824 12825 -- Here we have a reference at elaboration time that must be checked 12826 12827 if Debug_Flag_Underscore_LL then 12828 Write_Str (" Check_Elab_Ref: "); 12829 12830 if Nkind (N) = N_Attribute_Reference then 12831 if not Is_Entity_Name (Prefix (N)) then 12832 Write_Str ("<<not entity name>>"); 12833 else 12834 Write_Name (Chars (Entity (Prefix (N)))); 12835 end if; 12836 12837 Write_Str ("'Access"); 12838 12839 elsif No (Name (N)) or else not Is_Entity_Name (Name (N)) then 12840 Write_Str ("<<not entity name>> "); 12841 12842 else 12843 Write_Name (Chars (Entity (Name (N)))); 12844 end if; 12845 12846 Write_Str (" reference at "); 12847 Write_Location (Sloc (N)); 12848 Write_Eol; 12849 end if; 12850 12851 -- Climb up the tree to make sure we are not inside default expression 12852 -- of a parameter specification or a record component, since in both 12853 -- these cases, we will be doing the actual reference later, not now, 12854 -- and it is at the time of the actual reference (statically speaking) 12855 -- that we must do our static check, not at the time of its initial 12856 -- analysis). 12857 12858 -- However, we have to check references within component definitions 12859 -- (e.g. a function call that determines an array component bound), 12860 -- so we terminate the loop in that case. 12861 12862 P := Parent (N); 12863 while Present (P) loop 12864 if Nkind_In (P, N_Parameter_Specification, 12865 N_Component_Declaration) 12866 then 12867 return; 12868 12869 -- The reference occurs within the constraint of a component, 12870 -- so it must be checked. 12871 12872 elsif Nkind (P) = N_Component_Definition then 12873 exit; 12874 12875 else 12876 P := Parent (P); 12877 end if; 12878 end loop; 12879 12880 -- Stuff that happens only at the outer level 12881 12882 if No (Outer_Scope) then 12883 Elab_Visited.Set_Last (0); 12884 12885 -- Nothing to do if current scope is Standard (this is a bit odd, but 12886 -- it happens in the case of generic instantiations). 12887 12888 C_Scope := Current_Scope; 12889 12890 if C_Scope = Standard_Standard then 12891 return; 12892 end if; 12893 12894 -- First case, we are in elaboration code 12895 12896 From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit; 12897 12898 if From_Elab_Code then 12899 12900 -- Complain if ref that comes from source in preelaborated unit 12901 -- and we are not inside a subprogram (i.e. we are in elab code). 12902 12903 if Comes_From_Source (N) 12904 and then In_Preelaborated_Unit 12905 and then not In_Inlined_Body 12906 and then Nkind (N) /= N_Attribute_Reference 12907 then 12908 -- This is a warning in GNAT mode allowing such calls to be 12909 -- used in the predefined library with appropriate care. 12910 12911 Error_Msg_Warn := GNAT_Mode; 12912 Error_Msg_N 12913 ("<<non-static call not allowed in preelaborated unit", N); 12914 return; 12915 end if; 12916 12917 -- Second case, we are inside a subprogram or concurrent unit, which 12918 -- means we are not in elaboration code. 12919 12920 else 12921 -- In this case, the issue is whether we are inside the 12922 -- declarative part of the unit in which we live, or inside its 12923 -- statements. In the latter case, there is no issue of ABE calls 12924 -- at this level (a call from outside to the unit in which we live 12925 -- might cause an ABE, but that will be detected when we analyze 12926 -- that outer level call, as it recurses into the called unit). 12927 12928 -- Climb up the tree, doing this test, and also testing for being 12929 -- inside a default expression, which, as discussed above, is not 12930 -- checked at this stage. 12931 12932 declare 12933 P : Node_Id; 12934 L : List_Id; 12935 12936 begin 12937 P := N; 12938 loop 12939 -- If we find a parentless subtree, it seems safe to assume 12940 -- that we are not in a declarative part and that no 12941 -- checking is required. 12942 12943 if No (P) then 12944 return; 12945 end if; 12946 12947 if Is_List_Member (P) then 12948 L := List_Containing (P); 12949 P := Parent (L); 12950 else 12951 L := No_List; 12952 P := Parent (P); 12953 end if; 12954 12955 exit when Nkind (P) = N_Subunit; 12956 12957 -- Filter out case of default expressions, where we do not 12958 -- do the check at this stage. 12959 12960 if Nkind_In (P, N_Parameter_Specification, 12961 N_Component_Declaration) 12962 then 12963 return; 12964 end if; 12965 12966 -- A protected body has no elaboration code and contains 12967 -- only other bodies. 12968 12969 if Nkind (P) = N_Protected_Body then 12970 return; 12971 12972 elsif Nkind_In (P, N_Subprogram_Body, 12973 N_Task_Body, 12974 N_Block_Statement, 12975 N_Entry_Body) 12976 then 12977 if L = Declarations (P) then 12978 exit; 12979 12980 -- We are not in elaboration code, but we are doing 12981 -- dynamic elaboration checks, in this case, we still 12982 -- need to do the reference, since the subprogram we are 12983 -- in could be called from another unit, also in dynamic 12984 -- elaboration check mode, at elaboration time. 12985 12986 elsif Dynamic_Elaboration_Checks then 12987 12988 -- We provide a debug flag to disable this check. That 12989 -- way we have an easy work around for regressions 12990 -- that are caused by this new check. This debug flag 12991 -- can be removed later. 12992 12993 if Debug_Flag_DD then 12994 return; 12995 end if; 12996 12997 -- Do the check in this case 12998 12999 exit; 13000 13001 elsif Nkind (P) = N_Task_Body then 13002 13003 -- The check is deferred until Check_Task_Activation 13004 -- but we need to capture local suppress pragmas 13005 -- that may inhibit checks on this call. 13006 13007 Ent := Get_Referenced_Ent (N); 13008 13009 if No (Ent) then 13010 return; 13011 13012 elsif Elaboration_Checks_Suppressed (Current_Scope) 13013 or else Elaboration_Checks_Suppressed (Ent) 13014 or else Elaboration_Checks_Suppressed (Scope (Ent)) 13015 then 13016 if Nkind (N) in N_Subprogram_Call then 13017 Set_No_Elaboration_Check (N); 13018 end if; 13019 end if; 13020 13021 return; 13022 13023 -- Static model, call is not in elaboration code, we 13024 -- never need to worry, because in the static model the 13025 -- top-level caller always takes care of things. 13026 13027 else 13028 return; 13029 end if; 13030 end if; 13031 end loop; 13032 end; 13033 end if; 13034 end if; 13035 13036 Ent := Get_Referenced_Ent (N); 13037 13038 if No (Ent) then 13039 return; 13040 end if; 13041 13042 -- Determine whether a prior call to the same subprogram was already 13043 -- examined within the same context. If this is the case, then there is 13044 -- no need to proceed with the various warnings and checks because the 13045 -- work was already done for the previous call. 13046 13047 declare 13048 Self : constant Visited_Element := 13049 (Subp_Id => Ent, Context => Parent (N)); 13050 13051 begin 13052 for Index in 1 .. Elab_Visited.Last loop 13053 if Self = Elab_Visited.Table (Index) then 13054 return; 13055 end if; 13056 end loop; 13057 end; 13058 13059 -- See if we need to analyze this reference. We analyze it if either of 13060 -- the following conditions is met: 13061 13062 -- It is an inner level call (since in this case it was triggered 13063 -- by an outer level call from elaboration code), but only if the 13064 -- call is within the scope of the original outer level call. 13065 13066 -- It is an outer level reference from elaboration code, or a call to 13067 -- an entity is in the same elaboration scope. 13068 13069 -- And in these cases, we will check both inter-unit calls and 13070 -- intra-unit (within a single unit) calls. 13071 13072 C_Scope := Current_Scope; 13073 13074 -- If not outer level reference, then we follow it if it is within the 13075 -- original scope of the outer reference. 13076 13077 if Present (Outer_Scope) 13078 and then Within (Scope (Ent), Outer_Scope) 13079 then 13080 Set_C_Scope; 13081 Check_A_Call 13082 (N => N, 13083 E => Ent, 13084 Outer_Scope => Outer_Scope, 13085 Inter_Unit_Only => False, 13086 In_Init_Proc => In_Init_Proc); 13087 13088 -- Nothing to do if elaboration checks suppressed for this scope. 13089 -- However, an interesting exception, the fact that elaboration checks 13090 -- are suppressed within an instance (because we can trace the body when 13091 -- we process the template) does not extend to calls to generic formal 13092 -- subprograms. 13093 13094 elsif Elaboration_Checks_Suppressed (Current_Scope) 13095 and then not Is_Call_Of_Generic_Formal (N) 13096 then 13097 null; 13098 13099 elsif From_Elab_Code then 13100 Set_C_Scope; 13101 Check_A_Call (N, Ent, Standard_Standard, Inter_Unit_Only => False); 13102 13103 elsif Same_Elaboration_Scope (C_Scope, Scope (Ent)) then 13104 Set_C_Scope; 13105 Check_A_Call (N, Ent, Scope (Ent), Inter_Unit_Only => False); 13106 13107 -- If none of those cases holds, but Dynamic_Elaboration_Checks mode 13108 -- is set, then we will do the check, but only in the inter-unit case 13109 -- (this is to accommodate unguarded elaboration calls from other units 13110 -- in which this same mode is set). We don't want warnings in this case, 13111 -- it would generate warnings having nothing to do with elaboration. 13112 13113 elsif Dynamic_Elaboration_Checks then 13114 Set_C_Scope; 13115 Check_A_Call 13116 (N, 13117 Ent, 13118 Standard_Standard, 13119 Inter_Unit_Only => True, 13120 Generate_Warnings => False); 13121 13122 -- Otherwise nothing to do 13123 13124 else 13125 return; 13126 end if; 13127 13128 -- A call to an Init_Proc in elaboration code may bring additional 13129 -- dependencies, if some of the record components thereof have 13130 -- initializations that are function calls that come from source. We 13131 -- treat the current node as a call to each of these functions, to check 13132 -- their elaboration impact. 13133 13134 if Is_Init_Proc (Ent) and then From_Elab_Code then 13135 Process_Init_Proc : declare 13136 Unit_Decl : constant Node_Id := Unit_Declaration_Node (Ent); 13137 13138 function Check_Init_Call (Nod : Node_Id) return Traverse_Result; 13139 -- Find subprogram calls within body of Init_Proc for Traverse 13140 -- instantiation below. 13141 13142 procedure Traverse_Body is new Traverse_Proc (Check_Init_Call); 13143 -- Traversal procedure to find all calls with body of Init_Proc 13144 13145 --------------------- 13146 -- Check_Init_Call -- 13147 --------------------- 13148 13149 function Check_Init_Call (Nod : Node_Id) return Traverse_Result is 13150 Func : Entity_Id; 13151 13152 begin 13153 if Nkind (Nod) in N_Subprogram_Call 13154 and then Is_Entity_Name (Name (Nod)) 13155 then 13156 Func := Entity (Name (Nod)); 13157 13158 if Comes_From_Source (Func) then 13159 Check_A_Call 13160 (N, Func, Standard_Standard, Inter_Unit_Only => True); 13161 end if; 13162 13163 return OK; 13164 13165 else 13166 return OK; 13167 end if; 13168 end Check_Init_Call; 13169 13170 -- Start of processing for Process_Init_Proc 13171 13172 begin 13173 if Nkind (Unit_Decl) = N_Subprogram_Body then 13174 Traverse_Body (Handled_Statement_Sequence (Unit_Decl)); 13175 end if; 13176 end Process_Init_Proc; 13177 end if; 13178 end Check_Elab_Call; 13179 13180 ----------------------- 13181 -- Check_Elab_Assign -- 13182 ----------------------- 13183 13184 procedure Check_Elab_Assign (N : Node_Id) is 13185 Ent : Entity_Id; 13186 Scop : Entity_Id; 13187 13188 Pkg_Spec : Entity_Id; 13189 Pkg_Body : Entity_Id; 13190 13191 begin 13192 pragma Assert (Legacy_Elaboration_Checks); 13193 13194 -- For record or array component, check prefix. If it is an access type, 13195 -- then there is nothing to do (we do not know what is being assigned), 13196 -- but otherwise this is an assignment to the prefix. 13197 13198 if Nkind_In (N, N_Indexed_Component, 13199 N_Selected_Component, 13200 N_Slice) 13201 then 13202 if not Is_Access_Type (Etype (Prefix (N))) then 13203 Check_Elab_Assign (Prefix (N)); 13204 end if; 13205 13206 return; 13207 end if; 13208 13209 -- For type conversion, check expression 13210 13211 if Nkind (N) = N_Type_Conversion then 13212 Check_Elab_Assign (Expression (N)); 13213 return; 13214 end if; 13215 13216 -- Nothing to do if this is not an entity reference otherwise get entity 13217 13218 if Is_Entity_Name (N) then 13219 Ent := Entity (N); 13220 else 13221 return; 13222 end if; 13223 13224 -- What we are looking for is a reference in the body of a package that 13225 -- modifies a variable declared in the visible part of the package spec. 13226 13227 if Present (Ent) 13228 and then Comes_From_Source (N) 13229 and then not Suppress_Elaboration_Warnings (Ent) 13230 and then Ekind (Ent) = E_Variable 13231 and then not In_Private_Part (Ent) 13232 and then Is_Library_Level_Entity (Ent) 13233 then 13234 Scop := Current_Scope; 13235 loop 13236 if No (Scop) or else Scop = Standard_Standard then 13237 return; 13238 elsif Ekind (Scop) = E_Package 13239 and then Is_Compilation_Unit (Scop) 13240 then 13241 exit; 13242 else 13243 Scop := Scope (Scop); 13244 end if; 13245 end loop; 13246 13247 -- Here Scop points to the containing library package 13248 13249 Pkg_Spec := Scop; 13250 Pkg_Body := Body_Entity (Pkg_Spec); 13251 13252 -- All OK if the package has an Elaborate_Body pragma 13253 13254 if Has_Pragma_Elaborate_Body (Scop) then 13255 return; 13256 end if; 13257 13258 -- OK if entity being modified is not in containing package spec 13259 13260 if not In_Same_Source_Unit (Scop, Ent) then 13261 return; 13262 end if; 13263 13264 -- All OK if entity appears in generic package or generic instance. 13265 -- We just get too messed up trying to give proper warnings in the 13266 -- presence of generics. Better no message than a junk one. 13267 13268 Scop := Scope (Ent); 13269 while Present (Scop) and then Scop /= Pkg_Spec loop 13270 if Ekind (Scop) = E_Generic_Package then 13271 return; 13272 elsif Ekind (Scop) = E_Package 13273 and then Is_Generic_Instance (Scop) 13274 then 13275 return; 13276 end if; 13277 13278 Scop := Scope (Scop); 13279 end loop; 13280 13281 -- All OK if in task, don't issue warnings there 13282 13283 if In_Task_Activation then 13284 return; 13285 end if; 13286 13287 -- OK if no package body 13288 13289 if No (Pkg_Body) then 13290 return; 13291 end if; 13292 13293 -- OK if reference is not in package body 13294 13295 if not In_Same_Source_Unit (Pkg_Body, N) then 13296 return; 13297 end if; 13298 13299 -- OK if package body has no handled statement sequence 13300 13301 declare 13302 HSS : constant Node_Id := 13303 Handled_Statement_Sequence (Declaration_Node (Pkg_Body)); 13304 begin 13305 if No (HSS) or else not Comes_From_Source (HSS) then 13306 return; 13307 end if; 13308 end; 13309 13310 -- We definitely have a case of a modification of an entity in 13311 -- the package spec from the elaboration code of the package body. 13312 -- We may not give the warning (because there are some additional 13313 -- checks to avoid too many false positives), but it would be a good 13314 -- idea for the binder to try to keep the body elaboration close to 13315 -- the spec elaboration. 13316 13317 Set_Elaborate_Body_Desirable (Pkg_Spec); 13318 13319 -- All OK in gnat mode (we know what we are doing) 13320 13321 if GNAT_Mode then 13322 return; 13323 end if; 13324 13325 -- All OK if all warnings suppressed 13326 13327 if Warning_Mode = Suppress then 13328 return; 13329 end if; 13330 13331 -- All OK if elaboration checks suppressed for entity 13332 13333 if Checks_May_Be_Suppressed (Ent) 13334 and then Is_Check_Suppressed (Ent, Elaboration_Check) 13335 then 13336 return; 13337 end if; 13338 13339 -- OK if the entity is initialized. Note that the No_Initialization 13340 -- flag usually means that the initialization has been rewritten into 13341 -- assignments, but that still counts for us. 13342 13343 declare 13344 Decl : constant Node_Id := Declaration_Node (Ent); 13345 begin 13346 if Nkind (Decl) = N_Object_Declaration 13347 and then (Present (Expression (Decl)) 13348 or else No_Initialization (Decl)) 13349 then 13350 return; 13351 end if; 13352 end; 13353 13354 -- Here is where we give the warning 13355 13356 -- All OK if warnings suppressed on the entity 13357 13358 if not Has_Warnings_Off (Ent) then 13359 Error_Msg_Sloc := Sloc (Ent); 13360 13361 Error_Msg_NE 13362 ("??& can be accessed by clients before this initialization", 13363 N, Ent); 13364 Error_Msg_NE 13365 ("\??add Elaborate_Body to spec to ensure & is initialized", 13366 N, Ent); 13367 end if; 13368 13369 if not All_Errors_Mode then 13370 Set_Suppress_Elaboration_Warnings (Ent); 13371 end if; 13372 end if; 13373 end Check_Elab_Assign; 13374 13375 ---------------------- 13376 -- Check_Elab_Calls -- 13377 ---------------------- 13378 13379 -- WARNING: This routine manages SPARK regions 13380 13381 procedure Check_Elab_Calls is 13382 Saved_SM : SPARK_Mode_Type; 13383 Saved_SMP : Node_Id; 13384 13385 begin 13386 pragma Assert (Legacy_Elaboration_Checks); 13387 13388 -- If expansion is disabled, do not generate any checks, unless we 13389 -- are in GNATprove mode, so that errors are issued in GNATprove for 13390 -- violations of static elaboration rules in SPARK code. Also skip 13391 -- checks if any subunits are missing because in either case we lack the 13392 -- full information that we need, and no object file will be created in 13393 -- any case. 13394 13395 if (not Expander_Active and not GNATprove_Mode) 13396 or else Is_Generic_Unit (Cunit_Entity (Main_Unit)) 13397 or else Subunits_Missing 13398 then 13399 return; 13400 end if; 13401 13402 -- Skip delayed calls if we had any errors 13403 13404 if Serious_Errors_Detected = 0 then 13405 Delaying_Elab_Checks := False; 13406 Expander_Mode_Save_And_Set (True); 13407 13408 for J in Delay_Check.First .. Delay_Check.Last loop 13409 Push_Scope (Delay_Check.Table (J).Curscop); 13410 From_Elab_Code := Delay_Check.Table (J).From_Elab_Code; 13411 In_Task_Activation := Delay_Check.Table (J).In_Task_Activation; 13412 13413 Saved_SM := SPARK_Mode; 13414 Saved_SMP := SPARK_Mode_Pragma; 13415 13416 -- Set appropriate value of SPARK_Mode 13417 13418 if Delay_Check.Table (J).From_SPARK_Code then 13419 SPARK_Mode := On; 13420 end if; 13421 13422 Check_Internal_Call_Continue 13423 (N => Delay_Check.Table (J).N, 13424 E => Delay_Check.Table (J).E, 13425 Outer_Scope => Delay_Check.Table (J).Outer_Scope, 13426 Orig_Ent => Delay_Check.Table (J).Orig_Ent); 13427 13428 Restore_SPARK_Mode (Saved_SM, Saved_SMP); 13429 Pop_Scope; 13430 end loop; 13431 13432 -- Set Delaying_Elab_Checks back on for next main compilation 13433 13434 Expander_Mode_Restore; 13435 Delaying_Elab_Checks := True; 13436 end if; 13437 end Check_Elab_Calls; 13438 13439 ------------------------------ 13440 -- Check_Elab_Instantiation -- 13441 ------------------------------ 13442 13443 procedure Check_Elab_Instantiation 13444 (N : Node_Id; 13445 Outer_Scope : Entity_Id := Empty) 13446 is 13447 Ent : Entity_Id; 13448 13449 begin 13450 pragma Assert (Legacy_Elaboration_Checks); 13451 13452 -- Check for and deal with bad instantiation case. There is some 13453 -- duplicated code here, but we will worry about this later ??? 13454 13455 Check_Bad_Instantiation (N); 13456 13457 if Is_Known_Guaranteed_ABE (N) then 13458 return; 13459 end if; 13460 13461 -- Nothing to do if we do not have an instantiation (happens in some 13462 -- error cases, and also in the formal package declaration case) 13463 13464 if Nkind (N) not in N_Generic_Instantiation then 13465 return; 13466 end if; 13467 13468 -- Nothing to do if inside a generic template 13469 13470 if Inside_A_Generic then 13471 return; 13472 end if; 13473 13474 -- Nothing to do if the instantiation is not in the main unit 13475 13476 if not In_Extended_Main_Code_Unit (N) then 13477 return; 13478 end if; 13479 13480 Ent := Get_Generic_Entity (N); 13481 From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit; 13482 13483 -- See if we need to analyze this instantiation. We analyze it if 13484 -- either of the following conditions is met: 13485 13486 -- It is an inner level instantiation (since in this case it was 13487 -- triggered by an outer level call from elaboration code), but 13488 -- only if the instantiation is within the scope of the original 13489 -- outer level call. 13490 13491 -- It is an outer level instantiation from elaboration code, or the 13492 -- instantiated entity is in the same elaboration scope. 13493 13494 -- And in these cases, we will check both the inter-unit case and 13495 -- the intra-unit (within a single unit) case. 13496 13497 C_Scope := Current_Scope; 13498 13499 if Present (Outer_Scope) and then Within (Scope (Ent), Outer_Scope) then 13500 Set_C_Scope; 13501 Check_A_Call (N, Ent, Outer_Scope, Inter_Unit_Only => False); 13502 13503 elsif From_Elab_Code then 13504 Set_C_Scope; 13505 Check_A_Call (N, Ent, Standard_Standard, Inter_Unit_Only => False); 13506 13507 elsif Same_Elaboration_Scope (C_Scope, Scope (Ent)) then 13508 Set_C_Scope; 13509 Check_A_Call (N, Ent, Scope (Ent), Inter_Unit_Only => False); 13510 13511 -- If none of those cases holds, but Dynamic_Elaboration_Checks mode is 13512 -- set, then we will do the check, but only in the inter-unit case (this 13513 -- is to accommodate unguarded elaboration calls from other units in 13514 -- which this same mode is set). We inhibit warnings in this case, since 13515 -- this instantiation is not occurring in elaboration code. 13516 13517 elsif Dynamic_Elaboration_Checks then 13518 Set_C_Scope; 13519 Check_A_Call 13520 (N, 13521 Ent, 13522 Standard_Standard, 13523 Inter_Unit_Only => True, 13524 Generate_Warnings => False); 13525 13526 else 13527 return; 13528 end if; 13529 end Check_Elab_Instantiation; 13530 13531 ------------------------- 13532 -- Check_Internal_Call -- 13533 ------------------------- 13534 13535 procedure Check_Internal_Call 13536 (N : Node_Id; 13537 E : Entity_Id; 13538 Outer_Scope : Entity_Id; 13539 Orig_Ent : Entity_Id) 13540 is 13541 function Within_Initial_Condition (Call : Node_Id) return Boolean; 13542 -- Determine whether call Call occurs within pragma Initial_Condition or 13543 -- pragma Check with check_kind set to Initial_Condition. 13544 13545 ------------------------------ 13546 -- Within_Initial_Condition -- 13547 ------------------------------ 13548 13549 function Within_Initial_Condition (Call : Node_Id) return Boolean is 13550 Args : List_Id; 13551 Nam : Name_Id; 13552 Par : Node_Id; 13553 13554 begin 13555 -- Traverse the parent chain looking for an enclosing pragma 13556 13557 Par := Call; 13558 while Present (Par) loop 13559 if Nkind (Par) = N_Pragma then 13560 Nam := Pragma_Name (Par); 13561 13562 -- Pragma Initial_Condition appears in its alternative from as 13563 -- Check (Initial_Condition, ...). 13564 13565 if Nam = Name_Check then 13566 Args := Pragma_Argument_Associations (Par); 13567 13568 -- Pragma Check should have at least two arguments 13569 13570 pragma Assert (Present (Args)); 13571 13572 return 13573 Chars (Expression (First (Args))) = Name_Initial_Condition; 13574 13575 -- Direct match 13576 13577 elsif Nam = Name_Initial_Condition then 13578 return True; 13579 13580 -- Since pragmas are never nested within other pragmas, stop 13581 -- the traversal. 13582 13583 else 13584 return False; 13585 end if; 13586 13587 -- Prevent the search from going too far 13588 13589 elsif Is_Body_Or_Package_Declaration (Par) then 13590 exit; 13591 end if; 13592 13593 Par := Parent (Par); 13594 13595 -- If assertions are not enabled, the check pragma is rewritten 13596 -- as an if_statement in sem_prag, to generate various warnings 13597 -- on boolean expressions. Retrieve the original pragma. 13598 13599 if Nkind (Original_Node (Par)) = N_Pragma then 13600 Par := Original_Node (Par); 13601 end if; 13602 end loop; 13603 13604 return False; 13605 end Within_Initial_Condition; 13606 13607 -- Local variables 13608 13609 Inst_Case : constant Boolean := Nkind (N) in N_Generic_Instantiation; 13610 13611 -- Start of processing for Check_Internal_Call 13612 13613 begin 13614 -- For P'Access, we want to warn if the -gnatw.f switch is set, and the 13615 -- node comes from source. 13616 13617 if Nkind (N) = N_Attribute_Reference 13618 and then ((not Warn_On_Elab_Access and then not Debug_Flag_Dot_O) 13619 or else not Comes_From_Source (N)) 13620 then 13621 return; 13622 13623 -- If not function or procedure call, instantiation, or 'Access, then 13624 -- ignore call (this happens in some error cases and rewriting cases). 13625 13626 elsif not Nkind_In (N, N_Attribute_Reference, 13627 N_Function_Call, 13628 N_Procedure_Call_Statement) 13629 and then not Inst_Case 13630 then 13631 return; 13632 13633 -- Nothing to do if this is a call or instantiation that has already 13634 -- been found to be a sure ABE. 13635 13636 elsif Nkind (N) /= N_Attribute_Reference 13637 and then Is_Known_Guaranteed_ABE (N) 13638 then 13639 return; 13640 13641 -- Nothing to do if errors already detected (avoid cascaded errors) 13642 13643 elsif Serious_Errors_Detected /= 0 then 13644 return; 13645 13646 -- Nothing to do if not in full analysis mode 13647 13648 elsif not Full_Analysis then 13649 return; 13650 13651 -- Nothing to do if analyzing in special spec-expression mode, since the 13652 -- call is not actually being made at this time. 13653 13654 elsif In_Spec_Expression then 13655 return; 13656 13657 -- Nothing to do for call to intrinsic subprogram 13658 13659 elsif Is_Intrinsic_Subprogram (E) then 13660 return; 13661 13662 -- Nothing to do if call is within a generic unit 13663 13664 elsif Inside_A_Generic then 13665 return; 13666 13667 -- Nothing to do when the call appears within pragma Initial_Condition. 13668 -- The pragma is part of the elaboration statements of a package body 13669 -- and may only call external subprograms or subprograms whose body is 13670 -- already available. 13671 13672 elsif Within_Initial_Condition (N) then 13673 return; 13674 end if; 13675 13676 -- Delay this call if we are still delaying calls 13677 13678 if Delaying_Elab_Checks then 13679 Delay_Check.Append 13680 ((N => N, 13681 E => E, 13682 Orig_Ent => Orig_Ent, 13683 Curscop => Current_Scope, 13684 Outer_Scope => Outer_Scope, 13685 From_Elab_Code => From_Elab_Code, 13686 In_Task_Activation => In_Task_Activation, 13687 From_SPARK_Code => SPARK_Mode = On)); 13688 return; 13689 13690 -- Otherwise, call phase 2 continuation right now 13691 13692 else 13693 Check_Internal_Call_Continue (N, E, Outer_Scope, Orig_Ent); 13694 end if; 13695 end Check_Internal_Call; 13696 13697 ---------------------------------- 13698 -- Check_Internal_Call_Continue -- 13699 ---------------------------------- 13700 13701 procedure Check_Internal_Call_Continue 13702 (N : Node_Id; 13703 E : Entity_Id; 13704 Outer_Scope : Entity_Id; 13705 Orig_Ent : Entity_Id) 13706 is 13707 function Find_Elab_Reference (N : Node_Id) return Traverse_Result; 13708 -- Function applied to each node as we traverse the body. Checks for 13709 -- call or entity reference that needs checking, and if so checks it. 13710 -- Always returns OK, so entire tree is traversed, except that as 13711 -- described below subprogram bodies are skipped for now. 13712 13713 procedure Traverse is new Atree.Traverse_Proc (Find_Elab_Reference); 13714 -- Traverse procedure using above Find_Elab_Reference function 13715 13716 ------------------------- 13717 -- Find_Elab_Reference -- 13718 ------------------------- 13719 13720 function Find_Elab_Reference (N : Node_Id) return Traverse_Result is 13721 Actual : Node_Id; 13722 13723 begin 13724 -- If user has specified that there are no entry calls in elaboration 13725 -- code, do not trace past an accept statement, because the rendez- 13726 -- vous will happen after elaboration. 13727 13728 if Nkind_In (Original_Node (N), N_Accept_Statement, 13729 N_Selective_Accept) 13730 and then Restriction_Active (No_Entry_Calls_In_Elaboration_Code) 13731 then 13732 return Abandon; 13733 13734 -- If we have a function call, check it 13735 13736 elsif Nkind (N) = N_Function_Call then 13737 Check_Elab_Call (N, Outer_Scope); 13738 return OK; 13739 13740 -- If we have a procedure call, check the call, and also check 13741 -- arguments that are assignments (OUT or IN OUT mode formals). 13742 13743 elsif Nkind (N) = N_Procedure_Call_Statement then 13744 Check_Elab_Call (N, Outer_Scope, In_Init_Proc => Is_Init_Proc (E)); 13745 13746 Actual := First_Actual (N); 13747 while Present (Actual) loop 13748 if Known_To_Be_Assigned (Actual) then 13749 Check_Elab_Assign (Actual); 13750 end if; 13751 13752 Next_Actual (Actual); 13753 end loop; 13754 13755 return OK; 13756 13757 -- If we have an access attribute for a subprogram, check it. 13758 -- Suppress this behavior under debug flag. 13759 13760 elsif not Debug_Flag_Dot_UU 13761 and then Nkind (N) = N_Attribute_Reference 13762 and then Nam_In (Attribute_Name (N), Name_Access, 13763 Name_Unrestricted_Access) 13764 and then Is_Entity_Name (Prefix (N)) 13765 and then Is_Subprogram (Entity (Prefix (N))) 13766 then 13767 Check_Elab_Call (N, Outer_Scope); 13768 return OK; 13769 13770 -- In SPARK mode, if we have an entity reference to a variable, then 13771 -- check it. For now we consider any reference. 13772 13773 elsif SPARK_Mode = On 13774 and then Nkind (N) in N_Has_Entity 13775 and then Present (Entity (N)) 13776 and then Ekind (Entity (N)) = E_Variable 13777 then 13778 Check_Elab_Call (N, Outer_Scope); 13779 return OK; 13780 13781 -- If we have a generic instantiation, check it 13782 13783 elsif Nkind (N) in N_Generic_Instantiation then 13784 Check_Elab_Instantiation (N, Outer_Scope); 13785 return OK; 13786 13787 -- Skip subprogram bodies that come from source (wait for call to 13788 -- analyze these). The reason for the come from source test is to 13789 -- avoid catching task bodies. 13790 13791 -- For task bodies, we should really avoid these too, waiting for the 13792 -- task activation, but that's too much trouble to catch for now, so 13793 -- we go in unconditionally. This is not so terrible, it means the 13794 -- error backtrace is not quite complete, and we are too eager to 13795 -- scan bodies of tasks that are unused, but this is hardly very 13796 -- significant. 13797 13798 elsif Nkind (N) = N_Subprogram_Body 13799 and then Comes_From_Source (N) 13800 then 13801 return Skip; 13802 13803 elsif Nkind (N) = N_Assignment_Statement 13804 and then Comes_From_Source (N) 13805 then 13806 Check_Elab_Assign (Name (N)); 13807 return OK; 13808 13809 else 13810 return OK; 13811 end if; 13812 end Find_Elab_Reference; 13813 13814 Inst_Case : constant Boolean := Is_Generic_Unit (E); 13815 Loc : constant Source_Ptr := Sloc (N); 13816 13817 Ebody : Entity_Id; 13818 Sbody : Node_Id; 13819 13820 -- Start of processing for Check_Internal_Call_Continue 13821 13822 begin 13823 -- Save outer level call if at outer level 13824 13825 if Elab_Call.Last = 0 then 13826 Outer_Level_Sloc := Loc; 13827 end if; 13828 13829 -- If the call is to a function that renames a literal, no check needed 13830 13831 if Ekind (E) = E_Enumeration_Literal then 13832 return; 13833 end if; 13834 13835 -- Register the subprogram as examined within this particular context. 13836 -- This ensures that calls to the same subprogram but in different 13837 -- contexts receive warnings and checks of their own since the calls 13838 -- may be reached through different flow paths. 13839 13840 Elab_Visited.Append ((Subp_Id => E, Context => Parent (N))); 13841 13842 Sbody := Unit_Declaration_Node (E); 13843 13844 if not Nkind_In (Sbody, N_Subprogram_Body, N_Package_Body) then 13845 Ebody := Corresponding_Body (Sbody); 13846 13847 if No (Ebody) then 13848 return; 13849 else 13850 Sbody := Unit_Declaration_Node (Ebody); 13851 end if; 13852 end if; 13853 13854 -- If the body appears after the outer level call or instantiation then 13855 -- we have an error case handled below. 13856 13857 if Earlier_In_Extended_Unit (Outer_Level_Sloc, Sloc (Sbody)) 13858 and then not In_Task_Activation 13859 then 13860 null; 13861 13862 -- If we have the instantiation case we are done, since we now know that 13863 -- the body of the generic appeared earlier. 13864 13865 elsif Inst_Case then 13866 return; 13867 13868 -- Otherwise we have a call, so we trace through the called body to see 13869 -- if it has any problems. 13870 13871 else 13872 pragma Assert (Nkind (Sbody) = N_Subprogram_Body); 13873 13874 Elab_Call.Append ((Cloc => Loc, Ent => E)); 13875 13876 if Debug_Flag_Underscore_LL then 13877 Write_Str ("Elab_Call.Last = "); 13878 Write_Int (Int (Elab_Call.Last)); 13879 Write_Str (" Ent = "); 13880 Write_Name (Chars (E)); 13881 Write_Str (" at "); 13882 Write_Location (Sloc (N)); 13883 Write_Eol; 13884 end if; 13885 13886 -- Now traverse declarations and statements of subprogram body. Note 13887 -- that we cannot simply Traverse (Sbody), since traverse does not 13888 -- normally visit subprogram bodies. 13889 13890 declare 13891 Decl : Node_Id; 13892 begin 13893 Decl := First (Declarations (Sbody)); 13894 while Present (Decl) loop 13895 Traverse (Decl); 13896 Next (Decl); 13897 end loop; 13898 end; 13899 13900 Traverse (Handled_Statement_Sequence (Sbody)); 13901 13902 Elab_Call.Decrement_Last; 13903 return; 13904 end if; 13905 13906 -- Here is the case of calling a subprogram where the body has not yet 13907 -- been encountered. A warning message is needed, except if this is the 13908 -- case of appearing within an aspect specification that results in 13909 -- a check call, we do not really have such a situation, so no warning 13910 -- is needed (e.g. the case of a precondition, where the call appears 13911 -- textually before the body, but in actual fact is moved to the 13912 -- appropriate subprogram body and so does not need a check). 13913 13914 declare 13915 P : Node_Id; 13916 O : Node_Id; 13917 13918 begin 13919 P := Parent (N); 13920 loop 13921 -- Keep looking at parents if we are still in the subexpression 13922 13923 if Nkind (P) in N_Subexpr then 13924 P := Parent (P); 13925 13926 -- Here P is the parent of the expression, check for special case 13927 13928 else 13929 O := Original_Node (P); 13930 13931 -- Definitely not the special case if orig node is not a pragma 13932 13933 exit when Nkind (O) /= N_Pragma; 13934 13935 -- Check we have an If statement or a null statement (happens 13936 -- when the If has been expanded to be True). 13937 13938 exit when not Nkind_In (P, N_If_Statement, N_Null_Statement); 13939 13940 -- Our special case will be indicated either by the pragma 13941 -- coming from an aspect ... 13942 13943 if Present (Corresponding_Aspect (O)) then 13944 return; 13945 13946 -- Or, in the case of an initial condition, specifically by a 13947 -- Check pragma specifying an Initial_Condition check. 13948 13949 elsif Pragma_Name (O) = Name_Check 13950 and then 13951 Chars 13952 (Expression (First (Pragma_Argument_Associations (O)))) = 13953 Name_Initial_Condition 13954 then 13955 return; 13956 13957 -- For anything else, we have an error 13958 13959 else 13960 exit; 13961 end if; 13962 end if; 13963 end loop; 13964 end; 13965 13966 -- Not that special case, warning and dynamic check is required 13967 13968 -- If we have nothing in the call stack, then this is at the outer 13969 -- level, and the ABE is bound to occur, unless it's a 'Access, or 13970 -- it's a renaming. 13971 13972 if Elab_Call.Last = 0 then 13973 Error_Msg_Warn := SPARK_Mode /= On; 13974 13975 declare 13976 Insert_Check : Boolean := True; 13977 -- This flag is set to True if an elaboration check should be 13978 -- inserted. 13979 13980 begin 13981 if In_Task_Activation then 13982 Insert_Check := False; 13983 13984 elsif Inst_Case then 13985 Error_Msg_NE 13986 ("cannot instantiate& before body seen<<", N, Orig_Ent); 13987 13988 elsif Nkind (N) = N_Attribute_Reference then 13989 Error_Msg_NE 13990 ("Access attribute of & before body seen<<", N, Orig_Ent); 13991 Error_Msg_N ("\possible Program_Error on later references<", N); 13992 Insert_Check := False; 13993 13994 elsif Nkind (Unit_Declaration_Node (Orig_Ent)) /= 13995 N_Subprogram_Renaming_Declaration 13996 then 13997 Error_Msg_NE 13998 ("cannot call& before body seen<<", N, Orig_Ent); 13999 14000 elsif not Is_Generic_Actual_Subprogram (Orig_Ent) then 14001 Insert_Check := False; 14002 end if; 14003 14004 if Insert_Check then 14005 Error_Msg_N ("\Program_Error [<<", N); 14006 Insert_Elab_Check (N); 14007 end if; 14008 end; 14009 14010 -- Call is not at outer level 14011 14012 else 14013 -- Do not generate elaboration checks in GNATprove mode because the 14014 -- elaboration counter and the check are both forms of expansion. 14015 14016 if GNATprove_Mode then 14017 null; 14018 14019 -- Generate an elaboration check 14020 14021 elsif not Elaboration_Checks_Suppressed (E) then 14022 Set_Elaboration_Entity_Required (E); 14023 14024 -- Create a declaration of the elaboration entity, and insert it 14025 -- prior to the subprogram or the generic unit, within the same 14026 -- scope. Since the subprogram may be overloaded, create a unique 14027 -- entity. 14028 14029 if No (Elaboration_Entity (E)) then 14030 declare 14031 Loce : constant Source_Ptr := Sloc (E); 14032 Ent : constant Entity_Id := 14033 Make_Defining_Identifier (Loc, 14034 New_External_Name (Chars (E), 'E', -1)); 14035 14036 begin 14037 Set_Elaboration_Entity (E, Ent); 14038 Push_Scope (Scope (E)); 14039 14040 Insert_Action (Declaration_Node (E), 14041 Make_Object_Declaration (Loce, 14042 Defining_Identifier => Ent, 14043 Object_Definition => 14044 New_Occurrence_Of (Standard_Short_Integer, Loce), 14045 Expression => 14046 Make_Integer_Literal (Loc, Uint_0))); 14047 14048 -- Set elaboration flag at the point of the body 14049 14050 Set_Elaboration_Flag (Sbody, E); 14051 14052 -- Kill current value indication. This is necessary because 14053 -- the tests of this flag are inserted out of sequence and 14054 -- must not pick up bogus indications of the wrong constant 14055 -- value. Also, this is never a true constant, since one way 14056 -- or another, it gets reset. 14057 14058 Set_Current_Value (Ent, Empty); 14059 Set_Last_Assignment (Ent, Empty); 14060 Set_Is_True_Constant (Ent, False); 14061 Pop_Scope; 14062 end; 14063 end if; 14064 14065 -- Generate: 14066 -- if Enn = 0 then 14067 -- raise Program_Error with "access before elaboration"; 14068 -- end if; 14069 14070 Insert_Elab_Check (N, 14071 Make_Attribute_Reference (Loc, 14072 Attribute_Name => Name_Elaborated, 14073 Prefix => New_Occurrence_Of (E, Loc))); 14074 end if; 14075 14076 -- Generate the warning 14077 14078 if not Suppress_Elaboration_Warnings (E) 14079 and then not Elaboration_Checks_Suppressed (E) 14080 14081 -- Suppress this warning if we have a function call that occurred 14082 -- within an assertion expression, since we can get false warnings 14083 -- in this case, due to the out of order handling in this case. 14084 14085 and then 14086 (Nkind (Original_Node (N)) /= N_Function_Call 14087 or else not In_Assertion_Expression_Pragma (Original_Node (N))) 14088 then 14089 Error_Msg_Warn := SPARK_Mode /= On; 14090 14091 if Inst_Case then 14092 Error_Msg_NE 14093 ("instantiation of& may occur before body is seen<l<", 14094 N, Orig_Ent); 14095 else 14096 -- A rather specific check. For Finalize/Adjust/Initialize, if 14097 -- the type has Warnings_Off set, suppress the warning. 14098 14099 if Nam_In (Chars (E), Name_Adjust, 14100 Name_Finalize, 14101 Name_Initialize) 14102 and then Present (First_Formal (E)) 14103 then 14104 declare 14105 T : constant Entity_Id := Etype (First_Formal (E)); 14106 begin 14107 if Is_Controlled (T) then 14108 if Warnings_Off (T) 14109 or else (Ekind (T) = E_Private_Type 14110 and then Warnings_Off (Full_View (T))) 14111 then 14112 goto Output; 14113 end if; 14114 end if; 14115 end; 14116 end if; 14117 14118 -- Go ahead and give warning if not this special case 14119 14120 Error_Msg_NE 14121 ("call to& may occur before body is seen<l<", N, Orig_Ent); 14122 end if; 14123 14124 Error_Msg_N ("\Program_Error ]<l<", N); 14125 14126 -- There is no need to query the elaboration warning message flags 14127 -- because the main message is an error, not a warning, therefore 14128 -- all the clarification messages produces by Output_Calls must be 14129 -- emitted unconditionally. 14130 14131 <<Output>> 14132 14133 Output_Calls (N, Check_Elab_Flag => False); 14134 end if; 14135 end if; 14136 end Check_Internal_Call_Continue; 14137 14138 --------------------------- 14139 -- Check_Task_Activation -- 14140 --------------------------- 14141 14142 procedure Check_Task_Activation (N : Node_Id) is 14143 Loc : constant Source_Ptr := Sloc (N); 14144 Inter_Procs : constant Elist_Id := New_Elmt_List; 14145 Intra_Procs : constant Elist_Id := New_Elmt_List; 14146 Ent : Entity_Id; 14147 P : Entity_Id; 14148 Task_Scope : Entity_Id; 14149 Cunit_SC : Boolean := False; 14150 Decl : Node_Id; 14151 Elmt : Elmt_Id; 14152 Enclosing : Entity_Id; 14153 14154 procedure Add_Task_Proc (Typ : Entity_Id); 14155 -- Add to Task_Procs the task body procedure(s) of task types in Typ. 14156 -- For record types, this procedure recurses over component types. 14157 14158 procedure Collect_Tasks (Decls : List_Id); 14159 -- Collect the types of the tasks that are to be activated in the given 14160 -- list of declarations, in order to perform elaboration checks on the 14161 -- corresponding task procedures that are called implicitly here. 14162 14163 function Outer_Unit (E : Entity_Id) return Entity_Id; 14164 -- find enclosing compilation unit of Entity, ignoring subunits, or 14165 -- else enclosing subprogram. If E is not a package, there is no need 14166 -- for inter-unit elaboration checks. 14167 14168 ------------------- 14169 -- Add_Task_Proc -- 14170 ------------------- 14171 14172 procedure Add_Task_Proc (Typ : Entity_Id) is 14173 Comp : Entity_Id; 14174 Proc : Entity_Id := Empty; 14175 14176 begin 14177 if Is_Task_Type (Typ) then 14178 Proc := Get_Task_Body_Procedure (Typ); 14179 14180 elsif Is_Array_Type (Typ) 14181 and then Has_Task (Base_Type (Typ)) 14182 then 14183 Add_Task_Proc (Component_Type (Typ)); 14184 14185 elsif Is_Record_Type (Typ) 14186 and then Has_Task (Base_Type (Typ)) 14187 then 14188 Comp := First_Component (Typ); 14189 while Present (Comp) loop 14190 Add_Task_Proc (Etype (Comp)); 14191 Comp := Next_Component (Comp); 14192 end loop; 14193 end if; 14194 14195 -- If the task type is another unit, we will perform the usual 14196 -- elaboration check on its enclosing unit. If the type is in the 14197 -- same unit, we can trace the task body as for an internal call, 14198 -- but we only need to examine other external calls, because at 14199 -- the point the task is activated, internal subprogram bodies 14200 -- will have been elaborated already. We keep separate lists for 14201 -- each kind of task. 14202 14203 -- Skip this test if errors have occurred, since in this case 14204 -- we can get false indications. 14205 14206 if Serious_Errors_Detected /= 0 then 14207 return; 14208 end if; 14209 14210 if Present (Proc) then 14211 if Outer_Unit (Scope (Proc)) = Enclosing then 14212 14213 if No (Corresponding_Body (Unit_Declaration_Node (Proc))) 14214 and then 14215 (not Is_Generic_Instance (Scope (Proc)) 14216 or else Scope (Proc) = Scope (Defining_Identifier (Decl))) 14217 then 14218 Error_Msg_Warn := SPARK_Mode /= On; 14219 Error_Msg_N 14220 ("task will be activated before elaboration of its body<<", 14221 Decl); 14222 Error_Msg_N ("\Program_Error [<<", Decl); 14223 14224 elsif Present 14225 (Corresponding_Body (Unit_Declaration_Node (Proc))) 14226 then 14227 Append_Elmt (Proc, Intra_Procs); 14228 end if; 14229 14230 else 14231 -- No need for multiple entries of the same type 14232 14233 Elmt := First_Elmt (Inter_Procs); 14234 while Present (Elmt) loop 14235 if Node (Elmt) = Proc then 14236 return; 14237 end if; 14238 14239 Next_Elmt (Elmt); 14240 end loop; 14241 14242 Append_Elmt (Proc, Inter_Procs); 14243 end if; 14244 end if; 14245 end Add_Task_Proc; 14246 14247 ------------------- 14248 -- Collect_Tasks -- 14249 ------------------- 14250 14251 procedure Collect_Tasks (Decls : List_Id) is 14252 begin 14253 if Present (Decls) then 14254 Decl := First (Decls); 14255 while Present (Decl) loop 14256 if Nkind (Decl) = N_Object_Declaration 14257 and then Has_Task (Etype (Defining_Identifier (Decl))) 14258 then 14259 Add_Task_Proc (Etype (Defining_Identifier (Decl))); 14260 end if; 14261 14262 Next (Decl); 14263 end loop; 14264 end if; 14265 end Collect_Tasks; 14266 14267 ---------------- 14268 -- Outer_Unit -- 14269 ---------------- 14270 14271 function Outer_Unit (E : Entity_Id) return Entity_Id is 14272 Outer : Entity_Id; 14273 14274 begin 14275 Outer := E; 14276 while Present (Outer) loop 14277 if Elaboration_Checks_Suppressed (Outer) then 14278 Cunit_SC := True; 14279 end if; 14280 14281 exit when Is_Child_Unit (Outer) 14282 or else Scope (Outer) = Standard_Standard 14283 or else Ekind (Outer) /= E_Package; 14284 Outer := Scope (Outer); 14285 end loop; 14286 14287 return Outer; 14288 end Outer_Unit; 14289 14290 -- Start of processing for Check_Task_Activation 14291 14292 begin 14293 pragma Assert (Legacy_Elaboration_Checks); 14294 14295 Enclosing := Outer_Unit (Current_Scope); 14296 14297 -- Find all tasks declared in the current unit 14298 14299 if Nkind (N) = N_Package_Body then 14300 P := Unit_Declaration_Node (Corresponding_Spec (N)); 14301 14302 Collect_Tasks (Declarations (N)); 14303 Collect_Tasks (Visible_Declarations (Specification (P))); 14304 Collect_Tasks (Private_Declarations (Specification (P))); 14305 14306 elsif Nkind (N) = N_Package_Declaration then 14307 Collect_Tasks (Visible_Declarations (Specification (N))); 14308 Collect_Tasks (Private_Declarations (Specification (N))); 14309 14310 else 14311 Collect_Tasks (Declarations (N)); 14312 end if; 14313 14314 -- We only perform detailed checks in all tasks that are library level 14315 -- entities. If the master is a subprogram or task, activation will 14316 -- depend on the activation of the master itself. 14317 14318 -- Should dynamic checks be added in the more general case??? 14319 14320 if Ekind (Enclosing) /= E_Package then 14321 return; 14322 end if; 14323 14324 -- For task types defined in other units, we want the unit containing 14325 -- the task body to be elaborated before the current one. 14326 14327 Elmt := First_Elmt (Inter_Procs); 14328 while Present (Elmt) loop 14329 Ent := Node (Elmt); 14330 Task_Scope := Outer_Unit (Scope (Ent)); 14331 14332 if not Is_Compilation_Unit (Task_Scope) then 14333 null; 14334 14335 elsif Suppress_Elaboration_Warnings (Task_Scope) 14336 or else Elaboration_Checks_Suppressed (Task_Scope) 14337 then 14338 null; 14339 14340 elsif Dynamic_Elaboration_Checks then 14341 if not Elaboration_Checks_Suppressed (Ent) 14342 and then not Cunit_SC 14343 and then not Restriction_Active 14344 (No_Entry_Calls_In_Elaboration_Code) 14345 then 14346 -- Runtime elaboration check required. Generate check of the 14347 -- elaboration counter for the unit containing the entity. 14348 14349 Insert_Elab_Check (N, 14350 Make_Attribute_Reference (Loc, 14351 Prefix => 14352 New_Occurrence_Of (Spec_Entity (Task_Scope), Loc), 14353 Attribute_Name => Name_Elaborated)); 14354 end if; 14355 14356 else 14357 -- Force the binder to elaborate other unit first 14358 14359 if Elab_Info_Messages 14360 and then not Suppress_Elaboration_Warnings (Ent) 14361 and then not Elaboration_Checks_Suppressed (Ent) 14362 and then not Suppress_Elaboration_Warnings (Task_Scope) 14363 and then not Elaboration_Checks_Suppressed (Task_Scope) 14364 then 14365 Error_Msg_Node_2 := Task_Scope; 14366 Error_Msg_NE 14367 ("info: activation of an instance of task type & requires " 14368 & "pragma Elaborate_All on &?$?", N, Ent); 14369 end if; 14370 14371 Activate_Elaborate_All_Desirable (N, Task_Scope); 14372 Set_Suppress_Elaboration_Warnings (Task_Scope); 14373 end if; 14374 14375 Next_Elmt (Elmt); 14376 end loop; 14377 14378 -- For tasks declared in the current unit, trace other calls within the 14379 -- task procedure bodies, which are available. 14380 14381 if not Debug_Flag_Dot_Y then 14382 In_Task_Activation := True; 14383 14384 Elmt := First_Elmt (Intra_Procs); 14385 while Present (Elmt) loop 14386 Ent := Node (Elmt); 14387 Check_Internal_Call_Continue (N, Ent, Enclosing, Ent); 14388 Next_Elmt (Elmt); 14389 end loop; 14390 14391 In_Task_Activation := False; 14392 end if; 14393 end Check_Task_Activation; 14394 14395 ------------------------ 14396 -- Get_Referenced_Ent -- 14397 ------------------------ 14398 14399 function Get_Referenced_Ent (N : Node_Id) return Entity_Id is 14400 Nam : Node_Id; 14401 14402 begin 14403 if Nkind (N) in N_Has_Entity 14404 and then Present (Entity (N)) 14405 and then Ekind (Entity (N)) = E_Variable 14406 then 14407 return Entity (N); 14408 end if; 14409 14410 if Nkind (N) = N_Attribute_Reference then 14411 Nam := Prefix (N); 14412 else 14413 Nam := Name (N); 14414 end if; 14415 14416 if No (Nam) then 14417 return Empty; 14418 elsif Nkind (Nam) = N_Selected_Component then 14419 return Entity (Selector_Name (Nam)); 14420 elsif not Is_Entity_Name (Nam) then 14421 return Empty; 14422 else 14423 return Entity (Nam); 14424 end if; 14425 end Get_Referenced_Ent; 14426 14427 ---------------------- 14428 -- Has_Generic_Body -- 14429 ---------------------- 14430 14431 function Has_Generic_Body (N : Node_Id) return Boolean is 14432 Ent : constant Entity_Id := Get_Generic_Entity (N); 14433 Decl : constant Node_Id := Unit_Declaration_Node (Ent); 14434 Scop : Entity_Id; 14435 14436 function Find_Body_In (E : Entity_Id; N : Node_Id) return Node_Id; 14437 -- Determine if the list of nodes headed by N and linked by Next 14438 -- contains a package body for the package spec entity E, and if so 14439 -- return the package body. If not, then returns Empty. 14440 14441 function Load_Package_Body (Nam : Unit_Name_Type) return Node_Id; 14442 -- This procedure is called load the unit whose name is given by Nam. 14443 -- This unit is being loaded to see whether it contains an optional 14444 -- generic body. The returned value is the loaded unit, which is always 14445 -- a package body (only package bodies can contain other entities in the 14446 -- sense in which Has_Generic_Body is interested). We only attempt to 14447 -- load bodies if we are generating code. If we are in semantics check 14448 -- only mode, then it would be wrong to load bodies that are not 14449 -- required from a semantic point of view, so in this case we return 14450 -- Empty. The result is that the caller may incorrectly decide that a 14451 -- generic spec does not have a body when in fact it does, but the only 14452 -- harm in this is that some warnings on elaboration problems may be 14453 -- lost in semantic checks only mode, which is not big loss. We also 14454 -- return Empty if we go for a body and it is not there. 14455 14456 function Locate_Corresponding_Body (PE : Entity_Id) return Node_Id; 14457 -- PE is the entity for a package spec. This function locates the 14458 -- corresponding package body, returning Empty if none is found. The 14459 -- package body returned is fully parsed but may not yet be analyzed, 14460 -- so only syntactic fields should be referenced. 14461 14462 ------------------ 14463 -- Find_Body_In -- 14464 ------------------ 14465 14466 function Find_Body_In (E : Entity_Id; N : Node_Id) return Node_Id is 14467 Nod : Node_Id; 14468 14469 begin 14470 Nod := N; 14471 while Present (Nod) loop 14472 14473 -- If we found the package body we are looking for, return it 14474 14475 if Nkind (Nod) = N_Package_Body 14476 and then Chars (Defining_Unit_Name (Nod)) = Chars (E) 14477 then 14478 return Nod; 14479 14480 -- If we found the stub for the body, go after the subunit, 14481 -- loading it if necessary. 14482 14483 elsif Nkind (Nod) = N_Package_Body_Stub 14484 and then Chars (Defining_Identifier (Nod)) = Chars (E) 14485 then 14486 if Present (Library_Unit (Nod)) then 14487 return Unit (Library_Unit (Nod)); 14488 14489 else 14490 return Load_Package_Body (Get_Unit_Name (Nod)); 14491 end if; 14492 14493 -- If neither package body nor stub, keep looking on chain 14494 14495 else 14496 Next (Nod); 14497 end if; 14498 end loop; 14499 14500 return Empty; 14501 end Find_Body_In; 14502 14503 ----------------------- 14504 -- Load_Package_Body -- 14505 ----------------------- 14506 14507 function Load_Package_Body (Nam : Unit_Name_Type) return Node_Id is 14508 U : Unit_Number_Type; 14509 14510 begin 14511 if Operating_Mode /= Generate_Code then 14512 return Empty; 14513 else 14514 U := 14515 Load_Unit 14516 (Load_Name => Nam, 14517 Required => False, 14518 Subunit => False, 14519 Error_Node => N); 14520 14521 if U = No_Unit then 14522 return Empty; 14523 else 14524 return Unit (Cunit (U)); 14525 end if; 14526 end if; 14527 end Load_Package_Body; 14528 14529 ------------------------------- 14530 -- Locate_Corresponding_Body -- 14531 ------------------------------- 14532 14533 function Locate_Corresponding_Body (PE : Entity_Id) return Node_Id is 14534 Spec : constant Node_Id := Declaration_Node (PE); 14535 Decl : constant Node_Id := Parent (Spec); 14536 Scop : constant Entity_Id := Scope (PE); 14537 PBody : Node_Id; 14538 14539 begin 14540 if Is_Library_Level_Entity (PE) then 14541 14542 -- If package is a library unit that requires a body, we have no 14543 -- choice but to go after that body because it might contain an 14544 -- optional body for the original generic package. 14545 14546 if Unit_Requires_Body (PE) then 14547 14548 -- Load the body. Note that we are a little careful here to use 14549 -- Spec to get the unit number, rather than PE or Decl, since 14550 -- in the case where the package is itself a library level 14551 -- instantiation, Spec will properly reference the generic 14552 -- template, which is what we really want. 14553 14554 return 14555 Load_Package_Body 14556 (Get_Body_Name (Unit_Name (Get_Source_Unit (Spec)))); 14557 14558 -- But if the package is a library unit that does NOT require 14559 -- a body, then no body is permitted, so we are sure that there 14560 -- is no body for the original generic package. 14561 14562 else 14563 return Empty; 14564 end if; 14565 14566 -- Otherwise look and see if we are embedded in a further package 14567 14568 elsif Is_Package_Or_Generic_Package (Scop) then 14569 14570 -- If so, get the body of the enclosing package, and look in 14571 -- its package body for the package body we are looking for. 14572 14573 PBody := Locate_Corresponding_Body (Scop); 14574 14575 if No (PBody) then 14576 return Empty; 14577 else 14578 return Find_Body_In (PE, First (Declarations (PBody))); 14579 end if; 14580 14581 -- If we are not embedded in a further package, then the body 14582 -- must be in the same declarative part as we are. 14583 14584 else 14585 return Find_Body_In (PE, Next (Decl)); 14586 end if; 14587 end Locate_Corresponding_Body; 14588 14589 -- Start of processing for Has_Generic_Body 14590 14591 begin 14592 if Present (Corresponding_Body (Decl)) then 14593 return True; 14594 14595 elsif Unit_Requires_Body (Ent) then 14596 return True; 14597 14598 -- Compilation units cannot have optional bodies 14599 14600 elsif Is_Compilation_Unit (Ent) then 14601 return False; 14602 14603 -- Otherwise look at what scope we are in 14604 14605 else 14606 Scop := Scope (Ent); 14607 14608 -- Case of entity is in other than a package spec, in this case 14609 -- the body, if present, must be in the same declarative part. 14610 14611 if not Is_Package_Or_Generic_Package (Scop) then 14612 declare 14613 P : Node_Id; 14614 14615 begin 14616 -- Declaration node may get us a spec, so if so, go to 14617 -- the parent declaration. 14618 14619 P := Declaration_Node (Ent); 14620 while not Is_List_Member (P) loop 14621 P := Parent (P); 14622 end loop; 14623 14624 return Present (Find_Body_In (Ent, Next (P))); 14625 end; 14626 14627 -- If the entity is in a package spec, then we have to locate 14628 -- the corresponding package body, and look there. 14629 14630 else 14631 declare 14632 PBody : constant Node_Id := Locate_Corresponding_Body (Scop); 14633 14634 begin 14635 if No (PBody) then 14636 return False; 14637 else 14638 return 14639 Present 14640 (Find_Body_In (Ent, (First (Declarations (PBody))))); 14641 end if; 14642 end; 14643 end if; 14644 end if; 14645 end Has_Generic_Body; 14646 14647 ----------------------- 14648 -- Insert_Elab_Check -- 14649 ----------------------- 14650 14651 procedure Insert_Elab_Check (N : Node_Id; C : Node_Id := Empty) is 14652 Nod : Node_Id; 14653 Loc : constant Source_Ptr := Sloc (N); 14654 14655 Chk : Node_Id; 14656 -- The check (N_Raise_Program_Error) node to be inserted 14657 14658 begin 14659 -- If expansion is disabled, do not generate any checks. Also 14660 -- skip checks if any subunits are missing because in either 14661 -- case we lack the full information that we need, and no object 14662 -- file will be created in any case. 14663 14664 if not Expander_Active or else Subunits_Missing then 14665 return; 14666 end if; 14667 14668 -- If we have a generic instantiation, where Instance_Spec is set, 14669 -- then this field points to a generic instance spec that has 14670 -- been inserted before the instantiation node itself, so that 14671 -- is where we want to insert a check. 14672 14673 if Nkind (N) in N_Generic_Instantiation 14674 and then Present (Instance_Spec (N)) 14675 then 14676 Nod := Instance_Spec (N); 14677 else 14678 Nod := N; 14679 end if; 14680 14681 -- Build check node, possibly with condition 14682 14683 Chk := 14684 Make_Raise_Program_Error (Loc, Reason => PE_Access_Before_Elaboration); 14685 14686 if Present (C) then 14687 Set_Condition (Chk, Make_Op_Not (Loc, Right_Opnd => C)); 14688 end if; 14689 14690 -- If we are inserting at the top level, insert in Aux_Decls 14691 14692 if Nkind (Parent (Nod)) = N_Compilation_Unit then 14693 declare 14694 ADN : constant Node_Id := Aux_Decls_Node (Parent (Nod)); 14695 14696 begin 14697 if No (Declarations (ADN)) then 14698 Set_Declarations (ADN, New_List (Chk)); 14699 else 14700 Append_To (Declarations (ADN), Chk); 14701 end if; 14702 14703 Analyze (Chk); 14704 end; 14705 14706 -- Otherwise just insert as an action on the node in question 14707 14708 else 14709 Insert_Action (Nod, Chk); 14710 end if; 14711 end Insert_Elab_Check; 14712 14713 ------------------------------- 14714 -- Is_Call_Of_Generic_Formal -- 14715 ------------------------------- 14716 14717 function Is_Call_Of_Generic_Formal (N : Node_Id) return Boolean is 14718 begin 14719 return Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement) 14720 14721 -- Always return False if debug flag -gnatd.G is set 14722 14723 and then not Debug_Flag_Dot_GG 14724 14725 -- For now, we detect this by looking for the strange identifier 14726 -- node, whose Chars reflect the name of the generic formal, but 14727 -- the Chars of the Entity references the generic actual. 14728 14729 and then Nkind (Name (N)) = N_Identifier 14730 and then Chars (Name (N)) /= Chars (Entity (Name (N))); 14731 end Is_Call_Of_Generic_Formal; 14732 14733 ------------------------------- 14734 -- Is_Finalization_Procedure -- 14735 ------------------------------- 14736 14737 function Is_Finalization_Procedure (Id : Entity_Id) return Boolean is 14738 begin 14739 -- Check whether Id is a procedure with at least one parameter 14740 14741 if Ekind (Id) = E_Procedure and then Present (First_Formal (Id)) then 14742 declare 14743 Typ : constant Entity_Id := Etype (First_Formal (Id)); 14744 Deep_Fin : Entity_Id := Empty; 14745 Fin : Entity_Id := Empty; 14746 14747 begin 14748 -- If the type of the first formal does not require finalization 14749 -- actions, then this is definitely not [Deep_]Finalize. 14750 14751 if not Needs_Finalization (Typ) then 14752 return False; 14753 end if; 14754 14755 -- At this point we have the following scenario: 14756 14757 -- procedure Name (Param1 : [in] [out] Ctrl[; Param2 : ...]); 14758 14759 -- Recover the two possible versions of [Deep_]Finalize using the 14760 -- type of the first parameter and compare with the input. 14761 14762 Deep_Fin := TSS (Typ, TSS_Deep_Finalize); 14763 14764 if Is_Controlled (Typ) then 14765 Fin := Find_Prim_Op (Typ, Name_Finalize); 14766 end if; 14767 14768 return (Present (Deep_Fin) and then Id = Deep_Fin) 14769 or else (Present (Fin) and then Id = Fin); 14770 end; 14771 end if; 14772 14773 return False; 14774 end Is_Finalization_Procedure; 14775 14776 ------------------ 14777 -- Output_Calls -- 14778 ------------------ 14779 14780 procedure Output_Calls 14781 (N : Node_Id; 14782 Check_Elab_Flag : Boolean) 14783 is 14784 function Emit (Flag : Boolean) return Boolean; 14785 -- Determine whether to emit an error message based on the combination 14786 -- of flags Check_Elab_Flag and Flag. 14787 14788 function Is_Printable_Error_Name return Boolean; 14789 -- An internal function, used to determine if a name, stored in the 14790 -- Name_Buffer, is either a non-internal name, or is an internal name 14791 -- that is printable by the error message circuits (i.e. it has a single 14792 -- upper case letter at the end). 14793 14794 ---------- 14795 -- Emit -- 14796 ---------- 14797 14798 function Emit (Flag : Boolean) return Boolean is 14799 begin 14800 if Check_Elab_Flag then 14801 return Flag; 14802 else 14803 return True; 14804 end if; 14805 end Emit; 14806 14807 ----------------------------- 14808 -- Is_Printable_Error_Name -- 14809 ----------------------------- 14810 14811 function Is_Printable_Error_Name return Boolean is 14812 begin 14813 if not Is_Internal_Name then 14814 return True; 14815 14816 elsif Name_Len = 1 then 14817 return False; 14818 14819 else 14820 Name_Len := Name_Len - 1; 14821 return not Is_Internal_Name; 14822 end if; 14823 end Is_Printable_Error_Name; 14824 14825 -- Local variables 14826 14827 Ent : Entity_Id; 14828 14829 -- Start of processing for Output_Calls 14830 14831 begin 14832 for J in reverse 1 .. Elab_Call.Last loop 14833 Error_Msg_Sloc := Elab_Call.Table (J).Cloc; 14834 14835 Ent := Elab_Call.Table (J).Ent; 14836 Get_Name_String (Chars (Ent)); 14837 14838 -- Dynamic elaboration model, warnings controlled by -gnatwl 14839 14840 if Dynamic_Elaboration_Checks then 14841 if Emit (Elab_Warnings) then 14842 if Is_Generic_Unit (Ent) then 14843 Error_Msg_NE ("\\?l?& instantiated #", N, Ent); 14844 elsif Is_Init_Proc (Ent) then 14845 Error_Msg_N ("\\?l?initialization procedure called #", N); 14846 elsif Is_Printable_Error_Name then 14847 Error_Msg_NE ("\\?l?& called #", N, Ent); 14848 else 14849 Error_Msg_N ("\\?l?called #", N); 14850 end if; 14851 end if; 14852 14853 -- Static elaboration model, info messages controlled by -gnatel 14854 14855 else 14856 if Emit (Elab_Info_Messages) then 14857 if Is_Generic_Unit (Ent) then 14858 Error_Msg_NE ("\\?$?& instantiated #", N, Ent); 14859 elsif Is_Init_Proc (Ent) then 14860 Error_Msg_N ("\\?$?initialization procedure called #", N); 14861 elsif Is_Printable_Error_Name then 14862 Error_Msg_NE ("\\?$?& called #", N, Ent); 14863 else 14864 Error_Msg_N ("\\?$?called #", N); 14865 end if; 14866 end if; 14867 end if; 14868 end loop; 14869 end Output_Calls; 14870 14871 ---------------------------- 14872 -- Same_Elaboration_Scope -- 14873 ---------------------------- 14874 14875 function Same_Elaboration_Scope (Scop1, Scop2 : Entity_Id) return Boolean is 14876 S1 : Entity_Id; 14877 S2 : Entity_Id; 14878 14879 begin 14880 -- Find elaboration scope for Scop1 14881 -- This is either a subprogram or a compilation unit. 14882 14883 S1 := Scop1; 14884 while S1 /= Standard_Standard 14885 and then not Is_Compilation_Unit (S1) 14886 and then Ekind_In (S1, E_Package, E_Protected_Type, E_Block) 14887 loop 14888 S1 := Scope (S1); 14889 end loop; 14890 14891 -- Find elaboration scope for Scop2 14892 14893 S2 := Scop2; 14894 while S2 /= Standard_Standard 14895 and then not Is_Compilation_Unit (S2) 14896 and then Ekind_In (S2, E_Package, E_Protected_Type, E_Block) 14897 loop 14898 S2 := Scope (S2); 14899 end loop; 14900 14901 return S1 = S2; 14902 end Same_Elaboration_Scope; 14903 14904 ----------------- 14905 -- Set_C_Scope -- 14906 ----------------- 14907 14908 procedure Set_C_Scope is 14909 begin 14910 while not Is_Compilation_Unit (C_Scope) loop 14911 C_Scope := Scope (C_Scope); 14912 end loop; 14913 end Set_C_Scope; 14914 14915 -------------------------------- 14916 -- Set_Elaboration_Constraint -- 14917 -------------------------------- 14918 14919 procedure Set_Elaboration_Constraint 14920 (Call : Node_Id; 14921 Subp : Entity_Id; 14922 Scop : Entity_Id) 14923 is 14924 Elab_Unit : Entity_Id; 14925 14926 -- Check whether this is a call to an Initialize subprogram for a 14927 -- controlled type. Note that Call can also be a 'Access attribute 14928 -- reference, which now generates an elaboration check. 14929 14930 Init_Call : constant Boolean := 14931 Nkind (Call) = N_Procedure_Call_Statement 14932 and then Chars (Subp) = Name_Initialize 14933 and then Comes_From_Source (Subp) 14934 and then Present (Parameter_Associations (Call)) 14935 and then Is_Controlled (Etype (First_Actual (Call))); 14936 14937 begin 14938 -- If the unit is mentioned in a with_clause of the current unit, it is 14939 -- visible, and we can set the elaboration flag. 14940 14941 if Is_Immediately_Visible (Scop) 14942 or else (Is_Child_Unit (Scop) and then Is_Visible_Lib_Unit (Scop)) 14943 then 14944 Activate_Elaborate_All_Desirable (Call, Scop); 14945 Set_Suppress_Elaboration_Warnings (Scop); 14946 return; 14947 end if; 14948 14949 -- If this is not an initialization call or a call using object notation 14950 -- we know that the unit of the called entity is in the context, and we 14951 -- can set the flag as well. The unit need not be visible if the call 14952 -- occurs within an instantiation. 14953 14954 if Is_Init_Proc (Subp) 14955 or else Init_Call 14956 or else Nkind (Original_Node (Call)) = N_Selected_Component 14957 then 14958 null; -- detailed processing follows. 14959 14960 else 14961 Activate_Elaborate_All_Desirable (Call, Scop); 14962 Set_Suppress_Elaboration_Warnings (Scop); 14963 return; 14964 end if; 14965 14966 -- If the unit is not in the context, there must be an intermediate unit 14967 -- that is, on which we need to place to elaboration flag. This happens 14968 -- with init proc calls. 14969 14970 if Is_Init_Proc (Subp) or else Init_Call then 14971 14972 -- The initialization call is on an object whose type is not declared 14973 -- in the same scope as the subprogram. The type of the object must 14974 -- be a subtype of the type of operation. This object is the first 14975 -- actual in the call. 14976 14977 declare 14978 Typ : constant Entity_Id := 14979 Etype (First (Parameter_Associations (Call))); 14980 begin 14981 Elab_Unit := Scope (Typ); 14982 while (Present (Elab_Unit)) 14983 and then not Is_Compilation_Unit (Elab_Unit) 14984 loop 14985 Elab_Unit := Scope (Elab_Unit); 14986 end loop; 14987 end; 14988 14989 -- If original node uses selected component notation, the prefix is 14990 -- visible and determines the scope that must be elaborated. After 14991 -- rewriting, the prefix is the first actual in the call. 14992 14993 elsif Nkind (Original_Node (Call)) = N_Selected_Component then 14994 Elab_Unit := Scope (Etype (First (Parameter_Associations (Call)))); 14995 14996 -- Not one of special cases above 14997 14998 else 14999 -- Using previously computed scope. If the elaboration check is 15000 -- done after analysis, the scope is not visible any longer, but 15001 -- must still be in the context. 15002 15003 Elab_Unit := Scop; 15004 end if; 15005 15006 Activate_Elaborate_All_Desirable (Call, Elab_Unit); 15007 Set_Suppress_Elaboration_Warnings (Elab_Unit); 15008 end Set_Elaboration_Constraint; 15009 15010 ----------------- 15011 -- Spec_Entity -- 15012 ----------------- 15013 15014 function Spec_Entity (E : Entity_Id) return Entity_Id is 15015 Decl : Node_Id; 15016 15017 begin 15018 -- Check for case of body entity 15019 -- Why is the check for E_Void needed??? 15020 15021 if Ekind_In (E, E_Void, E_Subprogram_Body, E_Package_Body) then 15022 Decl := E; 15023 15024 loop 15025 Decl := Parent (Decl); 15026 exit when Nkind (Decl) in N_Proper_Body; 15027 end loop; 15028 15029 return Corresponding_Spec (Decl); 15030 15031 else 15032 return E; 15033 end if; 15034 end Spec_Entity; 15035 15036 ------------ 15037 -- Within -- 15038 ------------ 15039 15040 function Within (E1, E2 : Entity_Id) return Boolean is 15041 Scop : Entity_Id; 15042 begin 15043 Scop := E1; 15044 loop 15045 if Scop = E2 then 15046 return True; 15047 elsif Scop = Standard_Standard then 15048 return False; 15049 else 15050 Scop := Scope (Scop); 15051 end if; 15052 end loop; 15053 end Within; 15054 15055 -------------------------- 15056 -- Within_Elaborate_All -- 15057 -------------------------- 15058 15059 function Within_Elaborate_All 15060 (Unit : Unit_Number_Type; 15061 E : Entity_Id) return Boolean 15062 is 15063 type Unit_Number_Set is array (Main_Unit .. Last_Unit) of Boolean; 15064 pragma Pack (Unit_Number_Set); 15065 15066 Seen : Unit_Number_Set := (others => False); 15067 -- Seen (X) is True after we have seen unit X in the walk. This is used 15068 -- to prevent processing the same unit more than once. 15069 15070 Result : Boolean := False; 15071 15072 procedure Helper (Unit : Unit_Number_Type); 15073 -- This helper procedure does all the work for Within_Elaborate_All. It 15074 -- walks the dependency graph, and sets Result to True if it finds an 15075 -- appropriate Elaborate_All. 15076 15077 ------------ 15078 -- Helper -- 15079 ------------ 15080 15081 procedure Helper (Unit : Unit_Number_Type) is 15082 CU : constant Node_Id := Cunit (Unit); 15083 15084 Item : Node_Id; 15085 Item2 : Node_Id; 15086 Elab_Id : Entity_Id; 15087 Par : Node_Id; 15088 15089 begin 15090 if Seen (Unit) then 15091 return; 15092 else 15093 Seen (Unit) := True; 15094 end if; 15095 15096 -- First, check for Elaborate_Alls on this unit 15097 15098 Item := First (Context_Items (CU)); 15099 while Present (Item) loop 15100 if Nkind (Item) = N_Pragma 15101 and then Pragma_Name (Item) = Name_Elaborate_All 15102 then 15103 -- Return if some previous error on the pragma itself. The 15104 -- pragma may be unanalyzed, because of a previous error, or 15105 -- if it is the context of a subunit, inherited by its parent. 15106 15107 if Error_Posted (Item) or else not Analyzed (Item) then 15108 return; 15109 end if; 15110 15111 Elab_Id := 15112 Entity 15113 (Expression (First (Pragma_Argument_Associations (Item)))); 15114 15115 if E = Elab_Id then 15116 Result := True; 15117 return; 15118 end if; 15119 15120 Par := Parent (Unit_Declaration_Node (Elab_Id)); 15121 15122 Item2 := First (Context_Items (Par)); 15123 while Present (Item2) loop 15124 if Nkind (Item2) = N_With_Clause 15125 and then Entity (Name (Item2)) = E 15126 and then not Limited_Present (Item2) 15127 then 15128 Result := True; 15129 return; 15130 end if; 15131 15132 Next (Item2); 15133 end loop; 15134 end if; 15135 15136 Next (Item); 15137 end loop; 15138 15139 -- Second, recurse on with's. We could do this as part of the above 15140 -- loop, but it's probably more efficient to have two loops, because 15141 -- the relevant Elaborate_All is likely to be on the initial unit. In 15142 -- other words, we're walking the with's breadth-first. This part is 15143 -- only necessary in the dynamic elaboration model. 15144 15145 if Dynamic_Elaboration_Checks then 15146 Item := First (Context_Items (CU)); 15147 while Present (Item) loop 15148 if Nkind (Item) = N_With_Clause 15149 and then not Limited_Present (Item) 15150 then 15151 -- Note: the following call to Get_Cunit_Unit_Number does a 15152 -- linear search, which could be slow, but it's OK because 15153 -- we're about to give a warning anyway. Also, there might 15154 -- be hundreds of units, but not millions. If it turns out 15155 -- to be a problem, we could store the Get_Cunit_Unit_Number 15156 -- in each N_Compilation_Unit node, but that would involve 15157 -- rearranging N_Compilation_Unit_Aux to make room. 15158 15159 Helper (Get_Cunit_Unit_Number (Library_Unit (Item))); 15160 15161 if Result then 15162 return; 15163 end if; 15164 end if; 15165 15166 Next (Item); 15167 end loop; 15168 end if; 15169 end Helper; 15170 15171 -- Start of processing for Within_Elaborate_All 15172 15173 begin 15174 Helper (Unit); 15175 return Result; 15176 end Within_Elaborate_All; 15177 15178end Sem_Elab; 15179