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-2020, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with ALI; use ALI; 27with Atree; use Atree; 28with Checks; use Checks; 29with Debug; use Debug; 30with Einfo; use Einfo; 31with Elists; use Elists; 32with Errout; use Errout; 33with Exp_Ch11; use Exp_Ch11; 34with Exp_Tss; use Exp_Tss; 35with Exp_Util; use Exp_Util; 36with Expander; use Expander; 37with Lib; use Lib; 38with Lib.Load; use Lib.Load; 39with Namet; use Namet; 40with Nlists; use Nlists; 41with Nmake; use Nmake; 42with Opt; use Opt; 43with Output; use Output; 44with Restrict; use Restrict; 45with Rident; use Rident; 46with Rtsfind; use Rtsfind; 47with Sem; use Sem; 48with Sem_Aux; use Sem_Aux; 49with Sem_Cat; use Sem_Cat; 50with Sem_Ch7; use Sem_Ch7; 51with Sem_Ch8; use Sem_Ch8; 52with Sem_Disp; use Sem_Disp; 53with Sem_Prag; use Sem_Prag; 54with Sem_Util; use Sem_Util; 55with Sinfo; use Sinfo; 56with Sinput; use Sinput; 57with Snames; use Snames; 58with Stand; use Stand; 59with Table; 60with Tbuild; use Tbuild; 61with Uintp; use Uintp; 62with Uname; use Uname; 63 64with GNAT; use GNAT; 65with GNAT.Dynamic_HTables; use GNAT.Dynamic_HTables; 66with GNAT.Lists; use GNAT.Lists; 67with GNAT.Sets; use GNAT.Sets; 68 69package body Sem_Elab is 70 71 ----------------------------------------- 72 -- Access-before-elaboration mechanism -- 73 ----------------------------------------- 74 75 -- The access-before-elaboration (ABE) mechanism implemented in this unit 76 -- has the following objectives: 77 -- 78 -- * Diagnose at compile time or install run-time checks to prevent ABE 79 -- access to data and behavior. 80 -- 81 -- The high-level idea is to accurately diagnose ABE issues within a 82 -- single unit because the ABE mechanism can inspect the whole unit. 83 -- As soon as the elaboration graph extends to an external unit, the 84 -- diagnostics stop because the body of the unit may not be available. 85 -- Due to control and data flow, the ABE mechanism cannot accurately 86 -- determine whether a particular scenario will be elaborated or not. 87 -- Conditional ABE checks are therefore used to verify the elaboration 88 -- status of local and external targets at run time. 89 -- 90 -- * Supply implicit elaboration dependencies for a unit to binde 91 -- 92 -- The ABE mechanism creates implicit dependencies in the form of with 93 -- clauses subject to pragma Elaborate[_All] when the elaboration graph 94 -- reaches into an external unit. The implicit dependencies are encoded 95 -- in the ALI file of the main unit. GNATbind and binde then use these 96 -- dependencies to augment the library item graph and determine the 97 -- elaboration order of all units in the compilation. 98 -- 99 -- * Supply pieces of the invocation graph for a unit to bindo 100 -- 101 -- The ABE mechanism captures paths starting from elaboration code or 102 -- top level constructs that reach into an external unit. The paths are 103 -- encoded in the ALI file of the main unit in the form of declarations 104 -- which represent nodes, and relations which represent edges. GNATbind 105 -- and bindo then build the full invocation graph in order to augment 106 -- the library item graph and determine the elaboration order of all 107 -- units in the compilation. 108 -- 109 -- The ABE mechanism supports three models of elaboration: 110 -- 111 -- * Dynamic model - This is the most permissive of the three models. 112 -- When the dynamic model is in effect, the mechanism diagnoses and 113 -- installs run-time checks to detect ABE issues in the main unit. 114 -- The behavior of this model is identical to that specified by the 115 -- Ada RM. This model is enabled with switch -gnatE. 116 -- 117 -- Static model - This is the middle ground of the three models. When 118 -- the static model is in effect, the mechanism diagnoses and installs 119 -- run-time checks to detect ABE issues in the main unit. In addition, 120 -- the mechanism generates implicit dependencies between units in the 121 -- form of with clauses subject to pragma Elaborate[_All] to ensure 122 -- the prior elaboration of withed units. This is the default model. 123 -- 124 -- * SPARK model - This is the most conservative of the three models and 125 -- implements the semantics defined in SPARK RM 7.7. The SPARK model 126 -- is in effect only when a context resides in a SPARK_Mode On region, 127 -- otherwise the mechanism falls back to one of the previous models. 128 -- 129 -- The ABE mechanism consists of a "recording" phase and a "processing" 130 -- phase. 131 132 ----------------- 133 -- Terminology -- 134 ----------------- 135 136 -- * ABE - An attempt to invoke a scenario which has not been elaborated 137 -- yet. 138 -- 139 -- * Bridge target - A type of target. A bridge target is a link between 140 -- scenarios. It is usually a byproduct of expansion and does not have 141 -- any direct ABE ramifications. 142 -- 143 -- * Call marker - A special node used to indicate the presence of a call 144 -- in the tree in case expansion transforms or eliminates the original 145 -- call. N_Call_Marker nodes do not have static and run-time semantics. 146 -- 147 -- * Conditional ABE - A type of ABE. A conditional ABE occurs when the 148 -- invocation of a target by a scenario within the main unit causes an 149 -- ABE, but does not cause an ABE for another scenarios within the main 150 -- unit. 151 -- 152 -- * Declaration level - A type of enclosing level. A scenario or target is 153 -- at the declaration level when it appears within the declarations of a 154 -- block statement, entry body, subprogram body, or task body, ignoring 155 -- enclosing packages. 156 -- 157 -- * Early call region - A section of code which ends at a subprogram body 158 -- and starts from the nearest non-preelaborable construct which precedes 159 -- the subprogram body. The early call region extends from a package body 160 -- to a package spec when the spec carries pragma Elaborate_Body. 161 -- 162 -- * Generic library level - A type of enclosing level. A scenario or 163 -- target is at the generic library level if it appears in a generic 164 -- package library unit, ignoring enclosing packages. 165 -- 166 -- * Guaranteed ABE - A type of ABE. A guaranteed ABE occurs when the 167 -- invocation of a target by all scenarios within the main unit causes 168 -- an ABE. 169 -- 170 -- * Instantiation library level - A type of enclosing level. A scenario 171 -- or target is at the instantiation library level if it appears in an 172 -- instantiation library unit, ignoring enclosing packages. 173 -- 174 -- * Invocation - The act of activating a task, calling a subprogram, or 175 -- instantiating a generic. 176 -- 177 -- * Invocation construct - An entry declaration, [single] protected type, 178 -- subprogram declaration, subprogram instantiation, or a [single] task 179 -- type declared in the visible, private, or body declarations of the 180 -- main unit. 181 -- 182 -- * Invocation relation - A flow link between two invocation constructs 183 -- 184 -- * Invocation signature - A set of attributes that uniquely identify an 185 -- invocation construct within the namespace of all ALI files. 186 -- 187 -- * Library level - A type of enclosing level. A scenario or target is at 188 -- the library level if it appears in a package library unit, ignoring 189 -- enclosing packages. 190 -- 191 -- * Non-library-level encapsulator - A construct that cannot be elaborated 192 -- on its own and requires elaboration by a top-level scenario. 193 -- 194 -- * Scenario - A construct or context which is invoked by elaboration code 195 -- or invocation construct. The scenarios recognized by the ABE mechanism 196 -- are as follows: 197 -- 198 -- - '[Unrestricted_]Access of entries, operators, and subprograms 199 -- 200 -- - Assignments to variables 201 -- 202 -- - Calls to entries, operators, and subprograms 203 -- 204 -- - Derived type declarations 205 -- 206 -- - Instantiations 207 -- 208 -- - Pragma Refined_State 209 -- 210 -- - Reads of variables 211 -- 212 -- - Task activation 213 -- 214 -- * Target - A construct invoked by a scenario. The targets recognized by 215 -- the ABE mechanism are as follows: 216 -- 217 -- - For '[Unrestricted_]Access of entries, operators, and subprograms, 218 -- the target is the entry, operator, or subprogram. 219 -- 220 -- - For assignments to variables, the target is the variable 221 -- 222 -- - For calls, the target is the entry, operator, or subprogram 223 -- 224 -- - For derived type declarations, the target is the derived type 225 -- 226 -- - For instantiations, the target is the generic template 227 -- 228 -- - For pragma Refined_State, the targets are the constituents 229 -- 230 -- - For reads of variables, the target is the variable 231 -- 232 -- - For task activation, the target is the task body 233 234 ------------------ 235 -- Architecture -- 236 ------------------ 237 238 -- Analysis/Resolution 239 -- | 240 -- +- Build_Call_Marker 241 -- | 242 -- +- Build_Variable_Reference_Marker 243 -- | 244 -- +- | -------------------- Recording phase ---------------------------+ 245 -- | v | 246 -- | Record_Elaboration_Scenario | 247 -- | | | 248 -- | +--> Check_Preelaborated_Call | 249 -- | | | 250 -- | +--> Process_Guaranteed_ABE | 251 -- | | | | 252 -- | | +--> Process_Guaranteed_ABE_Activation | 253 -- | | +--> Process_Guaranteed_ABE_Call | 254 -- | | +--> Process_Guaranteed_ABE_Instantiation | 255 -- | | | 256 -- +- | ----------------------------------------------------------------+ 257 -- | 258 -- | 259 -- +--> Internal_Representation 260 -- | 261 -- +--> Scenario_Storage 262 -- | 263 -- End of Compilation 264 -- | 265 -- +- | --------------------- Processing phase -------------------------+ 266 -- | v | 267 -- | Check_Elaboration_Scenarios | 268 -- | | | 269 -- | +--> Check_Conditional_ABE_Scenarios | 270 -- | | | | 271 -- | | +--> Process_Conditional_ABE <----------------------+ | 272 -- | | | | | 273 -- | | +--> Process_Conditional_ABE_Activation | | 274 -- | | | | | | 275 -- | | | +-----------------------------+ | | 276 -- | | | | | | 277 -- | | +--> Process_Conditional_ABE_Call +---> Traverse_Body | 278 -- | | | | | | 279 -- | | | +-----------------------------+ | 280 -- | | | | 281 -- | | +--> Process_Conditional_ABE_Access_Taken | 282 -- | | +--> Process_Conditional_ABE_Instantiation | 283 -- | | +--> Process_Conditional_ABE_Variable_Assignment | 284 -- | | +--> Process_Conditional_ABE_Variable_Reference | 285 -- | | | 286 -- | +--> Check_SPARK_Scenario | 287 -- | | | | 288 -- | | +--> Process_SPARK_Scenario | 289 -- | | | | 290 -- | | +--> Process_SPARK_Derived_Type | 291 -- | | +--> Process_SPARK_Instantiation | 292 -- | | +--> Process_SPARK_Refined_State_Pragma | 293 -- | | | 294 -- | +--> Record_Invocation_Graph | 295 -- | | | 296 -- | +--> Process_Invocation_Body_Scenarios | 297 -- | +--> Process_Invocation_Spec_Scenarios | 298 -- | +--> Process_Main_Unit | 299 -- | | | 300 -- | +--> Process_Invocation_Scenario <-------------+ | 301 -- | | | | 302 -- | +--> Process_Invocation_Activation | | 303 -- | | | | | 304 -- | | +------------------------+ | | 305 -- | | | | | 306 -- | +--> Process_Invocation_Call +---> Traverse_Body | 307 -- | | | | 308 -- | +------------------------+ | 309 -- | | 310 -- +--------------------------------------------------------------------+ 311 312 --------------------- 313 -- Recording phase -- 314 --------------------- 315 316 -- The Recording phase coincides with the analysis/resolution phase of the 317 -- compiler. It has the following objectives: 318 -- 319 -- * Record all suitable scenarios for examination by the Processing 320 -- phase. 321 -- 322 -- Saving only a certain number of nodes improves the performance of 323 -- the ABE mechanism. This eliminates the need to examine the whole 324 -- tree in a separate pass. 325 -- 326 -- * Record certain SPARK scenarios which are not necessarily invoked 327 -- during elaboration, but still require elaboration-related checks. 328 -- 329 -- Saving only a certain number of nodes improves the performance of 330 -- the ABE mechanism. This eliminates the need to examine the whole 331 -- tree in a separate pass. 332 -- 333 -- * Detect and diagnose calls in preelaborable or pure units, including 334 -- generic bodies. 335 -- 336 -- This diagnostic is carried out during the Recording phase because it 337 -- does not need the heavy recursive traversal done by the Processing 338 -- phase. 339 -- 340 -- * Detect and diagnose guaranteed ABEs caused by instantiations, calls, 341 -- and task activation. 342 -- 343 -- The issues detected by the ABE mechanism are reported as warnings 344 -- because they do not violate Ada semantics. Forward instantiations 345 -- may thus reach gigi, however gigi cannot handle certain kinds of 346 -- premature instantiations and may crash. To avoid this limitation, 347 -- the ABE mechanism must identify forward instantiations as early as 348 -- possible and suppress their bodies. Calls and task activations are 349 -- included in this category for completeness. 350 351 ---------------------- 352 -- Processing phase -- 353 ---------------------- 354 355 -- The Processing phase is a separate pass which starts after instantiating 356 -- and/or inlining of bodies, but before the removal of Ghost code. It has 357 -- the following objectives: 358 -- 359 -- * Examine all scenarios saved during the Recording phase, and perform 360 -- the following actions: 361 -- 362 -- - Dynamic model 363 -- 364 -- Diagnose conditional ABEs, and install run-time conditional ABE 365 -- checks for all scenarios. 366 -- 367 -- - SPARK model 368 -- 369 -- Enforce the SPARK elaboration rules 370 -- 371 -- - Static model 372 -- 373 -- Diagnose conditional ABEs, install run-time conditional ABE 374 -- checks only for scenarios are reachable from elaboration code, 375 -- and guarantee the elaboration of external units by creating 376 -- implicit with clauses subject to pragma Elaborate[_All]. 377 -- 378 -- * Examine library-level scenarios and invocation constructs, and 379 -- perform the following actions: 380 -- 381 -- - Determine whether the flow of execution reaches into an external 382 -- unit. If this is the case, encode the path in the ALI file of 383 -- the main unit. 384 -- 385 -- - Create declarations for invocation constructs in the ALI file of 386 -- the main unit. 387 388 ---------------------- 389 -- Important points -- 390 ---------------------- 391 392 -- The Processing phase starts after the analysis, resolution, expansion 393 -- phase has completed. As a result, no current semantic information is 394 -- available. The scope stack is empty, global flags such as In_Instance 395 -- or Inside_A_Generic become useless. To remedy this, the ABE mechanism 396 -- must either save or recompute semantic information. 397 -- 398 -- Expansion heavily transforms calls and to some extent instantiations. To 399 -- remedy this, the ABE mechanism generates N_Call_Marker nodes in order to 400 -- capture the target and relevant attributes of the original call. 401 -- 402 -- The diagnostics of the ABE mechanism depend on accurate source locations 403 -- to determine the spatial relation of nodes. 404 405 ----------------------------------------- 406 -- Suppression of elaboration warnings -- 407 ----------------------------------------- 408 409 -- Elaboration warnings along multiple traversal paths rooted at a scenario 410 -- are suppressed when the scenario has elaboration warnings suppressed. 411 -- 412 -- Root scenario 413 -- | 414 -- +-- Child scenario 1 415 -- | | 416 -- | +-- Grandchild scenario 1 417 -- | | 418 -- | +-- Grandchild scenario N 419 -- | 420 -- +-- Child scenario N 421 -- 422 -- If the root scenario has elaboration warnings suppressed, then all its 423 -- child, grandchild, etc. scenarios will have their elaboration warnings 424 -- suppressed. 425 -- 426 -- In addition to switch -gnatwL, pragma Warnings may be used to suppress 427 -- elaboration-related warnings when used in the following manner: 428 -- 429 -- pragma Warnings ("L"); 430 -- <scenario-or-target> 431 -- 432 -- <target> 433 -- pragma Warnings (Off, target); 434 -- 435 -- pragma Warnings (Off); 436 -- <scenario-or-target> 437 -- 438 -- * To suppress elaboration warnings for '[Unrestricted_]Access of 439 -- entries, operators, and subprograms, either: 440 -- 441 -- - Suppress the entry, operator, or subprogram, or 442 -- - Suppress the attribute, or 443 -- - Use switch -gnatw.f 444 -- 445 -- * To suppress elaboration warnings for calls to entries, operators, 446 -- and subprograms, either: 447 -- 448 -- - Suppress the entry, operator, or subprogram, or 449 -- - Suppress the call 450 -- 451 -- * To suppress elaboration warnings for instantiations, suppress the 452 -- instantiation. 453 -- 454 -- * To suppress elaboration warnings for task activations, either: 455 -- 456 -- - Suppress the task object, or 457 -- - Suppress the task type, or 458 -- - Suppress the activation call 459 460 -------------- 461 -- Switches -- 462 -------------- 463 464 -- The following switches may be used to control the behavior of the ABE 465 -- mechanism. 466 -- 467 -- -gnatd_a stop elaboration checks on accept or select statement 468 -- 469 -- The ABE mechanism stops the traversal of a task body when it 470 -- encounters an accept or a select statement. This behavior is 471 -- equivalent to restriction No_Entry_Calls_In_Elaboration_Code, 472 -- but without penalizing actual entry calls during elaboration. 473 -- 474 -- -gnatd_e ignore entry calls and requeue statements for elaboration 475 -- 476 -- The ABE mechanism does not generate N_Call_Marker nodes for 477 -- protected or task entry calls as well as requeue statements. 478 -- As a result, the calls and requeues are not recorded or 479 -- processed. 480 -- 481 -- -gnatdE elaboration checks on predefined units 482 -- 483 -- The ABE mechanism considers scenarios which appear in internal 484 -- units (Ada, GNAT, Interfaces, System). 485 -- 486 -- -gnatd_F encode full invocation paths in ALI files 487 -- 488 -- The ABE mechanism encodes the full path from an elaboration 489 -- procedure or invocable construct to an external target. The 490 -- path contains all intermediate activations, instantiations, 491 -- and calls. 492 -- 493 -- -gnatd.G ignore calls through generic formal parameters for elaboration 494 -- 495 -- The ABE mechanism does not generate N_Call_Marker nodes for 496 -- calls which occur in expanded instances, and invoke generic 497 -- actual subprograms through generic formal subprograms. As a 498 -- result, the calls are not recorded or processed. 499 -- 500 -- -gnatd_i ignore activations and calls to instances for elaboration 501 -- 502 -- The ABE mechanism ignores calls and task activations when they 503 -- target a subprogram or task type defined an external instance. 504 -- As a result, the calls and task activations are not processed. 505 -- 506 -- -gnatdL ignore external calls from instances for elaboration 507 -- 508 -- The ABE mechanism does not generate N_Call_Marker nodes for 509 -- calls which occur in expanded instances, do not invoke generic 510 -- actual subprograms through formal subprograms, and the target 511 -- is external to the instance. As a result, the calls are not 512 -- recorded or processed. 513 -- 514 -- -gnatd.o conservative elaboration order for indirect calls 515 -- 516 -- The ABE mechanism treats '[Unrestricted_]Access of an entry, 517 -- operator, or subprogram as an immediate invocation of the 518 -- target. As a result, it performs ABE checks and diagnostics on 519 -- the immediate call. 520 -- 521 -- -gnatd_p ignore assertion pragmas for elaboration 522 -- 523 -- The ABE mechanism does not generate N_Call_Marker nodes for 524 -- calls to subprograms which verify the run-time semantics of 525 -- the following assertion pragmas: 526 -- 527 -- Default_Initial_Condition 528 -- Initial_Condition 529 -- Invariant 530 -- Invariant'Class 531 -- Post 532 -- Post'Class 533 -- Postcondition 534 -- Type_Invariant 535 -- Type_Invariant_Class 536 -- 537 -- As a result, the assertion expressions of the pragmas are not 538 -- processed. 539 -- 540 -- -gnatd_s stop elaboration checks on synchronous suspension 541 -- 542 -- The ABE mechanism stops the traversal of a task body when it 543 -- encounters a call to one of the following routines: 544 -- 545 -- Ada.Synchronous_Barriers.Wait_For_Release 546 -- Ada.Synchronous_Task_Control.Suspend_Until_True 547 -- 548 -- -gnatd_T output trace information on invocation relation construction 549 -- 550 -- The ABE mechanism outputs text information concerning relation 551 -- construction to standard output. 552 -- 553 -- -gnatd.U ignore indirect calls for static elaboration 554 -- 555 -- The ABE mechanism does not consider '[Unrestricted_]Access of 556 -- entries, operators, and subprograms. As a result, the scenarios 557 -- are not recorder or processed. 558 -- 559 -- -gnatd.v enforce SPARK elaboration rules in SPARK code 560 -- 561 -- The ABE mechanism applies some of the SPARK elaboration rules 562 -- defined in the SPARK reference manual, chapter 7.7. Note that 563 -- certain rules are always enforced, regardless of whether the 564 -- switch is active. 565 -- 566 -- -gnatd.y disable implicit pragma Elaborate_All on task bodies 567 -- 568 -- The ABE mechanism does not generate implicit Elaborate_All when 569 -- the need for the pragma came from a task body. 570 -- 571 -- -gnatE dynamic elaboration checking mode enabled 572 -- 573 -- The ABE mechanism assumes that any scenario is elaborated or 574 -- invoked by elaboration code. The ABE mechanism performs very 575 -- little diagnostics and generates condintional ABE checks to 576 -- detect ABE issues at run-time. 577 -- 578 -- -gnatel turn on info messages on generated Elaborate[_All] pragmas 579 -- 580 -- The ABE mechanism produces information messages on generated 581 -- implicit Elabote[_All] pragmas along with traceback showing 582 -- why the pragma was generated. In addition, the ABE mechanism 583 -- produces information messages for each scenario elaborated or 584 -- invoked by elaboration code. 585 -- 586 -- -gnateL turn off info messages on generated Elaborate[_All] pragmas 587 -- 588 -- The complementary switch for -gnatel. 589 -- 590 -- -gnatH legacy elaboration checking mode enabled 591 -- 592 -- When this switch is in effect, the pre-18.x ABE model becomes 593 -- the de facto ABE model. This amounts to cutting off all entry 594 -- points into the new ABE mechanism, and giving full control to 595 -- the old ABE mechanism. 596 -- 597 -- -gnatJ permissive elaboration checking mode enabled 598 -- 599 -- This switch activates the following switches: 600 -- 601 -- -gnatd_a 602 -- -gnatd_e 603 -- -gnatd.G 604 -- -gnatd_i 605 -- -gnatdL 606 -- -gnatd_p 607 -- -gnatd_s 608 -- -gnatd.U 609 -- -gnatd.y 610 -- 611 -- IMPORTANT: The behavior of the ABE mechanism becomes more 612 -- permissive at the cost of accurate diagnostics and runtime 613 -- ABE checks. 614 -- 615 -- -gnatw.f turn on warnings for suspicious Subp'Access 616 -- 617 -- The ABE mechanism treats '[Unrestricted_]Access of an entry, 618 -- operator, or subprogram as a pseudo invocation of the target. 619 -- As a result, it performs ABE diagnostics on the pseudo call. 620 -- 621 -- -gnatw.F turn off warnings for suspicious Subp'Access 622 -- 623 -- The complementary switch for -gnatw.f. 624 -- 625 -- -gnatwl turn on warnings for elaboration problems 626 -- 627 -- The ABE mechanism produces warnings on detected ABEs along with 628 -- a traceback showing the graph of the ABE. 629 -- 630 -- -gnatwL turn off warnings for elaboration problems 631 -- 632 -- The complementary switch for -gnatwl. 633 634 -------------------------- 635 -- Debugging ABE issues -- 636 -------------------------- 637 638 -- * If the issue involves a call, ensure that the call is eligible for ABE 639 -- processing and receives a corresponding call marker. The routines of 640 -- interest are 641 -- 642 -- Build_Call_Marker 643 -- Record_Elaboration_Scenario 644 -- 645 -- * If the issue involves an arbitrary scenario, ensure that the scenario 646 -- is either recorded, or is successfully recognized while traversing a 647 -- body. The routines of interest are 648 -- 649 -- Record_Elaboration_Scenario 650 -- Process_Conditional_ABE 651 -- Process_Guaranteed_ABE 652 -- Traverse_Body 653 -- 654 -- * If the issue involves a circularity in the elaboration order, examine 655 -- the ALI files and look for the following encodings next to units: 656 -- 657 -- E indicates a source Elaborate 658 -- 659 -- EA indicates a source Elaborate_All 660 -- 661 -- AD indicates an implicit Elaborate_All 662 -- 663 -- ED indicates an implicit Elaborate 664 -- 665 -- If possible, compare these encodings with those generated by the old 666 -- ABE mechanism. The routines of interest are 667 -- 668 -- Ensure_Prior_Elaboration 669 670 ----------- 671 -- Kinds -- 672 ----------- 673 674 -- The following type enumerates all possible elaboration phase statutes 675 676 type Elaboration_Phase_Status is 677 (Inactive, 678 -- The elaboration phase of the compiler has not started yet 679 680 Active, 681 -- The elaboration phase of the compiler is currently in progress 682 683 Completed); 684 -- The elaboration phase of the compiler has finished 685 686 Elaboration_Phase : Elaboration_Phase_Status := Inactive; 687 -- The status of the elaboration phase. Use routine Set_Elaboration_Phase 688 -- to alter its value. 689 690 -- The following type enumerates all subprogram body traversal modes 691 692 type Body_Traversal_Kind is 693 (Deep_Traversal, 694 -- The traversal examines the internals of a subprogram 695 696 No_Traversal); 697 698 -- The following type enumerates all operation modes 699 700 type Processing_Kind is 701 (Conditional_ABE_Processing, 702 -- The ABE mechanism detects and diagnoses conditional ABEs for library 703 -- and declaration-level scenarios. 704 705 Dynamic_Model_Processing, 706 -- The ABE mechanism installs conditional ABE checks for all eligible 707 -- scenarios when the dynamic model is in effect. 708 709 Guaranteed_ABE_Processing, 710 -- The ABE mechanism detects and diagnoses guaranteed ABEs caused by 711 -- calls, instantiations, and task activations. 712 713 Invocation_Construct_Processing, 714 -- The ABE mechanism locates all invocation constructs within the main 715 -- unit and utilizes them as roots of miltiple DFS traversals aimed at 716 -- detecting transitions from the main unit to an external unit. 717 718 Invocation_Body_Processing, 719 -- The ABE mechanism utilizes all library-level body scenarios as roots 720 -- of miltiple DFS traversals aimed at detecting transitions from the 721 -- main unit to an external unit. 722 723 Invocation_Spec_Processing, 724 -- The ABE mechanism utilizes all library-level spec scenarios as roots 725 -- of miltiple DFS traversals aimed at detecting transitions from the 726 -- main unit to an external unit. 727 728 SPARK_Processing, 729 -- The ABE mechanism detects and diagnoses violations of the SPARK 730 -- elaboration rules for SPARK-specific scenarios. 731 732 No_Processing); 733 734 -- The following type enumerates all possible scenario kinds 735 736 type Scenario_Kind is 737 (Access_Taken_Scenario, 738 -- An attribute reference which takes 'Access or 'Unrestricted_Access of 739 -- an entry, operator, or subprogram. 740 741 Call_Scenario, 742 -- A call which invokes an entry, operator, or subprogram 743 744 Derived_Type_Scenario, 745 -- A declaration of a derived type. This is a SPARK-specific scenario. 746 747 Instantiation_Scenario, 748 -- An instantiation which instantiates a generic package or subprogram. 749 -- This scenario is also subject to SPARK-specific rules. 750 751 Refined_State_Pragma_Scenario, 752 -- A Refined_State pragma. This is a SPARK-specific scenario. 753 754 Task_Activation_Scenario, 755 -- A call which activates objects of various task types 756 757 Variable_Assignment_Scenario, 758 -- An assignment statement which modifies the value of some variable 759 760 Variable_Reference_Scenario, 761 -- A reference to a variable. This is a SPARK-specific scenario. 762 763 No_Scenario); 764 765 -- The following type enumerates all possible consistency models of target 766 -- and scenario representations. 767 768 type Representation_Kind is 769 (Inconsistent_Representation, 770 -- A representation is said to be "inconsistent" when it is created from 771 -- a partially analyzed tree. In such an environment, certain attributes 772 -- such as a completing body may not be available yet. 773 774 Consistent_Representation, 775 -- A representation is said to be "consistent" when it is created from a 776 -- fully analyzed tree, where all attributes are available. 777 778 No_Representation); 779 780 -- The following type enumerates all possible target kinds 781 782 type Target_Kind is 783 (Generic_Target, 784 -- A generic unit being instantiated 785 786 Package_Target, 787 -- The package form of an instantiation 788 789 Subprogram_Target, 790 -- An entry, operator, or subprogram being invoked, or aliased through 791 -- 'Access or 'Unrestricted_Access. 792 793 Task_Target, 794 -- A task being activated by an activation call 795 796 Variable_Target, 797 -- A variable being updated through an assignment statement, or read 798 -- through a variable reference. 799 800 No_Target); 801 802 ----------- 803 -- Types -- 804 ----------- 805 806 procedure Destroy (NE : in out Node_Or_Entity_Id); 807 pragma Inline (Destroy); 808 -- Destroy node or entity NE 809 810 function Hash (NE : Node_Or_Entity_Id) return Bucket_Range_Type; 811 pragma Inline (Hash); 812 -- Obtain the hash value of key NE 813 814 -- The following is a general purpose list for nodes and entities 815 816 package NE_List is new Doubly_Linked_Lists 817 (Element_Type => Node_Or_Entity_Id, 818 "=" => "=", 819 Destroy_Element => Destroy); 820 821 -- The following is a general purpose map which relates nodes and entities 822 -- to lists of nodes and entities. 823 824 package NE_List_Map is new Dynamic_Hash_Tables 825 (Key_Type => Node_Or_Entity_Id, 826 Value_Type => NE_List.Doubly_Linked_List, 827 No_Value => NE_List.Nil, 828 Expansion_Threshold => 1.5, 829 Expansion_Factor => 2, 830 Compression_Threshold => 0.3, 831 Compression_Factor => 2, 832 "=" => "=", 833 Destroy_Value => NE_List.Destroy, 834 Hash => Hash); 835 836 -- The following is a general purpose membership set for nodes and entities 837 838 package NE_Set is new Membership_Sets 839 (Element_Type => Node_Or_Entity_Id, 840 "=" => "=", 841 Hash => Hash); 842 843 -- The following type captures relevant attributes which pertain to the 844 -- in state of the Processing phase. 845 846 type Processing_In_State is record 847 Processing : Processing_Kind := No_Processing; 848 -- Operation mode of the Processing phase. Once set, this value should 849 -- not be changed. 850 851 Representation : Representation_Kind := No_Representation; 852 -- Required level of scenario and target representation. Once set, this 853 -- value should not be changed. 854 855 Suppress_Checks : Boolean := False; 856 -- This flag is set when the Processing phase must not generate any ABE 857 -- checks. 858 859 Suppress_Implicit_Pragmas : Boolean := False; 860 -- This flag is set when the Processing phase must not generate any 861 -- implicit Elaborate[_All] pragmas. 862 863 Suppress_Info_Messages : Boolean := False; 864 -- This flag is set when the Processing phase must not emit any info 865 -- messages. 866 867 Suppress_Up_Level_Targets : Boolean := False; 868 -- This flag is set when the Processing phase must ignore up-level 869 -- targets. 870 871 Suppress_Warnings : Boolean := False; 872 -- This flag is set when the Processing phase must not emit any warnings 873 -- on elaboration problems. 874 875 Traversal : Body_Traversal_Kind := No_Traversal; 876 -- The subprogram body traversal mode. Once set, this value should not 877 -- be changed. 878 879 Within_Generic : Boolean := False; 880 -- This flag is set when the Processing phase is currently within a 881 -- generic unit. 882 883 Within_Initial_Condition : Boolean := False; 884 -- This flag is set when the Processing phase is currently examining a 885 -- scenario which was reached from an initial condition procedure. 886 887 Within_Partial_Finalization : Boolean := False; 888 -- This flag is set when the Processing phase is currently examining a 889 -- scenario which was reached from a partial finalization procedure. 890 891 Within_Task_Body : Boolean := False; 892 -- This flag is set when the Processing phase is currently examining a 893 -- scenario which was reached from a task body. 894 end record; 895 896 -- The following constants define the various operational states of the 897 -- Processing phase. 898 899 -- The conditional ABE state is used when processing scenarios that appear 900 -- at the declaration, instantiation, and library levels to detect errors 901 -- and install conditional ABE checks. 902 903 Conditional_ABE_State : constant Processing_In_State := 904 (Processing => Conditional_ABE_Processing, 905 Representation => Consistent_Representation, 906 Traversal => Deep_Traversal, 907 others => False); 908 909 -- The dynamic model state is used to install conditional ABE checks when 910 -- switch -gnatE (dynamic elaboration checking mode enabled) is in effect. 911 912 Dynamic_Model_State : constant Processing_In_State := 913 (Processing => Dynamic_Model_Processing, 914 Representation => Consistent_Representation, 915 Suppress_Implicit_Pragmas => True, 916 Suppress_Info_Messages => True, 917 Suppress_Up_Level_Targets => True, 918 Suppress_Warnings => True, 919 Traversal => No_Traversal, 920 others => False); 921 922 -- The guaranteed ABE state is used when processing scenarios that appear 923 -- at the declaration, instantiation, and library levels to detect errors 924 -- and install guarateed ABE failures. 925 926 Guaranteed_ABE_State : constant Processing_In_State := 927 (Processing => Guaranteed_ABE_Processing, 928 Representation => Inconsistent_Representation, 929 Suppress_Implicit_Pragmas => True, 930 Traversal => No_Traversal, 931 others => False); 932 933 -- The invocation body state is used when processing scenarios that appear 934 -- at the body library level to encode paths that start from elaboration 935 -- code and ultimately reach into external units. 936 937 Invocation_Body_State : constant Processing_In_State := 938 (Processing => Invocation_Body_Processing, 939 Representation => Consistent_Representation, 940 Suppress_Checks => True, 941 Suppress_Implicit_Pragmas => True, 942 Suppress_Info_Messages => True, 943 Suppress_Up_Level_Targets => True, 944 Suppress_Warnings => True, 945 Traversal => Deep_Traversal, 946 others => False); 947 948 -- The invocation construct state is used when processing constructs that 949 -- appear within the spec and body of the main unit and eventually reach 950 -- into external units. 951 952 Invocation_Construct_State : constant Processing_In_State := 953 (Processing => Invocation_Construct_Processing, 954 Representation => Consistent_Representation, 955 Suppress_Checks => True, 956 Suppress_Implicit_Pragmas => True, 957 Suppress_Info_Messages => True, 958 Suppress_Up_Level_Targets => True, 959 Suppress_Warnings => True, 960 Traversal => Deep_Traversal, 961 others => False); 962 963 -- The invocation spec state is used when processing scenarios that appear 964 -- at the spec library level to encode paths that start from elaboration 965 -- code and ultimately reach into external units. 966 967 Invocation_Spec_State : constant Processing_In_State := 968 (Processing => Invocation_Spec_Processing, 969 Representation => Consistent_Representation, 970 Suppress_Checks => True, 971 Suppress_Implicit_Pragmas => True, 972 Suppress_Info_Messages => True, 973 Suppress_Up_Level_Targets => True, 974 Suppress_Warnings => True, 975 Traversal => Deep_Traversal, 976 others => False); 977 978 -- The SPARK state is used when verying SPARK-specific semantics of certain 979 -- scenarios. 980 981 SPARK_State : constant Processing_In_State := 982 (Processing => SPARK_Processing, 983 Representation => Consistent_Representation, 984 Traversal => No_Traversal, 985 others => False); 986 987 -- The following type identifies a scenario representation 988 989 type Scenario_Rep_Id is new Natural; 990 991 No_Scenario_Rep : constant Scenario_Rep_Id := Scenario_Rep_Id'First; 992 First_Scenario_Rep : constant Scenario_Rep_Id := No_Scenario_Rep + 1; 993 994 -- The following type identifies a target representation 995 996 type Target_Rep_Id is new Natural; 997 998 No_Target_Rep : constant Target_Rep_Id := Target_Rep_Id'First; 999 First_Target_Rep : constant Target_Rep_Id := No_Target_Rep + 1; 1000 1001 -------------- 1002 -- Services -- 1003 -------------- 1004 1005 -- The following package keeps track of all active scenarios during a DFS 1006 -- traversal. 1007 1008 package Active_Scenarios is 1009 1010 ----------- 1011 -- Types -- 1012 ----------- 1013 1014 -- The following type defines the position within the active scenario 1015 -- stack. 1016 1017 type Active_Scenario_Pos is new Natural; 1018 1019 --------------------- 1020 -- Data structures -- 1021 --------------------- 1022 1023 -- The following table stores all active scenarios in a DFS traversal. 1024 -- This table must be maintained in a FIFO fashion. 1025 1026 package Active_Scenario_Stack is new Table.Table 1027 (Table_Index_Type => Active_Scenario_Pos, 1028 Table_Component_Type => Node_Id, 1029 Table_Low_Bound => 1, 1030 Table_Initial => 50, 1031 Table_Increment => 200, 1032 Table_Name => "Active_Scenario_Stack"); 1033 1034 --------- 1035 -- API -- 1036 --------- 1037 1038 procedure Output_Active_Scenarios 1039 (Error_Nod : Node_Id; 1040 In_State : Processing_In_State); 1041 pragma Inline (Output_Active_Scenarios); 1042 -- Output the contents of the active scenario stack from earliest to 1043 -- latest to supplement an earlier error emitted for node Error_Nod. 1044 -- In_State denotes the current state of the Processing phase. 1045 1046 procedure Pop_Active_Scenario (N : Node_Id); 1047 pragma Inline (Pop_Active_Scenario); 1048 -- Pop the top of the scenario stack. A check is made to ensure that the 1049 -- scenario being removed is the same as N. 1050 1051 procedure Push_Active_Scenario (N : Node_Id); 1052 pragma Inline (Push_Active_Scenario); 1053 -- Push scenario N on top of the scenario stack 1054 1055 function Root_Scenario return Node_Id; 1056 pragma Inline (Root_Scenario); 1057 -- Return the scenario which started a DFS traversal 1058 1059 end Active_Scenarios; 1060 use Active_Scenarios; 1061 1062 -- The following package provides the main entry point for task activation 1063 -- processing. 1064 1065 package Activation_Processor is 1066 1067 ----------- 1068 -- Types -- 1069 ----------- 1070 1071 type Activation_Processor_Ptr is access procedure 1072 (Call : Node_Id; 1073 Call_Rep : Scenario_Rep_Id; 1074 Obj_Id : Entity_Id; 1075 Obj_Rep : Target_Rep_Id; 1076 Task_Typ : Entity_Id; 1077 Task_Rep : Target_Rep_Id; 1078 In_State : Processing_In_State); 1079 -- Reference to a procedure that takes all attributes of an activation 1080 -- and performs a desired action. Call is the activation call. Call_Rep 1081 -- is the representation of the call. Obj_Id is the task object being 1082 -- activated. Obj_Rep is the representation of the object. Task_Typ is 1083 -- the task type whose body is being activated. Task_Rep denotes the 1084 -- representation of the task type. In_State is the current state of 1085 -- the Processing phase. 1086 1087 --------- 1088 -- API -- 1089 --------- 1090 1091 procedure Process_Activation 1092 (Call : Node_Id; 1093 Call_Rep : Scenario_Rep_Id; 1094 Processor : Activation_Processor_Ptr; 1095 In_State : Processing_In_State); 1096 -- Find all task objects activated by activation call Call and invoke 1097 -- Processor on them. Call_Rep denotes the representation of the call. 1098 -- In_State is the current state of the Processing phase. 1099 1100 end Activation_Processor; 1101 use Activation_Processor; 1102 1103 -- The following package profides functionality for traversing subprogram 1104 -- bodies in DFS manner and processing of eligible scenarios within. 1105 1106 package Body_Processor is 1107 1108 ----------- 1109 -- Types -- 1110 ----------- 1111 1112 type Scenario_Predicate_Ptr is access function 1113 (N : Node_Id) return Boolean; 1114 -- Reference to a function which determines whether arbitrary node N 1115 -- denotes a suitable scenario for processing. 1116 1117 type Scenario_Processor_Ptr is access procedure 1118 (N : Node_Id; In_State : Processing_In_State); 1119 -- Reference to a procedure which processes scenario N. In_State is the 1120 -- current state of the Processing phase. 1121 1122 --------- 1123 -- API -- 1124 --------- 1125 1126 procedure Traverse_Body 1127 (N : Node_Id; 1128 Requires_Processing : Scenario_Predicate_Ptr; 1129 Processor : Scenario_Processor_Ptr; 1130 In_State : Processing_In_State); 1131 pragma Inline (Traverse_Body); 1132 -- Traverse the declarations and handled statements of subprogram body 1133 -- N, looking for scenarios that satisfy predicate Requires_Processing. 1134 -- Routine Processor is invoked for each such scenario. 1135 1136 procedure Reset_Traversed_Bodies; 1137 pragma Inline (Reset_Traversed_Bodies); 1138 -- Reset the visited status of all subprogram bodies that have already 1139 -- been processed by routine Traverse_Body. 1140 1141 ----------------- 1142 -- Maintenance -- 1143 ----------------- 1144 1145 procedure Finalize_Body_Processor; 1146 pragma Inline (Finalize_Body_Processor); 1147 -- Finalize all internal data structures 1148 1149 procedure Initialize_Body_Processor; 1150 pragma Inline (Initialize_Body_Processor); 1151 -- Initialize all internal data structures 1152 1153 end Body_Processor; 1154 use Body_Processor; 1155 1156 -- The following package provides functionality for installing ABE-related 1157 -- checks and failures. 1158 1159 package Check_Installer is 1160 1161 --------- 1162 -- API -- 1163 --------- 1164 1165 function Check_Or_Failure_Generation_OK return Boolean; 1166 pragma Inline (Check_Or_Failure_Generation_OK); 1167 -- Determine whether a conditional ABE check or guaranteed ABE failure 1168 -- can be generated. 1169 1170 procedure Install_Dynamic_ABE_Checks; 1171 pragma Inline (Install_Dynamic_ABE_Checks); 1172 -- Install conditional ABE checks for all saved scenarios when the 1173 -- dynamic model is in effect. 1174 1175 procedure Install_Scenario_ABE_Check 1176 (N : Node_Id; 1177 Targ_Id : Entity_Id; 1178 Targ_Rep : Target_Rep_Id; 1179 Disable : Scenario_Rep_Id); 1180 pragma Inline (Install_Scenario_ABE_Check); 1181 -- Install a conditional ABE check for scenario N to ensure that target 1182 -- Targ_Id is properly elaborated. Targ_Rep is the representation of the 1183 -- target. If the check is installed, disable the elaboration checks of 1184 -- scenario Disable. 1185 1186 procedure Install_Scenario_ABE_Check 1187 (N : Node_Id; 1188 Targ_Id : Entity_Id; 1189 Targ_Rep : Target_Rep_Id; 1190 Disable : Target_Rep_Id); 1191 pragma Inline (Install_Scenario_ABE_Check); 1192 -- Install a conditional ABE check for scenario N to ensure that target 1193 -- Targ_Id is properly elaborated. Targ_Rep is the representation of the 1194 -- target. If the check is installed, disable the elaboration checks of 1195 -- target Disable. 1196 1197 procedure Install_Scenario_ABE_Failure 1198 (N : Node_Id; 1199 Targ_Id : Entity_Id; 1200 Targ_Rep : Target_Rep_Id; 1201 Disable : Scenario_Rep_Id); 1202 pragma Inline (Install_Scenario_ABE_Failure); 1203 -- Install a guaranteed ABE failure for scenario N with target Targ_Id. 1204 -- Targ_Rep denotes the representation of the target. If the failure is 1205 -- installed, disable the elaboration checks of scenario Disable. 1206 1207 procedure Install_Scenario_ABE_Failure 1208 (N : Node_Id; 1209 Targ_Id : Entity_Id; 1210 Targ_Rep : Target_Rep_Id; 1211 Disable : Target_Rep_Id); 1212 pragma Inline (Install_Scenario_ABE_Failure); 1213 -- Install a guaranteed ABE failure for scenario N with target Targ_Id. 1214 -- Targ_Rep denotes the representation of the target. If the failure is 1215 -- installed, disable the elaboration checks of target Disable. 1216 1217 procedure Install_Unit_ABE_Check 1218 (N : Node_Id; 1219 Unit_Id : Entity_Id; 1220 Disable : Scenario_Rep_Id); 1221 pragma Inline (Install_Unit_ABE_Check); 1222 -- Install a conditional ABE check for scenario N to ensure that unit 1223 -- Unit_Id is properly elaborated. If the check is installed, disable 1224 -- the elaboration checks of scenario Disable. 1225 1226 procedure Install_Unit_ABE_Check 1227 (N : Node_Id; 1228 Unit_Id : Entity_Id; 1229 Disable : Target_Rep_Id); 1230 pragma Inline (Install_Unit_ABE_Check); 1231 -- Install a conditional ABE check for scenario N to ensure that unit 1232 -- Unit_Id is properly elaborated. If the check is installed, disable 1233 -- the elaboration checks of target Disable. 1234 1235 end Check_Installer; 1236 use Check_Installer; 1237 1238 -- The following package provides the main entry point for conditional ABE 1239 -- checks and diagnostics. 1240 1241 package Conditional_ABE_Processor is 1242 1243 --------- 1244 -- API -- 1245 --------- 1246 1247 procedure Check_Conditional_ABE_Scenarios 1248 (Iter : in out NE_Set.Iterator); 1249 pragma Inline (Check_Conditional_ABE_Scenarios); 1250 -- Perform conditional ABE checks and diagnostics for all scenarios 1251 -- available through iterator Iter. 1252 1253 procedure Process_Conditional_ABE 1254 (N : Node_Id; 1255 In_State : Processing_In_State); 1256 pragma Inline (Process_Conditional_ABE); 1257 -- Perform conditional ABE checks and diagnostics for scenario N. 1258 -- In_State denotes the current state of the Processing phase. 1259 1260 end Conditional_ABE_Processor; 1261 use Conditional_ABE_Processor; 1262 1263 -- The following package provides functionality to emit errors, information 1264 -- messages, and warnings. 1265 1266 package Diagnostics is 1267 1268 --------- 1269 -- API -- 1270 --------- 1271 1272 procedure Elab_Msg_NE 1273 (Msg : String; 1274 N : Node_Id; 1275 Id : Entity_Id; 1276 Info_Msg : Boolean; 1277 In_SPARK : Boolean); 1278 pragma Inline (Elab_Msg_NE); 1279 -- Wrapper around Error_Msg_NE. Emit message Msg concerning arbitrary 1280 -- node N and entity. If flag Info_Msg is set, the routine emits an 1281 -- information message, otherwise it emits an error. If flag In_SPARK 1282 -- is set, then string " in SPARK" is added to the end of the message. 1283 1284 procedure Info_Call 1285 (Call : Node_Id; 1286 Subp_Id : Entity_Id; 1287 Info_Msg : Boolean; 1288 In_SPARK : Boolean); 1289 pragma Inline (Info_Call); 1290 -- Output information concerning call Call that invokes subprogram 1291 -- Subp_Id. When flag Info_Msg is set, the routine emits an information 1292 -- message, otherwise it emits an error. When flag In_SPARK is set, " in 1293 -- SPARK" is added to the end of the message. 1294 1295 procedure Info_Instantiation 1296 (Inst : Node_Id; 1297 Gen_Id : Entity_Id; 1298 Info_Msg : Boolean; 1299 In_SPARK : Boolean); 1300 pragma Inline (Info_Instantiation); 1301 -- Output information concerning instantiation Inst which instantiates 1302 -- generic unit Gen_Id. If flag Info_Msg is set, the routine emits an 1303 -- information message, otherwise it emits an error. If flag In_SPARK 1304 -- is set, then string " in SPARK" is added to the end of the message. 1305 1306 procedure Info_Variable_Reference 1307 (Ref : Node_Id; 1308 Var_Id : Entity_Id; 1309 Info_Msg : Boolean; 1310 In_SPARK : Boolean); 1311 pragma Inline (Info_Variable_Reference); 1312 -- Output information concerning reference Ref which mentions variable 1313 -- Var_Id. If flag Info_Msg is set, the routine emits an information 1314 -- message, otherwise it emits an error. If flag In_SPARK is set, then 1315 -- string " in SPARK" is added to the end of the message. 1316 1317 end Diagnostics; 1318 use Diagnostics; 1319 1320 -- The following package provides functionality to locate the early call 1321 -- region of a subprogram body. 1322 1323 package Early_Call_Region_Processor is 1324 1325 --------- 1326 -- API -- 1327 --------- 1328 1329 function Find_Early_Call_Region 1330 (Body_Decl : Node_Id; 1331 Assume_Elab_Body : Boolean := False; 1332 Skip_Memoization : Boolean := False) return Node_Id; 1333 pragma Inline (Find_Early_Call_Region); 1334 -- Find the start of the early call region that belongs to subprogram 1335 -- body Body_Decl as defined in SPARK RM 7.7. This routine finds the 1336 -- early call region, memoizes it, and returns it, but this behavior 1337 -- can be altered. Flag Assume_Elab_Body should be set when a package 1338 -- spec may lack pragma Elaborate_Body, but the routine must still 1339 -- examine that spec. Flag Skip_Memoization should be set when the 1340 -- routine must avoid memoizing the region. 1341 1342 ----------------- 1343 -- Maintenance -- 1344 ----------------- 1345 1346 procedure Finalize_Early_Call_Region_Processor; 1347 pragma Inline (Finalize_Early_Call_Region_Processor); 1348 -- Finalize all internal data structures 1349 1350 procedure Initialize_Early_Call_Region_Processor; 1351 pragma Inline (Initialize_Early_Call_Region_Processor); 1352 -- Initialize all internal data structures 1353 1354 end Early_Call_Region_Processor; 1355 use Early_Call_Region_Processor; 1356 1357 -- The following package provides access to the elaboration statuses of all 1358 -- units withed by the main unit. 1359 1360 package Elaborated_Units is 1361 1362 --------- 1363 -- API -- 1364 --------- 1365 1366 procedure Collect_Elaborated_Units; 1367 pragma Inline (Collect_Elaborated_Units); 1368 -- Save the elaboration statuses of all units withed by the main unit 1369 1370 procedure Ensure_Prior_Elaboration 1371 (N : Node_Id; 1372 Unit_Id : Entity_Id; 1373 Prag_Nam : Name_Id; 1374 In_State : Processing_In_State); 1375 pragma Inline (Ensure_Prior_Elaboration); 1376 -- Guarantee the elaboration of unit Unit_Id with respect to the main 1377 -- unit by either suggesting or installing an Elaborate[_All] pragma 1378 -- denoted by Prag_Nam. N denotes the related scenario. In_State is the 1379 -- current state of the Processing phase. 1380 1381 function Has_Prior_Elaboration 1382 (Unit_Id : Entity_Id; 1383 Context_OK : Boolean := False; 1384 Elab_Body_OK : Boolean := False; 1385 Same_Unit_OK : Boolean := False) return Boolean; 1386 pragma Inline (Has_Prior_Elaboration); 1387 -- Determine whether unit Unit_Id is elaborated prior to the main unit. 1388 -- If flag Context_OK is set, the routine considers the following case 1389 -- as valid prior elaboration: 1390 -- 1391 -- * Unit_Id is in the elaboration context of the main unit 1392 -- 1393 -- If flag Elab_Body_OK is set, the routine considers the following case 1394 -- as valid prior elaboration: 1395 -- 1396 -- * Unit_Id has pragma Elaborate_Body and is not the main unit 1397 -- 1398 -- If flag Same_Unit_OK is set, the routine considers the following 1399 -- cases as valid prior elaboration: 1400 -- 1401 -- * Unit_Id is the main unit 1402 -- 1403 -- * Unit_Id denotes the spec of the main unit body 1404 1405 procedure Meet_Elaboration_Requirement 1406 (N : Node_Id; 1407 Targ_Id : Entity_Id; 1408 Req_Nam : Name_Id; 1409 In_State : Processing_In_State); 1410 pragma Inline (Meet_Elaboration_Requirement); 1411 -- Determine whether elaboration requirement Req_Nam for scenario N with 1412 -- target Targ_Id is met by the context of the main unit using the SPARK 1413 -- rules. Req_Nam must denote either Elaborate or Elaborate_All. Emit an 1414 -- error if this is not the case. In_State denotes the current state of 1415 -- the Processing phase. 1416 1417 ----------------- 1418 -- Maintenance -- 1419 ----------------- 1420 1421 procedure Finalize_Elaborated_Units; 1422 pragma Inline (Finalize_Elaborated_Units); 1423 -- Finalize all internal data structures 1424 1425 procedure Initialize_Elaborated_Units; 1426 pragma Inline (Initialize_Elaborated_Units); 1427 -- Initialize all internal data structures 1428 1429 end Elaborated_Units; 1430 use Elaborated_Units; 1431 1432 -- The following package provides the main entry point for guaranteed ABE 1433 -- checks and diagnostics. 1434 1435 package Guaranteed_ABE_Processor is 1436 1437 --------- 1438 -- API -- 1439 --------- 1440 1441 procedure Process_Guaranteed_ABE 1442 (N : Node_Id; 1443 In_State : Processing_In_State); 1444 pragma Inline (Process_Guaranteed_ABE); 1445 -- Perform guaranteed ABE checks and diagnostics for scenario N. 1446 -- In_State is the current state of the Processing phase. 1447 1448 end Guaranteed_ABE_Processor; 1449 use Guaranteed_ABE_Processor; 1450 1451 -- The following package provides access to the internal representation of 1452 -- scenarios and targets. 1453 1454 package Internal_Representation is 1455 1456 ----------- 1457 -- Types -- 1458 ----------- 1459 1460 -- The following type enumerates all possible Ghost mode kinds 1461 1462 type Extended_Ghost_Mode is 1463 (Is_Ignored, 1464 Is_Checked_Or_Not_Specified); 1465 1466 -- The following type enumerates all possible SPARK mode kinds 1467 1468 type Extended_SPARK_Mode is 1469 (Is_On, 1470 Is_Off_Or_Not_Specified); 1471 1472 -------------- 1473 -- Builders -- 1474 -------------- 1475 1476 function Scenario_Representation_Of 1477 (N : Node_Id; 1478 In_State : Processing_In_State) return Scenario_Rep_Id; 1479 pragma Inline (Scenario_Representation_Of); 1480 -- Obtain the id of elaboration scenario N's representation. The routine 1481 -- constructs the representation if it is not available. In_State is the 1482 -- current state of the Processing phase. 1483 1484 function Target_Representation_Of 1485 (Id : Entity_Id; 1486 In_State : Processing_In_State) return Target_Rep_Id; 1487 pragma Inline (Target_Representation_Of); 1488 -- Obtain the id of elaboration target Id's representation. The routine 1489 -- constructs the representation if it is not available. In_State is the 1490 -- current state of the Processing phase. 1491 1492 ------------------------- 1493 -- Scenario attributes -- 1494 ------------------------- 1495 1496 function Activated_Task_Objects 1497 (S_Id : Scenario_Rep_Id) return NE_List.Doubly_Linked_List; 1498 pragma Inline (Activated_Task_Objects); 1499 -- For Task_Activation_Scenario S_Id, obtain the list of task objects 1500 -- the scenario is activating. 1501 1502 function Activated_Task_Type (S_Id : Scenario_Rep_Id) return Entity_Id; 1503 pragma Inline (Activated_Task_Type); 1504 -- For Task_Activation_Scenario S_Id, obtain the currently activated 1505 -- task type. 1506 1507 procedure Disable_Elaboration_Checks (S_Id : Scenario_Rep_Id); 1508 pragma Inline (Disable_Elaboration_Checks); 1509 -- Disable elaboration checks of scenario S_Id 1510 1511 function Elaboration_Checks_OK (S_Id : Scenario_Rep_Id) return Boolean; 1512 pragma Inline (Elaboration_Checks_OK); 1513 -- Determine whether scenario S_Id may be subjected to elaboration 1514 -- checks. 1515 1516 function Elaboration_Warnings_OK (S_Id : Scenario_Rep_Id) return Boolean; 1517 pragma Inline (Elaboration_Warnings_OK); 1518 -- Determine whether scenario S_Id may be subjected to elaboration 1519 -- warnings. 1520 1521 function Ghost_Mode_Of 1522 (S_Id : Scenario_Rep_Id) return Extended_Ghost_Mode; 1523 pragma Inline (Ghost_Mode_Of); 1524 -- Obtain the Ghost mode of scenario S_Id 1525 1526 function Is_Dispatching_Call (S_Id : Scenario_Rep_Id) return Boolean; 1527 pragma Inline (Is_Dispatching_Call); 1528 -- For Call_Scenario S_Id, determine whether the call is dispatching 1529 1530 function Is_Read_Reference (S_Id : Scenario_Rep_Id) return Boolean; 1531 pragma Inline (Is_Read_Reference); 1532 -- For Variable_Reference_Scenario S_Id, determine whether the reference 1533 -- is a read. 1534 1535 function Kind (S_Id : Scenario_Rep_Id) return Scenario_Kind; 1536 pragma Inline (Kind); 1537 -- Obtain the nature of scenario S_Id 1538 1539 function Level (S_Id : Scenario_Rep_Id) return Enclosing_Level_Kind; 1540 pragma Inline (Level); 1541 -- Obtain the enclosing level of scenario S_Id 1542 1543 procedure Set_Activated_Task_Objects 1544 (S_Id : Scenario_Rep_Id; 1545 Task_Objs : NE_List.Doubly_Linked_List); 1546 pragma Inline (Set_Activated_Task_Objects); 1547 -- For Task_Activation_Scenario S_Id, set the list of task objects 1548 -- activated by the scenario to Task_Objs. 1549 1550 procedure Set_Activated_Task_Type 1551 (S_Id : Scenario_Rep_Id; 1552 Task_Typ : Entity_Id); 1553 pragma Inline (Set_Activated_Task_Type); 1554 -- For Task_Activation_Scenario S_Id, set the currently activated task 1555 -- type to Task_Typ. 1556 1557 function SPARK_Mode_Of 1558 (S_Id : Scenario_Rep_Id) return Extended_SPARK_Mode; 1559 pragma Inline (SPARK_Mode_Of); 1560 -- Obtain the SPARK mode of scenario S_Id 1561 1562 function Target (S_Id : Scenario_Rep_Id) return Entity_Id; 1563 pragma Inline (Target); 1564 -- Obtain the target of scenario S_Id 1565 1566 ----------------------- 1567 -- Target attributes -- 1568 ----------------------- 1569 1570 function Barrier_Body_Declaration (T_Id : Target_Rep_Id) return Node_Id; 1571 pragma Inline (Barrier_Body_Declaration); 1572 -- For Subprogram_Target T_Id, obtain the declaration of the barrier 1573 -- function's body. 1574 1575 function Body_Declaration (T_Id : Target_Rep_Id) return Node_Id; 1576 pragma Inline (Body_Declaration); 1577 -- Obtain the declaration of the body which belongs to target T_Id 1578 1579 procedure Disable_Elaboration_Checks (T_Id : Target_Rep_Id); 1580 pragma Inline (Disable_Elaboration_Checks); 1581 -- Disable elaboration checks of target T_Id 1582 1583 function Elaboration_Checks_OK (T_Id : Target_Rep_Id) return Boolean; 1584 pragma Inline (Elaboration_Checks_OK); 1585 -- Determine whether target T_Id may be subjected to elaboration checks 1586 1587 function Elaboration_Warnings_OK (T_Id : Target_Rep_Id) return Boolean; 1588 pragma Inline (Elaboration_Warnings_OK); 1589 -- Determine whether target T_Id may be subjected to elaboration 1590 -- warnings. 1591 1592 function Ghost_Mode_Of (T_Id : Target_Rep_Id) return Extended_Ghost_Mode; 1593 pragma Inline (Ghost_Mode_Of); 1594 -- Obtain the Ghost mode of target T_Id 1595 1596 function Kind (T_Id : Target_Rep_Id) return Target_Kind; 1597 pragma Inline (Kind); 1598 -- Obtain the nature of target T_Id 1599 1600 function SPARK_Mode_Of (T_Id : Target_Rep_Id) return Extended_SPARK_Mode; 1601 pragma Inline (SPARK_Mode_Of); 1602 -- Obtain the SPARK mode of target T_Id 1603 1604 function Spec_Declaration (T_Id : Target_Rep_Id) return Node_Id; 1605 pragma Inline (Spec_Declaration); 1606 -- Obtain the declaration of the spec which belongs to target T_Id 1607 1608 function Unit (T_Id : Target_Rep_Id) return Entity_Id; 1609 pragma Inline (Unit); 1610 -- Obtain the unit where the target is defined 1611 1612 function Variable_Declaration (T_Id : Target_Rep_Id) return Node_Id; 1613 pragma Inline (Variable_Declaration); 1614 -- For Variable_Target T_Id, obtain the declaration of the variable 1615 1616 ----------------- 1617 -- Maintenance -- 1618 ----------------- 1619 1620 procedure Finalize_Internal_Representation; 1621 pragma Inline (Finalize_Internal_Representation); 1622 -- Finalize all internal data structures 1623 1624 procedure Initialize_Internal_Representation; 1625 pragma Inline (Initialize_Internal_Representation); 1626 -- Initialize all internal data structures 1627 1628 end Internal_Representation; 1629 use Internal_Representation; 1630 1631 -- The following package provides functionality for recording pieces of the 1632 -- invocation graph in the ALI file of the main unit. 1633 1634 package Invocation_Graph is 1635 1636 --------- 1637 -- API -- 1638 --------- 1639 1640 procedure Record_Invocation_Graph; 1641 pragma Inline (Record_Invocation_Graph); 1642 -- Process all declaration, instantiation, and library level scenarios, 1643 -- along with invocation construct within the spec and body of the main 1644 -- unit to determine whether any of these reach into an external unit. 1645 -- If such a path exists, encode in the ALI file of the main unit. 1646 1647 ----------------- 1648 -- Maintenance -- 1649 ----------------- 1650 1651 procedure Finalize_Invocation_Graph; 1652 pragma Inline (Finalize_Invocation_Graph); 1653 -- Finalize all internal data structures 1654 1655 procedure Initialize_Invocation_Graph; 1656 pragma Inline (Initialize_Invocation_Graph); 1657 -- Initialize all internal data structures 1658 1659 end Invocation_Graph; 1660 use Invocation_Graph; 1661 1662 -- The following package stores scenarios 1663 1664 package Scenario_Storage is 1665 1666 --------- 1667 -- API -- 1668 --------- 1669 1670 procedure Add_Declaration_Scenario (N : Node_Id); 1671 pragma Inline (Add_Declaration_Scenario); 1672 -- Save declaration level scenario N 1673 1674 procedure Add_Dynamic_ABE_Check_Scenario (N : Node_Id); 1675 pragma Inline (Add_Dynamic_ABE_Check_Scenario); 1676 -- Save scenario N for conditional ABE check installation purposes when 1677 -- the dynamic model is in effect. 1678 1679 procedure Add_Library_Body_Scenario (N : Node_Id); 1680 pragma Inline (Add_Library_Body_Scenario); 1681 -- Save library-level body scenario N 1682 1683 procedure Add_Library_Spec_Scenario (N : Node_Id); 1684 pragma Inline (Add_Library_Spec_Scenario); 1685 -- Save library-level spec scenario N 1686 1687 procedure Add_SPARK_Scenario (N : Node_Id); 1688 pragma Inline (Add_SPARK_Scenario); 1689 -- Save SPARK scenario N 1690 1691 procedure Delete_Scenario (N : Node_Id); 1692 pragma Inline (Delete_Scenario); 1693 -- Delete arbitrary scenario N 1694 1695 function Iterate_Declaration_Scenarios return NE_Set.Iterator; 1696 pragma Inline (Iterate_Declaration_Scenarios); 1697 -- Obtain an iterator over all declaration level scenarios 1698 1699 function Iterate_Dynamic_ABE_Check_Scenarios return NE_Set.Iterator; 1700 pragma Inline (Iterate_Dynamic_ABE_Check_Scenarios); 1701 -- Obtain an iterator over all scenarios that require a conditional ABE 1702 -- check when the dynamic model is in effect. 1703 1704 function Iterate_Library_Body_Scenarios return NE_Set.Iterator; 1705 pragma Inline (Iterate_Library_Body_Scenarios); 1706 -- Obtain an iterator over all library level body scenarios 1707 1708 function Iterate_Library_Spec_Scenarios return NE_Set.Iterator; 1709 pragma Inline (Iterate_Library_Spec_Scenarios); 1710 -- Obtain an iterator over all library level spec scenarios 1711 1712 function Iterate_SPARK_Scenarios return NE_Set.Iterator; 1713 pragma Inline (Iterate_SPARK_Scenarios); 1714 -- Obtain an iterator over all SPARK scenarios 1715 1716 procedure Replace_Scenario (Old_N : Node_Id; New_N : Node_Id); 1717 pragma Inline (Replace_Scenario); 1718 -- Replace scenario Old_N with scenario New_N 1719 1720 ----------------- 1721 -- Maintenance -- 1722 ----------------- 1723 1724 procedure Finalize_Scenario_Storage; 1725 pragma Inline (Finalize_Scenario_Storage); 1726 -- Finalize all internal data structures 1727 1728 procedure Initialize_Scenario_Storage; 1729 pragma Inline (Initialize_Scenario_Storage); 1730 -- Initialize all internal data structures 1731 1732 end Scenario_Storage; 1733 use Scenario_Storage; 1734 1735 -- The following package provides various semantic predicates 1736 1737 package Semantics is 1738 1739 --------- 1740 -- API -- 1741 --------- 1742 1743 function Is_Accept_Alternative_Proc (Id : Entity_Id) return Boolean; 1744 pragma Inline (Is_Accept_Alternative_Proc); 1745 -- Determine whether arbitrary entity Id denotes an internally generated 1746 -- procedure which encapsulates the statements of an accept alternative. 1747 1748 function Is_Activation_Proc (Id : Entity_Id) return Boolean; 1749 pragma Inline (Is_Activation_Proc); 1750 -- Determine whether arbitrary entity Id denotes a runtime procedure in 1751 -- charge with activating tasks. 1752 1753 function Is_Ada_Semantic_Target (Id : Entity_Id) return Boolean; 1754 pragma Inline (Is_Ada_Semantic_Target); 1755 -- Determine whether arbitrary entity Id denodes a source or internally 1756 -- generated subprogram which emulates Ada semantics. 1757 1758 function Is_Assertion_Pragma_Target (Id : Entity_Id) return Boolean; 1759 pragma Inline (Is_Assertion_Pragma_Target); 1760 -- Determine whether arbitrary entity Id denotes a procedure which 1761 -- varifies the run-time semantics of an assertion pragma. 1762 1763 function Is_Bodiless_Subprogram (Subp_Id : Entity_Id) return Boolean; 1764 pragma Inline (Is_Bodiless_Subprogram); 1765 -- Determine whether subprogram Subp_Id will never have a body 1766 1767 function Is_Bridge_Target (Id : Entity_Id) return Boolean; 1768 pragma Inline (Is_Bridge_Target); 1769 -- Determine whether arbitrary entity Id denotes a bridge target 1770 1771 function Is_Controlled_Proc 1772 (Subp_Id : Entity_Id; 1773 Subp_Nam : Name_Id) return Boolean; 1774 pragma Inline (Is_Controlled_Proc); 1775 -- Determine whether subprogram Subp_Id denotes controlled type 1776 -- primitives Adjust, Finalize, or Initialize as denoted by name 1777 -- Subp_Nam. 1778 1779 function Is_Default_Initial_Condition_Proc 1780 (Id : Entity_Id) return Boolean; 1781 pragma Inline (Is_Default_Initial_Condition_Proc); 1782 -- Determine whether arbitrary entity Id denotes internally generated 1783 -- routine Default_Initial_Condition. 1784 1785 function Is_Finalizer_Proc (Id : Entity_Id) return Boolean; 1786 pragma Inline (Is_Finalizer_Proc); 1787 -- Determine whether arbitrary entity Id denotes internally generated 1788 -- routine _Finalizer. 1789 1790 function Is_Initial_Condition_Proc (Id : Entity_Id) return Boolean; 1791 pragma Inline (Is_Initial_Condition_Proc); 1792 -- Determine whether arbitrary entity Id denotes internally generated 1793 -- routine Initial_Condition. 1794 1795 function Is_Initialized (Obj_Decl : Node_Id) return Boolean; 1796 pragma Inline (Is_Initialized); 1797 -- Determine whether object declaration Obj_Decl is initialized 1798 1799 function Is_Invariant_Proc (Id : Entity_Id) return Boolean; 1800 pragma Inline (Is_Invariant_Proc); 1801 -- Determine whether arbitrary entity Id denotes an invariant procedure 1802 1803 function Is_Non_Library_Level_Encapsulator (N : Node_Id) return Boolean; 1804 pragma Inline (Is_Non_Library_Level_Encapsulator); 1805 -- Determine whether arbitrary node N is a non-library encapsulator 1806 1807 function Is_Partial_Invariant_Proc (Id : Entity_Id) return Boolean; 1808 pragma Inline (Is_Partial_Invariant_Proc); 1809 -- Determine whether arbitrary entity Id denotes a partial invariant 1810 -- procedure. 1811 1812 function Is_Postconditions_Proc (Id : Entity_Id) return Boolean; 1813 pragma Inline (Is_Postconditions_Proc); 1814 -- Determine whether arbitrary entity Id denotes internally generated 1815 -- routine _Postconditions. 1816 1817 function Is_Preelaborated_Unit (Id : Entity_Id) return Boolean; 1818 pragma Inline (Is_Preelaborated_Unit); 1819 -- Determine whether arbitrary entity Id denotes a unit which is subject 1820 -- to one of the following pragmas: 1821 -- 1822 -- * Preelaborable 1823 -- * Pure 1824 -- * Remote_Call_Interface 1825 -- * Remote_Types 1826 -- * Shared_Passive 1827 1828 function Is_Protected_Entry (Id : Entity_Id) return Boolean; 1829 pragma Inline (Is_Protected_Entry); 1830 -- Determine whether arbitrary entity Id denotes a protected entry 1831 1832 function Is_Protected_Subp (Id : Entity_Id) return Boolean; 1833 pragma Inline (Is_Protected_Subp); 1834 -- Determine whether entity Id denotes a protected subprogram 1835 1836 function Is_Protected_Body_Subp (Id : Entity_Id) return Boolean; 1837 pragma Inline (Is_Protected_Body_Subp); 1838 -- Determine whether entity Id denotes the protected or unprotected 1839 -- version of a protected subprogram. 1840 1841 function Is_Scenario (N : Node_Id) return Boolean; 1842 pragma Inline (Is_Scenario); 1843 -- Determine whether attribute node N denotes a scenario. The scenario 1844 -- may not necessarily be eligible for ABE processing. 1845 1846 function Is_SPARK_Semantic_Target (Id : Entity_Id) return Boolean; 1847 pragma Inline (Is_SPARK_Semantic_Target); 1848 -- Determine whether arbitrary entity Id nodes a source or internally 1849 -- generated subprogram which emulates SPARK semantics. 1850 1851 function Is_Subprogram_Inst (Id : Entity_Id) return Boolean; 1852 pragma Inline (Is_Subprogram_Inst); 1853 -- Determine whether arbitrary entity Id denotes a subprogram instance 1854 1855 function Is_Suitable_Access_Taken (N : Node_Id) return Boolean; 1856 pragma Inline (Is_Suitable_Access_Taken); 1857 -- Determine whether arbitrary node N denotes a suitable attribute for 1858 -- ABE processing. 1859 1860 function Is_Suitable_Call (N : Node_Id) return Boolean; 1861 pragma Inline (Is_Suitable_Call); 1862 -- Determine whether arbitrary node N denotes a suitable call for ABE 1863 -- processing. 1864 1865 function Is_Suitable_Instantiation (N : Node_Id) return Boolean; 1866 pragma Inline (Is_Suitable_Instantiation); 1867 -- Determine whether arbitrary node N is a suitable instantiation for 1868 -- ABE processing. 1869 1870 function Is_Suitable_SPARK_Derived_Type (N : Node_Id) return Boolean; 1871 pragma Inline (Is_Suitable_SPARK_Derived_Type); 1872 -- Determine whether arbitrary node N denotes a suitable derived type 1873 -- declaration for ABE processing using the SPARK rules. 1874 1875 function Is_Suitable_SPARK_Instantiation (N : Node_Id) return Boolean; 1876 pragma Inline (Is_Suitable_SPARK_Instantiation); 1877 -- Determine whether arbitrary node N denotes a suitable instantiation 1878 -- for ABE processing using the SPARK rules. 1879 1880 function Is_Suitable_SPARK_Refined_State_Pragma 1881 (N : Node_Id) return Boolean; 1882 pragma Inline (Is_Suitable_SPARK_Refined_State_Pragma); 1883 -- Determine whether arbitrary node N denotes a suitable Refined_State 1884 -- pragma for ABE processing using the SPARK rules. 1885 1886 function Is_Suitable_Variable_Assignment (N : Node_Id) return Boolean; 1887 pragma Inline (Is_Suitable_Variable_Assignment); 1888 -- Determine whether arbitrary node N denotes a suitable assignment for 1889 -- ABE processing. 1890 1891 function Is_Suitable_Variable_Reference (N : Node_Id) return Boolean; 1892 pragma Inline (Is_Suitable_Variable_Reference); 1893 -- Determine whether arbitrary node N is a suitable variable reference 1894 -- for ABE processing. 1895 1896 function Is_Task_Entry (Id : Entity_Id) return Boolean; 1897 pragma Inline (Is_Task_Entry); 1898 -- Determine whether arbitrary entity Id denotes a task entry 1899 1900 function Is_Up_Level_Target 1901 (Targ_Decl : Node_Id; 1902 In_State : Processing_In_State) return Boolean; 1903 pragma Inline (Is_Up_Level_Target); 1904 -- Determine whether the current root resides at the declaration level. 1905 -- If this is the case, determine whether a target with by declaration 1906 -- Target_Decl is within a context which encloses the current root or is 1907 -- in a different unit. In_State is the current state of the Processing 1908 -- phase. 1909 1910 end Semantics; 1911 use Semantics; 1912 1913 -- The following package provides the main entry point for SPARK-related 1914 -- checks and diagnostics. 1915 1916 package SPARK_Processor is 1917 1918 --------- 1919 -- API -- 1920 --------- 1921 1922 procedure Check_SPARK_Model_In_Effect; 1923 pragma Inline (Check_SPARK_Model_In_Effect); 1924 -- Determine whether a suitable elaboration model is currently in effect 1925 -- for verifying SPARK rules. Emit a warning if this is not the case. 1926 1927 procedure Check_SPARK_Scenarios; 1928 pragma Inline (Check_SPARK_Scenarios); 1929 -- Examine SPARK scenarios which are not necessarily executable during 1930 -- elaboration, but still requires elaboration-related checks. 1931 1932 end SPARK_Processor; 1933 use SPARK_Processor; 1934 1935 ----------------------- 1936 -- Local subprograms -- 1937 ----------------------- 1938 1939 function Assignment_Target (Asmt : Node_Id) return Node_Id; 1940 pragma Inline (Assignment_Target); 1941 -- Obtain the target of assignment statement Asmt 1942 1943 function Call_Name (Call : Node_Id) return Node_Id; 1944 pragma Inline (Call_Name); 1945 -- Obtain the name of an entry, operator, or subprogram call Call 1946 1947 function Canonical_Subprogram (Subp_Id : Entity_Id) return Entity_Id; 1948 pragma Inline (Canonical_Subprogram); 1949 -- Obtain the uniform canonical entity of subprogram Subp_Id 1950 1951 function Compilation_Unit (Unit_Id : Entity_Id) return Node_Id; 1952 pragma Inline (Compilation_Unit); 1953 -- Return the N_Compilation_Unit node of unit Unit_Id 1954 1955 function Elaboration_Phase_Active return Boolean; 1956 pragma Inline (Elaboration_Phase_Active); 1957 -- Determine whether the elaboration phase of the compilation has started 1958 1959 procedure Error_Preelaborated_Call (N : Node_Id); 1960 -- Give an error or warning for a non-static/non-preelaborable call in a 1961 -- preelaborated unit. 1962 1963 procedure Finalize_All_Data_Structures; 1964 pragma Inline (Finalize_All_Data_Structures); 1965 -- Destroy all internal data structures 1966 1967 function Find_Enclosing_Instance (N : Node_Id) return Node_Id; 1968 pragma Inline (Find_Enclosing_Instance); 1969 -- Find the declaration or body of the nearest expanded instance which 1970 -- encloses arbitrary node N. Return Empty if no such instance exists. 1971 1972 function Find_Top_Unit (N : Node_Or_Entity_Id) return Entity_Id; 1973 pragma Inline (Find_Top_Unit); 1974 -- Return the top unit which contains arbitrary node or entity N. The unit 1975 -- is obtained by logically unwinding instantiations and subunits when N 1976 -- resides within one. 1977 1978 function Find_Unit_Entity (N : Node_Id) return Entity_Id; 1979 pragma Inline (Find_Unit_Entity); 1980 -- Return the entity of unit N 1981 1982 function First_Formal_Type (Subp_Id : Entity_Id) return Entity_Id; 1983 pragma Inline (First_Formal_Type); 1984 -- Return the type of subprogram Subp_Id's first formal parameter. If the 1985 -- subprogram lacks formal parameters, return Empty. 1986 1987 function Has_Body (Pack_Decl : Node_Id) return Boolean; 1988 pragma Inline (Has_Body); 1989 -- Determine whether package declaration Pack_Decl has a corresponding body 1990 -- or would eventually have one. 1991 1992 function In_External_Instance 1993 (N : Node_Id; 1994 Target_Decl : Node_Id) return Boolean; 1995 pragma Inline (In_External_Instance); 1996 -- Determine whether a target desctibed by its declaration Target_Decl 1997 -- resides in a package instance which is external to scenario N. 1998 1999 function In_Main_Context (N : Node_Id) return Boolean; 2000 pragma Inline (In_Main_Context); 2001 -- Determine whether arbitrary node N appears within the main compilation 2002 -- unit. 2003 2004 function In_Same_Context 2005 (N1 : Node_Id; 2006 N2 : Node_Id; 2007 Nested_OK : Boolean := False) return Boolean; 2008 pragma Inline (In_Same_Context); 2009 -- Determine whether two arbitrary nodes N1 and N2 appear within the same 2010 -- context ignoring enclosing library levels. Nested_OK should be set when 2011 -- the context of N1 can enclose that of N2. 2012 2013 procedure Initialize_All_Data_Structures; 2014 pragma Inline (Initialize_All_Data_Structures); 2015 -- Create all internal data structures 2016 2017 function Instantiated_Generic (Inst : Node_Id) return Entity_Id; 2018 pragma Inline (Instantiated_Generic); 2019 -- Obtain the generic instantiated by instance Inst 2020 2021 function Is_Safe_Activation 2022 (Call : Node_Id; 2023 Task_Rep : Target_Rep_Id) return Boolean; 2024 pragma Inline (Is_Safe_Activation); 2025 -- Determine whether activation call Call which activates an object of a 2026 -- task type described by representation Task_Rep is always ABE-safe. 2027 2028 function Is_Safe_Call 2029 (Call : Node_Id; 2030 Subp_Id : Entity_Id; 2031 Subp_Rep : Target_Rep_Id) return Boolean; 2032 pragma Inline (Is_Safe_Call); 2033 -- Determine whether call Call which invokes entry, operator, or subprogram 2034 -- Subp_Id is always ABE-safe. Subp_Rep is the representation of the entry, 2035 -- operator, or subprogram. 2036 2037 function Is_Safe_Instantiation 2038 (Inst : Node_Id; 2039 Gen_Id : Entity_Id; 2040 Gen_Rep : Target_Rep_Id) return Boolean; 2041 pragma Inline (Is_Safe_Instantiation); 2042 -- Determine whether instantiation Inst which instantiates generic Gen_Id 2043 -- is always ABE-safe. Gen_Rep is the representation of the generic. 2044 2045 function Is_Same_Unit 2046 (Unit_1 : Entity_Id; 2047 Unit_2 : Entity_Id) return Boolean; 2048 pragma Inline (Is_Same_Unit); 2049 -- Determine whether entities Unit_1 and Unit_2 denote the same unit 2050 2051 function Main_Unit_Entity return Entity_Id; 2052 pragma Inline (Main_Unit_Entity); 2053 -- Return the entity of the main unit 2054 2055 function Non_Private_View (Typ : Entity_Id) return Entity_Id; 2056 pragma Inline (Non_Private_View); 2057 -- Return the full view of private type Typ if available, otherwise return 2058 -- type Typ. 2059 2060 function Scenario (N : Node_Id) return Node_Id; 2061 pragma Inline (Scenario); 2062 -- Return the appropriate scenario node for scenario N 2063 2064 procedure Set_Elaboration_Phase (Status : Elaboration_Phase_Status); 2065 pragma Inline (Set_Elaboration_Phase); 2066 -- Change the status of the elaboration phase of the compiler to Status 2067 2068 procedure Spec_And_Body_From_Entity 2069 (Id : Node_Id; 2070 Spec_Decl : out Node_Id; 2071 Body_Decl : out Node_Id); 2072 pragma Inline (Spec_And_Body_From_Entity); 2073 -- Given arbitrary entity Id representing a construct with a spec and body, 2074 -- retrieve declaration of the spec in Spec_Decl and the declaration of the 2075 -- body in Body_Decl. 2076 2077 procedure Spec_And_Body_From_Node 2078 (N : Node_Id; 2079 Spec_Decl : out Node_Id; 2080 Body_Decl : out Node_Id); 2081 pragma Inline (Spec_And_Body_From_Node); 2082 -- Given arbitrary node N representing a construct with a spec and body, 2083 -- retrieve declaration of the spec in Spec_Decl and the declaration of 2084 -- the body in Body_Decl. 2085 2086 function Static_Elaboration_Checks return Boolean; 2087 pragma Inline (Static_Elaboration_Checks); 2088 -- Determine whether the static model is in effect 2089 2090 function Unit_Entity (Unit_Id : Entity_Id) return Entity_Id; 2091 pragma Inline (Unit_Entity); 2092 -- Return the entity of the initial declaration for unit Unit_Id 2093 2094 procedure Update_Elaboration_Scenario (New_N : Node_Id; Old_N : Node_Id); 2095 pragma Inline (Update_Elaboration_Scenario); 2096 -- Update all relevant internal data structures when scenario Old_N is 2097 -- transformed into scenario New_N by Atree.Rewrite. 2098 2099 ---------------------- 2100 -- Active_Scenarios -- 2101 ---------------------- 2102 2103 package body Active_Scenarios is 2104 2105 ----------------------- 2106 -- Local subprograms -- 2107 ----------------------- 2108 2109 procedure Output_Access_Taken 2110 (Attr : Node_Id; 2111 Attr_Rep : Scenario_Rep_Id; 2112 Error_Nod : Node_Id); 2113 pragma Inline (Output_Access_Taken); 2114 -- Emit a specific diagnostic message for 'Access attribute reference 2115 -- Attr with representation Attr_Rep. The message is associated with 2116 -- node Error_Nod. 2117 2118 procedure Output_Active_Scenario 2119 (N : Node_Id; 2120 Error_Nod : Node_Id; 2121 In_State : Processing_In_State); 2122 pragma Inline (Output_Active_Scenario); 2123 -- Top level dispatcher for outputting a scenario. Emit a specific 2124 -- diagnostic message for scenario N. The message is associated with 2125 -- node Error_Nod. In_State is the current state of the Processing 2126 -- phase. 2127 2128 procedure Output_Call 2129 (Call : Node_Id; 2130 Call_Rep : Scenario_Rep_Id; 2131 Error_Nod : Node_Id); 2132 pragma Inline (Output_Call); 2133 -- Emit a diagnostic message for call Call with representation Call_Rep. 2134 -- The message is associated with node Error_Nod. 2135 2136 procedure Output_Header (Error_Nod : Node_Id); 2137 pragma Inline (Output_Header); 2138 -- Emit a specific diagnostic message for the unit of the root scenario. 2139 -- The message is associated with node Error_Nod. 2140 2141 procedure Output_Instantiation 2142 (Inst : Node_Id; 2143 Inst_Rep : Scenario_Rep_Id; 2144 Error_Nod : Node_Id); 2145 pragma Inline (Output_Instantiation); 2146 -- Emit a specific diagnostic message for instantiation Inst with 2147 -- representation Inst_Rep. The message is associated with node 2148 -- Error_Nod. 2149 2150 procedure Output_Refined_State_Pragma 2151 (Prag : Node_Id; 2152 Prag_Rep : Scenario_Rep_Id; 2153 Error_Nod : Node_Id); 2154 pragma Inline (Output_Refined_State_Pragma); 2155 -- Emit a specific diagnostic message for Refined_State pragma Prag 2156 -- with representation Prag_Rep. The message is associated with node 2157 -- Error_Nod. 2158 2159 procedure Output_Task_Activation 2160 (Call : Node_Id; 2161 Call_Rep : Scenario_Rep_Id; 2162 Error_Nod : Node_Id); 2163 pragma Inline (Output_Task_Activation); 2164 -- Emit a specific diagnostic message for activation call Call 2165 -- with representation Call_Rep. The message is associated with 2166 -- node Error_Nod. 2167 2168 procedure Output_Variable_Assignment 2169 (Asmt : Node_Id; 2170 Asmt_Rep : Scenario_Rep_Id; 2171 Error_Nod : Node_Id); 2172 pragma Inline (Output_Variable_Assignment); 2173 -- Emit a specific diagnostic message for assignment statement Asmt 2174 -- with representation Asmt_Rep. The message is associated with node 2175 -- Error_Nod. 2176 2177 procedure Output_Variable_Reference 2178 (Ref : Node_Id; 2179 Ref_Rep : Scenario_Rep_Id; 2180 Error_Nod : Node_Id); 2181 pragma Inline (Output_Variable_Reference); 2182 -- Emit a specific diagnostic message for read reference Ref with 2183 -- representation Ref_Rep. The message is associated with node 2184 -- Error_Nod. 2185 2186 ------------------- 2187 -- Output_Access -- 2188 ------------------- 2189 2190 procedure Output_Access_Taken 2191 (Attr : Node_Id; 2192 Attr_Rep : Scenario_Rep_Id; 2193 Error_Nod : Node_Id) 2194 is 2195 Subp_Id : constant Entity_Id := Target (Attr_Rep); 2196 2197 begin 2198 Error_Msg_Name_1 := Attribute_Name (Attr); 2199 Error_Msg_Sloc := Sloc (Attr); 2200 Error_Msg_NE ("\\ % of & taken #", Error_Nod, Subp_Id); 2201 end Output_Access_Taken; 2202 2203 ---------------------------- 2204 -- Output_Active_Scenario -- 2205 ---------------------------- 2206 2207 procedure Output_Active_Scenario 2208 (N : Node_Id; 2209 Error_Nod : Node_Id; 2210 In_State : Processing_In_State) 2211 is 2212 Scen : constant Node_Id := Scenario (N); 2213 Scen_Rep : Scenario_Rep_Id; 2214 2215 begin 2216 -- 'Access 2217 2218 if Is_Suitable_Access_Taken (Scen) then 2219 Output_Access_Taken 2220 (Attr => Scen, 2221 Attr_Rep => Scenario_Representation_Of (Scen, In_State), 2222 Error_Nod => Error_Nod); 2223 2224 -- Call or task activation 2225 2226 elsif Is_Suitable_Call (Scen) then 2227 Scen_Rep := Scenario_Representation_Of (Scen, In_State); 2228 2229 if Kind (Scen_Rep) = Call_Scenario then 2230 Output_Call 2231 (Call => Scen, 2232 Call_Rep => Scen_Rep, 2233 Error_Nod => Error_Nod); 2234 2235 else 2236 pragma Assert (Kind (Scen_Rep) = Task_Activation_Scenario); 2237 2238 Output_Task_Activation 2239 (Call => Scen, 2240 Call_Rep => Scen_Rep, 2241 Error_Nod => Error_Nod); 2242 end if; 2243 2244 -- Instantiation 2245 2246 elsif Is_Suitable_Instantiation (Scen) then 2247 Output_Instantiation 2248 (Inst => Scen, 2249 Inst_Rep => Scenario_Representation_Of (Scen, In_State), 2250 Error_Nod => Error_Nod); 2251 2252 -- Pragma Refined_State 2253 2254 elsif Is_Suitable_SPARK_Refined_State_Pragma (Scen) then 2255 Output_Refined_State_Pragma 2256 (Prag => Scen, 2257 Prag_Rep => Scenario_Representation_Of (Scen, In_State), 2258 Error_Nod => Error_Nod); 2259 2260 -- Variable assignment 2261 2262 elsif Is_Suitable_Variable_Assignment (Scen) then 2263 Output_Variable_Assignment 2264 (Asmt => Scen, 2265 Asmt_Rep => Scenario_Representation_Of (Scen, In_State), 2266 Error_Nod => Error_Nod); 2267 2268 -- Variable reference 2269 2270 elsif Is_Suitable_Variable_Reference (Scen) then 2271 Output_Variable_Reference 2272 (Ref => Scen, 2273 Ref_Rep => Scenario_Representation_Of (Scen, In_State), 2274 Error_Nod => Error_Nod); 2275 end if; 2276 end Output_Active_Scenario; 2277 2278 ----------------------------- 2279 -- Output_Active_Scenarios -- 2280 ----------------------------- 2281 2282 procedure Output_Active_Scenarios 2283 (Error_Nod : Node_Id; 2284 In_State : Processing_In_State) 2285 is 2286 package Scenarios renames Active_Scenario_Stack; 2287 2288 Header_Posted : Boolean := False; 2289 2290 begin 2291 -- Output the contents of the active scenario stack starting from the 2292 -- bottom, or the least recent scenario. 2293 2294 for Index in Scenarios.First .. Scenarios.Last loop 2295 if not Header_Posted then 2296 Output_Header (Error_Nod); 2297 Header_Posted := True; 2298 end if; 2299 2300 Output_Active_Scenario 2301 (N => Scenarios.Table (Index), 2302 Error_Nod => Error_Nod, 2303 In_State => In_State); 2304 end loop; 2305 end Output_Active_Scenarios; 2306 2307 ----------------- 2308 -- Output_Call -- 2309 ----------------- 2310 2311 procedure Output_Call 2312 (Call : Node_Id; 2313 Call_Rep : Scenario_Rep_Id; 2314 Error_Nod : Node_Id) 2315 is 2316 procedure Output_Accept_Alternative (Alt_Id : Entity_Id); 2317 pragma Inline (Output_Accept_Alternative); 2318 -- Emit a specific diagnostic message concerning accept alternative 2319 -- with entity Alt_Id. 2320 2321 procedure Output_Call (Subp_Id : Entity_Id; Kind : String); 2322 pragma Inline (Output_Call); 2323 -- Emit a specific diagnostic message concerning a call of kind Kind 2324 -- which invokes subprogram Subp_Id. 2325 2326 procedure Output_Type_Actions (Subp_Id : Entity_Id; Action : String); 2327 pragma Inline (Output_Type_Actions); 2328 -- Emit a specific diagnostic message concerning action Action of a 2329 -- type performed by subprogram Subp_Id. 2330 2331 procedure Output_Verification_Call 2332 (Pred : String; 2333 Id : Entity_Id; 2334 Id_Kind : String); 2335 pragma Inline (Output_Verification_Call); 2336 -- Emit a specific diagnostic message concerning the verification of 2337 -- predicate Pred applied to related entity Id with kind Id_Kind. 2338 2339 ------------------------------- 2340 -- Output_Accept_Alternative -- 2341 ------------------------------- 2342 2343 procedure Output_Accept_Alternative (Alt_Id : Entity_Id) is 2344 Entry_Id : constant Entity_Id := Receiving_Entry (Alt_Id); 2345 2346 begin 2347 pragma Assert (Present (Entry_Id)); 2348 2349 Error_Msg_NE ("\\ entry & selected #", Error_Nod, Entry_Id); 2350 end Output_Accept_Alternative; 2351 2352 ----------------- 2353 -- Output_Call -- 2354 ----------------- 2355 2356 procedure Output_Call (Subp_Id : Entity_Id; Kind : String) is 2357 begin 2358 Error_Msg_NE ("\\ " & Kind & " & called #", Error_Nod, Subp_Id); 2359 end Output_Call; 2360 2361 ------------------------- 2362 -- Output_Type_Actions -- 2363 ------------------------- 2364 2365 procedure Output_Type_Actions 2366 (Subp_Id : Entity_Id; 2367 Action : String) 2368 is 2369 Typ : constant Entity_Id := First_Formal_Type (Subp_Id); 2370 2371 begin 2372 pragma Assert (Present (Typ)); 2373 2374 Error_Msg_NE 2375 ("\\ " & Action & " actions for type & #", Error_Nod, Typ); 2376 end Output_Type_Actions; 2377 2378 ------------------------------ 2379 -- Output_Verification_Call -- 2380 ------------------------------ 2381 2382 procedure Output_Verification_Call 2383 (Pred : String; 2384 Id : Entity_Id; 2385 Id_Kind : String) 2386 is 2387 begin 2388 pragma Assert (Present (Id)); 2389 2390 Error_Msg_NE 2391 ("\\ " & Pred & " of " & Id_Kind & " & verified #", 2392 Error_Nod, Id); 2393 end Output_Verification_Call; 2394 2395 -- Local variables 2396 2397 Subp_Id : constant Entity_Id := Target (Call_Rep); 2398 2399 -- Start of processing for Output_Call 2400 2401 begin 2402 Error_Msg_Sloc := Sloc (Call); 2403 2404 -- Accept alternative 2405 2406 if Is_Accept_Alternative_Proc (Subp_Id) then 2407 Output_Accept_Alternative (Subp_Id); 2408 2409 -- Adjustment 2410 2411 elsif Is_TSS (Subp_Id, TSS_Deep_Adjust) then 2412 Output_Type_Actions (Subp_Id, "adjustment"); 2413 2414 -- Default_Initial_Condition 2415 2416 elsif Is_Default_Initial_Condition_Proc (Subp_Id) then 2417 2418 -- Only do output for a normal DIC procedure, since partial DIC 2419 -- procedures are subsidiary to those. 2420 2421 if not Is_Partial_DIC_Procedure (Subp_Id) then 2422 Output_Verification_Call 2423 (Pred => "Default_Initial_Condition", 2424 Id => First_Formal_Type (Subp_Id), 2425 Id_Kind => "type"); 2426 end if; 2427 2428 -- Entries 2429 2430 elsif Is_Protected_Entry (Subp_Id) then 2431 Output_Call (Subp_Id, "entry"); 2432 2433 -- Task entry calls are never processed because the entry being 2434 -- invoked does not have a corresponding "body", it has a select. A 2435 -- task entry call appears in the stack of active scenarios for the 2436 -- sole purpose of checking No_Entry_Calls_In_Elaboration_Code and 2437 -- nothing more. 2438 2439 elsif Is_Task_Entry (Subp_Id) then 2440 null; 2441 2442 -- Finalization 2443 2444 elsif Is_TSS (Subp_Id, TSS_Deep_Finalize) then 2445 Output_Type_Actions (Subp_Id, "finalization"); 2446 2447 -- Calls to _Finalizer procedures must not appear in the output 2448 -- because this creates confusing noise. 2449 2450 elsif Is_Finalizer_Proc (Subp_Id) then 2451 null; 2452 2453 -- Initial_Condition 2454 2455 elsif Is_Initial_Condition_Proc (Subp_Id) then 2456 Output_Verification_Call 2457 (Pred => "Initial_Condition", 2458 Id => Find_Enclosing_Scope (Call), 2459 Id_Kind => "package"); 2460 2461 -- Initialization 2462 2463 elsif Is_Init_Proc (Subp_Id) 2464 or else Is_TSS (Subp_Id, TSS_Deep_Initialize) 2465 then 2466 Output_Type_Actions (Subp_Id, "initialization"); 2467 2468 -- Invariant 2469 2470 elsif Is_Invariant_Proc (Subp_Id) then 2471 Output_Verification_Call 2472 (Pred => "invariants", 2473 Id => First_Formal_Type (Subp_Id), 2474 Id_Kind => "type"); 2475 2476 -- Partial invariant calls must not appear in the output because this 2477 -- creates confusing noise. Note that a partial invariant is always 2478 -- invoked by the "full" invariant which is already placed on the 2479 -- stack. 2480 2481 elsif Is_Partial_Invariant_Proc (Subp_Id) then 2482 null; 2483 2484 -- _Postconditions 2485 2486 elsif Is_Postconditions_Proc (Subp_Id) then 2487 Output_Verification_Call 2488 (Pred => "postconditions", 2489 Id => Find_Enclosing_Scope (Call), 2490 Id_Kind => "subprogram"); 2491 2492 -- Subprograms must come last because some of the previous cases fall 2493 -- under this category. 2494 2495 elsif Ekind (Subp_Id) = E_Function then 2496 Output_Call (Subp_Id, "function"); 2497 2498 elsif Ekind (Subp_Id) = E_Procedure then 2499 Output_Call (Subp_Id, "procedure"); 2500 2501 else 2502 pragma Assert (False); 2503 return; 2504 end if; 2505 end Output_Call; 2506 2507 ------------------- 2508 -- Output_Header -- 2509 ------------------- 2510 2511 procedure Output_Header (Error_Nod : Node_Id) is 2512 Unit_Id : constant Entity_Id := Find_Top_Unit (Root_Scenario); 2513 2514 begin 2515 if Ekind (Unit_Id) = E_Package then 2516 Error_Msg_NE ("\\ spec of unit & elaborated", Error_Nod, Unit_Id); 2517 2518 elsif Ekind (Unit_Id) = E_Package_Body then 2519 Error_Msg_NE ("\\ body of unit & elaborated", Error_Nod, Unit_Id); 2520 2521 else 2522 Error_Msg_NE ("\\ in body of unit &", Error_Nod, Unit_Id); 2523 end if; 2524 end Output_Header; 2525 2526 -------------------------- 2527 -- Output_Instantiation -- 2528 -------------------------- 2529 2530 procedure Output_Instantiation 2531 (Inst : Node_Id; 2532 Inst_Rep : Scenario_Rep_Id; 2533 Error_Nod : Node_Id) 2534 is 2535 procedure Output_Instantiation (Gen_Id : Entity_Id; Kind : String); 2536 pragma Inline (Output_Instantiation); 2537 -- Emit a specific diagnostic message concerning an instantiation of 2538 -- generic unit Gen_Id. Kind denotes the kind of the instantiation. 2539 2540 -------------------------- 2541 -- Output_Instantiation -- 2542 -------------------------- 2543 2544 procedure Output_Instantiation (Gen_Id : Entity_Id; Kind : String) is 2545 begin 2546 Error_Msg_NE 2547 ("\\ " & Kind & " & instantiated as & #", Error_Nod, Gen_Id); 2548 end Output_Instantiation; 2549 2550 -- Local variables 2551 2552 Gen_Id : constant Entity_Id := Target (Inst_Rep); 2553 2554 -- Start of processing for Output_Instantiation 2555 2556 begin 2557 Error_Msg_Node_2 := Defining_Entity (Inst); 2558 Error_Msg_Sloc := Sloc (Inst); 2559 2560 if Nkind (Inst) = N_Function_Instantiation then 2561 Output_Instantiation (Gen_Id, "function"); 2562 2563 elsif Nkind (Inst) = N_Package_Instantiation then 2564 Output_Instantiation (Gen_Id, "package"); 2565 2566 elsif Nkind (Inst) = N_Procedure_Instantiation then 2567 Output_Instantiation (Gen_Id, "procedure"); 2568 2569 else 2570 pragma Assert (False); 2571 return; 2572 end if; 2573 end Output_Instantiation; 2574 2575 --------------------------------- 2576 -- Output_Refined_State_Pragma -- 2577 --------------------------------- 2578 2579 procedure Output_Refined_State_Pragma 2580 (Prag : Node_Id; 2581 Prag_Rep : Scenario_Rep_Id; 2582 Error_Nod : Node_Id) 2583 is 2584 pragma Unreferenced (Prag_Rep); 2585 2586 begin 2587 Error_Msg_Sloc := Sloc (Prag); 2588 Error_Msg_N ("\\ refinement constituents read #", Error_Nod); 2589 end Output_Refined_State_Pragma; 2590 2591 ---------------------------- 2592 -- Output_Task_Activation -- 2593 ---------------------------- 2594 2595 procedure Output_Task_Activation 2596 (Call : Node_Id; 2597 Call_Rep : Scenario_Rep_Id; 2598 Error_Nod : Node_Id) 2599 is 2600 pragma Unreferenced (Call_Rep); 2601 2602 function Find_Activator return Entity_Id; 2603 -- Find the nearest enclosing construct which houses call Call 2604 2605 -------------------- 2606 -- Find_Activator -- 2607 -------------------- 2608 2609 function Find_Activator return Entity_Id is 2610 Par : Node_Id; 2611 2612 begin 2613 -- Climb the parent chain looking for a package [body] or a 2614 -- construct with a statement sequence. 2615 2616 Par := Parent (Call); 2617 while Present (Par) loop 2618 if Nkind (Par) in N_Package_Body | N_Package_Declaration then 2619 return Defining_Entity (Par); 2620 2621 elsif Nkind (Par) = N_Handled_Sequence_Of_Statements then 2622 return Defining_Entity (Parent (Par)); 2623 end if; 2624 2625 Par := Parent (Par); 2626 end loop; 2627 2628 return Empty; 2629 end Find_Activator; 2630 2631 -- Local variables 2632 2633 Activator : constant Entity_Id := Find_Activator; 2634 2635 -- Start of processing for Output_Task_Activation 2636 2637 begin 2638 pragma Assert (Present (Activator)); 2639 2640 Error_Msg_NE ("\\ local tasks of & activated", Error_Nod, Activator); 2641 end Output_Task_Activation; 2642 2643 -------------------------------- 2644 -- Output_Variable_Assignment -- 2645 -------------------------------- 2646 2647 procedure Output_Variable_Assignment 2648 (Asmt : Node_Id; 2649 Asmt_Rep : Scenario_Rep_Id; 2650 Error_Nod : Node_Id) 2651 is 2652 Var_Id : constant Entity_Id := Target (Asmt_Rep); 2653 2654 begin 2655 Error_Msg_Sloc := Sloc (Asmt); 2656 Error_Msg_NE ("\\ variable & assigned #", Error_Nod, Var_Id); 2657 end Output_Variable_Assignment; 2658 2659 ------------------------------- 2660 -- Output_Variable_Reference -- 2661 ------------------------------- 2662 2663 procedure Output_Variable_Reference 2664 (Ref : Node_Id; 2665 Ref_Rep : Scenario_Rep_Id; 2666 Error_Nod : Node_Id) 2667 is 2668 Var_Id : constant Entity_Id := Target (Ref_Rep); 2669 2670 begin 2671 Error_Msg_Sloc := Sloc (Ref); 2672 Error_Msg_NE ("\\ variable & read #", Error_Nod, Var_Id); 2673 end Output_Variable_Reference; 2674 2675 ------------------------- 2676 -- Pop_Active_Scenario -- 2677 ------------------------- 2678 2679 procedure Pop_Active_Scenario (N : Node_Id) is 2680 package Scenarios renames Active_Scenario_Stack; 2681 Top : Node_Id renames Scenarios.Table (Scenarios.Last); 2682 2683 begin 2684 pragma Assert (Top = N); 2685 Scenarios.Decrement_Last; 2686 end Pop_Active_Scenario; 2687 2688 -------------------------- 2689 -- Push_Active_Scenario -- 2690 -------------------------- 2691 2692 procedure Push_Active_Scenario (N : Node_Id) is 2693 begin 2694 Active_Scenario_Stack.Append (N); 2695 end Push_Active_Scenario; 2696 2697 ------------------- 2698 -- Root_Scenario -- 2699 ------------------- 2700 2701 function Root_Scenario return Node_Id is 2702 package Scenarios renames Active_Scenario_Stack; 2703 2704 begin 2705 -- Ensure that the scenario stack has at least one active scenario in 2706 -- it. The one at the bottom (index First) is the root scenario. 2707 2708 pragma Assert (Scenarios.Last >= Scenarios.First); 2709 return Scenarios.Table (Scenarios.First); 2710 end Root_Scenario; 2711 end Active_Scenarios; 2712 2713 -------------------------- 2714 -- Activation_Processor -- 2715 -------------------------- 2716 2717 package body Activation_Processor is 2718 2719 ------------------------ 2720 -- Process_Activation -- 2721 ------------------------ 2722 2723 procedure Process_Activation 2724 (Call : Node_Id; 2725 Call_Rep : Scenario_Rep_Id; 2726 Processor : Activation_Processor_Ptr; 2727 In_State : Processing_In_State) 2728 is 2729 procedure Process_Task_Object (Obj_Id : Entity_Id; Typ : Entity_Id); 2730 pragma Inline (Process_Task_Object); 2731 -- Invoke Processor for task object Obj_Id of type Typ 2732 2733 procedure Process_Task_Objects 2734 (Task_Objs : NE_List.Doubly_Linked_List); 2735 pragma Inline (Process_Task_Objects); 2736 -- Invoke Processor for all task objects found in list Task_Objs 2737 2738 procedure Traverse_List 2739 (List : List_Id; 2740 Task_Objs : NE_List.Doubly_Linked_List); 2741 pragma Inline (Traverse_List); 2742 -- Traverse declarative or statement list List while searching for 2743 -- objects of a task type, or containing task components. If such an 2744 -- object is found, first save it in list Task_Objs and then invoke 2745 -- Processor on it. 2746 2747 ------------------------- 2748 -- Process_Task_Object -- 2749 ------------------------- 2750 2751 procedure Process_Task_Object (Obj_Id : Entity_Id; Typ : Entity_Id) is 2752 Root_Typ : constant Entity_Id := 2753 Non_Private_View (Root_Type (Typ)); 2754 Comp_Id : Entity_Id; 2755 Obj_Rep : Target_Rep_Id; 2756 Root_Rep : Target_Rep_Id; 2757 2758 New_In_State : Processing_In_State := In_State; 2759 -- Each step of the Processing phase constitutes a new state 2760 2761 begin 2762 if Is_Task_Type (Typ) then 2763 Obj_Rep := Target_Representation_Of (Obj_Id, New_In_State); 2764 Root_Rep := Target_Representation_Of (Root_Typ, New_In_State); 2765 2766 -- Warnings are suppressed when a prior scenario is already in 2767 -- that mode, or when the object, activation call, or task type 2768 -- have warnings suppressed. Update the state of the Processing 2769 -- phase to reflect this. 2770 2771 New_In_State.Suppress_Warnings := 2772 New_In_State.Suppress_Warnings 2773 or else not Elaboration_Warnings_OK (Call_Rep) 2774 or else not Elaboration_Warnings_OK (Obj_Rep) 2775 or else not Elaboration_Warnings_OK (Root_Rep); 2776 2777 -- Update the state of the Processing phase to indicate that 2778 -- any further traversal is now within a task body. 2779 2780 New_In_State.Within_Task_Body := True; 2781 2782 -- Associate the current task type with the activation call 2783 2784 Set_Activated_Task_Type (Call_Rep, Root_Typ); 2785 2786 -- Process the activation of the current task object by calling 2787 -- the supplied processor. 2788 2789 Processor.all 2790 (Call => Call, 2791 Call_Rep => Call_Rep, 2792 Obj_Id => Obj_Id, 2793 Obj_Rep => Obj_Rep, 2794 Task_Typ => Root_Typ, 2795 Task_Rep => Root_Rep, 2796 In_State => New_In_State); 2797 2798 -- Reset the association between the current task and the 2799 -- activtion call. 2800 2801 Set_Activated_Task_Type (Call_Rep, Empty); 2802 2803 -- Examine the component type when the object is an array 2804 2805 elsif Is_Array_Type (Typ) and then Has_Task (Root_Typ) then 2806 Process_Task_Object 2807 (Obj_Id => Obj_Id, 2808 Typ => Component_Type (Typ)); 2809 2810 -- Examine individual component types when the object is a record 2811 2812 elsif Is_Record_Type (Typ) and then Has_Task (Root_Typ) then 2813 Comp_Id := First_Component (Typ); 2814 while Present (Comp_Id) loop 2815 Process_Task_Object 2816 (Obj_Id => Obj_Id, 2817 Typ => Etype (Comp_Id)); 2818 2819 Next_Component (Comp_Id); 2820 end loop; 2821 end if; 2822 end Process_Task_Object; 2823 2824 -------------------------- 2825 -- Process_Task_Objects -- 2826 -------------------------- 2827 2828 procedure Process_Task_Objects 2829 (Task_Objs : NE_List.Doubly_Linked_List) 2830 is 2831 Iter : NE_List.Iterator; 2832 Obj_Id : Entity_Id; 2833 2834 begin 2835 Iter := NE_List.Iterate (Task_Objs); 2836 while NE_List.Has_Next (Iter) loop 2837 NE_List.Next (Iter, Obj_Id); 2838 2839 Process_Task_Object 2840 (Obj_Id => Obj_Id, 2841 Typ => Etype (Obj_Id)); 2842 end loop; 2843 end Process_Task_Objects; 2844 2845 ------------------- 2846 -- Traverse_List -- 2847 ------------------- 2848 2849 procedure Traverse_List 2850 (List : List_Id; 2851 Task_Objs : NE_List.Doubly_Linked_List) 2852 is 2853 Item : Node_Id; 2854 Item_Id : Entity_Id; 2855 Item_Typ : Entity_Id; 2856 2857 begin 2858 -- Examine the contents of the list looking for an object 2859 -- declaration of a task type or one that contains a task 2860 -- within. 2861 2862 Item := First (List); 2863 while Present (Item) loop 2864 if Nkind (Item) = N_Object_Declaration then 2865 Item_Id := Defining_Entity (Item); 2866 Item_Typ := Etype (Item_Id); 2867 2868 if Has_Task (Item_Typ) then 2869 2870 -- The object is either of a task type, or contains a 2871 -- task component. Save it in the list of task objects 2872 -- associated with the activation call. 2873 2874 NE_List.Append (Task_Objs, Item_Id); 2875 2876 Process_Task_Object 2877 (Obj_Id => Item_Id, 2878 Typ => Item_Typ); 2879 end if; 2880 end if; 2881 2882 Next (Item); 2883 end loop; 2884 end Traverse_List; 2885 2886 -- Local variables 2887 2888 Context : Node_Id; 2889 Spec : Node_Id; 2890 Task_Objs : NE_List.Doubly_Linked_List; 2891 2892 -- Start of processing for Process_Activation 2893 2894 begin 2895 -- Nothing to do when the activation is a guaranteed ABE 2896 2897 if Is_Known_Guaranteed_ABE (Call) then 2898 return; 2899 end if; 2900 2901 Task_Objs := Activated_Task_Objects (Call_Rep); 2902 2903 -- The activation call has been processed at least once, and all 2904 -- task objects have already been collected. Directly process the 2905 -- objects without having to reexamine the context of the call. 2906 2907 if NE_List.Present (Task_Objs) then 2908 Process_Task_Objects (Task_Objs); 2909 2910 -- Otherwise the activation call is being processed for the first 2911 -- time. Collect all task objects in case the call is reprocessed 2912 -- multiple times. 2913 2914 else 2915 Task_Objs := NE_List.Create; 2916 Set_Activated_Task_Objects (Call_Rep, Task_Objs); 2917 2918 -- Find the context of the activation call where all task objects 2919 -- being activated are declared. This is usually the parent of the 2920 -- call. 2921 2922 Context := Parent (Call); 2923 2924 -- Handle the case where the activation call appears within the 2925 -- handled statements of a block or a body. 2926 2927 if Nkind (Context) = N_Handled_Sequence_Of_Statements then 2928 Context := Parent (Context); 2929 end if; 2930 2931 -- Process all task objects in both the spec and body when the 2932 -- activation call appears in a package body. 2933 2934 if Nkind (Context) = N_Package_Body then 2935 Spec := 2936 Specification 2937 (Unit_Declaration_Node (Corresponding_Spec (Context))); 2938 2939 Traverse_List 2940 (List => Visible_Declarations (Spec), 2941 Task_Objs => Task_Objs); 2942 2943 Traverse_List 2944 (List => Private_Declarations (Spec), 2945 Task_Objs => Task_Objs); 2946 2947 Traverse_List 2948 (List => Declarations (Context), 2949 Task_Objs => Task_Objs); 2950 2951 -- Process all task objects in the spec when the activation call 2952 -- appears in a package spec. 2953 2954 elsif Nkind (Context) = N_Package_Specification then 2955 Traverse_List 2956 (List => Visible_Declarations (Context), 2957 Task_Objs => Task_Objs); 2958 2959 Traverse_List 2960 (List => Private_Declarations (Context), 2961 Task_Objs => Task_Objs); 2962 2963 -- Otherwise the context must be a block or a body. Process all 2964 -- task objects found in the declarations. 2965 2966 else 2967 pragma Assert 2968 (Nkind (Context) in 2969 N_Block_Statement | N_Entry_Body | N_Protected_Body | 2970 N_Subprogram_Body | N_Task_Body); 2971 2972 Traverse_List 2973 (List => Declarations (Context), 2974 Task_Objs => Task_Objs); 2975 end if; 2976 end if; 2977 end Process_Activation; 2978 end Activation_Processor; 2979 2980 ----------------------- 2981 -- Assignment_Target -- 2982 ----------------------- 2983 2984 function Assignment_Target (Asmt : Node_Id) return Node_Id is 2985 Nam : Node_Id; 2986 2987 begin 2988 Nam := Name (Asmt); 2989 2990 -- When the name denotes an array or record component, find the whole 2991 -- object. 2992 2993 while Nkind (Nam) in 2994 N_Explicit_Dereference | N_Indexed_Component | 2995 N_Selected_Component | N_Slice 2996 loop 2997 Nam := Prefix (Nam); 2998 end loop; 2999 3000 return Nam; 3001 end Assignment_Target; 3002 3003 -------------------- 3004 -- Body_Processor -- 3005 -------------------- 3006 3007 package body Body_Processor is 3008 3009 --------------------- 3010 -- Data structures -- 3011 --------------------- 3012 3013 -- The following map relates scenario lists to subprogram bodies 3014 3015 Nested_Scenarios_Map : NE_List_Map.Dynamic_Hash_Table := NE_List_Map.Nil; 3016 3017 -- The following set contains all subprogram bodies that have been 3018 -- processed by routine Traverse_Body. 3019 3020 Traversed_Bodies_Set : NE_Set.Membership_Set := NE_Set.Nil; 3021 3022 ----------------------- 3023 -- Local subprograms -- 3024 ----------------------- 3025 3026 function Is_Traversed_Body (N : Node_Id) return Boolean; 3027 pragma Inline (Is_Traversed_Body); 3028 -- Determine whether subprogram body N has already been traversed 3029 3030 function Nested_Scenarios 3031 (N : Node_Id) return NE_List.Doubly_Linked_List; 3032 pragma Inline (Nested_Scenarios); 3033 -- Obtain the list of scenarios associated with subprogram body N 3034 3035 procedure Set_Is_Traversed_Body 3036 (N : Node_Id; 3037 Val : Boolean := True); 3038 pragma Inline (Set_Is_Traversed_Body); 3039 -- Mark subprogram body N as traversed depending on value Val 3040 3041 procedure Set_Nested_Scenarios 3042 (N : Node_Id; 3043 Scenarios : NE_List.Doubly_Linked_List); 3044 pragma Inline (Set_Nested_Scenarios); 3045 -- Associate scenario list Scenarios with subprogram body N 3046 3047 ----------------------------- 3048 -- Finalize_Body_Processor -- 3049 ----------------------------- 3050 3051 procedure Finalize_Body_Processor is 3052 begin 3053 NE_List_Map.Destroy (Nested_Scenarios_Map); 3054 NE_Set.Destroy (Traversed_Bodies_Set); 3055 end Finalize_Body_Processor; 3056 3057 ------------------------------- 3058 -- Initialize_Body_Processor -- 3059 ------------------------------- 3060 3061 procedure Initialize_Body_Processor is 3062 begin 3063 Nested_Scenarios_Map := NE_List_Map.Create (250); 3064 Traversed_Bodies_Set := NE_Set.Create (250); 3065 end Initialize_Body_Processor; 3066 3067 ----------------------- 3068 -- Is_Traversed_Body -- 3069 ----------------------- 3070 3071 function Is_Traversed_Body (N : Node_Id) return Boolean is 3072 pragma Assert (Present (N)); 3073 begin 3074 return NE_Set.Contains (Traversed_Bodies_Set, N); 3075 end Is_Traversed_Body; 3076 3077 ---------------------- 3078 -- Nested_Scenarios -- 3079 ---------------------- 3080 3081 function Nested_Scenarios 3082 (N : Node_Id) return NE_List.Doubly_Linked_List 3083 is 3084 pragma Assert (Present (N)); 3085 pragma Assert (Nkind (N) = N_Subprogram_Body); 3086 3087 begin 3088 return NE_List_Map.Get (Nested_Scenarios_Map, N); 3089 end Nested_Scenarios; 3090 3091 ---------------------------- 3092 -- Reset_Traversed_Bodies -- 3093 ---------------------------- 3094 3095 procedure Reset_Traversed_Bodies is 3096 begin 3097 NE_Set.Reset (Traversed_Bodies_Set); 3098 end Reset_Traversed_Bodies; 3099 3100 --------------------------- 3101 -- Set_Is_Traversed_Body -- 3102 --------------------------- 3103 3104 procedure Set_Is_Traversed_Body 3105 (N : Node_Id; 3106 Val : Boolean := True) 3107 is 3108 pragma Assert (Present (N)); 3109 3110 begin 3111 if Val then 3112 NE_Set.Insert (Traversed_Bodies_Set, N); 3113 else 3114 NE_Set.Delete (Traversed_Bodies_Set, N); 3115 end if; 3116 end Set_Is_Traversed_Body; 3117 3118 -------------------------- 3119 -- Set_Nested_Scenarios -- 3120 -------------------------- 3121 3122 procedure Set_Nested_Scenarios 3123 (N : Node_Id; 3124 Scenarios : NE_List.Doubly_Linked_List) 3125 is 3126 pragma Assert (Present (N)); 3127 begin 3128 NE_List_Map.Put (Nested_Scenarios_Map, N, Scenarios); 3129 end Set_Nested_Scenarios; 3130 3131 ------------------- 3132 -- Traverse_Body -- 3133 ------------------- 3134 3135 procedure Traverse_Body 3136 (N : Node_Id; 3137 Requires_Processing : Scenario_Predicate_Ptr; 3138 Processor : Scenario_Processor_Ptr; 3139 In_State : Processing_In_State) 3140 is 3141 Scenarios : NE_List.Doubly_Linked_List := NE_List.Nil; 3142 -- The list of scenarios that appear within the declarations and 3143 -- statement of subprogram body N. The variable is intentionally 3144 -- global because Is_Potential_Scenario needs to populate it. 3145 3146 function In_Task_Body (Nod : Node_Id) return Boolean; 3147 pragma Inline (In_Task_Body); 3148 -- Determine whether arbitrary node Nod appears within a task body 3149 3150 function Is_Synchronous_Suspension_Call 3151 (Nod : Node_Id) return Boolean; 3152 pragma Inline (Is_Synchronous_Suspension_Call); 3153 -- Determine whether arbitrary node Nod denotes a call to one of 3154 -- these routines: 3155 -- 3156 -- Ada.Synchronous_Barriers.Wait_For_Release 3157 -- Ada.Synchronous_Task_Control.Suspend_Until_True 3158 3159 procedure Traverse_Collected_Scenarios; 3160 pragma Inline (Traverse_Collected_Scenarios); 3161 -- Traverse the already collected scenarios in list Scenarios by 3162 -- invoking Processor on each individual one. 3163 3164 procedure Traverse_List (List : List_Id); 3165 pragma Inline (Traverse_List); 3166 -- Invoke Traverse_Potential_Scenarios on each node in list List 3167 3168 function Traverse_Potential_Scenario 3169 (Scen : Node_Id) return Traverse_Result; 3170 pragma Inline (Traverse_Potential_Scenario); 3171 -- Determine whether arbitrary node Scen is a suitable scenario using 3172 -- predicate Is_Scenario and traverse it by invoking Processor on it. 3173 3174 procedure Traverse_Potential_Scenarios is 3175 new Traverse_Proc (Traverse_Potential_Scenario); 3176 3177 ------------------ 3178 -- In_Task_Body -- 3179 ------------------ 3180 3181 function In_Task_Body (Nod : Node_Id) return Boolean is 3182 Par : Node_Id; 3183 3184 begin 3185 -- Climb the parent chain looking for a task body [procedure] 3186 3187 Par := Nod; 3188 while Present (Par) loop 3189 if Nkind (Par) = N_Task_Body then 3190 return True; 3191 3192 elsif Nkind (Par) = N_Subprogram_Body 3193 and then Is_Task_Body_Procedure (Par) 3194 then 3195 return True; 3196 3197 -- Prevent the search from going too far. Note that this test 3198 -- shares nodes with the two cases above, and must come last. 3199 3200 elsif Is_Body_Or_Package_Declaration (Par) then 3201 return False; 3202 end if; 3203 3204 Par := Parent (Par); 3205 end loop; 3206 3207 return False; 3208 end In_Task_Body; 3209 3210 ------------------------------------ 3211 -- Is_Synchronous_Suspension_Call -- 3212 ------------------------------------ 3213 3214 function Is_Synchronous_Suspension_Call 3215 (Nod : Node_Id) return Boolean 3216 is 3217 Subp_Id : Entity_Id; 3218 3219 begin 3220 -- To qualify, the call must invoke one of the runtime routines 3221 -- which perform synchronous suspension. 3222 3223 if Is_Suitable_Call (Nod) then 3224 Subp_Id := Target (Nod); 3225 3226 return 3227 Is_RTE (Subp_Id, RE_Suspend_Until_True) 3228 or else 3229 Is_RTE (Subp_Id, RE_Wait_For_Release); 3230 end if; 3231 3232 return False; 3233 end Is_Synchronous_Suspension_Call; 3234 3235 ---------------------------------- 3236 -- Traverse_Collected_Scenarios -- 3237 ---------------------------------- 3238 3239 procedure Traverse_Collected_Scenarios is 3240 Iter : NE_List.Iterator; 3241 Scen : Node_Id; 3242 3243 begin 3244 Iter := NE_List.Iterate (Scenarios); 3245 while NE_List.Has_Next (Iter) loop 3246 NE_List.Next (Iter, Scen); 3247 3248 -- The current scenario satisfies the input predicate, process 3249 -- it. 3250 3251 if Requires_Processing.all (Scen) then 3252 Processor.all (Scen, In_State); 3253 end if; 3254 end loop; 3255 end Traverse_Collected_Scenarios; 3256 3257 ------------------- 3258 -- Traverse_List -- 3259 ------------------- 3260 3261 procedure Traverse_List (List : List_Id) is 3262 Scen : Node_Id; 3263 3264 begin 3265 Scen := First (List); 3266 while Present (Scen) loop 3267 Traverse_Potential_Scenarios (Scen); 3268 Next (Scen); 3269 end loop; 3270 end Traverse_List; 3271 3272 --------------------------------- 3273 -- Traverse_Potential_Scenario -- 3274 --------------------------------- 3275 3276 function Traverse_Potential_Scenario 3277 (Scen : Node_Id) return Traverse_Result 3278 is 3279 begin 3280 -- Special cases 3281 3282 -- Skip constructs which do not have elaboration of their own and 3283 -- need to be elaborated by other means such as invocation, task 3284 -- activation, etc. 3285 3286 if Is_Non_Library_Level_Encapsulator (Scen) then 3287 return Skip; 3288 3289 -- Terminate the traversal of a task body when encountering an 3290 -- accept or select statement, and 3291 -- 3292 -- * Entry calls during elaboration are not allowed. In this 3293 -- case the accept or select statement will cause the task 3294 -- to block at elaboration time because there are no entry 3295 -- calls to unblock it. 3296 -- 3297 -- or 3298 -- 3299 -- * Switch -gnatd_a (stop elaboration checks on accept or 3300 -- select statement) is in effect. 3301 3302 elsif (Debug_Flag_Underscore_A 3303 or else Restriction_Active 3304 (No_Entry_Calls_In_Elaboration_Code)) 3305 and then Nkind (Original_Node (Scen)) in 3306 N_Accept_Statement | N_Selective_Accept 3307 then 3308 return Abandon; 3309 3310 -- Terminate the traversal of a task body when encountering a 3311 -- suspension call, and 3312 -- 3313 -- * Entry calls during elaboration are not allowed. In this 3314 -- case the suspension call emulates an entry call and will 3315 -- cause the task to block at elaboration time. 3316 -- 3317 -- or 3318 -- 3319 -- * Switch -gnatd_s (stop elaboration checks on synchronous 3320 -- suspension) is in effect. 3321 -- 3322 -- Note that the guard should not be checking the state of flag 3323 -- Within_Task_Body because only suspension calls which appear 3324 -- immediately within the statements of the task are supported. 3325 -- Flag Within_Task_Body carries over to deeper levels of the 3326 -- traversal. 3327 3328 elsif (Debug_Flag_Underscore_S 3329 or else Restriction_Active 3330 (No_Entry_Calls_In_Elaboration_Code)) 3331 and then Is_Synchronous_Suspension_Call (Scen) 3332 and then In_Task_Body (Scen) 3333 then 3334 return Abandon; 3335 3336 -- Certain nodes carry semantic lists which act as repositories 3337 -- until expansion transforms the node and relocates the contents. 3338 -- Examine these lists in case expansion is disabled. 3339 3340 elsif Nkind (Scen) in N_And_Then | N_Or_Else then 3341 Traverse_List (Actions (Scen)); 3342 3343 elsif Nkind (Scen) in N_Elsif_Part | N_Iteration_Scheme then 3344 Traverse_List (Condition_Actions (Scen)); 3345 3346 elsif Nkind (Scen) = N_If_Expression then 3347 Traverse_List (Then_Actions (Scen)); 3348 Traverse_List (Else_Actions (Scen)); 3349 3350 elsif Nkind (Scen) in 3351 N_Component_Association | N_Iterated_Component_Association 3352 then 3353 Traverse_List (Loop_Actions (Scen)); 3354 3355 -- General case 3356 3357 -- The current node satisfies the input predicate, process it 3358 3359 elsif Requires_Processing.all (Scen) then 3360 Processor.all (Scen, In_State); 3361 end if; 3362 3363 -- Save a general scenario regardless of whether it satisfies the 3364 -- input predicate. This allows for quick subsequent traversals of 3365 -- general scenarios, even with different predicates. 3366 3367 if Is_Suitable_Access_Taken (Scen) 3368 or else Is_Suitable_Call (Scen) 3369 or else Is_Suitable_Instantiation (Scen) 3370 or else Is_Suitable_Variable_Assignment (Scen) 3371 or else Is_Suitable_Variable_Reference (Scen) 3372 then 3373 NE_List.Append (Scenarios, Scen); 3374 end if; 3375 3376 return OK; 3377 end Traverse_Potential_Scenario; 3378 3379 -- Start of processing for Traverse_Body 3380 3381 begin 3382 -- Nothing to do when the traversal is suppressed 3383 3384 if In_State.Traversal = No_Traversal then 3385 return; 3386 3387 -- Nothing to do when there is no input 3388 3389 elsif No (N) then 3390 return; 3391 3392 -- Nothing to do when the input is not a subprogram body 3393 3394 elsif Nkind (N) /= N_Subprogram_Body then 3395 return; 3396 3397 -- Nothing to do if the subprogram body was already traversed 3398 3399 elsif Is_Traversed_Body (N) then 3400 return; 3401 end if; 3402 3403 -- Mark the subprogram body as traversed 3404 3405 Set_Is_Traversed_Body (N); 3406 3407 Scenarios := Nested_Scenarios (N); 3408 3409 -- The subprogram body has been traversed at least once, and all 3410 -- scenarios that appear within its declarations and statements 3411 -- have already been collected. Directly retraverse the scenarios 3412 -- without having to retraverse the subprogram body subtree. 3413 3414 if NE_List.Present (Scenarios) then 3415 Traverse_Collected_Scenarios; 3416 3417 -- Otherwise the subprogram body is being traversed for the first 3418 -- time. Collect all scenarios that appear within its declarations 3419 -- and statements in case the subprogram body has to be retraversed 3420 -- multiple times. 3421 3422 else 3423 Scenarios := NE_List.Create; 3424 Set_Nested_Scenarios (N, Scenarios); 3425 3426 Traverse_List (Declarations (N)); 3427 Traverse_Potential_Scenarios (Handled_Statement_Sequence (N)); 3428 end if; 3429 end Traverse_Body; 3430 end Body_Processor; 3431 3432 ----------------------- 3433 -- Build_Call_Marker -- 3434 ----------------------- 3435 3436 procedure Build_Call_Marker (N : Node_Id) is 3437 function In_External_Context 3438 (Call : Node_Id; 3439 Subp_Id : Entity_Id) return Boolean; 3440 pragma Inline (In_External_Context); 3441 -- Determine whether entry, operator, or subprogram Subp_Id is external 3442 -- to call Call which must reside within an instance. 3443 3444 function In_Premature_Context (Call : Node_Id) return Boolean; 3445 pragma Inline (In_Premature_Context); 3446 -- Determine whether call Call appears within a premature context 3447 3448 function Is_Default_Expression (Call : Node_Id) return Boolean; 3449 pragma Inline (Is_Default_Expression); 3450 -- Determine whether call Call acts as the expression of a defaulted 3451 -- parameter within a source call. 3452 3453 function Is_Generic_Formal_Subp (Subp_Id : Entity_Id) return Boolean; 3454 pragma Inline (Is_Generic_Formal_Subp); 3455 -- Determine whether subprogram Subp_Id denotes a generic formal 3456 -- subprogram which appears in the "prologue" of an instantiation. 3457 3458 ------------------------- 3459 -- In_External_Context -- 3460 ------------------------- 3461 3462 function In_External_Context 3463 (Call : Node_Id; 3464 Subp_Id : Entity_Id) return Boolean 3465 is 3466 Spec_Decl : constant Entity_Id := Unit_Declaration_Node (Subp_Id); 3467 3468 Inst : Node_Id; 3469 Inst_Body : Node_Id; 3470 Inst_Spec : Node_Id; 3471 3472 begin 3473 Inst := Find_Enclosing_Instance (Call); 3474 3475 -- The call appears within an instance 3476 3477 if Present (Inst) then 3478 3479 -- The call comes from the main unit and the target does not 3480 3481 if In_Extended_Main_Code_Unit (Call) 3482 and then not In_Extended_Main_Code_Unit (Spec_Decl) 3483 then 3484 return True; 3485 3486 -- Otherwise the target declaration must not appear within the 3487 -- instance spec or body. 3488 3489 else 3490 Spec_And_Body_From_Node 3491 (N => Inst, 3492 Spec_Decl => Inst_Spec, 3493 Body_Decl => Inst_Body); 3494 3495 return not In_Subtree 3496 (N => Spec_Decl, 3497 Root1 => Inst_Spec, 3498 Root2 => Inst_Body); 3499 end if; 3500 end if; 3501 3502 return False; 3503 end In_External_Context; 3504 3505 -------------------------- 3506 -- In_Premature_Context -- 3507 -------------------------- 3508 3509 function In_Premature_Context (Call : Node_Id) return Boolean is 3510 Par : Node_Id; 3511 3512 begin 3513 -- Climb the parent chain looking for premature contexts 3514 3515 Par := Parent (Call); 3516 while Present (Par) loop 3517 3518 -- Aspect specifications and generic associations are premature 3519 -- contexts because nested calls has not been relocated to their 3520 -- final context. 3521 3522 if Nkind (Par) in N_Aspect_Specification | N_Generic_Association 3523 then 3524 return True; 3525 3526 -- Prevent the search from going too far 3527 3528 elsif Is_Body_Or_Package_Declaration (Par) then 3529 exit; 3530 end if; 3531 3532 Par := Parent (Par); 3533 end loop; 3534 3535 return False; 3536 end In_Premature_Context; 3537 3538 --------------------------- 3539 -- Is_Default_Expression -- 3540 --------------------------- 3541 3542 function Is_Default_Expression (Call : Node_Id) return Boolean is 3543 Outer_Call : constant Node_Id := Parent (Call); 3544 Outer_Nam : Node_Id; 3545 3546 begin 3547 -- To qualify, the node must appear immediately within a source call 3548 -- which invokes a source target. 3549 3550 if Nkind (Outer_Call) in N_Entry_Call_Statement 3551 | N_Function_Call 3552 | N_Procedure_Call_Statement 3553 and then Comes_From_Source (Outer_Call) 3554 then 3555 Outer_Nam := Call_Name (Outer_Call); 3556 3557 return 3558 Is_Entity_Name (Outer_Nam) 3559 and then Present (Entity (Outer_Nam)) 3560 and then Is_Subprogram_Or_Entry (Entity (Outer_Nam)) 3561 and then Comes_From_Source (Entity (Outer_Nam)); 3562 end if; 3563 3564 return False; 3565 end Is_Default_Expression; 3566 3567 ---------------------------- 3568 -- Is_Generic_Formal_Subp -- 3569 ---------------------------- 3570 3571 function Is_Generic_Formal_Subp (Subp_Id : Entity_Id) return Boolean is 3572 Subp_Decl : constant Node_Id := Unit_Declaration_Node (Subp_Id); 3573 Context : constant Node_Id := Parent (Subp_Decl); 3574 3575 begin 3576 -- To qualify, the subprogram must rename a generic actual subprogram 3577 -- where the enclosing context is an instantiation. 3578 3579 return 3580 Nkind (Subp_Decl) = N_Subprogram_Renaming_Declaration 3581 and then not Comes_From_Source (Subp_Decl) 3582 and then Nkind (Context) in N_Function_Specification 3583 | N_Package_Specification 3584 | N_Procedure_Specification 3585 and then Present (Generic_Parent (Context)); 3586 end Is_Generic_Formal_Subp; 3587 3588 -- Local variables 3589 3590 Call_Nam : Node_Id; 3591 Marker : Node_Id; 3592 Subp_Id : Entity_Id; 3593 3594 -- Start of processing for Build_Call_Marker 3595 3596 begin 3597 -- Nothing to do when switch -gnatH (legacy elaboration checking mode 3598 -- enabled) is in effect because the legacy ABE mechanism does not need 3599 -- to carry out this action. 3600 3601 if Legacy_Elaboration_Checks then 3602 return; 3603 3604 -- Nothing to do when the call is being preanalyzed as the marker will 3605 -- be inserted in the wrong place. 3606 3607 elsif Preanalysis_Active then 3608 return; 3609 3610 -- Nothing to do when the elaboration phase of the compiler is not 3611 -- active. 3612 3613 elsif not Elaboration_Phase_Active then 3614 return; 3615 3616 -- Nothing to do when the input does not denote a call or a requeue 3617 3618 elsif Nkind (N) not in N_Entry_Call_Statement 3619 | N_Function_Call 3620 | N_Procedure_Call_Statement 3621 | N_Requeue_Statement 3622 then 3623 return; 3624 3625 -- Nothing to do when the input denotes entry call or requeue statement, 3626 -- and switch -gnatd_e (ignore entry calls and requeue statements for 3627 -- elaboration) is in effect. 3628 3629 elsif Debug_Flag_Underscore_E 3630 and then Nkind (N) in N_Entry_Call_Statement | N_Requeue_Statement 3631 then 3632 return; 3633 3634 -- Nothing to do when the call is analyzed/resolved too early within an 3635 -- intermediate context. This check is saved for last because it incurs 3636 -- a performance penalty. 3637 3638 elsif In_Premature_Context (N) then 3639 return; 3640 end if; 3641 3642 Call_Nam := Call_Name (N); 3643 3644 -- Nothing to do when the call is erroneous or left in a bad state 3645 3646 if not (Is_Entity_Name (Call_Nam) 3647 and then Present (Entity (Call_Nam)) 3648 and then Is_Subprogram_Or_Entry (Entity (Call_Nam))) 3649 then 3650 return; 3651 end if; 3652 3653 Subp_Id := Canonical_Subprogram (Entity (Call_Nam)); 3654 3655 -- Nothing to do when the call invokes a generic formal subprogram and 3656 -- switch -gnatd.G (ignore calls through generic formal parameters for 3657 -- elaboration) is in effect. This check must be performed with the 3658 -- direct target of the call to avoid the side effects of mapping 3659 -- actuals to formals using renamings. 3660 3661 if Debug_Flag_Dot_GG 3662 and then Is_Generic_Formal_Subp (Entity (Call_Nam)) 3663 then 3664 return; 3665 3666 -- Nothing to do when the call appears within the expanded spec or 3667 -- body of an instantiated generic, the call does not invoke a generic 3668 -- formal subprogram, the target is external to the instance, and switch 3669 -- -gnatdL (ignore external calls from instances for elaboration) is in 3670 -- effect. This check must be performed with the direct target of the 3671 -- call to avoid the side effects of mapping actuals to formals using 3672 -- renamings. 3673 3674 elsif Debug_Flag_LL 3675 and then not Is_Generic_Formal_Subp (Entity (Call_Nam)) 3676 and then In_External_Context 3677 (Call => N, 3678 Subp_Id => Subp_Id) 3679 then 3680 return; 3681 3682 -- Nothing to do when the call invokes an assertion pragma procedure 3683 -- and switch -gnatd_p (ignore assertion pragmas for elaboration) is 3684 -- in effect. 3685 3686 elsif Debug_Flag_Underscore_P 3687 and then Is_Assertion_Pragma_Target (Subp_Id) 3688 then 3689 return; 3690 3691 -- Static expression functions require no ABE processing 3692 3693 elsif Is_Static_Function (Subp_Id) then 3694 return; 3695 3696 -- Source calls to source targets are always considered because they 3697 -- reflect the original call graph. 3698 3699 elsif Comes_From_Source (N) and then Comes_From_Source (Subp_Id) then 3700 null; 3701 3702 -- A call to a source function which acts as the default expression in 3703 -- another call requires special detection. 3704 3705 elsif Comes_From_Source (Subp_Id) 3706 and then Nkind (N) = N_Function_Call 3707 and then Is_Default_Expression (N) 3708 then 3709 null; 3710 3711 -- The target emulates Ada semantics 3712 3713 elsif Is_Ada_Semantic_Target (Subp_Id) then 3714 null; 3715 3716 -- The target acts as a link between scenarios 3717 3718 elsif Is_Bridge_Target (Subp_Id) then 3719 null; 3720 3721 -- The target emulates SPARK semantics 3722 3723 elsif Is_SPARK_Semantic_Target (Subp_Id) then 3724 null; 3725 3726 -- Otherwise the call is not suitable for ABE processing. This prevents 3727 -- the generation of call markers which will never play a role in ABE 3728 -- diagnostics. 3729 3730 else 3731 return; 3732 end if; 3733 3734 -- At this point it is known that the call will play some role in ABE 3735 -- checks and diagnostics. Create a corresponding call marker in case 3736 -- the original call is heavily transformed by expansion later on. 3737 3738 Marker := Make_Call_Marker (Sloc (N)); 3739 3740 -- Inherit the attributes of the original call 3741 3742 Set_Is_Declaration_Level_Node 3743 (Marker, Find_Enclosing_Level (N) = Declaration_Level); 3744 3745 Set_Is_Dispatching_Call 3746 (Marker, 3747 Nkind (N) in N_Subprogram_Call 3748 and then Present (Controlling_Argument (N))); 3749 3750 Set_Is_Elaboration_Checks_OK_Node 3751 (Marker, Is_Elaboration_Checks_OK_Node (N)); 3752 3753 Set_Is_Elaboration_Warnings_OK_Node 3754 (Marker, Is_Elaboration_Warnings_OK_Node (N)); 3755 3756 Set_Is_Ignored_Ghost_Node (Marker, Is_Ignored_Ghost_Node (N)); 3757 Set_Is_Source_Call (Marker, Comes_From_Source (N)); 3758 Set_Is_SPARK_Mode_On_Node (Marker, Is_SPARK_Mode_On_Node (N)); 3759 Set_Target (Marker, Subp_Id); 3760 3761 -- Ada 2020 (AI12-0175): Calls to certain functions that are essentially 3762 -- unchecked conversions are preelaborable. 3763 3764 if Ada_Version >= Ada_2020 then 3765 Set_Is_Preelaborable_Call (Marker, Is_Preelaborable_Construct (N)); 3766 else 3767 Set_Is_Preelaborable_Call (Marker, False); 3768 end if; 3769 3770 -- The marker is inserted prior to the original call. This placement has 3771 -- several desirable effects: 3772 3773 -- 1) The marker appears in the same context, in close proximity to 3774 -- the call. 3775 3776 -- <marker> 3777 -- <call> 3778 3779 -- 2) Inserting the marker prior to the call ensures that an ABE check 3780 -- will take effect prior to the call. 3781 3782 -- <ABE check> 3783 -- <marker> 3784 -- <call> 3785 3786 -- 3) The above two properties are preserved even when the call is a 3787 -- function which is subsequently relocated in order to capture its 3788 -- result. Note that if the call is relocated to a new context, the 3789 -- relocated call will receive a marker of its own. 3790 3791 -- <ABE check> 3792 -- <maker> 3793 -- Temp : ... := Func_Call ...; 3794 -- ... Temp ... 3795 3796 -- The insertion must take place even when the call does not occur in 3797 -- the main unit to keep the tree symmetric. This ensures that internal 3798 -- name serialization is consistent in case the call marker causes the 3799 -- tree to transform in some way. 3800 3801 Insert_Action (N, Marker); 3802 3803 -- The marker becomes the "corresponding" scenario for the call. Save 3804 -- the marker for later processing by the ABE phase. 3805 3806 Record_Elaboration_Scenario (Marker); 3807 end Build_Call_Marker; 3808 3809 ------------------------------------- 3810 -- Build_Variable_Reference_Marker -- 3811 ------------------------------------- 3812 3813 procedure Build_Variable_Reference_Marker 3814 (N : Node_Id; 3815 Read : Boolean; 3816 Write : Boolean) 3817 is 3818 function Ultimate_Variable (Var_Id : Entity_Id) return Entity_Id; 3819 pragma Inline (Ultimate_Variable); 3820 -- Obtain the ultimate renamed variable of variable Var_Id 3821 3822 ----------------------- 3823 -- Ultimate_Variable -- 3824 ----------------------- 3825 3826 function Ultimate_Variable (Var_Id : Entity_Id) return Entity_Id is 3827 Ren_Id : Entity_Id; 3828 3829 begin 3830 Ren_Id := Var_Id; 3831 while Present (Renamed_Entity (Ren_Id)) 3832 and then Nkind (Renamed_Entity (Ren_Id)) in N_Entity 3833 loop 3834 Ren_Id := Renamed_Entity (Ren_Id); 3835 end loop; 3836 3837 return Ren_Id; 3838 end Ultimate_Variable; 3839 3840 -- Local variables 3841 3842 Var_Id : constant Entity_Id := Ultimate_Variable (Entity (N)); 3843 Marker : Node_Id; 3844 3845 -- Start of processing for Build_Variable_Reference_Marker 3846 3847 begin 3848 -- Nothing to do when the elaboration phase of the compiler is not 3849 -- active. 3850 3851 if not Elaboration_Phase_Active then 3852 return; 3853 end if; 3854 3855 Marker := Make_Variable_Reference_Marker (Sloc (N)); 3856 3857 -- Inherit the attributes of the original variable reference 3858 3859 Set_Is_Elaboration_Checks_OK_Node 3860 (Marker, Is_Elaboration_Checks_OK_Node (N)); 3861 3862 Set_Is_Elaboration_Warnings_OK_Node 3863 (Marker, Is_Elaboration_Warnings_OK_Node (N)); 3864 3865 Set_Is_Read (Marker, Read); 3866 Set_Is_SPARK_Mode_On_Node (Marker, Is_SPARK_Mode_On_Node (N)); 3867 Set_Is_Write (Marker, Write); 3868 Set_Target (Marker, Var_Id); 3869 3870 -- The marker is inserted prior to the original variable reference. The 3871 -- insertion must take place even when the reference does not occur in 3872 -- the main unit to keep the tree symmetric. This ensures that internal 3873 -- name serialization is consistent in case the variable marker causes 3874 -- the tree to transform in some way. 3875 3876 Insert_Action (N, Marker); 3877 3878 -- The marker becomes the "corresponding" scenario for the reference. 3879 -- Save the marker for later processing for the ABE phase. 3880 3881 Record_Elaboration_Scenario (Marker); 3882 end Build_Variable_Reference_Marker; 3883 3884 --------------- 3885 -- Call_Name -- 3886 --------------- 3887 3888 function Call_Name (Call : Node_Id) return Node_Id is 3889 Nam : Node_Id; 3890 3891 begin 3892 Nam := Name (Call); 3893 3894 -- When the call invokes an entry family, the name appears as an indexed 3895 -- component. 3896 3897 if Nkind (Nam) = N_Indexed_Component then 3898 Nam := Prefix (Nam); 3899 end if; 3900 3901 -- When the call employs the object.operation form, the name appears as 3902 -- a selected component. 3903 3904 if Nkind (Nam) = N_Selected_Component then 3905 Nam := Selector_Name (Nam); 3906 end if; 3907 3908 return Nam; 3909 end Call_Name; 3910 3911 -------------------------- 3912 -- Canonical_Subprogram -- 3913 -------------------------- 3914 3915 function Canonical_Subprogram (Subp_Id : Entity_Id) return Entity_Id is 3916 Canon_Id : Entity_Id; 3917 3918 begin 3919 Canon_Id := Subp_Id; 3920 3921 -- Use the original protected subprogram when dealing with one of the 3922 -- specialized lock-manipulating versions. 3923 3924 if Is_Protected_Body_Subp (Canon_Id) then 3925 Canon_Id := Protected_Subprogram (Canon_Id); 3926 end if; 3927 3928 -- Obtain the original subprogram except when the subprogram is also 3929 -- an instantiation. In this case the alias is the internally generated 3930 -- subprogram which appears within the anonymous package created for the 3931 -- instantiation, making it unuitable. 3932 3933 if not Is_Generic_Instance (Canon_Id) then 3934 Canon_Id := Get_Renamed_Entity (Canon_Id); 3935 end if; 3936 3937 return Canon_Id; 3938 end Canonical_Subprogram; 3939 3940 --------------------------------- 3941 -- Check_Elaboration_Scenarios -- 3942 --------------------------------- 3943 3944 procedure Check_Elaboration_Scenarios is 3945 Iter : NE_Set.Iterator; 3946 3947 begin 3948 -- Nothing to do when switch -gnatH (legacy elaboration checking mode 3949 -- enabled) is in effect because the legacy ABE mechanism does not need 3950 -- to carry out this action. 3951 3952 if Legacy_Elaboration_Checks then 3953 Finalize_All_Data_Structures; 3954 return; 3955 3956 -- Nothing to do when the elaboration phase of the compiler is not 3957 -- active. 3958 3959 elsif not Elaboration_Phase_Active then 3960 Finalize_All_Data_Structures; 3961 return; 3962 end if; 3963 3964 -- Restore the original elaboration model which was in effect when the 3965 -- scenarios were first recorded. The model may be specified by pragma 3966 -- Elaboration_Checks which appears on the initial declaration of the 3967 -- main unit. 3968 3969 Install_Elaboration_Model (Unit_Entity (Main_Unit_Entity)); 3970 3971 -- Examine the context of the main unit and record all units with prior 3972 -- elaboration with respect to it. 3973 3974 Collect_Elaborated_Units; 3975 3976 -- Examine all scenarios saved during the Recording phase applying the 3977 -- Ada or SPARK elaboration rules in order to detect and diagnose ABE 3978 -- issues, install conditional ABE checks, and ensure the elaboration 3979 -- of units. 3980 3981 Iter := Iterate_Declaration_Scenarios; 3982 Check_Conditional_ABE_Scenarios (Iter); 3983 3984 Iter := Iterate_Library_Body_Scenarios; 3985 Check_Conditional_ABE_Scenarios (Iter); 3986 3987 Iter := Iterate_Library_Spec_Scenarios; 3988 Check_Conditional_ABE_Scenarios (Iter); 3989 3990 -- Examine each SPARK scenario saved during the Recording phase which 3991 -- is not necessarily executable during elaboration, but still requires 3992 -- elaboration-related checks. 3993 3994 Check_SPARK_Scenarios; 3995 3996 -- Add conditional ABE checks for all scenarios that require one when 3997 -- the dynamic model is in effect. 3998 3999 Install_Dynamic_ABE_Checks; 4000 4001 -- Examine all scenarios saved during the Recording phase along with 4002 -- invocation constructs within the spec and body of the main unit. 4003 -- Record the declarations and paths that reach into an external unit 4004 -- in the ALI file of the main unit. 4005 4006 Record_Invocation_Graph; 4007 4008 -- Destroy all internal data structures and complete the elaboration 4009 -- phase of the compiler. 4010 4011 Finalize_All_Data_Structures; 4012 Set_Elaboration_Phase (Completed); 4013 end Check_Elaboration_Scenarios; 4014 4015 --------------------- 4016 -- Check_Installer -- 4017 --------------------- 4018 4019 package body Check_Installer is 4020 4021 ----------------------- 4022 -- Local subprograms -- 4023 ----------------------- 4024 4025 function ABE_Check_Or_Failure_OK 4026 (N : Node_Id; 4027 Targ_Id : Entity_Id; 4028 Unit_Id : Entity_Id) return Boolean; 4029 pragma Inline (ABE_Check_Or_Failure_OK); 4030 -- Determine whether a conditional ABE check or guaranteed ABE failure 4031 -- can be installed for scenario N with target Targ_Id which resides in 4032 -- unit Unit_Id. 4033 4034 function Insertion_Node (N : Node_Id) return Node_Id; 4035 pragma Inline (Insertion_Node); 4036 -- Obtain the proper insertion node of an ABE check or failure for 4037 -- scenario N. 4038 4039 procedure Insert_ABE_Check_Or_Failure (N : Node_Id; Check : Node_Id); 4040 pragma Inline (Insert_ABE_Check_Or_Failure); 4041 -- Insert conditional ABE check or guaranteed ABE failure Check prior to 4042 -- scenario N. 4043 4044 procedure Install_Scenario_ABE_Check_Common 4045 (N : Node_Id; 4046 Targ_Id : Entity_Id; 4047 Targ_Rep : Target_Rep_Id); 4048 pragma Inline (Install_Scenario_ABE_Check_Common); 4049 -- Install a conditional ABE check for scenario N to ensure that target 4050 -- Targ_Id is properly elaborated. Targ_Rep is the representation of the 4051 -- target. 4052 4053 procedure Install_Scenario_ABE_Failure_Common (N : Node_Id); 4054 pragma Inline (Install_Scenario_ABE_Failure_Common); 4055 -- Install a guaranteed ABE failure for scenario N 4056 4057 procedure Install_Unit_ABE_Check_Common 4058 (N : Node_Id; 4059 Unit_Id : Entity_Id); 4060 pragma Inline (Install_Unit_ABE_Check_Common); 4061 -- Install a conditional ABE check for scenario N to ensure that unit 4062 -- Unit_Id is properly elaborated. 4063 4064 ----------------------------- 4065 -- ABE_Check_Or_Failure_OK -- 4066 ----------------------------- 4067 4068 function ABE_Check_Or_Failure_OK 4069 (N : Node_Id; 4070 Targ_Id : Entity_Id; 4071 Unit_Id : Entity_Id) return Boolean 4072 is 4073 pragma Unreferenced (Targ_Id); 4074 4075 Ins_Node : constant Node_Id := Insertion_Node (N); 4076 4077 begin 4078 if not Check_Or_Failure_Generation_OK then 4079 return False; 4080 4081 -- Nothing to do when the scenario denots a compilation unit because 4082 -- there is no executable environment at that level. 4083 4084 elsif Nkind (Parent (Ins_Node)) = N_Compilation_Unit then 4085 return False; 4086 4087 -- An ABE check or failure is not needed when the target is defined 4088 -- in a unit which is elaborated prior to the main unit. This check 4089 -- must also consider the following cases: 4090 -- 4091 -- * The unit of the target appears in the context of the main unit 4092 -- 4093 -- * The unit of the target is subject to pragma Elaborate_Body. An 4094 -- ABE check MUST NOT be generated because the unit is always 4095 -- elaborated prior to the main unit. 4096 -- 4097 -- * The unit of the target is the main unit. An ABE check MUST be 4098 -- added in this case because a conditional ABE may be raised 4099 -- depending on the flow of execution within the main unit (flag 4100 -- Same_Unit_OK is False). 4101 4102 elsif Has_Prior_Elaboration 4103 (Unit_Id => Unit_Id, 4104 Context_OK => True, 4105 Elab_Body_OK => True) 4106 then 4107 return False; 4108 end if; 4109 4110 return True; 4111 end ABE_Check_Or_Failure_OK; 4112 4113 ------------------------------------ 4114 -- Check_Or_Failure_Generation_OK -- 4115 ------------------------------------ 4116 4117 function Check_Or_Failure_Generation_OK return Boolean is 4118 begin 4119 -- An ABE check or failure is not needed when the compilation will 4120 -- not produce an executable. 4121 4122 if Serious_Errors_Detected > 0 then 4123 return False; 4124 4125 -- An ABE check or failure must not be installed when compiling for 4126 -- GNATprove because raise statements are not supported. 4127 4128 elsif GNATprove_Mode then 4129 return False; 4130 end if; 4131 4132 return True; 4133 end Check_Or_Failure_Generation_OK; 4134 4135 -------------------- 4136 -- Insertion_Node -- 4137 -------------------- 4138 4139 function Insertion_Node (N : Node_Id) return Node_Id is 4140 begin 4141 -- When the scenario denotes an instantiation, the proper insertion 4142 -- node is the instance spec. This ensures that the generic actuals 4143 -- will not be evaluated prior to a potential ABE. 4144 4145 if Nkind (N) in N_Generic_Instantiation 4146 and then Present (Instance_Spec (N)) 4147 then 4148 return Instance_Spec (N); 4149 4150 -- Otherwise the proper insertion node is the scenario itself 4151 4152 else 4153 return N; 4154 end if; 4155 end Insertion_Node; 4156 4157 --------------------------------- 4158 -- Insert_ABE_Check_Or_Failure -- 4159 --------------------------------- 4160 4161 procedure Insert_ABE_Check_Or_Failure (N : Node_Id; Check : Node_Id) is 4162 Ins_Nod : constant Node_Id := Insertion_Node (N); 4163 Scop_Id : constant Entity_Id := Find_Enclosing_Scope (Ins_Nod); 4164 4165 begin 4166 -- Install the nearest enclosing scope of the scenario as there must 4167 -- be something on the scope stack. 4168 4169 Push_Scope (Scop_Id); 4170 4171 Insert_Action (Ins_Nod, Check); 4172 4173 Pop_Scope; 4174 end Insert_ABE_Check_Or_Failure; 4175 4176 -------------------------------- 4177 -- Install_Dynamic_ABE_Checks -- 4178 -------------------------------- 4179 4180 procedure Install_Dynamic_ABE_Checks is 4181 Iter : NE_Set.Iterator; 4182 N : Node_Id; 4183 4184 begin 4185 if not Check_Or_Failure_Generation_OK then 4186 return; 4187 4188 -- Nothing to do if the dynamic model is not in effect 4189 4190 elsif not Dynamic_Elaboration_Checks then 4191 return; 4192 end if; 4193 4194 -- Install a conditional ABE check for each saved scenario 4195 4196 Iter := Iterate_Dynamic_ABE_Check_Scenarios; 4197 while NE_Set.Has_Next (Iter) loop 4198 NE_Set.Next (Iter, N); 4199 4200 Process_Conditional_ABE 4201 (N => N, 4202 In_State => Dynamic_Model_State); 4203 end loop; 4204 end Install_Dynamic_ABE_Checks; 4205 4206 -------------------------------- 4207 -- Install_Scenario_ABE_Check -- 4208 -------------------------------- 4209 4210 procedure Install_Scenario_ABE_Check 4211 (N : Node_Id; 4212 Targ_Id : Entity_Id; 4213 Targ_Rep : Target_Rep_Id; 4214 Disable : Scenario_Rep_Id) 4215 is 4216 begin 4217 -- Nothing to do when the scenario does not need an ABE check 4218 4219 if not ABE_Check_Or_Failure_OK 4220 (N => N, 4221 Targ_Id => Targ_Id, 4222 Unit_Id => Unit (Targ_Rep)) 4223 then 4224 return; 4225 end if; 4226 4227 -- Prevent multiple attempts to install the same ABE check 4228 4229 Disable_Elaboration_Checks (Disable); 4230 4231 Install_Scenario_ABE_Check_Common 4232 (N => N, 4233 Targ_Id => Targ_Id, 4234 Targ_Rep => Targ_Rep); 4235 end Install_Scenario_ABE_Check; 4236 4237 -------------------------------- 4238 -- Install_Scenario_ABE_Check -- 4239 -------------------------------- 4240 4241 procedure Install_Scenario_ABE_Check 4242 (N : Node_Id; 4243 Targ_Id : Entity_Id; 4244 Targ_Rep : Target_Rep_Id; 4245 Disable : Target_Rep_Id) 4246 is 4247 begin 4248 -- Nothing to do when the scenario does not need an ABE check 4249 4250 if not ABE_Check_Or_Failure_OK 4251 (N => N, 4252 Targ_Id => Targ_Id, 4253 Unit_Id => Unit (Targ_Rep)) 4254 then 4255 return; 4256 end if; 4257 4258 -- Prevent multiple attempts to install the same ABE check 4259 4260 Disable_Elaboration_Checks (Disable); 4261 4262 Install_Scenario_ABE_Check_Common 4263 (N => N, 4264 Targ_Id => Targ_Id, 4265 Targ_Rep => Targ_Rep); 4266 end Install_Scenario_ABE_Check; 4267 4268 --------------------------------------- 4269 -- Install_Scenario_ABE_Check_Common -- 4270 --------------------------------------- 4271 4272 procedure Install_Scenario_ABE_Check_Common 4273 (N : Node_Id; 4274 Targ_Id : Entity_Id; 4275 Targ_Rep : Target_Rep_Id) 4276 is 4277 Targ_Body : constant Node_Id := Body_Declaration (Targ_Rep); 4278 Targ_Decl : constant Node_Id := Spec_Declaration (Targ_Rep); 4279 4280 pragma Assert (Present (Targ_Body)); 4281 pragma Assert (Present (Targ_Decl)); 4282 4283 procedure Build_Elaboration_Entity; 4284 pragma Inline (Build_Elaboration_Entity); 4285 -- Create a new elaboration flag for Targ_Id, insert it prior to 4286 -- Targ_Decl, and set it after Targ_Body. 4287 4288 ------------------------------ 4289 -- Build_Elaboration_Entity -- 4290 ------------------------------ 4291 4292 procedure Build_Elaboration_Entity is 4293 Loc : constant Source_Ptr := Sloc (Targ_Id); 4294 Flag_Id : Entity_Id; 4295 4296 begin 4297 -- Nothing to do if the target has an elaboration flag 4298 4299 if Present (Elaboration_Entity (Targ_Id)) then 4300 return; 4301 end if; 4302 4303 -- Create the declaration of the elaboration flag. The name 4304 -- carries a unique counter in case the name is overloaded. 4305 4306 Flag_Id := 4307 Make_Defining_Identifier (Loc, 4308 Chars => New_External_Name (Chars (Targ_Id), 'E', -1)); 4309 4310 Set_Elaboration_Entity (Targ_Id, Flag_Id); 4311 Set_Elaboration_Entity_Required (Targ_Id); 4312 4313 Push_Scope (Scope (Targ_Id)); 4314 4315 -- Generate: 4316 -- Enn : Short_Integer := 0; 4317 4318 Insert_Action (Targ_Decl, 4319 Make_Object_Declaration (Loc, 4320 Defining_Identifier => Flag_Id, 4321 Object_Definition => 4322 New_Occurrence_Of (Standard_Short_Integer, Loc), 4323 Expression => Make_Integer_Literal (Loc, Uint_0))); 4324 4325 -- Generate: 4326 -- Enn := 1; 4327 4328 Set_Elaboration_Flag (Targ_Body, Targ_Id); 4329 4330 Pop_Scope; 4331 end Build_Elaboration_Entity; 4332 4333 -- Local variables 4334 4335 Loc : constant Source_Ptr := Sloc (N); 4336 4337 -- Start for processing for Install_Scenario_ABE_Check_Common 4338 4339 begin 4340 -- Create an elaboration flag for the target when it does not have 4341 -- one. 4342 4343 Build_Elaboration_Entity; 4344 4345 -- Generate: 4346 -- if not Targ_Id'Elaborated then 4347 -- raise Program_Error with "access before elaboration"; 4348 -- end if; 4349 4350 Insert_ABE_Check_Or_Failure 4351 (N => N, 4352 Check => 4353 Make_Raise_Program_Error (Loc, 4354 Condition => 4355 Make_Op_Not (Loc, 4356 Right_Opnd => 4357 Make_Attribute_Reference (Loc, 4358 Prefix => New_Occurrence_Of (Targ_Id, Loc), 4359 Attribute_Name => Name_Elaborated)), 4360 Reason => PE_Access_Before_Elaboration)); 4361 end Install_Scenario_ABE_Check_Common; 4362 4363 ---------------------------------- 4364 -- Install_Scenario_ABE_Failure -- 4365 ---------------------------------- 4366 4367 procedure Install_Scenario_ABE_Failure 4368 (N : Node_Id; 4369 Targ_Id : Entity_Id; 4370 Targ_Rep : Target_Rep_Id; 4371 Disable : Scenario_Rep_Id) 4372 is 4373 begin 4374 -- Nothing to do when the scenario does not require an ABE failure 4375 4376 if not ABE_Check_Or_Failure_OK 4377 (N => N, 4378 Targ_Id => Targ_Id, 4379 Unit_Id => Unit (Targ_Rep)) 4380 then 4381 return; 4382 end if; 4383 4384 -- Prevent multiple attempts to install the same ABE check 4385 4386 Disable_Elaboration_Checks (Disable); 4387 4388 Install_Scenario_ABE_Failure_Common (N); 4389 end Install_Scenario_ABE_Failure; 4390 4391 ---------------------------------- 4392 -- Install_Scenario_ABE_Failure -- 4393 ---------------------------------- 4394 4395 procedure Install_Scenario_ABE_Failure 4396 (N : Node_Id; 4397 Targ_Id : Entity_Id; 4398 Targ_Rep : Target_Rep_Id; 4399 Disable : Target_Rep_Id) 4400 is 4401 begin 4402 -- Nothing to do when the scenario does not require an ABE failure 4403 4404 if not ABE_Check_Or_Failure_OK 4405 (N => N, 4406 Targ_Id => Targ_Id, 4407 Unit_Id => Unit (Targ_Rep)) 4408 then 4409 return; 4410 end if; 4411 4412 -- Prevent multiple attempts to install the same ABE check 4413 4414 Disable_Elaboration_Checks (Disable); 4415 4416 Install_Scenario_ABE_Failure_Common (N); 4417 end Install_Scenario_ABE_Failure; 4418 4419 ----------------------------------------- 4420 -- Install_Scenario_ABE_Failure_Common -- 4421 ----------------------------------------- 4422 4423 procedure Install_Scenario_ABE_Failure_Common (N : Node_Id) is 4424 Loc : constant Source_Ptr := Sloc (N); 4425 4426 begin 4427 -- Generate: 4428 -- raise Program_Error with "access before elaboration"; 4429 4430 Insert_ABE_Check_Or_Failure 4431 (N => N, 4432 Check => 4433 Make_Raise_Program_Error (Loc, 4434 Reason => PE_Access_Before_Elaboration)); 4435 end Install_Scenario_ABE_Failure_Common; 4436 4437 ---------------------------- 4438 -- Install_Unit_ABE_Check -- 4439 ---------------------------- 4440 4441 procedure Install_Unit_ABE_Check 4442 (N : Node_Id; 4443 Unit_Id : Entity_Id; 4444 Disable : Scenario_Rep_Id) 4445 is 4446 Spec_Id : constant Entity_Id := Unique_Entity (Unit_Id); 4447 4448 begin 4449 -- Nothing to do when the scenario does not require an ABE check 4450 4451 if not ABE_Check_Or_Failure_OK 4452 (N => N, 4453 Targ_Id => Empty, 4454 Unit_Id => Spec_Id) 4455 then 4456 return; 4457 end if; 4458 4459 -- Prevent multiple attempts to install the same ABE check 4460 4461 Disable_Elaboration_Checks (Disable); 4462 4463 Install_Unit_ABE_Check_Common 4464 (N => N, 4465 Unit_Id => Unit_Id); 4466 end Install_Unit_ABE_Check; 4467 4468 ---------------------------- 4469 -- Install_Unit_ABE_Check -- 4470 ---------------------------- 4471 4472 procedure Install_Unit_ABE_Check 4473 (N : Node_Id; 4474 Unit_Id : Entity_Id; 4475 Disable : Target_Rep_Id) 4476 is 4477 Spec_Id : constant Entity_Id := Unique_Entity (Unit_Id); 4478 4479 begin 4480 -- Nothing to do when the scenario does not require an ABE check 4481 4482 if not ABE_Check_Or_Failure_OK 4483 (N => N, 4484 Targ_Id => Empty, 4485 Unit_Id => Spec_Id) 4486 then 4487 return; 4488 end if; 4489 4490 -- Prevent multiple attempts to install the same ABE check 4491 4492 Disable_Elaboration_Checks (Disable); 4493 4494 Install_Unit_ABE_Check_Common 4495 (N => N, 4496 Unit_Id => Unit_Id); 4497 end Install_Unit_ABE_Check; 4498 4499 ----------------------------------- 4500 -- Install_Unit_ABE_Check_Common -- 4501 ----------------------------------- 4502 4503 procedure Install_Unit_ABE_Check_Common 4504 (N : Node_Id; 4505 Unit_Id : Entity_Id) 4506 is 4507 Loc : constant Source_Ptr := Sloc (N); 4508 Spec_Id : constant Entity_Id := Unique_Entity (Unit_Id); 4509 4510 begin 4511 -- Generate: 4512 -- if not Spec_Id'Elaborated then 4513 -- raise Program_Error with "access before elaboration"; 4514 -- end if; 4515 4516 Insert_ABE_Check_Or_Failure 4517 (N => N, 4518 Check => 4519 Make_Raise_Program_Error (Loc, 4520 Condition => 4521 Make_Op_Not (Loc, 4522 Right_Opnd => 4523 Make_Attribute_Reference (Loc, 4524 Prefix => New_Occurrence_Of (Spec_Id, Loc), 4525 Attribute_Name => Name_Elaborated)), 4526 Reason => PE_Access_Before_Elaboration)); 4527 end Install_Unit_ABE_Check_Common; 4528 end Check_Installer; 4529 4530 ---------------------- 4531 -- Compilation_Unit -- 4532 ---------------------- 4533 4534 function Compilation_Unit (Unit_Id : Entity_Id) return Node_Id is 4535 Comp_Unit : Node_Id; 4536 4537 begin 4538 Comp_Unit := Parent (Unit_Id); 4539 4540 -- Handle the case where a concurrent subunit is rewritten as a null 4541 -- statement due to expansion activities. 4542 4543 if Nkind (Comp_Unit) = N_Null_Statement 4544 and then Nkind (Original_Node (Comp_Unit)) in 4545 N_Protected_Body | N_Task_Body 4546 then 4547 Comp_Unit := Parent (Comp_Unit); 4548 pragma Assert (Nkind (Comp_Unit) = N_Subunit); 4549 4550 -- Otherwise use the declaration node of the unit 4551 4552 else 4553 Comp_Unit := Parent (Unit_Declaration_Node (Unit_Id)); 4554 end if; 4555 4556 -- Handle the case where a subprogram instantiation which acts as a 4557 -- compilation unit is expanded into an anonymous package that wraps 4558 -- the instantiated subprogram. 4559 4560 if Nkind (Comp_Unit) = N_Package_Specification 4561 and then Nkind (Original_Node (Parent (Comp_Unit))) in 4562 N_Function_Instantiation | N_Procedure_Instantiation 4563 then 4564 Comp_Unit := Parent (Parent (Comp_Unit)); 4565 4566 -- Handle the case where the compilation unit is a subunit 4567 4568 elsif Nkind (Comp_Unit) = N_Subunit then 4569 Comp_Unit := Parent (Comp_Unit); 4570 end if; 4571 4572 pragma Assert (Nkind (Comp_Unit) = N_Compilation_Unit); 4573 4574 return Comp_Unit; 4575 end Compilation_Unit; 4576 4577 ------------------------------- 4578 -- Conditional_ABE_Processor -- 4579 ------------------------------- 4580 4581 package body Conditional_ABE_Processor is 4582 4583 ----------------------- 4584 -- Local subprograms -- 4585 ----------------------- 4586 4587 function Is_Conditional_ABE_Scenario (N : Node_Id) return Boolean; 4588 pragma Inline (Is_Conditional_ABE_Scenario); 4589 -- Determine whether node N is a suitable scenario for conditional ABE 4590 -- checks and diagnostics. 4591 4592 procedure Process_Conditional_ABE_Access_Taken 4593 (Attr : Node_Id; 4594 Attr_Rep : Scenario_Rep_Id; 4595 In_State : Processing_In_State); 4596 pragma Inline (Process_Conditional_ABE_Access_Taken); 4597 -- Perform ABE checks and diagnostics for attribute reference Attr with 4598 -- representation Attr_Rep which takes 'Access of an entry, operator, or 4599 -- subprogram. In_State is the current state of the Processing phase. 4600 4601 procedure Process_Conditional_ABE_Activation 4602 (Call : Node_Id; 4603 Call_Rep : Scenario_Rep_Id; 4604 Obj_Id : Entity_Id; 4605 Obj_Rep : Target_Rep_Id; 4606 Task_Typ : Entity_Id; 4607 Task_Rep : Target_Rep_Id; 4608 In_State : Processing_In_State); 4609 pragma Inline (Process_Conditional_ABE_Activation); 4610 -- Perform common conditional ABE checks and diagnostics for activation 4611 -- call Call which activates object Obj_Id of task type Task_Typ. Formal 4612 -- Call_Rep denotes the representation of the call. Obj_Rep denotes the 4613 -- representation of the object. Task_Rep denotes the representation of 4614 -- the task type. In_State is the current state of the Processing phase. 4615 4616 procedure Process_Conditional_ABE_Call 4617 (Call : Node_Id; 4618 Call_Rep : Scenario_Rep_Id; 4619 In_State : Processing_In_State); 4620 pragma Inline (Process_Conditional_ABE_Call); 4621 -- Top-level dispatcher for processing of calls. Perform ABE checks and 4622 -- diagnostics for call Call with representation Call_Rep. In_State is 4623 -- the current state of the Processing phase. 4624 4625 procedure Process_Conditional_ABE_Call_Ada 4626 (Call : Node_Id; 4627 Call_Rep : Scenario_Rep_Id; 4628 Subp_Id : Entity_Id; 4629 Subp_Rep : Target_Rep_Id; 4630 In_State : Processing_In_State); 4631 pragma Inline (Process_Conditional_ABE_Call_Ada); 4632 -- Perform ABE checks and diagnostics for call Call which invokes entry, 4633 -- operator, or subprogram Subp_Id using the Ada rules. Call_Rep denotes 4634 -- the representation of the call. Subp_Rep denotes the representation 4635 -- of the subprogram. In_State is the current state of the Processing 4636 -- phase. 4637 4638 procedure Process_Conditional_ABE_Call_SPARK 4639 (Call : Node_Id; 4640 Call_Rep : Scenario_Rep_Id; 4641 Subp_Id : Entity_Id; 4642 Subp_Rep : Target_Rep_Id; 4643 In_State : Processing_In_State); 4644 pragma Inline (Process_Conditional_ABE_Call_SPARK); 4645 -- Perform ABE checks and diagnostics for call Call which invokes entry, 4646 -- operator, or subprogram Subp_Id using the SPARK rules. Call_Rep is 4647 -- the representation of the call. Subp_Rep denotes the representation 4648 -- of the subprogram. In_State is the current state of the Processing 4649 -- phase. 4650 4651 procedure Process_Conditional_ABE_Instantiation 4652 (Inst : Node_Id; 4653 Inst_Rep : Scenario_Rep_Id; 4654 In_State : Processing_In_State); 4655 pragma Inline (Process_Conditional_ABE_Instantiation); 4656 -- Top-level dispatcher for processing of instantiations. Perform ABE 4657 -- checks and diagnostics for instantiation Inst with representation 4658 -- Inst_Rep. In_State is the current state of the Processing phase. 4659 4660 procedure Process_Conditional_ABE_Instantiation_Ada 4661 (Inst : Node_Id; 4662 Inst_Rep : Scenario_Rep_Id; 4663 Gen_Id : Entity_Id; 4664 Gen_Rep : Target_Rep_Id; 4665 In_State : Processing_In_State); 4666 pragma Inline (Process_Conditional_ABE_Instantiation_Ada); 4667 -- Perform ABE checks and diagnostics for instantiation Inst of generic 4668 -- Gen_Id using the Ada rules. Inst_Rep denotes the representation of 4669 -- the instnace. Gen_Rep is the representation of the generic. In_State 4670 -- is the current state of the Processing phase. 4671 4672 procedure Process_Conditional_ABE_Instantiation_SPARK 4673 (Inst : Node_Id; 4674 Inst_Rep : Scenario_Rep_Id; 4675 Gen_Id : Entity_Id; 4676 Gen_Rep : Target_Rep_Id; 4677 In_State : Processing_In_State); 4678 pragma Inline (Process_Conditional_ABE_Instantiation_SPARK); 4679 -- Perform ABE checks and diagnostics for instantiation Inst of generic 4680 -- Gen_Id using the SPARK rules. Inst_Rep denotes the representation of 4681 -- the instnace. Gen_Rep is the representation of the generic. In_State 4682 -- is the current state of the Processing phase. 4683 4684 procedure Process_Conditional_ABE_Variable_Assignment 4685 (Asmt : Node_Id; 4686 Asmt_Rep : Scenario_Rep_Id; 4687 In_State : Processing_In_State); 4688 pragma Inline (Process_Conditional_ABE_Variable_Assignment); 4689 -- Top-level dispatcher for processing of variable assignments. Perform 4690 -- ABE checks and diagnostics for assignment Asmt with representation 4691 -- Asmt_Rep. In_State denotes the current state of the Processing phase. 4692 4693 procedure Process_Conditional_ABE_Variable_Assignment_Ada 4694 (Asmt : Node_Id; 4695 Asmt_Rep : Scenario_Rep_Id; 4696 Var_Id : Entity_Id; 4697 Var_Rep : Target_Rep_Id; 4698 In_State : Processing_In_State); 4699 pragma Inline (Process_Conditional_ABE_Variable_Assignment_Ada); 4700 -- Perform ABE checks and diagnostics for assignment statement Asmt that 4701 -- modifies the value of variable Var_Id using the Ada rules. Asmt_Rep 4702 -- denotes the representation of the assignment. Var_Rep denotes the 4703 -- representation of the variable. In_State is the current state of the 4704 -- Processing phase. 4705 4706 procedure Process_Conditional_ABE_Variable_Assignment_SPARK 4707 (Asmt : Node_Id; 4708 Asmt_Rep : Scenario_Rep_Id; 4709 Var_Id : Entity_Id; 4710 Var_Rep : Target_Rep_Id; 4711 In_State : Processing_In_State); 4712 pragma Inline (Process_Conditional_ABE_Variable_Assignment_SPARK); 4713 -- Perform ABE checks and diagnostics for assignment statement Asmt that 4714 -- modifies the value of variable Var_Id using the SPARK rules. Asmt_Rep 4715 -- denotes the representation of the assignment. Var_Rep denotes the 4716 -- representation of the variable. In_State is the current state of the 4717 -- Processing phase. 4718 4719 procedure Process_Conditional_ABE_Variable_Reference 4720 (Ref : Node_Id; 4721 Ref_Rep : Scenario_Rep_Id; 4722 In_State : Processing_In_State); 4723 pragma Inline (Process_Conditional_ABE_Variable_Reference); 4724 -- Perform ABE checks and diagnostics for variable reference Ref with 4725 -- representation Ref_Rep. In_State denotes the current state of the 4726 -- Processing phase. 4727 4728 procedure Traverse_Conditional_ABE_Body 4729 (N : Node_Id; 4730 In_State : Processing_In_State); 4731 pragma Inline (Traverse_Conditional_ABE_Body); 4732 -- Traverse subprogram body N looking for suitable scenarios that need 4733 -- to be processed for conditional ABE checks and diagnostics. In_State 4734 -- is the current state of the Processing phase. 4735 4736 ------------------------------------- 4737 -- Check_Conditional_ABE_Scenarios -- 4738 ------------------------------------- 4739 4740 procedure Check_Conditional_ABE_Scenarios 4741 (Iter : in out NE_Set.Iterator) 4742 is 4743 N : Node_Id; 4744 4745 begin 4746 while NE_Set.Has_Next (Iter) loop 4747 NE_Set.Next (Iter, N); 4748 4749 -- Reset the traversed status of all subprogram bodies because the 4750 -- current conditional scenario acts as a new DFS traversal root. 4751 4752 Reset_Traversed_Bodies; 4753 4754 Process_Conditional_ABE 4755 (N => N, 4756 In_State => Conditional_ABE_State); 4757 end loop; 4758 end Check_Conditional_ABE_Scenarios; 4759 4760 --------------------------------- 4761 -- Is_Conditional_ABE_Scenario -- 4762 --------------------------------- 4763 4764 function Is_Conditional_ABE_Scenario (N : Node_Id) return Boolean is 4765 begin 4766 return 4767 Is_Suitable_Access_Taken (N) 4768 or else Is_Suitable_Call (N) 4769 or else Is_Suitable_Instantiation (N) 4770 or else Is_Suitable_Variable_Assignment (N) 4771 or else Is_Suitable_Variable_Reference (N); 4772 end Is_Conditional_ABE_Scenario; 4773 4774 ----------------------------- 4775 -- Process_Conditional_ABE -- 4776 ----------------------------- 4777 4778 procedure Process_Conditional_ABE 4779 (N : Node_Id; 4780 In_State : Processing_In_State) 4781 is 4782 Scen : constant Node_Id := Scenario (N); 4783 Scen_Rep : Scenario_Rep_Id; 4784 4785 begin 4786 -- Add the current scenario to the stack of active scenarios 4787 4788 Push_Active_Scenario (Scen); 4789 4790 -- 'Access 4791 4792 if Is_Suitable_Access_Taken (Scen) then 4793 Process_Conditional_ABE_Access_Taken 4794 (Attr => Scen, 4795 Attr_Rep => Scenario_Representation_Of (Scen, In_State), 4796 In_State => In_State); 4797 4798 -- Call or task activation 4799 4800 elsif Is_Suitable_Call (Scen) then 4801 Scen_Rep := Scenario_Representation_Of (Scen, In_State); 4802 4803 -- Routine Build_Call_Marker creates call markers regardless of 4804 -- whether the call occurs within the main unit or not. This way 4805 -- the serialization of internal names is kept consistent. Only 4806 -- call markers found within the main unit must be processed. 4807 4808 if In_Main_Context (Scen) then 4809 Scen_Rep := Scenario_Representation_Of (Scen, In_State); 4810 4811 if Kind (Scen_Rep) = Call_Scenario then 4812 Process_Conditional_ABE_Call 4813 (Call => Scen, 4814 Call_Rep => Scen_Rep, 4815 In_State => In_State); 4816 4817 else 4818 pragma Assert (Kind (Scen_Rep) = Task_Activation_Scenario); 4819 4820 Process_Activation 4821 (Call => Scen, 4822 Call_Rep => Scen_Rep, 4823 Processor => Process_Conditional_ABE_Activation'Access, 4824 In_State => In_State); 4825 end if; 4826 end if; 4827 4828 -- Instantiation 4829 4830 elsif Is_Suitable_Instantiation (Scen) then 4831 Process_Conditional_ABE_Instantiation 4832 (Inst => Scen, 4833 Inst_Rep => Scenario_Representation_Of (Scen, In_State), 4834 In_State => In_State); 4835 4836 -- Variable assignments 4837 4838 elsif Is_Suitable_Variable_Assignment (Scen) then 4839 Process_Conditional_ABE_Variable_Assignment 4840 (Asmt => Scen, 4841 Asmt_Rep => Scenario_Representation_Of (Scen, In_State), 4842 In_State => In_State); 4843 4844 -- Variable references 4845 4846 elsif Is_Suitable_Variable_Reference (Scen) then 4847 4848 -- Routine Build_Variable_Reference_Marker makes variable markers 4849 -- regardless of whether the reference occurs within the main unit 4850 -- or not. This way the serialization of internal names is kept 4851 -- consistent. Only variable markers within the main unit must be 4852 -- processed. 4853 4854 if In_Main_Context (Scen) then 4855 Process_Conditional_ABE_Variable_Reference 4856 (Ref => Scen, 4857 Ref_Rep => Scenario_Representation_Of (Scen, In_State), 4858 In_State => In_State); 4859 end if; 4860 end if; 4861 4862 -- Remove the current scenario from the stack of active scenarios 4863 -- once all ABE diagnostics and checks have been performed. 4864 4865 Pop_Active_Scenario (Scen); 4866 end Process_Conditional_ABE; 4867 4868 ------------------------------------------ 4869 -- Process_Conditional_ABE_Access_Taken -- 4870 ------------------------------------------ 4871 4872 procedure Process_Conditional_ABE_Access_Taken 4873 (Attr : Node_Id; 4874 Attr_Rep : Scenario_Rep_Id; 4875 In_State : Processing_In_State) 4876 is 4877 function Build_Access_Marker (Subp_Id : Entity_Id) return Node_Id; 4878 pragma Inline (Build_Access_Marker); 4879 -- Create a suitable call marker which invokes subprogram Subp_Id 4880 4881 ------------------------- 4882 -- Build_Access_Marker -- 4883 ------------------------- 4884 4885 function Build_Access_Marker (Subp_Id : Entity_Id) return Node_Id is 4886 Marker : Node_Id; 4887 4888 begin 4889 Marker := Make_Call_Marker (Sloc (Attr)); 4890 4891 -- Inherit relevant attributes from the attribute 4892 4893 Set_Target (Marker, Subp_Id); 4894 Set_Is_Declaration_Level_Node 4895 (Marker, Level (Attr_Rep) = Declaration_Level); 4896 Set_Is_Dispatching_Call 4897 (Marker, False); 4898 Set_Is_Elaboration_Checks_OK_Node 4899 (Marker, Elaboration_Checks_OK (Attr_Rep)); 4900 Set_Is_Elaboration_Warnings_OK_Node 4901 (Marker, Elaboration_Warnings_OK (Attr_Rep)); 4902 Set_Is_Preelaborable_Call 4903 (Marker, False); 4904 Set_Is_Source_Call 4905 (Marker, Comes_From_Source (Attr)); 4906 Set_Is_SPARK_Mode_On_Node 4907 (Marker, SPARK_Mode_Of (Attr_Rep) = Is_On); 4908 4909 -- Partially insert the call marker into the tree by setting its 4910 -- parent pointer. 4911 4912 Set_Parent (Marker, Attr); 4913 4914 return Marker; 4915 end Build_Access_Marker; 4916 4917 -- Local variables 4918 4919 Root : constant Node_Id := Root_Scenario; 4920 Subp_Id : constant Entity_Id := Target (Attr_Rep); 4921 Subp_Rep : constant Target_Rep_Id := 4922 Target_Representation_Of (Subp_Id, In_State); 4923 Body_Decl : constant Node_Id := Body_Declaration (Subp_Rep); 4924 4925 New_In_State : Processing_In_State := In_State; 4926 -- Each step of the Processing phase constitutes a new state 4927 4928 -- Start of processing for Process_Conditional_ABE_Access 4929 4930 begin 4931 -- Output relevant information when switch -gnatel (info messages on 4932 -- implicit Elaborate[_All] pragmas) is in effect. 4933 4934 if Elab_Info_Messages 4935 and then not New_In_State.Suppress_Info_Messages 4936 then 4937 Error_Msg_NE 4938 ("info: access to & during elaboration", Attr, Subp_Id); 4939 end if; 4940 4941 -- Warnings are suppressed when a prior scenario is already in that 4942 -- mode or when the attribute or the target have warnings suppressed. 4943 -- Update the state of the Processing phase to reflect this. 4944 4945 New_In_State.Suppress_Warnings := 4946 New_In_State.Suppress_Warnings 4947 or else not Elaboration_Warnings_OK (Attr_Rep) 4948 or else not Elaboration_Warnings_OK (Subp_Rep); 4949 4950 -- Do not emit any ABE diagnostics when the current or previous 4951 -- scenario in this traversal has suppressed elaboration warnings. 4952 4953 if New_In_State.Suppress_Warnings then 4954 null; 4955 4956 -- Both the attribute and the corresponding subprogram body are in 4957 -- the same unit. The body must appear prior to the root scenario 4958 -- which started the recursive search. If this is not the case, then 4959 -- there is a potential ABE if the access value is used to call the 4960 -- subprogram. Emit a warning only when switch -gnatw.f (warnings on 4961 -- suspucious 'Access) is in effect. 4962 4963 elsif Warn_On_Elab_Access 4964 and then Present (Body_Decl) 4965 and then In_Extended_Main_Code_Unit (Body_Decl) 4966 and then Earlier_In_Extended_Unit (Root, Body_Decl) 4967 then 4968 Error_Msg_Name_1 := Attribute_Name (Attr); 4969 Error_Msg_NE 4970 ("??% attribute of & before body seen", Attr, Subp_Id); 4971 Error_Msg_N ("\possible Program_Error on later references", Attr); 4972 4973 Output_Active_Scenarios (Attr, New_In_State); 4974 end if; 4975 4976 -- Treat the attribute an immediate invocation of the target when 4977 -- switch -gnatd.o (conservative elaboration order for indirect 4978 -- calls) is in effect. This has the following desirable effects: 4979 -- 4980 -- * Ensure that the unit with the corresponding body is elaborated 4981 -- prior to the main unit. 4982 -- 4983 -- * Perform conditional ABE checks and diagnostics 4984 -- 4985 -- * Traverse the body of the target (if available) 4986 4987 if Debug_Flag_Dot_O then 4988 Process_Conditional_ABE 4989 (N => Build_Access_Marker (Subp_Id), 4990 In_State => New_In_State); 4991 4992 -- Otherwise ensure that the unit with the corresponding body is 4993 -- elaborated prior to the main unit. 4994 4995 else 4996 Ensure_Prior_Elaboration 4997 (N => Attr, 4998 Unit_Id => Unit (Subp_Rep), 4999 Prag_Nam => Name_Elaborate_All, 5000 In_State => New_In_State); 5001 end if; 5002 end Process_Conditional_ABE_Access_Taken; 5003 5004 ---------------------------------------- 5005 -- Process_Conditional_ABE_Activation -- 5006 ---------------------------------------- 5007 5008 procedure Process_Conditional_ABE_Activation 5009 (Call : Node_Id; 5010 Call_Rep : Scenario_Rep_Id; 5011 Obj_Id : Entity_Id; 5012 Obj_Rep : Target_Rep_Id; 5013 Task_Typ : Entity_Id; 5014 Task_Rep : Target_Rep_Id; 5015 In_State : Processing_In_State) 5016 is 5017 pragma Unreferenced (Task_Typ); 5018 5019 Body_Decl : constant Node_Id := Body_Declaration (Task_Rep); 5020 Spec_Decl : constant Node_Id := Spec_Declaration (Task_Rep); 5021 Root : constant Node_Id := Root_Scenario; 5022 Unit_Id : constant Node_Id := Unit (Task_Rep); 5023 5024 Check_OK : constant Boolean := 5025 not In_State.Suppress_Checks 5026 and then Ghost_Mode_Of (Obj_Rep) /= Is_Ignored 5027 and then Ghost_Mode_Of (Task_Rep) /= Is_Ignored 5028 and then Elaboration_Checks_OK (Obj_Rep) 5029 and then Elaboration_Checks_OK (Task_Rep); 5030 -- A run-time ABE check may be installed only when the object and the 5031 -- task type have active elaboration checks, and both are not ignored 5032 -- Ghost constructs. 5033 5034 New_In_State : Processing_In_State := In_State; 5035 -- Each step of the Processing phase constitutes a new state 5036 5037 begin 5038 -- Output relevant information when switch -gnatel (info messages on 5039 -- implicit Elaborate[_All] pragmas) is in effect. 5040 5041 if Elab_Info_Messages 5042 and then not New_In_State.Suppress_Info_Messages 5043 then 5044 Error_Msg_NE 5045 ("info: activation of & during elaboration", Call, Obj_Id); 5046 end if; 5047 5048 -- Nothing to do when the call activates a task whose type is defined 5049 -- within an instance and switch -gnatd_i (ignore activations and 5050 -- calls to instances for elaboration) is in effect. 5051 5052 if Debug_Flag_Underscore_I 5053 and then In_External_Instance 5054 (N => Call, 5055 Target_Decl => Spec_Decl) 5056 then 5057 return; 5058 5059 -- Nothing to do when the activation is a guaranteed ABE 5060 5061 elsif Is_Known_Guaranteed_ABE (Call) then 5062 return; 5063 5064 -- Nothing to do when the root scenario appears at the declaration 5065 -- level and the task is in the same unit, but outside this context. 5066 -- 5067 -- task type Task_Typ; -- task declaration 5068 -- 5069 -- procedure Proc is 5070 -- function A ... is 5071 -- begin 5072 -- if Some_Condition then 5073 -- declare 5074 -- T : Task_Typ; 5075 -- begin 5076 -- <activation call> -- activation site 5077 -- end; 5078 -- ... 5079 -- end A; 5080 -- 5081 -- X : ... := A; -- root scenario 5082 -- ... 5083 -- 5084 -- task body Task_Typ is 5085 -- ... 5086 -- end Task_Typ; 5087 -- 5088 -- In the example above, the context of X is the declarative list of 5089 -- Proc. The "elaboration" of X may reach the activation of T whose 5090 -- body is defined outside of X's context. The task body is relevant 5091 -- only when Proc is invoked, but this happens only during "normal" 5092 -- elaboration, therefore the task body must not be considered if 5093 -- this is not the case. 5094 5095 elsif Is_Up_Level_Target 5096 (Targ_Decl => Spec_Decl, 5097 In_State => New_In_State) 5098 then 5099 return; 5100 5101 -- Nothing to do when the activation is ABE-safe 5102 -- 5103 -- generic 5104 -- package Gen is 5105 -- task type Task_Typ; 5106 -- end Gen; 5107 -- 5108 -- package body Gen is 5109 -- task body Task_Typ is 5110 -- begin 5111 -- ... 5112 -- end Task_Typ; 5113 -- end Gen; 5114 -- 5115 -- with Gen; 5116 -- procedure Main is 5117 -- package Nested is 5118 -- package Inst is new Gen; 5119 -- T : Inst.Task_Typ; 5120 -- <activation call> -- safe activation 5121 -- end Nested; 5122 -- ... 5123 5124 elsif Is_Safe_Activation (Call, Task_Rep) then 5125 5126 -- Note that the task body must still be examined for any nested 5127 -- scenarios. 5128 5129 null; 5130 5131 -- The activation call and the task body are both in the main unit 5132 -- 5133 -- If the root scenario appears prior to the task body, then this is 5134 -- a possible ABE with respect to the root scenario. 5135 -- 5136 -- task type Task_Typ; 5137 -- 5138 -- function A ... is 5139 -- begin 5140 -- if Some_Condition then 5141 -- declare 5142 -- package Pack is 5143 -- T : Task_Typ; 5144 -- end Pack; -- activation of T 5145 -- ... 5146 -- end A; 5147 -- 5148 -- X : ... := A; -- root scenario 5149 -- 5150 -- task body Task_Typ is -- task body 5151 -- ... 5152 -- end Task_Typ; 5153 -- 5154 -- Y : ... := A; -- root scenario 5155 -- 5156 -- IMPORTANT: The activation of T is a possible ABE for X, but 5157 -- not for Y. Intalling an unconditional ABE raise prior to the 5158 -- activation call would be wrong as it will fail for Y as well 5159 -- but in Y's case the activation of T is never an ABE. 5160 5161 elsif Present (Body_Decl) 5162 and then In_Extended_Main_Code_Unit (Body_Decl) 5163 then 5164 if Earlier_In_Extended_Unit (Root, Body_Decl) then 5165 5166 -- Do not emit any ABE diagnostics when a previous scenario in 5167 -- this traversal has suppressed elaboration warnings. 5168 5169 if New_In_State.Suppress_Warnings then 5170 null; 5171 5172 -- Do not emit any ABE diagnostics when the activation occurs 5173 -- in a partial finalization context because this action leads 5174 -- to confusing noise. 5175 5176 elsif New_In_State.Within_Partial_Finalization then 5177 null; 5178 5179 -- Otherwise emit the ABE disgnostic 5180 5181 else 5182 Error_Msg_Sloc := Sloc (Call); 5183 Error_Msg_N 5184 ("??task & will be activated # before elaboration of its " 5185 & "body", Obj_Id); 5186 Error_Msg_N 5187 ("\Program_Error may be raised at run time", Obj_Id); 5188 5189 Output_Active_Scenarios (Obj_Id, New_In_State); 5190 end if; 5191 5192 -- Install a conditional run-time ABE check to verify that the 5193 -- task body has been elaborated prior to the activation call. 5194 5195 if Check_OK then 5196 Install_Scenario_ABE_Check 5197 (N => Call, 5198 Targ_Id => Defining_Entity (Spec_Decl), 5199 Targ_Rep => Task_Rep, 5200 Disable => Obj_Rep); 5201 5202 -- Update the state of the Processing phase to indicate that 5203 -- no implicit Elaborate[_All] pragma must be generated from 5204 -- this point on. 5205 -- 5206 -- task type Task_Typ; 5207 -- 5208 -- function A ... is 5209 -- begin 5210 -- if Some_Condition then 5211 -- declare 5212 -- package Pack is 5213 -- <ABE check> 5214 -- T : Task_Typ; 5215 -- end Pack; -- activation of T 5216 -- ... 5217 -- end A; 5218 -- 5219 -- X : ... := A; 5220 -- 5221 -- task body Task_Typ is 5222 -- begin 5223 -- External.Subp; -- imparts Elaborate_All 5224 -- end Task_Typ; 5225 -- 5226 -- If Some_Condition is True, then the ABE check will fail 5227 -- at runtime and the call to External.Subp will never take 5228 -- place, rendering the implicit Elaborate_All useless. 5229 -- 5230 -- If the value of Some_Condition is False, then the call 5231 -- to External.Subp will never take place, rendering the 5232 -- implicit Elaborate_All useless. 5233 5234 New_In_State.Suppress_Implicit_Pragmas := True; 5235 end if; 5236 end if; 5237 5238 -- Otherwise the task body is not available in this compilation or 5239 -- it resides in an external unit. Install a run-time ABE check to 5240 -- verify that the task body has been elaborated prior to the 5241 -- activation call when the dynamic model is in effect. 5242 5243 elsif Check_OK 5244 and then New_In_State.Processing = Dynamic_Model_Processing 5245 then 5246 Install_Unit_ABE_Check 5247 (N => Call, 5248 Unit_Id => Unit_Id, 5249 Disable => Obj_Rep); 5250 end if; 5251 5252 -- Both the activation call and task type are subject to SPARK_Mode 5253 -- On, this triggers the SPARK rules for task activation. Compared 5254 -- to calls and instantiations, task activation in SPARK does not 5255 -- require the presence of Elaborate[_All] pragmas in case the task 5256 -- type is defined outside the main unit. This is because SPARK uses 5257 -- a special policy which activates all tasks after the main unit has 5258 -- finished its elaboration. 5259 5260 if SPARK_Mode_Of (Call_Rep) = Is_On 5261 and then SPARK_Mode_Of (Task_Rep) = Is_On 5262 then 5263 null; 5264 5265 -- Otherwise the Ada rules are in effect. Ensure that the unit with 5266 -- the task body is elaborated prior to the main unit. 5267 5268 else 5269 Ensure_Prior_Elaboration 5270 (N => Call, 5271 Unit_Id => Unit_Id, 5272 Prag_Nam => Name_Elaborate_All, 5273 In_State => New_In_State); 5274 end if; 5275 5276 Traverse_Conditional_ABE_Body 5277 (N => Body_Decl, 5278 In_State => New_In_State); 5279 end Process_Conditional_ABE_Activation; 5280 5281 ---------------------------------- 5282 -- Process_Conditional_ABE_Call -- 5283 ---------------------------------- 5284 5285 procedure Process_Conditional_ABE_Call 5286 (Call : Node_Id; 5287 Call_Rep : Scenario_Rep_Id; 5288 In_State : Processing_In_State) 5289 is 5290 function In_Initialization_Context (N : Node_Id) return Boolean; 5291 pragma Inline (In_Initialization_Context); 5292 -- Determine whether arbitrary node N appears within a type init 5293 -- proc, primitive [Deep_]Initialize, or a block created for 5294 -- initialization purposes. 5295 5296 function Is_Partial_Finalization_Proc 5297 (Subp_Id : Entity_Id) return Boolean; 5298 pragma Inline (Is_Partial_Finalization_Proc); 5299 -- Determine whether subprogram Subp_Id is a partial finalization 5300 -- procedure. 5301 5302 ------------------------------- 5303 -- In_Initialization_Context -- 5304 ------------------------------- 5305 5306 function In_Initialization_Context (N : Node_Id) return Boolean is 5307 Par : Node_Id; 5308 Spec_Id : Entity_Id; 5309 5310 begin 5311 -- Climb the parent chain looking for initialization actions 5312 5313 Par := Parent (N); 5314 while Present (Par) loop 5315 5316 -- A block may be part of the initialization actions of a 5317 -- default initialized object. 5318 5319 if Nkind (Par) = N_Block_Statement 5320 and then Is_Initialization_Block (Par) 5321 then 5322 return True; 5323 5324 -- A subprogram body may denote an initialization routine 5325 5326 elsif Nkind (Par) = N_Subprogram_Body then 5327 Spec_Id := Unique_Defining_Entity (Par); 5328 5329 -- The current subprogram body denotes a type init proc or 5330 -- primitive [Deep_]Initialize. 5331 5332 if Is_Init_Proc (Spec_Id) 5333 or else Is_Controlled_Proc (Spec_Id, Name_Initialize) 5334 or else Is_TSS (Spec_Id, TSS_Deep_Initialize) 5335 then 5336 return True; 5337 end if; 5338 5339 -- Prevent the search from going too far 5340 5341 elsif Is_Body_Or_Package_Declaration (Par) then 5342 exit; 5343 end if; 5344 5345 Par := Parent (Par); 5346 end loop; 5347 5348 return False; 5349 end In_Initialization_Context; 5350 5351 ---------------------------------- 5352 -- Is_Partial_Finalization_Proc -- 5353 ---------------------------------- 5354 5355 function Is_Partial_Finalization_Proc 5356 (Subp_Id : Entity_Id) return Boolean 5357 is 5358 begin 5359 -- To qualify, the subprogram must denote a finalizer procedure 5360 -- or primitive [Deep_]Finalize, and the call must appear within 5361 -- an initialization context. 5362 5363 return 5364 (Is_Controlled_Proc (Subp_Id, Name_Finalize) 5365 or else Is_Finalizer_Proc (Subp_Id) 5366 or else Is_TSS (Subp_Id, TSS_Deep_Finalize)) 5367 and then In_Initialization_Context (Call); 5368 end Is_Partial_Finalization_Proc; 5369 5370 -- Local variables 5371 5372 Subp_Id : constant Entity_Id := Target (Call_Rep); 5373 Subp_Rep : constant Target_Rep_Id := 5374 Target_Representation_Of (Subp_Id, In_State); 5375 Subp_Decl : constant Node_Id := Spec_Declaration (Subp_Rep); 5376 5377 SPARK_Rules_On : constant Boolean := 5378 SPARK_Mode_Of (Call_Rep) = Is_On 5379 and then SPARK_Mode_Of (Subp_Rep) = Is_On; 5380 5381 New_In_State : Processing_In_State := In_State; 5382 -- Each step of the Processing phase constitutes a new state 5383 5384 -- Start of processing for Process_Conditional_ABE_Call 5385 5386 begin 5387 -- Output relevant information when switch -gnatel (info messages on 5388 -- implicit Elaborate[_All] pragmas) is in effect. 5389 5390 if Elab_Info_Messages 5391 and then not New_In_State.Suppress_Info_Messages 5392 then 5393 Info_Call 5394 (Call => Call, 5395 Subp_Id => Subp_Id, 5396 Info_Msg => True, 5397 In_SPARK => SPARK_Rules_On); 5398 end if; 5399 5400 -- Check whether the invocation of an entry clashes with an existing 5401 -- restriction. This check is relevant only when the processing was 5402 -- started from some library-level scenario. 5403 5404 if Is_Protected_Entry (Subp_Id) then 5405 Check_Restriction (No_Entry_Calls_In_Elaboration_Code, Call); 5406 5407 elsif Is_Task_Entry (Subp_Id) then 5408 Check_Restriction (No_Entry_Calls_In_Elaboration_Code, Call); 5409 5410 -- Task entry calls are never processed because the entry being 5411 -- invoked does not have a corresponding "body", it has a select. 5412 5413 return; 5414 end if; 5415 5416 -- Nothing to do when the call invokes a target defined within an 5417 -- instance and switch -gnatd_i (ignore activations and calls to 5418 -- instances for elaboration) is in effect. 5419 5420 if Debug_Flag_Underscore_I 5421 and then In_External_Instance 5422 (N => Call, 5423 Target_Decl => Subp_Decl) 5424 then 5425 return; 5426 5427 -- Nothing to do when the call is a guaranteed ABE 5428 5429 elsif Is_Known_Guaranteed_ABE (Call) then 5430 return; 5431 5432 -- Nothing to do when the root scenario appears at the declaration 5433 -- level and the target is in the same unit but outside this context. 5434 -- 5435 -- function B ...; -- target declaration 5436 -- 5437 -- procedure Proc is 5438 -- function A ... is 5439 -- begin 5440 -- if Some_Condition then 5441 -- return B; -- call site 5442 -- ... 5443 -- end A; 5444 -- 5445 -- X : ... := A; -- root scenario 5446 -- ... 5447 -- 5448 -- function B ... is 5449 -- ... 5450 -- end B; 5451 -- 5452 -- In the example above, the context of X is the declarative region 5453 -- of Proc. The "elaboration" of X may eventually reach B which is 5454 -- defined outside of X's context. B is relevant only when Proc is 5455 -- invoked, but this happens only by means of "normal" elaboration, 5456 -- therefore B must not be considered if this is not the case. 5457 5458 elsif Is_Up_Level_Target 5459 (Targ_Decl => Subp_Decl, 5460 In_State => New_In_State) 5461 then 5462 return; 5463 end if; 5464 5465 -- Warnings are suppressed when a prior scenario is already in that 5466 -- mode, or the call or target have warnings suppressed. Update the 5467 -- state of the Processing phase to reflect this. 5468 5469 New_In_State.Suppress_Warnings := 5470 New_In_State.Suppress_Warnings 5471 or else not Elaboration_Warnings_OK (Call_Rep) 5472 or else not Elaboration_Warnings_OK (Subp_Rep); 5473 5474 -- The call occurs in an initial condition context when a prior 5475 -- scenario is already in that mode, or when the target is an 5476 -- Initial_Condition procedure. Update the state of the Processing 5477 -- phase to reflect this. 5478 5479 New_In_State.Within_Initial_Condition := 5480 New_In_State.Within_Initial_Condition 5481 or else Is_Initial_Condition_Proc (Subp_Id); 5482 5483 -- The call occurs in a partial finalization context when a prior 5484 -- scenario is already in that mode, or when the target denotes a 5485 -- [Deep_]Finalize primitive or a finalizer within an initialization 5486 -- context. Update the state of the Processing phase to reflect this. 5487 5488 New_In_State.Within_Partial_Finalization := 5489 New_In_State.Within_Partial_Finalization 5490 or else Is_Partial_Finalization_Proc (Subp_Id); 5491 5492 -- The SPARK rules are in effect. Note that -gnatd.v (enforce SPARK 5493 -- elaboration rules in SPARK code) is intentionally not taken into 5494 -- account here because Process_Conditional_ABE_Call_SPARK has two 5495 -- separate modes of operation. 5496 5497 if SPARK_Rules_On then 5498 Process_Conditional_ABE_Call_SPARK 5499 (Call => Call, 5500 Call_Rep => Call_Rep, 5501 Subp_Id => Subp_Id, 5502 Subp_Rep => Subp_Rep, 5503 In_State => New_In_State); 5504 5505 -- Otherwise the Ada rules are in effect 5506 5507 else 5508 Process_Conditional_ABE_Call_Ada 5509 (Call => Call, 5510 Call_Rep => Call_Rep, 5511 Subp_Id => Subp_Id, 5512 Subp_Rep => Subp_Rep, 5513 In_State => New_In_State); 5514 end if; 5515 5516 -- Inspect the target body (and barried function) for other suitable 5517 -- elaboration scenarios. 5518 5519 Traverse_Conditional_ABE_Body 5520 (N => Barrier_Body_Declaration (Subp_Rep), 5521 In_State => New_In_State); 5522 5523 Traverse_Conditional_ABE_Body 5524 (N => Body_Declaration (Subp_Rep), 5525 In_State => New_In_State); 5526 end Process_Conditional_ABE_Call; 5527 5528 -------------------------------------- 5529 -- Process_Conditional_ABE_Call_Ada -- 5530 -------------------------------------- 5531 5532 procedure Process_Conditional_ABE_Call_Ada 5533 (Call : Node_Id; 5534 Call_Rep : Scenario_Rep_Id; 5535 Subp_Id : Entity_Id; 5536 Subp_Rep : Target_Rep_Id; 5537 In_State : Processing_In_State) 5538 is 5539 Body_Decl : constant Node_Id := Body_Declaration (Subp_Rep); 5540 Root : constant Node_Id := Root_Scenario; 5541 Unit_Id : constant Node_Id := Unit (Subp_Rep); 5542 5543 Check_OK : constant Boolean := 5544 not In_State.Suppress_Checks 5545 and then Ghost_Mode_Of (Call_Rep) /= Is_Ignored 5546 and then Ghost_Mode_Of (Subp_Rep) /= Is_Ignored 5547 and then Elaboration_Checks_OK (Call_Rep) 5548 and then Elaboration_Checks_OK (Subp_Rep); 5549 -- A run-time ABE check may be installed only when both the call 5550 -- and the target have active elaboration checks, and both are not 5551 -- ignored Ghost constructs. 5552 5553 New_In_State : Processing_In_State := In_State; 5554 -- Each step of the Processing phase constitutes a new state 5555 5556 begin 5557 -- Nothing to do for an Ada dispatching call because there are no 5558 -- ABE diagnostics for either models. ABE checks for the dynamic 5559 -- model are handled by Install_Primitive_Elaboration_Check. 5560 5561 if Is_Dispatching_Call (Call_Rep) then 5562 return; 5563 5564 -- Nothing to do when the call is ABE-safe 5565 -- 5566 -- generic 5567 -- function Gen ...; 5568 -- 5569 -- function Gen ... is 5570 -- begin 5571 -- ... 5572 -- end Gen; 5573 -- 5574 -- with Gen; 5575 -- procedure Main is 5576 -- function Inst is new Gen; 5577 -- X : ... := Inst; -- safe call 5578 -- ... 5579 5580 elsif Is_Safe_Call (Call, Subp_Id, Subp_Rep) then 5581 return; 5582 5583 -- The call and the target body are both in the main unit 5584 -- 5585 -- If the root scenario appears prior to the target body, then this 5586 -- is a possible ABE with respect to the root scenario. 5587 -- 5588 -- function B ...; 5589 -- 5590 -- function A ... is 5591 -- begin 5592 -- if Some_Condition then 5593 -- return B; -- call site 5594 -- ... 5595 -- end A; 5596 -- 5597 -- X : ... := A; -- root scenario 5598 -- 5599 -- function B ... is -- target body 5600 -- ... 5601 -- end B; 5602 -- 5603 -- Y : ... := A; -- root scenario 5604 -- 5605 -- IMPORTANT: The call to B from A is a possible ABE for X, but 5606 -- not for Y. Installing an unconditional ABE raise prior to the 5607 -- call to B would be wrong as it will fail for Y as well, but in 5608 -- Y's case the call to B is never an ABE. 5609 5610 elsif Present (Body_Decl) 5611 and then In_Extended_Main_Code_Unit (Body_Decl) 5612 then 5613 if Earlier_In_Extended_Unit (Root, Body_Decl) then 5614 5615 -- Do not emit any ABE diagnostics when a previous scenario in 5616 -- this traversal has suppressed elaboration warnings. 5617 5618 if New_In_State.Suppress_Warnings then 5619 null; 5620 5621 -- Do not emit any ABE diagnostics when the call occurs in a 5622 -- partial finalization context because this leads to confusing 5623 -- noise. 5624 5625 elsif New_In_State.Within_Partial_Finalization then 5626 null; 5627 5628 -- Otherwise emit the ABE diagnostic 5629 5630 else 5631 Error_Msg_NE 5632 ("??cannot call & before body seen", Call, Subp_Id); 5633 Error_Msg_N 5634 ("\Program_Error may be raised at run time", Call); 5635 5636 Output_Active_Scenarios (Call, New_In_State); 5637 end if; 5638 5639 -- Install a conditional run-time ABE check to verify that the 5640 -- target body has been elaborated prior to the call. 5641 5642 if Check_OK then 5643 Install_Scenario_ABE_Check 5644 (N => Call, 5645 Targ_Id => Subp_Id, 5646 Targ_Rep => Subp_Rep, 5647 Disable => Call_Rep); 5648 5649 -- Update the state of the Processing phase to indicate that 5650 -- no implicit Elaborate[_All] pragma must be generated from 5651 -- this point on. 5652 -- 5653 -- function B ...; 5654 -- 5655 -- function A ... is 5656 -- begin 5657 -- if Some_Condition then 5658 -- <ABE check> 5659 -- return B; 5660 -- ... 5661 -- end A; 5662 -- 5663 -- X : ... := A; 5664 -- 5665 -- function B ... is 5666 -- External.Subp; -- imparts Elaborate_All 5667 -- end B; 5668 -- 5669 -- If Some_Condition is True, then the ABE check will fail 5670 -- at runtime and the call to External.Subp will never take 5671 -- place, rendering the implicit Elaborate_All useless. 5672 -- 5673 -- If the value of Some_Condition is False, then the call 5674 -- to External.Subp will never take place, rendering the 5675 -- implicit Elaborate_All useless. 5676 5677 New_In_State.Suppress_Implicit_Pragmas := True; 5678 end if; 5679 end if; 5680 5681 -- Otherwise the target body is not available in this compilation or 5682 -- it resides in an external unit. Install a run-time ABE check to 5683 -- verify that the target body has been elaborated prior to the call 5684 -- site when the dynamic model is in effect. 5685 5686 elsif Check_OK 5687 and then New_In_State.Processing = Dynamic_Model_Processing 5688 then 5689 Install_Unit_ABE_Check 5690 (N => Call, 5691 Unit_Id => Unit_Id, 5692 Disable => Call_Rep); 5693 end if; 5694 5695 -- Ensure that the unit with the target body is elaborated prior to 5696 -- the main unit. The implicit Elaborate[_All] is generated only when 5697 -- the call has elaboration checks enabled. This behavior parallels 5698 -- that of the old ABE mechanism. 5699 5700 if Elaboration_Checks_OK (Call_Rep) then 5701 Ensure_Prior_Elaboration 5702 (N => Call, 5703 Unit_Id => Unit_Id, 5704 Prag_Nam => Name_Elaborate_All, 5705 In_State => New_In_State); 5706 end if; 5707 end Process_Conditional_ABE_Call_Ada; 5708 5709 ---------------------------------------- 5710 -- Process_Conditional_ABE_Call_SPARK -- 5711 ---------------------------------------- 5712 5713 procedure Process_Conditional_ABE_Call_SPARK 5714 (Call : Node_Id; 5715 Call_Rep : Scenario_Rep_Id; 5716 Subp_Id : Entity_Id; 5717 Subp_Rep : Target_Rep_Id; 5718 In_State : Processing_In_State) 5719 is 5720 pragma Unreferenced (Call_Rep); 5721 5722 Body_Decl : constant Node_Id := Body_Declaration (Subp_Rep); 5723 Region : Node_Id; 5724 5725 begin 5726 -- Ensure that a suitable elaboration model is in effect for SPARK 5727 -- rule verification. 5728 5729 Check_SPARK_Model_In_Effect; 5730 5731 -- The call and the target body are both in the main unit 5732 5733 if Present (Body_Decl) 5734 and then In_Extended_Main_Code_Unit (Body_Decl) 5735 and then Earlier_In_Extended_Unit (Call, Body_Decl) 5736 then 5737 -- Do not emit any ABE diagnostics when a previous scenario in 5738 -- this traversal has suppressed elaboration warnings. 5739 5740 if In_State.Suppress_Warnings then 5741 null; 5742 5743 -- Do not emit any ABE diagnostics when the call occurs in an 5744 -- initial condition context because this leads to incorrect 5745 -- diagnostics. 5746 5747 elsif In_State.Within_Initial_Condition then 5748 null; 5749 5750 -- Do not emit any ABE diagnostics when the call occurs in a 5751 -- partial finalization context because this leads to confusing 5752 -- noise. 5753 5754 elsif In_State.Within_Partial_Finalization then 5755 null; 5756 5757 -- Ensure that a call that textually precedes the subprogram body 5758 -- it invokes appears within the early call region of the body. 5759 -- 5760 -- IMPORTANT: This check must always be performed even when switch 5761 -- -gnatd.v (enforce SPARK elaboration rules in SPARK code) is not 5762 -- specified because the static model cannot guarantee the absence 5763 -- of elaboration issues when dispatching calls are involved. 5764 5765 else 5766 Region := Find_Early_Call_Region (Body_Decl); 5767 5768 if Earlier_In_Extended_Unit (Call, Region) then 5769 Error_Msg_NE 5770 ("call must appear within early call region of subprogram " 5771 & "body & (SPARK RM 7.7(3))", 5772 Call, Subp_Id); 5773 5774 Error_Msg_Sloc := Sloc (Region); 5775 Error_Msg_N ("\region starts #", Call); 5776 5777 Error_Msg_Sloc := Sloc (Body_Decl); 5778 Error_Msg_N ("\region ends #", Call); 5779 5780 Output_Active_Scenarios (Call, In_State); 5781 end if; 5782 end if; 5783 end if; 5784 5785 -- A call to a source target or to a target which emulates Ada 5786 -- or SPARK semantics imposes an Elaborate_All requirement on the 5787 -- context of the main unit. Determine whether the context has a 5788 -- pragma strong enough to meet the requirement. 5789 -- 5790 -- IMPORTANT: This check must be performed only when switch -gnatd.v 5791 -- (enforce SPARK elaboration rules in SPARK code) is active because 5792 -- the static model can ensure the prior elaboration of the unit 5793 -- which contains a body by installing an implicit Elaborate[_All] 5794 -- pragma. 5795 5796 if Debug_Flag_Dot_V then 5797 if Comes_From_Source (Subp_Id) 5798 or else Is_Ada_Semantic_Target (Subp_Id) 5799 or else Is_SPARK_Semantic_Target (Subp_Id) 5800 then 5801 Meet_Elaboration_Requirement 5802 (N => Call, 5803 Targ_Id => Subp_Id, 5804 Req_Nam => Name_Elaborate_All, 5805 In_State => In_State); 5806 end if; 5807 5808 -- Otherwise ensure that the unit with the target body is elaborated 5809 -- prior to the main unit. 5810 5811 else 5812 Ensure_Prior_Elaboration 5813 (N => Call, 5814 Unit_Id => Unit (Subp_Rep), 5815 Prag_Nam => Name_Elaborate_All, 5816 In_State => In_State); 5817 end if; 5818 end Process_Conditional_ABE_Call_SPARK; 5819 5820 ------------------------------------------- 5821 -- Process_Conditional_ABE_Instantiation -- 5822 ------------------------------------------- 5823 5824 procedure Process_Conditional_ABE_Instantiation 5825 (Inst : Node_Id; 5826 Inst_Rep : Scenario_Rep_Id; 5827 In_State : Processing_In_State) 5828 is 5829 Gen_Id : constant Entity_Id := Target (Inst_Rep); 5830 Gen_Rep : constant Target_Rep_Id := 5831 Target_Representation_Of (Gen_Id, In_State); 5832 5833 SPARK_Rules_On : constant Boolean := 5834 SPARK_Mode_Of (Inst_Rep) = Is_On 5835 and then SPARK_Mode_Of (Gen_Rep) = Is_On; 5836 5837 New_In_State : Processing_In_State := In_State; 5838 -- Each step of the Processing phase constitutes a new state 5839 5840 begin 5841 -- Output relevant information when switch -gnatel (info messages on 5842 -- implicit Elaborate[_All] pragmas) is in effect. 5843 5844 if Elab_Info_Messages 5845 and then not New_In_State.Suppress_Info_Messages 5846 then 5847 Info_Instantiation 5848 (Inst => Inst, 5849 Gen_Id => Gen_Id, 5850 Info_Msg => True, 5851 In_SPARK => SPARK_Rules_On); 5852 end if; 5853 5854 -- Nothing to do when the instantiation is a guaranteed ABE 5855 5856 if Is_Known_Guaranteed_ABE (Inst) then 5857 return; 5858 5859 -- Nothing to do when the root scenario appears at the declaration 5860 -- level and the generic is in the same unit, but outside this 5861 -- context. 5862 -- 5863 -- generic 5864 -- procedure Gen is ...; -- generic declaration 5865 -- 5866 -- procedure Proc is 5867 -- function A ... is 5868 -- begin 5869 -- if Some_Condition then 5870 -- declare 5871 -- procedure I is new Gen; -- instantiation site 5872 -- ... 5873 -- ... 5874 -- end A; 5875 -- 5876 -- X : ... := A; -- root scenario 5877 -- ... 5878 -- 5879 -- procedure Gen is 5880 -- ... 5881 -- end Gen; 5882 -- 5883 -- In the example above, the context of X is the declarative region 5884 -- of Proc. The "elaboration" of X may eventually reach Gen which 5885 -- appears outside of X's context. Gen is relevant only when Proc is 5886 -- invoked, but this happens only by means of "normal" elaboration, 5887 -- therefore Gen must not be considered if this is not the case. 5888 5889 elsif Is_Up_Level_Target 5890 (Targ_Decl => Spec_Declaration (Gen_Rep), 5891 In_State => New_In_State) 5892 then 5893 return; 5894 end if; 5895 5896 -- Warnings are suppressed when a prior scenario is already in that 5897 -- mode, or when the instantiation has warnings suppressed. Update 5898 -- the state of the processing phase to reflect this. 5899 5900 New_In_State.Suppress_Warnings := 5901 New_In_State.Suppress_Warnings 5902 or else not Elaboration_Warnings_OK (Inst_Rep); 5903 5904 -- The SPARK rules are in effect 5905 5906 if SPARK_Rules_On then 5907 Process_Conditional_ABE_Instantiation_SPARK 5908 (Inst => Inst, 5909 Inst_Rep => Inst_Rep, 5910 Gen_Id => Gen_Id, 5911 Gen_Rep => Gen_Rep, 5912 In_State => New_In_State); 5913 5914 -- Otherwise the Ada rules are in effect, or SPARK code is allowed to 5915 -- violate the SPARK rules. 5916 5917 else 5918 Process_Conditional_ABE_Instantiation_Ada 5919 (Inst => Inst, 5920 Inst_Rep => Inst_Rep, 5921 Gen_Id => Gen_Id, 5922 Gen_Rep => Gen_Rep, 5923 In_State => New_In_State); 5924 end if; 5925 end Process_Conditional_ABE_Instantiation; 5926 5927 ----------------------------------------------- 5928 -- Process_Conditional_ABE_Instantiation_Ada -- 5929 ----------------------------------------------- 5930 5931 procedure Process_Conditional_ABE_Instantiation_Ada 5932 (Inst : Node_Id; 5933 Inst_Rep : Scenario_Rep_Id; 5934 Gen_Id : Entity_Id; 5935 Gen_Rep : Target_Rep_Id; 5936 In_State : Processing_In_State) 5937 is 5938 Body_Decl : constant Node_Id := Body_Declaration (Gen_Rep); 5939 Root : constant Node_Id := Root_Scenario; 5940 Unit_Id : constant Entity_Id := Unit (Gen_Rep); 5941 5942 Check_OK : constant Boolean := 5943 not In_State.Suppress_Checks 5944 and then Ghost_Mode_Of (Inst_Rep) /= Is_Ignored 5945 and then Ghost_Mode_Of (Gen_Rep) /= Is_Ignored 5946 and then Elaboration_Checks_OK (Inst_Rep) 5947 and then Elaboration_Checks_OK (Gen_Rep); 5948 -- A run-time ABE check may be installed only when both the instance 5949 -- and the generic have active elaboration checks and both are not 5950 -- ignored Ghost constructs. 5951 5952 New_In_State : Processing_In_State := In_State; 5953 -- Each step of the Processing phase constitutes a new state 5954 5955 begin 5956 -- Nothing to do when the instantiation is ABE-safe 5957 -- 5958 -- generic 5959 -- package Gen is 5960 -- ... 5961 -- end Gen; 5962 -- 5963 -- package body Gen is 5964 -- ... 5965 -- end Gen; 5966 -- 5967 -- with Gen; 5968 -- procedure Main is 5969 -- package Inst is new Gen (ABE); -- safe instantiation 5970 -- ... 5971 5972 if Is_Safe_Instantiation (Inst, Gen_Id, Gen_Rep) then 5973 return; 5974 5975 -- The instantiation and the generic body are both in the main unit 5976 -- 5977 -- If the root scenario appears prior to the generic body, then this 5978 -- is a possible ABE with respect to the root scenario. 5979 -- 5980 -- generic 5981 -- package Gen is 5982 -- ... 5983 -- end Gen; 5984 -- 5985 -- function A ... is 5986 -- begin 5987 -- if Some_Condition then 5988 -- declare 5989 -- package Inst is new Gen; -- instantiation site 5990 -- ... 5991 -- end A; 5992 -- 5993 -- X : ... := A; -- root scenario 5994 -- 5995 -- package body Gen is -- generic body 5996 -- ... 5997 -- end Gen; 5998 -- 5999 -- Y : ... := A; -- root scenario 6000 -- 6001 -- IMPORTANT: The instantiation of Gen is a possible ABE for X, 6002 -- but not for Y. Installing an unconditional ABE raise prior to 6003 -- the instance site would be wrong as it will fail for Y as well, 6004 -- but in Y's case the instantiation of Gen is never an ABE. 6005 6006 elsif Present (Body_Decl) 6007 and then In_Extended_Main_Code_Unit (Body_Decl) 6008 then 6009 if Earlier_In_Extended_Unit (Root, Body_Decl) then 6010 6011 -- Do not emit any ABE diagnostics when a previous scenario in 6012 -- this traversal has suppressed elaboration warnings. 6013 6014 if New_In_State.Suppress_Warnings then 6015 null; 6016 6017 -- Do not emit any ABE diagnostics when the instantiation 6018 -- occurs in partial finalization context because this leads 6019 -- to unwanted noise. 6020 6021 elsif New_In_State.Within_Partial_Finalization then 6022 null; 6023 6024 -- Otherwise output the diagnostic 6025 6026 else 6027 Error_Msg_NE 6028 ("??cannot instantiate & before body seen", Inst, Gen_Id); 6029 Error_Msg_N 6030 ("\Program_Error may be raised at run time", Inst); 6031 6032 Output_Active_Scenarios (Inst, New_In_State); 6033 end if; 6034 6035 -- Install a conditional run-time ABE check to verify that the 6036 -- generic body has been elaborated prior to the instantiation. 6037 6038 if Check_OK then 6039 Install_Scenario_ABE_Check 6040 (N => Inst, 6041 Targ_Id => Gen_Id, 6042 Targ_Rep => Gen_Rep, 6043 Disable => Inst_Rep); 6044 6045 -- Update the state of the Processing phase to indicate that 6046 -- no implicit Elaborate[_All] pragma must be generated from 6047 -- this point on. 6048 -- 6049 -- generic 6050 -- package Gen is 6051 -- ... 6052 -- end Gen; 6053 -- 6054 -- function A ... is 6055 -- begin 6056 -- if Some_Condition then 6057 -- <ABE check> 6058 -- declare Inst is new Gen; 6059 -- ... 6060 -- end A; 6061 -- 6062 -- X : ... := A; 6063 -- 6064 -- package body Gen is 6065 -- begin 6066 -- External.Subp; -- imparts Elaborate_All 6067 -- end Gen; 6068 -- 6069 -- If Some_Condition is True, then the ABE check will fail 6070 -- at runtime and the call to External.Subp will never take 6071 -- place, rendering the implicit Elaborate_All useless. 6072 -- 6073 -- If the value of Some_Condition is False, then the call 6074 -- to External.Subp will never take place, rendering the 6075 -- implicit Elaborate_All useless. 6076 6077 New_In_State.Suppress_Implicit_Pragmas := True; 6078 end if; 6079 end if; 6080 6081 -- Otherwise the generic body is not available in this compilation 6082 -- or it resides in an external unit. Install a run-time ABE check 6083 -- to verify that the generic body has been elaborated prior to the 6084 -- instantiation when the dynamic model is in effect. 6085 6086 elsif Check_OK 6087 and then New_In_State.Processing = Dynamic_Model_Processing 6088 then 6089 Install_Unit_ABE_Check 6090 (N => Inst, 6091 Unit_Id => Unit_Id, 6092 Disable => Inst_Rep); 6093 end if; 6094 6095 -- Ensure that the unit with the generic body is elaborated prior 6096 -- to the main unit. No implicit pragma has to be generated if the 6097 -- instantiation has elaboration checks suppressed. This behavior 6098 -- parallels that of the old ABE mechanism. 6099 6100 if Elaboration_Checks_OK (Inst_Rep) then 6101 Ensure_Prior_Elaboration 6102 (N => Inst, 6103 Unit_Id => Unit_Id, 6104 Prag_Nam => Name_Elaborate, 6105 In_State => New_In_State); 6106 end if; 6107 end Process_Conditional_ABE_Instantiation_Ada; 6108 6109 ------------------------------------------------- 6110 -- Process_Conditional_ABE_Instantiation_SPARK -- 6111 ------------------------------------------------- 6112 6113 procedure Process_Conditional_ABE_Instantiation_SPARK 6114 (Inst : Node_Id; 6115 Inst_Rep : Scenario_Rep_Id; 6116 Gen_Id : Entity_Id; 6117 Gen_Rep : Target_Rep_Id; 6118 In_State : Processing_In_State) 6119 is 6120 pragma Unreferenced (Inst_Rep); 6121 6122 Req_Nam : Name_Id; 6123 6124 begin 6125 -- Ensure that a suitable elaboration model is in effect for SPARK 6126 -- rule verification. 6127 6128 Check_SPARK_Model_In_Effect; 6129 6130 -- A source instantiation imposes an Elaborate[_All] requirement 6131 -- on the context of the main unit. Determine whether the context 6132 -- has a pragma strong enough to meet the requirement. The check 6133 -- is orthogonal to the ABE ramifications of the instantiation. 6134 -- 6135 -- IMPORTANT: This check must be performed only when switch -gnatd.v 6136 -- (enforce SPARK elaboration rules in SPARK code) is active because 6137 -- the static model can ensure the prior elaboration of the unit 6138 -- which contains a body by installing an implicit Elaborate[_All] 6139 -- pragma. 6140 6141 if Debug_Flag_Dot_V then 6142 if Nkind (Inst) = N_Package_Instantiation then 6143 Req_Nam := Name_Elaborate_All; 6144 else 6145 Req_Nam := Name_Elaborate; 6146 end if; 6147 6148 Meet_Elaboration_Requirement 6149 (N => Inst, 6150 Targ_Id => Gen_Id, 6151 Req_Nam => Req_Nam, 6152 In_State => In_State); 6153 6154 -- Otherwise ensure that the unit with the target body is elaborated 6155 -- prior to the main unit. 6156 6157 else 6158 Ensure_Prior_Elaboration 6159 (N => Inst, 6160 Unit_Id => Unit (Gen_Rep), 6161 Prag_Nam => Name_Elaborate, 6162 In_State => In_State); 6163 end if; 6164 end Process_Conditional_ABE_Instantiation_SPARK; 6165 6166 ------------------------------------------------- 6167 -- Process_Conditional_ABE_Variable_Assignment -- 6168 ------------------------------------------------- 6169 6170 procedure Process_Conditional_ABE_Variable_Assignment 6171 (Asmt : Node_Id; 6172 Asmt_Rep : Scenario_Rep_Id; 6173 In_State : Processing_In_State) 6174 is 6175 6176 Var_Id : constant Entity_Id := Target (Asmt_Rep); 6177 Var_Rep : constant Target_Rep_Id := 6178 Target_Representation_Of (Var_Id, In_State); 6179 6180 SPARK_Rules_On : constant Boolean := 6181 SPARK_Mode_Of (Asmt_Rep) = Is_On 6182 and then SPARK_Mode_Of (Var_Rep) = Is_On; 6183 6184 begin 6185 -- Output relevant information when switch -gnatel (info messages on 6186 -- implicit Elaborate[_All] pragmas) is in effect. 6187 6188 if Elab_Info_Messages 6189 and then not In_State.Suppress_Info_Messages 6190 then 6191 Elab_Msg_NE 6192 (Msg => "assignment to & during elaboration", 6193 N => Asmt, 6194 Id => Var_Id, 6195 Info_Msg => True, 6196 In_SPARK => SPARK_Rules_On); 6197 end if; 6198 6199 -- The SPARK rules are in effect. These rules are applied regardless 6200 -- of whether switch -gnatd.v (enforce SPARK elaboration rules in 6201 -- SPARK code) is in effect because the static model cannot ensure 6202 -- safe assignment of variables. 6203 6204 if SPARK_Rules_On then 6205 Process_Conditional_ABE_Variable_Assignment_SPARK 6206 (Asmt => Asmt, 6207 Asmt_Rep => Asmt_Rep, 6208 Var_Id => Var_Id, 6209 Var_Rep => Var_Rep, 6210 In_State => In_State); 6211 6212 -- Otherwise the Ada rules are in effect 6213 6214 else 6215 Process_Conditional_ABE_Variable_Assignment_Ada 6216 (Asmt => Asmt, 6217 Asmt_Rep => Asmt_Rep, 6218 Var_Id => Var_Id, 6219 Var_Rep => Var_Rep, 6220 In_State => In_State); 6221 end if; 6222 end Process_Conditional_ABE_Variable_Assignment; 6223 6224 ----------------------------------------------------- 6225 -- Process_Conditional_ABE_Variable_Assignment_Ada -- 6226 ----------------------------------------------------- 6227 6228 procedure Process_Conditional_ABE_Variable_Assignment_Ada 6229 (Asmt : Node_Id; 6230 Asmt_Rep : Scenario_Rep_Id; 6231 Var_Id : Entity_Id; 6232 Var_Rep : Target_Rep_Id; 6233 In_State : Processing_In_State) 6234 is 6235 pragma Unreferenced (Asmt_Rep); 6236 6237 Var_Decl : constant Node_Id := Variable_Declaration (Var_Rep); 6238 Unit_Id : constant Entity_Id := Unit (Var_Rep); 6239 6240 begin 6241 -- Emit a warning when an uninitialized variable declared in a 6242 -- package spec without a pragma Elaborate_Body is initialized 6243 -- by elaboration code within the corresponding body. 6244 6245 if Is_Elaboration_Warnings_OK_Id (Var_Id) 6246 and then not Is_Initialized (Var_Decl) 6247 and then not Has_Pragma_Elaborate_Body (Unit_Id) 6248 then 6249 -- Do not emit any ABE diagnostics when a previous scenario in 6250 -- this traversal has suppressed elaboration warnings. 6251 6252 if not In_State.Suppress_Warnings then 6253 Error_Msg_NE 6254 ("??variable & can be accessed by clients before this " 6255 & "initialization", Asmt, Var_Id); 6256 6257 Error_Msg_NE 6258 ("\add pragma ""Elaborate_Body"" to spec & to ensure proper " 6259 & "initialization", Asmt, Unit_Id); 6260 6261 Output_Active_Scenarios (Asmt, In_State); 6262 end if; 6263 6264 -- Generate an implicit Elaborate_Body in the spec 6265 6266 Set_Elaborate_Body_Desirable (Unit_Id); 6267 end if; 6268 end Process_Conditional_ABE_Variable_Assignment_Ada; 6269 6270 ------------------------------------------------------- 6271 -- Process_Conditional_ABE_Variable_Assignment_SPARK -- 6272 ------------------------------------------------------- 6273 6274 procedure Process_Conditional_ABE_Variable_Assignment_SPARK 6275 (Asmt : Node_Id; 6276 Asmt_Rep : Scenario_Rep_Id; 6277 Var_Id : Entity_Id; 6278 Var_Rep : Target_Rep_Id; 6279 In_State : Processing_In_State) 6280 is 6281 pragma Unreferenced (Asmt_Rep); 6282 6283 Var_Decl : constant Node_Id := Variable_Declaration (Var_Rep); 6284 Unit_Id : constant Entity_Id := Unit (Var_Rep); 6285 6286 begin 6287 -- Ensure that a suitable elaboration model is in effect for SPARK 6288 -- rule verification. 6289 6290 Check_SPARK_Model_In_Effect; 6291 6292 -- Do not emit any ABE diagnostics when a previous scenario in this 6293 -- traversal has suppressed elaboration warnings. 6294 6295 if In_State.Suppress_Warnings then 6296 null; 6297 6298 -- Emit an error when an initialized variable declared in a package 6299 -- spec that is missing pragma Elaborate_Body is further modified by 6300 -- elaboration code within the corresponding body. 6301 6302 elsif Is_Elaboration_Warnings_OK_Id (Var_Id) 6303 and then Is_Initialized (Var_Decl) 6304 and then not Has_Pragma_Elaborate_Body (Unit_Id) 6305 then 6306 Error_Msg_NE 6307 ("variable & modified by elaboration code in package body", 6308 Asmt, Var_Id); 6309 6310 Error_Msg_NE 6311 ("\add pragma ""Elaborate_Body"" to spec & to ensure full " 6312 & "initialization", Asmt, Unit_Id); 6313 6314 Output_Active_Scenarios (Asmt, In_State); 6315 end if; 6316 end Process_Conditional_ABE_Variable_Assignment_SPARK; 6317 6318 ------------------------------------------------ 6319 -- Process_Conditional_ABE_Variable_Reference -- 6320 ------------------------------------------------ 6321 6322 procedure Process_Conditional_ABE_Variable_Reference 6323 (Ref : Node_Id; 6324 Ref_Rep : Scenario_Rep_Id; 6325 In_State : Processing_In_State) 6326 is 6327 Var_Id : constant Entity_Id := Target (Ref); 6328 Var_Rep : Target_Rep_Id; 6329 Unit_Id : Entity_Id; 6330 6331 begin 6332 -- Nothing to do when the variable reference is not a read 6333 6334 if not Is_Read_Reference (Ref_Rep) then 6335 return; 6336 end if; 6337 6338 Var_Rep := Target_Representation_Of (Var_Id, In_State); 6339 Unit_Id := Unit (Var_Rep); 6340 6341 -- Output relevant information when switch -gnatel (info messages on 6342 -- implicit Elaborate[_All] pragmas) is in effect. 6343 6344 if Elab_Info_Messages 6345 and then not In_State.Suppress_Info_Messages 6346 then 6347 Elab_Msg_NE 6348 (Msg => "read of variable & during elaboration", 6349 N => Ref, 6350 Id => Var_Id, 6351 Info_Msg => True, 6352 In_SPARK => True); 6353 end if; 6354 6355 -- Nothing to do when the variable appears within the main unit 6356 -- because diagnostics on reads are relevant only for external 6357 -- variables. 6358 6359 if Is_Same_Unit (Unit_Id, Main_Unit_Entity) then 6360 null; 6361 6362 -- Nothing to do when the variable is already initialized. Note that 6363 -- the variable may be further modified by the external unit. 6364 6365 elsif Is_Initialized (Variable_Declaration (Var_Rep)) then 6366 null; 6367 6368 -- Nothing to do when the external unit guarantees the initialization 6369 -- of the variable by means of pragma Elaborate_Body. 6370 6371 elsif Has_Pragma_Elaborate_Body (Unit_Id) then 6372 null; 6373 6374 -- A variable read imposes an Elaborate requirement on the context of 6375 -- the main unit. Determine whether the context has a pragma strong 6376 -- enough to meet the requirement. 6377 6378 else 6379 Meet_Elaboration_Requirement 6380 (N => Ref, 6381 Targ_Id => Var_Id, 6382 Req_Nam => Name_Elaborate, 6383 In_State => In_State); 6384 end if; 6385 end Process_Conditional_ABE_Variable_Reference; 6386 6387 ----------------------------------- 6388 -- Traverse_Conditional_ABE_Body -- 6389 ----------------------------------- 6390 6391 procedure Traverse_Conditional_ABE_Body 6392 (N : Node_Id; 6393 In_State : Processing_In_State) 6394 is 6395 begin 6396 Traverse_Body 6397 (N => N, 6398 Requires_Processing => Is_Conditional_ABE_Scenario'Access, 6399 Processor => Process_Conditional_ABE'Access, 6400 In_State => In_State); 6401 end Traverse_Conditional_ABE_Body; 6402 end Conditional_ABE_Processor; 6403 6404 ------------- 6405 -- Destroy -- 6406 ------------- 6407 6408 procedure Destroy (NE : in out Node_Or_Entity_Id) is 6409 pragma Unreferenced (NE); 6410 begin 6411 null; 6412 end Destroy; 6413 6414 ----------------- 6415 -- Diagnostics -- 6416 ----------------- 6417 6418 package body Diagnostics is 6419 6420 ----------------- 6421 -- Elab_Msg_NE -- 6422 ----------------- 6423 6424 procedure Elab_Msg_NE 6425 (Msg : String; 6426 N : Node_Id; 6427 Id : Entity_Id; 6428 Info_Msg : Boolean; 6429 In_SPARK : Boolean) 6430 is 6431 function Prefix return String; 6432 pragma Inline (Prefix); 6433 -- Obtain the prefix of the message 6434 6435 function Suffix return String; 6436 pragma Inline (Suffix); 6437 -- Obtain the suffix of the message 6438 6439 ------------ 6440 -- Prefix -- 6441 ------------ 6442 6443 function Prefix return String is 6444 begin 6445 if Info_Msg then 6446 return "info: "; 6447 else 6448 return ""; 6449 end if; 6450 end Prefix; 6451 6452 ------------ 6453 -- Suffix -- 6454 ------------ 6455 6456 function Suffix return String is 6457 begin 6458 if In_SPARK then 6459 return " in SPARK"; 6460 else 6461 return ""; 6462 end if; 6463 end Suffix; 6464 6465 -- Start of processing for Elab_Msg_NE 6466 6467 begin 6468 Error_Msg_NE (Prefix & Msg & Suffix, N, Id); 6469 end Elab_Msg_NE; 6470 6471 --------------- 6472 -- Info_Call -- 6473 --------------- 6474 6475 procedure Info_Call 6476 (Call : Node_Id; 6477 Subp_Id : Entity_Id; 6478 Info_Msg : Boolean; 6479 In_SPARK : Boolean) 6480 is 6481 procedure Info_Accept_Alternative; 6482 pragma Inline (Info_Accept_Alternative); 6483 -- Output information concerning an accept alternative 6484 6485 procedure Info_Simple_Call; 6486 pragma Inline (Info_Simple_Call); 6487 -- Output information concerning the call 6488 6489 procedure Info_Type_Actions (Action : String); 6490 pragma Inline (Info_Type_Actions); 6491 -- Output information concerning action Action of a type 6492 6493 procedure Info_Verification_Call 6494 (Pred : String; 6495 Id : Entity_Id; 6496 Id_Kind : String); 6497 pragma Inline (Info_Verification_Call); 6498 -- Output information concerning the verification of predicate Pred 6499 -- applied to related entity Id with kind Id_Kind. 6500 6501 ----------------------------- 6502 -- Info_Accept_Alternative -- 6503 ----------------------------- 6504 6505 procedure Info_Accept_Alternative is 6506 Entry_Id : constant Entity_Id := Receiving_Entry (Subp_Id); 6507 pragma Assert (Present (Entry_Id)); 6508 6509 begin 6510 Elab_Msg_NE 6511 (Msg => "accept for entry & during elaboration", 6512 N => Call, 6513 Id => Entry_Id, 6514 Info_Msg => Info_Msg, 6515 In_SPARK => In_SPARK); 6516 end Info_Accept_Alternative; 6517 6518 ---------------------- 6519 -- Info_Simple_Call -- 6520 ---------------------- 6521 6522 procedure Info_Simple_Call is 6523 begin 6524 Elab_Msg_NE 6525 (Msg => "call to & during elaboration", 6526 N => Call, 6527 Id => Subp_Id, 6528 Info_Msg => Info_Msg, 6529 In_SPARK => In_SPARK); 6530 end Info_Simple_Call; 6531 6532 ----------------------- 6533 -- Info_Type_Actions -- 6534 ----------------------- 6535 6536 procedure Info_Type_Actions (Action : String) is 6537 Typ : constant Entity_Id := First_Formal_Type (Subp_Id); 6538 pragma Assert (Present (Typ)); 6539 6540 begin 6541 Elab_Msg_NE 6542 (Msg => Action & " actions for type & during elaboration", 6543 N => Call, 6544 Id => Typ, 6545 Info_Msg => Info_Msg, 6546 In_SPARK => In_SPARK); 6547 end Info_Type_Actions; 6548 6549 ---------------------------- 6550 -- Info_Verification_Call -- 6551 ---------------------------- 6552 6553 procedure Info_Verification_Call 6554 (Pred : String; 6555 Id : Entity_Id; 6556 Id_Kind : String) 6557 is 6558 pragma Assert (Present (Id)); 6559 6560 begin 6561 Elab_Msg_NE 6562 (Msg => 6563 "verification of " & Pred & " of " & Id_Kind & " & during " 6564 & "elaboration", 6565 N => Call, 6566 Id => Id, 6567 Info_Msg => Info_Msg, 6568 In_SPARK => In_SPARK); 6569 end Info_Verification_Call; 6570 6571 -- Start of processing for Info_Call 6572 6573 begin 6574 -- Do not output anything for targets defined in internal units 6575 -- because this creates noise. 6576 6577 if not In_Internal_Unit (Subp_Id) then 6578 6579 -- Accept alternative 6580 6581 if Is_Accept_Alternative_Proc (Subp_Id) then 6582 Info_Accept_Alternative; 6583 6584 -- Adjustment 6585 6586 elsif Is_TSS (Subp_Id, TSS_Deep_Adjust) then 6587 Info_Type_Actions ("adjustment"); 6588 6589 -- Default_Initial_Condition 6590 6591 elsif Is_Default_Initial_Condition_Proc (Subp_Id) then 6592 Info_Verification_Call 6593 (Pred => "Default_Initial_Condition", 6594 Id => First_Formal_Type (Subp_Id), 6595 Id_Kind => "type"); 6596 6597 -- Entries 6598 6599 elsif Is_Protected_Entry (Subp_Id) then 6600 Info_Simple_Call; 6601 6602 -- Task entry calls are never processed because the entry being 6603 -- invoked does not have a corresponding "body", it has a select. 6604 6605 elsif Is_Task_Entry (Subp_Id) then 6606 null; 6607 6608 -- Finalization 6609 6610 elsif Is_TSS (Subp_Id, TSS_Deep_Finalize) then 6611 Info_Type_Actions ("finalization"); 6612 6613 -- Calls to _Finalizer procedures must not appear in the output 6614 -- because this creates confusing noise. 6615 6616 elsif Is_Finalizer_Proc (Subp_Id) then 6617 null; 6618 6619 -- Initial_Condition 6620 6621 elsif Is_Initial_Condition_Proc (Subp_Id) then 6622 Info_Verification_Call 6623 (Pred => "Initial_Condition", 6624 Id => Find_Enclosing_Scope (Call), 6625 Id_Kind => "package"); 6626 6627 -- Initialization 6628 6629 elsif Is_Init_Proc (Subp_Id) 6630 or else Is_TSS (Subp_Id, TSS_Deep_Initialize) 6631 then 6632 Info_Type_Actions ("initialization"); 6633 6634 -- Invariant 6635 6636 elsif Is_Invariant_Proc (Subp_Id) then 6637 Info_Verification_Call 6638 (Pred => "invariants", 6639 Id => First_Formal_Type (Subp_Id), 6640 Id_Kind => "type"); 6641 6642 -- Partial invariant calls must not appear in the output because 6643 -- this creates confusing noise. 6644 6645 elsif Is_Partial_Invariant_Proc (Subp_Id) then 6646 null; 6647 6648 -- _Postconditions 6649 6650 elsif Is_Postconditions_Proc (Subp_Id) then 6651 Info_Verification_Call 6652 (Pred => "postconditions", 6653 Id => Find_Enclosing_Scope (Call), 6654 Id_Kind => "subprogram"); 6655 6656 -- Subprograms must come last because some of the previous cases 6657 -- fall under this category. 6658 6659 elsif Ekind (Subp_Id) = E_Function then 6660 Info_Simple_Call; 6661 6662 elsif Ekind (Subp_Id) = E_Procedure then 6663 Info_Simple_Call; 6664 6665 else 6666 pragma Assert (False); 6667 return; 6668 end if; 6669 end if; 6670 end Info_Call; 6671 6672 ------------------------ 6673 -- Info_Instantiation -- 6674 ------------------------ 6675 6676 procedure Info_Instantiation 6677 (Inst : Node_Id; 6678 Gen_Id : Entity_Id; 6679 Info_Msg : Boolean; 6680 In_SPARK : Boolean) 6681 is 6682 begin 6683 Elab_Msg_NE 6684 (Msg => "instantiation of & during elaboration", 6685 N => Inst, 6686 Id => Gen_Id, 6687 Info_Msg => Info_Msg, 6688 In_SPARK => In_SPARK); 6689 end Info_Instantiation; 6690 6691 ----------------------------- 6692 -- Info_Variable_Reference -- 6693 ----------------------------- 6694 6695 procedure Info_Variable_Reference 6696 (Ref : Node_Id; 6697 Var_Id : Entity_Id; 6698 Info_Msg : Boolean; 6699 In_SPARK : Boolean) 6700 is 6701 begin 6702 if Is_Read (Ref) then 6703 Elab_Msg_NE 6704 (Msg => "read of variable & during elaboration", 6705 N => Ref, 6706 Id => Var_Id, 6707 Info_Msg => Info_Msg, 6708 In_SPARK => In_SPARK); 6709 end if; 6710 end Info_Variable_Reference; 6711 end Diagnostics; 6712 6713 --------------------------------- 6714 -- Early_Call_Region_Processor -- 6715 --------------------------------- 6716 6717 package body Early_Call_Region_Processor is 6718 6719 --------------------- 6720 -- Data structures -- 6721 --------------------- 6722 6723 -- The following map relates early call regions to subprogram bodies 6724 6725 procedure Destroy (N : in out Node_Id); 6726 -- Destroy node N 6727 6728 package ECR_Map is new Dynamic_Hash_Tables 6729 (Key_Type => Entity_Id, 6730 Value_Type => Node_Id, 6731 No_Value => Empty, 6732 Expansion_Threshold => 1.5, 6733 Expansion_Factor => 2, 6734 Compression_Threshold => 0.3, 6735 Compression_Factor => 2, 6736 "=" => "=", 6737 Destroy_Value => Destroy, 6738 Hash => Hash); 6739 6740 Early_Call_Regions_Map : ECR_Map.Dynamic_Hash_Table := ECR_Map.Nil; 6741 6742 ----------------------- 6743 -- Local subprograms -- 6744 ----------------------- 6745 6746 function Early_Call_Region (Body_Id : Entity_Id) return Node_Id; 6747 pragma Inline (Early_Call_Region); 6748 -- Obtain the early call region associated with entry or subprogram body 6749 -- Body_Id. 6750 6751 procedure Set_Early_Call_Region (Body_Id : Entity_Id; Start : Node_Id); 6752 pragma Inline (Set_Early_Call_Region); 6753 -- Associate an early call region with begins at construct Start with 6754 -- entry or subprogram body Body_Id. 6755 6756 ------------- 6757 -- Destroy -- 6758 ------------- 6759 6760 procedure Destroy (N : in out Node_Id) is 6761 pragma Unreferenced (N); 6762 begin 6763 null; 6764 end Destroy; 6765 6766 ----------------------- 6767 -- Early_Call_Region -- 6768 ----------------------- 6769 6770 function Early_Call_Region (Body_Id : Entity_Id) return Node_Id is 6771 pragma Assert (Present (Body_Id)); 6772 begin 6773 return ECR_Map.Get (Early_Call_Regions_Map, Body_Id); 6774 end Early_Call_Region; 6775 6776 ------------------------------------------ 6777 -- Finalize_Early_Call_Region_Processor -- 6778 ------------------------------------------ 6779 6780 procedure Finalize_Early_Call_Region_Processor is 6781 begin 6782 ECR_Map.Destroy (Early_Call_Regions_Map); 6783 end Finalize_Early_Call_Region_Processor; 6784 6785 ---------------------------- 6786 -- Find_Early_Call_Region -- 6787 ---------------------------- 6788 6789 function Find_Early_Call_Region 6790 (Body_Decl : Node_Id; 6791 Assume_Elab_Body : Boolean := False; 6792 Skip_Memoization : Boolean := False) return Node_Id 6793 is 6794 -- NOTE: The routines within Find_Early_Call_Region are intentionally 6795 -- unnested to avoid deep indentation of code. 6796 6797 ECR_Found : exception; 6798 -- This exception is raised when the early call region has been found 6799 6800 Start : Node_Id := Empty; 6801 -- The start of the early call region. This variable is updated by 6802 -- the various nested routines. Due to the use of exceptions, the 6803 -- variable must be global to the nested routines. 6804 6805 -- The algorithm implemented in this routine attempts to find the 6806 -- early call region of a subprogram body by inspecting constructs 6807 -- in reverse declarative order, while navigating the tree. The 6808 -- algorithm consists of an Inspection phase and Advancement phase. 6809 -- The pseudocode is as follows: 6810 -- 6811 -- loop 6812 -- inspection phase 6813 -- advancement phase 6814 -- end loop 6815 -- 6816 -- The infinite loop is terminated by raising exception ECR_Found. 6817 -- The algorithm utilizes two pointers, Curr and Start, to represent 6818 -- the current construct to inspect and the start of the early call 6819 -- region. 6820 -- 6821 -- IMPORTANT: The algorithm must maintain the following invariant at 6822 -- all time for it to function properly: 6823 -- 6824 -- A nested construct is entered only when it contains suitable 6825 -- constructs. 6826 -- 6827 -- This guarantees that leaving a nested or encapsulating construct 6828 -- functions properly. 6829 -- 6830 -- The Inspection phase determines whether the current construct is 6831 -- non-preelaborable, and if it is, the algorithm terminates. 6832 -- 6833 -- The Advancement phase walks the tree in reverse declarative order, 6834 -- while entering and leaving nested and encapsulating constructs. It 6835 -- may also terminate the elaborithm. There are several special cases 6836 -- of advancement. 6837 -- 6838 -- 1) General case: 6839 -- 6840 -- <construct 1> 6841 -- ... 6842 -- <construct N-1> <- Curr 6843 -- <construct N> <- Start 6844 -- <subprogram body> 6845 -- 6846 -- In the general case, a declarative or statement list is traversed 6847 -- in reverse order where Curr is the lead pointer, and Start is the 6848 -- last preelaborable construct. 6849 -- 6850 -- 2) Entering handled bodies 6851 -- 6852 -- package body Nested is <- Curr (2.3) 6853 -- <declarations> <- Curr (2.2) 6854 -- begin 6855 -- <statements> <- Curr (2.1) 6856 -- end Nested; 6857 -- <construct> <- Start 6858 -- 6859 -- In this case, the algorithm enters a handled body by starting from 6860 -- the last statement (2.1), or the last declaration (2.2), or the 6861 -- body is consumed (2.3) because it is empty and thus preelaborable. 6862 -- 6863 -- 3) Entering package declarations 6864 -- 6865 -- package Nested is <- Curr (2.3) 6866 -- <visible declarations> <- Curr (2.2) 6867 -- private 6868 -- <private declarations> <- Curr (2.1) 6869 -- end Nested; 6870 -- <construct> <- Start 6871 -- 6872 -- In this case, the algorithm enters a package declaration by 6873 -- starting from the last private declaration (2.1), the last visible 6874 -- declaration (2.2), or the package is consumed (2.3) because it is 6875 -- empty and thus preelaborable. 6876 -- 6877 -- 4) Transitioning from list to list of the same construct 6878 -- 6879 -- Certain constructs have two eligible lists. The algorithm must 6880 -- thus transition from the second to the first list when the second 6881 -- list is exhausted. 6882 -- 6883 -- declare <- Curr (4.2) 6884 -- <declarations> <- Curr (4.1) 6885 -- begin 6886 -- <statements> <- Start 6887 -- end; 6888 -- 6889 -- In this case, the algorithm has exhausted the second list (the 6890 -- statements in the example above), and continues with the last 6891 -- declaration (4.1) or the construct is consumed (4.2) because it 6892 -- contains only preelaborable code. 6893 -- 6894 -- 5) Transitioning from list to construct 6895 -- 6896 -- tack body Task is <- Curr (5.1) 6897 -- <- Curr (Empty) 6898 -- <construct 1> <- Start 6899 -- 6900 -- In this case, the algorithm has exhausted a list, Curr is Empty, 6901 -- and the owner of the list is consumed (5.1). 6902 -- 6903 -- 6) Transitioning from unit to unit 6904 -- 6905 -- A package body with a spec subject to pragma Elaborate_Body 6906 -- extends the possible range of the early call region to the package 6907 -- spec. 6908 -- 6909 -- package Pack is <- Curr (6.3) 6910 -- pragma Elaborate_Body; <- Curr (6.2) 6911 -- <visible declarations> <- Curr (6.2) 6912 -- private 6913 -- <private declarations> <- Curr (6.1) 6914 -- end Pack; 6915 -- 6916 -- package body Pack is <- Curr, Start 6917 -- 6918 -- In this case, the algorithm has reached a package body compilation 6919 -- unit whose spec is subject to pragma Elaborate_Body, or the caller 6920 -- of the algorithm has specified this behavior. This transition is 6921 -- equivalent to 3). 6922 -- 6923 -- 7) Transitioning from unit to termination 6924 -- 6925 -- Reaching a compilation unit always terminates the algorithm as 6926 -- there are no more lists to examine. This must take case 6) into 6927 -- account. 6928 -- 6929 -- 8) Transitioning from subunit to stub 6930 -- 6931 -- package body Pack is separate; <- Curr (8.1) 6932 -- 6933 -- separate (...) 6934 -- package body Pack is <- Curr, Start 6935 -- 6936 -- Reaching a subunit continues the search from the corresponding 6937 -- stub (8.1). 6938 6939 procedure Advance (Curr : in out Node_Id); 6940 pragma Inline (Advance); 6941 -- Update the Curr and Start pointers depending on their location 6942 -- in the tree to the next eligible construct. This routine raises 6943 -- ECR_Found. 6944 6945 procedure Enter_Handled_Body (Curr : in out Node_Id); 6946 pragma Inline (Enter_Handled_Body); 6947 -- Update the Curr and Start pointers to enter a nested handled body 6948 -- if applicable. This routine raises ECR_Found. 6949 6950 procedure Enter_Package_Declaration (Curr : in out Node_Id); 6951 pragma Inline (Enter_Package_Declaration); 6952 -- Update the Curr and Start pointers to enter a nested package spec 6953 -- if applicable. This routine raises ECR_Found. 6954 6955 function Find_ECR (N : Node_Id) return Node_Id; 6956 pragma Inline (Find_ECR); 6957 -- Find an early call region starting from arbitrary node N 6958 6959 function Has_Suitable_Construct (List : List_Id) return Boolean; 6960 pragma Inline (Has_Suitable_Construct); 6961 -- Determine whether list List contains a suitable construct for 6962 -- inclusion into an early call region. 6963 6964 procedure Include (N : Node_Id; Curr : out Node_Id); 6965 pragma Inline (Include); 6966 -- Update the Curr and Start pointers to include arbitrary construct 6967 -- N in the early call region. This routine raises ECR_Found. 6968 6969 function Is_OK_Preelaborable_Construct (N : Node_Id) return Boolean; 6970 pragma Inline (Is_OK_Preelaborable_Construct); 6971 -- Determine whether arbitrary node N denotes a preelaboration-safe 6972 -- construct. 6973 6974 function Is_Suitable_Construct (N : Node_Id) return Boolean; 6975 pragma Inline (Is_Suitable_Construct); 6976 -- Determine whether arbitrary node N denotes a suitable construct 6977 -- for inclusion into the early call region. 6978 6979 procedure Transition_Body_Declarations 6980 (Bod : Node_Id; 6981 Curr : out Node_Id); 6982 pragma Inline (Transition_Body_Declarations); 6983 -- Update the Curr and Start pointers when construct Bod denotes a 6984 -- block statement or a suitable body. This routine raises ECR_Found. 6985 6986 procedure Transition_Handled_Statements 6987 (HSS : Node_Id; 6988 Curr : out Node_Id); 6989 pragma Inline (Transition_Handled_Statements); 6990 -- Update the Curr and Start pointers when node HSS denotes a handled 6991 -- sequence of statements. This routine raises ECR_Found. 6992 6993 procedure Transition_Spec_Declarations 6994 (Spec : Node_Id; 6995 Curr : out Node_Id); 6996 pragma Inline (Transition_Spec_Declarations); 6997 -- Update the Curr and Start pointers when construct Spec denotes 6998 -- a concurrent definition or a package spec. This routine raises 6999 -- ECR_Found. 7000 7001 procedure Transition_Unit (Unit : Node_Id; Curr : out Node_Id); 7002 pragma Inline (Transition_Unit); 7003 -- Update the Curr and Start pointers when node Unit denotes a 7004 -- potential compilation unit. This routine raises ECR_Found. 7005 7006 ------------- 7007 -- Advance -- 7008 ------------- 7009 7010 procedure Advance (Curr : in out Node_Id) is 7011 Context : Node_Id; 7012 7013 begin 7014 -- Curr denotes one of the following cases upon entry into this 7015 -- routine: 7016 -- 7017 -- * Empty - There is no current construct when a declarative or 7018 -- a statement list has been exhausted. This does not indicate 7019 -- that the early call region has been computed as it is still 7020 -- possible to transition to another list. 7021 -- 7022 -- * Encapsulator - The current construct wraps declarations 7023 -- and/or statements. This indicates that the early call 7024 -- region may extend within the nested construct. 7025 -- 7026 -- * Preelaborable - The current construct is preelaborable 7027 -- because Find_ECR would not invoke Advance if this was not 7028 -- the case. 7029 7030 -- The current construct is an encapsulator or is preelaborable 7031 7032 if Present (Curr) then 7033 7034 -- Enter encapsulators by inspecting their declarations and/or 7035 -- statements. 7036 7037 if Nkind (Curr) in N_Block_Statement | N_Package_Body then 7038 Enter_Handled_Body (Curr); 7039 7040 elsif Nkind (Curr) = N_Package_Declaration then 7041 Enter_Package_Declaration (Curr); 7042 7043 -- Early call regions have a property which can be exploited to 7044 -- optimize the algorithm. 7045 -- 7046 -- <preceding subprogram body> 7047 -- <preelaborable construct 1> 7048 -- ... 7049 -- <preelaborable construct N> 7050 -- <initiating subprogram body> 7051 -- 7052 -- If a traversal initiated from a subprogram body reaches a 7053 -- preceding subprogram body, then both bodies share the same 7054 -- early call region. 7055 -- 7056 -- The property results in the following desirable effects: 7057 -- 7058 -- * If the preceding body already has an early call region, 7059 -- then the initiating body can reuse it. This minimizes the 7060 -- amount of processing performed by the algorithm. 7061 -- 7062 -- * If the preceding body lack an early call region, then the 7063 -- algorithm can compute the early call region, and reuse it 7064 -- for the initiating body. This processing performs the same 7065 -- amount of work, but has the beneficial effect of computing 7066 -- the early call regions of all preceding bodies. 7067 7068 elsif Nkind (Curr) in N_Entry_Body | N_Subprogram_Body then 7069 Start := 7070 Find_Early_Call_Region 7071 (Body_Decl => Curr, 7072 Assume_Elab_Body => Assume_Elab_Body, 7073 Skip_Memoization => Skip_Memoization); 7074 7075 raise ECR_Found; 7076 7077 -- Otherwise current construct is preelaborable. Unpdate the 7078 -- early call region to include it. 7079 7080 else 7081 Include (Curr, Curr); 7082 end if; 7083 7084 -- Otherwise the current construct is missing, indicating that the 7085 -- current list has been exhausted. Depending on the context of 7086 -- the list, several transitions are possible. 7087 7088 else 7089 -- The invariant of the algorithm ensures that Curr and Start 7090 -- are at the same level of nesting at the point of transition. 7091 -- The algorithm can determine which list the traversal came 7092 -- from by examining Start. 7093 7094 Context := Parent (Start); 7095 7096 -- Attempt the following transitions: 7097 -- 7098 -- private declarations -> visible declarations 7099 -- private declarations -> upper level 7100 -- private declarations -> terminate 7101 -- visible declarations -> upper level 7102 -- visible declarations -> terminate 7103 7104 if Nkind (Context) in N_Package_Specification 7105 | N_Protected_Definition 7106 | N_Task_Definition 7107 then 7108 Transition_Spec_Declarations (Context, Curr); 7109 7110 -- Attempt the following transitions: 7111 -- 7112 -- statements -> declarations 7113 -- statements -> upper level 7114 -- statements -> corresponding package spec (Elab_Body) 7115 -- statements -> terminate 7116 7117 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements then 7118 Transition_Handled_Statements (Context, Curr); 7119 7120 -- Attempt the following transitions: 7121 -- 7122 -- declarations -> upper level 7123 -- declarations -> corresponding package spec (Elab_Body) 7124 -- declarations -> terminate 7125 7126 elsif Nkind (Context) in N_Block_Statement 7127 | N_Entry_Body 7128 | N_Package_Body 7129 | N_Protected_Body 7130 | N_Subprogram_Body 7131 | N_Task_Body 7132 then 7133 Transition_Body_Declarations (Context, Curr); 7134 7135 -- Otherwise it is not possible to transition. Stop the search 7136 -- because there are no more declarations or statements to 7137 -- check. 7138 7139 else 7140 raise ECR_Found; 7141 end if; 7142 end if; 7143 end Advance; 7144 7145 -------------------------- 7146 -- Enter_Handled_Body -- 7147 -------------------------- 7148 7149 procedure Enter_Handled_Body (Curr : in out Node_Id) is 7150 Decls : constant List_Id := Declarations (Curr); 7151 HSS : constant Node_Id := Handled_Statement_Sequence (Curr); 7152 Stmts : List_Id := No_List; 7153 7154 begin 7155 if Present (HSS) then 7156 Stmts := Statements (HSS); 7157 end if; 7158 7159 -- The handled body has a non-empty statement sequence. The 7160 -- construct to inspect is the last statement. 7161 7162 if Has_Suitable_Construct (Stmts) then 7163 Curr := Last (Stmts); 7164 7165 -- The handled body lacks statements, but has non-empty 7166 -- declarations. The construct to inspect is the last declaration. 7167 7168 elsif Has_Suitable_Construct (Decls) then 7169 Curr := Last (Decls); 7170 7171 -- Otherwise the handled body lacks both declarations and 7172 -- statements. The construct to inspect is the node which precedes 7173 -- the handled body. Update the early call region to include the 7174 -- handled body. 7175 7176 else 7177 Include (Curr, Curr); 7178 end if; 7179 end Enter_Handled_Body; 7180 7181 ------------------------------- 7182 -- Enter_Package_Declaration -- 7183 ------------------------------- 7184 7185 procedure Enter_Package_Declaration (Curr : in out Node_Id) is 7186 Pack_Spec : constant Node_Id := Specification (Curr); 7187 Prv_Decls : constant List_Id := Private_Declarations (Pack_Spec); 7188 Vis_Decls : constant List_Id := Visible_Declarations (Pack_Spec); 7189 7190 begin 7191 -- The package has a non-empty private declarations. The construct 7192 -- to inspect is the last private declaration. 7193 7194 if Has_Suitable_Construct (Prv_Decls) then 7195 Curr := Last (Prv_Decls); 7196 7197 -- The package lacks private declarations, but has non-empty 7198 -- visible declarations. In this case the construct to inspect 7199 -- is the last visible declaration. 7200 7201 elsif Has_Suitable_Construct (Vis_Decls) then 7202 Curr := Last (Vis_Decls); 7203 7204 -- Otherwise the package lacks any declarations. The construct 7205 -- to inspect is the node which precedes the package. Update the 7206 -- early call region to include the package declaration. 7207 7208 else 7209 Include (Curr, Curr); 7210 end if; 7211 end Enter_Package_Declaration; 7212 7213 -------------- 7214 -- Find_ECR -- 7215 -------------- 7216 7217 function Find_ECR (N : Node_Id) return Node_Id is 7218 Curr : Node_Id; 7219 7220 begin 7221 -- The early call region starts at N 7222 7223 Curr := Prev (N); 7224 Start := N; 7225 7226 -- Inspect each node in reverse declarative order while going in 7227 -- and out of nested and enclosing constructs. Note that the only 7228 -- way to terminate this infinite loop is to raise ECR_Found. 7229 7230 loop 7231 -- The current construct is not preelaboration-safe. Terminate 7232 -- the traversal. 7233 7234 if Present (Curr) 7235 and then not Is_OK_Preelaborable_Construct (Curr) 7236 then 7237 raise ECR_Found; 7238 end if; 7239 7240 -- Advance to the next suitable construct. This may terminate 7241 -- the traversal by raising ECR_Found. 7242 7243 Advance (Curr); 7244 end loop; 7245 7246 exception 7247 when ECR_Found => 7248 return Start; 7249 end Find_ECR; 7250 7251 ---------------------------- 7252 -- Has_Suitable_Construct -- 7253 ---------------------------- 7254 7255 function Has_Suitable_Construct (List : List_Id) return Boolean is 7256 Item : Node_Id; 7257 7258 begin 7259 -- Examine the list in reverse declarative order, looking for a 7260 -- suitable construct. 7261 7262 if Present (List) then 7263 Item := Last (List); 7264 while Present (Item) loop 7265 if Is_Suitable_Construct (Item) then 7266 return True; 7267 end if; 7268 7269 Prev (Item); 7270 end loop; 7271 end if; 7272 7273 return False; 7274 end Has_Suitable_Construct; 7275 7276 ------------- 7277 -- Include -- 7278 ------------- 7279 7280 procedure Include (N : Node_Id; Curr : out Node_Id) is 7281 begin 7282 Start := N; 7283 7284 -- The input node is a compilation unit. This terminates the 7285 -- search because there are no more lists to inspect and there are 7286 -- no more enclosing constructs to climb up to. The transitions 7287 -- are: 7288 -- 7289 -- private declarations -> terminate 7290 -- visible declarations -> terminate 7291 -- statements -> terminate 7292 -- declarations -> terminate 7293 7294 if Nkind (Parent (Start)) = N_Compilation_Unit then 7295 raise ECR_Found; 7296 7297 -- Otherwise the input node is still within some list 7298 7299 else 7300 Curr := Prev (Start); 7301 end if; 7302 end Include; 7303 7304 ----------------------------------- 7305 -- Is_OK_Preelaborable_Construct -- 7306 ----------------------------------- 7307 7308 function Is_OK_Preelaborable_Construct (N : Node_Id) return Boolean is 7309 begin 7310 -- Assignment statements are acceptable as long as they were 7311 -- produced by the ABE mechanism to update elaboration flags. 7312 7313 if Nkind (N) = N_Assignment_Statement then 7314 return Is_Elaboration_Code (N); 7315 7316 -- Block statements are acceptable even though they directly 7317 -- violate preelaborability. The intention is not to penalize 7318 -- the early call region when a block contains only preelaborable 7319 -- constructs. 7320 -- 7321 -- declare 7322 -- Val : constant Integer := 1; 7323 -- begin 7324 -- pragma Assert (Val = 1); 7325 -- null; 7326 -- end; 7327 -- 7328 -- Note that the Advancement phase does enter blocks, and will 7329 -- detect any non-preelaborable declarations or statements within. 7330 7331 elsif Nkind (N) = N_Block_Statement then 7332 return True; 7333 end if; 7334 7335 -- Otherwise the construct must be preelaborable. The check must 7336 -- take the syntactic and semantic structure of the construct. DO 7337 -- NOT use Is_Preelaborable_Construct here. 7338 7339 return not Is_Non_Preelaborable_Construct (N); 7340 end Is_OK_Preelaborable_Construct; 7341 7342 --------------------------- 7343 -- Is_Suitable_Construct -- 7344 --------------------------- 7345 7346 function Is_Suitable_Construct (N : Node_Id) return Boolean is 7347 Context : constant Node_Id := Parent (N); 7348 7349 begin 7350 -- An internally-generated statement sequence which contains only 7351 -- a single null statement is not a suitable construct because it 7352 -- is a byproduct of the parser. Such a null statement should be 7353 -- excluded from the early call region because it carries the 7354 -- source location of the "end" keyword, and may lead to confusing 7355 -- diagnistics. 7356 7357 if Nkind (N) = N_Null_Statement 7358 and then not Comes_From_Source (N) 7359 and then Present (Context) 7360 and then Nkind (Context) = N_Handled_Sequence_Of_Statements 7361 then 7362 return False; 7363 end if; 7364 7365 -- Otherwise only constructs which correspond to pure Ada 7366 -- constructs are considered suitable. 7367 7368 case Nkind (N) is 7369 when N_Call_Marker 7370 | N_Freeze_Entity 7371 | N_Freeze_Generic_Entity 7372 | N_Implicit_Label_Declaration 7373 | N_Itype_Reference 7374 | N_Pop_Constraint_Error_Label 7375 | N_Pop_Program_Error_Label 7376 | N_Pop_Storage_Error_Label 7377 | N_Push_Constraint_Error_Label 7378 | N_Push_Program_Error_Label 7379 | N_Push_Storage_Error_Label 7380 | N_SCIL_Dispatch_Table_Tag_Init 7381 | N_SCIL_Dispatching_Call 7382 | N_SCIL_Membership_Test 7383 | N_Variable_Reference_Marker 7384 => 7385 return False; 7386 7387 when others => 7388 return True; 7389 end case; 7390 end Is_Suitable_Construct; 7391 7392 ---------------------------------- 7393 -- Transition_Body_Declarations -- 7394 ---------------------------------- 7395 7396 procedure Transition_Body_Declarations 7397 (Bod : Node_Id; 7398 Curr : out Node_Id) 7399 is 7400 Decls : constant List_Id := Declarations (Bod); 7401 7402 begin 7403 -- The search must come from the declarations of the body 7404 7405 pragma Assert 7406 (Is_Non_Empty_List (Decls) 7407 and then List_Containing (Start) = Decls); 7408 7409 -- The search finished inspecting the declarations. The construct 7410 -- to inspect is the node which precedes the handled body, unless 7411 -- the body is a compilation unit. The transitions are: 7412 -- 7413 -- declarations -> upper level 7414 -- declarations -> corresponding package spec (Elab_Body) 7415 -- declarations -> terminate 7416 7417 Transition_Unit (Bod, Curr); 7418 end Transition_Body_Declarations; 7419 7420 ----------------------------------- 7421 -- Transition_Handled_Statements -- 7422 ----------------------------------- 7423 7424 procedure Transition_Handled_Statements 7425 (HSS : Node_Id; 7426 Curr : out Node_Id) 7427 is 7428 Bod : constant Node_Id := Parent (HSS); 7429 Decls : constant List_Id := Declarations (Bod); 7430 Stmts : constant List_Id := Statements (HSS); 7431 7432 begin 7433 -- The search must come from the statements of certain bodies or 7434 -- statements. 7435 7436 pragma Assert 7437 (Nkind (Bod) in 7438 N_Block_Statement | 7439 N_Entry_Body | 7440 N_Package_Body | 7441 N_Protected_Body | 7442 N_Subprogram_Body | 7443 N_Task_Body); 7444 7445 -- The search must come from the statements of the handled 7446 -- sequence. 7447 7448 pragma Assert 7449 (Is_Non_Empty_List (Stmts) 7450 and then List_Containing (Start) = Stmts); 7451 7452 -- The search finished inspecting the statements. The handled body 7453 -- has non-empty declarations. The construct to inspect is the 7454 -- last declaration. The transitions are: 7455 -- 7456 -- statements -> declarations 7457 7458 if Has_Suitable_Construct (Decls) then 7459 Curr := Last (Decls); 7460 7461 -- Otherwise the handled body lacks declarations. The construct to 7462 -- inspect is the node which precedes the handled body, unless the 7463 -- body is a compilation unit. The transitions are: 7464 -- 7465 -- statements -> upper level 7466 -- statements -> corresponding package spec (Elab_Body) 7467 -- statements -> terminate 7468 7469 else 7470 Transition_Unit (Bod, Curr); 7471 end if; 7472 end Transition_Handled_Statements; 7473 7474 ---------------------------------- 7475 -- Transition_Spec_Declarations -- 7476 ---------------------------------- 7477 7478 procedure Transition_Spec_Declarations 7479 (Spec : Node_Id; 7480 Curr : out Node_Id) 7481 is 7482 Prv_Decls : constant List_Id := Private_Declarations (Spec); 7483 Vis_Decls : constant List_Id := Visible_Declarations (Spec); 7484 7485 begin 7486 pragma Assert (Present (Start) and then Is_List_Member (Start)); 7487 7488 -- The search came from the private declarations and finished 7489 -- their inspection. 7490 7491 if Has_Suitable_Construct (Prv_Decls) 7492 and then List_Containing (Start) = Prv_Decls 7493 then 7494 -- The context has non-empty visible declarations. The node to 7495 -- inspect is the last visible declaration. The transitions 7496 -- are: 7497 -- 7498 -- private declarations -> visible declarations 7499 7500 if Has_Suitable_Construct (Vis_Decls) then 7501 Curr := Last (Vis_Decls); 7502 7503 -- Otherwise the context lacks visible declarations. The 7504 -- construct to inspect is the node which precedes the context 7505 -- unless the context is a compilation unit. The transitions 7506 -- are: 7507 -- 7508 -- private declarations -> upper level 7509 -- private declarations -> terminate 7510 7511 else 7512 Transition_Unit (Parent (Spec), Curr); 7513 end if; 7514 7515 -- The search came from the visible declarations and finished 7516 -- their inspections. The construct to inspect is the node which 7517 -- precedes the context, unless the context is a compilaton unit. 7518 -- The transitions are: 7519 -- 7520 -- visible declarations -> upper level 7521 -- visible declarations -> terminate 7522 7523 elsif Has_Suitable_Construct (Vis_Decls) 7524 and then List_Containing (Start) = Vis_Decls 7525 then 7526 Transition_Unit (Parent (Spec), Curr); 7527 7528 -- At this point both declarative lists are empty, but the 7529 -- traversal still came from within the spec. This indicates 7530 -- that the invariant of the algorithm has been violated. 7531 7532 else 7533 pragma Assert (False); 7534 raise ECR_Found; 7535 end if; 7536 end Transition_Spec_Declarations; 7537 7538 --------------------- 7539 -- Transition_Unit -- 7540 --------------------- 7541 7542 procedure Transition_Unit 7543 (Unit : Node_Id; 7544 Curr : out Node_Id) 7545 is 7546 Context : constant Node_Id := Parent (Unit); 7547 7548 begin 7549 -- The unit is a compilation unit. This terminates the search 7550 -- because there are no more lists to inspect and there are no 7551 -- more enclosing constructs to climb up to. 7552 7553 if Nkind (Context) = N_Compilation_Unit then 7554 7555 -- A package body with a corresponding spec subject to pragma 7556 -- Elaborate_Body is an exception to the above. The annotation 7557 -- allows the search to continue into the package declaration. 7558 -- The transitions are: 7559 -- 7560 -- statements -> corresponding package spec (Elab_Body) 7561 -- declarations -> corresponding package spec (Elab_Body) 7562 7563 if Nkind (Unit) = N_Package_Body 7564 and then (Assume_Elab_Body 7565 or else Has_Pragma_Elaborate_Body 7566 (Corresponding_Spec (Unit))) 7567 then 7568 Curr := Unit_Declaration_Node (Corresponding_Spec (Unit)); 7569 Enter_Package_Declaration (Curr); 7570 7571 -- Otherwise terminate the search. The transitions are: 7572 -- 7573 -- private declarations -> terminate 7574 -- visible declarations -> terminate 7575 -- statements -> terminate 7576 -- declarations -> terminate 7577 7578 else 7579 raise ECR_Found; 7580 end if; 7581 7582 -- The unit is a subunit. The construct to inspect is the node 7583 -- which precedes the corresponding stub. Update the early call 7584 -- region to include the unit. 7585 7586 elsif Nkind (Context) = N_Subunit then 7587 Start := Unit; 7588 Curr := Corresponding_Stub (Context); 7589 7590 -- Otherwise the unit is nested. The construct to inspect is the 7591 -- node which precedes the unit. Update the early call region to 7592 -- include the unit. 7593 7594 else 7595 Include (Unit, Curr); 7596 end if; 7597 end Transition_Unit; 7598 7599 -- Local variables 7600 7601 Body_Id : constant Entity_Id := Unique_Defining_Entity (Body_Decl); 7602 Region : Node_Id; 7603 7604 -- Start of processing for Find_Early_Call_Region 7605 7606 begin 7607 -- The caller demands the start of the early call region without 7608 -- saving or retrieving it to/from internal data structures. 7609 7610 if Skip_Memoization then 7611 Region := Find_ECR (Body_Decl); 7612 7613 -- Default behavior 7614 7615 else 7616 -- Check whether the early call region of the subprogram body is 7617 -- available. 7618 7619 Region := Early_Call_Region (Body_Id); 7620 7621 if No (Region) then 7622 Region := Find_ECR (Body_Decl); 7623 7624 -- Associate the early call region with the subprogram body in 7625 -- case other scenarios need it. 7626 7627 Set_Early_Call_Region (Body_Id, Region); 7628 end if; 7629 end if; 7630 7631 -- A subprogram body must always have an early call region 7632 7633 pragma Assert (Present (Region)); 7634 7635 return Region; 7636 end Find_Early_Call_Region; 7637 7638 -------------------------------------------- 7639 -- Initialize_Early_Call_Region_Processor -- 7640 -------------------------------------------- 7641 7642 procedure Initialize_Early_Call_Region_Processor is 7643 begin 7644 Early_Call_Regions_Map := ECR_Map.Create (100); 7645 end Initialize_Early_Call_Region_Processor; 7646 7647 --------------------------- 7648 -- Set_Early_Call_Region -- 7649 --------------------------- 7650 7651 procedure Set_Early_Call_Region (Body_Id : Entity_Id; Start : Node_Id) is 7652 pragma Assert (Present (Body_Id)); 7653 pragma Assert (Present (Start)); 7654 7655 begin 7656 ECR_Map.Put (Early_Call_Regions_Map, Body_Id, Start); 7657 end Set_Early_Call_Region; 7658 end Early_Call_Region_Processor; 7659 7660 ---------------------- 7661 -- Elaborated_Units -- 7662 ---------------------- 7663 7664 package body Elaborated_Units is 7665 7666 ----------- 7667 -- Types -- 7668 ----------- 7669 7670 -- The following type idenfities the elaboration attributes of a unit 7671 7672 type Elaboration_Attributes_Id is new Natural; 7673 7674 No_Elaboration_Attributes : constant Elaboration_Attributes_Id := 7675 Elaboration_Attributes_Id'First; 7676 First_Elaboration_Attributes : constant Elaboration_Attributes_Id := 7677 No_Elaboration_Attributes + 1; 7678 7679 -- The following type represents the elaboration attributes of a unit 7680 7681 type Elaboration_Attributes_Record is record 7682 Elab_Pragma : Node_Id := Empty; 7683 -- This attribute denotes a source Elaborate or Elaborate_All pragma 7684 -- which guarantees the prior elaboration of some unit with respect 7685 -- to the main unit. The pragma may come from the following contexts: 7686 -- 7687 -- * The main unit 7688 -- * The spec of the main unit (if applicable) 7689 -- * Any parent spec of the main unit (if applicable) 7690 -- * Any parent subunit of the main unit (if applicable) 7691 -- 7692 -- The attribute remains Empty if no such pragma is available. Source 7693 -- pragmas play a role in satisfying SPARK elaboration requirements. 7694 7695 With_Clause : Node_Id := Empty; 7696 -- This attribute denotes an internally-generated or a source with 7697 -- clause for some unit withed by the main unit. With clauses carry 7698 -- flags which represent implicit Elaborate or Elaborate_All pragmas. 7699 -- These clauses play a role in supplying elaboration dependencies to 7700 -- binde. 7701 end record; 7702 7703 --------------------- 7704 -- Data structures -- 7705 --------------------- 7706 7707 -- The following table stores all elaboration attributes 7708 7709 package Elaboration_Attributes is new Table.Table 7710 (Table_Index_Type => Elaboration_Attributes_Id, 7711 Table_Component_Type => Elaboration_Attributes_Record, 7712 Table_Low_Bound => First_Elaboration_Attributes, 7713 Table_Initial => 250, 7714 Table_Increment => 200, 7715 Table_Name => "Elaboration_Attributes"); 7716 7717 procedure Destroy (EA_Id : in out Elaboration_Attributes_Id); 7718 -- Destroy elaboration attributes EA_Id 7719 7720 package UA_Map is new Dynamic_Hash_Tables 7721 (Key_Type => Entity_Id, 7722 Value_Type => Elaboration_Attributes_Id, 7723 No_Value => No_Elaboration_Attributes, 7724 Expansion_Threshold => 1.5, 7725 Expansion_Factor => 2, 7726 Compression_Threshold => 0.3, 7727 Compression_Factor => 2, 7728 "=" => "=", 7729 Destroy_Value => Destroy, 7730 Hash => Hash); 7731 7732 -- The following map relates an elaboration attributes of a unit to the 7733 -- unit. 7734 7735 Unit_To_Attributes_Map : UA_Map.Dynamic_Hash_Table := UA_Map.Nil; 7736 7737 ------------------ 7738 -- Constructors -- 7739 ------------------ 7740 7741 function Elaboration_Attributes_Of 7742 (Unit_Id : Entity_Id) return Elaboration_Attributes_Id; 7743 pragma Inline (Elaboration_Attributes_Of); 7744 -- Obtain the elaboration attributes of unit Unit_Id 7745 7746 ----------------------- 7747 -- Local subprograms -- 7748 ----------------------- 7749 7750 function Elab_Pragma (EA_Id : Elaboration_Attributes_Id) return Node_Id; 7751 pragma Inline (Elab_Pragma); 7752 -- Obtain the Elaborate[_All] pragma of elaboration attributes EA_Id 7753 7754 procedure Ensure_Prior_Elaboration_Dynamic 7755 (N : Node_Id; 7756 Unit_Id : Entity_Id; 7757 Prag_Nam : Name_Id; 7758 In_State : Processing_In_State); 7759 pragma Inline (Ensure_Prior_Elaboration_Dynamic); 7760 -- Guarantee the elaboration of unit Unit_Id with respect to the main 7761 -- unit by suggesting the use of Elaborate[_All] with name Prag_Nam. N 7762 -- denotes the related scenario. In_State is the current state of the 7763 -- Processing phase. 7764 7765 procedure Ensure_Prior_Elaboration_Static 7766 (N : Node_Id; 7767 Unit_Id : Entity_Id; 7768 Prag_Nam : Name_Id; 7769 In_State : Processing_In_State); 7770 pragma Inline (Ensure_Prior_Elaboration_Static); 7771 -- Guarantee the elaboration of unit Unit_Id with respect to the main 7772 -- unit by installing an implicit Elaborate[_All] pragma with name 7773 -- Prag_Nam. N denotes the related scenario. In_State is the current 7774 -- state of the Processing phase. 7775 7776 function Present (EA_Id : Elaboration_Attributes_Id) return Boolean; 7777 pragma Inline (Present); 7778 -- Determine whether elaboration attributes UA_Id exist 7779 7780 procedure Set_Elab_Pragma 7781 (EA_Id : Elaboration_Attributes_Id; 7782 Prag : Node_Id); 7783 pragma Inline (Set_Elab_Pragma); 7784 -- Set the Elaborate[_All] pragma of elaboration attributes EA_Id to 7785 -- Prag. 7786 7787 procedure Set_With_Clause 7788 (EA_Id : Elaboration_Attributes_Id; 7789 Clause : Node_Id); 7790 pragma Inline (Set_With_Clause); 7791 -- Set the with clause of elaboration attributes EA_Id to Clause 7792 7793 function With_Clause (EA_Id : Elaboration_Attributes_Id) return Node_Id; 7794 pragma Inline (With_Clause); 7795 -- Obtain the implicit or source with clause of elaboration attributes 7796 -- EA_Id. 7797 7798 ------------------------------ 7799 -- Collect_Elaborated_Units -- 7800 ------------------------------ 7801 7802 procedure Collect_Elaborated_Units is 7803 procedure Add_Pragma (Prag : Node_Id); 7804 pragma Inline (Add_Pragma); 7805 -- Determine whether pragma Prag denotes a legal Elaborate[_All] 7806 -- pragma. If this is the case, add the related unit to the context. 7807 -- For pragma Elaborate_All, include recursively all units withed by 7808 -- the related unit. 7809 7810 procedure Add_Unit 7811 (Unit_Id : Entity_Id; 7812 Prag : Node_Id; 7813 Full_Context : Boolean); 7814 pragma Inline (Add_Unit); 7815 -- Add unit Unit_Id to the elaboration context. Prag denotes the 7816 -- pragma which prompted the inclusion of the unit to the context. 7817 -- If flag Full_Context is set, examine the nonlimited clauses of 7818 -- unit Unit_Id and add each withed unit to the context. 7819 7820 procedure Find_Elaboration_Context (Comp_Unit : Node_Id); 7821 pragma Inline (Find_Elaboration_Context); 7822 -- Examine the context items of compilation unit Comp_Unit for 7823 -- suitable elaboration-related pragmas and add all related units 7824 -- to the context. 7825 7826 ---------------- 7827 -- Add_Pragma -- 7828 ---------------- 7829 7830 procedure Add_Pragma (Prag : Node_Id) is 7831 Prag_Args : constant List_Id := 7832 Pragma_Argument_Associations (Prag); 7833 Prag_Nam : constant Name_Id := Pragma_Name (Prag); 7834 Unit_Arg : Node_Id; 7835 7836 begin 7837 -- Nothing to do if the pragma is not related to elaboration 7838 7839 if Prag_Nam not in Name_Elaborate | Name_Elaborate_All then 7840 return; 7841 7842 -- Nothing to do when the pragma is illegal 7843 7844 elsif Error_Posted (Prag) then 7845 return; 7846 end if; 7847 7848 Unit_Arg := Get_Pragma_Arg (First (Prag_Args)); 7849 7850 -- The argument of the pragma may appear in package.package form 7851 7852 if Nkind (Unit_Arg) = N_Selected_Component then 7853 Unit_Arg := Selector_Name (Unit_Arg); 7854 end if; 7855 7856 Add_Unit 7857 (Unit_Id => Entity (Unit_Arg), 7858 Prag => Prag, 7859 Full_Context => Prag_Nam = Name_Elaborate_All); 7860 end Add_Pragma; 7861 7862 -------------- 7863 -- Add_Unit -- 7864 -------------- 7865 7866 procedure Add_Unit 7867 (Unit_Id : Entity_Id; 7868 Prag : Node_Id; 7869 Full_Context : Boolean) 7870 is 7871 Clause : Node_Id; 7872 EA_Id : Elaboration_Attributes_Id; 7873 Unit_Prag : Node_Id; 7874 7875 begin 7876 -- Nothing to do when some previous error left a with clause or a 7877 -- pragma in a bad state. 7878 7879 if No (Unit_Id) then 7880 return; 7881 end if; 7882 7883 EA_Id := Elaboration_Attributes_Of (Unit_Id); 7884 Unit_Prag := Elab_Pragma (EA_Id); 7885 7886 -- The unit is already included in the context by means of pragma 7887 -- Elaborate[_All]. 7888 7889 if Present (Unit_Prag) then 7890 7891 -- Upgrade an existing pragma Elaborate when the unit is 7892 -- subject to Elaborate_All because the new pragma covers a 7893 -- larger set of units. 7894 7895 if Pragma_Name (Unit_Prag) = Name_Elaborate 7896 and then Pragma_Name (Prag) = Name_Elaborate_All 7897 then 7898 Set_Elab_Pragma (EA_Id, Prag); 7899 7900 -- Otherwise the unit retains its existing pragma and does not 7901 -- need to be included in the context again. 7902 7903 else 7904 return; 7905 end if; 7906 7907 -- Otherwise the current unit is not included in the context 7908 7909 else 7910 Set_Elab_Pragma (EA_Id, Prag); 7911 end if; 7912 7913 -- Includes all units withed by the current one when computing the 7914 -- full context. 7915 7916 if Full_Context then 7917 7918 -- Process all nonlimited with clauses found in the context of 7919 -- the current unit. Note that limited clauses do not impose an 7920 -- elaboration order. 7921 7922 Clause := First (Context_Items (Compilation_Unit (Unit_Id))); 7923 while Present (Clause) loop 7924 if Nkind (Clause) = N_With_Clause 7925 and then not Error_Posted (Clause) 7926 and then not Limited_Present (Clause) 7927 then 7928 Add_Unit 7929 (Unit_Id => Entity (Name (Clause)), 7930 Prag => Prag, 7931 Full_Context => Full_Context); 7932 end if; 7933 7934 Next (Clause); 7935 end loop; 7936 end if; 7937 end Add_Unit; 7938 7939 ------------------------------ 7940 -- Find_Elaboration_Context -- 7941 ------------------------------ 7942 7943 procedure Find_Elaboration_Context (Comp_Unit : Node_Id) is 7944 pragma Assert (Nkind (Comp_Unit) = N_Compilation_Unit); 7945 7946 Prag : Node_Id; 7947 7948 begin 7949 -- Process all elaboration-related pragmas found in the context of 7950 -- the compilation unit. 7951 7952 Prag := First (Context_Items (Comp_Unit)); 7953 while Present (Prag) loop 7954 if Nkind (Prag) = N_Pragma then 7955 Add_Pragma (Prag); 7956 end if; 7957 7958 Next (Prag); 7959 end loop; 7960 end Find_Elaboration_Context; 7961 7962 -- Local variables 7963 7964 Par_Id : Entity_Id; 7965 Unit_Id : Node_Id; 7966 7967 -- Start of processing for Collect_Elaborated_Units 7968 7969 begin 7970 -- Perform a traversal to examines the context of the main unit. The 7971 -- traversal performs the following jumps: 7972 -- 7973 -- subunit -> parent subunit 7974 -- parent subunit -> body 7975 -- body -> spec 7976 -- spec -> parent spec 7977 -- parent spec -> grandparent spec and so on 7978 -- 7979 -- The traversal relies on units rather than scopes because the scope 7980 -- of a subunit is some spec, while this traversal must process the 7981 -- body as well. Given that protected and task bodies can also be 7982 -- subunits, this complicates the scope approach even further. 7983 7984 Unit_Id := Unit (Cunit (Main_Unit)); 7985 7986 -- Perform the following traversals when the main unit is a subunit 7987 -- 7988 -- subunit -> parent subunit 7989 -- parent subunit -> body 7990 7991 while Present (Unit_Id) and then Nkind (Unit_Id) = N_Subunit loop 7992 Find_Elaboration_Context (Parent (Unit_Id)); 7993 7994 -- Continue the traversal by going to the unit which contains the 7995 -- corresponding stub. 7996 7997 if Present (Corresponding_Stub (Unit_Id)) then 7998 Unit_Id := 7999 Unit (Cunit (Get_Source_Unit (Corresponding_Stub (Unit_Id)))); 8000 8001 -- Otherwise the subunit may be erroneous or left in a bad state 8002 8003 else 8004 exit; 8005 end if; 8006 end loop; 8007 8008 -- Perform the following traversal now that subunits have been taken 8009 -- care of, or the main unit is a body. 8010 -- 8011 -- body -> spec 8012 8013 if Present (Unit_Id) 8014 and then Nkind (Unit_Id) in N_Package_Body | N_Subprogram_Body 8015 then 8016 Find_Elaboration_Context (Parent (Unit_Id)); 8017 8018 -- Continue the traversal by going to the unit which contains the 8019 -- corresponding spec. 8020 8021 if Present (Corresponding_Spec (Unit_Id)) then 8022 Unit_Id := 8023 Unit (Cunit (Get_Source_Unit (Corresponding_Spec (Unit_Id)))); 8024 end if; 8025 end if; 8026 8027 -- Perform the following traversals now that the body has been taken 8028 -- care of, or the main unit is a spec. 8029 -- 8030 -- spec -> parent spec 8031 -- parent spec -> grandparent spec and so on 8032 8033 if Present (Unit_Id) 8034 and then Nkind (Unit_Id) in N_Generic_Package_Declaration 8035 | N_Generic_Subprogram_Declaration 8036 | N_Package_Declaration 8037 | N_Subprogram_Declaration 8038 then 8039 Find_Elaboration_Context (Parent (Unit_Id)); 8040 8041 -- Process a potential chain of parent units which ends with the 8042 -- main unit spec. The traversal can now safely rely on the scope 8043 -- chain. 8044 8045 Par_Id := Scope (Defining_Entity (Unit_Id)); 8046 while Present (Par_Id) and then Par_Id /= Standard_Standard loop 8047 Find_Elaboration_Context (Compilation_Unit (Par_Id)); 8048 8049 Par_Id := Scope (Par_Id); 8050 end loop; 8051 end if; 8052 end Collect_Elaborated_Units; 8053 8054 ------------- 8055 -- Destroy -- 8056 ------------- 8057 8058 procedure Destroy (EA_Id : in out Elaboration_Attributes_Id) is 8059 pragma Unreferenced (EA_Id); 8060 begin 8061 null; 8062 end Destroy; 8063 8064 ----------------- 8065 -- Elab_Pragma -- 8066 ----------------- 8067 8068 function Elab_Pragma 8069 (EA_Id : Elaboration_Attributes_Id) return Node_Id 8070 is 8071 pragma Assert (Present (EA_Id)); 8072 begin 8073 return Elaboration_Attributes.Table (EA_Id).Elab_Pragma; 8074 end Elab_Pragma; 8075 8076 ------------------------------- 8077 -- Elaboration_Attributes_Of -- 8078 ------------------------------- 8079 8080 function Elaboration_Attributes_Of 8081 (Unit_Id : Entity_Id) return Elaboration_Attributes_Id 8082 is 8083 EA_Id : Elaboration_Attributes_Id; 8084 8085 begin 8086 EA_Id := UA_Map.Get (Unit_To_Attributes_Map, Unit_Id); 8087 8088 -- The unit lacks elaboration attributes. This indicates that the 8089 -- unit is encountered for the first time. Create the elaboration 8090 -- attributes for it. 8091 8092 if not Present (EA_Id) then 8093 Elaboration_Attributes.Append 8094 ((Elab_Pragma => Empty, 8095 With_Clause => Empty)); 8096 EA_Id := Elaboration_Attributes.Last; 8097 8098 -- Associate the elaboration attributes with the unit 8099 8100 UA_Map.Put (Unit_To_Attributes_Map, Unit_Id, EA_Id); 8101 end if; 8102 8103 pragma Assert (Present (EA_Id)); 8104 8105 return EA_Id; 8106 end Elaboration_Attributes_Of; 8107 8108 ------------------------------ 8109 -- Ensure_Prior_Elaboration -- 8110 ------------------------------ 8111 8112 procedure Ensure_Prior_Elaboration 8113 (N : Node_Id; 8114 Unit_Id : Entity_Id; 8115 Prag_Nam : Name_Id; 8116 In_State : Processing_In_State) 8117 is 8118 pragma Assert (Prag_Nam in Name_Elaborate | Name_Elaborate_All); 8119 8120 begin 8121 -- Nothing to do when the need for prior elaboration came from a 8122 -- partial finalization routine which occurs in an initialization 8123 -- context. This behavior parallels that of the old ABE mechanism. 8124 8125 if In_State.Within_Partial_Finalization then 8126 return; 8127 8128 -- Nothing to do when the need for prior elaboration came from a task 8129 -- body and switch -gnatd.y (disable implicit pragma Elaborate_All on 8130 -- task bodies) is in effect. 8131 8132 elsif Debug_Flag_Dot_Y and then In_State.Within_Task_Body then 8133 return; 8134 8135 -- Nothing to do when the unit is elaborated prior to the main unit. 8136 -- This check must also consider the following cases: 8137 -- 8138 -- * No check is made against the context of the main unit because 8139 -- this is specific to the elaboration model in effect and requires 8140 -- custom handling (see Ensure_xxx_Prior_Elaboration). 8141 -- 8142 -- * Unit_Id is subject to pragma Elaborate_Body. An implicit pragma 8143 -- Elaborate[_All] MUST be generated even though Unit_Id is always 8144 -- elaborated prior to the main unit. This conservative strategy 8145 -- ensures that other units withed by Unit_Id will not lead to an 8146 -- ABE. 8147 -- 8148 -- package A is package body A is 8149 -- procedure ABE; procedure ABE is ... end ABE; 8150 -- end A; end A; 8151 -- 8152 -- with A; 8153 -- package B is package body B is 8154 -- pragma Elaborate_Body; procedure Proc is 8155 -- begin 8156 -- procedure Proc; A.ABE; 8157 -- package B; end Proc; 8158 -- end B; 8159 -- 8160 -- with B; 8161 -- package C is package body C is 8162 -- ... ... 8163 -- end C; begin 8164 -- B.Proc; 8165 -- end C; 8166 -- 8167 -- In the example above, the elaboration of C invokes B.Proc. B is 8168 -- subject to pragma Elaborate_Body. If no pragma Elaborate[_All] 8169 -- is gnerated for B in C, then the following elaboratio order will 8170 -- lead to an ABE: 8171 -- 8172 -- spec of A elaborated 8173 -- spec of B elaborated 8174 -- body of B elaborated 8175 -- spec of C elaborated 8176 -- body of C elaborated <-- calls B.Proc which calls A.ABE 8177 -- body of A elaborated <-- problem 8178 -- 8179 -- The generation of an implicit pragma Elaborate_All (B) ensures 8180 -- that the elaboration-order mechanism will not pick the above 8181 -- order. 8182 -- 8183 -- An implicit Elaborate is NOT generated when the unit is subject 8184 -- to Elaborate_Body because both pragmas have the same effect. 8185 -- 8186 -- * Unit_Id is the main unit. An implicit pragma Elaborate[_All] 8187 -- MUST NOT be generated in this case because a unit cannot depend 8188 -- on its own elaboration. This case is therefore treated as valid 8189 -- prior elaboration. 8190 8191 elsif Has_Prior_Elaboration 8192 (Unit_Id => Unit_Id, 8193 Same_Unit_OK => True, 8194 Elab_Body_OK => Prag_Nam = Name_Elaborate) 8195 then 8196 return; 8197 end if; 8198 8199 -- Suggest the use of pragma Prag_Nam when the dynamic model is in 8200 -- effect. 8201 8202 if Dynamic_Elaboration_Checks then 8203 Ensure_Prior_Elaboration_Dynamic 8204 (N => N, 8205 Unit_Id => Unit_Id, 8206 Prag_Nam => Prag_Nam, 8207 In_State => In_State); 8208 8209 -- Install an implicit pragma Prag_Nam when the static model is in 8210 -- effect. 8211 8212 else 8213 pragma Assert (Static_Elaboration_Checks); 8214 8215 Ensure_Prior_Elaboration_Static 8216 (N => N, 8217 Unit_Id => Unit_Id, 8218 Prag_Nam => Prag_Nam, 8219 In_State => In_State); 8220 end if; 8221 end Ensure_Prior_Elaboration; 8222 8223 -------------------------------------- 8224 -- Ensure_Prior_Elaboration_Dynamic -- 8225 -------------------------------------- 8226 8227 procedure Ensure_Prior_Elaboration_Dynamic 8228 (N : Node_Id; 8229 Unit_Id : Entity_Id; 8230 Prag_Nam : Name_Id; 8231 In_State : Processing_In_State) 8232 is 8233 procedure Info_Missing_Pragma; 8234 pragma Inline (Info_Missing_Pragma); 8235 -- Output information concerning missing Elaborate or Elaborate_All 8236 -- pragma with name Prag_Nam for scenario N, which would ensure the 8237 -- prior elaboration of Unit_Id. 8238 8239 ------------------------- 8240 -- Info_Missing_Pragma -- 8241 ------------------------- 8242 8243 procedure Info_Missing_Pragma is 8244 begin 8245 -- Internal units are ignored as they cause unnecessary noise 8246 8247 if not In_Internal_Unit (Unit_Id) then 8248 8249 -- The name of the unit subjected to the elaboration pragma is 8250 -- fully qualified to improve the clarity of the info message. 8251 8252 Error_Msg_Name_1 := Prag_Nam; 8253 Error_Msg_Qual_Level := Nat'Last; 8254 8255 Error_Msg_NE ("info: missing pragma % for unit &", N, Unit_Id); 8256 Error_Msg_Qual_Level := 0; 8257 end if; 8258 end Info_Missing_Pragma; 8259 8260 -- Local variables 8261 8262 EA_Id : constant Elaboration_Attributes_Id := 8263 Elaboration_Attributes_Of (Unit_Id); 8264 N_Lvl : Enclosing_Level_Kind; 8265 N_Rep : Scenario_Rep_Id; 8266 8267 -- Start of processing for Ensure_Prior_Elaboration_Dynamic 8268 8269 begin 8270 -- Nothing to do when the unit is guaranteed prior elaboration by 8271 -- means of a source Elaborate[_All] pragma. 8272 8273 if Present (Elab_Pragma (EA_Id)) then 8274 return; 8275 end if; 8276 8277 -- Output extra information on a missing Elaborate[_All] pragma when 8278 -- switch -gnatel (info messages on implicit Elaborate[_All] pragmas 8279 -- is in effect. 8280 8281 if Elab_Info_Messages 8282 and then not In_State.Suppress_Info_Messages 8283 then 8284 N_Rep := Scenario_Representation_Of (N, In_State); 8285 N_Lvl := Level (N_Rep); 8286 8287 -- Declaration-level scenario 8288 8289 if (Is_Suitable_Call (N) or else Is_Suitable_Instantiation (N)) 8290 and then N_Lvl = Declaration_Level 8291 then 8292 null; 8293 8294 -- Library-level scenario 8295 8296 elsif N_Lvl in Library_Level then 8297 null; 8298 8299 -- Instantiation library-level scenario 8300 8301 elsif N_Lvl = Instantiation_Level then 8302 null; 8303 8304 -- Otherwise the scenario does not appear at the proper level 8305 8306 else 8307 return; 8308 end if; 8309 8310 Info_Missing_Pragma; 8311 end if; 8312 end Ensure_Prior_Elaboration_Dynamic; 8313 8314 ------------------------------------- 8315 -- Ensure_Prior_Elaboration_Static -- 8316 ------------------------------------- 8317 8318 procedure Ensure_Prior_Elaboration_Static 8319 (N : Node_Id; 8320 Unit_Id : Entity_Id; 8321 Prag_Nam : Name_Id; 8322 In_State : Processing_In_State) 8323 is 8324 function Find_With_Clause 8325 (Items : List_Id; 8326 Withed_Id : Entity_Id) return Node_Id; 8327 pragma Inline (Find_With_Clause); 8328 -- Find a nonlimited with clause in the list of context items Items 8329 -- that withs unit Withed_Id. Return Empty if no such clause exists. 8330 8331 procedure Info_Implicit_Pragma; 8332 pragma Inline (Info_Implicit_Pragma); 8333 -- Output information concerning an implicitly generated Elaborate 8334 -- or Elaborate_All pragma with name Prag_Nam for scenario N which 8335 -- ensures the prior elaboration of unit Unit_Id. 8336 8337 ---------------------- 8338 -- Find_With_Clause -- 8339 ---------------------- 8340 8341 function Find_With_Clause 8342 (Items : List_Id; 8343 Withed_Id : Entity_Id) return Node_Id 8344 is 8345 Item : Node_Id; 8346 8347 begin 8348 -- Examine the context clauses looking for a suitable with. Note 8349 -- that limited clauses do not affect the elaboration order. 8350 8351 Item := First (Items); 8352 while Present (Item) loop 8353 if Nkind (Item) = N_With_Clause 8354 and then not Error_Posted (Item) 8355 and then not Limited_Present (Item) 8356 and then Entity (Name (Item)) = Withed_Id 8357 then 8358 return Item; 8359 end if; 8360 8361 Next (Item); 8362 end loop; 8363 8364 return Empty; 8365 end Find_With_Clause; 8366 8367 -------------------------- 8368 -- Info_Implicit_Pragma -- 8369 -------------------------- 8370 8371 procedure Info_Implicit_Pragma is 8372 begin 8373 -- Internal units are ignored as they cause unnecessary noise 8374 8375 if not In_Internal_Unit (Unit_Id) then 8376 8377 -- The name of the unit subjected to the elaboration pragma is 8378 -- fully qualified to improve the clarity of the info message. 8379 8380 Error_Msg_Name_1 := Prag_Nam; 8381 Error_Msg_Qual_Level := Nat'Last; 8382 8383 Error_Msg_NE 8384 ("info: implicit pragma % generated for unit &", N, Unit_Id); 8385 8386 Error_Msg_Qual_Level := 0; 8387 Output_Active_Scenarios (N, In_State); 8388 end if; 8389 end Info_Implicit_Pragma; 8390 8391 -- Local variables 8392 8393 EA_Id : constant Elaboration_Attributes_Id := 8394 Elaboration_Attributes_Of (Unit_Id); 8395 8396 Main_Cunit : constant Node_Id := Cunit (Main_Unit); 8397 Loc : constant Source_Ptr := Sloc (Main_Cunit); 8398 Unit_Cunit : constant Node_Id := Compilation_Unit (Unit_Id); 8399 Unit_Prag : constant Node_Id := Elab_Pragma (EA_Id); 8400 Unit_With : constant Node_Id := With_Clause (EA_Id); 8401 8402 Clause : Node_Id; 8403 Items : List_Id; 8404 8405 -- Start of processing for Ensure_Prior_Elaboration_Static 8406 8407 begin 8408 -- Nothing to do when the caller has suppressed the generation of 8409 -- implicit Elaborate[_All] pragmas. 8410 8411 if In_State.Suppress_Implicit_Pragmas then 8412 return; 8413 8414 -- Nothing to do when the unit is guaranteed prior elaboration by 8415 -- means of a source Elaborate[_All] pragma. 8416 8417 elsif Present (Unit_Prag) then 8418 return; 8419 8420 -- Nothing to do when the unit has an existing implicit Elaborate or 8421 -- Elaborate_All pragma installed by a previous scenario. 8422 8423 elsif Present (Unit_With) then 8424 8425 -- The unit is already guaranteed prior elaboration by means of an 8426 -- implicit Elaborate pragma, however the current scenario imposes 8427 -- a stronger requirement of Elaborate_All. "Upgrade" the existing 8428 -- pragma to match this new requirement. 8429 8430 if Elaborate_Desirable (Unit_With) 8431 and then Prag_Nam = Name_Elaborate_All 8432 then 8433 Set_Elaborate_All_Desirable (Unit_With); 8434 Set_Elaborate_Desirable (Unit_With, False); 8435 end if; 8436 8437 return; 8438 end if; 8439 8440 -- At this point it is known that the unit has no prior elaboration 8441 -- according to pragmas and hierarchical relationships. 8442 8443 Items := Context_Items (Main_Cunit); 8444 8445 if No (Items) then 8446 Items := New_List; 8447 Set_Context_Items (Main_Cunit, Items); 8448 end if; 8449 8450 -- Locate the with clause for the unit. Note that there may not be a 8451 -- clause if the unit is visible through a subunit-body, body-spec, 8452 -- or spec-parent relationship. 8453 8454 Clause := 8455 Find_With_Clause 8456 (Items => Items, 8457 Withed_Id => Unit_Id); 8458 8459 -- Generate: 8460 -- with Id; 8461 8462 -- Note that adding implicit with clauses is safe because analysis, 8463 -- resolution, and expansion have already taken place and it is not 8464 -- possible to interfere with visibility. 8465 8466 if No (Clause) then 8467 Clause := 8468 Make_With_Clause (Loc, 8469 Name => New_Occurrence_Of (Unit_Id, Loc)); 8470 8471 Set_Implicit_With (Clause); 8472 Set_Library_Unit (Clause, Unit_Cunit); 8473 8474 Append_To (Items, Clause); 8475 end if; 8476 8477 -- Mark the with clause depending on the pragma required 8478 8479 if Prag_Nam = Name_Elaborate then 8480 Set_Elaborate_Desirable (Clause); 8481 else 8482 Set_Elaborate_All_Desirable (Clause); 8483 end if; 8484 8485 -- The implicit Elaborate[_All] ensures the prior elaboration of 8486 -- the unit. Include the unit in the elaboration context of the 8487 -- main unit. 8488 8489 Set_With_Clause (EA_Id, Clause); 8490 8491 -- Output extra information on an implicit Elaborate[_All] pragma 8492 -- when switch -gnatel (info messages on implicit Elaborate[_All] 8493 -- pragmas is in effect. 8494 8495 if Elab_Info_Messages then 8496 Info_Implicit_Pragma; 8497 end if; 8498 end Ensure_Prior_Elaboration_Static; 8499 8500 ------------------------------- 8501 -- Finalize_Elaborated_Units -- 8502 ------------------------------- 8503 8504 procedure Finalize_Elaborated_Units is 8505 begin 8506 UA_Map.Destroy (Unit_To_Attributes_Map); 8507 end Finalize_Elaborated_Units; 8508 8509 --------------------------- 8510 -- Has_Prior_Elaboration -- 8511 --------------------------- 8512 8513 function Has_Prior_Elaboration 8514 (Unit_Id : Entity_Id; 8515 Context_OK : Boolean := False; 8516 Elab_Body_OK : Boolean := False; 8517 Same_Unit_OK : Boolean := False) return Boolean 8518 is 8519 EA_Id : constant Elaboration_Attributes_Id := 8520 Elaboration_Attributes_Of (Unit_Id); 8521 Main_Id : constant Entity_Id := Main_Unit_Entity; 8522 Unit_Prag : constant Node_Id := Elab_Pragma (EA_Id); 8523 Unit_With : constant Node_Id := With_Clause (EA_Id); 8524 8525 begin 8526 -- A preelaborated unit is always elaborated prior to the main unit 8527 8528 if Is_Preelaborated_Unit (Unit_Id) then 8529 return True; 8530 8531 -- An internal unit is always elaborated prior to a non-internal main 8532 -- unit. 8533 8534 elsif In_Internal_Unit (Unit_Id) 8535 and then not In_Internal_Unit (Main_Id) 8536 then 8537 return True; 8538 8539 -- A unit has prior elaboration if it appears within the context 8540 -- of the main unit. Consider this case only when requested by the 8541 -- caller. 8542 8543 elsif Context_OK 8544 and then (Present (Unit_Prag) or else Present (Unit_With)) 8545 then 8546 return True; 8547 8548 -- A unit whose body is elaborated together with its spec has prior 8549 -- elaboration except with respect to itself. Consider this case only 8550 -- when requested by the caller. 8551 8552 elsif Elab_Body_OK 8553 and then Has_Pragma_Elaborate_Body (Unit_Id) 8554 and then not Is_Same_Unit (Unit_Id, Main_Id) 8555 then 8556 return True; 8557 8558 -- A unit has no prior elaboration with respect to itself, but does 8559 -- not require any means of ensuring its own elaboration either. 8560 -- Treat this case as valid prior elaboration only when requested by 8561 -- the caller. 8562 8563 elsif Same_Unit_OK and then Is_Same_Unit (Unit_Id, Main_Id) then 8564 return True; 8565 end if; 8566 8567 return False; 8568 end Has_Prior_Elaboration; 8569 8570 --------------------------------- 8571 -- Initialize_Elaborated_Units -- 8572 --------------------------------- 8573 8574 procedure Initialize_Elaborated_Units is 8575 begin 8576 Unit_To_Attributes_Map := UA_Map.Create (250); 8577 end Initialize_Elaborated_Units; 8578 8579 ---------------------------------- 8580 -- Meet_Elaboration_Requirement -- 8581 ---------------------------------- 8582 8583 procedure Meet_Elaboration_Requirement 8584 (N : Node_Id; 8585 Targ_Id : Entity_Id; 8586 Req_Nam : Name_Id; 8587 In_State : Processing_In_State) 8588 is 8589 pragma Assert (Req_Nam in Name_Elaborate | Name_Elaborate_All); 8590 8591 Main_Id : constant Entity_Id := Main_Unit_Entity; 8592 Unit_Id : constant Entity_Id := Find_Top_Unit (Targ_Id); 8593 8594 procedure Elaboration_Requirement_Error; 8595 pragma Inline (Elaboration_Requirement_Error); 8596 -- Emit an error concerning scenario N which has failed to meet the 8597 -- elaboration requirement. 8598 8599 function Find_Preelaboration_Pragma 8600 (Prag_Nam : Name_Id) return Node_Id; 8601 pragma Inline (Find_Preelaboration_Pragma); 8602 -- Traverse the visible declarations of unit Unit_Id and locate a 8603 -- source preelaboration-related pragma with name Prag_Nam. 8604 8605 procedure Info_Requirement_Met (Prag : Node_Id); 8606 pragma Inline (Info_Requirement_Met); 8607 -- Output information concerning pragma Prag which meets requirement 8608 -- Req_Nam. 8609 8610 ----------------------------------- 8611 -- Elaboration_Requirement_Error -- 8612 ----------------------------------- 8613 8614 procedure Elaboration_Requirement_Error is 8615 begin 8616 if Is_Suitable_Call (N) then 8617 Info_Call 8618 (Call => N, 8619 Subp_Id => Targ_Id, 8620 Info_Msg => False, 8621 In_SPARK => True); 8622 8623 elsif Is_Suitable_Instantiation (N) then 8624 Info_Instantiation 8625 (Inst => N, 8626 Gen_Id => Targ_Id, 8627 Info_Msg => False, 8628 In_SPARK => True); 8629 8630 elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then 8631 Error_Msg_N 8632 ("read of refinement constituents during elaboration in " 8633 & "SPARK", N); 8634 8635 elsif Is_Suitable_Variable_Reference (N) then 8636 Info_Variable_Reference 8637 (Ref => N, 8638 Var_Id => Targ_Id, 8639 Info_Msg => False, 8640 In_SPARK => True); 8641 8642 -- No other scenario may impose a requirement on the context of 8643 -- the main unit. 8644 8645 else 8646 pragma Assert (False); 8647 return; 8648 end if; 8649 8650 Error_Msg_Name_1 := Req_Nam; 8651 Error_Msg_Node_2 := Unit_Id; 8652 Error_Msg_NE ("\\unit & requires pragma % for &", N, Main_Id); 8653 8654 Output_Active_Scenarios (N, In_State); 8655 end Elaboration_Requirement_Error; 8656 8657 -------------------------------- 8658 -- Find_Preelaboration_Pragma -- 8659 -------------------------------- 8660 8661 function Find_Preelaboration_Pragma 8662 (Prag_Nam : Name_Id) return Node_Id 8663 is 8664 Spec : constant Node_Id := Parent (Unit_Id); 8665 Decl : Node_Id; 8666 8667 begin 8668 -- A preelaboration-related pragma comes from source and appears 8669 -- at the top of the visible declarations of a package. 8670 8671 if Nkind (Spec) = N_Package_Specification then 8672 Decl := First (Visible_Declarations (Spec)); 8673 while Present (Decl) loop 8674 if Comes_From_Source (Decl) then 8675 if Nkind (Decl) = N_Pragma 8676 and then Pragma_Name (Decl) = Prag_Nam 8677 then 8678 return Decl; 8679 8680 -- Otherwise the construct terminates the region where 8681 -- the preelaboration-related pragma may appear. 8682 8683 else 8684 exit; 8685 end if; 8686 end if; 8687 8688 Next (Decl); 8689 end loop; 8690 end if; 8691 8692 return Empty; 8693 end Find_Preelaboration_Pragma; 8694 8695 -------------------------- 8696 -- Info_Requirement_Met -- 8697 -------------------------- 8698 8699 procedure Info_Requirement_Met (Prag : Node_Id) is 8700 pragma Assert (Present (Prag)); 8701 8702 begin 8703 Error_Msg_Name_1 := Req_Nam; 8704 Error_Msg_Sloc := Sloc (Prag); 8705 Error_Msg_NE 8706 ("\\% requirement for unit & met by pragma #", N, Unit_Id); 8707 end Info_Requirement_Met; 8708 8709 -- Local variables 8710 8711 EA_Id : Elaboration_Attributes_Id; 8712 Elab_Nam : Name_Id; 8713 Req_Met : Boolean; 8714 Unit_Prag : Node_Id; 8715 8716 -- Start of processing for Meet_Elaboration_Requirement 8717 8718 begin 8719 -- Assume that the requirement has not been met 8720 8721 Req_Met := False; 8722 8723 -- If the target is within the main unit, either at the source level 8724 -- or through an instantiation, then there is no real requirement to 8725 -- meet because the main unit cannot force its own elaboration by 8726 -- means of an Elaborate[_All] pragma. Treat this case as valid 8727 -- coverage. 8728 8729 if In_Extended_Main_Code_Unit (Targ_Id) then 8730 Req_Met := True; 8731 8732 -- Otherwise the target resides in an external unit 8733 8734 -- The requirement is met when the target comes from an internal unit 8735 -- because such a unit is elaborated prior to a non-internal unit. 8736 8737 elsif In_Internal_Unit (Unit_Id) 8738 and then not In_Internal_Unit (Main_Id) 8739 then 8740 Req_Met := True; 8741 8742 -- The requirement is met when the target comes from a preelaborated 8743 -- unit. This portion must parallel predicate Is_Preelaborated_Unit. 8744 8745 elsif Is_Preelaborated_Unit (Unit_Id) then 8746 Req_Met := True; 8747 8748 -- Output extra information when switch -gnatel (info messages on 8749 -- implicit Elaborate[_All] pragmas. 8750 8751 if Elab_Info_Messages 8752 and then not In_State.Suppress_Info_Messages 8753 then 8754 if Is_Preelaborated (Unit_Id) then 8755 Elab_Nam := Name_Preelaborate; 8756 8757 elsif Is_Pure (Unit_Id) then 8758 Elab_Nam := Name_Pure; 8759 8760 elsif Is_Remote_Call_Interface (Unit_Id) then 8761 Elab_Nam := Name_Remote_Call_Interface; 8762 8763 elsif Is_Remote_Types (Unit_Id) then 8764 Elab_Nam := Name_Remote_Types; 8765 8766 else 8767 pragma Assert (Is_Shared_Passive (Unit_Id)); 8768 Elab_Nam := Name_Shared_Passive; 8769 end if; 8770 8771 Info_Requirement_Met (Find_Preelaboration_Pragma (Elab_Nam)); 8772 end if; 8773 8774 -- Determine whether the context of the main unit has a pragma strong 8775 -- enough to meet the requirement. 8776 8777 else 8778 EA_Id := Elaboration_Attributes_Of (Unit_Id); 8779 Unit_Prag := Elab_Pragma (EA_Id); 8780 8781 -- The pragma must be either Elaborate_All or be as strong as the 8782 -- requirement. 8783 8784 if Present (Unit_Prag) 8785 and then Pragma_Name (Unit_Prag) in Name_Elaborate_All | Req_Nam 8786 then 8787 Req_Met := True; 8788 8789 -- Output extra information when switch -gnatel (info messages 8790 -- on implicit Elaborate[_All] pragmas. 8791 8792 if Elab_Info_Messages 8793 and then not In_State.Suppress_Info_Messages 8794 then 8795 Info_Requirement_Met (Unit_Prag); 8796 end if; 8797 end if; 8798 end if; 8799 8800 -- The requirement was not met by the context of the main unit, issue 8801 -- an error. 8802 8803 if not Req_Met then 8804 Elaboration_Requirement_Error; 8805 end if; 8806 end Meet_Elaboration_Requirement; 8807 8808 ------------- 8809 -- Present -- 8810 ------------- 8811 8812 function Present (EA_Id : Elaboration_Attributes_Id) return Boolean is 8813 begin 8814 return EA_Id /= No_Elaboration_Attributes; 8815 end Present; 8816 8817 --------------------- 8818 -- Set_Elab_Pragma -- 8819 --------------------- 8820 8821 procedure Set_Elab_Pragma 8822 (EA_Id : Elaboration_Attributes_Id; 8823 Prag : Node_Id) 8824 is 8825 pragma Assert (Present (EA_Id)); 8826 begin 8827 Elaboration_Attributes.Table (EA_Id).Elab_Pragma := Prag; 8828 end Set_Elab_Pragma; 8829 8830 --------------------- 8831 -- Set_With_Clause -- 8832 --------------------- 8833 8834 procedure Set_With_Clause 8835 (EA_Id : Elaboration_Attributes_Id; 8836 Clause : Node_Id) 8837 is 8838 pragma Assert (Present (EA_Id)); 8839 begin 8840 Elaboration_Attributes.Table (EA_Id).With_Clause := Clause; 8841 end Set_With_Clause; 8842 8843 ----------------- 8844 -- With_Clause -- 8845 ----------------- 8846 8847 function With_Clause 8848 (EA_Id : Elaboration_Attributes_Id) return Node_Id 8849 is 8850 pragma Assert (Present (EA_Id)); 8851 begin 8852 return Elaboration_Attributes.Table (EA_Id).With_Clause; 8853 end With_Clause; 8854 end Elaborated_Units; 8855 8856 ------------------------------ 8857 -- Elaboration_Phase_Active -- 8858 ------------------------------ 8859 8860 function Elaboration_Phase_Active return Boolean is 8861 begin 8862 return Elaboration_Phase = Active; 8863 end Elaboration_Phase_Active; 8864 8865 ------------------------------ 8866 -- Error_Preelaborated_Call -- 8867 ------------------------------ 8868 8869 procedure Error_Preelaborated_Call (N : Node_Id) is 8870 begin 8871 -- This is a warning in GNAT mode allowing such calls to be used in the 8872 -- predefined library units with appropriate care. 8873 8874 Error_Msg_Warn := GNAT_Mode; 8875 8876 -- Ada 2020 (AI12-0175): Calls to certain functions that are essentially 8877 -- unchecked conversions are preelaborable. 8878 8879 if Ada_Version >= Ada_2020 then 8880 Error_Msg_N 8881 ("<<non-preelaborable call not allowed in preelaborated unit", N); 8882 else 8883 Error_Msg_N 8884 ("<<non-static call not allowed in preelaborated unit", N); 8885 end if; 8886 end Error_Preelaborated_Call; 8887 8888 ---------------------------------- 8889 -- Finalize_All_Data_Structures -- 8890 ---------------------------------- 8891 8892 procedure Finalize_All_Data_Structures is 8893 begin 8894 Finalize_Body_Processor; 8895 Finalize_Early_Call_Region_Processor; 8896 Finalize_Elaborated_Units; 8897 Finalize_Internal_Representation; 8898 Finalize_Invocation_Graph; 8899 Finalize_Scenario_Storage; 8900 end Finalize_All_Data_Structures; 8901 8902 ----------------------------- 8903 -- Find_Enclosing_Instance -- 8904 ----------------------------- 8905 8906 function Find_Enclosing_Instance (N : Node_Id) return Node_Id is 8907 Par : Node_Id; 8908 8909 begin 8910 -- Climb the parent chain looking for an enclosing instance spec or body 8911 8912 Par := N; 8913 while Present (Par) loop 8914 if Nkind (Par) in N_Package_Body 8915 | N_Package_Declaration 8916 | N_Subprogram_Body 8917 | N_Subprogram_Declaration 8918 and then Is_Generic_Instance (Unique_Defining_Entity (Par)) 8919 then 8920 return Par; 8921 end if; 8922 8923 Par := Parent (Par); 8924 end loop; 8925 8926 return Empty; 8927 end Find_Enclosing_Instance; 8928 8929 -------------------------- 8930 -- Find_Enclosing_Level -- 8931 -------------------------- 8932 8933 function Find_Enclosing_Level (N : Node_Id) return Enclosing_Level_Kind is 8934 function Level_Of (Unit : Node_Id) return Enclosing_Level_Kind; 8935 pragma Inline (Level_Of); 8936 -- Obtain the corresponding level of unit Unit 8937 8938 -------------- 8939 -- Level_Of -- 8940 -------------- 8941 8942 function Level_Of (Unit : Node_Id) return Enclosing_Level_Kind is 8943 Spec_Id : Entity_Id; 8944 8945 begin 8946 if Nkind (Unit) in N_Generic_Instantiation then 8947 return Instantiation_Level; 8948 8949 elsif Nkind (Unit) = N_Generic_Package_Declaration then 8950 return Generic_Spec_Level; 8951 8952 elsif Nkind (Unit) = N_Package_Declaration then 8953 return Library_Spec_Level; 8954 8955 elsif Nkind (Unit) = N_Package_Body then 8956 Spec_Id := Corresponding_Spec (Unit); 8957 8958 -- The body belongs to a generic package 8959 8960 if Present (Spec_Id) 8961 and then Ekind (Spec_Id) = E_Generic_Package 8962 then 8963 return Generic_Body_Level; 8964 8965 -- Otherwise the body belongs to a non-generic package. This also 8966 -- treats an illegal package body without a corresponding spec as 8967 -- a non-generic package body. 8968 8969 else 8970 return Library_Body_Level; 8971 end if; 8972 end if; 8973 8974 return No_Level; 8975 end Level_Of; 8976 8977 -- Local variables 8978 8979 Context : Node_Id; 8980 Curr : Node_Id; 8981 Prev : Node_Id; 8982 8983 -- Start of processing for Find_Enclosing_Level 8984 8985 begin 8986 -- Call markers and instantiations which appear at the declaration level 8987 -- but are later relocated in a different context retain their original 8988 -- declaration level. 8989 8990 if Nkind (N) in N_Call_Marker 8991 | N_Function_Instantiation 8992 | N_Package_Instantiation 8993 | N_Procedure_Instantiation 8994 and then Is_Declaration_Level_Node (N) 8995 then 8996 return Declaration_Level; 8997 end if; 8998 8999 -- Climb the parent chain looking at the enclosing levels 9000 9001 Prev := N; 9002 Curr := Parent (Prev); 9003 while Present (Curr) loop 9004 9005 -- A traversal from a subunit continues via the corresponding stub 9006 9007 if Nkind (Curr) = N_Subunit then 9008 Curr := Corresponding_Stub (Curr); 9009 9010 -- The current construct is a package. Packages are ignored because 9011 -- they are always elaborated when the enclosing context is invoked 9012 -- or elaborated. 9013 9014 elsif Nkind (Curr) in N_Package_Body | N_Package_Declaration then 9015 null; 9016 9017 -- The current construct is a block statement 9018 9019 elsif Nkind (Curr) = N_Block_Statement then 9020 9021 -- Ignore internally generated blocks created by the expander for 9022 -- various purposes such as abort defer/undefer. 9023 9024 if not Comes_From_Source (Curr) then 9025 null; 9026 9027 -- If the traversal came from the handled sequence of statments, 9028 -- then the node appears at the level of the enclosing construct. 9029 -- This is a more reliable test because transients scopes within 9030 -- the declarative region of the encapsulator are hard to detect. 9031 9032 elsif Nkind (Prev) = N_Handled_Sequence_Of_Statements 9033 and then Handled_Statement_Sequence (Curr) = Prev 9034 then 9035 return Find_Enclosing_Level (Parent (Curr)); 9036 9037 -- Otherwise the traversal came from the declarations, the node is 9038 -- at the declaration level. 9039 9040 else 9041 return Declaration_Level; 9042 end if; 9043 9044 -- The current construct is a declaration-level encapsulator 9045 9046 elsif Nkind (Curr) in 9047 N_Entry_Body | N_Subprogram_Body | N_Task_Body 9048 then 9049 -- If the traversal came from the handled sequence of statments, 9050 -- then the node cannot possibly appear at any level. This is 9051 -- a more reliable test because transients scopes within the 9052 -- declarative region of the encapsulator are hard to detect. 9053 9054 if Nkind (Prev) = N_Handled_Sequence_Of_Statements 9055 and then Handled_Statement_Sequence (Curr) = Prev 9056 then 9057 return No_Level; 9058 9059 -- Otherwise the traversal came from the declarations, the node is 9060 -- at the declaration level. 9061 9062 else 9063 return Declaration_Level; 9064 end if; 9065 9066 -- The current construct is a non-library-level encapsulator which 9067 -- indicates that the node cannot possibly appear at any level. Note 9068 -- that the check must come after the declaration-level check because 9069 -- both predicates share certain nodes. 9070 9071 elsif Is_Non_Library_Level_Encapsulator (Curr) then 9072 Context := Parent (Curr); 9073 9074 -- The sole exception is when the encapsulator is the compilation 9075 -- utit itself because the compilation unit node requires special 9076 -- processing (see below). 9077 9078 if Present (Context) 9079 and then Nkind (Context) = N_Compilation_Unit 9080 then 9081 null; 9082 9083 -- Otherwise the node is not at any level 9084 9085 else 9086 return No_Level; 9087 end if; 9088 9089 -- The current construct is a compilation unit. The node appears at 9090 -- the [generic] library level when the unit is a [generic] package. 9091 9092 elsif Nkind (Curr) = N_Compilation_Unit then 9093 return Level_Of (Unit (Curr)); 9094 end if; 9095 9096 Prev := Curr; 9097 Curr := Parent (Prev); 9098 end loop; 9099 9100 return No_Level; 9101 end Find_Enclosing_Level; 9102 9103 ------------------- 9104 -- Find_Top_Unit -- 9105 ------------------- 9106 9107 function Find_Top_Unit (N : Node_Or_Entity_Id) return Entity_Id is 9108 begin 9109 return Find_Unit_Entity (Unit (Cunit (Get_Top_Level_Code_Unit (N)))); 9110 end Find_Top_Unit; 9111 9112 ---------------------- 9113 -- Find_Unit_Entity -- 9114 ---------------------- 9115 9116 function Find_Unit_Entity (N : Node_Id) return Entity_Id is 9117 Context : constant Node_Id := Parent (N); 9118 Orig_N : constant Node_Id := Original_Node (N); 9119 9120 begin 9121 -- The unit denotes a package body of an instantiation which acts as 9122 -- a compilation unit. The proper entity is that of the package spec. 9123 9124 if Nkind (N) = N_Package_Body 9125 and then Nkind (Orig_N) = N_Package_Instantiation 9126 and then Nkind (Context) = N_Compilation_Unit 9127 then 9128 return Corresponding_Spec (N); 9129 9130 -- The unit denotes an anonymous package created to wrap a subprogram 9131 -- instantiation which acts as a compilation unit. The proper entity is 9132 -- that of the "related instance". 9133 9134 elsif Nkind (N) = N_Package_Declaration 9135 and then Nkind (Orig_N) in 9136 N_Function_Instantiation | N_Procedure_Instantiation 9137 and then Nkind (Context) = N_Compilation_Unit 9138 then 9139 return Related_Instance (Defining_Entity (N)); 9140 9141 -- The unit denotes a concurrent body acting as a subunit. Such bodies 9142 -- are generally rewritten into null statements. The proper entity is 9143 -- that of the "original node". 9144 9145 elsif Nkind (N) = N_Subunit 9146 and then Nkind (Proper_Body (N)) = N_Null_Statement 9147 and then Nkind (Original_Node (Proper_Body (N))) in 9148 N_Protected_Body | N_Task_Body 9149 then 9150 return Defining_Entity (Original_Node (Proper_Body (N))); 9151 9152 -- Otherwise the proper entity is the defining entity 9153 9154 else 9155 return Defining_Entity (N); 9156 end if; 9157 end Find_Unit_Entity; 9158 9159 ----------------------- 9160 -- First_Formal_Type -- 9161 ----------------------- 9162 9163 function First_Formal_Type (Subp_Id : Entity_Id) return Entity_Id is 9164 Formal_Id : constant Entity_Id := First_Formal (Subp_Id); 9165 Typ : Entity_Id; 9166 9167 begin 9168 if Present (Formal_Id) then 9169 Typ := Etype (Formal_Id); 9170 9171 -- Handle various combinations of concurrent and private types 9172 9173 loop 9174 if Ekind (Typ) in E_Protected_Type | E_Task_Type 9175 and then Present (Anonymous_Object (Typ)) 9176 then 9177 Typ := Anonymous_Object (Typ); 9178 9179 elsif Is_Concurrent_Record_Type (Typ) then 9180 Typ := Corresponding_Concurrent_Type (Typ); 9181 9182 elsif Is_Private_Type (Typ) and then Present (Full_View (Typ)) then 9183 Typ := Full_View (Typ); 9184 9185 else 9186 exit; 9187 end if; 9188 end loop; 9189 9190 return Typ; 9191 end if; 9192 9193 return Empty; 9194 end First_Formal_Type; 9195 9196 ------------------------------ 9197 -- Guaranteed_ABE_Processor -- 9198 ------------------------------ 9199 9200 package body Guaranteed_ABE_Processor is 9201 function Is_Guaranteed_ABE 9202 (N : Node_Id; 9203 Target_Decl : Node_Id; 9204 Target_Body : Node_Id) return Boolean; 9205 pragma Inline (Is_Guaranteed_ABE); 9206 -- Determine whether scenario N with a target described by its initial 9207 -- declaration Target_Decl and body Target_Decl results in a guaranteed 9208 -- ABE. 9209 9210 procedure Process_Guaranteed_ABE_Activation 9211 (Call : Node_Id; 9212 Call_Rep : Scenario_Rep_Id; 9213 Obj_Id : Entity_Id; 9214 Obj_Rep : Target_Rep_Id; 9215 Task_Typ : Entity_Id; 9216 Task_Rep : Target_Rep_Id; 9217 In_State : Processing_In_State); 9218 pragma Inline (Process_Guaranteed_ABE_Activation); 9219 -- Perform common guaranteed ABE checks and diagnostics for activation 9220 -- call Call which activates object Obj_Id of task type Task_Typ. Formal 9221 -- Call_Rep denotes the representation of the call. Obj_Rep denotes the 9222 -- representation of the object. Task_Rep denotes the representation of 9223 -- the task type. In_State is the current state of the Processing phase. 9224 9225 procedure Process_Guaranteed_ABE_Call 9226 (Call : Node_Id; 9227 Call_Rep : Scenario_Rep_Id; 9228 In_State : Processing_In_State); 9229 pragma Inline (Process_Guaranteed_ABE_Call); 9230 -- Perform common guaranteed ABE checks and diagnostics for call Call 9231 -- with representation Call_Rep. In_State denotes the current state of 9232 -- the Processing phase. 9233 9234 procedure Process_Guaranteed_ABE_Instantiation 9235 (Inst : Node_Id; 9236 Inst_Rep : Scenario_Rep_Id; 9237 In_State : Processing_In_State); 9238 pragma Inline (Process_Guaranteed_ABE_Instantiation); 9239 -- Perform common guaranteed ABE checks and diagnostics for instance 9240 -- Inst with representation Inst_Rep. In_State is the current state of 9241 -- the Processing phase. 9242 9243 ----------------------- 9244 -- Is_Guaranteed_ABE -- 9245 ----------------------- 9246 9247 function Is_Guaranteed_ABE 9248 (N : Node_Id; 9249 Target_Decl : Node_Id; 9250 Target_Body : Node_Id) return Boolean 9251 is 9252 Spec : Node_Id; 9253 begin 9254 -- Avoid cascaded errors if there were previous serious infractions. 9255 -- As a result the scenario will not be treated as a guaranteed ABE. 9256 -- This behavior parallels that of the old ABE mechanism. 9257 9258 if Serious_Errors_Detected > 0 then 9259 return False; 9260 9261 -- The scenario and the target appear in the same context ignoring 9262 -- enclosing library levels. 9263 9264 elsif In_Same_Context (N, Target_Decl) then 9265 9266 -- The target body has already been encountered. The scenario 9267 -- results in a guaranteed ABE if it appears prior to the body. 9268 9269 if Present (Target_Body) then 9270 return Earlier_In_Extended_Unit (N, Target_Body); 9271 9272 -- Otherwise the body has not been encountered yet. The scenario 9273 -- is a guaranteed ABE since the body will appear later, unless 9274 -- this is a null specification, which can occur if expansion is 9275 -- disabled (e.g. -gnatc or GNATprove mode). It is assumed that 9276 -- the caller has already ensured that the scenario is ABE-safe 9277 -- because optional bodies are not considered here. 9278 9279 else 9280 Spec := Specification (Target_Decl); 9281 9282 if Nkind (Spec) /= N_Procedure_Specification 9283 or else not Null_Present (Spec) 9284 then 9285 return True; 9286 end if; 9287 end if; 9288 end if; 9289 9290 return False; 9291 end Is_Guaranteed_ABE; 9292 9293 ---------------------------- 9294 -- Process_Guaranteed_ABE -- 9295 ---------------------------- 9296 9297 procedure Process_Guaranteed_ABE 9298 (N : Node_Id; 9299 In_State : Processing_In_State) 9300 is 9301 Scen : constant Node_Id := Scenario (N); 9302 Scen_Rep : Scenario_Rep_Id; 9303 9304 begin 9305 -- Add the current scenario to the stack of active scenarios 9306 9307 Push_Active_Scenario (Scen); 9308 9309 -- Only calls, instantiations, and task activations may result in a 9310 -- guaranteed ABE. 9311 9312 -- Call or task activation 9313 9314 if Is_Suitable_Call (Scen) then 9315 Scen_Rep := Scenario_Representation_Of (Scen, In_State); 9316 9317 if Kind (Scen_Rep) = Call_Scenario then 9318 Process_Guaranteed_ABE_Call 9319 (Call => Scen, 9320 Call_Rep => Scen_Rep, 9321 In_State => In_State); 9322 9323 else 9324 pragma Assert (Kind (Scen_Rep) = Task_Activation_Scenario); 9325 9326 Process_Activation 9327 (Call => Scen, 9328 Call_Rep => Scenario_Representation_Of (Scen, In_State), 9329 Processor => Process_Guaranteed_ABE_Activation'Access, 9330 In_State => In_State); 9331 end if; 9332 9333 -- Instantiation 9334 9335 elsif Is_Suitable_Instantiation (Scen) then 9336 Process_Guaranteed_ABE_Instantiation 9337 (Inst => Scen, 9338 Inst_Rep => Scenario_Representation_Of (Scen, In_State), 9339 In_State => In_State); 9340 end if; 9341 9342 -- Remove the current scenario from the stack of active scenarios 9343 -- once all ABE diagnostics and checks have been performed. 9344 9345 Pop_Active_Scenario (Scen); 9346 end Process_Guaranteed_ABE; 9347 9348 --------------------------------------- 9349 -- Process_Guaranteed_ABE_Activation -- 9350 --------------------------------------- 9351 9352 procedure Process_Guaranteed_ABE_Activation 9353 (Call : Node_Id; 9354 Call_Rep : Scenario_Rep_Id; 9355 Obj_Id : Entity_Id; 9356 Obj_Rep : Target_Rep_Id; 9357 Task_Typ : Entity_Id; 9358 Task_Rep : Target_Rep_Id; 9359 In_State : Processing_In_State) 9360 is 9361 Spec_Decl : constant Node_Id := Spec_Declaration (Task_Rep); 9362 9363 Check_OK : constant Boolean := 9364 not In_State.Suppress_Checks 9365 and then Ghost_Mode_Of (Obj_Rep) /= Is_Ignored 9366 and then Ghost_Mode_Of (Task_Rep) /= Is_Ignored 9367 and then Elaboration_Checks_OK (Obj_Rep) 9368 and then Elaboration_Checks_OK (Task_Rep); 9369 -- A run-time ABE check may be installed only when the object and the 9370 -- task type have active elaboration checks, and both are not ignored 9371 -- Ghost constructs. 9372 9373 begin 9374 -- Nothing to do when the root scenario appears at the declaration 9375 -- level and the task is in the same unit, but outside this context. 9376 -- 9377 -- task type Task_Typ; -- task declaration 9378 -- 9379 -- procedure Proc is 9380 -- function A ... is 9381 -- begin 9382 -- if Some_Condition then 9383 -- declare 9384 -- T : Task_Typ; 9385 -- begin 9386 -- <activation call> -- activation site 9387 -- end; 9388 -- ... 9389 -- end A; 9390 -- 9391 -- X : ... := A; -- root scenario 9392 -- ... 9393 -- 9394 -- task body Task_Typ is 9395 -- ... 9396 -- end Task_Typ; 9397 -- 9398 -- In the example above, the context of X is the declarative list 9399 -- of Proc. The "elaboration" of X may reach the activation of T 9400 -- whose body is defined outside of X's context. The task body is 9401 -- relevant only when Proc is invoked, but this happens only in 9402 -- "normal" elaboration, therefore the task body must not be 9403 -- considered if this is not the case. 9404 9405 if Is_Up_Level_Target 9406 (Targ_Decl => Spec_Decl, 9407 In_State => In_State) 9408 then 9409 return; 9410 9411 -- Nothing to do when the activation is ABE-safe 9412 -- 9413 -- generic 9414 -- package Gen is 9415 -- task type Task_Typ; 9416 -- end Gen; 9417 -- 9418 -- package body Gen is 9419 -- task body Task_Typ is 9420 -- begin 9421 -- ... 9422 -- end Task_Typ; 9423 -- end Gen; 9424 -- 9425 -- with Gen; 9426 -- procedure Main is 9427 -- package Nested is 9428 -- package Inst is new Gen; 9429 -- T : Inst.Task_Typ; 9430 -- end Nested; -- safe activation 9431 -- ... 9432 9433 elsif Is_Safe_Activation (Call, Task_Rep) then 9434 return; 9435 9436 -- An activation call leads to a guaranteed ABE when the activation 9437 -- call and the task appear within the same context ignoring library 9438 -- levels, and the body of the task has not been seen yet or appears 9439 -- after the activation call. 9440 -- 9441 -- procedure Guaranteed_ABE is 9442 -- task type Task_Typ; 9443 -- 9444 -- package Nested is 9445 -- T : Task_Typ; 9446 -- <activation call> -- guaranteed ABE 9447 -- end Nested; 9448 -- 9449 -- task body Task_Typ is 9450 -- ... 9451 -- end Task_Typ; 9452 -- ... 9453 9454 elsif Is_Guaranteed_ABE 9455 (N => Call, 9456 Target_Decl => Spec_Decl, 9457 Target_Body => Body_Declaration (Task_Rep)) 9458 then 9459 if Elaboration_Warnings_OK (Call_Rep) then 9460 Error_Msg_Sloc := Sloc (Call); 9461 Error_Msg_N 9462 ("??task & will be activated # before elaboration of its " 9463 & "body", Obj_Id); 9464 Error_Msg_N 9465 ("\Program_Error will be raised at run time", Obj_Id); 9466 end if; 9467 9468 -- Mark the activation call as a guaranteed ABE 9469 9470 Set_Is_Known_Guaranteed_ABE (Call); 9471 9472 -- Install a run-time ABE failue because this activation call will 9473 -- always result in an ABE. 9474 9475 if Check_OK then 9476 Install_Scenario_ABE_Failure 9477 (N => Call, 9478 Targ_Id => Task_Typ, 9479 Targ_Rep => Task_Rep, 9480 Disable => Obj_Rep); 9481 end if; 9482 end if; 9483 end Process_Guaranteed_ABE_Activation; 9484 9485 --------------------------------- 9486 -- Process_Guaranteed_ABE_Call -- 9487 --------------------------------- 9488 9489 procedure Process_Guaranteed_ABE_Call 9490 (Call : Node_Id; 9491 Call_Rep : Scenario_Rep_Id; 9492 In_State : Processing_In_State) 9493 is 9494 Subp_Id : constant Entity_Id := Target (Call_Rep); 9495 Subp_Rep : constant Target_Rep_Id := 9496 Target_Representation_Of (Subp_Id, In_State); 9497 Spec_Decl : constant Node_Id := Spec_Declaration (Subp_Rep); 9498 9499 Check_OK : constant Boolean := 9500 not In_State.Suppress_Checks 9501 and then Ghost_Mode_Of (Call_Rep) /= Is_Ignored 9502 and then Ghost_Mode_Of (Subp_Rep) /= Is_Ignored 9503 and then Elaboration_Checks_OK (Call_Rep) 9504 and then Elaboration_Checks_OK (Subp_Rep); 9505 -- A run-time ABE check may be installed only when both the call 9506 -- and the target have active elaboration checks, and both are not 9507 -- ignored Ghost constructs. 9508 9509 begin 9510 -- Nothing to do when the root scenario appears at the declaration 9511 -- level and the target is in the same unit but outside this context. 9512 -- 9513 -- function B ...; -- target declaration 9514 -- 9515 -- procedure Proc is 9516 -- function A ... is 9517 -- begin 9518 -- if Some_Condition then 9519 -- return B; -- call site 9520 -- ... 9521 -- end A; 9522 -- 9523 -- X : ... := A; -- root scenario 9524 -- ... 9525 -- 9526 -- function B ... is 9527 -- ... 9528 -- end B; 9529 -- 9530 -- In the example above, the context of X is the declarative region 9531 -- of Proc. The "elaboration" of X may eventually reach B which is 9532 -- defined outside of X's context. B is relevant only when Proc is 9533 -- invoked, but this happens only by means of "normal" elaboration, 9534 -- therefore B must not be considered if this is not the case. 9535 9536 if Is_Up_Level_Target 9537 (Targ_Decl => Spec_Decl, 9538 In_State => In_State) 9539 then 9540 return; 9541 9542 -- Nothing to do when the call is ABE-safe 9543 -- 9544 -- generic 9545 -- function Gen ...; 9546 -- 9547 -- function Gen ... is 9548 -- begin 9549 -- ... 9550 -- end Gen; 9551 -- 9552 -- with Gen; 9553 -- procedure Main is 9554 -- function Inst is new Gen; 9555 -- X : ... := Inst; -- safe call 9556 -- ... 9557 9558 elsif Is_Safe_Call (Call, Subp_Id, Subp_Rep) then 9559 return; 9560 9561 -- A call leads to a guaranteed ABE when the call and the target 9562 -- appear within the same context ignoring library levels, and the 9563 -- body of the target has not been seen yet or appears after the 9564 -- call. 9565 -- 9566 -- procedure Guaranteed_ABE is 9567 -- function Func ...; 9568 -- 9569 -- package Nested is 9570 -- Obj : ... := Func; -- guaranteed ABE 9571 -- end Nested; 9572 -- 9573 -- function Func ... is 9574 -- ... 9575 -- end Func; 9576 -- ... 9577 9578 elsif Is_Guaranteed_ABE 9579 (N => Call, 9580 Target_Decl => Spec_Decl, 9581 Target_Body => Body_Declaration (Subp_Rep)) 9582 then 9583 if Elaboration_Warnings_OK (Call_Rep) then 9584 Error_Msg_NE 9585 ("??cannot call & before body seen", Call, Subp_Id); 9586 Error_Msg_N ("\Program_Error will be raised at run time", Call); 9587 end if; 9588 9589 -- Mark the call as a guaranteed ABE 9590 9591 Set_Is_Known_Guaranteed_ABE (Call); 9592 9593 -- Install a run-time ABE failure because the call will always 9594 -- result in an ABE. 9595 9596 if Check_OK then 9597 Install_Scenario_ABE_Failure 9598 (N => Call, 9599 Targ_Id => Subp_Id, 9600 Targ_Rep => Subp_Rep, 9601 Disable => Call_Rep); 9602 end if; 9603 end if; 9604 end Process_Guaranteed_ABE_Call; 9605 9606 ------------------------------------------ 9607 -- Process_Guaranteed_ABE_Instantiation -- 9608 ------------------------------------------ 9609 9610 procedure Process_Guaranteed_ABE_Instantiation 9611 (Inst : Node_Id; 9612 Inst_Rep : Scenario_Rep_Id; 9613 In_State : Processing_In_State) 9614 is 9615 Gen_Id : constant Entity_Id := Target (Inst_Rep); 9616 Gen_Rep : constant Target_Rep_Id := 9617 Target_Representation_Of (Gen_Id, In_State); 9618 Spec_Decl : constant Node_Id := Spec_Declaration (Gen_Rep); 9619 9620 Check_OK : constant Boolean := 9621 not In_State.Suppress_Checks 9622 and then Ghost_Mode_Of (Inst_Rep) /= Is_Ignored 9623 and then Ghost_Mode_Of (Gen_Rep) /= Is_Ignored 9624 and then Elaboration_Checks_OK (Inst_Rep) 9625 and then Elaboration_Checks_OK (Gen_Rep); 9626 -- A run-time ABE check may be installed only when both the instance 9627 -- and the generic have active elaboration checks and both are not 9628 -- ignored Ghost constructs. 9629 9630 begin 9631 -- Nothing to do when the root scenario appears at the declaration 9632 -- level and the generic is in the same unit, but outside this 9633 -- context. 9634 -- 9635 -- generic 9636 -- procedure Gen is ...; -- generic declaration 9637 -- 9638 -- procedure Proc is 9639 -- function A ... is 9640 -- begin 9641 -- if Some_Condition then 9642 -- declare 9643 -- procedure I is new Gen; -- instantiation site 9644 -- ... 9645 -- ... 9646 -- end A; 9647 -- 9648 -- X : ... := A; -- root scenario 9649 -- ... 9650 -- 9651 -- procedure Gen is 9652 -- ... 9653 -- end Gen; 9654 -- 9655 -- In the example above, the context of X is the declarative region 9656 -- of Proc. The "elaboration" of X may eventually reach Gen which 9657 -- appears outside of X's context. Gen is relevant only when Proc is 9658 -- invoked, but this happens only by means of "normal" elaboration, 9659 -- therefore Gen must not be considered if this is not the case. 9660 9661 if Is_Up_Level_Target 9662 (Targ_Decl => Spec_Decl, 9663 In_State => In_State) 9664 then 9665 return; 9666 9667 -- Nothing to do when the instantiation is ABE-safe 9668 -- 9669 -- generic 9670 -- package Gen is 9671 -- ... 9672 -- end Gen; 9673 -- 9674 -- package body Gen is 9675 -- ... 9676 -- end Gen; 9677 -- 9678 -- with Gen; 9679 -- procedure Main is 9680 -- package Inst is new Gen (ABE); -- safe instantiation 9681 -- ... 9682 9683 elsif Is_Safe_Instantiation (Inst, Gen_Id, Gen_Rep) then 9684 return; 9685 9686 -- An instantiation leads to a guaranteed ABE when the instantiation 9687 -- and the generic appear within the same context ignoring library 9688 -- levels, and the body of the generic has not been seen yet or 9689 -- appears after the instantiation. 9690 -- 9691 -- procedure Guaranteed_ABE is 9692 -- generic 9693 -- procedure Gen; 9694 -- 9695 -- package Nested is 9696 -- procedure Inst is new Gen; -- guaranteed ABE 9697 -- end Nested; 9698 -- 9699 -- procedure Gen is 9700 -- ... 9701 -- end Gen; 9702 -- ... 9703 9704 elsif Is_Guaranteed_ABE 9705 (N => Inst, 9706 Target_Decl => Spec_Decl, 9707 Target_Body => Body_Declaration (Gen_Rep)) 9708 then 9709 if Elaboration_Warnings_OK (Inst_Rep) then 9710 Error_Msg_NE 9711 ("??cannot instantiate & before body seen", Inst, Gen_Id); 9712 Error_Msg_N ("\Program_Error will be raised at run time", Inst); 9713 end if; 9714 9715 -- Mark the instantiation as a guarantee ABE. This automatically 9716 -- suppresses the instantiation of the generic body. 9717 9718 Set_Is_Known_Guaranteed_ABE (Inst); 9719 9720 -- Install a run-time ABE failure because the instantiation will 9721 -- always result in an ABE. 9722 9723 if Check_OK then 9724 Install_Scenario_ABE_Failure 9725 (N => Inst, 9726 Targ_Id => Gen_Id, 9727 Targ_Rep => Gen_Rep, 9728 Disable => Inst_Rep); 9729 end if; 9730 end if; 9731 end Process_Guaranteed_ABE_Instantiation; 9732 end Guaranteed_ABE_Processor; 9733 9734 -------------- 9735 -- Has_Body -- 9736 -------------- 9737 9738 function Has_Body (Pack_Decl : Node_Id) return Boolean is 9739 function Find_Corresponding_Body (Spec_Id : Entity_Id) return Node_Id; 9740 pragma Inline (Find_Corresponding_Body); 9741 -- Try to locate the corresponding body of spec Spec_Id. If no body is 9742 -- found, return Empty. 9743 9744 function Find_Body 9745 (Spec_Id : Entity_Id; 9746 From : Node_Id) return Node_Id; 9747 pragma Inline (Find_Body); 9748 -- Try to locate the corresponding body of spec Spec_Id in the node list 9749 -- which follows arbitrary node From. If no body is found, return Empty. 9750 9751 function Load_Package_Body (Unit_Nam : Unit_Name_Type) return Node_Id; 9752 pragma Inline (Load_Package_Body); 9753 -- Attempt to load the body of unit Unit_Nam. If the load failed, return 9754 -- Empty. If the compilation will not generate code, return Empty. 9755 9756 ----------------------------- 9757 -- Find_Corresponding_Body -- 9758 ----------------------------- 9759 9760 function Find_Corresponding_Body (Spec_Id : Entity_Id) return Node_Id is 9761 Context : constant Entity_Id := Scope (Spec_Id); 9762 Spec_Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id); 9763 Body_Decl : Node_Id; 9764 Body_Id : Entity_Id; 9765 9766 begin 9767 if Is_Compilation_Unit (Spec_Id) then 9768 Body_Id := Corresponding_Body (Spec_Decl); 9769 9770 if Present (Body_Id) then 9771 return Unit_Declaration_Node (Body_Id); 9772 9773 -- The package is at the library and requires a body. Load the 9774 -- corresponding body because the optional body may be declared 9775 -- there. 9776 9777 elsif Unit_Requires_Body (Spec_Id) then 9778 return 9779 Load_Package_Body 9780 (Get_Body_Name (Unit_Name (Get_Source_Unit (Spec_Decl)))); 9781 9782 -- Otherwise there is no optional body 9783 9784 else 9785 return Empty; 9786 end if; 9787 9788 -- The immediate context is a package. The optional body may be 9789 -- within the body of that package. 9790 9791 -- procedure Proc is 9792 -- package Nested_1 is 9793 -- package Nested_2 is 9794 -- generic 9795 -- package Pack is 9796 -- end Pack; 9797 -- end Nested_2; 9798 -- end Nested_1; 9799 9800 -- package body Nested_1 is 9801 -- package body Nested_2 is separate; 9802 -- end Nested_1; 9803 9804 -- separate (Proc.Nested_1.Nested_2) 9805 -- package body Nested_2 is 9806 -- package body Pack is -- optional body 9807 -- ... 9808 -- end Pack; 9809 -- end Nested_2; 9810 9811 elsif Is_Package_Or_Generic_Package (Context) then 9812 Body_Decl := Find_Corresponding_Body (Context); 9813 9814 -- The optional body is within the body of the enclosing package 9815 9816 if Present (Body_Decl) then 9817 return 9818 Find_Body 9819 (Spec_Id => Spec_Id, 9820 From => First (Declarations (Body_Decl))); 9821 9822 -- Otherwise the enclosing package does not have a body. This may 9823 -- be the result of an error or a genuine lack of a body. 9824 9825 else 9826 return Empty; 9827 end if; 9828 9829 -- Otherwise the immediate context is a body. The optional body may 9830 -- be within the same list as the spec. 9831 9832 -- procedure Proc is 9833 -- generic 9834 -- package Pack is 9835 -- end Pack; 9836 9837 -- package body Pack is -- optional body 9838 -- ... 9839 -- end Pack; 9840 9841 else 9842 return 9843 Find_Body 9844 (Spec_Id => Spec_Id, 9845 From => Next (Spec_Decl)); 9846 end if; 9847 end Find_Corresponding_Body; 9848 9849 --------------- 9850 -- Find_Body -- 9851 --------------- 9852 9853 function Find_Body 9854 (Spec_Id : Entity_Id; 9855 From : Node_Id) return Node_Id 9856 is 9857 Spec_Nam : constant Name_Id := Chars (Spec_Id); 9858 Item : Node_Id; 9859 Lib_Unit : Node_Id; 9860 9861 begin 9862 Item := From; 9863 while Present (Item) loop 9864 9865 -- The current item denotes the optional body 9866 9867 if Nkind (Item) = N_Package_Body 9868 and then Chars (Defining_Entity (Item)) = Spec_Nam 9869 then 9870 return Item; 9871 9872 -- The current item denotes a stub, the optional body may be in 9873 -- the subunit. 9874 9875 elsif Nkind (Item) = N_Package_Body_Stub 9876 and then Chars (Defining_Entity (Item)) = Spec_Nam 9877 then 9878 Lib_Unit := Library_Unit (Item); 9879 9880 -- The corresponding subunit was previously loaded 9881 9882 if Present (Lib_Unit) then 9883 return Lib_Unit; 9884 9885 -- Otherwise attempt to load the corresponding subunit 9886 9887 else 9888 return Load_Package_Body (Get_Unit_Name (Item)); 9889 end if; 9890 end if; 9891 9892 Next (Item); 9893 end loop; 9894 9895 return Empty; 9896 end Find_Body; 9897 9898 ----------------------- 9899 -- Load_Package_Body -- 9900 ----------------------- 9901 9902 function Load_Package_Body (Unit_Nam : Unit_Name_Type) return Node_Id is 9903 Body_Decl : Node_Id; 9904 Unit_Num : Unit_Number_Type; 9905 9906 begin 9907 -- The load is performed only when the compilation will generate code 9908 9909 if Operating_Mode = Generate_Code then 9910 Unit_Num := 9911 Load_Unit 9912 (Load_Name => Unit_Nam, 9913 Required => False, 9914 Subunit => False, 9915 Error_Node => Pack_Decl); 9916 9917 -- The load failed most likely because the physical file is 9918 -- missing. 9919 9920 if Unit_Num = No_Unit then 9921 return Empty; 9922 9923 -- Otherwise the load was successful, return the body of the unit 9924 9925 else 9926 Body_Decl := Unit (Cunit (Unit_Num)); 9927 9928 -- If the unit is a subunit with an available proper body, 9929 -- return the proper body. 9930 9931 if Nkind (Body_Decl) = N_Subunit 9932 and then Present (Proper_Body (Body_Decl)) 9933 then 9934 Body_Decl := Proper_Body (Body_Decl); 9935 end if; 9936 9937 return Body_Decl; 9938 end if; 9939 end if; 9940 9941 return Empty; 9942 end Load_Package_Body; 9943 9944 -- Local variables 9945 9946 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl); 9947 9948 -- Start of processing for Has_Body 9949 9950 begin 9951 -- The body is available 9952 9953 if Present (Corresponding_Body (Pack_Decl)) then 9954 return True; 9955 9956 -- The body is required if the package spec contains a construct which 9957 -- requires a completion in a body. 9958 9959 elsif Unit_Requires_Body (Pack_Id) then 9960 return True; 9961 9962 -- The body may be optional 9963 9964 else 9965 return Present (Find_Corresponding_Body (Pack_Id)); 9966 end if; 9967 end Has_Body; 9968 9969 ---------- 9970 -- Hash -- 9971 ---------- 9972 9973 function Hash (NE : Node_Or_Entity_Id) return Bucket_Range_Type is 9974 pragma Assert (Present (NE)); 9975 begin 9976 return Bucket_Range_Type (NE); 9977 end Hash; 9978 9979 -------------------------- 9980 -- In_External_Instance -- 9981 -------------------------- 9982 9983 function In_External_Instance 9984 (N : Node_Id; 9985 Target_Decl : Node_Id) return Boolean 9986 is 9987 Inst : Node_Id; 9988 Inst_Body : Node_Id; 9989 Inst_Spec : Node_Id; 9990 9991 begin 9992 Inst := Find_Enclosing_Instance (Target_Decl); 9993 9994 -- The target declaration appears within an instance spec. Visibility is 9995 -- ignored because internally generated primitives for private types may 9996 -- reside in the private declarations and still be invoked from outside. 9997 9998 if Present (Inst) and then Nkind (Inst) = N_Package_Declaration then 9999 10000 -- The scenario comes from the main unit and the instance does not 10001 10002 if In_Extended_Main_Code_Unit (N) 10003 and then not In_Extended_Main_Code_Unit (Inst) 10004 then 10005 return True; 10006 10007 -- Otherwise the scenario must not appear within the instance spec or 10008 -- body. 10009 10010 else 10011 Spec_And_Body_From_Node 10012 (N => Inst, 10013 Spec_Decl => Inst_Spec, 10014 Body_Decl => Inst_Body); 10015 10016 return not In_Subtree 10017 (N => N, 10018 Root1 => Inst_Spec, 10019 Root2 => Inst_Body); 10020 end if; 10021 end if; 10022 10023 return False; 10024 end In_External_Instance; 10025 10026 --------------------- 10027 -- In_Main_Context -- 10028 --------------------- 10029 10030 function In_Main_Context (N : Node_Id) return Boolean is 10031 begin 10032 -- Scenarios outside the main unit are not considered because the ALI 10033 -- information supplied to binde is for the main unit only. 10034 10035 if not In_Extended_Main_Code_Unit (N) then 10036 return False; 10037 10038 -- Scenarios within internal units are not considered unless switch 10039 -- -gnatdE (elaboration checks on predefined units) is in effect. 10040 10041 elsif not Debug_Flag_EE and then In_Internal_Unit (N) then 10042 return False; 10043 end if; 10044 10045 return True; 10046 end In_Main_Context; 10047 10048 --------------------- 10049 -- In_Same_Context -- 10050 --------------------- 10051 10052 function In_Same_Context 10053 (N1 : Node_Id; 10054 N2 : Node_Id; 10055 Nested_OK : Boolean := False) return Boolean 10056 is 10057 function Find_Enclosing_Context (N : Node_Id) return Node_Id; 10058 pragma Inline (Find_Enclosing_Context); 10059 -- Return the nearest enclosing non-library-level or compilation unit 10060 -- node which encapsulates arbitrary node N. Return Empty is no such 10061 -- context is available. 10062 10063 function In_Nested_Context 10064 (Outer : Node_Id; 10065 Inner : Node_Id) return Boolean; 10066 pragma Inline (In_Nested_Context); 10067 -- Determine whether arbitrary node Outer encapsulates arbitrary node 10068 -- Inner. 10069 10070 ---------------------------- 10071 -- Find_Enclosing_Context -- 10072 ---------------------------- 10073 10074 function Find_Enclosing_Context (N : Node_Id) return Node_Id is 10075 Context : Node_Id; 10076 Par : Node_Id; 10077 10078 begin 10079 Par := Parent (N); 10080 while Present (Par) loop 10081 10082 -- A traversal from a subunit continues via the corresponding stub 10083 10084 if Nkind (Par) = N_Subunit then 10085 Par := Corresponding_Stub (Par); 10086 10087 -- Stop the traversal when the nearest enclosing non-library-level 10088 -- encapsulator has been reached. 10089 10090 elsif Is_Non_Library_Level_Encapsulator (Par) then 10091 Context := Parent (Par); 10092 10093 -- The sole exception is when the encapsulator is the unit of 10094 -- compilation because this case requires special processing 10095 -- (see below). 10096 10097 if Present (Context) 10098 and then Nkind (Context) = N_Compilation_Unit 10099 then 10100 null; 10101 10102 else 10103 return Par; 10104 end if; 10105 10106 -- Reaching a compilation unit node without hitting a non-library- 10107 -- level encapsulator indicates that N is at the library level in 10108 -- which case the compilation unit is the context. 10109 10110 elsif Nkind (Par) = N_Compilation_Unit then 10111 return Par; 10112 end if; 10113 10114 Par := Parent (Par); 10115 end loop; 10116 10117 return Empty; 10118 end Find_Enclosing_Context; 10119 10120 ----------------------- 10121 -- In_Nested_Context -- 10122 ----------------------- 10123 10124 function In_Nested_Context 10125 (Outer : Node_Id; 10126 Inner : Node_Id) return Boolean 10127 is 10128 Par : Node_Id; 10129 10130 begin 10131 Par := Inner; 10132 while Present (Par) loop 10133 10134 -- A traversal from a subunit continues via the corresponding stub 10135 10136 if Nkind (Par) = N_Subunit then 10137 Par := Corresponding_Stub (Par); 10138 10139 elsif Par = Outer then 10140 return True; 10141 end if; 10142 10143 Par := Parent (Par); 10144 end loop; 10145 10146 return False; 10147 end In_Nested_Context; 10148 10149 -- Local variables 10150 10151 Context_1 : constant Node_Id := Find_Enclosing_Context (N1); 10152 Context_2 : constant Node_Id := Find_Enclosing_Context (N2); 10153 10154 -- Start of processing for In_Same_Context 10155 10156 begin 10157 -- Both nodes appear within the same context 10158 10159 if Context_1 = Context_2 then 10160 return True; 10161 10162 -- Both nodes appear in compilation units. Determine whether one unit 10163 -- is the body of the other. 10164 10165 elsif Nkind (Context_1) = N_Compilation_Unit 10166 and then Nkind (Context_2) = N_Compilation_Unit 10167 then 10168 return 10169 Is_Same_Unit 10170 (Unit_1 => Defining_Entity (Unit (Context_1)), 10171 Unit_2 => Defining_Entity (Unit (Context_2))); 10172 10173 -- The context of N1 encloses the context of N2 10174 10175 elsif Nested_OK and then In_Nested_Context (Context_1, Context_2) then 10176 return True; 10177 end if; 10178 10179 return False; 10180 end In_Same_Context; 10181 10182 ---------------- 10183 -- Initialize -- 10184 ---------------- 10185 10186 procedure Initialize is 10187 begin 10188 -- Set the soft link which enables Atree.Rewrite to update a scenario 10189 -- each time it is transformed into another node. 10190 10191 Set_Rewriting_Proc (Update_Elaboration_Scenario'Access); 10192 10193 -- Create all internal data structures and activate the elaboration 10194 -- phase of the compiler. 10195 10196 Initialize_All_Data_Structures; 10197 Set_Elaboration_Phase (Active); 10198 end Initialize; 10199 10200 ------------------------------------ 10201 -- Initialize_All_Data_Structures -- 10202 ------------------------------------ 10203 10204 procedure Initialize_All_Data_Structures is 10205 begin 10206 Initialize_Body_Processor; 10207 Initialize_Early_Call_Region_Processor; 10208 Initialize_Elaborated_Units; 10209 Initialize_Internal_Representation; 10210 Initialize_Invocation_Graph; 10211 Initialize_Scenario_Storage; 10212 end Initialize_All_Data_Structures; 10213 10214 -------------------------- 10215 -- Instantiated_Generic -- 10216 -------------------------- 10217 10218 function Instantiated_Generic (Inst : Node_Id) return Entity_Id is 10219 begin 10220 -- Traverse a possible chain of renamings to obtain the original generic 10221 -- being instantiatied. 10222 10223 return Get_Renamed_Entity (Entity (Name (Inst))); 10224 end Instantiated_Generic; 10225 10226 ----------------------------- 10227 -- Internal_Representation -- 10228 ----------------------------- 10229 10230 package body Internal_Representation is 10231 10232 ----------- 10233 -- Types -- 10234 ----------- 10235 10236 -- The following type represents the contents of a scenario 10237 10238 type Scenario_Rep_Record is record 10239 Elab_Checks_OK : Boolean := False; 10240 -- The status of elaboration checks for the scenario 10241 10242 Elab_Warnings_OK : Boolean := False; 10243 -- The status of elaboration warnings for the scenario 10244 10245 GM : Extended_Ghost_Mode := Is_Checked_Or_Not_Specified; 10246 -- The Ghost mode of the scenario 10247 10248 Kind : Scenario_Kind := No_Scenario; 10249 -- The nature of the scenario 10250 10251 Level : Enclosing_Level_Kind := No_Level; 10252 -- The enclosing level where the scenario resides 10253 10254 SM : Extended_SPARK_Mode := Is_Off_Or_Not_Specified; 10255 -- The SPARK mode of the scenario 10256 10257 Target : Entity_Id := Empty; 10258 -- The target of the scenario 10259 10260 -- The following attributes are multiplexed and depend on the Kind of 10261 -- the scenario. They are mapped as follows: 10262 -- 10263 -- Call_Scenario 10264 -- Is_Dispatching_Call (Flag_1) 10265 -- 10266 -- Task_Activation_Scenario 10267 -- Activated_Task_Objects (List_1) 10268 -- Activated_Task_Type (Field_1) 10269 -- 10270 -- Variable_Reference 10271 -- Is_Read_Reference (Flag_1) 10272 10273 Flag_1 : Boolean := False; 10274 Field_1 : Node_Or_Entity_Id := Empty; 10275 List_1 : NE_List.Doubly_Linked_List := NE_List.Nil; 10276 end record; 10277 10278 -- The following type represents the contents of a target 10279 10280 type Target_Rep_Record is record 10281 Body_Decl : Node_Id := Empty; 10282 -- The declaration of the target body 10283 10284 Elab_Checks_OK : Boolean := False; 10285 -- The status of elaboration checks for the target 10286 10287 Elab_Warnings_OK : Boolean := False; 10288 -- The status of elaboration warnings for the target 10289 10290 GM : Extended_Ghost_Mode := Is_Checked_Or_Not_Specified; 10291 -- The Ghost mode of the target 10292 10293 Kind : Target_Kind := No_Target; 10294 -- The nature of the target 10295 10296 SM : Extended_SPARK_Mode := Is_Off_Or_Not_Specified; 10297 -- The SPARK mode of the target 10298 10299 Spec_Decl : Node_Id := Empty; 10300 -- The declaration of the target spec 10301 10302 Unit : Entity_Id := Empty; 10303 -- The top unit where the target is declared 10304 10305 Version : Representation_Kind := No_Representation; 10306 -- The version of the target representation 10307 10308 -- The following attributes are multiplexed and depend on the Kind of 10309 -- the target. They are mapped as follows: 10310 -- 10311 -- Subprogram_Target 10312 -- Barrier_Body_Declaration (Field_1) 10313 -- 10314 -- Variable_Target 10315 -- Variable_Declaration (Field_1) 10316 10317 Field_1 : Node_Or_Entity_Id := Empty; 10318 end record; 10319 10320 --------------------- 10321 -- Data structures -- 10322 --------------------- 10323 10324 procedure Destroy (T_Id : in out Target_Rep_Id); 10325 -- Destroy a target representation T_Id 10326 10327 package ETT_Map is new Dynamic_Hash_Tables 10328 (Key_Type => Entity_Id, 10329 Value_Type => Target_Rep_Id, 10330 No_Value => No_Target_Rep, 10331 Expansion_Threshold => 1.5, 10332 Expansion_Factor => 2, 10333 Compression_Threshold => 0.3, 10334 Compression_Factor => 2, 10335 "=" => "=", 10336 Destroy_Value => Destroy, 10337 Hash => Hash); 10338 10339 -- The following map relates target representations to entities 10340 10341 Entity_To_Target_Map : ETT_Map.Dynamic_Hash_Table := ETT_Map.Nil; 10342 10343 procedure Destroy (S_Id : in out Scenario_Rep_Id); 10344 -- Destroy a scenario representation S_Id 10345 10346 package NTS_Map is new Dynamic_Hash_Tables 10347 (Key_Type => Node_Id, 10348 Value_Type => Scenario_Rep_Id, 10349 No_Value => No_Scenario_Rep, 10350 Expansion_Threshold => 1.5, 10351 Expansion_Factor => 2, 10352 Compression_Threshold => 0.3, 10353 Compression_Factor => 2, 10354 "=" => "=", 10355 Destroy_Value => Destroy, 10356 Hash => Hash); 10357 10358 -- The following map relates scenario representations to nodes 10359 10360 Node_To_Scenario_Map : NTS_Map.Dynamic_Hash_Table := NTS_Map.Nil; 10361 10362 -- The following table stores all scenario representations 10363 10364 package Scenario_Reps is new Table.Table 10365 (Table_Index_Type => Scenario_Rep_Id, 10366 Table_Component_Type => Scenario_Rep_Record, 10367 Table_Low_Bound => First_Scenario_Rep, 10368 Table_Initial => 1000, 10369 Table_Increment => 200, 10370 Table_Name => "Scenario_Reps"); 10371 10372 -- The following table stores all target representations 10373 10374 package Target_Reps is new Table.Table 10375 (Table_Index_Type => Target_Rep_Id, 10376 Table_Component_Type => Target_Rep_Record, 10377 Table_Low_Bound => First_Target_Rep, 10378 Table_Initial => 1000, 10379 Table_Increment => 200, 10380 Table_Name => "Target_Reps"); 10381 10382 -------------- 10383 -- Builders -- 10384 -------------- 10385 10386 function Create_Access_Taken_Rep 10387 (Attr : Node_Id) return Scenario_Rep_Record; 10388 pragma Inline (Create_Access_Taken_Rep); 10389 -- Create the representation of 'Access attribute Attr 10390 10391 function Create_Call_Or_Task_Activation_Rep 10392 (Call : Node_Id) return Scenario_Rep_Record; 10393 pragma Inline (Create_Call_Or_Task_Activation_Rep); 10394 -- Create the representation of call or task activation Call 10395 10396 function Create_Derived_Type_Rep 10397 (Typ_Decl : Node_Id) return Scenario_Rep_Record; 10398 pragma Inline (Create_Derived_Type_Rep); 10399 -- Create the representation of a derived type described by declaration 10400 -- Typ_Decl. 10401 10402 function Create_Generic_Rep 10403 (Gen_Id : Entity_Id) return Target_Rep_Record; 10404 pragma Inline (Create_Generic_Rep); 10405 -- Create the representation of generic Gen_Id 10406 10407 function Create_Instantiation_Rep 10408 (Inst : Node_Id) return Scenario_Rep_Record; 10409 pragma Inline (Create_Instantiation_Rep); 10410 -- Create the representation of instantiation Inst 10411 10412 function Create_Package_Rep 10413 (Pack_Id : Entity_Id) return Target_Rep_Record; 10414 pragma Inline (Create_Package_Rep); 10415 -- Create the representation of package Pack_Id 10416 10417 function Create_Protected_Entry_Rep 10418 (PE_Id : Entity_Id) return Target_Rep_Record; 10419 pragma Inline (Create_Protected_Entry_Rep); 10420 -- Create the representation of protected entry PE_Id 10421 10422 function Create_Protected_Subprogram_Rep 10423 (PS_Id : Entity_Id) return Target_Rep_Record; 10424 pragma Inline (Create_Protected_Subprogram_Rep); 10425 -- Create the representation of protected subprogram PS_Id 10426 10427 function Create_Refined_State_Pragma_Rep 10428 (Prag : Node_Id) return Scenario_Rep_Record; 10429 pragma Inline (Create_Refined_State_Pragma_Rep); 10430 -- Create the representation of Refined_State pragma Prag 10431 10432 function Create_Scenario_Rep 10433 (N : Node_Id; 10434 In_State : Processing_In_State) return Scenario_Rep_Record; 10435 pragma Inline (Create_Scenario_Rep); 10436 -- Top level dispatcher. Create the representation of elaboration 10437 -- scenario N. In_State is the current state of the Processing phase. 10438 10439 function Create_Subprogram_Rep 10440 (Subp_Id : Entity_Id) return Target_Rep_Record; 10441 pragma Inline (Create_Subprogram_Rep); 10442 -- Create the representation of entry, operator, or subprogram Subp_Id 10443 10444 function Create_Target_Rep 10445 (Id : Entity_Id; 10446 In_State : Processing_In_State) return Target_Rep_Record; 10447 pragma Inline (Create_Target_Rep); 10448 -- Top level dispatcher. Create the representation of elaboration target 10449 -- Id. In_State is the current state of the Processing phase. 10450 10451 function Create_Task_Entry_Rep 10452 (TE_Id : Entity_Id) return Target_Rep_Record; 10453 pragma Inline (Create_Task_Entry_Rep); 10454 -- Create the representation of task entry TE_Id 10455 10456 function Create_Task_Rep (Task_Typ : Entity_Id) return Target_Rep_Record; 10457 pragma Inline (Create_Task_Rep); 10458 -- Create the representation of task type Typ 10459 10460 function Create_Variable_Assignment_Rep 10461 (Asmt : Node_Id) return Scenario_Rep_Record; 10462 pragma Inline (Create_Variable_Assignment_Rep); 10463 -- Create the representation of variable assignment Asmt 10464 10465 function Create_Variable_Reference_Rep 10466 (Ref : Node_Id) return Scenario_Rep_Record; 10467 pragma Inline (Create_Variable_Reference_Rep); 10468 -- Create the representation of variable reference Ref 10469 10470 function Create_Variable_Rep 10471 (Var_Id : Entity_Id) return Target_Rep_Record; 10472 pragma Inline (Create_Variable_Rep); 10473 -- Create the representation of variable Var_Id 10474 10475 ----------------------- 10476 -- Local subprograms -- 10477 ----------------------- 10478 10479 function Ghost_Mode_Of_Entity 10480 (Id : Entity_Id) return Extended_Ghost_Mode; 10481 pragma Inline (Ghost_Mode_Of_Entity); 10482 -- Obtain the extended Ghost mode of arbitrary entity Id 10483 10484 function Ghost_Mode_Of_Node (N : Node_Id) return Extended_Ghost_Mode; 10485 pragma Inline (Ghost_Mode_Of_Node); 10486 -- Obtain the extended Ghost mode of arbitrary node N 10487 10488 function Present (S_Id : Scenario_Rep_Id) return Boolean; 10489 pragma Inline (Present); 10490 -- Determine whether scenario representation S_Id exists 10491 10492 function Present (T_Id : Target_Rep_Id) return Boolean; 10493 pragma Inline (Present); 10494 -- Determine whether target representation T_Id exists 10495 10496 function SPARK_Mode_Of_Entity 10497 (Id : Entity_Id) return Extended_SPARK_Mode; 10498 pragma Inline (SPARK_Mode_Of_Entity); 10499 -- Obtain the extended SPARK mode of arbitrary entity Id 10500 10501 function SPARK_Mode_Of_Node (N : Node_Id) return Extended_SPARK_Mode; 10502 pragma Inline (SPARK_Mode_Of_Node); 10503 -- Obtain the extended SPARK mode of arbitrary node N 10504 10505 function To_Ghost_Mode 10506 (Ignored_Status : Boolean) return Extended_Ghost_Mode; 10507 pragma Inline (To_Ghost_Mode); 10508 -- Convert a Ghost mode indicated by Ignored_Status into its extended 10509 -- equivalent. 10510 10511 function To_SPARK_Mode (On_Status : Boolean) return Extended_SPARK_Mode; 10512 pragma Inline (To_SPARK_Mode); 10513 -- Convert a SPARK mode indicated by On_Status into its extended 10514 -- equivalent. 10515 10516 function Version (T_Id : Target_Rep_Id) return Representation_Kind; 10517 pragma Inline (Version); 10518 -- Obtain the version of target representation T_Id 10519 10520 ---------------------------- 10521 -- Activated_Task_Objects -- 10522 ---------------------------- 10523 10524 function Activated_Task_Objects 10525 (S_Id : Scenario_Rep_Id) return NE_List.Doubly_Linked_List 10526 is 10527 pragma Assert (Present (S_Id)); 10528 pragma Assert (Kind (S_Id) = Task_Activation_Scenario); 10529 10530 begin 10531 return Scenario_Reps.Table (S_Id).List_1; 10532 end Activated_Task_Objects; 10533 10534 ------------------------- 10535 -- Activated_Task_Type -- 10536 ------------------------- 10537 10538 function Activated_Task_Type 10539 (S_Id : Scenario_Rep_Id) return Entity_Id 10540 is 10541 pragma Assert (Present (S_Id)); 10542 pragma Assert (Kind (S_Id) = Task_Activation_Scenario); 10543 10544 begin 10545 return Scenario_Reps.Table (S_Id).Field_1; 10546 end Activated_Task_Type; 10547 10548 ------------------------------ 10549 -- Barrier_Body_Declaration -- 10550 ------------------------------ 10551 10552 function Barrier_Body_Declaration 10553 (T_Id : Target_Rep_Id) return Node_Id 10554 is 10555 pragma Assert (Present (T_Id)); 10556 pragma Assert (Kind (T_Id) = Subprogram_Target); 10557 10558 begin 10559 return Target_Reps.Table (T_Id).Field_1; 10560 end Barrier_Body_Declaration; 10561 10562 ---------------------- 10563 -- Body_Declaration -- 10564 ---------------------- 10565 10566 function Body_Declaration (T_Id : Target_Rep_Id) return Node_Id is 10567 pragma Assert (Present (T_Id)); 10568 begin 10569 return Target_Reps.Table (T_Id).Body_Decl; 10570 end Body_Declaration; 10571 10572 ----------------------------- 10573 -- Create_Access_Taken_Rep -- 10574 ----------------------------- 10575 10576 function Create_Access_Taken_Rep 10577 (Attr : Node_Id) return Scenario_Rep_Record 10578 is 10579 Rec : Scenario_Rep_Record; 10580 10581 begin 10582 Rec.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Attr); 10583 Rec.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Node (Attr); 10584 Rec.GM := Is_Checked_Or_Not_Specified; 10585 Rec.SM := SPARK_Mode_Of_Node (Attr); 10586 Rec.Kind := Access_Taken_Scenario; 10587 Rec.Target := Canonical_Subprogram (Entity (Prefix (Attr))); 10588 10589 return Rec; 10590 end Create_Access_Taken_Rep; 10591 10592 ---------------------------------------- 10593 -- Create_Call_Or_Task_Activation_Rep -- 10594 ---------------------------------------- 10595 10596 function Create_Call_Or_Task_Activation_Rep 10597 (Call : Node_Id) return Scenario_Rep_Record 10598 is 10599 Subp_Id : constant Entity_Id := Canonical_Subprogram (Target (Call)); 10600 Kind : Scenario_Kind; 10601 Rec : Scenario_Rep_Record; 10602 10603 begin 10604 if Is_Activation_Proc (Subp_Id) then 10605 Kind := Task_Activation_Scenario; 10606 else 10607 Kind := Call_Scenario; 10608 end if; 10609 10610 Rec.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Call); 10611 Rec.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Node (Call); 10612 Rec.GM := Ghost_Mode_Of_Node (Call); 10613 Rec.SM := SPARK_Mode_Of_Node (Call); 10614 Rec.Kind := Kind; 10615 Rec.Target := Subp_Id; 10616 10617 -- Scenario-specific attributes 10618 10619 Rec.Flag_1 := Is_Dispatching_Call (Call); -- Dispatching_Call 10620 10621 return Rec; 10622 end Create_Call_Or_Task_Activation_Rep; 10623 10624 ----------------------------- 10625 -- Create_Derived_Type_Rep -- 10626 ----------------------------- 10627 10628 function Create_Derived_Type_Rep 10629 (Typ_Decl : Node_Id) return Scenario_Rep_Record 10630 is 10631 Typ : constant Entity_Id := Defining_Entity (Typ_Decl); 10632 Rec : Scenario_Rep_Record; 10633 10634 begin 10635 Rec.Elab_Checks_OK := False; -- not relevant 10636 Rec.Elab_Warnings_OK := False; -- not relevant 10637 Rec.GM := Ghost_Mode_Of_Entity (Typ); 10638 Rec.SM := SPARK_Mode_Of_Entity (Typ); 10639 Rec.Kind := Derived_Type_Scenario; 10640 Rec.Target := Typ; 10641 10642 return Rec; 10643 end Create_Derived_Type_Rep; 10644 10645 ------------------------ 10646 -- Create_Generic_Rep -- 10647 ------------------------ 10648 10649 function Create_Generic_Rep 10650 (Gen_Id : Entity_Id) return Target_Rep_Record 10651 is 10652 Rec : Target_Rep_Record; 10653 10654 begin 10655 Rec.Kind := Generic_Target; 10656 10657 Spec_And_Body_From_Entity 10658 (Id => Gen_Id, 10659 Body_Decl => Rec.Body_Decl, 10660 Spec_Decl => Rec.Spec_Decl); 10661 10662 return Rec; 10663 end Create_Generic_Rep; 10664 10665 ------------------------------ 10666 -- Create_Instantiation_Rep -- 10667 ------------------------------ 10668 10669 function Create_Instantiation_Rep 10670 (Inst : Node_Id) return Scenario_Rep_Record 10671 is 10672 Rec : Scenario_Rep_Record; 10673 10674 begin 10675 Rec.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Inst); 10676 Rec.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Node (Inst); 10677 Rec.GM := Ghost_Mode_Of_Node (Inst); 10678 Rec.SM := SPARK_Mode_Of_Node (Inst); 10679 Rec.Kind := Instantiation_Scenario; 10680 Rec.Target := Instantiated_Generic (Inst); 10681 10682 return Rec; 10683 end Create_Instantiation_Rep; 10684 10685 ------------------------ 10686 -- Create_Package_Rep -- 10687 ------------------------ 10688 10689 function Create_Package_Rep 10690 (Pack_Id : Entity_Id) return Target_Rep_Record 10691 is 10692 Rec : Target_Rep_Record; 10693 10694 begin 10695 Rec.Kind := Package_Target; 10696 10697 Spec_And_Body_From_Entity 10698 (Id => Pack_Id, 10699 Body_Decl => Rec.Body_Decl, 10700 Spec_Decl => Rec.Spec_Decl); 10701 10702 return Rec; 10703 end Create_Package_Rep; 10704 10705 -------------------------------- 10706 -- Create_Protected_Entry_Rep -- 10707 -------------------------------- 10708 10709 function Create_Protected_Entry_Rep 10710 (PE_Id : Entity_Id) return Target_Rep_Record 10711 is 10712 Prot_Id : constant Entity_Id := Protected_Body_Subprogram (PE_Id); 10713 10714 Barf_Id : Entity_Id; 10715 Dummy : Node_Id; 10716 Rec : Target_Rep_Record; 10717 Spec_Id : Entity_Id; 10718 10719 begin 10720 -- When the entry [family] has already been expanded, it carries both 10721 -- the procedure which emulates the behavior of the entry [family] as 10722 -- well as the barrier function. 10723 10724 if Present (Prot_Id) then 10725 Barf_Id := Barrier_Function (PE_Id); 10726 Spec_Id := Prot_Id; 10727 10728 -- Otherwise no expansion took place 10729 10730 else 10731 Barf_Id := Empty; 10732 Spec_Id := PE_Id; 10733 end if; 10734 10735 Rec.Kind := Subprogram_Target; 10736 10737 Spec_And_Body_From_Entity 10738 (Id => Spec_Id, 10739 Body_Decl => Rec.Body_Decl, 10740 Spec_Decl => Rec.Spec_Decl); 10741 10742 -- Target-specific attributes 10743 10744 if Present (Barf_Id) then 10745 Spec_And_Body_From_Entity 10746 (Id => Barf_Id, 10747 Body_Decl => Rec.Field_1, -- Barrier_Body_Declaration 10748 Spec_Decl => Dummy); 10749 end if; 10750 10751 return Rec; 10752 end Create_Protected_Entry_Rep; 10753 10754 ------------------------------------- 10755 -- Create_Protected_Subprogram_Rep -- 10756 ------------------------------------- 10757 10758 function Create_Protected_Subprogram_Rep 10759 (PS_Id : Entity_Id) return Target_Rep_Record 10760 is 10761 Prot_Id : constant Entity_Id := Protected_Body_Subprogram (PS_Id); 10762 Rec : Target_Rep_Record; 10763 Spec_Id : Entity_Id; 10764 10765 begin 10766 -- When the protected subprogram has already been expanded, it 10767 -- carries the subprogram which seizes the lock and invokes the 10768 -- original statements. 10769 10770 if Present (Prot_Id) then 10771 Spec_Id := Prot_Id; 10772 10773 -- Otherwise no expansion took place 10774 10775 else 10776 Spec_Id := PS_Id; 10777 end if; 10778 10779 Rec.Kind := Subprogram_Target; 10780 10781 Spec_And_Body_From_Entity 10782 (Id => Spec_Id, 10783 Body_Decl => Rec.Body_Decl, 10784 Spec_Decl => Rec.Spec_Decl); 10785 10786 return Rec; 10787 end Create_Protected_Subprogram_Rep; 10788 10789 ------------------------------------- 10790 -- Create_Refined_State_Pragma_Rep -- 10791 ------------------------------------- 10792 10793 function Create_Refined_State_Pragma_Rep 10794 (Prag : Node_Id) return Scenario_Rep_Record 10795 is 10796 Rec : Scenario_Rep_Record; 10797 10798 begin 10799 Rec.Elab_Checks_OK := False; -- not relevant 10800 Rec.Elab_Warnings_OK := False; -- not relevant 10801 Rec.GM := 10802 To_Ghost_Mode (Is_Ignored_Ghost_Pragma (Prag)); 10803 Rec.SM := Is_Off_Or_Not_Specified; 10804 Rec.Kind := Refined_State_Pragma_Scenario; 10805 Rec.Target := Empty; 10806 10807 return Rec; 10808 end Create_Refined_State_Pragma_Rep; 10809 10810 ------------------------- 10811 -- Create_Scenario_Rep -- 10812 ------------------------- 10813 10814 function Create_Scenario_Rep 10815 (N : Node_Id; 10816 In_State : Processing_In_State) return Scenario_Rep_Record 10817 is 10818 pragma Unreferenced (In_State); 10819 10820 Rec : Scenario_Rep_Record; 10821 10822 begin 10823 if Is_Suitable_Access_Taken (N) then 10824 Rec := Create_Access_Taken_Rep (N); 10825 10826 elsif Is_Suitable_Call (N) then 10827 Rec := Create_Call_Or_Task_Activation_Rep (N); 10828 10829 elsif Is_Suitable_Instantiation (N) then 10830 Rec := Create_Instantiation_Rep (N); 10831 10832 elsif Is_Suitable_SPARK_Derived_Type (N) then 10833 Rec := Create_Derived_Type_Rep (N); 10834 10835 elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then 10836 Rec := Create_Refined_State_Pragma_Rep (N); 10837 10838 elsif Is_Suitable_Variable_Assignment (N) then 10839 Rec := Create_Variable_Assignment_Rep (N); 10840 10841 elsif Is_Suitable_Variable_Reference (N) then 10842 Rec := Create_Variable_Reference_Rep (N); 10843 10844 else 10845 pragma Assert (False); 10846 return Rec; 10847 end if; 10848 10849 -- Common scenario attributes 10850 10851 Rec.Level := Find_Enclosing_Level (N); 10852 10853 return Rec; 10854 end Create_Scenario_Rep; 10855 10856 --------------------------- 10857 -- Create_Subprogram_Rep -- 10858 --------------------------- 10859 10860 function Create_Subprogram_Rep 10861 (Subp_Id : Entity_Id) return Target_Rep_Record 10862 is 10863 Rec : Target_Rep_Record; 10864 Spec_Id : Entity_Id; 10865 10866 begin 10867 Spec_Id := Subp_Id; 10868 10869 -- The elaboration target denotes an internal function that returns a 10870 -- constrained array type in a SPARK-to-C compilation. In this case 10871 -- the function receives a corresponding procedure which has an out 10872 -- parameter. The proper body for ABE checks and diagnostics is that 10873 -- of the procedure. 10874 10875 if Ekind (Spec_Id) = E_Function 10876 and then Rewritten_For_C (Spec_Id) 10877 then 10878 Spec_Id := Corresponding_Procedure (Spec_Id); 10879 end if; 10880 10881 Rec.Kind := Subprogram_Target; 10882 10883 Spec_And_Body_From_Entity 10884 (Id => Spec_Id, 10885 Body_Decl => Rec.Body_Decl, 10886 Spec_Decl => Rec.Spec_Decl); 10887 10888 return Rec; 10889 end Create_Subprogram_Rep; 10890 10891 ----------------------- 10892 -- Create_Target_Rep -- 10893 ----------------------- 10894 10895 function Create_Target_Rep 10896 (Id : Entity_Id; 10897 In_State : Processing_In_State) return Target_Rep_Record 10898 is 10899 Rec : Target_Rep_Record; 10900 10901 begin 10902 if Is_Generic_Unit (Id) then 10903 Rec := Create_Generic_Rep (Id); 10904 10905 elsif Is_Protected_Entry (Id) then 10906 Rec := Create_Protected_Entry_Rep (Id); 10907 10908 elsif Is_Protected_Subp (Id) then 10909 Rec := Create_Protected_Subprogram_Rep (Id); 10910 10911 elsif Is_Task_Entry (Id) then 10912 Rec := Create_Task_Entry_Rep (Id); 10913 10914 elsif Is_Task_Type (Id) then 10915 Rec := Create_Task_Rep (Id); 10916 10917 elsif Ekind (Id) in E_Constant | E_Variable then 10918 Rec := Create_Variable_Rep (Id); 10919 10920 elsif Ekind (Id) in E_Entry | E_Function | E_Operator | E_Procedure 10921 then 10922 Rec := Create_Subprogram_Rep (Id); 10923 10924 elsif Ekind (Id) = E_Package then 10925 Rec := Create_Package_Rep (Id); 10926 10927 else 10928 pragma Assert (False); 10929 return Rec; 10930 end if; 10931 10932 -- Common target attributes 10933 10934 Rec.Elab_Checks_OK := Is_Elaboration_Checks_OK_Id (Id); 10935 Rec.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Id (Id); 10936 Rec.GM := Ghost_Mode_Of_Entity (Id); 10937 Rec.SM := SPARK_Mode_Of_Entity (Id); 10938 Rec.Unit := Find_Top_Unit (Id); 10939 Rec.Version := In_State.Representation; 10940 10941 return Rec; 10942 end Create_Target_Rep; 10943 10944 --------------------------- 10945 -- Create_Task_Entry_Rep -- 10946 --------------------------- 10947 10948 function Create_Task_Entry_Rep 10949 (TE_Id : Entity_Id) return Target_Rep_Record 10950 is 10951 Task_Typ : constant Entity_Id := Non_Private_View (Scope (TE_Id)); 10952 Task_Body_Id : constant Entity_Id := Task_Body_Procedure (Task_Typ); 10953 10954 Rec : Target_Rep_Record; 10955 Spec_Id : Entity_Id; 10956 10957 begin 10958 -- The task type has already been expanded, it carries the procedure 10959 -- which emulates the behavior of the task body. 10960 10961 if Present (Task_Body_Id) then 10962 Spec_Id := Task_Body_Id; 10963 10964 -- Otherwise no expansion took place 10965 10966 else 10967 Spec_Id := TE_Id; 10968 end if; 10969 10970 Rec.Kind := Subprogram_Target; 10971 10972 Spec_And_Body_From_Entity 10973 (Id => Spec_Id, 10974 Body_Decl => Rec.Body_Decl, 10975 Spec_Decl => Rec.Spec_Decl); 10976 10977 return Rec; 10978 end Create_Task_Entry_Rep; 10979 10980 --------------------- 10981 -- Create_Task_Rep -- 10982 --------------------- 10983 10984 function Create_Task_Rep 10985 (Task_Typ : Entity_Id) return Target_Rep_Record 10986 is 10987 Task_Body_Id : constant Entity_Id := Task_Body_Procedure (Task_Typ); 10988 10989 Rec : Target_Rep_Record; 10990 Spec_Id : Entity_Id; 10991 10992 begin 10993 -- The task type has already been expanded, it carries the procedure 10994 -- which emulates the behavior of the task body. 10995 10996 if Present (Task_Body_Id) then 10997 Spec_Id := Task_Body_Id; 10998 10999 -- Otherwise no expansion took place 11000 11001 else 11002 Spec_Id := Task_Typ; 11003 end if; 11004 11005 Rec.Kind := Task_Target; 11006 11007 Spec_And_Body_From_Entity 11008 (Id => Spec_Id, 11009 Body_Decl => Rec.Body_Decl, 11010 Spec_Decl => Rec.Spec_Decl); 11011 11012 return Rec; 11013 end Create_Task_Rep; 11014 11015 ------------------------------------ 11016 -- Create_Variable_Assignment_Rep -- 11017 ------------------------------------ 11018 11019 function Create_Variable_Assignment_Rep 11020 (Asmt : Node_Id) return Scenario_Rep_Record 11021 is 11022 Var_Id : constant Entity_Id := Entity (Assignment_Target (Asmt)); 11023 Rec : Scenario_Rep_Record; 11024 11025 begin 11026 Rec.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Asmt); 11027 Rec.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Id (Var_Id); 11028 Rec.GM := Ghost_Mode_Of_Node (Asmt); 11029 Rec.SM := SPARK_Mode_Of_Node (Asmt); 11030 Rec.Kind := Variable_Assignment_Scenario; 11031 Rec.Target := Var_Id; 11032 11033 return Rec; 11034 end Create_Variable_Assignment_Rep; 11035 11036 ----------------------------------- 11037 -- Create_Variable_Reference_Rep -- 11038 ----------------------------------- 11039 11040 function Create_Variable_Reference_Rep 11041 (Ref : Node_Id) return Scenario_Rep_Record 11042 is 11043 Rec : Scenario_Rep_Record; 11044 11045 begin 11046 Rec.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Ref); 11047 Rec.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Node (Ref); 11048 Rec.GM := Ghost_Mode_Of_Node (Ref); 11049 Rec.SM := SPARK_Mode_Of_Node (Ref); 11050 Rec.Kind := Variable_Reference_Scenario; 11051 Rec.Target := Target (Ref); 11052 11053 -- Scenario-specific attributes 11054 11055 Rec.Flag_1 := Is_Read (Ref); -- Is_Read_Reference 11056 11057 return Rec; 11058 end Create_Variable_Reference_Rep; 11059 11060 ------------------------- 11061 -- Create_Variable_Rep -- 11062 ------------------------- 11063 11064 function Create_Variable_Rep 11065 (Var_Id : Entity_Id) return Target_Rep_Record 11066 is 11067 Rec : Target_Rep_Record; 11068 11069 begin 11070 Rec.Kind := Variable_Target; 11071 11072 -- Target-specific attributes 11073 11074 Rec.Field_1 := Declaration_Node (Var_Id); -- Variable_Declaration 11075 11076 return Rec; 11077 end Create_Variable_Rep; 11078 11079 ------------- 11080 -- Destroy -- 11081 ------------- 11082 11083 procedure Destroy (S_Id : in out Scenario_Rep_Id) is 11084 pragma Unreferenced (S_Id); 11085 begin 11086 null; 11087 end Destroy; 11088 11089 ------------- 11090 -- Destroy -- 11091 ------------- 11092 11093 procedure Destroy (T_Id : in out Target_Rep_Id) is 11094 pragma Unreferenced (T_Id); 11095 begin 11096 null; 11097 end Destroy; 11098 11099 -------------------------------- 11100 -- Disable_Elaboration_Checks -- 11101 -------------------------------- 11102 11103 procedure Disable_Elaboration_Checks (S_Id : Scenario_Rep_Id) is 11104 pragma Assert (Present (S_Id)); 11105 begin 11106 Scenario_Reps.Table (S_Id).Elab_Checks_OK := False; 11107 end Disable_Elaboration_Checks; 11108 11109 -------------------------------- 11110 -- Disable_Elaboration_Checks -- 11111 -------------------------------- 11112 11113 procedure Disable_Elaboration_Checks (T_Id : Target_Rep_Id) is 11114 pragma Assert (Present (T_Id)); 11115 begin 11116 Target_Reps.Table (T_Id).Elab_Checks_OK := False; 11117 end Disable_Elaboration_Checks; 11118 11119 --------------------------- 11120 -- Elaboration_Checks_OK -- 11121 --------------------------- 11122 11123 function Elaboration_Checks_OK (S_Id : Scenario_Rep_Id) return Boolean is 11124 pragma Assert (Present (S_Id)); 11125 begin 11126 return Scenario_Reps.Table (S_Id).Elab_Checks_OK; 11127 end Elaboration_Checks_OK; 11128 11129 --------------------------- 11130 -- Elaboration_Checks_OK -- 11131 --------------------------- 11132 11133 function Elaboration_Checks_OK (T_Id : Target_Rep_Id) return Boolean is 11134 pragma Assert (Present (T_Id)); 11135 begin 11136 return Target_Reps.Table (T_Id).Elab_Checks_OK; 11137 end Elaboration_Checks_OK; 11138 11139 ----------------------------- 11140 -- Elaboration_Warnings_OK -- 11141 ----------------------------- 11142 11143 function Elaboration_Warnings_OK 11144 (S_Id : Scenario_Rep_Id) return Boolean 11145 is 11146 pragma Assert (Present (S_Id)); 11147 begin 11148 return Scenario_Reps.Table (S_Id).Elab_Warnings_OK; 11149 end Elaboration_Warnings_OK; 11150 11151 ----------------------------- 11152 -- Elaboration_Warnings_OK -- 11153 ----------------------------- 11154 11155 function Elaboration_Warnings_OK (T_Id : Target_Rep_Id) return Boolean is 11156 pragma Assert (Present (T_Id)); 11157 begin 11158 return Target_Reps.Table (T_Id).Elab_Warnings_OK; 11159 end Elaboration_Warnings_OK; 11160 11161 -------------------------------------- 11162 -- Finalize_Internal_Representation -- 11163 -------------------------------------- 11164 11165 procedure Finalize_Internal_Representation is 11166 begin 11167 ETT_Map.Destroy (Entity_To_Target_Map); 11168 NTS_Map.Destroy (Node_To_Scenario_Map); 11169 end Finalize_Internal_Representation; 11170 11171 ------------------- 11172 -- Ghost_Mode_Of -- 11173 ------------------- 11174 11175 function Ghost_Mode_Of 11176 (S_Id : Scenario_Rep_Id) return Extended_Ghost_Mode 11177 is 11178 pragma Assert (Present (S_Id)); 11179 begin 11180 return Scenario_Reps.Table (S_Id).GM; 11181 end Ghost_Mode_Of; 11182 11183 ------------------- 11184 -- Ghost_Mode_Of -- 11185 ------------------- 11186 11187 function Ghost_Mode_Of 11188 (T_Id : Target_Rep_Id) return Extended_Ghost_Mode 11189 is 11190 pragma Assert (Present (T_Id)); 11191 begin 11192 return Target_Reps.Table (T_Id).GM; 11193 end Ghost_Mode_Of; 11194 11195 -------------------------- 11196 -- Ghost_Mode_Of_Entity -- 11197 -------------------------- 11198 11199 function Ghost_Mode_Of_Entity 11200 (Id : Entity_Id) return Extended_Ghost_Mode 11201 is 11202 begin 11203 return To_Ghost_Mode (Is_Ignored_Ghost_Entity (Id)); 11204 end Ghost_Mode_Of_Entity; 11205 11206 ------------------------ 11207 -- Ghost_Mode_Of_Node -- 11208 ------------------------ 11209 11210 function Ghost_Mode_Of_Node (N : Node_Id) return Extended_Ghost_Mode is 11211 begin 11212 return To_Ghost_Mode (Is_Ignored_Ghost_Node (N)); 11213 end Ghost_Mode_Of_Node; 11214 11215 ---------------------------------------- 11216 -- Initialize_Internal_Representation -- 11217 ---------------------------------------- 11218 11219 procedure Initialize_Internal_Representation is 11220 begin 11221 Entity_To_Target_Map := ETT_Map.Create (500); 11222 Node_To_Scenario_Map := NTS_Map.Create (500); 11223 end Initialize_Internal_Representation; 11224 11225 ------------------------- 11226 -- Is_Dispatching_Call -- 11227 ------------------------- 11228 11229 function Is_Dispatching_Call (S_Id : Scenario_Rep_Id) return Boolean is 11230 pragma Assert (Present (S_Id)); 11231 pragma Assert (Kind (S_Id) = Call_Scenario); 11232 11233 begin 11234 return Scenario_Reps.Table (S_Id).Flag_1; 11235 end Is_Dispatching_Call; 11236 11237 ----------------------- 11238 -- Is_Read_Reference -- 11239 ----------------------- 11240 11241 function Is_Read_Reference (S_Id : Scenario_Rep_Id) return Boolean is 11242 pragma Assert (Present (S_Id)); 11243 pragma Assert (Kind (S_Id) = Variable_Reference_Scenario); 11244 11245 begin 11246 return Scenario_Reps.Table (S_Id).Flag_1; 11247 end Is_Read_Reference; 11248 11249 ---------- 11250 -- Kind -- 11251 ---------- 11252 11253 function Kind (S_Id : Scenario_Rep_Id) return Scenario_Kind is 11254 pragma Assert (Present (S_Id)); 11255 begin 11256 return Scenario_Reps.Table (S_Id).Kind; 11257 end Kind; 11258 11259 ---------- 11260 -- Kind -- 11261 ---------- 11262 11263 function Kind (T_Id : Target_Rep_Id) return Target_Kind is 11264 pragma Assert (Present (T_Id)); 11265 begin 11266 return Target_Reps.Table (T_Id).Kind; 11267 end Kind; 11268 11269 ----------- 11270 -- Level -- 11271 ----------- 11272 11273 function Level (S_Id : Scenario_Rep_Id) return Enclosing_Level_Kind is 11274 pragma Assert (Present (S_Id)); 11275 begin 11276 return Scenario_Reps.Table (S_Id).Level; 11277 end Level; 11278 11279 ------------- 11280 -- Present -- 11281 ------------- 11282 11283 function Present (S_Id : Scenario_Rep_Id) return Boolean is 11284 begin 11285 return S_Id /= No_Scenario_Rep; 11286 end Present; 11287 11288 ------------- 11289 -- Present -- 11290 ------------- 11291 11292 function Present (T_Id : Target_Rep_Id) return Boolean is 11293 begin 11294 return T_Id /= No_Target_Rep; 11295 end Present; 11296 11297 -------------------------------- 11298 -- Scenario_Representation_Of -- 11299 -------------------------------- 11300 11301 function Scenario_Representation_Of 11302 (N : Node_Id; 11303 In_State : Processing_In_State) return Scenario_Rep_Id 11304 is 11305 S_Id : Scenario_Rep_Id; 11306 11307 begin 11308 S_Id := NTS_Map.Get (Node_To_Scenario_Map, N); 11309 11310 -- The elaboration scenario lacks a representation. This indicates 11311 -- that the scenario is encountered for the first time. Create the 11312 -- representation of it. 11313 11314 if not Present (S_Id) then 11315 Scenario_Reps.Append (Create_Scenario_Rep (N, In_State)); 11316 S_Id := Scenario_Reps.Last; 11317 11318 -- Associate the internal representation with the elaboration 11319 -- scenario. 11320 11321 NTS_Map.Put (Node_To_Scenario_Map, N, S_Id); 11322 end if; 11323 11324 pragma Assert (Present (S_Id)); 11325 11326 return S_Id; 11327 end Scenario_Representation_Of; 11328 11329 -------------------------------- 11330 -- Set_Activated_Task_Objects -- 11331 -------------------------------- 11332 11333 procedure Set_Activated_Task_Objects 11334 (S_Id : Scenario_Rep_Id; 11335 Task_Objs : NE_List.Doubly_Linked_List) 11336 is 11337 pragma Assert (Present (S_Id)); 11338 pragma Assert (Kind (S_Id) = Task_Activation_Scenario); 11339 11340 begin 11341 Scenario_Reps.Table (S_Id).List_1 := Task_Objs; 11342 end Set_Activated_Task_Objects; 11343 11344 ----------------------------- 11345 -- Set_Activated_Task_Type -- 11346 ----------------------------- 11347 11348 procedure Set_Activated_Task_Type 11349 (S_Id : Scenario_Rep_Id; 11350 Task_Typ : Entity_Id) 11351 is 11352 pragma Assert (Present (S_Id)); 11353 pragma Assert (Kind (S_Id) = Task_Activation_Scenario); 11354 11355 begin 11356 Scenario_Reps.Table (S_Id).Field_1 := Task_Typ; 11357 end Set_Activated_Task_Type; 11358 11359 ------------------- 11360 -- SPARK_Mode_Of -- 11361 ------------------- 11362 11363 function SPARK_Mode_Of 11364 (S_Id : Scenario_Rep_Id) return Extended_SPARK_Mode 11365 is 11366 pragma Assert (Present (S_Id)); 11367 begin 11368 return Scenario_Reps.Table (S_Id).SM; 11369 end SPARK_Mode_Of; 11370 11371 ------------------- 11372 -- SPARK_Mode_Of -- 11373 ------------------- 11374 11375 function SPARK_Mode_Of 11376 (T_Id : Target_Rep_Id) return Extended_SPARK_Mode 11377 is 11378 pragma Assert (Present (T_Id)); 11379 begin 11380 return Target_Reps.Table (T_Id).SM; 11381 end SPARK_Mode_Of; 11382 11383 -------------------------- 11384 -- SPARK_Mode_Of_Entity -- 11385 -------------------------- 11386 11387 function SPARK_Mode_Of_Entity 11388 (Id : Entity_Id) return Extended_SPARK_Mode 11389 is 11390 Prag : constant Node_Id := SPARK_Pragma (Id); 11391 11392 begin 11393 return 11394 To_SPARK_Mode 11395 (Present (Prag) 11396 and then Get_SPARK_Mode_From_Annotation (Prag) = On); 11397 end SPARK_Mode_Of_Entity; 11398 11399 ------------------------ 11400 -- SPARK_Mode_Of_Node -- 11401 ------------------------ 11402 11403 function SPARK_Mode_Of_Node (N : Node_Id) return Extended_SPARK_Mode is 11404 begin 11405 return To_SPARK_Mode (Is_SPARK_Mode_On_Node (N)); 11406 end SPARK_Mode_Of_Node; 11407 11408 ---------------------- 11409 -- Spec_Declaration -- 11410 ---------------------- 11411 11412 function Spec_Declaration (T_Id : Target_Rep_Id) return Node_Id is 11413 pragma Assert (Present (T_Id)); 11414 begin 11415 return Target_Reps.Table (T_Id).Spec_Decl; 11416 end Spec_Declaration; 11417 11418 ------------ 11419 -- Target -- 11420 ------------ 11421 11422 function Target (S_Id : Scenario_Rep_Id) return Entity_Id is 11423 pragma Assert (Present (S_Id)); 11424 begin 11425 return Scenario_Reps.Table (S_Id).Target; 11426 end Target; 11427 11428 ------------------------------ 11429 -- Target_Representation_Of -- 11430 ------------------------------ 11431 11432 function Target_Representation_Of 11433 (Id : Entity_Id; 11434 In_State : Processing_In_State) return Target_Rep_Id 11435 is 11436 T_Id : Target_Rep_Id; 11437 11438 begin 11439 T_Id := ETT_Map.Get (Entity_To_Target_Map, Id); 11440 11441 -- The elaboration target lacks an internal representation. This 11442 -- indicates that the target is encountered for the first time. 11443 -- Create the internal representation of it. 11444 11445 if not Present (T_Id) then 11446 Target_Reps.Append (Create_Target_Rep (Id, In_State)); 11447 T_Id := Target_Reps.Last; 11448 11449 -- Associate the internal representation with the elaboration 11450 -- target. 11451 11452 ETT_Map.Put (Entity_To_Target_Map, Id, T_Id); 11453 11454 -- The Processing phase is working with a partially analyzed tree, 11455 -- where various attributes become available as analysis continues. 11456 -- This case arrises in the context of guaranteed ABE processing. 11457 -- Update the existing representation by including new attributes. 11458 11459 elsif In_State.Representation = Inconsistent_Representation then 11460 Target_Reps.Table (T_Id) := Create_Target_Rep (Id, In_State); 11461 11462 -- Otherwise the Processing phase imposes a particular representation 11463 -- version which is not satisfied by the target. This case arrises 11464 -- when the Processing phase switches from guaranteed ABE checks and 11465 -- diagnostics to some other mode of operation. Update the existing 11466 -- representation to include all attributes. 11467 11468 elsif In_State.Representation /= Version (T_Id) then 11469 Target_Reps.Table (T_Id) := Create_Target_Rep (Id, In_State); 11470 end if; 11471 11472 pragma Assert (Present (T_Id)); 11473 11474 return T_Id; 11475 end Target_Representation_Of; 11476 11477 ------------------- 11478 -- To_Ghost_Mode -- 11479 ------------------- 11480 11481 function To_Ghost_Mode 11482 (Ignored_Status : Boolean) return Extended_Ghost_Mode 11483 is 11484 begin 11485 if Ignored_Status then 11486 return Is_Ignored; 11487 else 11488 return Is_Checked_Or_Not_Specified; 11489 end if; 11490 end To_Ghost_Mode; 11491 11492 ------------------- 11493 -- To_SPARK_Mode -- 11494 ------------------- 11495 11496 function To_SPARK_Mode 11497 (On_Status : Boolean) return Extended_SPARK_Mode 11498 is 11499 begin 11500 if On_Status then 11501 return Is_On; 11502 else 11503 return Is_Off_Or_Not_Specified; 11504 end if; 11505 end To_SPARK_Mode; 11506 11507 ---------- 11508 -- Unit -- 11509 ---------- 11510 11511 function Unit (T_Id : Target_Rep_Id) return Entity_Id is 11512 pragma Assert (Present (T_Id)); 11513 begin 11514 return Target_Reps.Table (T_Id).Unit; 11515 end Unit; 11516 11517 -------------------------- 11518 -- Variable_Declaration -- 11519 -------------------------- 11520 11521 function Variable_Declaration (T_Id : Target_Rep_Id) return Node_Id is 11522 pragma Assert (Present (T_Id)); 11523 pragma Assert (Kind (T_Id) = Variable_Target); 11524 11525 begin 11526 return Target_Reps.Table (T_Id).Field_1; 11527 end Variable_Declaration; 11528 11529 ------------- 11530 -- Version -- 11531 ------------- 11532 11533 function Version (T_Id : Target_Rep_Id) return Representation_Kind is 11534 pragma Assert (Present (T_Id)); 11535 begin 11536 return Target_Reps.Table (T_Id).Version; 11537 end Version; 11538 end Internal_Representation; 11539 11540 ---------------------- 11541 -- Invocation_Graph -- 11542 ---------------------- 11543 11544 package body Invocation_Graph is 11545 11546 ----------- 11547 -- Types -- 11548 ----------- 11549 11550 -- The following type represents simplified version of an invocation 11551 -- relation. 11552 11553 type Invoker_Target_Relation is record 11554 Invoker : Entity_Id := Empty; 11555 Target : Entity_Id := Empty; 11556 end record; 11557 11558 -- The following variables define the entities of the dummy elaboration 11559 -- procedures used as origins of library level paths. 11560 11561 Elab_Body_Id : Entity_Id := Empty; 11562 Elab_Spec_Id : Entity_Id := Empty; 11563 11564 --------------------- 11565 -- Data structures -- 11566 --------------------- 11567 11568 -- The following set contains all declared invocation constructs. It 11569 -- ensures that the same construct is not declared multiple times in 11570 -- the ALI file of the main unit. 11571 11572 Saved_Constructs_Set : NE_Set.Membership_Set := NE_Set.Nil; 11573 11574 function Hash (Key : Invoker_Target_Relation) return Bucket_Range_Type; 11575 -- Obtain the hash value of pair Key 11576 11577 package IR_Set is new Membership_Sets 11578 (Element_Type => Invoker_Target_Relation, 11579 "=" => "=", 11580 Hash => Hash); 11581 11582 -- The following set contains all recorded simple invocation relations. 11583 -- It ensures that multiple relations involving the same invoker and 11584 -- target do not appear in the ALI file of the main unit. 11585 11586 Saved_Relations_Set : IR_Set.Membership_Set := IR_Set.Nil; 11587 11588 -------------- 11589 -- Builders -- 11590 -------------- 11591 11592 function Signature_Of (Id : Entity_Id) return Invocation_Signature_Id; 11593 pragma Inline (Signature_Of); 11594 -- Obtain the invication signature id of arbitrary entity Id 11595 11596 ----------------------- 11597 -- Local subprograms -- 11598 ----------------------- 11599 11600 procedure Build_Elaborate_Body_Procedure; 11601 pragma Inline (Build_Elaborate_Body_Procedure); 11602 -- Create a dummy elaborate body procedure and store its entity in 11603 -- Elab_Body_Id. 11604 11605 procedure Build_Elaborate_Procedure 11606 (Proc_Id : out Entity_Id; 11607 Proc_Nam : Name_Id; 11608 Loc : Source_Ptr); 11609 pragma Inline (Build_Elaborate_Procedure); 11610 -- Create a dummy elaborate procedure with name Proc_Nam and source 11611 -- location Loc. The entity is returned in Proc_Id. 11612 11613 procedure Build_Elaborate_Spec_Procedure; 11614 pragma Inline (Build_Elaborate_Spec_Procedure); 11615 -- Create a dummy elaborate spec procedure and store its entity in 11616 -- Elab_Spec_Id. 11617 11618 function Build_Subprogram_Invocation 11619 (Subp_Id : Entity_Id) return Node_Id; 11620 pragma Inline (Build_Subprogram_Invocation); 11621 -- Create a dummy call marker that invokes subprogram Subp_Id 11622 11623 function Build_Task_Activation 11624 (Task_Typ : Entity_Id; 11625 In_State : Processing_In_State) return Node_Id; 11626 pragma Inline (Build_Task_Activation); 11627 -- Create a dummy call marker that activates an anonymous task object of 11628 -- type Task_Typ. 11629 11630 procedure Declare_Invocation_Construct 11631 (Constr_Id : Entity_Id; 11632 In_State : Processing_In_State); 11633 pragma Inline (Declare_Invocation_Construct); 11634 -- Declare invocation construct Constr_Id by creating a declaration for 11635 -- it in the ALI file of the main unit. In_State is the current state of 11636 -- the Processing phase. 11637 11638 function Invocation_Graph_Recording_OK return Boolean; 11639 pragma Inline (Invocation_Graph_Recording_OK); 11640 -- Determine whether the invocation graph can be recorded 11641 11642 function Is_Invocation_Scenario (N : Node_Id) return Boolean; 11643 pragma Inline (Is_Invocation_Scenario); 11644 -- Determine whether node N is a suitable scenario for invocation graph 11645 -- recording purposes. 11646 11647 function Is_Invocation_Target (Id : Entity_Id) return Boolean; 11648 pragma Inline (Is_Invocation_Target); 11649 -- Determine whether arbitrary entity Id denotes an invocation target 11650 11651 function Is_Saved_Construct (Constr : Entity_Id) return Boolean; 11652 pragma Inline (Is_Saved_Construct); 11653 -- Determine whether invocation construct Constr has already been 11654 -- declared in the ALI file of the main unit. 11655 11656 function Is_Saved_Relation 11657 (Rel : Invoker_Target_Relation) return Boolean; 11658 pragma Inline (Is_Saved_Relation); 11659 -- Determine whether simple invocation relation Rel has already been 11660 -- recorded in the ALI file of the main unit. 11661 11662 procedure Process_Declarations 11663 (Decls : List_Id; 11664 In_State : Processing_In_State); 11665 pragma Inline (Process_Declarations); 11666 -- Process declaration list Decls by processing all invocation scenarios 11667 -- within it. 11668 11669 procedure Process_Freeze_Node 11670 (Fnode : Node_Id; 11671 In_State : Processing_In_State); 11672 pragma Inline (Process_Freeze_Node); 11673 -- Process freeze node Fnode by processing all invocation scenarios in 11674 -- its Actions list. 11675 11676 procedure Process_Invocation_Activation 11677 (Call : Node_Id; 11678 Call_Rep : Scenario_Rep_Id; 11679 Obj_Id : Entity_Id; 11680 Obj_Rep : Target_Rep_Id; 11681 Task_Typ : Entity_Id; 11682 Task_Rep : Target_Rep_Id; 11683 In_State : Processing_In_State); 11684 pragma Inline (Process_Invocation_Activation); 11685 -- Process activation call Call which activates object Obj_Id of task 11686 -- type Task_Typ by processing all invocation scenarios within the task 11687 -- body. Call_Rep is the representation of the call. Obj_Rep denotes the 11688 -- representation of the object. Task_Rep is the representation of the 11689 -- task type. In_State is the current state of the Processing phase. 11690 11691 procedure Process_Invocation_Body_Scenarios; 11692 pragma Inline (Process_Invocation_Body_Scenarios); 11693 -- Process all library level body scenarios 11694 11695 procedure Process_Invocation_Call 11696 (Call : Node_Id; 11697 Call_Rep : Scenario_Rep_Id; 11698 In_State : Processing_In_State); 11699 pragma Inline (Process_Invocation_Call); 11700 -- Process invocation call scenario Call with representation Call_Rep. 11701 -- In_State is the current state of the Processing phase. 11702 11703 procedure Process_Invocation_Instantiation 11704 (Inst : Node_Id; 11705 Inst_Rep : Scenario_Rep_Id; 11706 In_State : Processing_In_State); 11707 pragma Inline (Process_Invocation_Instantiation); 11708 -- Process invocation instantiation scenario Inst with representation 11709 -- Inst_Rep. In_State is the current state of the Processing phase. 11710 11711 procedure Process_Invocation_Scenario 11712 (N : Node_Id; 11713 In_State : Processing_In_State); 11714 pragma Inline (Process_Invocation_Scenario); 11715 -- Process single invocation scenario N. In_State is the current state 11716 -- of the Processing phase. 11717 11718 procedure Process_Invocation_Scenarios 11719 (Iter : in out NE_Set.Iterator; 11720 In_State : Processing_In_State); 11721 pragma Inline (Process_Invocation_Scenarios); 11722 -- Process all invocation scenarios obtained via iterator Iter. In_State 11723 -- is the current state of the Processing phase. 11724 11725 procedure Process_Invocation_Spec_Scenarios; 11726 pragma Inline (Process_Invocation_Spec_Scenarios); 11727 -- Process all library level spec scenarios 11728 11729 procedure Process_Main_Unit; 11730 pragma Inline (Process_Main_Unit); 11731 -- Process all invocation scenarios within the main unit 11732 11733 procedure Process_Package_Declaration 11734 (Pack_Decl : Node_Id; 11735 In_State : Processing_In_State); 11736 pragma Inline (Process_Package_Declaration); 11737 -- Process package declaration Pack_Decl by processing all invocation 11738 -- scenarios in its visible and private declarations. If the main unit 11739 -- contains a generic, the declarations of the body are also examined. 11740 -- In_State is the current state of the Processing phase. 11741 11742 procedure Process_Protected_Type_Declaration 11743 (Prot_Decl : Node_Id; 11744 In_State : Processing_In_State); 11745 pragma Inline (Process_Protected_Type_Declaration); 11746 -- Process the declarations of protected type Prot_Decl. In_State is the 11747 -- current state of the Processing phase. 11748 11749 procedure Process_Subprogram_Declaration 11750 (Subp_Decl : Node_Id; 11751 In_State : Processing_In_State); 11752 pragma Inline (Process_Subprogram_Declaration); 11753 -- Process subprogram declaration Subp_Decl by processing all invocation 11754 -- scenarios within its body. In_State denotes the current state of the 11755 -- Processing phase. 11756 11757 procedure Process_Subprogram_Instantiation 11758 (Inst : Node_Id; 11759 In_State : Processing_In_State); 11760 pragma Inline (Process_Subprogram_Instantiation); 11761 -- Process subprogram instantiation Inst. In_State is the current state 11762 -- of the Processing phase. 11763 11764 procedure Process_Task_Type_Declaration 11765 (Task_Decl : Node_Id; 11766 In_State : Processing_In_State); 11767 pragma Inline (Process_Task_Type_Declaration); 11768 -- Process task declaration Task_Decl by processing all invocation 11769 -- scenarios within its body. In_State is the current state of the 11770 -- Processing phase. 11771 11772 procedure Record_Full_Invocation_Path (In_State : Processing_In_State); 11773 pragma Inline (Record_Full_Invocation_Path); 11774 -- Record all relations between scenario pairs found in the stack of 11775 -- active scenarios. In_State is the current state of the Processing 11776 -- phase. 11777 11778 procedure Record_Invocation_Graph_Encoding; 11779 pragma Inline (Record_Invocation_Graph_Encoding); 11780 -- Record the encoding format used to capture information related to 11781 -- invocation constructs and relations. 11782 11783 procedure Record_Invocation_Path (In_State : Processing_In_State); 11784 pragma Inline (Record_Invocation_Path); 11785 -- Record the invocation relations found within the path represented in 11786 -- the active scenario stack. In_State denotes the current state of the 11787 -- Processing phase. 11788 11789 procedure Record_Simple_Invocation_Path (In_State : Processing_In_State); 11790 pragma Inline (Record_Simple_Invocation_Path); 11791 -- Record a single relation from the start to the end of the stack of 11792 -- active scenarios. In_State is the current state of the Processing 11793 -- phase. 11794 11795 procedure Record_Invocation_Relation 11796 (Invk_Id : Entity_Id; 11797 Targ_Id : Entity_Id; 11798 In_State : Processing_In_State); 11799 pragma Inline (Record_Invocation_Relation); 11800 -- Record an invocation relation with invoker Invk_Id and target Targ_Id 11801 -- by creating an entry for it in the ALI file of the main unit. Formal 11802 -- In_State denotes the current state of the Processing phase. 11803 11804 procedure Set_Is_Saved_Construct 11805 (Constr : Entity_Id; 11806 Val : Boolean := True); 11807 pragma Inline (Set_Is_Saved_Construct); 11808 -- Mark invocation construct Constr as declared in the ALI file of the 11809 -- main unit depending on value Val. 11810 11811 procedure Set_Is_Saved_Relation 11812 (Rel : Invoker_Target_Relation; 11813 Val : Boolean := True); 11814 pragma Inline (Set_Is_Saved_Relation); 11815 -- Mark simple invocation relation Rel as recorded in the ALI file of 11816 -- the main unit depending on value Val. 11817 11818 function Target_Of 11819 (Pos : Active_Scenario_Pos; 11820 In_State : Processing_In_State) return Entity_Id; 11821 pragma Inline (Target_Of); 11822 -- Given position within the active scenario stack Pos, obtain the 11823 -- target of the indicated scenario. In_State is the current state 11824 -- of the Processing phase. 11825 11826 procedure Traverse_Invocation_Body 11827 (N : Node_Id; 11828 In_State : Processing_In_State); 11829 pragma Inline (Traverse_Invocation_Body); 11830 -- Traverse subprogram body N looking for suitable invocation scenarios 11831 -- that need to be processed for invocation graph recording purposes. 11832 -- In_State is the current state of the Processing phase. 11833 11834 procedure Write_Invocation_Path (In_State : Processing_In_State); 11835 pragma Inline (Write_Invocation_Path); 11836 -- Write out a path represented by the active scenario on the stack to 11837 -- standard output. In_State denotes the current state of the Processing 11838 -- phase. 11839 11840 ------------------------------------ 11841 -- Build_Elaborate_Body_Procedure -- 11842 ------------------------------------ 11843 11844 procedure Build_Elaborate_Body_Procedure is 11845 Body_Decl : Node_Id; 11846 Spec_Decl : Node_Id; 11847 11848 begin 11849 -- Nothing to do when a previous call already created the procedure 11850 11851 if Present (Elab_Body_Id) then 11852 return; 11853 end if; 11854 11855 Spec_And_Body_From_Entity 11856 (Id => Main_Unit_Entity, 11857 Body_Decl => Body_Decl, 11858 Spec_Decl => Spec_Decl); 11859 11860 pragma Assert (Present (Body_Decl)); 11861 11862 Build_Elaborate_Procedure 11863 (Proc_Id => Elab_Body_Id, 11864 Proc_Nam => Name_B, 11865 Loc => Sloc (Body_Decl)); 11866 end Build_Elaborate_Body_Procedure; 11867 11868 ------------------------------- 11869 -- Build_Elaborate_Procedure -- 11870 ------------------------------- 11871 11872 procedure Build_Elaborate_Procedure 11873 (Proc_Id : out Entity_Id; 11874 Proc_Nam : Name_Id; 11875 Loc : Source_Ptr) 11876 is 11877 Proc_Decl : Node_Id; 11878 pragma Unreferenced (Proc_Decl); 11879 11880 begin 11881 Proc_Id := Make_Defining_Identifier (Loc, Proc_Nam); 11882 11883 -- Partially decorate the elaboration procedure because it will not 11884 -- be insertred into the tree and analyzed. 11885 11886 Set_Ekind (Proc_Id, E_Procedure); 11887 Set_Etype (Proc_Id, Standard_Void_Type); 11888 Set_Scope (Proc_Id, Unique_Entity (Main_Unit_Entity)); 11889 11890 -- Create a dummy declaration for the elaboration procedure. The 11891 -- declaration does not need to be syntactically legal, but must 11892 -- carry an accurate source location. 11893 11894 Proc_Decl := 11895 Make_Subprogram_Body (Loc, 11896 Specification => 11897 Make_Procedure_Specification (Loc, 11898 Defining_Unit_Name => Proc_Id), 11899 Declarations => No_List, 11900 Handled_Statement_Sequence => Empty); 11901 end Build_Elaborate_Procedure; 11902 11903 ------------------------------------ 11904 -- Build_Elaborate_Spec_Procedure -- 11905 ------------------------------------ 11906 11907 procedure Build_Elaborate_Spec_Procedure is 11908 Body_Decl : Node_Id; 11909 Spec_Decl : Node_Id; 11910 11911 begin 11912 -- Nothing to do when a previous call already created the procedure 11913 11914 if Present (Elab_Spec_Id) then 11915 return; 11916 end if; 11917 11918 Spec_And_Body_From_Entity 11919 (Id => Main_Unit_Entity, 11920 Body_Decl => Body_Decl, 11921 Spec_Decl => Spec_Decl); 11922 11923 pragma Assert (Present (Spec_Decl)); 11924 11925 Build_Elaborate_Procedure 11926 (Proc_Id => Elab_Spec_Id, 11927 Proc_Nam => Name_S, 11928 Loc => Sloc (Spec_Decl)); 11929 end Build_Elaborate_Spec_Procedure; 11930 11931 --------------------------------- 11932 -- Build_Subprogram_Invocation -- 11933 --------------------------------- 11934 11935 function Build_Subprogram_Invocation 11936 (Subp_Id : Entity_Id) return Node_Id 11937 is 11938 Marker : constant Node_Id := Make_Call_Marker (Sloc (Subp_Id)); 11939 Subp_Decl : constant Node_Id := Unit_Declaration_Node (Subp_Id); 11940 11941 begin 11942 -- Create a dummy call marker which invokes the subprogram 11943 11944 Set_Is_Declaration_Level_Node (Marker, False); 11945 Set_Is_Dispatching_Call (Marker, False); 11946 Set_Is_Elaboration_Checks_OK_Node (Marker, False); 11947 Set_Is_Elaboration_Warnings_OK_Node (Marker, False); 11948 Set_Is_Ignored_Ghost_Node (Marker, False); 11949 Set_Is_Preelaborable_Call (Marker, False); 11950 Set_Is_Source_Call (Marker, False); 11951 Set_Is_SPARK_Mode_On_Node (Marker, False); 11952 11953 -- Invoke the uniform canonical entity of the subprogram 11954 11955 Set_Target (Marker, Canonical_Subprogram (Subp_Id)); 11956 11957 -- Partially insert the marker into the tree 11958 11959 Set_Parent (Marker, Parent (Subp_Decl)); 11960 11961 return Marker; 11962 end Build_Subprogram_Invocation; 11963 11964 --------------------------- 11965 -- Build_Task_Activation -- 11966 --------------------------- 11967 11968 function Build_Task_Activation 11969 (Task_Typ : Entity_Id; 11970 In_State : Processing_In_State) return Node_Id 11971 is 11972 Loc : constant Source_Ptr := Sloc (Task_Typ); 11973 Marker : constant Node_Id := Make_Call_Marker (Loc); 11974 Task_Decl : constant Node_Id := Unit_Declaration_Node (Task_Typ); 11975 11976 Activ_Id : Entity_Id; 11977 Marker_Rep_Id : Scenario_Rep_Id; 11978 Task_Obj : Entity_Id; 11979 Task_Objs : NE_List.Doubly_Linked_List; 11980 11981 begin 11982 -- Create a dummy call marker which activates some tasks 11983 11984 Set_Is_Declaration_Level_Node (Marker, False); 11985 Set_Is_Dispatching_Call (Marker, False); 11986 Set_Is_Elaboration_Checks_OK_Node (Marker, False); 11987 Set_Is_Elaboration_Warnings_OK_Node (Marker, False); 11988 Set_Is_Ignored_Ghost_Node (Marker, False); 11989 Set_Is_Preelaborable_Call (Marker, False); 11990 Set_Is_Source_Call (Marker, False); 11991 Set_Is_SPARK_Mode_On_Node (Marker, False); 11992 11993 -- Invoke the appropriate version of Activate_Tasks 11994 11995 if Restricted_Profile then 11996 Activ_Id := RTE (RE_Activate_Restricted_Tasks); 11997 else 11998 Activ_Id := RTE (RE_Activate_Tasks); 11999 end if; 12000 12001 Set_Target (Marker, Activ_Id); 12002 12003 -- Partially insert the marker into the tree 12004 12005 Set_Parent (Marker, Parent (Task_Decl)); 12006 12007 -- Create a dummy task object. Partially decorate the object because 12008 -- it will not be inserted into the tree and analyzed. 12009 12010 Task_Obj := Make_Temporary (Loc, 'T'); 12011 Set_Ekind (Task_Obj, E_Variable); 12012 Set_Etype (Task_Obj, Task_Typ); 12013 12014 -- Associate the dummy task object with the activation call 12015 12016 Task_Objs := NE_List.Create; 12017 NE_List.Append (Task_Objs, Task_Obj); 12018 12019 Marker_Rep_Id := Scenario_Representation_Of (Marker, In_State); 12020 Set_Activated_Task_Objects (Marker_Rep_Id, Task_Objs); 12021 Set_Activated_Task_Type (Marker_Rep_Id, Task_Typ); 12022 12023 return Marker; 12024 end Build_Task_Activation; 12025 12026 ---------------------------------- 12027 -- Declare_Invocation_Construct -- 12028 ---------------------------------- 12029 12030 procedure Declare_Invocation_Construct 12031 (Constr_Id : Entity_Id; 12032 In_State : Processing_In_State) 12033 is 12034 function Body_Placement_Of 12035 (Id : Entity_Id) return Declaration_Placement_Kind; 12036 pragma Inline (Body_Placement_Of); 12037 -- Obtain the placement of arbitrary entity Id's body 12038 12039 function Declaration_Placement_Of_Node 12040 (N : Node_Id) return Declaration_Placement_Kind; 12041 pragma Inline (Declaration_Placement_Of_Node); 12042 -- Obtain the placement of arbitrary node N 12043 12044 function Kind_Of (Id : Entity_Id) return Invocation_Construct_Kind; 12045 pragma Inline (Kind_Of); 12046 -- Obtain the invocation construct kind of arbitrary entity Id 12047 12048 function Spec_Placement_Of 12049 (Id : Entity_Id) return Declaration_Placement_Kind; 12050 pragma Inline (Spec_Placement_Of); 12051 -- Obtain the placement of arbitrary entity Id's spec 12052 12053 ----------------------- 12054 -- Body_Placement_Of -- 12055 ----------------------- 12056 12057 function Body_Placement_Of 12058 (Id : Entity_Id) return Declaration_Placement_Kind 12059 is 12060 Id_Rep : constant Target_Rep_Id := 12061 Target_Representation_Of (Id, In_State); 12062 Body_Decl : constant Node_Id := Body_Declaration (Id_Rep); 12063 Spec_Decl : constant Node_Id := Spec_Declaration (Id_Rep); 12064 12065 begin 12066 -- The entity has a body 12067 12068 if Present (Body_Decl) then 12069 return Declaration_Placement_Of_Node (Body_Decl); 12070 12071 -- Otherwise the entity must have a spec 12072 12073 else 12074 pragma Assert (Present (Spec_Decl)); 12075 return Declaration_Placement_Of_Node (Spec_Decl); 12076 end if; 12077 end Body_Placement_Of; 12078 12079 ----------------------------------- 12080 -- Declaration_Placement_Of_Node -- 12081 ----------------------------------- 12082 12083 function Declaration_Placement_Of_Node 12084 (N : Node_Id) return Declaration_Placement_Kind 12085 is 12086 Main_Unit_Id : constant Entity_Id := Main_Unit_Entity; 12087 N_Unit_Id : constant Entity_Id := Find_Top_Unit (N); 12088 12089 begin 12090 -- The node is in the main unit, its placement depends on the main 12091 -- unit kind. 12092 12093 if N_Unit_Id = Main_Unit_Id then 12094 12095 -- The main unit is a body 12096 12097 if Ekind (Main_Unit_Id) in E_Package_Body | E_Subprogram_Body 12098 then 12099 return In_Body; 12100 12101 -- The main unit is a stand-alone subprogram body 12102 12103 elsif Ekind (Main_Unit_Id) in E_Function | E_Procedure 12104 and then Nkind (Unit_Declaration_Node (Main_Unit_Id)) = 12105 N_Subprogram_Body 12106 then 12107 return In_Body; 12108 12109 -- Otherwise the main unit is a spec 12110 12111 else 12112 return In_Spec; 12113 end if; 12114 12115 -- Otherwise the node is in the complementary unit of the main 12116 -- unit. The main unit is a body, the node is in the spec. 12117 12118 elsif Ekind (Main_Unit_Id) in E_Package_Body | E_Subprogram_Body 12119 then 12120 return In_Spec; 12121 12122 -- The main unit is a spec, the node is in the body 12123 12124 else 12125 return In_Body; 12126 end if; 12127 end Declaration_Placement_Of_Node; 12128 12129 ------------- 12130 -- Kind_Of -- 12131 ------------- 12132 12133 function Kind_Of (Id : Entity_Id) return Invocation_Construct_Kind is 12134 begin 12135 if Id = Elab_Body_Id then 12136 return Elaborate_Body_Procedure; 12137 12138 elsif Id = Elab_Spec_Id then 12139 return Elaborate_Spec_Procedure; 12140 12141 else 12142 return Regular_Construct; 12143 end if; 12144 end Kind_Of; 12145 12146 ----------------------- 12147 -- Spec_Placement_Of -- 12148 ----------------------- 12149 12150 function Spec_Placement_Of 12151 (Id : Entity_Id) return Declaration_Placement_Kind 12152 is 12153 Id_Rep : constant Target_Rep_Id := 12154 Target_Representation_Of (Id, In_State); 12155 Body_Decl : constant Node_Id := Body_Declaration (Id_Rep); 12156 Spec_Decl : constant Node_Id := Spec_Declaration (Id_Rep); 12157 12158 begin 12159 -- The entity has a spec 12160 12161 if Present (Spec_Decl) then 12162 return Declaration_Placement_Of_Node (Spec_Decl); 12163 12164 -- Otherwise the entity must have a body 12165 12166 else 12167 pragma Assert (Present (Body_Decl)); 12168 return Declaration_Placement_Of_Node (Body_Decl); 12169 end if; 12170 end Spec_Placement_Of; 12171 12172 -- Start of processing for Declare_Invocation_Construct 12173 12174 begin 12175 -- Nothing to do when the construct has already been declared in the 12176 -- ALI file. 12177 12178 if Is_Saved_Construct (Constr_Id) then 12179 return; 12180 end if; 12181 12182 -- Mark the construct as declared in the ALI file 12183 12184 Set_Is_Saved_Construct (Constr_Id); 12185 12186 -- Add the construct in the ALI file 12187 12188 Add_Invocation_Construct 12189 (Body_Placement => Body_Placement_Of (Constr_Id), 12190 Kind => Kind_Of (Constr_Id), 12191 Signature => Signature_Of (Constr_Id), 12192 Spec_Placement => Spec_Placement_Of (Constr_Id), 12193 Update_Units => False); 12194 end Declare_Invocation_Construct; 12195 12196 ------------------------------- 12197 -- Finalize_Invocation_Graph -- 12198 ------------------------------- 12199 12200 procedure Finalize_Invocation_Graph is 12201 begin 12202 NE_Set.Destroy (Saved_Constructs_Set); 12203 IR_Set.Destroy (Saved_Relations_Set); 12204 end Finalize_Invocation_Graph; 12205 12206 ---------- 12207 -- Hash -- 12208 ---------- 12209 12210 function Hash (Key : Invoker_Target_Relation) return Bucket_Range_Type is 12211 pragma Assert (Present (Key.Invoker)); 12212 pragma Assert (Present (Key.Target)); 12213 12214 begin 12215 return 12216 Hash_Two_Keys 12217 (Bucket_Range_Type (Key.Invoker), 12218 Bucket_Range_Type (Key.Target)); 12219 end Hash; 12220 12221 --------------------------------- 12222 -- Initialize_Invocation_Graph -- 12223 --------------------------------- 12224 12225 procedure Initialize_Invocation_Graph is 12226 begin 12227 Saved_Constructs_Set := NE_Set.Create (100); 12228 Saved_Relations_Set := IR_Set.Create (200); 12229 end Initialize_Invocation_Graph; 12230 12231 ----------------------------------- 12232 -- Invocation_Graph_Recording_OK -- 12233 ----------------------------------- 12234 12235 function Invocation_Graph_Recording_OK return Boolean is 12236 Main_Cunit : constant Node_Id := Cunit (Main_Unit); 12237 12238 begin 12239 -- Nothing to do when compiling for GNATprove because the invocation 12240 -- graph is not needed. 12241 12242 if GNATprove_Mode then 12243 return False; 12244 12245 -- Nothing to do when the compilation will not produce an ALI file 12246 12247 elsif Serious_Errors_Detected > 0 then 12248 return False; 12249 12250 -- Nothing to do when the main unit requires a body. Processing the 12251 -- completing body will create the ALI file for the unit and record 12252 -- the invocation graph. 12253 12254 elsif Body_Required (Main_Cunit) then 12255 return False; 12256 end if; 12257 12258 return True; 12259 end Invocation_Graph_Recording_OK; 12260 12261 ---------------------------- 12262 -- Is_Invocation_Scenario -- 12263 ---------------------------- 12264 12265 function Is_Invocation_Scenario (N : Node_Id) return Boolean is 12266 begin 12267 return 12268 Is_Suitable_Access_Taken (N) 12269 or else Is_Suitable_Call (N) 12270 or else Is_Suitable_Instantiation (N); 12271 end Is_Invocation_Scenario; 12272 12273 -------------------------- 12274 -- Is_Invocation_Target -- 12275 -------------------------- 12276 12277 function Is_Invocation_Target (Id : Entity_Id) return Boolean is 12278 begin 12279 -- To qualify, the entity must either come from source, or denote an 12280 -- Ada, bridge, or SPARK target. 12281 12282 return 12283 Comes_From_Source (Id) 12284 or else Is_Ada_Semantic_Target (Id) 12285 or else Is_Bridge_Target (Id) 12286 or else Is_SPARK_Semantic_Target (Id); 12287 end Is_Invocation_Target; 12288 12289 ------------------------ 12290 -- Is_Saved_Construct -- 12291 ------------------------ 12292 12293 function Is_Saved_Construct (Constr : Entity_Id) return Boolean is 12294 pragma Assert (Present (Constr)); 12295 begin 12296 return NE_Set.Contains (Saved_Constructs_Set, Constr); 12297 end Is_Saved_Construct; 12298 12299 ----------------------- 12300 -- Is_Saved_Relation -- 12301 ----------------------- 12302 12303 function Is_Saved_Relation 12304 (Rel : Invoker_Target_Relation) return Boolean 12305 is 12306 pragma Assert (Present (Rel.Invoker)); 12307 pragma Assert (Present (Rel.Target)); 12308 12309 begin 12310 return IR_Set.Contains (Saved_Relations_Set, Rel); 12311 end Is_Saved_Relation; 12312 12313 -------------------------- 12314 -- Process_Declarations -- 12315 -------------------------- 12316 12317 procedure Process_Declarations 12318 (Decls : List_Id; 12319 In_State : Processing_In_State) 12320 is 12321 Decl : Node_Id; 12322 12323 begin 12324 Decl := First (Decls); 12325 while Present (Decl) loop 12326 12327 -- Freeze node 12328 12329 if Nkind (Decl) = N_Freeze_Entity then 12330 Process_Freeze_Node 12331 (Fnode => Decl, 12332 In_State => In_State); 12333 12334 -- Package (nested) 12335 12336 elsif Nkind (Decl) = N_Package_Declaration then 12337 Process_Package_Declaration 12338 (Pack_Decl => Decl, 12339 In_State => In_State); 12340 12341 -- Protected type 12342 12343 elsif Nkind (Decl) in N_Protected_Type_Declaration 12344 | N_Single_Protected_Declaration 12345 then 12346 Process_Protected_Type_Declaration 12347 (Prot_Decl => Decl, 12348 In_State => In_State); 12349 12350 -- Subprogram or entry 12351 12352 elsif Nkind (Decl) in N_Entry_Declaration 12353 | N_Subprogram_Declaration 12354 then 12355 Process_Subprogram_Declaration 12356 (Subp_Decl => Decl, 12357 In_State => In_State); 12358 12359 -- Subprogram body (stand alone) 12360 12361 elsif Nkind (Decl) = N_Subprogram_Body 12362 and then No (Corresponding_Spec (Decl)) 12363 then 12364 Process_Subprogram_Declaration 12365 (Subp_Decl => Decl, 12366 In_State => In_State); 12367 12368 -- Subprogram instantiation 12369 12370 elsif Nkind (Decl) in N_Subprogram_Instantiation then 12371 Process_Subprogram_Instantiation 12372 (Inst => Decl, 12373 In_State => In_State); 12374 12375 -- Task type 12376 12377 elsif Nkind (Decl) in N_Single_Task_Declaration 12378 | N_Task_Type_Declaration 12379 then 12380 Process_Task_Type_Declaration 12381 (Task_Decl => Decl, 12382 In_State => In_State); 12383 12384 -- Task type (derived) 12385 12386 elsif Nkind (Decl) = N_Full_Type_Declaration 12387 and then Is_Task_Type (Defining_Entity (Decl)) 12388 then 12389 Process_Task_Type_Declaration 12390 (Task_Decl => Decl, 12391 In_State => In_State); 12392 end if; 12393 12394 Next (Decl); 12395 end loop; 12396 end Process_Declarations; 12397 12398 ------------------------- 12399 -- Process_Freeze_Node -- 12400 ------------------------- 12401 12402 procedure Process_Freeze_Node 12403 (Fnode : Node_Id; 12404 In_State : Processing_In_State) 12405 is 12406 begin 12407 Process_Declarations 12408 (Decls => Actions (Fnode), 12409 In_State => In_State); 12410 end Process_Freeze_Node; 12411 12412 ----------------------------------- 12413 -- Process_Invocation_Activation -- 12414 ----------------------------------- 12415 12416 procedure Process_Invocation_Activation 12417 (Call : Node_Id; 12418 Call_Rep : Scenario_Rep_Id; 12419 Obj_Id : Entity_Id; 12420 Obj_Rep : Target_Rep_Id; 12421 Task_Typ : Entity_Id; 12422 Task_Rep : Target_Rep_Id; 12423 In_State : Processing_In_State) 12424 is 12425 pragma Unreferenced (Call); 12426 pragma Unreferenced (Call_Rep); 12427 pragma Unreferenced (Obj_Id); 12428 pragma Unreferenced (Obj_Rep); 12429 12430 begin 12431 -- Nothing to do when the task type appears within an internal unit 12432 12433 if In_Internal_Unit (Task_Typ) then 12434 return; 12435 end if; 12436 12437 -- The task type being activated is within the main unit. Extend the 12438 -- DFS traversal into its body. 12439 12440 if In_Extended_Main_Code_Unit (Task_Typ) then 12441 Traverse_Invocation_Body 12442 (N => Body_Declaration (Task_Rep), 12443 In_State => In_State); 12444 12445 -- The task type being activated resides within an external unit 12446 -- 12447 -- Main unit External unit 12448 -- +-----------+ +-------------+ 12449 -- | | | | 12450 -- | Start ------------> Task_Typ | 12451 -- | | | | 12452 -- +-----------+ +-------------+ 12453 -- 12454 -- Record the invocation path which originates from Start and reaches 12455 -- the task type. 12456 12457 else 12458 Record_Invocation_Path (In_State); 12459 end if; 12460 end Process_Invocation_Activation; 12461 12462 --------------------------------------- 12463 -- Process_Invocation_Body_Scenarios -- 12464 --------------------------------------- 12465 12466 procedure Process_Invocation_Body_Scenarios is 12467 Iter : NE_Set.Iterator := Iterate_Library_Body_Scenarios; 12468 begin 12469 Process_Invocation_Scenarios 12470 (Iter => Iter, 12471 In_State => Invocation_Body_State); 12472 end Process_Invocation_Body_Scenarios; 12473 12474 ----------------------------- 12475 -- Process_Invocation_Call -- 12476 ----------------------------- 12477 12478 procedure Process_Invocation_Call 12479 (Call : Node_Id; 12480 Call_Rep : Scenario_Rep_Id; 12481 In_State : Processing_In_State) 12482 is 12483 pragma Unreferenced (Call); 12484 12485 Subp_Id : constant Entity_Id := Target (Call_Rep); 12486 Subp_Rep : constant Target_Rep_Id := 12487 Target_Representation_Of (Subp_Id, In_State); 12488 12489 begin 12490 -- Nothing to do when the subprogram appears within an internal unit 12491 12492 if In_Internal_Unit (Subp_Id) then 12493 return; 12494 12495 -- Nothing to do for an abstract subprogram because it has no body to 12496 -- examine. 12497 12498 elsif Ekind (Subp_Id) in E_Function | E_Procedure 12499 and then Is_Abstract_Subprogram (Subp_Id) 12500 then 12501 return; 12502 12503 -- Nothin to do for a formal subprogram because it has no body to 12504 -- examine. 12505 12506 elsif Is_Formal_Subprogram (Subp_Id) then 12507 return; 12508 end if; 12509 12510 -- The subprogram being called is within the main unit. Extend the 12511 -- DFS traversal into its barrier function and body. 12512 12513 if In_Extended_Main_Code_Unit (Subp_Id) then 12514 if Ekind (Subp_Id) in E_Entry | E_Entry_Family | E_Procedure then 12515 Traverse_Invocation_Body 12516 (N => Barrier_Body_Declaration (Subp_Rep), 12517 In_State => In_State); 12518 end if; 12519 12520 Traverse_Invocation_Body 12521 (N => Body_Declaration (Subp_Rep), 12522 In_State => In_State); 12523 12524 -- The subprogram being called resides within an external unit 12525 -- 12526 -- Main unit External unit 12527 -- +-----------+ +-------------+ 12528 -- | | | | 12529 -- | Start ------------> Subp_Id | 12530 -- | | | | 12531 -- +-----------+ +-------------+ 12532 -- 12533 -- Record the invocation path which originates from Start and reaches 12534 -- the subprogram. 12535 12536 else 12537 Record_Invocation_Path (In_State); 12538 end if; 12539 end Process_Invocation_Call; 12540 12541 -------------------------------------- 12542 -- Process_Invocation_Instantiation -- 12543 -------------------------------------- 12544 12545 procedure Process_Invocation_Instantiation 12546 (Inst : Node_Id; 12547 Inst_Rep : Scenario_Rep_Id; 12548 In_State : Processing_In_State) 12549 is 12550 pragma Unreferenced (Inst); 12551 12552 Gen_Id : constant Entity_Id := Target (Inst_Rep); 12553 12554 begin 12555 -- Nothing to do when the generic appears within an internal unit 12556 12557 if In_Internal_Unit (Gen_Id) then 12558 return; 12559 end if; 12560 12561 -- The generic being instantiated resides within an external unit 12562 -- 12563 -- Main unit External unit 12564 -- +-----------+ +-------------+ 12565 -- | | | | 12566 -- | Start ------------> Generic | 12567 -- | | | | 12568 -- +-----------+ +-------------+ 12569 -- 12570 -- Record the invocation path which originates from Start and reaches 12571 -- the generic. 12572 12573 if not In_Extended_Main_Code_Unit (Gen_Id) then 12574 Record_Invocation_Path (In_State); 12575 end if; 12576 end Process_Invocation_Instantiation; 12577 12578 --------------------------------- 12579 -- Process_Invocation_Scenario -- 12580 --------------------------------- 12581 12582 procedure Process_Invocation_Scenario 12583 (N : Node_Id; 12584 In_State : Processing_In_State) 12585 is 12586 Scen : constant Node_Id := Scenario (N); 12587 Scen_Rep : Scenario_Rep_Id; 12588 12589 begin 12590 -- Add the current scenario to the stack of active scenarios 12591 12592 Push_Active_Scenario (Scen); 12593 12594 -- Call or task activation 12595 12596 if Is_Suitable_Call (Scen) then 12597 Scen_Rep := Scenario_Representation_Of (Scen, In_State); 12598 12599 -- Routine Build_Call_Marker creates call markers regardless of 12600 -- whether the call occurs within the main unit or not. This way 12601 -- the serialization of internal names is kept consistent. Only 12602 -- call markers found within the main unit must be processed. 12603 12604 if In_Main_Context (Scen) then 12605 Scen_Rep := Scenario_Representation_Of (Scen, In_State); 12606 12607 if Kind (Scen_Rep) = Call_Scenario then 12608 Process_Invocation_Call 12609 (Call => Scen, 12610 Call_Rep => Scen_Rep, 12611 In_State => In_State); 12612 12613 else 12614 pragma Assert (Kind (Scen_Rep) = Task_Activation_Scenario); 12615 12616 Process_Activation 12617 (Call => Scen, 12618 Call_Rep => Scen_Rep, 12619 Processor => Process_Invocation_Activation'Access, 12620 In_State => In_State); 12621 end if; 12622 end if; 12623 12624 -- Instantiation 12625 12626 elsif Is_Suitable_Instantiation (Scen) then 12627 Process_Invocation_Instantiation 12628 (Inst => Scen, 12629 Inst_Rep => Scenario_Representation_Of (Scen, In_State), 12630 In_State => In_State); 12631 end if; 12632 12633 -- Remove the current scenario from the stack of active scenarios 12634 -- once all invocation constructs and paths have been saved. 12635 12636 Pop_Active_Scenario (Scen); 12637 end Process_Invocation_Scenario; 12638 12639 ---------------------------------- 12640 -- Process_Invocation_Scenarios -- 12641 ---------------------------------- 12642 12643 procedure Process_Invocation_Scenarios 12644 (Iter : in out NE_Set.Iterator; 12645 In_State : Processing_In_State) 12646 is 12647 N : Node_Id; 12648 12649 begin 12650 while NE_Set.Has_Next (Iter) loop 12651 NE_Set.Next (Iter, N); 12652 12653 -- Reset the traversed status of all subprogram bodies because the 12654 -- current invocation scenario acts as a new DFS traversal root. 12655 12656 Reset_Traversed_Bodies; 12657 12658 Process_Invocation_Scenario (N, In_State); 12659 end loop; 12660 end Process_Invocation_Scenarios; 12661 12662 --------------------------------------- 12663 -- Process_Invocation_Spec_Scenarios -- 12664 --------------------------------------- 12665 12666 procedure Process_Invocation_Spec_Scenarios is 12667 Iter : NE_Set.Iterator := Iterate_Library_Spec_Scenarios; 12668 begin 12669 Process_Invocation_Scenarios 12670 (Iter => Iter, 12671 In_State => Invocation_Spec_State); 12672 end Process_Invocation_Spec_Scenarios; 12673 12674 ----------------------- 12675 -- Process_Main_Unit -- 12676 ----------------------- 12677 12678 procedure Process_Main_Unit is 12679 Unit_Decl : constant Node_Id := Unit (Cunit (Main_Unit)); 12680 Spec_Id : Entity_Id; 12681 12682 begin 12683 -- The main unit is a [generic] package body 12684 12685 if Nkind (Unit_Decl) = N_Package_Body then 12686 Spec_Id := Corresponding_Spec (Unit_Decl); 12687 pragma Assert (Present (Spec_Id)); 12688 12689 Process_Package_Declaration 12690 (Pack_Decl => Unit_Declaration_Node (Spec_Id), 12691 In_State => Invocation_Construct_State); 12692 12693 -- The main unit is a [generic] package declaration 12694 12695 elsif Nkind (Unit_Decl) = N_Package_Declaration then 12696 Process_Package_Declaration 12697 (Pack_Decl => Unit_Decl, 12698 In_State => Invocation_Construct_State); 12699 12700 -- The main unit is a [generic] subprogram body 12701 12702 elsif Nkind (Unit_Decl) = N_Subprogram_Body then 12703 Spec_Id := Corresponding_Spec (Unit_Decl); 12704 12705 -- The body completes a previous declaration 12706 12707 if Present (Spec_Id) then 12708 Process_Subprogram_Declaration 12709 (Subp_Decl => Unit_Declaration_Node (Spec_Id), 12710 In_State => Invocation_Construct_State); 12711 12712 -- Otherwise the body is stand-alone 12713 12714 else 12715 Process_Subprogram_Declaration 12716 (Subp_Decl => Unit_Decl, 12717 In_State => Invocation_Construct_State); 12718 end if; 12719 12720 -- The main unit is a subprogram instantiation 12721 12722 elsif Nkind (Unit_Decl) in N_Subprogram_Instantiation then 12723 Process_Subprogram_Instantiation 12724 (Inst => Unit_Decl, 12725 In_State => Invocation_Construct_State); 12726 12727 -- The main unit is an imported subprogram declaration 12728 12729 elsif Nkind (Unit_Decl) = N_Subprogram_Declaration then 12730 Process_Subprogram_Declaration 12731 (Subp_Decl => Unit_Decl, 12732 In_State => Invocation_Construct_State); 12733 end if; 12734 end Process_Main_Unit; 12735 12736 --------------------------------- 12737 -- Process_Package_Declaration -- 12738 --------------------------------- 12739 12740 procedure Process_Package_Declaration 12741 (Pack_Decl : Node_Id; 12742 In_State : Processing_In_State) 12743 is 12744 Body_Id : constant Entity_Id := Corresponding_Body (Pack_Decl); 12745 Spec : constant Node_Id := Specification (Pack_Decl); 12746 Spec_Id : constant Entity_Id := Defining_Entity (Pack_Decl); 12747 12748 begin 12749 -- Add a declaration for the generic package in the ALI of the main 12750 -- unit in case a client unit instantiates it. 12751 12752 if Ekind (Spec_Id) = E_Generic_Package then 12753 Declare_Invocation_Construct 12754 (Constr_Id => Spec_Id, 12755 In_State => In_State); 12756 12757 -- Otherwise inspect the visible and private declarations of the 12758 -- package for invocation constructs. 12759 12760 else 12761 Process_Declarations 12762 (Decls => Visible_Declarations (Spec), 12763 In_State => In_State); 12764 12765 Process_Declarations 12766 (Decls => Private_Declarations (Spec), 12767 In_State => In_State); 12768 12769 -- The package body containst at least one generic unit or an 12770 -- inlinable subprogram. Such constructs may grant clients of 12771 -- the main unit access to the private enclosing contexts of 12772 -- the constructs. Process the main unit body to discover and 12773 -- encode relevant invocation constructs and relations that 12774 -- may ultimately reach an external unit. 12775 12776 if Present (Body_Id) 12777 and then Save_Invocation_Graph_Of_Body (Cunit (Main_Unit)) 12778 then 12779 Process_Declarations 12780 (Decls => Declarations (Unit_Declaration_Node (Body_Id)), 12781 In_State => In_State); 12782 end if; 12783 end if; 12784 end Process_Package_Declaration; 12785 12786 ---------------------------------------- 12787 -- Process_Protected_Type_Declaration -- 12788 ---------------------------------------- 12789 12790 procedure Process_Protected_Type_Declaration 12791 (Prot_Decl : Node_Id; 12792 In_State : Processing_In_State) 12793 is 12794 Prot_Def : constant Node_Id := Protected_Definition (Prot_Decl); 12795 12796 begin 12797 if Present (Prot_Def) then 12798 Process_Declarations 12799 (Decls => Visible_Declarations (Prot_Def), 12800 In_State => In_State); 12801 end if; 12802 end Process_Protected_Type_Declaration; 12803 12804 ------------------------------------ 12805 -- Process_Subprogram_Declaration -- 12806 ------------------------------------ 12807 12808 procedure Process_Subprogram_Declaration 12809 (Subp_Decl : Node_Id; 12810 In_State : Processing_In_State) 12811 is 12812 Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl); 12813 12814 begin 12815 -- Nothing to do when the subprogram is not an invocation target 12816 12817 if not Is_Invocation_Target (Subp_Id) then 12818 return; 12819 end if; 12820 12821 -- Add a declaration for the subprogram in the ALI file of the main 12822 -- unit in case a client unit calls or instantiates it. 12823 12824 Declare_Invocation_Construct 12825 (Constr_Id => Subp_Id, 12826 In_State => In_State); 12827 12828 -- Do not process subprograms without a body because they do not 12829 -- contain any invocation scenarios. 12830 12831 if Is_Bodiless_Subprogram (Subp_Id) then 12832 null; 12833 12834 -- Do not process generic subprograms because generics must not be 12835 -- examined. 12836 12837 elsif Is_Generic_Subprogram (Subp_Id) then 12838 null; 12839 12840 -- Otherwise create a dummy scenario which calls the subprogram to 12841 -- act as a root for a DFS traversal. 12842 12843 else 12844 -- Reset the traversed status of all subprogram bodies because the 12845 -- subprogram acts as a new DFS traversal root. 12846 12847 Reset_Traversed_Bodies; 12848 12849 Process_Invocation_Scenario 12850 (N => Build_Subprogram_Invocation (Subp_Id), 12851 In_State => In_State); 12852 end if; 12853 end Process_Subprogram_Declaration; 12854 12855 -------------------------------------- 12856 -- Process_Subprogram_Instantiation -- 12857 -------------------------------------- 12858 12859 procedure Process_Subprogram_Instantiation 12860 (Inst : Node_Id; 12861 In_State : Processing_In_State) 12862 is 12863 begin 12864 -- Add a declaration for the instantiation in the ALI file of the 12865 -- main unit in case a client unit calls it. 12866 12867 Declare_Invocation_Construct 12868 (Constr_Id => Defining_Entity (Inst), 12869 In_State => In_State); 12870 end Process_Subprogram_Instantiation; 12871 12872 ----------------------------------- 12873 -- Process_Task_Type_Declaration -- 12874 ----------------------------------- 12875 12876 procedure Process_Task_Type_Declaration 12877 (Task_Decl : Node_Id; 12878 In_State : Processing_In_State) 12879 is 12880 Task_Typ : constant Entity_Id := Defining_Entity (Task_Decl); 12881 Task_Def : Node_Id; 12882 12883 begin 12884 -- Add a declaration for the task type the ALI file of the main unit 12885 -- in case a client unit creates a task object and activates it. 12886 12887 Declare_Invocation_Construct 12888 (Constr_Id => Task_Typ, 12889 In_State => In_State); 12890 12891 -- Process the entries of the task type because they represent valid 12892 -- entry points into the task body. 12893 12894 if Nkind (Task_Decl) in N_Single_Task_Declaration 12895 | N_Task_Type_Declaration 12896 then 12897 Task_Def := Task_Definition (Task_Decl); 12898 12899 if Present (Task_Def) then 12900 Process_Declarations 12901 (Decls => Visible_Declarations (Task_Def), 12902 In_State => In_State); 12903 end if; 12904 end if; 12905 12906 -- Reset the traversed status of all subprogram bodies because the 12907 -- task type acts as a new DFS traversal root. 12908 12909 Reset_Traversed_Bodies; 12910 12911 -- Create a dummy scenario which activates an anonymous object of the 12912 -- task type to acts as a root of a DFS traversal. 12913 12914 Process_Invocation_Scenario 12915 (N => Build_Task_Activation (Task_Typ, In_State), 12916 In_State => In_State); 12917 end Process_Task_Type_Declaration; 12918 12919 --------------------------------- 12920 -- Record_Full_Invocation_Path -- 12921 --------------------------------- 12922 12923 procedure Record_Full_Invocation_Path (In_State : Processing_In_State) is 12924 package Scenarios renames Active_Scenario_Stack; 12925 12926 begin 12927 -- The path originates from the elaboration of the body. Add an extra 12928 -- relation from the elaboration body procedure to the first active 12929 -- scenario. 12930 12931 if In_State.Processing = Invocation_Body_Processing then 12932 Build_Elaborate_Body_Procedure; 12933 12934 Record_Invocation_Relation 12935 (Invk_Id => Elab_Body_Id, 12936 Targ_Id => Target_Of (Scenarios.First, In_State), 12937 In_State => In_State); 12938 12939 -- The path originates from the elaboration of the spec. Add an extra 12940 -- relation from the elaboration spec procedure to the first active 12941 -- scenario. 12942 12943 elsif In_State.Processing = Invocation_Spec_Processing then 12944 Build_Elaborate_Spec_Procedure; 12945 12946 Record_Invocation_Relation 12947 (Invk_Id => Elab_Spec_Id, 12948 Targ_Id => Target_Of (Scenarios.First, In_State), 12949 In_State => In_State); 12950 end if; 12951 12952 -- Record individual relations formed by pairs of scenarios 12953 12954 for Index in Scenarios.First .. Scenarios.Last - 1 loop 12955 Record_Invocation_Relation 12956 (Invk_Id => Target_Of (Index, In_State), 12957 Targ_Id => Target_Of (Index + 1, In_State), 12958 In_State => In_State); 12959 end loop; 12960 end Record_Full_Invocation_Path; 12961 12962 ----------------------------- 12963 -- Record_Invocation_Graph -- 12964 ----------------------------- 12965 12966 procedure Record_Invocation_Graph is 12967 begin 12968 -- Nothing to do when the invocation graph is not recorded 12969 12970 if not Invocation_Graph_Recording_OK then 12971 return; 12972 end if; 12973 12974 -- Save the encoding format used to capture information about the 12975 -- invocation constructs and relations in the ALI file of the main 12976 -- unit. 12977 12978 Record_Invocation_Graph_Encoding; 12979 12980 -- Examine all library level invocation scenarios and perform DFS 12981 -- traversals from each one. Encode a path in the ALI file of the 12982 -- main unit if it reaches into an external unit. 12983 12984 Process_Invocation_Body_Scenarios; 12985 Process_Invocation_Spec_Scenarios; 12986 12987 -- Examine all invocation constructs within the spec and body of the 12988 -- main unit and perform DFS traversals from each one. Encode a path 12989 -- in the ALI file of the main unit if it reaches into an external 12990 -- unit. 12991 12992 Process_Main_Unit; 12993 end Record_Invocation_Graph; 12994 12995 -------------------------------------- 12996 -- Record_Invocation_Graph_Encoding -- 12997 -------------------------------------- 12998 12999 procedure Record_Invocation_Graph_Encoding is 13000 Kind : Invocation_Graph_Encoding_Kind := No_Encoding; 13001 13002 begin 13003 -- Switch -gnatd_F (encode full invocation paths in ALI files) is in 13004 -- effect. 13005 13006 if Debug_Flag_Underscore_FF then 13007 Kind := Full_Path_Encoding; 13008 else 13009 Kind := Endpoints_Encoding; 13010 end if; 13011 13012 -- Save the encoding format in the ALI file of the main unit 13013 13014 Set_Invocation_Graph_Encoding 13015 (Kind => Kind, 13016 Update_Units => False); 13017 end Record_Invocation_Graph_Encoding; 13018 13019 ---------------------------- 13020 -- Record_Invocation_Path -- 13021 ---------------------------- 13022 13023 procedure Record_Invocation_Path (In_State : Processing_In_State) is 13024 package Scenarios renames Active_Scenario_Stack; 13025 13026 begin 13027 -- Save a path when the active scenario stack contains at least one 13028 -- invocation scenario. 13029 13030 if Scenarios.Last - Scenarios.First < 0 then 13031 return; 13032 end if; 13033 13034 -- Register all relations in the path when switch -gnatd_F (encode 13035 -- full invocation paths in ALI files) is in effect. 13036 13037 if Debug_Flag_Underscore_FF then 13038 Record_Full_Invocation_Path (In_State); 13039 13040 -- Otherwise register a single relation 13041 13042 else 13043 Record_Simple_Invocation_Path (In_State); 13044 end if; 13045 13046 Write_Invocation_Path (In_State); 13047 end Record_Invocation_Path; 13048 13049 -------------------------------- 13050 -- Record_Invocation_Relation -- 13051 -------------------------------- 13052 13053 procedure Record_Invocation_Relation 13054 (Invk_Id : Entity_Id; 13055 Targ_Id : Entity_Id; 13056 In_State : Processing_In_State) 13057 is 13058 pragma Assert (Present (Invk_Id)); 13059 pragma Assert (Present (Targ_Id)); 13060 13061 procedure Get_Invocation_Attributes 13062 (Extra : out Entity_Id; 13063 Kind : out Invocation_Kind); 13064 pragma Inline (Get_Invocation_Attributes); 13065 -- Return the additional entity used in error diagnostics in Extra 13066 -- and the invocation kind in Kind which pertain to the invocation 13067 -- relation with invoker Invk_Id and target Targ_Id. 13068 13069 ------------------------------- 13070 -- Get_Invocation_Attributes -- 13071 ------------------------------- 13072 13073 procedure Get_Invocation_Attributes 13074 (Extra : out Entity_Id; 13075 Kind : out Invocation_Kind) 13076 is 13077 Targ_Rep : constant Target_Rep_Id := 13078 Target_Representation_Of (Targ_Id, In_State); 13079 Spec_Decl : constant Node_Id := Spec_Declaration (Targ_Rep); 13080 13081 begin 13082 -- Accept within a task body 13083 13084 if Is_Accept_Alternative_Proc (Targ_Id) then 13085 Extra := Receiving_Entry (Targ_Id); 13086 Kind := Accept_Alternative; 13087 13088 -- Activation of a task object 13089 13090 elsif Is_Activation_Proc (Targ_Id) 13091 or else Is_Task_Type (Targ_Id) 13092 then 13093 Extra := Empty; 13094 Kind := Task_Activation; 13095 13096 -- Controlled adjustment actions 13097 13098 elsif Is_Controlled_Proc (Targ_Id, Name_Adjust) then 13099 Extra := First_Formal_Type (Targ_Id); 13100 Kind := Controlled_Adjustment; 13101 13102 -- Controlled finalization actions 13103 13104 elsif Is_Controlled_Proc (Targ_Id, Name_Finalize) 13105 or else Is_Finalizer_Proc (Targ_Id) 13106 then 13107 Extra := First_Formal_Type (Targ_Id); 13108 Kind := Controlled_Finalization; 13109 13110 -- Controlled initialization actions 13111 13112 elsif Is_Controlled_Proc (Targ_Id, Name_Initialize) then 13113 Extra := First_Formal_Type (Targ_Id); 13114 Kind := Controlled_Initialization; 13115 13116 -- Default_Initial_Condition verification 13117 13118 elsif Is_Default_Initial_Condition_Proc (Targ_Id) then 13119 Extra := First_Formal_Type (Targ_Id); 13120 Kind := Default_Initial_Condition_Verification; 13121 13122 -- Initialization of object 13123 13124 elsif Is_Init_Proc (Targ_Id) then 13125 Extra := First_Formal_Type (Targ_Id); 13126 Kind := Type_Initialization; 13127 13128 -- Initial_Condition verification 13129 13130 elsif Is_Initial_Condition_Proc (Targ_Id) then 13131 Extra := First_Formal_Type (Targ_Id); 13132 Kind := Initial_Condition_Verification; 13133 13134 -- Instantiation 13135 13136 elsif Is_Generic_Unit (Targ_Id) then 13137 Extra := Empty; 13138 Kind := Instantiation; 13139 13140 -- Internal controlled adjustment actions 13141 13142 elsif Is_TSS (Targ_Id, TSS_Deep_Adjust) then 13143 Extra := First_Formal_Type (Targ_Id); 13144 Kind := Internal_Controlled_Adjustment; 13145 13146 -- Internal controlled finalization actions 13147 13148 elsif Is_TSS (Targ_Id, TSS_Deep_Finalize) then 13149 Extra := First_Formal_Type (Targ_Id); 13150 Kind := Internal_Controlled_Finalization; 13151 13152 -- Internal controlled initialization actions 13153 13154 elsif Is_TSS (Targ_Id, TSS_Deep_Initialize) then 13155 Extra := First_Formal_Type (Targ_Id); 13156 Kind := Internal_Controlled_Initialization; 13157 13158 -- Invariant verification 13159 13160 elsif Is_Invariant_Proc (Targ_Id) 13161 or else Is_Partial_Invariant_Proc (Targ_Id) 13162 then 13163 Extra := First_Formal_Type (Targ_Id); 13164 Kind := Invariant_Verification; 13165 13166 -- Postcondition verification 13167 13168 elsif Is_Postconditions_Proc (Targ_Id) then 13169 Extra := Find_Enclosing_Scope (Spec_Decl); 13170 Kind := Postcondition_Verification; 13171 13172 -- Protected entry call 13173 13174 elsif Is_Protected_Entry (Targ_Id) then 13175 Extra := Empty; 13176 Kind := Protected_Entry_Call; 13177 13178 -- Protected subprogram call 13179 13180 elsif Is_Protected_Subp (Targ_Id) then 13181 Extra := Empty; 13182 Kind := Protected_Subprogram_Call; 13183 13184 -- Task entry call 13185 13186 elsif Is_Task_Entry (Targ_Id) then 13187 Extra := Empty; 13188 Kind := Task_Entry_Call; 13189 13190 -- Entry, operator, or subprogram call. This case must come last 13191 -- because most invocations above are variations of this case. 13192 13193 elsif Ekind (Targ_Id) in 13194 E_Entry | E_Function | E_Operator | E_Procedure 13195 then 13196 Extra := Empty; 13197 Kind := Call; 13198 13199 else 13200 pragma Assert (False); 13201 Extra := Empty; 13202 Kind := No_Invocation; 13203 end if; 13204 end Get_Invocation_Attributes; 13205 13206 -- Local variables 13207 13208 Extra : Entity_Id; 13209 Extra_Nam : Name_Id; 13210 Kind : Invocation_Kind; 13211 Rel : Invoker_Target_Relation; 13212 13213 -- Start of processing for Record_Invocation_Relation 13214 13215 begin 13216 Rel.Invoker := Invk_Id; 13217 Rel.Target := Targ_Id; 13218 13219 -- Nothing to do when the invocation relation has already been 13220 -- recorded in ALI file of the main unit. 13221 13222 if Is_Saved_Relation (Rel) then 13223 return; 13224 end if; 13225 13226 -- Mark the relation as recorded in the ALI file 13227 13228 Set_Is_Saved_Relation (Rel); 13229 13230 -- Declare the invoker in the ALI file 13231 13232 Declare_Invocation_Construct 13233 (Constr_Id => Invk_Id, 13234 In_State => In_State); 13235 13236 -- Obtain the invocation-specific attributes of the relation 13237 13238 Get_Invocation_Attributes (Extra, Kind); 13239 13240 -- Certain invocations lack an extra entity used in error diagnostics 13241 13242 if Present (Extra) then 13243 Extra_Nam := Chars (Extra); 13244 else 13245 Extra_Nam := No_Name; 13246 end if; 13247 13248 -- Add the relation in the ALI file 13249 13250 Add_Invocation_Relation 13251 (Extra => Extra_Nam, 13252 Invoker => Signature_Of (Invk_Id), 13253 Kind => Kind, 13254 Target => Signature_Of (Targ_Id), 13255 Update_Units => False); 13256 end Record_Invocation_Relation; 13257 13258 ----------------------------------- 13259 -- Record_Simple_Invocation_Path -- 13260 ----------------------------------- 13261 13262 procedure Record_Simple_Invocation_Path 13263 (In_State : Processing_In_State) 13264 is 13265 package Scenarios renames Active_Scenario_Stack; 13266 13267 Last_Targ : constant Entity_Id := 13268 Target_Of (Scenarios.Last, In_State); 13269 First_Targ : Entity_Id; 13270 13271 begin 13272 -- The path originates from the elaboration of the body. Add an extra 13273 -- relation from the elaboration body procedure to the first active 13274 -- scenario. 13275 13276 if In_State.Processing = Invocation_Body_Processing then 13277 Build_Elaborate_Body_Procedure; 13278 First_Targ := Elab_Body_Id; 13279 13280 -- The path originates from the elaboration of the spec. Add an extra 13281 -- relation from the elaboration spec procedure to the first active 13282 -- scenario. 13283 13284 elsif In_State.Processing = Invocation_Spec_Processing then 13285 Build_Elaborate_Spec_Procedure; 13286 First_Targ := Elab_Spec_Id; 13287 13288 else 13289 First_Targ := Target_Of (Scenarios.First, In_State); 13290 end if; 13291 13292 -- Record a single relation from the first to the last scenario 13293 13294 if First_Targ /= Last_Targ then 13295 Record_Invocation_Relation 13296 (Invk_Id => First_Targ, 13297 Targ_Id => Last_Targ, 13298 In_State => In_State); 13299 end if; 13300 end Record_Simple_Invocation_Path; 13301 13302 ---------------------------- 13303 -- Set_Is_Saved_Construct -- 13304 ---------------------------- 13305 13306 procedure Set_Is_Saved_Construct 13307 (Constr : Entity_Id; 13308 Val : Boolean := True) 13309 is 13310 pragma Assert (Present (Constr)); 13311 13312 begin 13313 if Val then 13314 NE_Set.Insert (Saved_Constructs_Set, Constr); 13315 else 13316 NE_Set.Delete (Saved_Constructs_Set, Constr); 13317 end if; 13318 end Set_Is_Saved_Construct; 13319 13320 --------------------------- 13321 -- Set_Is_Saved_Relation -- 13322 --------------------------- 13323 13324 procedure Set_Is_Saved_Relation 13325 (Rel : Invoker_Target_Relation; 13326 Val : Boolean := True) 13327 is 13328 begin 13329 if Val then 13330 IR_Set.Insert (Saved_Relations_Set, Rel); 13331 else 13332 IR_Set.Delete (Saved_Relations_Set, Rel); 13333 end if; 13334 end Set_Is_Saved_Relation; 13335 13336 ------------------ 13337 -- Signature_Of -- 13338 ------------------ 13339 13340 function Signature_Of (Id : Entity_Id) return Invocation_Signature_Id is 13341 Loc : constant Source_Ptr := Sloc (Id); 13342 13343 function Instantiation_Locations return Name_Id; 13344 pragma Inline (Instantiation_Locations); 13345 -- Create a concatenation of all lines and colums of each instance 13346 -- where source location Loc appears. Return No_Name if no instances 13347 -- exist. 13348 13349 function Qualified_Scope return Name_Id; 13350 pragma Inline (Qualified_Scope); 13351 -- Obtain the qualified name of Id's scope 13352 13353 ----------------------------- 13354 -- Instantiation_Locations -- 13355 ----------------------------- 13356 13357 function Instantiation_Locations return Name_Id is 13358 Buffer : Bounded_String (2052); 13359 Inst : Source_Ptr; 13360 Loc_Nam : Name_Id; 13361 SFI : Source_File_Index; 13362 13363 begin 13364 SFI := Get_Source_File_Index (Loc); 13365 Inst := Instantiation (SFI); 13366 13367 -- The location is within an instance. Construct a concatenation 13368 -- of all lines and colums of each individual instance using the 13369 -- following format: 13370 -- 13371 -- line1_column1_line2_column2_ ... _lineN_columnN 13372 13373 if Inst /= No_Location then 13374 loop 13375 Append (Buffer, Nat (Get_Logical_Line_Number (Inst))); 13376 Append (Buffer, '_'); 13377 Append (Buffer, Nat (Get_Column_Number (Inst))); 13378 13379 SFI := Get_Source_File_Index (Inst); 13380 Inst := Instantiation (SFI); 13381 13382 exit when Inst = No_Location; 13383 13384 Append (Buffer, '_'); 13385 end loop; 13386 13387 Loc_Nam := Name_Find (Buffer); 13388 return Loc_Nam; 13389 13390 -- Otherwise there no instances are involved 13391 13392 else 13393 return No_Name; 13394 end if; 13395 end Instantiation_Locations; 13396 13397 --------------------- 13398 -- Qualified_Scope -- 13399 --------------------- 13400 13401 function Qualified_Scope return Name_Id is 13402 Scop : Entity_Id; 13403 13404 begin 13405 Scop := Scope (Id); 13406 13407 -- The entity appears within an anonymous concurrent type created 13408 -- for a single protected or task type declaration. Use the entity 13409 -- of the anonymous object as it represents the original scope. 13410 13411 if Is_Concurrent_Type (Scop) 13412 and then Present (Anonymous_Object (Scop)) 13413 then 13414 Scop := Anonymous_Object (Scop); 13415 end if; 13416 13417 return Get_Qualified_Name (Scop); 13418 end Qualified_Scope; 13419 13420 -- Start of processing for Signature_Of 13421 13422 begin 13423 return 13424 Invocation_Signature_Of 13425 (Column => Nat (Get_Column_Number (Loc)), 13426 Line => Nat (Get_Logical_Line_Number (Loc)), 13427 Locations => Instantiation_Locations, 13428 Name => Chars (Id), 13429 Scope => Qualified_Scope); 13430 end Signature_Of; 13431 13432 --------------- 13433 -- Target_Of -- 13434 --------------- 13435 13436 function Target_Of 13437 (Pos : Active_Scenario_Pos; 13438 In_State : Processing_In_State) return Entity_Id 13439 is 13440 package Scenarios renames Active_Scenario_Stack; 13441 13442 -- Ensure that the position is within the bounds of the active 13443 -- scenario stack. 13444 13445 pragma Assert (Scenarios.First <= Pos); 13446 pragma Assert (Pos <= Scenarios.Last); 13447 13448 Scen_Rep : constant Scenario_Rep_Id := 13449 Scenario_Representation_Of 13450 (Scenarios.Table (Pos), In_State); 13451 13452 begin 13453 -- The true target of an activation call is the current task type 13454 -- rather than routine Activate_Tasks. 13455 13456 if Kind (Scen_Rep) = Task_Activation_Scenario then 13457 return Activated_Task_Type (Scen_Rep); 13458 else 13459 return Target (Scen_Rep); 13460 end if; 13461 end Target_Of; 13462 13463 ------------------------------ 13464 -- Traverse_Invocation_Body -- 13465 ------------------------------ 13466 13467 procedure Traverse_Invocation_Body 13468 (N : Node_Id; 13469 In_State : Processing_In_State) 13470 is 13471 begin 13472 Traverse_Body 13473 (N => N, 13474 Requires_Processing => Is_Invocation_Scenario'Access, 13475 Processor => Process_Invocation_Scenario'Access, 13476 In_State => In_State); 13477 end Traverse_Invocation_Body; 13478 13479 --------------------------- 13480 -- Write_Invocation_Path -- 13481 --------------------------- 13482 13483 procedure Write_Invocation_Path (In_State : Processing_In_State) is 13484 procedure Write_Target (Targ_Id : Entity_Id; Is_First : Boolean); 13485 pragma Inline (Write_Target); 13486 -- Write out invocation target Targ_Id to standard output. Flag 13487 -- Is_First should be set when the target is first in a path. 13488 13489 ------------- 13490 -- Targ_Id -- 13491 ------------- 13492 13493 procedure Write_Target (Targ_Id : Entity_Id; Is_First : Boolean) is 13494 begin 13495 if not Is_First then 13496 Write_Str (" --> "); 13497 end if; 13498 13499 Write_Name (Get_Qualified_Name (Targ_Id)); 13500 Write_Eol; 13501 end Write_Target; 13502 13503 -- Local variables 13504 13505 package Scenarios renames Active_Scenario_Stack; 13506 13507 First_Seen : Boolean := False; 13508 13509 -- Start of processing for Write_Invocation_Path 13510 13511 begin 13512 -- Nothing to do when flag -gnatd_T (output trace information on 13513 -- invocation path recording) is not in effect. 13514 13515 if not Debug_Flag_Underscore_TT then 13516 return; 13517 end if; 13518 13519 -- The path originates from the elaboration of the body. Write the 13520 -- elaboration body procedure. 13521 13522 if In_State.Processing = Invocation_Body_Processing then 13523 Write_Target (Elab_Body_Id, True); 13524 First_Seen := True; 13525 13526 -- The path originates from the elaboration of the spec. Write the 13527 -- elaboration spec procedure. 13528 13529 elsif In_State.Processing = Invocation_Spec_Processing then 13530 Write_Target (Elab_Spec_Id, True); 13531 First_Seen := True; 13532 end if; 13533 13534 -- Write each individual target invoked by its corresponding scenario 13535 -- on the active scenario stack. 13536 13537 for Index in Scenarios.First .. Scenarios.Last loop 13538 Write_Target 13539 (Targ_Id => Target_Of (Index, In_State), 13540 Is_First => Index = Scenarios.First and then not First_Seen); 13541 end loop; 13542 13543 Write_Eol; 13544 end Write_Invocation_Path; 13545 end Invocation_Graph; 13546 13547 ------------------------ 13548 -- Is_Safe_Activation -- 13549 ------------------------ 13550 13551 function Is_Safe_Activation 13552 (Call : Node_Id; 13553 Task_Rep : Target_Rep_Id) return Boolean 13554 is 13555 begin 13556 -- The activation of a task coming from an external instance cannot 13557 -- cause an ABE because the generic was already instantiated. Note 13558 -- that the instantiation itself may lead to an ABE. 13559 13560 return 13561 In_External_Instance 13562 (N => Call, 13563 Target_Decl => Spec_Declaration (Task_Rep)); 13564 end Is_Safe_Activation; 13565 13566 ------------------ 13567 -- Is_Safe_Call -- 13568 ------------------ 13569 13570 function Is_Safe_Call 13571 (Call : Node_Id; 13572 Subp_Id : Entity_Id; 13573 Subp_Rep : Target_Rep_Id) return Boolean 13574 is 13575 Body_Decl : constant Node_Id := Body_Declaration (Subp_Rep); 13576 Spec_Decl : constant Node_Id := Spec_Declaration (Subp_Rep); 13577 13578 begin 13579 -- The target is either an abstract subprogram, formal subprogram, or 13580 -- imported, in which case it does not have a body at compile or bind 13581 -- time. Assume that the call is ABE-safe. 13582 13583 if Is_Bodiless_Subprogram (Subp_Id) then 13584 return True; 13585 13586 -- The target is an instantiation of a generic subprogram. The call 13587 -- cannot cause an ABE because the generic was already instantiated. 13588 -- Note that the instantiation itself may lead to an ABE. 13589 13590 elsif Is_Generic_Instance (Subp_Id) then 13591 return True; 13592 13593 -- The invocation of a target coming from an external instance cannot 13594 -- cause an ABE because the generic was already instantiated. Note that 13595 -- the instantiation itself may lead to an ABE. 13596 13597 elsif In_External_Instance 13598 (N => Call, 13599 Target_Decl => Spec_Decl) 13600 then 13601 return True; 13602 13603 -- The target is a subprogram body without a previous declaration. The 13604 -- call cannot cause an ABE because the body has already been seen. 13605 13606 elsif Nkind (Spec_Decl) = N_Subprogram_Body 13607 and then No (Corresponding_Spec (Spec_Decl)) 13608 then 13609 return True; 13610 13611 -- The target is a subprogram body stub without a prior declaration. 13612 -- The call cannot cause an ABE because the proper body substitutes 13613 -- the stub. 13614 13615 elsif Nkind (Spec_Decl) = N_Subprogram_Body_Stub 13616 and then No (Corresponding_Spec_Of_Stub (Spec_Decl)) 13617 then 13618 return True; 13619 13620 -- Subprogram bodies which wrap attribute references used as actuals 13621 -- in instantiations are always ABE-safe. These bodies are artifacts 13622 -- of expansion. 13623 13624 elsif Present (Body_Decl) 13625 and then Nkind (Body_Decl) = N_Subprogram_Body 13626 and then Was_Attribute_Reference (Body_Decl) 13627 then 13628 return True; 13629 end if; 13630 13631 return False; 13632 end Is_Safe_Call; 13633 13634 --------------------------- 13635 -- Is_Safe_Instantiation -- 13636 --------------------------- 13637 13638 function Is_Safe_Instantiation 13639 (Inst : Node_Id; 13640 Gen_Id : Entity_Id; 13641 Gen_Rep : Target_Rep_Id) return Boolean 13642 is 13643 Spec_Decl : constant Node_Id := Spec_Declaration (Gen_Rep); 13644 13645 begin 13646 -- The generic is an intrinsic subprogram in which case it does not 13647 -- have a body at compile or bind time. Assume that the instantiation 13648 -- is ABE-safe. 13649 13650 if Is_Bodiless_Subprogram (Gen_Id) then 13651 return True; 13652 13653 -- The instantiation of an external nested generic cannot cause an ABE 13654 -- if the outer generic was already instantiated. Note that the instance 13655 -- of the outer generic may lead to an ABE. 13656 13657 elsif In_External_Instance 13658 (N => Inst, 13659 Target_Decl => Spec_Decl) 13660 then 13661 return True; 13662 13663 -- The generic is a package. The instantiation cannot cause an ABE when 13664 -- the package has no body. 13665 13666 elsif Ekind (Gen_Id) = E_Generic_Package 13667 and then not Has_Body (Spec_Decl) 13668 then 13669 return True; 13670 end if; 13671 13672 return False; 13673 end Is_Safe_Instantiation; 13674 13675 ------------------ 13676 -- Is_Same_Unit -- 13677 ------------------ 13678 13679 function Is_Same_Unit 13680 (Unit_1 : Entity_Id; 13681 Unit_2 : Entity_Id) return Boolean 13682 is 13683 begin 13684 return Unit_Entity (Unit_1) = Unit_Entity (Unit_2); 13685 end Is_Same_Unit; 13686 13687 ------------------------------- 13688 -- Kill_Elaboration_Scenario -- 13689 ------------------------------- 13690 13691 procedure Kill_Elaboration_Scenario (N : Node_Id) is 13692 begin 13693 -- Nothing to do when switch -gnatH (legacy elaboration checking mode 13694 -- enabled) is in effect because the legacy ABE lechanism does not need 13695 -- to carry out this action. 13696 13697 if Legacy_Elaboration_Checks then 13698 return; 13699 13700 -- Nothing to do when the elaboration phase of the compiler is not 13701 -- active. 13702 13703 elsif not Elaboration_Phase_Active then 13704 return; 13705 end if; 13706 13707 -- Eliminate a recorded scenario when it appears within dead code 13708 -- because it will not be executed at elaboration time. 13709 13710 if Is_Scenario (N) then 13711 Delete_Scenario (N); 13712 end if; 13713 end Kill_Elaboration_Scenario; 13714 13715 ---------------------- 13716 -- Main_Unit_Entity -- 13717 ---------------------- 13718 13719 function Main_Unit_Entity return Entity_Id is 13720 begin 13721 -- Note that Cunit_Entity (Main_Unit) is not reliable in the presence of 13722 -- generic bodies and may return an outdated entity. 13723 13724 return Defining_Entity (Unit (Cunit (Main_Unit))); 13725 end Main_Unit_Entity; 13726 13727 ---------------------- 13728 -- Non_Private_View -- 13729 ---------------------- 13730 13731 function Non_Private_View (Typ : Entity_Id) return Entity_Id is 13732 begin 13733 if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then 13734 return Full_View (Typ); 13735 else 13736 return Typ; 13737 end if; 13738 end Non_Private_View; 13739 13740 --------------------------------- 13741 -- Record_Elaboration_Scenario -- 13742 --------------------------------- 13743 13744 procedure Record_Elaboration_Scenario (N : Node_Id) is 13745 procedure Check_Preelaborated_Call 13746 (Call : Node_Id; 13747 Call_Lvl : Enclosing_Level_Kind); 13748 pragma Inline (Check_Preelaborated_Call); 13749 -- Verify that entry, operator, or subprogram call Call with enclosing 13750 -- level Call_Lvl does not appear at the library level of preelaborated 13751 -- unit. 13752 13753 function Find_Code_Unit (Nod : Node_Or_Entity_Id) return Entity_Id; 13754 pragma Inline (Find_Code_Unit); 13755 -- Return the code unit which contains arbitrary node or entity Nod. 13756 -- This is the unit of the file which physically contains the related 13757 -- construct denoted by Nod except when Nod is within an instantiation. 13758 -- In that case the unit is that of the top-level instantiation. 13759 13760 function In_Preelaborated_Context (Nod : Node_Id) return Boolean; 13761 pragma Inline (In_Preelaborated_Context); 13762 -- Determine whether arbitrary node Nod appears within a preelaborated 13763 -- context. 13764 13765 procedure Record_Access_Taken 13766 (Attr : Node_Id; 13767 Attr_Lvl : Enclosing_Level_Kind); 13768 pragma Inline (Record_Access_Taken); 13769 -- Record 'Access scenario Attr with enclosing level Attr_Lvl 13770 13771 procedure Record_Call_Or_Task_Activation 13772 (Call : Node_Id; 13773 Call_Lvl : Enclosing_Level_Kind); 13774 pragma Inline (Record_Call_Or_Task_Activation); 13775 -- Record call scenario Call with enclosing level Call_Lvl 13776 13777 procedure Record_Instantiation 13778 (Inst : Node_Id; 13779 Inst_Lvl : Enclosing_Level_Kind); 13780 pragma Inline (Record_Instantiation); 13781 -- Record instantiation scenario Inst with enclosing level Inst_Lvl 13782 13783 procedure Record_Variable_Assignment 13784 (Asmt : Node_Id; 13785 Asmt_Lvl : Enclosing_Level_Kind); 13786 pragma Inline (Record_Variable_Assignment); 13787 -- Record variable assignment scenario Asmt with enclosing level 13788 -- Asmt_Lvl. 13789 13790 procedure Record_Variable_Reference 13791 (Ref : Node_Id; 13792 Ref_Lvl : Enclosing_Level_Kind); 13793 pragma Inline (Record_Variable_Reference); 13794 -- Record variable reference scenario Ref with enclosing level Ref_Lvl 13795 13796 ------------------------------ 13797 -- Check_Preelaborated_Call -- 13798 ------------------------------ 13799 13800 procedure Check_Preelaborated_Call 13801 (Call : Node_Id; 13802 Call_Lvl : Enclosing_Level_Kind) 13803 is 13804 begin 13805 -- Nothing to do when the call is internally generated because it is 13806 -- assumed that it will never violate preelaboration. 13807 13808 if not Is_Source_Call (Call) then 13809 return; 13810 13811 -- Nothing to do when the call is preelaborable by definition 13812 13813 elsif Is_Preelaborable_Call (Call) then 13814 return; 13815 13816 -- Library-level calls are always considered because they are part of 13817 -- the associated unit's elaboration actions. 13818 13819 elsif Call_Lvl in Library_Level then 13820 null; 13821 13822 -- Calls at the library level of a generic package body have to be 13823 -- checked because they would render an instantiation illegal if the 13824 -- template is marked as preelaborated. Note that this does not apply 13825 -- to calls at the library level of a generic package spec. 13826 13827 elsif Call_Lvl = Generic_Body_Level then 13828 null; 13829 13830 -- Otherwise the call does not appear at the proper level and must 13831 -- not be considered for this check. 13832 13833 else 13834 return; 13835 end if; 13836 13837 -- If the call appears within a preelaborated unit, give an error 13838 13839 if In_Preelaborated_Context (Call) then 13840 Error_Preelaborated_Call (Call); 13841 end if; 13842 end Check_Preelaborated_Call; 13843 13844 -------------------- 13845 -- Find_Code_Unit -- 13846 -------------------- 13847 13848 function Find_Code_Unit (Nod : Node_Or_Entity_Id) return Entity_Id is 13849 begin 13850 return Find_Unit_Entity (Unit (Cunit (Get_Code_Unit (Nod)))); 13851 end Find_Code_Unit; 13852 13853 ------------------------------ 13854 -- In_Preelaborated_Context -- 13855 ------------------------------ 13856 13857 function In_Preelaborated_Context (Nod : Node_Id) return Boolean is 13858 Body_Id : constant Entity_Id := Find_Code_Unit (Nod); 13859 Spec_Id : constant Entity_Id := Unique_Entity (Body_Id); 13860 13861 begin 13862 -- The node appears within a package body whose corresponding spec is 13863 -- subject to pragma Remote_Call_Interface or Remote_Types. This does 13864 -- not result in a preelaborated context because the package body may 13865 -- be on another machine. 13866 13867 if Ekind (Body_Id) = E_Package_Body 13868 and then Is_Package_Or_Generic_Package (Spec_Id) 13869 and then (Is_Remote_Call_Interface (Spec_Id) 13870 or else Is_Remote_Types (Spec_Id)) 13871 then 13872 return False; 13873 13874 -- Otherwise the node appears within a preelaborated context when the 13875 -- associated unit is preelaborated. 13876 13877 else 13878 return Is_Preelaborated_Unit (Spec_Id); 13879 end if; 13880 end In_Preelaborated_Context; 13881 13882 ------------------------- 13883 -- Record_Access_Taken -- 13884 ------------------------- 13885 13886 procedure Record_Access_Taken 13887 (Attr : Node_Id; 13888 Attr_Lvl : Enclosing_Level_Kind) 13889 is 13890 begin 13891 -- Signal any enclosing local exception handlers that the 'Access may 13892 -- raise Program_Error due to a failed ABE check when switch -gnatd.o 13893 -- (conservative elaboration order for indirect calls) is in effect. 13894 -- Marking the exception handlers ensures proper expansion by both 13895 -- the front and back end restriction when No_Exception_Propagation 13896 -- is in effect. 13897 13898 if Debug_Flag_Dot_O then 13899 Possible_Local_Raise (Attr, Standard_Program_Error); 13900 end if; 13901 13902 -- Add 'Access to the appropriate set 13903 13904 if Attr_Lvl = Library_Body_Level then 13905 Add_Library_Body_Scenario (Attr); 13906 13907 elsif Attr_Lvl = Library_Spec_Level 13908 or else Attr_Lvl = Instantiation_Level 13909 then 13910 Add_Library_Spec_Scenario (Attr); 13911 end if; 13912 13913 -- 'Access requires a conditional ABE check when the dynamic model is 13914 -- in effect. 13915 13916 Add_Dynamic_ABE_Check_Scenario (Attr); 13917 end Record_Access_Taken; 13918 13919 ------------------------------------ 13920 -- Record_Call_Or_Task_Activation -- 13921 ------------------------------------ 13922 13923 procedure Record_Call_Or_Task_Activation 13924 (Call : Node_Id; 13925 Call_Lvl : Enclosing_Level_Kind) 13926 is 13927 begin 13928 -- Signal any enclosing local exception handlers that the call may 13929 -- raise Program_Error due to failed ABE check. Marking the exception 13930 -- handlers ensures proper expansion by both the front and back end 13931 -- restriction when No_Exception_Propagation is in effect. 13932 13933 Possible_Local_Raise (Call, Standard_Program_Error); 13934 13935 -- Perform early detection of guaranteed ABEs in order to suppress 13936 -- the instantiation of generic bodies because gigi cannot handle 13937 -- certain types of premature instantiations. 13938 13939 Process_Guaranteed_ABE 13940 (N => Call, 13941 In_State => Guaranteed_ABE_State); 13942 13943 -- Add the call or task activation to the appropriate set 13944 13945 if Call_Lvl = Declaration_Level then 13946 Add_Declaration_Scenario (Call); 13947 13948 elsif Call_Lvl = Library_Body_Level then 13949 Add_Library_Body_Scenario (Call); 13950 13951 elsif Call_Lvl = Library_Spec_Level 13952 or else Call_Lvl = Instantiation_Level 13953 then 13954 Add_Library_Spec_Scenario (Call); 13955 end if; 13956 13957 -- A call or a task activation requires a conditional ABE check when 13958 -- the dynamic model is in effect. 13959 13960 Add_Dynamic_ABE_Check_Scenario (Call); 13961 end Record_Call_Or_Task_Activation; 13962 13963 -------------------------- 13964 -- Record_Instantiation -- 13965 -------------------------- 13966 13967 procedure Record_Instantiation 13968 (Inst : Node_Id; 13969 Inst_Lvl : Enclosing_Level_Kind) 13970 is 13971 begin 13972 -- Signal enclosing local exception handlers that instantiation may 13973 -- raise Program_Error due to failed ABE check. Marking the exception 13974 -- handlers ensures proper expansion by both the front and back end 13975 -- restriction when No_Exception_Propagation is in effect. 13976 13977 Possible_Local_Raise (Inst, Standard_Program_Error); 13978 13979 -- Perform early detection of guaranteed ABEs in order to suppress 13980 -- the instantiation of generic bodies because gigi cannot handle 13981 -- certain types of premature instantiations. 13982 13983 Process_Guaranteed_ABE 13984 (N => Inst, 13985 In_State => Guaranteed_ABE_State); 13986 13987 -- Add the instantiation to the appropriate set 13988 13989 if Inst_Lvl = Declaration_Level then 13990 Add_Declaration_Scenario (Inst); 13991 13992 elsif Inst_Lvl = Library_Body_Level then 13993 Add_Library_Body_Scenario (Inst); 13994 13995 elsif Inst_Lvl = Library_Spec_Level 13996 or else Inst_Lvl = Instantiation_Level 13997 then 13998 Add_Library_Spec_Scenario (Inst); 13999 end if; 14000 14001 -- Instantiations of generics subject to SPARK_Mode On require 14002 -- elaboration-related checks even though the instantiations may 14003 -- not appear within elaboration code. 14004 14005 if Is_Suitable_SPARK_Instantiation (Inst) then 14006 Add_SPARK_Scenario (Inst); 14007 end if; 14008 14009 -- An instantiation requires a conditional ABE check when the dynamic 14010 -- model is in effect. 14011 14012 Add_Dynamic_ABE_Check_Scenario (Inst); 14013 end Record_Instantiation; 14014 14015 -------------------------------- 14016 -- Record_Variable_Assignment -- 14017 -------------------------------- 14018 14019 procedure Record_Variable_Assignment 14020 (Asmt : Node_Id; 14021 Asmt_Lvl : Enclosing_Level_Kind) 14022 is 14023 begin 14024 -- Add the variable assignment to the appropriate set 14025 14026 if Asmt_Lvl = Library_Body_Level then 14027 Add_Library_Body_Scenario (Asmt); 14028 14029 elsif Asmt_Lvl = Library_Spec_Level 14030 or else Asmt_Lvl = Instantiation_Level 14031 then 14032 Add_Library_Spec_Scenario (Asmt); 14033 end if; 14034 end Record_Variable_Assignment; 14035 14036 ------------------------------- 14037 -- Record_Variable_Reference -- 14038 ------------------------------- 14039 14040 procedure Record_Variable_Reference 14041 (Ref : Node_Id; 14042 Ref_Lvl : Enclosing_Level_Kind) 14043 is 14044 begin 14045 -- Add the variable reference to the appropriate set 14046 14047 if Ref_Lvl = Library_Body_Level then 14048 Add_Library_Body_Scenario (Ref); 14049 14050 elsif Ref_Lvl = Library_Spec_Level 14051 or else Ref_Lvl = Instantiation_Level 14052 then 14053 Add_Library_Spec_Scenario (Ref); 14054 end if; 14055 end Record_Variable_Reference; 14056 14057 -- Local variables 14058 14059 Scen : constant Node_Id := Scenario (N); 14060 Scen_Lvl : Enclosing_Level_Kind; 14061 14062 -- Start of processing for Record_Elaboration_Scenario 14063 14064 begin 14065 -- Nothing to do when switch -gnatH (legacy elaboration checking mode 14066 -- enabled) is in effect because the legacy ABE mechanism does not need 14067 -- to carry out this action. 14068 14069 if Legacy_Elaboration_Checks then 14070 return; 14071 14072 -- Nothing to do when the scenario is being preanalyzed 14073 14074 elsif Preanalysis_Active then 14075 return; 14076 14077 -- Nothing to do when the elaboration phase of the compiler is not 14078 -- active. 14079 14080 elsif not Elaboration_Phase_Active then 14081 return; 14082 end if; 14083 14084 Scen_Lvl := Find_Enclosing_Level (Scen); 14085 14086 -- Ensure that a library-level call does not appear in a preelaborated 14087 -- unit. The check must come before ignoring scenarios within external 14088 -- units or inside generics because calls in those context must also be 14089 -- verified. 14090 14091 if Is_Suitable_Call (Scen) then 14092 Check_Preelaborated_Call (Scen, Scen_Lvl); 14093 end if; 14094 14095 -- Nothing to do when the scenario does not appear within the main unit 14096 14097 if not In_Main_Context (Scen) then 14098 return; 14099 14100 -- Nothing to do when the scenario appears within a generic 14101 14102 elsif Inside_A_Generic then 14103 return; 14104 14105 -- 'Access 14106 14107 elsif Is_Suitable_Access_Taken (Scen) then 14108 Record_Access_Taken 14109 (Attr => Scen, 14110 Attr_Lvl => Scen_Lvl); 14111 14112 -- Call or task activation 14113 14114 elsif Is_Suitable_Call (Scen) then 14115 Record_Call_Or_Task_Activation 14116 (Call => Scen, 14117 Call_Lvl => Scen_Lvl); 14118 14119 -- Derived type declaration 14120 14121 elsif Is_Suitable_SPARK_Derived_Type (Scen) then 14122 Add_SPARK_Scenario (Scen); 14123 14124 -- Instantiation 14125 14126 elsif Is_Suitable_Instantiation (Scen) then 14127 Record_Instantiation 14128 (Inst => Scen, 14129 Inst_Lvl => Scen_Lvl); 14130 14131 -- Refined_State pragma 14132 14133 elsif Is_Suitable_SPARK_Refined_State_Pragma (Scen) then 14134 Add_SPARK_Scenario (Scen); 14135 14136 -- Variable assignment 14137 14138 elsif Is_Suitable_Variable_Assignment (Scen) then 14139 Record_Variable_Assignment 14140 (Asmt => Scen, 14141 Asmt_Lvl => Scen_Lvl); 14142 14143 -- Variable reference 14144 14145 elsif Is_Suitable_Variable_Reference (Scen) then 14146 Record_Variable_Reference 14147 (Ref => Scen, 14148 Ref_Lvl => Scen_Lvl); 14149 end if; 14150 end Record_Elaboration_Scenario; 14151 14152 -------------- 14153 -- Scenario -- 14154 -------------- 14155 14156 function Scenario (N : Node_Id) return Node_Id is 14157 Orig_N : constant Node_Id := Original_Node (N); 14158 14159 begin 14160 -- An expanded instantiation is rewritten into a spec-body pair where 14161 -- N denotes the spec. In this case the original instantiation is the 14162 -- proper elaboration scenario. 14163 14164 if Nkind (Orig_N) in N_Generic_Instantiation then 14165 return Orig_N; 14166 14167 -- Otherwise the scenario is already in its proper form 14168 14169 else 14170 return N; 14171 end if; 14172 end Scenario; 14173 14174 ---------------------- 14175 -- Scenario_Storage -- 14176 ---------------------- 14177 14178 package body Scenario_Storage is 14179 14180 --------------------- 14181 -- Data structures -- 14182 --------------------- 14183 14184 -- The following sets store all scenarios 14185 14186 Declaration_Scenarios : NE_Set.Membership_Set := NE_Set.Nil; 14187 Dynamic_ABE_Check_Scenarios : NE_Set.Membership_Set := NE_Set.Nil; 14188 Library_Body_Scenarios : NE_Set.Membership_Set := NE_Set.Nil; 14189 Library_Spec_Scenarios : NE_Set.Membership_Set := NE_Set.Nil; 14190 SPARK_Scenarios : NE_Set.Membership_Set := NE_Set.Nil; 14191 14192 ------------------------------- 14193 -- Finalize_Scenario_Storage -- 14194 ------------------------------- 14195 14196 procedure Finalize_Scenario_Storage is 14197 begin 14198 NE_Set.Destroy (Declaration_Scenarios); 14199 NE_Set.Destroy (Dynamic_ABE_Check_Scenarios); 14200 NE_Set.Destroy (Library_Body_Scenarios); 14201 NE_Set.Destroy (Library_Spec_Scenarios); 14202 NE_Set.Destroy (SPARK_Scenarios); 14203 end Finalize_Scenario_Storage; 14204 14205 --------------------------------- 14206 -- Initialize_Scenario_Storage -- 14207 --------------------------------- 14208 14209 procedure Initialize_Scenario_Storage is 14210 begin 14211 Declaration_Scenarios := NE_Set.Create (1000); 14212 Dynamic_ABE_Check_Scenarios := NE_Set.Create (500); 14213 Library_Body_Scenarios := NE_Set.Create (1000); 14214 Library_Spec_Scenarios := NE_Set.Create (1000); 14215 SPARK_Scenarios := NE_Set.Create (100); 14216 end Initialize_Scenario_Storage; 14217 14218 ------------------------------ 14219 -- Add_Declaration_Scenario -- 14220 ------------------------------ 14221 14222 procedure Add_Declaration_Scenario (N : Node_Id) is 14223 pragma Assert (Present (N)); 14224 begin 14225 NE_Set.Insert (Declaration_Scenarios, N); 14226 end Add_Declaration_Scenario; 14227 14228 ------------------------------------ 14229 -- Add_Dynamic_ABE_Check_Scenario -- 14230 ------------------------------------ 14231 14232 procedure Add_Dynamic_ABE_Check_Scenario (N : Node_Id) is 14233 pragma Assert (Present (N)); 14234 14235 begin 14236 if not Check_Or_Failure_Generation_OK then 14237 return; 14238 14239 -- Nothing to do if the dynamic model is not in effect 14240 14241 elsif not Dynamic_Elaboration_Checks then 14242 return; 14243 end if; 14244 14245 NE_Set.Insert (Dynamic_ABE_Check_Scenarios, N); 14246 end Add_Dynamic_ABE_Check_Scenario; 14247 14248 ------------------------------- 14249 -- Add_Library_Body_Scenario -- 14250 ------------------------------- 14251 14252 procedure Add_Library_Body_Scenario (N : Node_Id) is 14253 pragma Assert (Present (N)); 14254 begin 14255 NE_Set.Insert (Library_Body_Scenarios, N); 14256 end Add_Library_Body_Scenario; 14257 14258 ------------------------------- 14259 -- Add_Library_Spec_Scenario -- 14260 ------------------------------- 14261 14262 procedure Add_Library_Spec_Scenario (N : Node_Id) is 14263 pragma Assert (Present (N)); 14264 begin 14265 NE_Set.Insert (Library_Spec_Scenarios, N); 14266 end Add_Library_Spec_Scenario; 14267 14268 ------------------------ 14269 -- Add_SPARK_Scenario -- 14270 ------------------------ 14271 14272 procedure Add_SPARK_Scenario (N : Node_Id) is 14273 pragma Assert (Present (N)); 14274 begin 14275 NE_Set.Insert (SPARK_Scenarios, N); 14276 end Add_SPARK_Scenario; 14277 14278 --------------------- 14279 -- Delete_Scenario -- 14280 --------------------- 14281 14282 procedure Delete_Scenario (N : Node_Id) is 14283 pragma Assert (Present (N)); 14284 14285 begin 14286 -- Delete the scenario from whichever set it belongs to 14287 14288 NE_Set.Delete (Declaration_Scenarios, N); 14289 NE_Set.Delete (Dynamic_ABE_Check_Scenarios, N); 14290 NE_Set.Delete (Library_Body_Scenarios, N); 14291 NE_Set.Delete (Library_Spec_Scenarios, N); 14292 NE_Set.Delete (SPARK_Scenarios, N); 14293 end Delete_Scenario; 14294 14295 ----------------------------------- 14296 -- Iterate_Declaration_Scenarios -- 14297 ----------------------------------- 14298 14299 function Iterate_Declaration_Scenarios return NE_Set.Iterator is 14300 begin 14301 return NE_Set.Iterate (Declaration_Scenarios); 14302 end Iterate_Declaration_Scenarios; 14303 14304 ----------------------------------------- 14305 -- Iterate_Dynamic_ABE_Check_Scenarios -- 14306 ----------------------------------------- 14307 14308 function Iterate_Dynamic_ABE_Check_Scenarios return NE_Set.Iterator is 14309 begin 14310 return NE_Set.Iterate (Dynamic_ABE_Check_Scenarios); 14311 end Iterate_Dynamic_ABE_Check_Scenarios; 14312 14313 ------------------------------------ 14314 -- Iterate_Library_Body_Scenarios -- 14315 ------------------------------------ 14316 14317 function Iterate_Library_Body_Scenarios return NE_Set.Iterator is 14318 begin 14319 return NE_Set.Iterate (Library_Body_Scenarios); 14320 end Iterate_Library_Body_Scenarios; 14321 14322 ------------------------------------ 14323 -- Iterate_Library_Spec_Scenarios -- 14324 ------------------------------------ 14325 14326 function Iterate_Library_Spec_Scenarios return NE_Set.Iterator is 14327 begin 14328 return NE_Set.Iterate (Library_Spec_Scenarios); 14329 end Iterate_Library_Spec_Scenarios; 14330 14331 ----------------------------- 14332 -- Iterate_SPARK_Scenarios -- 14333 ----------------------------- 14334 14335 function Iterate_SPARK_Scenarios return NE_Set.Iterator is 14336 begin 14337 return NE_Set.Iterate (SPARK_Scenarios); 14338 end Iterate_SPARK_Scenarios; 14339 14340 ---------------------- 14341 -- Replace_Scenario -- 14342 ---------------------- 14343 14344 procedure Replace_Scenario (Old_N : Node_Id; New_N : Node_Id) is 14345 procedure Replace_Scenario_In (Scenarios : NE_Set.Membership_Set); 14346 -- Determine whether scenario Old_N is present in set Scenarios, and 14347 -- if this is the case it, replace it with New_N. 14348 14349 ------------------------- 14350 -- Replace_Scenario_In -- 14351 ------------------------- 14352 14353 procedure Replace_Scenario_In (Scenarios : NE_Set.Membership_Set) is 14354 begin 14355 -- The set is intentionally checked for existance because node 14356 -- rewriting may occur after Sem_Elab has verified all scenarios 14357 -- and data structures have been destroyed. 14358 14359 if NE_Set.Present (Scenarios) 14360 and then NE_Set.Contains (Scenarios, Old_N) 14361 then 14362 NE_Set.Delete (Scenarios, Old_N); 14363 NE_Set.Insert (Scenarios, New_N); 14364 end if; 14365 end Replace_Scenario_In; 14366 14367 -- Start of processing for Replace_Scenario 14368 14369 begin 14370 Replace_Scenario_In (Declaration_Scenarios); 14371 Replace_Scenario_In (Dynamic_ABE_Check_Scenarios); 14372 Replace_Scenario_In (Library_Body_Scenarios); 14373 Replace_Scenario_In (Library_Spec_Scenarios); 14374 Replace_Scenario_In (SPARK_Scenarios); 14375 end Replace_Scenario; 14376 end Scenario_Storage; 14377 14378 --------------- 14379 -- Semantics -- 14380 --------------- 14381 14382 package body Semantics is 14383 14384 -------------------------------- 14385 -- Is_Accept_Alternative_Proc -- 14386 -------------------------------- 14387 14388 function Is_Accept_Alternative_Proc (Id : Entity_Id) return Boolean is 14389 begin 14390 -- To qualify, the entity must denote a procedure with a receiving 14391 -- entry. 14392 14393 return 14394 Ekind (Id) = E_Procedure and then Present (Receiving_Entry (Id)); 14395 end Is_Accept_Alternative_Proc; 14396 14397 ------------------------ 14398 -- Is_Activation_Proc -- 14399 ------------------------ 14400 14401 function Is_Activation_Proc (Id : Entity_Id) return Boolean is 14402 begin 14403 -- To qualify, the entity must denote one of the runtime procedures 14404 -- in charge of task activation. 14405 14406 if Ekind (Id) = E_Procedure then 14407 if Restricted_Profile then 14408 return Is_RTE (Id, RE_Activate_Restricted_Tasks); 14409 else 14410 return Is_RTE (Id, RE_Activate_Tasks); 14411 end if; 14412 end if; 14413 14414 return False; 14415 end Is_Activation_Proc; 14416 14417 ---------------------------- 14418 -- Is_Ada_Semantic_Target -- 14419 ---------------------------- 14420 14421 function Is_Ada_Semantic_Target (Id : Entity_Id) return Boolean is 14422 begin 14423 return 14424 Is_Activation_Proc (Id) 14425 or else Is_Controlled_Proc (Id, Name_Adjust) 14426 or else Is_Controlled_Proc (Id, Name_Finalize) 14427 or else Is_Controlled_Proc (Id, Name_Initialize) 14428 or else Is_Init_Proc (Id) 14429 or else Is_Invariant_Proc (Id) 14430 or else Is_Protected_Entry (Id) 14431 or else Is_Protected_Subp (Id) 14432 or else Is_Protected_Body_Subp (Id) 14433 or else Is_Subprogram_Inst (Id) 14434 or else Is_Task_Entry (Id); 14435 end Is_Ada_Semantic_Target; 14436 14437 -------------------------------- 14438 -- Is_Assertion_Pragma_Target -- 14439 -------------------------------- 14440 14441 function Is_Assertion_Pragma_Target (Id : Entity_Id) return Boolean is 14442 begin 14443 return 14444 Is_Default_Initial_Condition_Proc (Id) 14445 or else Is_Initial_Condition_Proc (Id) 14446 or else Is_Invariant_Proc (Id) 14447 or else Is_Partial_Invariant_Proc (Id) 14448 or else Is_Postconditions_Proc (Id); 14449 end Is_Assertion_Pragma_Target; 14450 14451 ---------------------------- 14452 -- Is_Bodiless_Subprogram -- 14453 ---------------------------- 14454 14455 function Is_Bodiless_Subprogram (Subp_Id : Entity_Id) return Boolean is 14456 begin 14457 -- An abstract subprogram does not have a body 14458 14459 if Ekind (Subp_Id) in E_Function | E_Operator | E_Procedure 14460 and then Is_Abstract_Subprogram (Subp_Id) 14461 then 14462 return True; 14463 14464 -- A formal subprogram does not have a body 14465 14466 elsif Is_Formal_Subprogram (Subp_Id) then 14467 return True; 14468 14469 -- An imported subprogram may have a body, however it is not known at 14470 -- compile or bind time where the body resides and whether it will be 14471 -- elaborated on time. 14472 14473 elsif Is_Imported (Subp_Id) then 14474 return True; 14475 end if; 14476 14477 return False; 14478 end Is_Bodiless_Subprogram; 14479 14480 ---------------------- 14481 -- Is_Bridge_Target -- 14482 ---------------------- 14483 14484 function Is_Bridge_Target (Id : Entity_Id) return Boolean is 14485 begin 14486 return 14487 Is_Accept_Alternative_Proc (Id) 14488 or else Is_Finalizer_Proc (Id) 14489 or else Is_Partial_Invariant_Proc (Id) 14490 or else Is_Postconditions_Proc (Id) 14491 or else Is_TSS (Id, TSS_Deep_Adjust) 14492 or else Is_TSS (Id, TSS_Deep_Finalize) 14493 or else Is_TSS (Id, TSS_Deep_Initialize); 14494 end Is_Bridge_Target; 14495 14496 ------------------------ 14497 -- Is_Controlled_Proc -- 14498 ------------------------ 14499 14500 function Is_Controlled_Proc 14501 (Subp_Id : Entity_Id; 14502 Subp_Nam : Name_Id) return Boolean 14503 is 14504 Formal_Id : Entity_Id; 14505 14506 begin 14507 pragma Assert 14508 (Subp_Nam in Name_Adjust | Name_Finalize | Name_Initialize); 14509 14510 -- To qualify, the subprogram must denote a source procedure with 14511 -- name Adjust, Finalize, or Initialize where the sole formal is 14512 -- controlled. 14513 14514 if Comes_From_Source (Subp_Id) 14515 and then Ekind (Subp_Id) = E_Procedure 14516 and then Chars (Subp_Id) = Subp_Nam 14517 then 14518 Formal_Id := First_Formal (Subp_Id); 14519 14520 return 14521 Present (Formal_Id) 14522 and then Is_Controlled (Etype (Formal_Id)) 14523 and then No (Next_Formal (Formal_Id)); 14524 end if; 14525 14526 return False; 14527 end Is_Controlled_Proc; 14528 14529 --------------------------------------- 14530 -- Is_Default_Initial_Condition_Proc -- 14531 --------------------------------------- 14532 14533 function Is_Default_Initial_Condition_Proc 14534 (Id : Entity_Id) return Boolean 14535 is 14536 begin 14537 -- To qualify, the entity must denote a Default_Initial_Condition 14538 -- procedure. 14539 14540 return Ekind (Id) = E_Procedure and then Is_DIC_Procedure (Id); 14541 end Is_Default_Initial_Condition_Proc; 14542 14543 ----------------------- 14544 -- Is_Finalizer_Proc -- 14545 ----------------------- 14546 14547 function Is_Finalizer_Proc (Id : Entity_Id) return Boolean is 14548 begin 14549 -- To qualify, the entity must denote a _Finalizer procedure 14550 14551 return Ekind (Id) = E_Procedure and then Chars (Id) = Name_uFinalizer; 14552 end Is_Finalizer_Proc; 14553 14554 ------------------------------- 14555 -- Is_Initial_Condition_Proc -- 14556 ------------------------------- 14557 14558 function Is_Initial_Condition_Proc (Id : Entity_Id) return Boolean is 14559 begin 14560 -- To qualify, the entity must denote an Initial_Condition procedure 14561 14562 return 14563 Ekind (Id) = E_Procedure 14564 and then Is_Initial_Condition_Procedure (Id); 14565 end Is_Initial_Condition_Proc; 14566 14567 -------------------- 14568 -- Is_Initialized -- 14569 -------------------- 14570 14571 function Is_Initialized (Obj_Decl : Node_Id) return Boolean is 14572 begin 14573 -- To qualify, the object declaration must have an expression 14574 14575 return 14576 Present (Expression (Obj_Decl)) 14577 or else Has_Init_Expression (Obj_Decl); 14578 end Is_Initialized; 14579 14580 ----------------------- 14581 -- Is_Invariant_Proc -- 14582 ----------------------- 14583 14584 function Is_Invariant_Proc (Id : Entity_Id) return Boolean is 14585 begin 14586 -- To qualify, the entity must denote the "full" invariant procedure 14587 14588 return Ekind (Id) = E_Procedure and then Is_Invariant_Procedure (Id); 14589 end Is_Invariant_Proc; 14590 14591 --------------------------------------- 14592 -- Is_Non_Library_Level_Encapsulator -- 14593 --------------------------------------- 14594 14595 function Is_Non_Library_Level_Encapsulator 14596 (N : Node_Id) return Boolean 14597 is 14598 begin 14599 case Nkind (N) is 14600 when N_Abstract_Subprogram_Declaration 14601 | N_Aspect_Specification 14602 | N_Component_Declaration 14603 | N_Entry_Body 14604 | N_Entry_Declaration 14605 | N_Expression_Function 14606 | N_Formal_Abstract_Subprogram_Declaration 14607 | N_Formal_Concrete_Subprogram_Declaration 14608 | N_Formal_Object_Declaration 14609 | N_Formal_Package_Declaration 14610 | N_Formal_Type_Declaration 14611 | N_Generic_Association 14612 | N_Implicit_Label_Declaration 14613 | N_Incomplete_Type_Declaration 14614 | N_Private_Extension_Declaration 14615 | N_Private_Type_Declaration 14616 | N_Protected_Body 14617 | N_Protected_Type_Declaration 14618 | N_Single_Protected_Declaration 14619 | N_Single_Task_Declaration 14620 | N_Subprogram_Body 14621 | N_Subprogram_Declaration 14622 | N_Task_Body 14623 | N_Task_Type_Declaration 14624 => 14625 return True; 14626 14627 when others => 14628 return Is_Generic_Declaration_Or_Body (N); 14629 end case; 14630 end Is_Non_Library_Level_Encapsulator; 14631 14632 ------------------------------- 14633 -- Is_Partial_Invariant_Proc -- 14634 ------------------------------- 14635 14636 function Is_Partial_Invariant_Proc (Id : Entity_Id) return Boolean is 14637 begin 14638 -- To qualify, the entity must denote the "partial" invariant 14639 -- procedure. 14640 14641 return 14642 Ekind (Id) = E_Procedure 14643 and then Is_Partial_Invariant_Procedure (Id); 14644 end Is_Partial_Invariant_Proc; 14645 14646 ---------------------------- 14647 -- Is_Postconditions_Proc -- 14648 ---------------------------- 14649 14650 function Is_Postconditions_Proc (Id : Entity_Id) return Boolean is 14651 begin 14652 -- To qualify, the entity must denote a _Postconditions procedure 14653 14654 return 14655 Ekind (Id) = E_Procedure and then Chars (Id) = Name_uPostconditions; 14656 end Is_Postconditions_Proc; 14657 14658 --------------------------- 14659 -- Is_Preelaborated_Unit -- 14660 --------------------------- 14661 14662 function Is_Preelaborated_Unit (Id : Entity_Id) return Boolean is 14663 begin 14664 return 14665 Is_Preelaborated (Id) 14666 or else Is_Pure (Id) 14667 or else Is_Remote_Call_Interface (Id) 14668 or else Is_Remote_Types (Id) 14669 or else Is_Shared_Passive (Id); 14670 end Is_Preelaborated_Unit; 14671 14672 ------------------------ 14673 -- Is_Protected_Entry -- 14674 ------------------------ 14675 14676 function Is_Protected_Entry (Id : Entity_Id) return Boolean is 14677 begin 14678 -- To qualify, the entity must denote an entry defined in a protected 14679 -- type. 14680 14681 return 14682 Is_Entry (Id) 14683 and then Is_Protected_Type (Non_Private_View (Scope (Id))); 14684 end Is_Protected_Entry; 14685 14686 ----------------------- 14687 -- Is_Protected_Subp -- 14688 ----------------------- 14689 14690 function Is_Protected_Subp (Id : Entity_Id) return Boolean is 14691 begin 14692 -- To qualify, the entity must denote a subprogram defined within a 14693 -- protected type. 14694 14695 return 14696 Ekind (Id) in E_Function | E_Procedure 14697 and then Is_Protected_Type (Non_Private_View (Scope (Id))); 14698 end Is_Protected_Subp; 14699 14700 ---------------------------- 14701 -- Is_Protected_Body_Subp -- 14702 ---------------------------- 14703 14704 function Is_Protected_Body_Subp (Id : Entity_Id) return Boolean is 14705 begin 14706 -- To qualify, the entity must denote a subprogram with attribute 14707 -- Protected_Subprogram set. 14708 14709 return 14710 Ekind (Id) in E_Function | E_Procedure 14711 and then Present (Protected_Subprogram (Id)); 14712 end Is_Protected_Body_Subp; 14713 14714 ----------------- 14715 -- Is_Scenario -- 14716 ----------------- 14717 14718 function Is_Scenario (N : Node_Id) return Boolean is 14719 begin 14720 case Nkind (N) is 14721 when N_Assignment_Statement 14722 | N_Attribute_Reference 14723 | N_Call_Marker 14724 | N_Entry_Call_Statement 14725 | N_Expanded_Name 14726 | N_Function_Call 14727 | N_Function_Instantiation 14728 | N_Identifier 14729 | N_Package_Instantiation 14730 | N_Procedure_Call_Statement 14731 | N_Procedure_Instantiation 14732 | N_Requeue_Statement 14733 => 14734 return True; 14735 14736 when others => 14737 return False; 14738 end case; 14739 end Is_Scenario; 14740 14741 ------------------------------ 14742 -- Is_SPARK_Semantic_Target -- 14743 ------------------------------ 14744 14745 function Is_SPARK_Semantic_Target (Id : Entity_Id) return Boolean is 14746 begin 14747 return 14748 Is_Default_Initial_Condition_Proc (Id) 14749 or else Is_Initial_Condition_Proc (Id); 14750 end Is_SPARK_Semantic_Target; 14751 14752 ------------------------ 14753 -- Is_Subprogram_Inst -- 14754 ------------------------ 14755 14756 function Is_Subprogram_Inst (Id : Entity_Id) return Boolean is 14757 begin 14758 -- To qualify, the entity must denote a function or a procedure which 14759 -- is hidden within an anonymous package, and is a generic instance. 14760 14761 return 14762 Ekind (Id) in E_Function | E_Procedure 14763 and then Is_Hidden (Id) 14764 and then Is_Generic_Instance (Id); 14765 end Is_Subprogram_Inst; 14766 14767 ------------------------------ 14768 -- Is_Suitable_Access_Taken -- 14769 ------------------------------ 14770 14771 function Is_Suitable_Access_Taken (N : Node_Id) return Boolean is 14772 Nam : Name_Id; 14773 Pref : Node_Id; 14774 Subp_Id : Entity_Id; 14775 14776 begin 14777 -- Nothing to do when switch -gnatd.U (ignore 'Access) is in effect 14778 14779 if Debug_Flag_Dot_UU then 14780 return False; 14781 14782 -- Nothing to do when the scenario is not an attribute reference 14783 14784 elsif Nkind (N) /= N_Attribute_Reference then 14785 return False; 14786 14787 -- Nothing to do for internally-generated attributes because they are 14788 -- assumed to be ABE safe. 14789 14790 elsif not Comes_From_Source (N) then 14791 return False; 14792 end if; 14793 14794 Nam := Attribute_Name (N); 14795 Pref := Prefix (N); 14796 14797 -- Sanitize the prefix of the attribute 14798 14799 if not Is_Entity_Name (Pref) then 14800 return False; 14801 14802 elsif No (Entity (Pref)) then 14803 return False; 14804 end if; 14805 14806 Subp_Id := Entity (Pref); 14807 14808 if not Is_Subprogram_Or_Entry (Subp_Id) then 14809 return False; 14810 end if; 14811 14812 -- Traverse a possible chain of renamings to obtain the original 14813 -- entry or subprogram which the prefix may rename. 14814 14815 Subp_Id := Get_Renamed_Entity (Subp_Id); 14816 14817 -- To qualify, the attribute must meet the following prerequisites: 14818 14819 return 14820 14821 -- The prefix must denote a source entry, operator, or subprogram 14822 -- which is not imported. 14823 14824 Comes_From_Source (Subp_Id) 14825 and then Is_Subprogram_Or_Entry (Subp_Id) 14826 and then not Is_Bodiless_Subprogram (Subp_Id) 14827 14828 -- The attribute name must be one of the 'Access forms. Note that 14829 -- 'Unchecked_Access cannot apply to a subprogram. 14830 14831 and then Nam in Name_Access | Name_Unrestricted_Access; 14832 end Is_Suitable_Access_Taken; 14833 14834 ---------------------- 14835 -- Is_Suitable_Call -- 14836 ---------------------- 14837 14838 function Is_Suitable_Call (N : Node_Id) return Boolean is 14839 begin 14840 -- Entry and subprogram calls are intentionally ignored because they 14841 -- may undergo expansion depending on the compilation mode, previous 14842 -- errors, generic context, etc. Call markers play the role of calls 14843 -- and provide a uniform foundation for ABE processing. 14844 14845 return Nkind (N) = N_Call_Marker; 14846 end Is_Suitable_Call; 14847 14848 ------------------------------- 14849 -- Is_Suitable_Instantiation -- 14850 ------------------------------- 14851 14852 function Is_Suitable_Instantiation (N : Node_Id) return Boolean is 14853 Inst : constant Node_Id := Scenario (N); 14854 14855 begin 14856 -- To qualify, the instantiation must come from source 14857 14858 return 14859 Comes_From_Source (Inst) 14860 and then Nkind (Inst) in N_Generic_Instantiation; 14861 end Is_Suitable_Instantiation; 14862 14863 ------------------------------------ 14864 -- Is_Suitable_SPARK_Derived_Type -- 14865 ------------------------------------ 14866 14867 function Is_Suitable_SPARK_Derived_Type (N : Node_Id) return Boolean is 14868 Prag : Node_Id; 14869 Typ : Entity_Id; 14870 14871 begin 14872 -- To qualify, the type declaration must denote a derived tagged type 14873 -- with primitive operations, subject to pragma SPARK_Mode On. 14874 14875 if Nkind (N) = N_Full_Type_Declaration 14876 and then Nkind (Type_Definition (N)) = N_Derived_Type_Definition 14877 then 14878 Typ := Defining_Entity (N); 14879 Prag := SPARK_Pragma (Typ); 14880 14881 return 14882 Is_Tagged_Type (Typ) 14883 and then Has_Primitive_Operations (Typ) 14884 and then Present (Prag) 14885 and then Get_SPARK_Mode_From_Annotation (Prag) = On; 14886 end if; 14887 14888 return False; 14889 end Is_Suitable_SPARK_Derived_Type; 14890 14891 ------------------------------------- 14892 -- Is_Suitable_SPARK_Instantiation -- 14893 ------------------------------------- 14894 14895 function Is_Suitable_SPARK_Instantiation (N : Node_Id) return Boolean is 14896 Inst : constant Node_Id := Scenario (N); 14897 14898 Gen_Id : Entity_Id; 14899 Prag : Node_Id; 14900 14901 begin 14902 -- To qualify, both the instantiation and the generic must be subject 14903 -- to SPARK_Mode On. 14904 14905 if Is_Suitable_Instantiation (N) then 14906 Gen_Id := Instantiated_Generic (Inst); 14907 Prag := SPARK_Pragma (Gen_Id); 14908 14909 return 14910 Is_SPARK_Mode_On_Node (Inst) 14911 and then Present (Prag) 14912 and then Get_SPARK_Mode_From_Annotation (Prag) = On; 14913 end if; 14914 14915 return False; 14916 end Is_Suitable_SPARK_Instantiation; 14917 14918 -------------------------------------------- 14919 -- Is_Suitable_SPARK_Refined_State_Pragma -- 14920 -------------------------------------------- 14921 14922 function Is_Suitable_SPARK_Refined_State_Pragma 14923 (N : Node_Id) return Boolean 14924 is 14925 begin 14926 -- To qualfy, the pragma must denote Refined_State 14927 14928 return 14929 Nkind (N) = N_Pragma 14930 and then Pragma_Name (N) = Name_Refined_State; 14931 end Is_Suitable_SPARK_Refined_State_Pragma; 14932 14933 ------------------------------------- 14934 -- Is_Suitable_Variable_Assignment -- 14935 ------------------------------------- 14936 14937 function Is_Suitable_Variable_Assignment (N : Node_Id) return Boolean is 14938 N_Unit : Node_Id; 14939 N_Unit_Id : Entity_Id; 14940 Nam : Node_Id; 14941 Var_Decl : Node_Id; 14942 Var_Id : Entity_Id; 14943 Var_Unit : Node_Id; 14944 Var_Unit_Id : Entity_Id; 14945 14946 begin 14947 -- Nothing to do when the scenario is not an assignment 14948 14949 if Nkind (N) /= N_Assignment_Statement then 14950 return False; 14951 14952 -- Nothing to do for internally-generated assignments because they 14953 -- are assumed to be ABE safe. 14954 14955 elsif not Comes_From_Source (N) then 14956 return False; 14957 14958 -- Assignments are ignored in GNAT mode on the assumption that 14959 -- they are ABE-safe. This behavior parallels that of the old 14960 -- ABE mechanism. 14961 14962 elsif GNAT_Mode then 14963 return False; 14964 end if; 14965 14966 Nam := Assignment_Target (N); 14967 14968 -- Sanitize the left hand side of the assignment 14969 14970 if not Is_Entity_Name (Nam) then 14971 return False; 14972 14973 elsif No (Entity (Nam)) then 14974 return False; 14975 end if; 14976 14977 Var_Id := Entity (Nam); 14978 14979 -- Sanitize the variable 14980 14981 if Var_Id = Any_Id then 14982 return False; 14983 14984 elsif Ekind (Var_Id) /= E_Variable then 14985 return False; 14986 end if; 14987 14988 Var_Decl := Declaration_Node (Var_Id); 14989 14990 if Nkind (Var_Decl) /= N_Object_Declaration then 14991 return False; 14992 end if; 14993 14994 N_Unit_Id := Find_Top_Unit (N); 14995 N_Unit := Unit_Declaration_Node (N_Unit_Id); 14996 14997 Var_Unit_Id := Find_Top_Unit (Var_Decl); 14998 Var_Unit := Unit_Declaration_Node (Var_Unit_Id); 14999 15000 -- To qualify, the assignment must meet the following prerequisites: 15001 15002 return 15003 Comes_From_Source (Var_Id) 15004 15005 -- The variable must be declared in the spec of compilation unit 15006 -- U. 15007 15008 and then Nkind (Var_Unit) = N_Package_Declaration 15009 and then Find_Enclosing_Level (Var_Decl) = Library_Spec_Level 15010 15011 -- The assignment must occur in the body of compilation unit U 15012 15013 and then Nkind (N_Unit) = N_Package_Body 15014 and then Present (Corresponding_Body (Var_Unit)) 15015 and then Corresponding_Body (Var_Unit) = N_Unit_Id; 15016 end Is_Suitable_Variable_Assignment; 15017 15018 ------------------------------------ 15019 -- Is_Suitable_Variable_Reference -- 15020 ------------------------------------ 15021 15022 function Is_Suitable_Variable_Reference (N : Node_Id) return Boolean is 15023 begin 15024 -- Expanded names and identifiers are intentionally ignored because 15025 -- they be folded, optimized away, etc. Variable references markers 15026 -- play the role of variable references and provide a uniform 15027 -- foundation for ABE processing. 15028 15029 return Nkind (N) = N_Variable_Reference_Marker; 15030 end Is_Suitable_Variable_Reference; 15031 15032 ------------------- 15033 -- Is_Task_Entry -- 15034 ------------------- 15035 15036 function Is_Task_Entry (Id : Entity_Id) return Boolean is 15037 begin 15038 -- To qualify, the entity must denote an entry defined in a task type 15039 15040 return 15041 Is_Entry (Id) and then Is_Task_Type (Non_Private_View (Scope (Id))); 15042 end Is_Task_Entry; 15043 15044 ------------------------ 15045 -- Is_Up_Level_Target -- 15046 ------------------------ 15047 15048 function Is_Up_Level_Target 15049 (Targ_Decl : Node_Id; 15050 In_State : Processing_In_State) return Boolean 15051 is 15052 Root : constant Node_Id := Root_Scenario; 15053 Root_Rep : constant Scenario_Rep_Id := 15054 Scenario_Representation_Of (Root, In_State); 15055 15056 begin 15057 -- The root appears within the declaratons of a block statement, 15058 -- entry body, subprogram body, or task body ignoring enclosing 15059 -- packages. The root is always within the main unit. 15060 15061 if not In_State.Suppress_Up_Level_Targets 15062 and then Level (Root_Rep) = Declaration_Level 15063 then 15064 -- The target is within the main unit. It acts as an up-level 15065 -- target when it appears within a context which encloses the 15066 -- root. 15067 -- 15068 -- package body Main_Unit is 15069 -- function Func ...; -- target 15070 -- 15071 -- procedure Proc is 15072 -- X : ... := Func; -- root scenario 15073 15074 if In_Extended_Main_Code_Unit (Targ_Decl) then 15075 return not In_Same_Context (Root, Targ_Decl, Nested_OK => True); 15076 15077 -- Otherwise the target is external to the main unit which makes 15078 -- it an up-level target. 15079 15080 else 15081 return True; 15082 end if; 15083 end if; 15084 15085 return False; 15086 end Is_Up_Level_Target; 15087 end Semantics; 15088 15089 --------------------------- 15090 -- Set_Elaboration_Phase -- 15091 --------------------------- 15092 15093 procedure Set_Elaboration_Phase (Status : Elaboration_Phase_Status) is 15094 begin 15095 Elaboration_Phase := Status; 15096 end Set_Elaboration_Phase; 15097 15098 --------------------- 15099 -- SPARK_Processor -- 15100 --------------------- 15101 15102 package body SPARK_Processor is 15103 15104 ----------------------- 15105 -- Local subprograms -- 15106 ----------------------- 15107 15108 procedure Process_SPARK_Derived_Type 15109 (Typ_Decl : Node_Id; 15110 Typ_Rep : Scenario_Rep_Id; 15111 In_State : Processing_In_State); 15112 pragma Inline (Process_SPARK_Derived_Type); 15113 -- Verify that the freeze node of a derived type denoted by declaration 15114 -- Typ_Decl is within the early call region of each overriding primitive 15115 -- body that belongs to the derived type (SPARK RM 7.7(8)). Typ_Rep is 15116 -- the representation of the type. In_State denotes the current state of 15117 -- the Processing phase. 15118 15119 procedure Process_SPARK_Instantiation 15120 (Inst : Node_Id; 15121 Inst_Rep : Scenario_Rep_Id; 15122 In_State : Processing_In_State); 15123 pragma Inline (Process_SPARK_Instantiation); 15124 -- Verify that instanciation Inst does not precede the generic body it 15125 -- instantiates (SPARK RM 7.7(6)). Inst_Rep is the representation of the 15126 -- instantiation. In_State is the current state of the Processing phase. 15127 15128 procedure Process_SPARK_Refined_State_Pragma 15129 (Prag : Node_Id; 15130 Prag_Rep : Scenario_Rep_Id; 15131 In_State : Processing_In_State); 15132 pragma Inline (Process_SPARK_Refined_State_Pragma); 15133 -- Verify that each constituent of Refined_State pragma Prag which 15134 -- belongs to abstract state mentioned in pragma Initializes has prior 15135 -- elaboration with respect to the main unit (SPARK RM 7.7.1(7)). 15136 -- Prag_Rep is the representation of the pragma. In_State denotes the 15137 -- current state of the Processing phase. 15138 15139 procedure Process_SPARK_Scenario 15140 (N : Node_Id; 15141 In_State : Processing_In_State); 15142 pragma Inline (Process_SPARK_Scenario); 15143 -- Top-level dispatcher for verifying SPARK scenarios which are not 15144 -- always executable during elaboration but still need elaboration- 15145 -- related checks. In_State is the current state of the Processing 15146 -- phase. 15147 15148 --------------------------------- 15149 -- Check_SPARK_Model_In_Effect -- 15150 --------------------------------- 15151 15152 SPARK_Model_Warning_Posted : Boolean := False; 15153 -- This flag prevents the same SPARK model-related warning from being 15154 -- emitted multiple times. 15155 15156 procedure Check_SPARK_Model_In_Effect is 15157 Spec_Id : constant Entity_Id := Unique_Entity (Main_Unit_Entity); 15158 15159 begin 15160 -- Do not emit the warning multiple times as this creates useless 15161 -- noise. 15162 15163 if SPARK_Model_Warning_Posted then 15164 null; 15165 15166 -- SPARK rule verification requires the "strict" static model 15167 15168 elsif Static_Elaboration_Checks 15169 and not Relaxed_Elaboration_Checks 15170 then 15171 null; 15172 15173 -- Any other combination of models does not guarantee the absence of 15174 -- ABE problems for SPARK rule verification purposes. Note that there 15175 -- is no need to check for the presence of the legacy ABE mechanism 15176 -- because the legacy code has its own dedicated processing for SPARK 15177 -- rules. 15178 15179 else 15180 SPARK_Model_Warning_Posted := True; 15181 15182 Error_Msg_N 15183 ("??SPARK elaboration checks require static elaboration model", 15184 Spec_Id); 15185 15186 if Dynamic_Elaboration_Checks then 15187 Error_Msg_N 15188 ("\dynamic elaboration model is in effect", Spec_Id); 15189 15190 else 15191 pragma Assert (Relaxed_Elaboration_Checks); 15192 Error_Msg_N 15193 ("\relaxed elaboration model is in effect", Spec_Id); 15194 end if; 15195 end if; 15196 end Check_SPARK_Model_In_Effect; 15197 15198 --------------------------- 15199 -- Check_SPARK_Scenarios -- 15200 --------------------------- 15201 15202 procedure Check_SPARK_Scenarios is 15203 Iter : NE_Set.Iterator; 15204 N : Node_Id; 15205 15206 begin 15207 Iter := Iterate_SPARK_Scenarios; 15208 while NE_Set.Has_Next (Iter) loop 15209 NE_Set.Next (Iter, N); 15210 15211 Process_SPARK_Scenario 15212 (N => N, 15213 In_State => SPARK_State); 15214 end loop; 15215 end Check_SPARK_Scenarios; 15216 15217 -------------------------------- 15218 -- Process_SPARK_Derived_Type -- 15219 -------------------------------- 15220 15221 procedure Process_SPARK_Derived_Type 15222 (Typ_Decl : Node_Id; 15223 Typ_Rep : Scenario_Rep_Id; 15224 In_State : Processing_In_State) 15225 is 15226 pragma Unreferenced (In_State); 15227 15228 Typ : constant Entity_Id := Target (Typ_Rep); 15229 15230 Stop_Check : exception; 15231 -- This exception is raised when the freeze node violates the 15232 -- placement rules. 15233 15234 procedure Check_Overriding_Primitive 15235 (Prim : Entity_Id; 15236 FNode : Node_Id); 15237 pragma Inline (Check_Overriding_Primitive); 15238 -- Verify that freeze node FNode is within the early call region of 15239 -- overriding primitive Prim's body. 15240 15241 function Freeze_Node_Location (FNode : Node_Id) return Source_Ptr; 15242 pragma Inline (Freeze_Node_Location); 15243 -- Return a more accurate source location associated with freeze node 15244 -- FNode. 15245 15246 function Precedes_Source_Construct (N : Node_Id) return Boolean; 15247 pragma Inline (Precedes_Source_Construct); 15248 -- Determine whether arbitrary node N appears prior to some source 15249 -- construct. 15250 15251 procedure Suggest_Elaborate_Body 15252 (N : Node_Id; 15253 Body_Decl : Node_Id; 15254 Error_Nod : Node_Id); 15255 pragma Inline (Suggest_Elaborate_Body); 15256 -- Suggest the use of pragma Elaborate_Body when the pragma will 15257 -- allow for node N to appear within the early call region of 15258 -- subprogram body Body_Decl. The suggestion is attached to 15259 -- Error_Nod as a continuation error. 15260 15261 -------------------------------- 15262 -- Check_Overriding_Primitive -- 15263 -------------------------------- 15264 15265 procedure Check_Overriding_Primitive 15266 (Prim : Entity_Id; 15267 FNode : Node_Id) 15268 is 15269 Prim_Decl : constant Node_Id := Unit_Declaration_Node (Prim); 15270 Body_Decl : Node_Id; 15271 Body_Id : Entity_Id; 15272 Region : Node_Id; 15273 15274 begin 15275 -- Nothing to do for predefined primitives because they are 15276 -- artifacts of tagged type expansion and cannot override source 15277 -- primitives. Nothing to do as well for inherited primitives, as 15278 -- the check concerns overriding ones. 15279 15280 if Is_Predefined_Dispatching_Operation (Prim) 15281 or else not Is_Overriding_Subprogram (Prim) 15282 then 15283 return; 15284 end if; 15285 15286 Body_Id := Corresponding_Body (Prim_Decl); 15287 15288 -- Nothing to do when the primitive does not have a corresponding 15289 -- body. This can happen when the unit with the bodies is not the 15290 -- main unit subjected to ABE checks. 15291 15292 if No (Body_Id) then 15293 return; 15294 15295 -- The primitive overrides a parent or progenitor primitive 15296 15297 elsif Present (Overridden_Operation (Prim)) then 15298 15299 -- Nothing to do when overriding an interface primitive happens 15300 -- by inheriting a non-interface primitive as the check would 15301 -- be done on the parent primitive. 15302 15303 if Present (Alias (Prim)) then 15304 return; 15305 end if; 15306 15307 -- Nothing to do when the primitive is not overriding. The body of 15308 -- such a primitive cannot be targeted by a dispatching call which 15309 -- is executable during elaboration, and cannot cause an ABE. 15310 15311 else 15312 return; 15313 end if; 15314 15315 Body_Decl := Unit_Declaration_Node (Body_Id); 15316 Region := Find_Early_Call_Region (Body_Decl); 15317 15318 -- The freeze node appears prior to the early call region of the 15319 -- primitive body. 15320 15321 -- IMPORTANT: This check must always be performed even when 15322 -- -gnatd.v (enforce SPARK elaboration rules in SPARK code) is not 15323 -- specified because the static model cannot guarantee the absence 15324 -- of ABEs in the presence of dispatching calls. 15325 15326 if Earlier_In_Extended_Unit (FNode, Region) then 15327 Error_Msg_Node_2 := Prim; 15328 Error_Msg_NE 15329 ("first freezing point of type & must appear within early " 15330 & "call region of primitive body & (SPARK RM 7.7(8))", 15331 Typ_Decl, Typ); 15332 15333 Error_Msg_Sloc := Sloc (Region); 15334 Error_Msg_N ("\region starts #", Typ_Decl); 15335 15336 Error_Msg_Sloc := Sloc (Body_Decl); 15337 Error_Msg_N ("\region ends #", Typ_Decl); 15338 15339 Error_Msg_Sloc := Freeze_Node_Location (FNode); 15340 Error_Msg_N ("\first freezing point #", Typ_Decl); 15341 15342 -- If applicable, suggest the use of pragma Elaborate_Body in 15343 -- the associated package spec. 15344 15345 Suggest_Elaborate_Body 15346 (N => FNode, 15347 Body_Decl => Body_Decl, 15348 Error_Nod => Typ_Decl); 15349 15350 raise Stop_Check; 15351 end if; 15352 end Check_Overriding_Primitive; 15353 15354 -------------------------- 15355 -- Freeze_Node_Location -- 15356 -------------------------- 15357 15358 function Freeze_Node_Location (FNode : Node_Id) return Source_Ptr is 15359 Context : constant Node_Id := Parent (FNode); 15360 Loc : constant Source_Ptr := Sloc (FNode); 15361 15362 Prv_Decls : List_Id; 15363 Vis_Decls : List_Id; 15364 15365 begin 15366 -- In general, the source location of the freeze node is as close 15367 -- as possible to the real freeze point, except when the freeze 15368 -- node is at the "bottom" of a package spec. 15369 15370 if Nkind (Context) = N_Package_Specification then 15371 Prv_Decls := Private_Declarations (Context); 15372 Vis_Decls := Visible_Declarations (Context); 15373 15374 -- The freeze node appears in the private declarations of the 15375 -- package. 15376 15377 if Present (Prv_Decls) 15378 and then List_Containing (FNode) = Prv_Decls 15379 then 15380 null; 15381 15382 -- The freeze node appears in the visible declarations of the 15383 -- package and there are no private declarations. 15384 15385 elsif Present (Vis_Decls) 15386 and then List_Containing (FNode) = Vis_Decls 15387 and then (No (Prv_Decls) or else Is_Empty_List (Prv_Decls)) 15388 then 15389 null; 15390 15391 -- Otherwise the freeze node is not in the "last" declarative 15392 -- list of the package. Use the existing source location of the 15393 -- freeze node. 15394 15395 else 15396 return Loc; 15397 end if; 15398 15399 -- The freeze node appears at the "bottom" of the package when 15400 -- it is in the "last" declarative list and is either the last 15401 -- in the list or is followed by internal constructs only. In 15402 -- that case the more appropriate source location is that of 15403 -- the package end label. 15404 15405 if not Precedes_Source_Construct (FNode) then 15406 return Sloc (End_Label (Context)); 15407 end if; 15408 end if; 15409 15410 return Loc; 15411 end Freeze_Node_Location; 15412 15413 ------------------------------- 15414 -- Precedes_Source_Construct -- 15415 ------------------------------- 15416 15417 function Precedes_Source_Construct (N : Node_Id) return Boolean is 15418 Decl : Node_Id; 15419 15420 begin 15421 Decl := Next (N); 15422 while Present (Decl) loop 15423 if Comes_From_Source (Decl) then 15424 return True; 15425 15426 -- A generated body for a source expression function is treated 15427 -- as a source construct. 15428 15429 elsif Nkind (Decl) = N_Subprogram_Body 15430 and then Was_Expression_Function (Decl) 15431 and then Comes_From_Source (Original_Node (Decl)) 15432 then 15433 return True; 15434 end if; 15435 15436 Next (Decl); 15437 end loop; 15438 15439 return False; 15440 end Precedes_Source_Construct; 15441 15442 ---------------------------- 15443 -- Suggest_Elaborate_Body -- 15444 ---------------------------- 15445 15446 procedure Suggest_Elaborate_Body 15447 (N : Node_Id; 15448 Body_Decl : Node_Id; 15449 Error_Nod : Node_Id) 15450 is 15451 Unit_Id : constant Node_Id := Unit (Cunit (Main_Unit)); 15452 Region : Node_Id; 15453 15454 begin 15455 -- The suggestion applies only when the subprogram body resides in 15456 -- a compilation package body, and a pragma Elaborate_Body would 15457 -- allow for the node to appear in the early call region of the 15458 -- subprogram body. This implies that all code from the subprogram 15459 -- body up to the node is preelaborable. 15460 15461 if Nkind (Unit_Id) = N_Package_Body then 15462 15463 -- Find the start of the early call region again assuming that 15464 -- the package spec has pragma Elaborate_Body. Note that the 15465 -- internal data structures are intentionally not updated 15466 -- because this is a speculative search. 15467 15468 Region := 15469 Find_Early_Call_Region 15470 (Body_Decl => Body_Decl, 15471 Assume_Elab_Body => True, 15472 Skip_Memoization => True); 15473 15474 -- If the node appears within the early call region, assuming 15475 -- that the package spec carries pragma Elaborate_Body, then it 15476 -- is safe to suggest the pragma. 15477 15478 if Earlier_In_Extended_Unit (Region, N) then 15479 Error_Msg_Name_1 := Name_Elaborate_Body; 15480 Error_Msg_NE 15481 ("\consider adding pragma % in spec of unit &", 15482 Error_Nod, Defining_Entity (Unit_Id)); 15483 end if; 15484 end if; 15485 end Suggest_Elaborate_Body; 15486 15487 -- Local variables 15488 15489 FNode : constant Node_Id := Freeze_Node (Typ); 15490 Prims : constant Elist_Id := Direct_Primitive_Operations (Typ); 15491 15492 Prim_Elmt : Elmt_Id; 15493 15494 -- Start of processing for Process_SPARK_Derived_Type 15495 15496 begin 15497 -- A type should have its freeze node set by the time SPARK scenarios 15498 -- are being verified. 15499 15500 pragma Assert (Present (FNode)); 15501 15502 -- Verify that the freeze node of the derived type is within the 15503 -- early call region of each overriding primitive body 15504 -- (SPARK RM 7.7(8)). 15505 15506 if Present (Prims) then 15507 Prim_Elmt := First_Elmt (Prims); 15508 while Present (Prim_Elmt) loop 15509 Check_Overriding_Primitive 15510 (Prim => Node (Prim_Elmt), 15511 FNode => FNode); 15512 15513 Next_Elmt (Prim_Elmt); 15514 end loop; 15515 end if; 15516 15517 exception 15518 when Stop_Check => 15519 null; 15520 end Process_SPARK_Derived_Type; 15521 15522 --------------------------------- 15523 -- Process_SPARK_Instantiation -- 15524 --------------------------------- 15525 15526 procedure Process_SPARK_Instantiation 15527 (Inst : Node_Id; 15528 Inst_Rep : Scenario_Rep_Id; 15529 In_State : Processing_In_State) 15530 is 15531 Gen_Id : constant Entity_Id := Target (Inst_Rep); 15532 Gen_Rep : constant Target_Rep_Id := 15533 Target_Representation_Of (Gen_Id, In_State); 15534 Body_Decl : constant Node_Id := Body_Declaration (Gen_Rep); 15535 15536 begin 15537 -- The instantiation and the generic body are both in the main unit 15538 15539 if Present (Body_Decl) 15540 and then In_Extended_Main_Code_Unit (Body_Decl) 15541 15542 -- If the instantiation appears prior to the generic body, then the 15543 -- instantiation is illegal (SPARK RM 7.7(6)). 15544 15545 -- IMPORTANT: This check must always be performed even when 15546 -- -gnatd.v (enforce SPARK elaboration rules in SPARK code) is not 15547 -- specified because the rule prevents use-before-declaration of 15548 -- objects that may precede the generic body. 15549 15550 and then Earlier_In_Extended_Unit (Inst, Body_Decl) 15551 then 15552 Error_Msg_NE 15553 ("cannot instantiate & before body seen", Inst, Gen_Id); 15554 end if; 15555 end Process_SPARK_Instantiation; 15556 15557 ---------------------------- 15558 -- Process_SPARK_Scenario -- 15559 ---------------------------- 15560 15561 procedure Process_SPARK_Scenario 15562 (N : Node_Id; 15563 In_State : Processing_In_State) 15564 is 15565 Scen : constant Node_Id := Scenario (N); 15566 15567 begin 15568 -- Ensure that a suitable elaboration model is in effect for SPARK 15569 -- rule verification. 15570 15571 Check_SPARK_Model_In_Effect; 15572 15573 -- Add the current scenario to the stack of active scenarios 15574 15575 Push_Active_Scenario (Scen); 15576 15577 -- Derived type 15578 15579 if Is_Suitable_SPARK_Derived_Type (Scen) then 15580 Process_SPARK_Derived_Type 15581 (Typ_Decl => Scen, 15582 Typ_Rep => Scenario_Representation_Of (Scen, In_State), 15583 In_State => In_State); 15584 15585 -- Instantiation 15586 15587 elsif Is_Suitable_SPARK_Instantiation (Scen) then 15588 Process_SPARK_Instantiation 15589 (Inst => Scen, 15590 Inst_Rep => Scenario_Representation_Of (Scen, In_State), 15591 In_State => In_State); 15592 15593 -- Refined_State pragma 15594 15595 elsif Is_Suitable_SPARK_Refined_State_Pragma (Scen) then 15596 Process_SPARK_Refined_State_Pragma 15597 (Prag => Scen, 15598 Prag_Rep => Scenario_Representation_Of (Scen, In_State), 15599 In_State => In_State); 15600 end if; 15601 15602 -- Remove the current scenario from the stack of active scenarios 15603 -- once all ABE diagnostics and checks have been performed. 15604 15605 Pop_Active_Scenario (Scen); 15606 end Process_SPARK_Scenario; 15607 15608 ---------------------------------------- 15609 -- Process_SPARK_Refined_State_Pragma -- 15610 ---------------------------------------- 15611 15612 procedure Process_SPARK_Refined_State_Pragma 15613 (Prag : Node_Id; 15614 Prag_Rep : Scenario_Rep_Id; 15615 In_State : Processing_In_State) 15616 is 15617 pragma Unreferenced (Prag_Rep); 15618 15619 procedure Check_SPARK_Constituent (Constit_Id : Entity_Id); 15620 pragma Inline (Check_SPARK_Constituent); 15621 -- Ensure that a single constituent Constit_Id is elaborated prior to 15622 -- the main unit. 15623 15624 procedure Check_SPARK_Constituents (Constits : Elist_Id); 15625 pragma Inline (Check_SPARK_Constituents); 15626 -- Ensure that all constituents found in list Constits are elaborated 15627 -- prior to the main unit. 15628 15629 procedure Check_SPARK_Initialized_State (State : Node_Id); 15630 pragma Inline (Check_SPARK_Initialized_State); 15631 -- Ensure that the constituents of single abstract state State are 15632 -- elaborated prior to the main unit. 15633 15634 procedure Check_SPARK_Initialized_States (Pack_Id : Entity_Id); 15635 pragma Inline (Check_SPARK_Initialized_States); 15636 -- Ensure that the constituents of all abstract states which appear 15637 -- in the Initializes pragma of package Pack_Id are elaborated prior 15638 -- to the main unit. 15639 15640 ----------------------------- 15641 -- Check_SPARK_Constituent -- 15642 ----------------------------- 15643 15644 procedure Check_SPARK_Constituent (Constit_Id : Entity_Id) is 15645 SM_Prag : Node_Id; 15646 15647 begin 15648 -- Nothing to do for "null" constituents 15649 15650 if Nkind (Constit_Id) = N_Null then 15651 return; 15652 15653 -- Nothing to do for illegal constituents 15654 15655 elsif Error_Posted (Constit_Id) then 15656 return; 15657 end if; 15658 15659 SM_Prag := SPARK_Pragma (Constit_Id); 15660 15661 -- The check applies only when the constituent is subject to 15662 -- pragma SPARK_Mode On. 15663 15664 if Present (SM_Prag) 15665 and then Get_SPARK_Mode_From_Annotation (SM_Prag) = On 15666 then 15667 -- An external constituent of an abstract state which appears 15668 -- in the Initializes pragma of a package spec imposes an 15669 -- Elaborate requirement on the context of the main unit. 15670 -- Determine whether the context has a pragma strong enough to 15671 -- meet the requirement. 15672 15673 -- IMPORTANT: This check is performed only when -gnatd.v 15674 -- (enforce SPARK elaboration rules in SPARK code) is in effect 15675 -- because the static model can ensure the prior elaboration of 15676 -- the unit which contains a constituent by installing implicit 15677 -- Elaborate pragma. 15678 15679 if Debug_Flag_Dot_V then 15680 Meet_Elaboration_Requirement 15681 (N => Prag, 15682 Targ_Id => Constit_Id, 15683 Req_Nam => Name_Elaborate, 15684 In_State => In_State); 15685 15686 -- Otherwise ensure that the unit with the external constituent 15687 -- is elaborated prior to the main unit. 15688 15689 else 15690 Ensure_Prior_Elaboration 15691 (N => Prag, 15692 Unit_Id => Find_Top_Unit (Constit_Id), 15693 Prag_Nam => Name_Elaborate, 15694 In_State => In_State); 15695 end if; 15696 end if; 15697 end Check_SPARK_Constituent; 15698 15699 ------------------------------ 15700 -- Check_SPARK_Constituents -- 15701 ------------------------------ 15702 15703 procedure Check_SPARK_Constituents (Constits : Elist_Id) is 15704 Constit_Elmt : Elmt_Id; 15705 15706 begin 15707 if Present (Constits) then 15708 Constit_Elmt := First_Elmt (Constits); 15709 while Present (Constit_Elmt) loop 15710 Check_SPARK_Constituent (Node (Constit_Elmt)); 15711 Next_Elmt (Constit_Elmt); 15712 end loop; 15713 end if; 15714 end Check_SPARK_Constituents; 15715 15716 ----------------------------------- 15717 -- Check_SPARK_Initialized_State -- 15718 ----------------------------------- 15719 15720 procedure Check_SPARK_Initialized_State (State : Node_Id) is 15721 SM_Prag : Node_Id; 15722 State_Id : Entity_Id; 15723 15724 begin 15725 -- Nothing to do for "null" initialization items 15726 15727 if Nkind (State) = N_Null then 15728 return; 15729 15730 -- Nothing to do for illegal states 15731 15732 elsif Error_Posted (State) then 15733 return; 15734 end if; 15735 15736 State_Id := Entity_Of (State); 15737 15738 -- Sanitize the state 15739 15740 if No (State_Id) then 15741 return; 15742 15743 elsif Error_Posted (State_Id) then 15744 return; 15745 15746 elsif Ekind (State_Id) /= E_Abstract_State then 15747 return; 15748 end if; 15749 15750 -- The check is performed only when the abstract state is subject 15751 -- to SPARK_Mode On. 15752 15753 SM_Prag := SPARK_Pragma (State_Id); 15754 15755 if Present (SM_Prag) 15756 and then Get_SPARK_Mode_From_Annotation (SM_Prag) = On 15757 then 15758 Check_SPARK_Constituents (Refinement_Constituents (State_Id)); 15759 end if; 15760 end Check_SPARK_Initialized_State; 15761 15762 ------------------------------------ 15763 -- Check_SPARK_Initialized_States -- 15764 ------------------------------------ 15765 15766 procedure Check_SPARK_Initialized_States (Pack_Id : Entity_Id) is 15767 Init_Prag : constant Node_Id := 15768 Get_Pragma (Pack_Id, Pragma_Initializes); 15769 15770 Init : Node_Id; 15771 Inits : Node_Id; 15772 15773 begin 15774 if Present (Init_Prag) then 15775 Inits := Expression (Get_Argument (Init_Prag, Pack_Id)); 15776 15777 -- Avoid processing a "null" initialization list. The only 15778 -- other alternative is an aggregate. 15779 15780 if Nkind (Inits) = N_Aggregate then 15781 15782 -- The initialization items appear in list form: 15783 -- 15784 -- (state1, state2) 15785 15786 if Present (Expressions (Inits)) then 15787 Init := First (Expressions (Inits)); 15788 while Present (Init) loop 15789 Check_SPARK_Initialized_State (Init); 15790 Next (Init); 15791 end loop; 15792 end if; 15793 15794 -- The initialization items appear in associated form: 15795 -- 15796 -- (state1 => item1, 15797 -- state2 => (item2, item3)) 15798 15799 if Present (Component_Associations (Inits)) then 15800 Init := First (Component_Associations (Inits)); 15801 while Present (Init) loop 15802 Check_SPARK_Initialized_State (Init); 15803 Next (Init); 15804 end loop; 15805 end if; 15806 end if; 15807 end if; 15808 end Check_SPARK_Initialized_States; 15809 15810 -- Local variables 15811 15812 Pack_Body : constant Node_Id := Find_Related_Package_Or_Body (Prag); 15813 15814 -- Start of processing for Process_SPARK_Refined_State_Pragma 15815 15816 begin 15817 -- Pragma Refined_State must be associated with a package body 15818 15819 pragma Assert 15820 (Present (Pack_Body) and then Nkind (Pack_Body) = N_Package_Body); 15821 15822 -- Verify that each external contitunent of an abstract state 15823 -- mentioned in pragma Initializes is properly elaborated. 15824 15825 Check_SPARK_Initialized_States (Unique_Defining_Entity (Pack_Body)); 15826 end Process_SPARK_Refined_State_Pragma; 15827 end SPARK_Processor; 15828 15829 ------------------------------- 15830 -- Spec_And_Body_From_Entity -- 15831 ------------------------------- 15832 15833 procedure Spec_And_Body_From_Entity 15834 (Id : Node_Id; 15835 Spec_Decl : out Node_Id; 15836 Body_Decl : out Node_Id) 15837 is 15838 begin 15839 Spec_And_Body_From_Node 15840 (N => Unit_Declaration_Node (Id), 15841 Spec_Decl => Spec_Decl, 15842 Body_Decl => Body_Decl); 15843 end Spec_And_Body_From_Entity; 15844 15845 ----------------------------- 15846 -- Spec_And_Body_From_Node -- 15847 ----------------------------- 15848 15849 procedure Spec_And_Body_From_Node 15850 (N : Node_Id; 15851 Spec_Decl : out Node_Id; 15852 Body_Decl : out Node_Id) 15853 is 15854 Body_Id : Entity_Id; 15855 Spec_Id : Entity_Id; 15856 15857 begin 15858 -- Assume that the construct lacks spec and body 15859 15860 Body_Decl := Empty; 15861 Spec_Decl := Empty; 15862 15863 -- Bodies 15864 15865 if Nkind (N) in N_Package_Body 15866 | N_Protected_Body 15867 | N_Subprogram_Body 15868 | N_Task_Body 15869 then 15870 Spec_Id := Corresponding_Spec (N); 15871 15872 -- The body completes a previous declaration 15873 15874 if Present (Spec_Id) then 15875 Spec_Decl := Unit_Declaration_Node (Spec_Id); 15876 15877 -- Otherwise the body acts as the initial declaration, and is both a 15878 -- spec and body. There is no need to look for an optional body. 15879 15880 else 15881 Body_Decl := N; 15882 Spec_Decl := N; 15883 return; 15884 end if; 15885 15886 -- Declarations 15887 15888 elsif Nkind (N) in N_Entry_Declaration 15889 | N_Generic_Package_Declaration 15890 | N_Generic_Subprogram_Declaration 15891 | N_Package_Declaration 15892 | N_Protected_Type_Declaration 15893 | N_Subprogram_Declaration 15894 | N_Task_Type_Declaration 15895 then 15896 Spec_Decl := N; 15897 15898 -- Expression function 15899 15900 elsif Nkind (N) = N_Expression_Function then 15901 Spec_Id := Corresponding_Spec (N); 15902 pragma Assert (Present (Spec_Id)); 15903 15904 Spec_Decl := Unit_Declaration_Node (Spec_Id); 15905 15906 -- Instantiations 15907 15908 elsif Nkind (N) in N_Generic_Instantiation then 15909 Spec_Decl := Instance_Spec (N); 15910 pragma Assert (Present (Spec_Decl)); 15911 15912 -- Stubs 15913 15914 elsif Nkind (N) in N_Body_Stub then 15915 Spec_Id := Corresponding_Spec_Of_Stub (N); 15916 15917 -- The stub completes a previous declaration 15918 15919 if Present (Spec_Id) then 15920 Spec_Decl := Unit_Declaration_Node (Spec_Id); 15921 15922 -- Otherwise the stub acts as a spec 15923 15924 else 15925 Spec_Decl := N; 15926 end if; 15927 end if; 15928 15929 -- Obtain an optional or mandatory body 15930 15931 if Present (Spec_Decl) then 15932 Body_Id := Corresponding_Body (Spec_Decl); 15933 15934 if Present (Body_Id) then 15935 Body_Decl := Unit_Declaration_Node (Body_Id); 15936 end if; 15937 end if; 15938 end Spec_And_Body_From_Node; 15939 15940 ------------------------------- 15941 -- Static_Elaboration_Checks -- 15942 ------------------------------- 15943 15944 function Static_Elaboration_Checks return Boolean is 15945 begin 15946 return not Dynamic_Elaboration_Checks; 15947 end Static_Elaboration_Checks; 15948 15949 ----------------- 15950 -- Unit_Entity -- 15951 ----------------- 15952 15953 function Unit_Entity (Unit_Id : Entity_Id) return Entity_Id is 15954 function Is_Subunit (Id : Entity_Id) return Boolean; 15955 pragma Inline (Is_Subunit); 15956 -- Determine whether the entity of an initial declaration denotes a 15957 -- subunit. 15958 15959 ---------------- 15960 -- Is_Subunit -- 15961 ---------------- 15962 15963 function Is_Subunit (Id : Entity_Id) return Boolean is 15964 Decl : constant Node_Id := Unit_Declaration_Node (Id); 15965 15966 begin 15967 return 15968 Nkind (Decl) in N_Generic_Package_Declaration 15969 | N_Generic_Subprogram_Declaration 15970 | N_Package_Declaration 15971 | N_Protected_Type_Declaration 15972 | N_Subprogram_Declaration 15973 | N_Task_Type_Declaration 15974 and then Present (Corresponding_Body (Decl)) 15975 and then Nkind (Parent (Unit_Declaration_Node 15976 (Corresponding_Body (Decl)))) = N_Subunit; 15977 end Is_Subunit; 15978 15979 -- Local variables 15980 15981 Id : Entity_Id; 15982 15983 -- Start of processing for Unit_Entity 15984 15985 begin 15986 Id := Unique_Entity (Unit_Id); 15987 15988 -- Skip all subunits found in the scope chain which ends at the input 15989 -- unit. 15990 15991 while Is_Subunit (Id) loop 15992 Id := Scope (Id); 15993 end loop; 15994 15995 return Id; 15996 end Unit_Entity; 15997 15998 --------------------------------- 15999 -- Update_Elaboration_Scenario -- 16000 --------------------------------- 16001 16002 procedure Update_Elaboration_Scenario (New_N : Node_Id; Old_N : Node_Id) is 16003 begin 16004 -- Nothing to do when the elaboration phase of the compiler is not 16005 -- active. 16006 16007 if not Elaboration_Phase_Active then 16008 return; 16009 16010 -- Nothing to do when the old and new scenarios are one and the same 16011 16012 elsif Old_N = New_N then 16013 return; 16014 end if; 16015 16016 -- A scenario is being transformed by Atree.Rewrite. Update all relevant 16017 -- internal data structures to reflect this change. This ensures that a 16018 -- potential run-time conditional ABE check or a guaranteed ABE failure 16019 -- is inserted at the proper place in the tree. 16020 16021 if Is_Scenario (Old_N) then 16022 Replace_Scenario (Old_N, New_N); 16023 end if; 16024 end Update_Elaboration_Scenario; 16025 16026 --------------------------------------------------------------------------- 16027 -- -- 16028 -- 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 -- 16029 -- -- 16030 -- M E C H A N I S M -- 16031 -- -- 16032 --------------------------------------------------------------------------- 16033 16034 -- This section contains the implementation of the pre-18.x legacy ABE 16035 -- mechanism. The mechanism can be activated using switch -gnatH (legacy 16036 -- elaboration checking mode enabled). 16037 16038 ----------------------------- 16039 -- Description of Approach -- 16040 ----------------------------- 16041 16042 -- Every non-static call that is encountered by Sem_Res results in a call 16043 -- to Check_Elab_Call, with N being the call node, and Outer set to its 16044 -- default value of True. In addition X'Access is treated like a call 16045 -- for the access-to-procedure case, and in SPARK mode only we also 16046 -- check variable references. 16047 16048 -- The goal of Check_Elab_Call is to determine whether or not the reference 16049 -- in question can generate an access before elaboration error (raising 16050 -- Program_Error) either by directly calling a subprogram whose body 16051 -- has not yet been elaborated, or indirectly, by calling a subprogram 16052 -- whose body has been elaborated, but which contains a call to such a 16053 -- subprogram. 16054 16055 -- In addition, in SPARK mode, we are checking for a variable reference in 16056 -- another package, which requires an explicit Elaborate_All pragma. 16057 16058 -- The only references that we need to look at the outer level are 16059 -- references that occur in elaboration code. There are two cases. The 16060 -- reference can be at the outer level of elaboration code, or it can 16061 -- be within another unit, e.g. the elaboration code of a subprogram. 16062 16063 -- In the case of an elaboration call at the outer level, we must trace 16064 -- all calls to outer level routines either within the current unit or to 16065 -- other units that are with'ed. For calls within the current unit, we can 16066 -- determine if the body has been elaborated or not, and if it has not, 16067 -- then a warning is generated. 16068 16069 -- Note that there are two subcases. If the original call directly calls a 16070 -- subprogram whose body has not been elaborated, then we know that an ABE 16071 -- will take place, and we replace the call by a raise of Program_Error. 16072 -- If the call is indirect, then we don't know that the PE will be raised, 16073 -- since the call might be guarded by a conditional. In this case we set 16074 -- Do_Elab_Check on the call so that a dynamic check is generated, and 16075 -- output a warning. 16076 16077 -- For calls to a subprogram in a with'ed unit or a 'Access or variable 16078 -- reference (SPARK mode case), we require that a pragma Elaborate_All 16079 -- or pragma Elaborate be present, or that the referenced unit have a 16080 -- pragma Preelaborate, pragma Pure, or pragma Elaborate_Body. If none 16081 -- of these conditions is met, then a warning is generated that a pragma 16082 -- Elaborate_All may be needed (error in the SPARK case), or an implicit 16083 -- pragma is generated. 16084 16085 -- For the case of an elaboration call at some inner level, we are 16086 -- interested in tracing only calls to subprograms at the same level, i.e. 16087 -- those that can be called during elaboration. Any calls to outer level 16088 -- routines cannot cause ABE's as a result of the original call (there 16089 -- might be an outer level call to the subprogram from outside that causes 16090 -- the ABE, but that gets analyzed separately). 16091 16092 -- Note that we never trace calls to inner level subprograms, since these 16093 -- cannot result in ABE's unless there is an elaboration problem at a lower 16094 -- level, which will be separately detected. 16095 16096 -- Note on pragma Elaborate. The checking here assumes that a pragma 16097 -- Elaborate on a with'ed unit guarantees that subprograms within the unit 16098 -- can be called without causing an ABE. This is not in fact the case since 16099 -- pragma Elaborate does not guarantee the transitive coverage guaranteed 16100 -- by Elaborate_All. However, we decide to trust the user in this case. 16101 16102 -------------------------------------- 16103 -- Instantiation Elaboration Errors -- 16104 -------------------------------------- 16105 16106 -- A special case arises when an instantiation appears in a context that is 16107 -- known to be before the body is elaborated, e.g. 16108 16109 -- generic package x is ... 16110 -- ... 16111 -- package xx is new x; 16112 -- ... 16113 -- package body x is ... 16114 16115 -- In this situation it is certain that an elaboration error will occur, 16116 -- and an unconditional raise Program_Error statement is inserted before 16117 -- the instantiation, and a warning generated. 16118 16119 -- The problem is that in this case we have no place to put the body of 16120 -- the instantiation. We can't put it in the normal place, because it is 16121 -- too early, and will cause errors to occur as a result of referencing 16122 -- entities before they are declared. 16123 16124 -- Our approach in this case is simply to avoid creating the body of the 16125 -- instantiation in such a case. The instantiation spec is modified to 16126 -- include dummy bodies for all subprograms, so that the resulting code 16127 -- does not contain subprogram specs with no corresponding bodies. 16128 16129 -- The following table records the recursive call chain for output in the 16130 -- Output routine. Each entry records the call node and the entity of the 16131 -- called routine. The number of entries in the table (i.e. the value of 16132 -- Elab_Call.Last) indicates the current depth of recursion and is used to 16133 -- identify the outer level. 16134 16135 type Elab_Call_Element is record 16136 Cloc : Source_Ptr; 16137 Ent : Entity_Id; 16138 end record; 16139 16140 package Elab_Call is new Table.Table 16141 (Table_Component_Type => Elab_Call_Element, 16142 Table_Index_Type => Int, 16143 Table_Low_Bound => 1, 16144 Table_Initial => 50, 16145 Table_Increment => 100, 16146 Table_Name => "Elab_Call"); 16147 16148 -- The following table records all calls that have been processed starting 16149 -- from an outer level call. The table prevents both infinite recursion and 16150 -- useless reanalysis of calls within the same context. The use of context 16151 -- is important because it allows for proper checks in more complex code: 16152 16153 -- if ... then 16154 -- Call; -- requires a check 16155 -- Call; -- does not need a check thanks to the table 16156 -- elsif ... then 16157 -- Call; -- requires a check, different context 16158 -- end if; 16159 16160 -- Call; -- requires a check, different context 16161 16162 type Visited_Element is record 16163 Subp_Id : Entity_Id; 16164 -- The entity of the subprogram being called 16165 16166 Context : Node_Id; 16167 -- The context where the call to the subprogram occurs 16168 end record; 16169 16170 package Elab_Visited is new Table.Table 16171 (Table_Component_Type => Visited_Element, 16172 Table_Index_Type => Int, 16173 Table_Low_Bound => 1, 16174 Table_Initial => 200, 16175 Table_Increment => 100, 16176 Table_Name => "Elab_Visited"); 16177 16178 -- The following table records delayed calls which must be examined after 16179 -- all generic bodies have been instantiated. 16180 16181 type Delay_Element is record 16182 N : Node_Id; 16183 -- The parameter N from the call to Check_Internal_Call. Note that this 16184 -- node may get rewritten over the delay period by expansion in the call 16185 -- case (but not in the instantiation case). 16186 16187 E : Entity_Id; 16188 -- The parameter E from the call to Check_Internal_Call 16189 16190 Orig_Ent : Entity_Id; 16191 -- The parameter Orig_Ent from the call to Check_Internal_Call 16192 16193 Curscop : Entity_Id; 16194 -- The current scope of the call. This is restored when we complete the 16195 -- delayed call, so that we do this in the right scope. 16196 16197 Outer_Scope : Entity_Id; 16198 -- Save scope of outer level call 16199 16200 From_Elab_Code : Boolean; 16201 -- Save indication of whether this call is from elaboration code 16202 16203 In_Task_Activation : Boolean; 16204 -- Save indication of whether this call is from a task body. Tasks are 16205 -- activated at the "begin", which is after all local procedure bodies, 16206 -- so calls to those procedures can't fail, even if they occur after the 16207 -- task body. 16208 16209 From_SPARK_Code : Boolean; 16210 -- Save indication of whether this call is under SPARK_Mode => On 16211 end record; 16212 16213 package Delay_Check is new Table.Table 16214 (Table_Component_Type => Delay_Element, 16215 Table_Index_Type => Int, 16216 Table_Low_Bound => 1, 16217 Table_Initial => 1000, 16218 Table_Increment => 100, 16219 Table_Name => "Delay_Check"); 16220 16221 C_Scope : Entity_Id; 16222 -- Top-level scope of current scope. Compute this only once at the outer 16223 -- level, i.e. for a call to Check_Elab_Call from outside this unit. 16224 16225 Outer_Level_Sloc : Source_Ptr; 16226 -- Save Sloc value for outer level call node for comparisons of source 16227 -- locations. A body is too late if it appears after the *outer* level 16228 -- call, not the particular call that is being analyzed. 16229 16230 From_Elab_Code : Boolean; 16231 -- This flag shows whether the outer level call currently being examined 16232 -- is or is not in elaboration code. We are only interested in calls to 16233 -- routines in other units if this flag is True. 16234 16235 In_Task_Activation : Boolean := False; 16236 -- This flag indicates whether we are performing elaboration checks on task 16237 -- bodies, at the point of activation. If true, we do not raise 16238 -- Program_Error for calls to local procedures, because all local bodies 16239 -- are known to be elaborated. However, we still need to trace such calls, 16240 -- because a local procedure could call a procedure in another package, 16241 -- so we might need an implicit Elaborate_All. 16242 16243 Delaying_Elab_Checks : Boolean := True; 16244 -- This is set True till the compilation is complete, including the 16245 -- insertion of all instance bodies. Then when Check_Elab_Calls is called, 16246 -- the delay table is used to make the delayed calls and this flag is reset 16247 -- to False, so that the calls are processed. 16248 16249 ----------------------- 16250 -- Local Subprograms -- 16251 ----------------------- 16252 16253 -- Note: Outer_Scope in all following specs represents the scope of 16254 -- interest of the outer level call. If it is set to Standard_Standard, 16255 -- then it means the outer level call was at elaboration level, and that 16256 -- thus all calls are of interest. If it was set to some other scope, 16257 -- then the original call was an inner call, and we are not interested 16258 -- in calls that go outside this scope. 16259 16260 procedure Activate_Elaborate_All_Desirable (N : Node_Id; U : Entity_Id); 16261 -- Analysis of construct N shows that we should set Elaborate_All_Desirable 16262 -- for the WITH clause for unit U (which will always be present). A special 16263 -- case is when N is a function or procedure instantiation, in which case 16264 -- it is sufficient to set Elaborate_Desirable, since in this case there is 16265 -- no possibility of transitive elaboration issues. 16266 16267 procedure Check_A_Call 16268 (N : Node_Id; 16269 E : Entity_Id; 16270 Outer_Scope : Entity_Id; 16271 Inter_Unit_Only : Boolean; 16272 Generate_Warnings : Boolean := True; 16273 In_Init_Proc : Boolean := False); 16274 -- This is the internal recursive routine that is called to check for 16275 -- possible elaboration error. The argument N is a subprogram call or 16276 -- generic instantiation, or 'Access attribute reference to be checked, and 16277 -- E is the entity of the called subprogram, or instantiated generic unit, 16278 -- or subprogram referenced by 'Access. 16279 -- 16280 -- In SPARK mode, N can also be a variable reference, since in SPARK this 16281 -- also triggers a requirement for Elaborate_All, and in this case E is the 16282 -- entity being referenced. 16283 -- 16284 -- Outer_Scope is the outer level scope for the original reference. 16285 -- Inter_Unit_Only is set if the call is only to be checked in the 16286 -- case where it is to another unit (and skipped if within a unit). 16287 -- Generate_Warnings is set to False to suppress warning messages about 16288 -- missing pragma Elaborate_All's. These messages are not wanted for 16289 -- inner calls in the dynamic model. Note that an instance of the Access 16290 -- attribute applied to a subprogram also generates a call to this 16291 -- procedure (since the referenced subprogram may be called later 16292 -- indirectly). Flag In_Init_Proc should be set whenever the current 16293 -- context is a type init proc. 16294 -- 16295 -- Note: this might better be called Check_A_Reference to recognize the 16296 -- variable case for SPARK, but we prefer to retain the historical name 16297 -- since in practice this is mostly about checking calls for the possible 16298 -- occurrence of an access-before-elaboration exception. 16299 16300 procedure Check_Bad_Instantiation (N : Node_Id); 16301 -- N is a node for an instantiation (if called with any other node kind, 16302 -- Check_Bad_Instantiation ignores the call). This subprogram checks for 16303 -- the special case of a generic instantiation of a generic spec in the 16304 -- same declarative part as the instantiation where a body is present and 16305 -- has not yet been seen. This is an obvious error, but needs to be checked 16306 -- specially at the time of the instantiation, since it is a case where we 16307 -- cannot insert the body anywhere. If this case is detected, warnings are 16308 -- generated, and a raise of Program_Error is inserted. In addition any 16309 -- subprograms in the generic spec are stubbed, and the Bad_Instantiation 16310 -- flag is set on the instantiation node. The caller in Sem_Ch12 uses this 16311 -- flag as an indication that no attempt should be made to insert an 16312 -- instance body. 16313 16314 procedure Check_Internal_Call 16315 (N : Node_Id; 16316 E : Entity_Id; 16317 Outer_Scope : Entity_Id; 16318 Orig_Ent : Entity_Id); 16319 -- N is a function call or procedure statement call node and E is the 16320 -- entity of the called function, which is within the current compilation 16321 -- unit (where subunits count as part of the parent). This call checks if 16322 -- this call, or any call within any accessed body could cause an ABE, and 16323 -- if so, outputs a warning. Orig_Ent differs from E only in the case of 16324 -- renamings, and points to the original name of the entity. This is used 16325 -- for error messages. Outer_Scope is the outer level scope for the 16326 -- original call. 16327 16328 procedure Check_Internal_Call_Continue 16329 (N : Node_Id; 16330 E : Entity_Id; 16331 Outer_Scope : Entity_Id; 16332 Orig_Ent : Entity_Id); 16333 -- The processing for Check_Internal_Call is divided up into two phases, 16334 -- and this represents the second phase. The second phase is delayed if 16335 -- Delaying_Elab_Checks is set to True. In this delayed case, the first 16336 -- phase makes an entry in the Delay_Check table, which is processed when 16337 -- Check_Elab_Calls is called. N, E and Orig_Ent are as for the call to 16338 -- Check_Internal_Call. Outer_Scope is the outer level scope for the 16339 -- original call. 16340 16341 function Get_Referenced_Ent (N : Node_Id) return Entity_Id; 16342 -- N is either a function or procedure call or an access attribute that 16343 -- references a subprogram. This call retrieves the relevant entity. If 16344 -- this is a call to a protected subprogram, the entity is a selected 16345 -- component. The callable entity may be absent, in which case Empty is 16346 -- returned. This happens with non-analyzed calls in nested generics. 16347 -- 16348 -- If SPARK_Mode is On, then N can also be a reference to an E_Variable 16349 -- entity, in which case, the value returned is simply this entity. 16350 16351 function Has_Generic_Body (N : Node_Id) return Boolean; 16352 -- N is a generic package instantiation node, and this routine determines 16353 -- if this package spec does in fact have a generic body. If so, then 16354 -- True is returned, otherwise False. Note that this is not at all the 16355 -- same as checking if the unit requires a body, since it deals with 16356 -- the case of optional bodies accurately (i.e. if a body is optional, 16357 -- then it looks to see if a body is actually present). Note: this 16358 -- function can only do a fully correct job if in generating code mode 16359 -- where all bodies have to be present. If we are operating in semantics 16360 -- check only mode, then in some cases of optional bodies, a result of 16361 -- False may incorrectly be given. In practice this simply means that 16362 -- some cases of warnings for incorrect order of elaboration will only 16363 -- be given when generating code, which is not a big problem (and is 16364 -- inevitable, given the optional body semantics of Ada). 16365 16366 procedure Insert_Elab_Check (N : Node_Id; C : Node_Id := Empty); 16367 -- Given code for an elaboration check (or unconditional raise if the check 16368 -- is not needed), inserts the code in the appropriate place. N is the call 16369 -- or instantiation node for which the check code is required. C is the 16370 -- test whose failure triggers the raise. 16371 16372 function Is_Call_Of_Generic_Formal (N : Node_Id) return Boolean; 16373 -- Returns True if node N is a call to a generic formal subprogram 16374 16375 function Is_Finalization_Procedure (Id : Entity_Id) return Boolean; 16376 -- Determine whether entity Id denotes a [Deep_]Finalize procedure 16377 16378 procedure Output_Calls 16379 (N : Node_Id; 16380 Check_Elab_Flag : Boolean); 16381 -- Outputs chain of calls stored in the Elab_Call table. The caller has 16382 -- already generated the main warning message, so the warnings generated 16383 -- are all continuation messages. The argument is the call node at which 16384 -- the messages are to be placed. When Check_Elab_Flag is set, calls are 16385 -- enumerated only when flag Elab_Warning is set for the dynamic case or 16386 -- when flag Elab_Info_Messages is set for the static case. 16387 16388 function Same_Elaboration_Scope (Scop1, Scop2 : Entity_Id) return Boolean; 16389 -- Given two scopes, determine whether they are the same scope from an 16390 -- elaboration point of view, i.e. packages and blocks are ignored. 16391 16392 procedure Set_C_Scope; 16393 -- On entry C_Scope is set to some scope. On return, C_Scope is reset 16394 -- to be the enclosing compilation unit of this scope. 16395 16396 procedure Set_Elaboration_Constraint 16397 (Call : Node_Id; 16398 Subp : Entity_Id; 16399 Scop : Entity_Id); 16400 -- The current unit U may depend semantically on some unit P that is not 16401 -- in the current context. If there is an elaboration call that reaches P, 16402 -- we need to indicate that P requires an Elaborate_All, but this is not 16403 -- effective in U's ali file, if there is no with_clause for P. In this 16404 -- case we add the Elaborate_All on the unit Q that directly or indirectly 16405 -- makes P available. This can happen in two cases: 16406 -- 16407 -- a) Q declares a subtype of a type declared in P, and the call is an 16408 -- initialization call for an object of that subtype. 16409 -- 16410 -- b) Q declares an object of some tagged type whose root type is 16411 -- declared in P, and the initialization call uses object notation on 16412 -- that object to reach a primitive operation or a classwide operation 16413 -- declared in P. 16414 -- 16415 -- If P appears in the context of U, the current processing is correct. 16416 -- Otherwise we must identify these two cases to retrieve Q and place the 16417 -- Elaborate_All_Desirable on it. 16418 16419 function Spec_Entity (E : Entity_Id) return Entity_Id; 16420 -- Given a compilation unit entity, if it is a spec entity, it is returned 16421 -- unchanged. If it is a body entity, then the spec for the corresponding 16422 -- spec is returned 16423 16424 function Within (E1, E2 : Entity_Id) return Boolean; 16425 -- Given two scopes E1 and E2, returns True if E1 is equal to E2, or is one 16426 -- of its contained scopes, False otherwise. 16427 16428 function Within_Elaborate_All 16429 (Unit : Unit_Number_Type; 16430 E : Entity_Id) return Boolean; 16431 -- Return True if we are within the scope of an Elaborate_All for E, or if 16432 -- we are within the scope of an Elaborate_All for some other unit U, and U 16433 -- with's E. This prevents spurious warnings when the called entity is 16434 -- renamed within U, or in case of generic instances. 16435 16436 -------------------------------------- 16437 -- Activate_Elaborate_All_Desirable -- 16438 -------------------------------------- 16439 16440 procedure Activate_Elaborate_All_Desirable (N : Node_Id; U : Entity_Id) is 16441 UN : constant Unit_Number_Type := Get_Code_Unit (N); 16442 CU : constant Node_Id := Cunit (UN); 16443 UE : constant Entity_Id := Cunit_Entity (UN); 16444 Unm : constant Unit_Name_Type := Unit_Name (UN); 16445 CI : constant List_Id := Context_Items (CU); 16446 Itm : Node_Id; 16447 Ent : Entity_Id; 16448 16449 procedure Add_To_Context_And_Mark (Itm : Node_Id); 16450 -- This procedure is called when the elaborate indication must be 16451 -- applied to a unit not in the context of the referencing unit. The 16452 -- unit gets added to the context as an implicit with. 16453 16454 function In_Withs_Of (UEs : Entity_Id) return Boolean; 16455 -- UEs is the spec entity of a unit. If the unit to be marked is 16456 -- in the context item list of this unit spec, then the call returns 16457 -- True and Itm is left set to point to the relevant N_With_Clause node. 16458 16459 procedure Set_Elab_Flag (Itm : Node_Id); 16460 -- Sets Elaborate_[All_]Desirable as appropriate on Itm 16461 16462 ----------------------------- 16463 -- Add_To_Context_And_Mark -- 16464 ----------------------------- 16465 16466 procedure Add_To_Context_And_Mark (Itm : Node_Id) is 16467 CW : constant Node_Id := 16468 Make_With_Clause (Sloc (Itm), 16469 Name => Name (Itm)); 16470 16471 begin 16472 Set_Library_Unit (CW, Library_Unit (Itm)); 16473 Set_Implicit_With (CW); 16474 16475 -- Set elaborate all desirable on copy and then append the copy to 16476 -- the list of body with's and we are done. 16477 16478 Set_Elab_Flag (CW); 16479 Append_To (CI, CW); 16480 end Add_To_Context_And_Mark; 16481 16482 ----------------- 16483 -- In_Withs_Of -- 16484 ----------------- 16485 16486 function In_Withs_Of (UEs : Entity_Id) return Boolean is 16487 UNs : constant Unit_Number_Type := Get_Source_Unit (UEs); 16488 CUs : constant Node_Id := Cunit (UNs); 16489 CIs : constant List_Id := Context_Items (CUs); 16490 16491 begin 16492 Itm := First (CIs); 16493 while Present (Itm) loop 16494 if Nkind (Itm) = N_With_Clause then 16495 Ent := 16496 Cunit_Entity (Get_Cunit_Unit_Number (Library_Unit (Itm))); 16497 16498 if U = Ent then 16499 return True; 16500 end if; 16501 end if; 16502 16503 Next (Itm); 16504 end loop; 16505 16506 return False; 16507 end In_Withs_Of; 16508 16509 ------------------- 16510 -- Set_Elab_Flag -- 16511 ------------------- 16512 16513 procedure Set_Elab_Flag (Itm : Node_Id) is 16514 begin 16515 if Nkind (N) in N_Subprogram_Instantiation then 16516 Set_Elaborate_Desirable (Itm); 16517 else 16518 Set_Elaborate_All_Desirable (Itm); 16519 end if; 16520 end Set_Elab_Flag; 16521 16522 -- Start of processing for Activate_Elaborate_All_Desirable 16523 16524 begin 16525 -- Do not set binder indication if expansion is disabled, as when 16526 -- compiling a generic unit. 16527 16528 if not Expander_Active then 16529 return; 16530 end if; 16531 16532 -- If an instance of a generic package contains a controlled object (so 16533 -- we're calling Initialize at elaboration time), and the instance is in 16534 -- a package body P that says "with P;", then we need to return without 16535 -- adding "pragma Elaborate_All (P);" to P. 16536 16537 if U = Main_Unit_Entity then 16538 return; 16539 end if; 16540 16541 Itm := First (CI); 16542 while Present (Itm) loop 16543 if Nkind (Itm) = N_With_Clause then 16544 Ent := Cunit_Entity (Get_Cunit_Unit_Number (Library_Unit (Itm))); 16545 16546 -- If we find it, then mark elaborate all desirable and return 16547 16548 if U = Ent then 16549 Set_Elab_Flag (Itm); 16550 return; 16551 end if; 16552 end if; 16553 16554 Next (Itm); 16555 end loop; 16556 16557 -- If we fall through then the with clause is not present in the 16558 -- current unit. One legitimate possibility is that the with clause 16559 -- is present in the spec when we are a body. 16560 16561 if Is_Body_Name (Unm) 16562 and then In_Withs_Of (Spec_Entity (UE)) 16563 then 16564 Add_To_Context_And_Mark (Itm); 16565 return; 16566 end if; 16567 16568 -- Similarly, we may be in the spec or body of a child unit, where 16569 -- the unit in question is with'ed by some ancestor of the child unit. 16570 16571 if Is_Child_Name (Unm) then 16572 declare 16573 Pkg : Entity_Id; 16574 16575 begin 16576 Pkg := UE; 16577 loop 16578 Pkg := Scope (Pkg); 16579 exit when Pkg = Standard_Standard; 16580 16581 if In_Withs_Of (Pkg) then 16582 Add_To_Context_And_Mark (Itm); 16583 return; 16584 end if; 16585 end loop; 16586 end; 16587 end if; 16588 16589 -- Here if we do not find with clause on spec or body. We just ignore 16590 -- this case; it means that the elaboration involves some other unit 16591 -- than the unit being compiled, and will be caught elsewhere. 16592 end Activate_Elaborate_All_Desirable; 16593 16594 ------------------ 16595 -- Check_A_Call -- 16596 ------------------ 16597 16598 procedure Check_A_Call 16599 (N : Node_Id; 16600 E : Entity_Id; 16601 Outer_Scope : Entity_Id; 16602 Inter_Unit_Only : Boolean; 16603 Generate_Warnings : Boolean := True; 16604 In_Init_Proc : Boolean := False) 16605 is 16606 Access_Case : constant Boolean := Nkind (N) = N_Attribute_Reference; 16607 -- Indicates if we have Access attribute case 16608 16609 function Call_To_Instance_From_Outside (Id : Entity_Id) return Boolean; 16610 -- True if we're calling an instance of a generic subprogram, or a 16611 -- subprogram in an instance of a generic package, and the call is 16612 -- outside that instance. 16613 16614 procedure Elab_Warning 16615 (Msg_D : String; 16616 Msg_S : String; 16617 Ent : Node_Or_Entity_Id); 16618 -- Generate a call to Error_Msg_NE with parameters Msg_D or Msg_S (for 16619 -- dynamic or static elaboration model), N and Ent. Msg_D is a real 16620 -- warning (output if Msg_D is non-null and Elab_Warnings is set), 16621 -- Msg_S is an info message (output if Elab_Info_Messages is set). 16622 16623 function Find_W_Scope return Entity_Id; 16624 -- Find top-level scope for called entity (not following renamings 16625 -- or derivations). This is where the Elaborate_All will go if it is 16626 -- needed. We start with the called entity, except in the case of an 16627 -- initialization procedure outside the current package, where the init 16628 -- proc is in the root package, and we start from the entity of the name 16629 -- in the call. 16630 16631 ----------------------------------- 16632 -- Call_To_Instance_From_Outside -- 16633 ----------------------------------- 16634 16635 function Call_To_Instance_From_Outside (Id : Entity_Id) return Boolean is 16636 Scop : Entity_Id := Id; 16637 16638 begin 16639 loop 16640 if Scop = Standard_Standard then 16641 return False; 16642 end if; 16643 16644 if Is_Generic_Instance (Scop) then 16645 return not In_Open_Scopes (Scop); 16646 end if; 16647 16648 Scop := Scope (Scop); 16649 end loop; 16650 end Call_To_Instance_From_Outside; 16651 16652 ------------------ 16653 -- Elab_Warning -- 16654 ------------------ 16655 16656 procedure Elab_Warning 16657 (Msg_D : String; 16658 Msg_S : String; 16659 Ent : Node_Or_Entity_Id) 16660 is 16661 begin 16662 -- Dynamic elaboration checks, real warning 16663 16664 if Dynamic_Elaboration_Checks then 16665 if not Access_Case then 16666 if Msg_D /= "" and then Elab_Warnings then 16667 Error_Msg_NE (Msg_D, N, Ent); 16668 end if; 16669 16670 -- In the access case emit first warning message as well, 16671 -- otherwise list of calls will appear as errors. 16672 16673 elsif Elab_Warnings then 16674 Error_Msg_NE (Msg_S, N, Ent); 16675 end if; 16676 16677 -- Static elaboration checks, info message 16678 16679 else 16680 if Elab_Info_Messages then 16681 Error_Msg_NE (Msg_S, N, Ent); 16682 end if; 16683 end if; 16684 end Elab_Warning; 16685 16686 ------------------ 16687 -- Find_W_Scope -- 16688 ------------------ 16689 16690 function Find_W_Scope return Entity_Id is 16691 Refed_Ent : constant Entity_Id := Get_Referenced_Ent (N); 16692 W_Scope : Entity_Id; 16693 16694 begin 16695 if Is_Init_Proc (Refed_Ent) 16696 and then not In_Same_Extended_Unit (N, Refed_Ent) 16697 then 16698 W_Scope := Scope (Refed_Ent); 16699 else 16700 W_Scope := E; 16701 end if; 16702 16703 -- Now loop through scopes to get to the enclosing compilation unit 16704 16705 while not Is_Compilation_Unit (W_Scope) loop 16706 W_Scope := Scope (W_Scope); 16707 end loop; 16708 16709 return W_Scope; 16710 end Find_W_Scope; 16711 16712 -- Local variables 16713 16714 Inst_Case : constant Boolean := Nkind (N) in N_Generic_Instantiation; 16715 -- Indicates if we have instantiation case 16716 16717 Loc : constant Source_Ptr := Sloc (N); 16718 16719 Variable_Case : constant Boolean := 16720 Nkind (N) in N_Has_Entity 16721 and then Present (Entity (N)) 16722 and then Ekind (Entity (N)) = E_Variable; 16723 -- Indicates if we have variable reference case 16724 16725 W_Scope : constant Entity_Id := Find_W_Scope; 16726 -- Top-level scope of directly called entity for subprogram. This 16727 -- differs from E_Scope in the case where renamings or derivations 16728 -- are involved, since it does not follow these links. W_Scope is 16729 -- generally in a visible unit, and it is this scope that may require 16730 -- an Elaborate_All. However, there are some cases (initialization 16731 -- calls and calls involving object notation) where W_Scope might not 16732 -- be in the context of the current unit, and there is an intermediate 16733 -- package that is, in which case the Elaborate_All has to be placed 16734 -- on this intermediate package. These special cases are handled in 16735 -- Set_Elaboration_Constraint. 16736 16737 Ent : Entity_Id; 16738 Callee_Unit_Internal : Boolean; 16739 Caller_Unit_Internal : Boolean; 16740 Decl : Node_Id; 16741 Inst_Callee : Source_Ptr; 16742 Inst_Caller : Source_Ptr; 16743 Unit_Callee : Unit_Number_Type; 16744 Unit_Caller : Unit_Number_Type; 16745 16746 Body_Acts_As_Spec : Boolean; 16747 -- Set to true if call is to body acting as spec (no separate spec) 16748 16749 Cunit_SC : Boolean := False; 16750 -- Set to suppress dynamic elaboration checks where one of the 16751 -- enclosing scopes has Elaboration_Checks_Suppressed set, or else 16752 -- if a pragma Elaborate[_All] applies to that scope, in which case 16753 -- warnings on the scope are also suppressed. For the internal case, 16754 -- we ignore this flag. 16755 16756 E_Scope : Entity_Id; 16757 -- Top-level scope of entity for called subprogram. This value includes 16758 -- following renamings and derivations, so this scope can be in a 16759 -- non-visible unit. This is the scope that is to be investigated to 16760 -- see whether an elaboration check is required. 16761 16762 Is_DIC : Boolean; 16763 -- Flag set when the subprogram being invoked is the procedure generated 16764 -- for pragma Default_Initial_Condition. 16765 16766 SPARK_Elab_Errors : Boolean; 16767 -- Flag set when an entity is called or a variable is read during SPARK 16768 -- dynamic elaboration. 16769 16770 -- Start of processing for Check_A_Call 16771 16772 begin 16773 -- If the call is known to be within a local Suppress Elaboration 16774 -- pragma, nothing to check. This can happen in task bodies. But 16775 -- we ignore this for a call to a generic formal. 16776 16777 if Nkind (N) in N_Subprogram_Call 16778 and then No_Elaboration_Check (N) 16779 and then not Is_Call_Of_Generic_Formal (N) 16780 then 16781 return; 16782 16783 -- If this is a rewrite of a Valid_Scalars attribute, then nothing to 16784 -- check, we don't mind in this case if the call occurs before the body 16785 -- since this is all generated code. 16786 16787 elsif Nkind (Original_Node (N)) = N_Attribute_Reference 16788 and then Attribute_Name (Original_Node (N)) = Name_Valid_Scalars 16789 then 16790 return; 16791 16792 -- Intrinsics such as instances of Unchecked_Deallocation do not have 16793 -- any body, so elaboration checking is not needed, and would be wrong. 16794 16795 elsif Is_Intrinsic_Subprogram (E) then 16796 return; 16797 16798 -- Do not consider references to internal variables for SPARK semantics 16799 16800 elsif Variable_Case and then not Comes_From_Source (E) then 16801 return; 16802 end if; 16803 16804 -- Proceed with check 16805 16806 Ent := E; 16807 16808 -- For a variable reference, just set Body_Acts_As_Spec to False 16809 16810 if Variable_Case then 16811 Body_Acts_As_Spec := False; 16812 16813 -- Additional checks for all other cases 16814 16815 else 16816 -- Go to parent for derived subprogram, or to original subprogram in 16817 -- the case of a renaming (Alias covers both these cases). 16818 16819 loop 16820 if (Suppress_Elaboration_Warnings (Ent) 16821 or else Elaboration_Checks_Suppressed (Ent)) 16822 and then (Inst_Case or else No (Alias (Ent))) 16823 then 16824 return; 16825 end if; 16826 16827 -- Nothing to do for imported entities 16828 16829 if Is_Imported (Ent) then 16830 return; 16831 end if; 16832 16833 exit when Inst_Case or else No (Alias (Ent)); 16834 Ent := Alias (Ent); 16835 end loop; 16836 16837 Decl := Unit_Declaration_Node (Ent); 16838 16839 if Nkind (Decl) = N_Subprogram_Body then 16840 Body_Acts_As_Spec := True; 16841 16842 elsif Nkind (Decl) in 16843 N_Subprogram_Declaration | N_Subprogram_Body_Stub 16844 or else Inst_Case 16845 then 16846 Body_Acts_As_Spec := False; 16847 16848 -- If we have none of an instantiation, subprogram body or subprogram 16849 -- declaration, or in the SPARK case, a variable reference, then 16850 -- it is not a case that we want to check. (One case is a call to a 16851 -- generic formal subprogram, where we do not want the check in the 16852 -- template). 16853 16854 else 16855 return; 16856 end if; 16857 end if; 16858 16859 E_Scope := Ent; 16860 loop 16861 if Elaboration_Checks_Suppressed (E_Scope) 16862 or else Suppress_Elaboration_Warnings (E_Scope) 16863 then 16864 Cunit_SC := True; 16865 end if; 16866 16867 -- Exit when we get to compilation unit, not counting subunits 16868 16869 exit when Is_Compilation_Unit (E_Scope) 16870 and then (Is_Child_Unit (E_Scope) 16871 or else Scope (E_Scope) = Standard_Standard); 16872 16873 pragma Assert (E_Scope /= Standard_Standard); 16874 16875 -- Move up a scope looking for compilation unit 16876 16877 E_Scope := Scope (E_Scope); 16878 end loop; 16879 16880 -- No checks needed for pure or preelaborated compilation units 16881 16882 if Is_Pure (E_Scope) or else Is_Preelaborated (E_Scope) then 16883 return; 16884 end if; 16885 16886 -- If the generic entity is within a deeper instance than we are, then 16887 -- either the instantiation to which we refer itself caused an ABE, in 16888 -- which case that will be handled separately, or else we know that the 16889 -- body we need appears as needed at the point of the instantiation. 16890 -- However, this assumption is only valid if we are in static mode. 16891 16892 if not Dynamic_Elaboration_Checks 16893 and then 16894 Instantiation_Depth (Sloc (Ent)) > Instantiation_Depth (Sloc (N)) 16895 then 16896 return; 16897 end if; 16898 16899 -- Do not give a warning for a package with no body 16900 16901 if Ekind (Ent) = E_Generic_Package and then not Has_Generic_Body (N) then 16902 return; 16903 end if; 16904 16905 -- Case of entity is in same unit as call or instantiation. In the 16906 -- instantiation case, W_Scope may be different from E_Scope; we want 16907 -- the unit in which the instantiation occurs, since we're analyzing 16908 -- based on the expansion. 16909 16910 if W_Scope = C_Scope then 16911 if not Inter_Unit_Only then 16912 Check_Internal_Call (N, Ent, Outer_Scope, E); 16913 end if; 16914 16915 return; 16916 end if; 16917 16918 -- Case of entity is not in current unit (i.e. with'ed unit case) 16919 16920 -- We are only interested in such calls if the outer call was from 16921 -- elaboration code, or if we are in Dynamic_Elaboration_Checks mode. 16922 16923 if not From_Elab_Code and then not Dynamic_Elaboration_Checks then 16924 return; 16925 end if; 16926 16927 -- Nothing to do if some scope said that no checks were required 16928 16929 if Cunit_SC then 16930 return; 16931 end if; 16932 16933 -- Nothing to do for a generic instance, because a call to an instance 16934 -- cannot fail the elaboration check, because the body of the instance 16935 -- is always elaborated immediately after the spec. 16936 16937 if Call_To_Instance_From_Outside (Ent) then 16938 return; 16939 end if; 16940 16941 -- Nothing to do if subprogram with no separate spec. However, a call 16942 -- to Deep_Initialize may result in a call to a user-defined Initialize 16943 -- procedure, which imposes a body dependency. This happens only if the 16944 -- type is controlled and the Initialize procedure is not inherited. 16945 16946 if Body_Acts_As_Spec then 16947 if Is_TSS (Ent, TSS_Deep_Initialize) then 16948 declare 16949 Typ : constant Entity_Id := Etype (First_Formal (Ent)); 16950 Init : Entity_Id; 16951 16952 begin 16953 if not Is_Controlled (Typ) then 16954 return; 16955 else 16956 Init := Find_Prim_Op (Typ, Name_Initialize); 16957 16958 if Comes_From_Source (Init) then 16959 Ent := Init; 16960 else 16961 return; 16962 end if; 16963 end if; 16964 end; 16965 16966 else 16967 return; 16968 end if; 16969 end if; 16970 16971 -- Check cases of internal units 16972 16973 Callee_Unit_Internal := In_Internal_Unit (E_Scope); 16974 16975 -- Do not give a warning if the with'ed unit is internal and this is 16976 -- the generic instantiation case (this saves a lot of hassle dealing 16977 -- with the Text_IO special child units) 16978 16979 if Callee_Unit_Internal and Inst_Case then 16980 return; 16981 end if; 16982 16983 if C_Scope = Standard_Standard then 16984 Caller_Unit_Internal := False; 16985 else 16986 Caller_Unit_Internal := In_Internal_Unit (C_Scope); 16987 end if; 16988 16989 -- Do not give a warning if the with'ed unit is internal and the caller 16990 -- is not internal (since the binder always elaborates internal units 16991 -- first). 16992 16993 if Callee_Unit_Internal and not Caller_Unit_Internal then 16994 return; 16995 end if; 16996 16997 -- For now, if debug flag -gnatdE is not set, do no checking for one 16998 -- internal unit withing another. This fixes the problem with the sgi 16999 -- build and storage errors. To be resolved later ??? 17000 17001 if (Callee_Unit_Internal and Caller_Unit_Internal) 17002 and not Debug_Flag_EE 17003 then 17004 return; 17005 end if; 17006 17007 if Is_TSS (E, TSS_Deep_Initialize) then 17008 Ent := E; 17009 end if; 17010 17011 -- If the call is in an instance, and the called entity is not 17012 -- defined in the same instance, then the elaboration issue focuses 17013 -- around the unit containing the template, it is this unit that 17014 -- requires an Elaborate_All. 17015 17016 -- However, if we are doing dynamic elaboration, we need to chase the 17017 -- call in the usual manner. 17018 17019 -- We also need to chase the call in the usual manner if it is a call 17020 -- to a generic formal parameter, since that case was not handled as 17021 -- part of the processing of the template. 17022 17023 Inst_Caller := Instantiation (Get_Source_File_Index (Sloc (N))); 17024 Inst_Callee := Instantiation (Get_Source_File_Index (Sloc (Ent))); 17025 17026 if Inst_Caller = No_Location then 17027 Unit_Caller := No_Unit; 17028 else 17029 Unit_Caller := Get_Source_Unit (N); 17030 end if; 17031 17032 if Inst_Callee = No_Location then 17033 Unit_Callee := No_Unit; 17034 else 17035 Unit_Callee := Get_Source_Unit (Ent); 17036 end if; 17037 17038 if Unit_Caller /= No_Unit 17039 and then Unit_Callee /= Unit_Caller 17040 and then not Dynamic_Elaboration_Checks 17041 and then not Is_Call_Of_Generic_Formal (N) 17042 then 17043 E_Scope := Spec_Entity (Cunit_Entity (Unit_Caller)); 17044 17045 -- If we don't get a spec entity, just ignore call. Not quite 17046 -- clear why this check is necessary. ??? 17047 17048 if No (E_Scope) then 17049 return; 17050 end if; 17051 17052 -- Otherwise step to enclosing compilation unit 17053 17054 while not Is_Compilation_Unit (E_Scope) loop 17055 E_Scope := Scope (E_Scope); 17056 end loop; 17057 17058 -- For the case where N is not an instance, and is not a call within 17059 -- instance to other than a generic formal, we recompute E_Scope 17060 -- for the error message, since we do NOT want to go to the unit 17061 -- that has the ultimate declaration in the case of renaming and 17062 -- derivation and we also want to go to the generic unit in the 17063 -- case of an instance, and no further. 17064 17065 else 17066 -- Loop to carefully follow renamings and derivations one step 17067 -- outside the current unit, but not further. 17068 17069 if not (Inst_Case or Variable_Case) 17070 and then Present (Alias (Ent)) 17071 then 17072 E_Scope := Alias (Ent); 17073 else 17074 E_Scope := Ent; 17075 end if; 17076 17077 loop 17078 while not Is_Compilation_Unit (E_Scope) loop 17079 E_Scope := Scope (E_Scope); 17080 end loop; 17081 17082 -- If E_Scope is the same as C_Scope, it means that there 17083 -- definitely was a local renaming or derivation, and we 17084 -- are not yet out of the current unit. 17085 17086 exit when E_Scope /= C_Scope; 17087 Ent := Alias (Ent); 17088 E_Scope := Ent; 17089 17090 -- If no alias, there could be a previous error, but not if we've 17091 -- already reached the outermost level (Standard). 17092 17093 if No (Ent) then 17094 return; 17095 end if; 17096 end loop; 17097 end if; 17098 17099 if Within_Elaborate_All (Current_Sem_Unit, E_Scope) then 17100 return; 17101 end if; 17102 17103 -- Determine whether the Default_Initial_Condition procedure of some 17104 -- type is being invoked. 17105 17106 Is_DIC := Ekind (Ent) = E_Procedure and then Is_DIC_Procedure (Ent); 17107 17108 -- Checks related to Default_Initial_Condition fall under the SPARK 17109 -- umbrella because this is a SPARK-specific annotation. 17110 17111 SPARK_Elab_Errors := 17112 SPARK_Mode = On and (Is_DIC or Dynamic_Elaboration_Checks); 17113 17114 -- Now check if an Elaborate_All (or dynamic check) is needed 17115 17116 if (Elab_Info_Messages or Elab_Warnings or SPARK_Elab_Errors) 17117 and then Generate_Warnings 17118 and then not Suppress_Elaboration_Warnings (Ent) 17119 and then not Elaboration_Checks_Suppressed (Ent) 17120 and then not Suppress_Elaboration_Warnings (E_Scope) 17121 and then not Elaboration_Checks_Suppressed (E_Scope) 17122 then 17123 -- Instantiation case 17124 17125 if Inst_Case then 17126 if Comes_From_Source (Ent) and then SPARK_Elab_Errors then 17127 Error_Msg_NE 17128 ("instantiation of & during elaboration in SPARK", N, Ent); 17129 else 17130 Elab_Warning 17131 ("instantiation of & may raise Program_Error?l?", 17132 "info: instantiation of & during elaboration?$?", Ent); 17133 end if; 17134 17135 -- Indirect call case, info message only in static elaboration 17136 -- case, because the attribute reference itself cannot raise an 17137 -- exception. Note that SPARK does not permit indirect calls. 17138 17139 elsif Access_Case then 17140 Elab_Warning ("", "info: access to & during elaboration?$?", Ent); 17141 17142 -- Variable reference in SPARK mode 17143 17144 elsif Variable_Case then 17145 if Comes_From_Source (Ent) and then SPARK_Elab_Errors then 17146 Error_Msg_NE 17147 ("reference to & during elaboration in SPARK", N, Ent); 17148 end if; 17149 17150 -- Subprogram call case 17151 17152 else 17153 if Nkind (Name (N)) in N_Has_Entity 17154 and then Is_Init_Proc (Entity (Name (N))) 17155 and then Comes_From_Source (Ent) 17156 then 17157 Elab_Warning 17158 ("implicit call to & may raise Program_Error?l?", 17159 "info: implicit call to & during elaboration?$?", 17160 Ent); 17161 17162 elsif SPARK_Elab_Errors then 17163 17164 -- Emit a specialized error message when the elaboration of an 17165 -- object of a private type evaluates the expression of pragma 17166 -- Default_Initial_Condition. This prevents the internal name 17167 -- of the procedure from appearing in the error message. 17168 17169 if Is_DIC then 17170 Error_Msg_N 17171 ("call to Default_Initial_Condition during elaboration in " 17172 & "SPARK", N); 17173 else 17174 Error_Msg_NE 17175 ("call to & during elaboration in SPARK", N, Ent); 17176 end if; 17177 17178 else 17179 Elab_Warning 17180 ("call to & may raise Program_Error?l?", 17181 "info: call to & during elaboration?$?", 17182 Ent); 17183 end if; 17184 end if; 17185 17186 Error_Msg_Qual_Level := Nat'Last; 17187 17188 -- Case of Elaborate_All not present and required, for SPARK this 17189 -- is an error, so give an error message. 17190 17191 if SPARK_Elab_Errors then 17192 Error_Msg_NE -- CODEFIX 17193 ("\Elaborate_All pragma required for&", N, W_Scope); 17194 17195 -- Otherwise we generate an implicit pragma. For a subprogram 17196 -- instantiation, Elaborate is good enough, since no transitive 17197 -- call is possible at elaboration time in this case. 17198 17199 elsif Nkind (N) in N_Subprogram_Instantiation then 17200 Elab_Warning 17201 ("\missing pragma Elaborate for&?l?", 17202 "\implicit pragma Elaborate for& generated?$?", 17203 W_Scope); 17204 17205 -- For all other cases, we need an implicit Elaborate_All 17206 17207 else 17208 Elab_Warning 17209 ("\missing pragma Elaborate_All for&?l?", 17210 "\implicit pragma Elaborate_All for & generated?$?", 17211 W_Scope); 17212 end if; 17213 17214 Error_Msg_Qual_Level := 0; 17215 17216 -- Take into account the flags related to elaboration warning 17217 -- messages when enumerating the various calls involved. This 17218 -- ensures the proper pairing of the main warning and the 17219 -- clarification messages generated by Output_Calls. 17220 17221 Output_Calls (N, Check_Elab_Flag => True); 17222 17223 -- Set flag to prevent further warnings for same unit unless in 17224 -- All_Errors_Mode. 17225 17226 if not All_Errors_Mode and not Dynamic_Elaboration_Checks then 17227 Set_Suppress_Elaboration_Warnings (W_Scope); 17228 end if; 17229 end if; 17230 17231 -- Check for runtime elaboration check required 17232 17233 if Dynamic_Elaboration_Checks then 17234 if not Elaboration_Checks_Suppressed (Ent) 17235 and then not Elaboration_Checks_Suppressed (W_Scope) 17236 and then not Elaboration_Checks_Suppressed (E_Scope) 17237 and then not Cunit_SC 17238 then 17239 -- Runtime elaboration check required. Generate check of the 17240 -- elaboration Boolean for the unit containing the entity. 17241 17242 -- Note that for this case, we do check the real unit (the one 17243 -- from following renamings, since that is the issue). 17244 17245 -- Could this possibly miss a useless but required PE??? 17246 17247 Insert_Elab_Check (N, 17248 Make_Attribute_Reference (Loc, 17249 Attribute_Name => Name_Elaborated, 17250 Prefix => 17251 New_Occurrence_Of (Spec_Entity (E_Scope), Loc))); 17252 17253 -- Prevent duplicate elaboration checks on the same call, which 17254 -- can happen if the body enclosing the call appears itself in a 17255 -- call whose elaboration check is delayed. 17256 17257 if Nkind (N) in N_Subprogram_Call then 17258 Set_No_Elaboration_Check (N); 17259 end if; 17260 end if; 17261 17262 -- Case of static elaboration model 17263 17264 else 17265 -- Do not do anything if elaboration checks suppressed. Note that 17266 -- we check Ent here, not E, since we want the real entity for the 17267 -- body to see if checks are suppressed for it, not the dummy 17268 -- entry for renamings or derivations. 17269 17270 if Elaboration_Checks_Suppressed (Ent) 17271 or else Elaboration_Checks_Suppressed (E_Scope) 17272 or else Elaboration_Checks_Suppressed (W_Scope) 17273 then 17274 null; 17275 17276 -- Do not generate an Elaborate_All for finalization routines 17277 -- that perform partial clean up as part of initialization. 17278 17279 elsif In_Init_Proc and then Is_Finalization_Procedure (Ent) then 17280 null; 17281 17282 -- Here we need to generate an implicit elaborate all 17283 17284 else 17285 -- Generate Elaborate_All warning unless suppressed 17286 17287 if (Elab_Info_Messages and Generate_Warnings and not Inst_Case) 17288 and then not Suppress_Elaboration_Warnings (Ent) 17289 and then not Suppress_Elaboration_Warnings (E_Scope) 17290 and then not Suppress_Elaboration_Warnings (W_Scope) 17291 then 17292 Error_Msg_Node_2 := W_Scope; 17293 Error_Msg_NE 17294 ("info: call to& in elaboration code requires pragma " 17295 & "Elaborate_All on&?$?", N, E); 17296 end if; 17297 17298 -- Set indication for binder to generate Elaborate_All 17299 17300 Set_Elaboration_Constraint (N, E, W_Scope); 17301 end if; 17302 end if; 17303 end Check_A_Call; 17304 17305 ----------------------------- 17306 -- Check_Bad_Instantiation -- 17307 ----------------------------- 17308 17309 procedure Check_Bad_Instantiation (N : Node_Id) is 17310 Ent : Entity_Id; 17311 17312 begin 17313 -- Nothing to do if we do not have an instantiation (happens in some 17314 -- error cases, and also in the formal package declaration case) 17315 17316 if Nkind (N) not in N_Generic_Instantiation then 17317 return; 17318 17319 -- Nothing to do if serious errors detected (avoid cascaded errors) 17320 17321 elsif Serious_Errors_Detected /= 0 then 17322 return; 17323 17324 -- Nothing to do if not in full analysis mode 17325 17326 elsif not Full_Analysis then 17327 return; 17328 17329 -- Nothing to do if inside a generic template 17330 17331 elsif Inside_A_Generic then 17332 return; 17333 17334 -- Nothing to do if a library level instantiation 17335 17336 elsif Nkind (Parent (N)) = N_Compilation_Unit then 17337 return; 17338 17339 -- Nothing to do if we are compiling a proper body for semantic 17340 -- purposes only. The generic body may be in another proper body. 17341 17342 elsif 17343 Nkind (Parent (Unit_Declaration_Node (Main_Unit_Entity))) = N_Subunit 17344 then 17345 return; 17346 end if; 17347 17348 Ent := Get_Generic_Entity (N); 17349 17350 -- The case we are interested in is when the generic spec is in the 17351 -- current declarative part 17352 17353 if not Same_Elaboration_Scope (Current_Scope, Scope (Ent)) 17354 or else not In_Same_Extended_Unit (N, Ent) 17355 then 17356 return; 17357 end if; 17358 17359 -- If the generic entity is within a deeper instance than we are, then 17360 -- either the instantiation to which we refer itself caused an ABE, in 17361 -- which case that will be handled separately. Otherwise, we know that 17362 -- the body we need appears as needed at the point of the instantiation. 17363 -- If they are both at the same level but not within the same instance 17364 -- then the body of the generic will be in the earlier instance. 17365 17366 declare 17367 D1 : constant Nat := Instantiation_Depth (Sloc (Ent)); 17368 D2 : constant Nat := Instantiation_Depth (Sloc (N)); 17369 17370 begin 17371 if D1 > D2 then 17372 return; 17373 17374 elsif D1 = D2 17375 and then Is_Generic_Instance (Scope (Ent)) 17376 and then not In_Open_Scopes (Scope (Ent)) 17377 then 17378 return; 17379 end if; 17380 end; 17381 17382 -- Now we can proceed, if the entity being called has a completion, 17383 -- then we are definitely OK, since we have already seen the body. 17384 17385 if Has_Completion (Ent) then 17386 return; 17387 end if; 17388 17389 -- If there is no body, then nothing to do 17390 17391 if not Has_Generic_Body (N) then 17392 return; 17393 end if; 17394 17395 -- Here we definitely have a bad instantiation 17396 17397 Error_Msg_Warn := SPARK_Mode /= On; 17398 Error_Msg_NE ("cannot instantiate& before body seen<<", N, Ent); 17399 Error_Msg_N ("\Program_Error [<<", N); 17400 17401 Insert_Elab_Check (N); 17402 Set_Is_Known_Guaranteed_ABE (N); 17403 end Check_Bad_Instantiation; 17404 17405 --------------------- 17406 -- Check_Elab_Call -- 17407 --------------------- 17408 17409 procedure Check_Elab_Call 17410 (N : Node_Id; 17411 Outer_Scope : Entity_Id := Empty; 17412 In_Init_Proc : Boolean := False) 17413 is 17414 Ent : Entity_Id; 17415 P : Node_Id; 17416 17417 begin 17418 pragma Assert (Legacy_Elaboration_Checks); 17419 17420 -- If the reference is not in the main unit, there is nothing to check. 17421 -- Elaboration call from units in the context of the main unit will lead 17422 -- to semantic dependencies when those units are compiled. 17423 17424 if not In_Extended_Main_Code_Unit (N) then 17425 return; 17426 end if; 17427 17428 -- For an entry call, check relevant restriction 17429 17430 if Nkind (N) = N_Entry_Call_Statement 17431 and then not In_Subprogram_Or_Concurrent_Unit 17432 then 17433 Check_Restriction (No_Entry_Calls_In_Elaboration_Code, N); 17434 17435 -- Nothing to do if this is not an expected type of reference (happens 17436 -- in some error conditions, and in some cases where rewriting occurs). 17437 17438 elsif Nkind (N) not in N_Subprogram_Call 17439 and then Nkind (N) /= N_Attribute_Reference 17440 and then (SPARK_Mode /= On 17441 or else Nkind (N) not in N_Has_Entity 17442 or else No (Entity (N)) 17443 or else Ekind (Entity (N)) /= E_Variable) 17444 then 17445 return; 17446 17447 -- Nothing to do if this is a call already rewritten for elab checking. 17448 -- Such calls appear as the targets of If_Expressions. 17449 17450 -- This check MUST be wrong, it catches far too much 17451 17452 elsif Nkind (Parent (N)) = N_If_Expression then 17453 return; 17454 17455 -- Nothing to do if inside a generic template 17456 17457 elsif Inside_A_Generic 17458 and then No (Enclosing_Generic_Body (N)) 17459 then 17460 return; 17461 17462 -- Nothing to do if call is being preanalyzed, as when within a 17463 -- pre/postcondition, a predicate, or an invariant. 17464 17465 elsif In_Spec_Expression then 17466 return; 17467 end if; 17468 17469 -- Nothing to do if this is a call to a postcondition, which is always 17470 -- within a subprogram body, even though the current scope may be the 17471 -- enclosing scope of the subprogram. 17472 17473 if Nkind (N) = N_Procedure_Call_Statement 17474 and then Is_Entity_Name (Name (N)) 17475 and then Chars (Entity (Name (N))) = Name_uPostconditions 17476 then 17477 return; 17478 end if; 17479 17480 -- Here we have a reference at elaboration time that must be checked 17481 17482 if Debug_Flag_Underscore_LL then 17483 Write_Str (" Check_Elab_Ref: "); 17484 17485 if Nkind (N) = N_Attribute_Reference then 17486 if not Is_Entity_Name (Prefix (N)) then 17487 Write_Str ("<<not entity name>>"); 17488 else 17489 Write_Name (Chars (Entity (Prefix (N)))); 17490 end if; 17491 17492 Write_Str ("'Access"); 17493 17494 elsif No (Name (N)) or else not Is_Entity_Name (Name (N)) then 17495 Write_Str ("<<not entity name>> "); 17496 17497 else 17498 Write_Name (Chars (Entity (Name (N)))); 17499 end if; 17500 17501 Write_Str (" reference at "); 17502 Write_Location (Sloc (N)); 17503 Write_Eol; 17504 end if; 17505 17506 -- Climb up the tree to make sure we are not inside default expression 17507 -- of a parameter specification or a record component, since in both 17508 -- these cases, we will be doing the actual reference later, not now, 17509 -- and it is at the time of the actual reference (statically speaking) 17510 -- that we must do our static check, not at the time of its initial 17511 -- analysis). 17512 17513 -- However, we have to check references within component definitions 17514 -- (e.g. a function call that determines an array component bound), 17515 -- so we terminate the loop in that case. 17516 17517 P := Parent (N); 17518 while Present (P) loop 17519 if Nkind (P) in N_Parameter_Specification | N_Component_Declaration 17520 then 17521 return; 17522 17523 -- The reference occurs within the constraint of a component, 17524 -- so it must be checked. 17525 17526 elsif Nkind (P) = N_Component_Definition then 17527 exit; 17528 17529 else 17530 P := Parent (P); 17531 end if; 17532 end loop; 17533 17534 -- Stuff that happens only at the outer level 17535 17536 if No (Outer_Scope) then 17537 Elab_Visited.Set_Last (0); 17538 17539 -- Nothing to do if current scope is Standard (this is a bit odd, but 17540 -- it happens in the case of generic instantiations). 17541 17542 C_Scope := Current_Scope; 17543 17544 if C_Scope = Standard_Standard then 17545 return; 17546 end if; 17547 17548 -- First case, we are in elaboration code 17549 17550 From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit; 17551 17552 if From_Elab_Code then 17553 17554 -- Complain if ref that comes from source in preelaborated unit 17555 -- and we are not inside a subprogram (i.e. we are in elab code). 17556 17557 -- Ada 2020 (AI12-0175): Calls to certain functions that are 17558 -- essentially unchecked conversions are preelaborable. 17559 17560 if Comes_From_Source (N) 17561 and then In_Preelaborated_Unit 17562 and then not In_Inlined_Body 17563 and then Nkind (N) /= N_Attribute_Reference 17564 and then not (Ada_Version >= Ada_2020 17565 and then Is_Preelaborable_Construct (N)) 17566 then 17567 Error_Preelaborated_Call (N); 17568 return; 17569 end if; 17570 17571 -- Second case, we are inside a subprogram or concurrent unit, which 17572 -- means we are not in elaboration code. 17573 17574 else 17575 -- In this case, the issue is whether we are inside the 17576 -- declarative part of the unit in which we live, or inside its 17577 -- statements. In the latter case, there is no issue of ABE calls 17578 -- at this level (a call from outside to the unit in which we live 17579 -- might cause an ABE, but that will be detected when we analyze 17580 -- that outer level call, as it recurses into the called unit). 17581 17582 -- Climb up the tree, doing this test, and also testing for being 17583 -- inside a default expression, which, as discussed above, is not 17584 -- checked at this stage. 17585 17586 declare 17587 P : Node_Id; 17588 L : List_Id; 17589 17590 begin 17591 P := N; 17592 loop 17593 -- If we find a parentless subtree, it seems safe to assume 17594 -- that we are not in a declarative part and that no 17595 -- checking is required. 17596 17597 if No (P) then 17598 return; 17599 end if; 17600 17601 if Is_List_Member (P) then 17602 L := List_Containing (P); 17603 P := Parent (L); 17604 else 17605 L := No_List; 17606 P := Parent (P); 17607 end if; 17608 17609 exit when Nkind (P) = N_Subunit; 17610 17611 -- Filter out case of default expressions, where we do not 17612 -- do the check at this stage. 17613 17614 if Nkind (P) in 17615 N_Parameter_Specification | N_Component_Declaration 17616 then 17617 return; 17618 end if; 17619 17620 -- A protected body has no elaboration code and contains 17621 -- only other bodies. 17622 17623 if Nkind (P) = N_Protected_Body then 17624 return; 17625 17626 elsif Nkind (P) in N_Subprogram_Body 17627 | N_Task_Body 17628 | N_Block_Statement 17629 | N_Entry_Body 17630 then 17631 if L = Declarations (P) then 17632 exit; 17633 17634 -- We are not in elaboration code, but we are doing 17635 -- dynamic elaboration checks, in this case, we still 17636 -- need to do the reference, since the subprogram we are 17637 -- in could be called from another unit, also in dynamic 17638 -- elaboration check mode, at elaboration time. 17639 17640 elsif Dynamic_Elaboration_Checks then 17641 17642 -- We provide a debug flag to disable this check. That 17643 -- way we have an easy work around for regressions 17644 -- that are caused by this new check. This debug flag 17645 -- can be removed later. 17646 17647 if Debug_Flag_DD then 17648 return; 17649 end if; 17650 17651 -- Do the check in this case 17652 17653 exit; 17654 17655 elsif Nkind (P) = N_Task_Body then 17656 17657 -- The check is deferred until Check_Task_Activation 17658 -- but we need to capture local suppress pragmas 17659 -- that may inhibit checks on this call. 17660 17661 Ent := Get_Referenced_Ent (N); 17662 17663 if No (Ent) then 17664 return; 17665 17666 elsif Elaboration_Checks_Suppressed (Current_Scope) 17667 or else Elaboration_Checks_Suppressed (Ent) 17668 or else Elaboration_Checks_Suppressed (Scope (Ent)) 17669 then 17670 if Nkind (N) in N_Subprogram_Call then 17671 Set_No_Elaboration_Check (N); 17672 end if; 17673 end if; 17674 17675 return; 17676 17677 -- Static model, call is not in elaboration code, we 17678 -- never need to worry, because in the static model the 17679 -- top-level caller always takes care of things. 17680 17681 else 17682 return; 17683 end if; 17684 end if; 17685 end loop; 17686 end; 17687 end if; 17688 end if; 17689 17690 Ent := Get_Referenced_Ent (N); 17691 17692 if No (Ent) then 17693 return; 17694 end if; 17695 17696 -- Determine whether a prior call to the same subprogram was already 17697 -- examined within the same context. If this is the case, then there is 17698 -- no need to proceed with the various warnings and checks because the 17699 -- work was already done for the previous call. 17700 17701 declare 17702 Self : constant Visited_Element := 17703 (Subp_Id => Ent, Context => Parent (N)); 17704 17705 begin 17706 for Index in 1 .. Elab_Visited.Last loop 17707 if Self = Elab_Visited.Table (Index) then 17708 return; 17709 end if; 17710 end loop; 17711 end; 17712 17713 -- See if we need to analyze this reference. We analyze it if either of 17714 -- the following conditions is met: 17715 17716 -- It is an inner level call (since in this case it was triggered 17717 -- by an outer level call from elaboration code), but only if the 17718 -- call is within the scope of the original outer level call. 17719 17720 -- It is an outer level reference from elaboration code, or a call to 17721 -- an entity is in the same elaboration scope. 17722 17723 -- And in these cases, we will check both inter-unit calls and 17724 -- intra-unit (within a single unit) calls. 17725 17726 C_Scope := Current_Scope; 17727 17728 -- If not outer level reference, then we follow it if it is within the 17729 -- original scope of the outer reference. 17730 17731 if Present (Outer_Scope) 17732 and then Within (Scope (Ent), Outer_Scope) 17733 then 17734 Set_C_Scope; 17735 Check_A_Call 17736 (N => N, 17737 E => Ent, 17738 Outer_Scope => Outer_Scope, 17739 Inter_Unit_Only => False, 17740 In_Init_Proc => In_Init_Proc); 17741 17742 -- Nothing to do if elaboration checks suppressed for this scope. 17743 -- However, an interesting exception, the fact that elaboration checks 17744 -- are suppressed within an instance (because we can trace the body when 17745 -- we process the template) does not extend to calls to generic formal 17746 -- subprograms. 17747 17748 elsif Elaboration_Checks_Suppressed (Current_Scope) 17749 and then not Is_Call_Of_Generic_Formal (N) 17750 then 17751 null; 17752 17753 elsif From_Elab_Code then 17754 Set_C_Scope; 17755 Check_A_Call (N, Ent, Standard_Standard, Inter_Unit_Only => False); 17756 17757 elsif Same_Elaboration_Scope (C_Scope, Scope (Ent)) then 17758 Set_C_Scope; 17759 Check_A_Call (N, Ent, Scope (Ent), Inter_Unit_Only => False); 17760 17761 -- If none of those cases holds, but Dynamic_Elaboration_Checks mode 17762 -- is set, then we will do the check, but only in the inter-unit case 17763 -- (this is to accommodate unguarded elaboration calls from other units 17764 -- in which this same mode is set). We don't want warnings in this case, 17765 -- it would generate warnings having nothing to do with elaboration. 17766 17767 elsif Dynamic_Elaboration_Checks then 17768 Set_C_Scope; 17769 Check_A_Call 17770 (N, 17771 Ent, 17772 Standard_Standard, 17773 Inter_Unit_Only => True, 17774 Generate_Warnings => False); 17775 17776 -- Otherwise nothing to do 17777 17778 else 17779 return; 17780 end if; 17781 17782 -- A call to an Init_Proc in elaboration code may bring additional 17783 -- dependencies, if some of the record components thereof have 17784 -- initializations that are function calls that come from source. We 17785 -- treat the current node as a call to each of these functions, to check 17786 -- their elaboration impact. 17787 17788 if Is_Init_Proc (Ent) and then From_Elab_Code then 17789 Process_Init_Proc : declare 17790 Unit_Decl : constant Node_Id := Unit_Declaration_Node (Ent); 17791 17792 function Check_Init_Call (Nod : Node_Id) return Traverse_Result; 17793 -- Find subprogram calls within body of Init_Proc for Traverse 17794 -- instantiation below. 17795 17796 procedure Traverse_Body is new Traverse_Proc (Check_Init_Call); 17797 -- Traversal procedure to find all calls with body of Init_Proc 17798 17799 --------------------- 17800 -- Check_Init_Call -- 17801 --------------------- 17802 17803 function Check_Init_Call (Nod : Node_Id) return Traverse_Result is 17804 Func : Entity_Id; 17805 17806 begin 17807 if Nkind (Nod) in N_Subprogram_Call 17808 and then Is_Entity_Name (Name (Nod)) 17809 then 17810 Func := Entity (Name (Nod)); 17811 17812 if Comes_From_Source (Func) then 17813 Check_A_Call 17814 (N, Func, Standard_Standard, Inter_Unit_Only => True); 17815 end if; 17816 17817 return OK; 17818 17819 else 17820 return OK; 17821 end if; 17822 end Check_Init_Call; 17823 17824 -- Start of processing for Process_Init_Proc 17825 17826 begin 17827 if Nkind (Unit_Decl) = N_Subprogram_Body then 17828 Traverse_Body (Handled_Statement_Sequence (Unit_Decl)); 17829 end if; 17830 end Process_Init_Proc; 17831 end if; 17832 end Check_Elab_Call; 17833 17834 ----------------------- 17835 -- Check_Elab_Assign -- 17836 ----------------------- 17837 17838 procedure Check_Elab_Assign (N : Node_Id) is 17839 Ent : Entity_Id; 17840 Scop : Entity_Id; 17841 17842 Pkg_Spec : Entity_Id; 17843 Pkg_Body : Entity_Id; 17844 17845 begin 17846 pragma Assert (Legacy_Elaboration_Checks); 17847 17848 -- For record or array component, check prefix. If it is an access type, 17849 -- then there is nothing to do (we do not know what is being assigned), 17850 -- but otherwise this is an assignment to the prefix. 17851 17852 if Nkind (N) in N_Indexed_Component | N_Selected_Component | N_Slice then 17853 if not Is_Access_Type (Etype (Prefix (N))) then 17854 Check_Elab_Assign (Prefix (N)); 17855 end if; 17856 17857 return; 17858 end if; 17859 17860 -- For type conversion, check expression 17861 17862 if Nkind (N) = N_Type_Conversion then 17863 Check_Elab_Assign (Expression (N)); 17864 return; 17865 end if; 17866 17867 -- Nothing to do if this is not an entity reference otherwise get entity 17868 17869 if Is_Entity_Name (N) then 17870 Ent := Entity (N); 17871 else 17872 return; 17873 end if; 17874 17875 -- What we are looking for is a reference in the body of a package that 17876 -- modifies a variable declared in the visible part of the package spec. 17877 17878 if Present (Ent) 17879 and then Comes_From_Source (N) 17880 and then not Suppress_Elaboration_Warnings (Ent) 17881 and then Ekind (Ent) = E_Variable 17882 and then not In_Private_Part (Ent) 17883 and then Is_Library_Level_Entity (Ent) 17884 then 17885 Scop := Current_Scope; 17886 loop 17887 if No (Scop) or else Scop = Standard_Standard then 17888 return; 17889 elsif Ekind (Scop) = E_Package 17890 and then Is_Compilation_Unit (Scop) 17891 then 17892 exit; 17893 else 17894 Scop := Scope (Scop); 17895 end if; 17896 end loop; 17897 17898 -- Here Scop points to the containing library package 17899 17900 Pkg_Spec := Scop; 17901 Pkg_Body := Body_Entity (Pkg_Spec); 17902 17903 -- All OK if the package has an Elaborate_Body pragma 17904 17905 if Has_Pragma_Elaborate_Body (Scop) then 17906 return; 17907 end if; 17908 17909 -- OK if entity being modified is not in containing package spec 17910 17911 if not In_Same_Source_Unit (Scop, Ent) then 17912 return; 17913 end if; 17914 17915 -- All OK if entity appears in generic package or generic instance. 17916 -- We just get too messed up trying to give proper warnings in the 17917 -- presence of generics. Better no message than a junk one. 17918 17919 Scop := Scope (Ent); 17920 while Present (Scop) and then Scop /= Pkg_Spec loop 17921 if Ekind (Scop) = E_Generic_Package then 17922 return; 17923 elsif Ekind (Scop) = E_Package 17924 and then Is_Generic_Instance (Scop) 17925 then 17926 return; 17927 end if; 17928 17929 Scop := Scope (Scop); 17930 end loop; 17931 17932 -- All OK if in task, don't issue warnings there 17933 17934 if In_Task_Activation then 17935 return; 17936 end if; 17937 17938 -- OK if no package body 17939 17940 if No (Pkg_Body) then 17941 return; 17942 end if; 17943 17944 -- OK if reference is not in package body 17945 17946 if not In_Same_Source_Unit (Pkg_Body, N) then 17947 return; 17948 end if; 17949 17950 -- OK if package body has no handled statement sequence 17951 17952 declare 17953 HSS : constant Node_Id := 17954 Handled_Statement_Sequence (Declaration_Node (Pkg_Body)); 17955 begin 17956 if No (HSS) or else not Comes_From_Source (HSS) then 17957 return; 17958 end if; 17959 end; 17960 17961 -- We definitely have a case of a modification of an entity in 17962 -- the package spec from the elaboration code of the package body. 17963 -- We may not give the warning (because there are some additional 17964 -- checks to avoid too many false positives), but it would be a good 17965 -- idea for the binder to try to keep the body elaboration close to 17966 -- the spec elaboration. 17967 17968 Set_Elaborate_Body_Desirable (Pkg_Spec); 17969 17970 -- All OK in gnat mode (we know what we are doing) 17971 17972 if GNAT_Mode then 17973 return; 17974 end if; 17975 17976 -- All OK if all warnings suppressed 17977 17978 if Warning_Mode = Suppress then 17979 return; 17980 end if; 17981 17982 -- All OK if elaboration checks suppressed for entity 17983 17984 if Checks_May_Be_Suppressed (Ent) 17985 and then Is_Check_Suppressed (Ent, Elaboration_Check) 17986 then 17987 return; 17988 end if; 17989 17990 -- OK if the entity is initialized. Note that the No_Initialization 17991 -- flag usually means that the initialization has been rewritten into 17992 -- assignments, but that still counts for us. 17993 17994 declare 17995 Decl : constant Node_Id := Declaration_Node (Ent); 17996 begin 17997 if Nkind (Decl) = N_Object_Declaration 17998 and then (Present (Expression (Decl)) 17999 or else No_Initialization (Decl)) 18000 then 18001 return; 18002 end if; 18003 end; 18004 18005 -- Here is where we give the warning 18006 18007 -- All OK if warnings suppressed on the entity 18008 18009 if not Has_Warnings_Off (Ent) then 18010 Error_Msg_Sloc := Sloc (Ent); 18011 18012 Error_Msg_NE 18013 ("??& can be accessed by clients before this initialization", 18014 N, Ent); 18015 Error_Msg_NE 18016 ("\??add Elaborate_Body to spec to ensure & is initialized", 18017 N, Ent); 18018 end if; 18019 18020 if not All_Errors_Mode then 18021 Set_Suppress_Elaboration_Warnings (Ent); 18022 end if; 18023 end if; 18024 end Check_Elab_Assign; 18025 18026 ---------------------- 18027 -- Check_Elab_Calls -- 18028 ---------------------- 18029 18030 -- WARNING: This routine manages SPARK regions 18031 18032 procedure Check_Elab_Calls is 18033 Saved_SM : SPARK_Mode_Type; 18034 Saved_SMP : Node_Id; 18035 18036 begin 18037 pragma Assert (Legacy_Elaboration_Checks); 18038 18039 -- If expansion is disabled, do not generate any checks, unless we 18040 -- are in GNATprove mode, so that errors are issued in GNATprove for 18041 -- violations of static elaboration rules in SPARK code. Also skip 18042 -- checks if any subunits are missing because in either case we lack the 18043 -- full information that we need, and no object file will be created in 18044 -- any case. 18045 18046 if (not Expander_Active and not GNATprove_Mode) 18047 or else Is_Generic_Unit (Cunit_Entity (Main_Unit)) 18048 or else Subunits_Missing 18049 then 18050 return; 18051 end if; 18052 18053 -- Skip delayed calls if we had any errors 18054 18055 if Serious_Errors_Detected = 0 then 18056 Delaying_Elab_Checks := False; 18057 Expander_Mode_Save_And_Set (True); 18058 18059 for J in Delay_Check.First .. Delay_Check.Last loop 18060 Push_Scope (Delay_Check.Table (J).Curscop); 18061 From_Elab_Code := Delay_Check.Table (J).From_Elab_Code; 18062 In_Task_Activation := Delay_Check.Table (J).In_Task_Activation; 18063 18064 Saved_SM := SPARK_Mode; 18065 Saved_SMP := SPARK_Mode_Pragma; 18066 18067 -- Set appropriate value of SPARK_Mode 18068 18069 if Delay_Check.Table (J).From_SPARK_Code then 18070 SPARK_Mode := On; 18071 end if; 18072 18073 Check_Internal_Call_Continue 18074 (N => Delay_Check.Table (J).N, 18075 E => Delay_Check.Table (J).E, 18076 Outer_Scope => Delay_Check.Table (J).Outer_Scope, 18077 Orig_Ent => Delay_Check.Table (J).Orig_Ent); 18078 18079 Restore_SPARK_Mode (Saved_SM, Saved_SMP); 18080 Pop_Scope; 18081 end loop; 18082 18083 -- Set Delaying_Elab_Checks back on for next main compilation 18084 18085 Expander_Mode_Restore; 18086 Delaying_Elab_Checks := True; 18087 end if; 18088 end Check_Elab_Calls; 18089 18090 ------------------------------ 18091 -- Check_Elab_Instantiation -- 18092 ------------------------------ 18093 18094 procedure Check_Elab_Instantiation 18095 (N : Node_Id; 18096 Outer_Scope : Entity_Id := Empty) 18097 is 18098 Ent : Entity_Id; 18099 18100 begin 18101 pragma Assert (Legacy_Elaboration_Checks); 18102 18103 -- Check for and deal with bad instantiation case. There is some 18104 -- duplicated code here, but we will worry about this later ??? 18105 18106 Check_Bad_Instantiation (N); 18107 18108 if Is_Known_Guaranteed_ABE (N) then 18109 return; 18110 end if; 18111 18112 -- Nothing to do if we do not have an instantiation (happens in some 18113 -- error cases, and also in the formal package declaration case) 18114 18115 if Nkind (N) not in N_Generic_Instantiation then 18116 return; 18117 end if; 18118 18119 -- Nothing to do if inside a generic template 18120 18121 if Inside_A_Generic then 18122 return; 18123 end if; 18124 18125 -- Nothing to do if the instantiation is not in the main unit 18126 18127 if not In_Extended_Main_Code_Unit (N) then 18128 return; 18129 end if; 18130 18131 Ent := Get_Generic_Entity (N); 18132 From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit; 18133 18134 -- See if we need to analyze this instantiation. We analyze it if 18135 -- either of the following conditions is met: 18136 18137 -- It is an inner level instantiation (since in this case it was 18138 -- triggered by an outer level call from elaboration code), but 18139 -- only if the instantiation is within the scope of the original 18140 -- outer level call. 18141 18142 -- It is an outer level instantiation from elaboration code, or the 18143 -- instantiated entity is in the same elaboration scope. 18144 18145 -- And in these cases, we will check both the inter-unit case and 18146 -- the intra-unit (within a single unit) case. 18147 18148 C_Scope := Current_Scope; 18149 18150 if Present (Outer_Scope) and then Within (Scope (Ent), Outer_Scope) then 18151 Set_C_Scope; 18152 Check_A_Call (N, Ent, Outer_Scope, Inter_Unit_Only => False); 18153 18154 elsif From_Elab_Code then 18155 Set_C_Scope; 18156 Check_A_Call (N, Ent, Standard_Standard, Inter_Unit_Only => False); 18157 18158 elsif Same_Elaboration_Scope (C_Scope, Scope (Ent)) then 18159 Set_C_Scope; 18160 Check_A_Call (N, Ent, Scope (Ent), Inter_Unit_Only => False); 18161 18162 -- If none of those cases holds, but Dynamic_Elaboration_Checks mode is 18163 -- set, then we will do the check, but only in the inter-unit case (this 18164 -- is to accommodate unguarded elaboration calls from other units in 18165 -- which this same mode is set). We inhibit warnings in this case, since 18166 -- this instantiation is not occurring in elaboration code. 18167 18168 elsif Dynamic_Elaboration_Checks then 18169 Set_C_Scope; 18170 Check_A_Call 18171 (N, 18172 Ent, 18173 Standard_Standard, 18174 Inter_Unit_Only => True, 18175 Generate_Warnings => False); 18176 18177 else 18178 return; 18179 end if; 18180 end Check_Elab_Instantiation; 18181 18182 ------------------------- 18183 -- Check_Internal_Call -- 18184 ------------------------- 18185 18186 procedure Check_Internal_Call 18187 (N : Node_Id; 18188 E : Entity_Id; 18189 Outer_Scope : Entity_Id; 18190 Orig_Ent : Entity_Id) 18191 is 18192 function Within_Initial_Condition (Call : Node_Id) return Boolean; 18193 -- Determine whether call Call occurs within pragma Initial_Condition or 18194 -- pragma Check with check_kind set to Initial_Condition. 18195 18196 ------------------------------ 18197 -- Within_Initial_Condition -- 18198 ------------------------------ 18199 18200 function Within_Initial_Condition (Call : Node_Id) return Boolean is 18201 Args : List_Id; 18202 Nam : Name_Id; 18203 Par : Node_Id; 18204 18205 begin 18206 -- Traverse the parent chain looking for an enclosing pragma 18207 18208 Par := Call; 18209 while Present (Par) loop 18210 if Nkind (Par) = N_Pragma then 18211 Nam := Pragma_Name (Par); 18212 18213 -- Pragma Initial_Condition appears in its alternative from as 18214 -- Check (Initial_Condition, ...). 18215 18216 if Nam = Name_Check then 18217 Args := Pragma_Argument_Associations (Par); 18218 18219 -- Pragma Check should have at least two arguments 18220 18221 pragma Assert (Present (Args)); 18222 18223 return 18224 Chars (Expression (First (Args))) = Name_Initial_Condition; 18225 18226 -- Direct match 18227 18228 elsif Nam = Name_Initial_Condition then 18229 return True; 18230 18231 -- Since pragmas are never nested within other pragmas, stop 18232 -- the traversal. 18233 18234 else 18235 return False; 18236 end if; 18237 18238 -- Prevent the search from going too far 18239 18240 elsif Is_Body_Or_Package_Declaration (Par) then 18241 exit; 18242 end if; 18243 18244 Par := Parent (Par); 18245 18246 -- If assertions are not enabled, the check pragma is rewritten 18247 -- as an if_statement in sem_prag, to generate various warnings 18248 -- on boolean expressions. Retrieve the original pragma. 18249 18250 if Nkind (Original_Node (Par)) = N_Pragma then 18251 Par := Original_Node (Par); 18252 end if; 18253 end loop; 18254 18255 return False; 18256 end Within_Initial_Condition; 18257 18258 -- Local variables 18259 18260 Inst_Case : constant Boolean := Nkind (N) in N_Generic_Instantiation; 18261 18262 -- Start of processing for Check_Internal_Call 18263 18264 begin 18265 -- For P'Access, we want to warn if the -gnatw.f switch is set, and the 18266 -- node comes from source. 18267 18268 if Nkind (N) = N_Attribute_Reference 18269 and then ((not Warn_On_Elab_Access and then not Debug_Flag_Dot_O) 18270 or else not Comes_From_Source (N)) 18271 then 18272 return; 18273 18274 -- If not function or procedure call, instantiation, or 'Access, then 18275 -- ignore call (this happens in some error cases and rewriting cases). 18276 18277 elsif Nkind (N) not in N_Attribute_Reference 18278 | N_Function_Call 18279 | N_Procedure_Call_Statement 18280 and then not Inst_Case 18281 then 18282 return; 18283 18284 -- Nothing to do if this is a call or instantiation that has already 18285 -- been found to be a sure ABE. 18286 18287 elsif Nkind (N) /= N_Attribute_Reference 18288 and then Is_Known_Guaranteed_ABE (N) 18289 then 18290 return; 18291 18292 -- Nothing to do if errors already detected (avoid cascaded errors) 18293 18294 elsif Serious_Errors_Detected /= 0 then 18295 return; 18296 18297 -- Nothing to do if not in full analysis mode 18298 18299 elsif not Full_Analysis then 18300 return; 18301 18302 -- Nothing to do if analyzing in special spec-expression mode, since the 18303 -- call is not actually being made at this time. 18304 18305 elsif In_Spec_Expression then 18306 return; 18307 18308 -- Nothing to do for call to intrinsic subprogram 18309 18310 elsif Is_Intrinsic_Subprogram (E) then 18311 return; 18312 18313 -- Nothing to do if call is within a generic unit 18314 18315 elsif Inside_A_Generic then 18316 return; 18317 18318 -- Nothing to do when the call appears within pragma Initial_Condition. 18319 -- The pragma is part of the elaboration statements of a package body 18320 -- and may only call external subprograms or subprograms whose body is 18321 -- already available. 18322 18323 elsif Within_Initial_Condition (N) then 18324 return; 18325 end if; 18326 18327 -- Delay this call if we are still delaying calls 18328 18329 if Delaying_Elab_Checks then 18330 Delay_Check.Append 18331 ((N => N, 18332 E => E, 18333 Orig_Ent => Orig_Ent, 18334 Curscop => Current_Scope, 18335 Outer_Scope => Outer_Scope, 18336 From_Elab_Code => From_Elab_Code, 18337 In_Task_Activation => In_Task_Activation, 18338 From_SPARK_Code => SPARK_Mode = On)); 18339 return; 18340 18341 -- Otherwise, call phase 2 continuation right now 18342 18343 else 18344 Check_Internal_Call_Continue (N, E, Outer_Scope, Orig_Ent); 18345 end if; 18346 end Check_Internal_Call; 18347 18348 ---------------------------------- 18349 -- Check_Internal_Call_Continue -- 18350 ---------------------------------- 18351 18352 procedure Check_Internal_Call_Continue 18353 (N : Node_Id; 18354 E : Entity_Id; 18355 Outer_Scope : Entity_Id; 18356 Orig_Ent : Entity_Id) 18357 is 18358 function Find_Elab_Reference (N : Node_Id) return Traverse_Result; 18359 -- Function applied to each node as we traverse the body. Checks for 18360 -- call or entity reference that needs checking, and if so checks it. 18361 -- Always returns OK, so entire tree is traversed, except that as 18362 -- described below subprogram bodies are skipped for now. 18363 18364 procedure Traverse is new Atree.Traverse_Proc (Find_Elab_Reference); 18365 -- Traverse procedure using above Find_Elab_Reference function 18366 18367 ------------------------- 18368 -- Find_Elab_Reference -- 18369 ------------------------- 18370 18371 function Find_Elab_Reference (N : Node_Id) return Traverse_Result is 18372 Actual : Node_Id; 18373 18374 begin 18375 -- If user has specified that there are no entry calls in elaboration 18376 -- code, do not trace past an accept statement, because the rendez- 18377 -- vous will happen after elaboration. 18378 18379 if Nkind (Original_Node (N)) in 18380 N_Accept_Statement | N_Selective_Accept 18381 and then Restriction_Active (No_Entry_Calls_In_Elaboration_Code) 18382 then 18383 return Abandon; 18384 18385 -- If we have a function call, check it 18386 18387 elsif Nkind (N) = N_Function_Call then 18388 Check_Elab_Call (N, Outer_Scope); 18389 return OK; 18390 18391 -- If we have a procedure call, check the call, and also check 18392 -- arguments that are assignments (OUT or IN OUT mode formals). 18393 18394 elsif Nkind (N) = N_Procedure_Call_Statement then 18395 Check_Elab_Call (N, Outer_Scope, In_Init_Proc => Is_Init_Proc (E)); 18396 18397 Actual := First_Actual (N); 18398 while Present (Actual) loop 18399 if Known_To_Be_Assigned (Actual) then 18400 Check_Elab_Assign (Actual); 18401 end if; 18402 18403 Next_Actual (Actual); 18404 end loop; 18405 18406 return OK; 18407 18408 -- If we have an access attribute for a subprogram, check it. 18409 -- Suppress this behavior under debug flag. 18410 18411 elsif not Debug_Flag_Dot_UU 18412 and then Nkind (N) = N_Attribute_Reference 18413 and then 18414 Attribute_Name (N) in Name_Access | Name_Unrestricted_Access 18415 and then Is_Entity_Name (Prefix (N)) 18416 and then Is_Subprogram (Entity (Prefix (N))) 18417 then 18418 Check_Elab_Call (N, Outer_Scope); 18419 return OK; 18420 18421 -- In SPARK mode, if we have an entity reference to a variable, then 18422 -- check it. For now we consider any reference. 18423 18424 elsif SPARK_Mode = On 18425 and then Nkind (N) in N_Has_Entity 18426 and then Present (Entity (N)) 18427 and then Ekind (Entity (N)) = E_Variable 18428 then 18429 Check_Elab_Call (N, Outer_Scope); 18430 return OK; 18431 18432 -- If we have a generic instantiation, check it 18433 18434 elsif Nkind (N) in N_Generic_Instantiation then 18435 Check_Elab_Instantiation (N, Outer_Scope); 18436 return OK; 18437 18438 -- Skip subprogram bodies that come from source (wait for call to 18439 -- analyze these). The reason for the come from source test is to 18440 -- avoid catching task bodies. 18441 18442 -- For task bodies, we should really avoid these too, waiting for the 18443 -- task activation, but that's too much trouble to catch for now, so 18444 -- we go in unconditionally. This is not so terrible, it means the 18445 -- error backtrace is not quite complete, and we are too eager to 18446 -- scan bodies of tasks that are unused, but this is hardly very 18447 -- significant. 18448 18449 elsif Nkind (N) = N_Subprogram_Body 18450 and then Comes_From_Source (N) 18451 then 18452 return Skip; 18453 18454 elsif Nkind (N) = N_Assignment_Statement 18455 and then Comes_From_Source (N) 18456 then 18457 Check_Elab_Assign (Name (N)); 18458 return OK; 18459 18460 else 18461 return OK; 18462 end if; 18463 end Find_Elab_Reference; 18464 18465 Inst_Case : constant Boolean := Is_Generic_Unit (E); 18466 Loc : constant Source_Ptr := Sloc (N); 18467 18468 Ebody : Entity_Id; 18469 Sbody : Node_Id; 18470 18471 -- Start of processing for Check_Internal_Call_Continue 18472 18473 begin 18474 -- Save outer level call if at outer level 18475 18476 if Elab_Call.Last = 0 then 18477 Outer_Level_Sloc := Loc; 18478 end if; 18479 18480 -- If the call is to a function that renames a literal, no check needed 18481 18482 if Ekind (E) = E_Enumeration_Literal then 18483 return; 18484 end if; 18485 18486 -- Register the subprogram as examined within this particular context. 18487 -- This ensures that calls to the same subprogram but in different 18488 -- contexts receive warnings and checks of their own since the calls 18489 -- may be reached through different flow paths. 18490 18491 Elab_Visited.Append ((Subp_Id => E, Context => Parent (N))); 18492 18493 Sbody := Unit_Declaration_Node (E); 18494 18495 if Nkind (Sbody) not in N_Subprogram_Body | N_Package_Body then 18496 Ebody := Corresponding_Body (Sbody); 18497 18498 if No (Ebody) then 18499 return; 18500 else 18501 Sbody := Unit_Declaration_Node (Ebody); 18502 end if; 18503 end if; 18504 18505 -- If the body appears after the outer level call or instantiation then 18506 -- we have an error case handled below. 18507 18508 if Earlier_In_Extended_Unit (Outer_Level_Sloc, Sloc (Sbody)) 18509 and then not In_Task_Activation 18510 then 18511 null; 18512 18513 -- If we have the instantiation case we are done, since we now know that 18514 -- the body of the generic appeared earlier. 18515 18516 elsif Inst_Case then 18517 return; 18518 18519 -- Otherwise we have a call, so we trace through the called body to see 18520 -- if it has any problems. 18521 18522 else 18523 pragma Assert (Nkind (Sbody) = N_Subprogram_Body); 18524 18525 Elab_Call.Append ((Cloc => Loc, Ent => E)); 18526 18527 if Debug_Flag_Underscore_LL then 18528 Write_Str ("Elab_Call.Last = "); 18529 Write_Int (Int (Elab_Call.Last)); 18530 Write_Str (" Ent = "); 18531 Write_Name (Chars (E)); 18532 Write_Str (" at "); 18533 Write_Location (Sloc (N)); 18534 Write_Eol; 18535 end if; 18536 18537 -- Now traverse declarations and statements of subprogram body. Note 18538 -- that we cannot simply Traverse (Sbody), since traverse does not 18539 -- normally visit subprogram bodies. 18540 18541 declare 18542 Decl : Node_Id; 18543 begin 18544 Decl := First (Declarations (Sbody)); 18545 while Present (Decl) loop 18546 Traverse (Decl); 18547 Next (Decl); 18548 end loop; 18549 end; 18550 18551 Traverse (Handled_Statement_Sequence (Sbody)); 18552 18553 Elab_Call.Decrement_Last; 18554 return; 18555 end if; 18556 18557 -- Here is the case of calling a subprogram where the body has not yet 18558 -- been encountered. A warning message is needed, except if this is the 18559 -- case of appearing within an aspect specification that results in 18560 -- a check call, we do not really have such a situation, so no warning 18561 -- is needed (e.g. the case of a precondition, where the call appears 18562 -- textually before the body, but in actual fact is moved to the 18563 -- appropriate subprogram body and so does not need a check). 18564 18565 declare 18566 P : Node_Id; 18567 O : Node_Id; 18568 18569 begin 18570 P := Parent (N); 18571 loop 18572 -- Keep looking at parents if we are still in the subexpression 18573 18574 if Nkind (P) in N_Subexpr then 18575 P := Parent (P); 18576 18577 -- Here P is the parent of the expression, check for special case 18578 18579 else 18580 O := Original_Node (P); 18581 18582 -- Definitely not the special case if orig node is not a pragma 18583 18584 exit when Nkind (O) /= N_Pragma; 18585 18586 -- Check we have an If statement or a null statement (happens 18587 -- when the If has been expanded to be True). 18588 18589 exit when Nkind (P) not in N_If_Statement | N_Null_Statement; 18590 18591 -- Our special case will be indicated either by the pragma 18592 -- coming from an aspect ... 18593 18594 if Present (Corresponding_Aspect (O)) then 18595 return; 18596 18597 -- Or, in the case of an initial condition, specifically by a 18598 -- Check pragma specifying an Initial_Condition check. 18599 18600 elsif Pragma_Name (O) = Name_Check 18601 and then 18602 Chars 18603 (Expression (First (Pragma_Argument_Associations (O)))) = 18604 Name_Initial_Condition 18605 then 18606 return; 18607 18608 -- For anything else, we have an error 18609 18610 else 18611 exit; 18612 end if; 18613 end if; 18614 end loop; 18615 end; 18616 18617 -- Not that special case, warning and dynamic check is required 18618 18619 -- If we have nothing in the call stack, then this is at the outer 18620 -- level, and the ABE is bound to occur, unless it's a 'Access, or 18621 -- it's a renaming. 18622 18623 if Elab_Call.Last = 0 then 18624 Error_Msg_Warn := SPARK_Mode /= On; 18625 18626 declare 18627 Insert_Check : Boolean := True; 18628 -- This flag is set to True if an elaboration check should be 18629 -- inserted. 18630 18631 begin 18632 if In_Task_Activation then 18633 Insert_Check := False; 18634 18635 elsif Inst_Case then 18636 Error_Msg_NE 18637 ("cannot instantiate& before body seen<<", N, Orig_Ent); 18638 18639 elsif Nkind (N) = N_Attribute_Reference then 18640 Error_Msg_NE 18641 ("Access attribute of & before body seen<<", N, Orig_Ent); 18642 Error_Msg_N 18643 ("\possible Program_Error on later references<<", N); 18644 Insert_Check := False; 18645 18646 elsif Nkind (Unit_Declaration_Node (Orig_Ent)) /= 18647 N_Subprogram_Renaming_Declaration 18648 or else Is_Generic_Actual_Subprogram (Orig_Ent) 18649 then 18650 Error_Msg_NE 18651 ("cannot call& before body seen<<", N, Orig_Ent); 18652 else 18653 Insert_Check := False; 18654 end if; 18655 18656 if Insert_Check then 18657 Error_Msg_N ("\Program_Error [<<", N); 18658 Insert_Elab_Check (N); 18659 end if; 18660 end; 18661 18662 -- Call is not at outer level 18663 18664 else 18665 -- Do not generate elaboration checks in GNATprove mode because the 18666 -- elaboration counter and the check are both forms of expansion. 18667 18668 if GNATprove_Mode then 18669 null; 18670 18671 -- Generate an elaboration check 18672 18673 elsif not Elaboration_Checks_Suppressed (E) then 18674 Set_Elaboration_Entity_Required (E); 18675 18676 -- Create a declaration of the elaboration entity, and insert it 18677 -- prior to the subprogram or the generic unit, within the same 18678 -- scope. Since the subprogram may be overloaded, create a unique 18679 -- entity. 18680 18681 if No (Elaboration_Entity (E)) then 18682 declare 18683 Loce : constant Source_Ptr := Sloc (E); 18684 Ent : constant Entity_Id := 18685 Make_Defining_Identifier (Loc, 18686 New_External_Name (Chars (E), 'E', -1)); 18687 18688 begin 18689 Set_Elaboration_Entity (E, Ent); 18690 Push_Scope (Scope (E)); 18691 18692 Insert_Action (Declaration_Node (E), 18693 Make_Object_Declaration (Loce, 18694 Defining_Identifier => Ent, 18695 Object_Definition => 18696 New_Occurrence_Of (Standard_Short_Integer, Loce), 18697 Expression => 18698 Make_Integer_Literal (Loc, Uint_0))); 18699 18700 -- Set elaboration flag at the point of the body 18701 18702 Set_Elaboration_Flag (Sbody, E); 18703 18704 -- Kill current value indication. This is necessary because 18705 -- the tests of this flag are inserted out of sequence and 18706 -- must not pick up bogus indications of the wrong constant 18707 -- value. Also, this is never a true constant, since one way 18708 -- or another, it gets reset. 18709 18710 Set_Current_Value (Ent, Empty); 18711 Set_Last_Assignment (Ent, Empty); 18712 Set_Is_True_Constant (Ent, False); 18713 Pop_Scope; 18714 end; 18715 end if; 18716 18717 -- Generate: 18718 -- if Enn = 0 then 18719 -- raise Program_Error with "access before elaboration"; 18720 -- end if; 18721 18722 Insert_Elab_Check (N, 18723 Make_Attribute_Reference (Loc, 18724 Attribute_Name => Name_Elaborated, 18725 Prefix => New_Occurrence_Of (E, Loc))); 18726 end if; 18727 18728 -- Generate the warning 18729 18730 if not Suppress_Elaboration_Warnings (E) 18731 and then not Elaboration_Checks_Suppressed (E) 18732 18733 -- Suppress this warning if we have a function call that occurred 18734 -- within an assertion expression, since we can get false warnings 18735 -- in this case, due to the out of order handling in this case. 18736 18737 and then 18738 (Nkind (Original_Node (N)) /= N_Function_Call 18739 or else not In_Assertion_Expression_Pragma (Original_Node (N))) 18740 then 18741 Error_Msg_Warn := SPARK_Mode /= On; 18742 18743 if Inst_Case then 18744 Error_Msg_NE 18745 ("instantiation of& may occur before body is seen<l<", 18746 N, Orig_Ent); 18747 else 18748 -- A rather specific check. For Finalize/Adjust/Initialize, if 18749 -- the type has Warnings_Off set, suppress the warning. 18750 18751 if Chars (E) in Name_Adjust 18752 | Name_Finalize 18753 | Name_Initialize 18754 and then Present (First_Formal (E)) 18755 then 18756 declare 18757 T : constant Entity_Id := Etype (First_Formal (E)); 18758 begin 18759 if Is_Controlled (T) then 18760 if Warnings_Off (T) 18761 or else (Ekind (T) = E_Private_Type 18762 and then Warnings_Off (Full_View (T))) 18763 then 18764 goto Output; 18765 end if; 18766 end if; 18767 end; 18768 end if; 18769 18770 -- Go ahead and give warning if not this special case 18771 18772 Error_Msg_NE 18773 ("call to& may occur before body is seen<l<", N, Orig_Ent); 18774 end if; 18775 18776 Error_Msg_N ("\Program_Error ]<l<", N); 18777 18778 -- There is no need to query the elaboration warning message flags 18779 -- because the main message is an error, not a warning, therefore 18780 -- all the clarification messages produces by Output_Calls must be 18781 -- emitted unconditionally. 18782 18783 <<Output>> 18784 18785 Output_Calls (N, Check_Elab_Flag => False); 18786 end if; 18787 end if; 18788 end Check_Internal_Call_Continue; 18789 18790 --------------------------- 18791 -- Check_Task_Activation -- 18792 --------------------------- 18793 18794 procedure Check_Task_Activation (N : Node_Id) is 18795 Loc : constant Source_Ptr := Sloc (N); 18796 Inter_Procs : constant Elist_Id := New_Elmt_List; 18797 Intra_Procs : constant Elist_Id := New_Elmt_List; 18798 Ent : Entity_Id; 18799 P : Entity_Id; 18800 Task_Scope : Entity_Id; 18801 Cunit_SC : Boolean := False; 18802 Decl : Node_Id; 18803 Elmt : Elmt_Id; 18804 Enclosing : Entity_Id; 18805 18806 procedure Add_Task_Proc (Typ : Entity_Id); 18807 -- Add to Task_Procs the task body procedure(s) of task types in Typ. 18808 -- For record types, this procedure recurses over component types. 18809 18810 procedure Collect_Tasks (Decls : List_Id); 18811 -- Collect the types of the tasks that are to be activated in the given 18812 -- list of declarations, in order to perform elaboration checks on the 18813 -- corresponding task procedures that are called implicitly here. 18814 18815 function Outer_Unit (E : Entity_Id) return Entity_Id; 18816 -- find enclosing compilation unit of Entity, ignoring subunits, or 18817 -- else enclosing subprogram. If E is not a package, there is no need 18818 -- for inter-unit elaboration checks. 18819 18820 ------------------- 18821 -- Add_Task_Proc -- 18822 ------------------- 18823 18824 procedure Add_Task_Proc (Typ : Entity_Id) is 18825 Comp : Entity_Id; 18826 Proc : Entity_Id := Empty; 18827 18828 begin 18829 if Is_Task_Type (Typ) then 18830 Proc := Get_Task_Body_Procedure (Typ); 18831 18832 elsif Is_Array_Type (Typ) 18833 and then Has_Task (Base_Type (Typ)) 18834 then 18835 Add_Task_Proc (Component_Type (Typ)); 18836 18837 elsif Is_Record_Type (Typ) 18838 and then Has_Task (Base_Type (Typ)) 18839 then 18840 Comp := First_Component (Typ); 18841 while Present (Comp) loop 18842 Add_Task_Proc (Etype (Comp)); 18843 Next_Component (Comp); 18844 end loop; 18845 end if; 18846 18847 -- If the task type is another unit, we will perform the usual 18848 -- elaboration check on its enclosing unit. If the type is in the 18849 -- same unit, we can trace the task body as for an internal call, 18850 -- but we only need to examine other external calls, because at 18851 -- the point the task is activated, internal subprogram bodies 18852 -- will have been elaborated already. We keep separate lists for 18853 -- each kind of task. 18854 18855 -- Skip this test if errors have occurred, since in this case 18856 -- we can get false indications. 18857 18858 if Serious_Errors_Detected /= 0 then 18859 return; 18860 end if; 18861 18862 if Present (Proc) then 18863 if Outer_Unit (Scope (Proc)) = Enclosing then 18864 18865 if No (Corresponding_Body (Unit_Declaration_Node (Proc))) 18866 and then 18867 (not Is_Generic_Instance (Scope (Proc)) 18868 or else Scope (Proc) = Scope (Defining_Identifier (Decl))) 18869 then 18870 Error_Msg_Warn := SPARK_Mode /= On; 18871 Error_Msg_N 18872 ("task will be activated before elaboration of its body<<", 18873 Decl); 18874 Error_Msg_N ("\Program_Error [<<", Decl); 18875 18876 elsif Present 18877 (Corresponding_Body (Unit_Declaration_Node (Proc))) 18878 then 18879 Append_Elmt (Proc, Intra_Procs); 18880 end if; 18881 18882 else 18883 -- No need for multiple entries of the same type 18884 18885 Elmt := First_Elmt (Inter_Procs); 18886 while Present (Elmt) loop 18887 if Node (Elmt) = Proc then 18888 return; 18889 end if; 18890 18891 Next_Elmt (Elmt); 18892 end loop; 18893 18894 Append_Elmt (Proc, Inter_Procs); 18895 end if; 18896 end if; 18897 end Add_Task_Proc; 18898 18899 ------------------- 18900 -- Collect_Tasks -- 18901 ------------------- 18902 18903 procedure Collect_Tasks (Decls : List_Id) is 18904 begin 18905 if Present (Decls) then 18906 Decl := First (Decls); 18907 while Present (Decl) loop 18908 if Nkind (Decl) = N_Object_Declaration 18909 and then Has_Task (Etype (Defining_Identifier (Decl))) 18910 then 18911 Add_Task_Proc (Etype (Defining_Identifier (Decl))); 18912 end if; 18913 18914 Next (Decl); 18915 end loop; 18916 end if; 18917 end Collect_Tasks; 18918 18919 ---------------- 18920 -- Outer_Unit -- 18921 ---------------- 18922 18923 function Outer_Unit (E : Entity_Id) return Entity_Id is 18924 Outer : Entity_Id; 18925 18926 begin 18927 Outer := E; 18928 while Present (Outer) loop 18929 if Elaboration_Checks_Suppressed (Outer) then 18930 Cunit_SC := True; 18931 end if; 18932 18933 exit when Is_Child_Unit (Outer) 18934 or else Scope (Outer) = Standard_Standard 18935 or else Ekind (Outer) /= E_Package; 18936 Outer := Scope (Outer); 18937 end loop; 18938 18939 return Outer; 18940 end Outer_Unit; 18941 18942 -- Start of processing for Check_Task_Activation 18943 18944 begin 18945 pragma Assert (Legacy_Elaboration_Checks); 18946 18947 Enclosing := Outer_Unit (Current_Scope); 18948 18949 -- Find all tasks declared in the current unit 18950 18951 if Nkind (N) = N_Package_Body then 18952 P := Unit_Declaration_Node (Corresponding_Spec (N)); 18953 18954 Collect_Tasks (Declarations (N)); 18955 Collect_Tasks (Visible_Declarations (Specification (P))); 18956 Collect_Tasks (Private_Declarations (Specification (P))); 18957 18958 elsif Nkind (N) = N_Package_Declaration then 18959 Collect_Tasks (Visible_Declarations (Specification (N))); 18960 Collect_Tasks (Private_Declarations (Specification (N))); 18961 18962 else 18963 Collect_Tasks (Declarations (N)); 18964 end if; 18965 18966 -- We only perform detailed checks in all tasks that are library level 18967 -- entities. If the master is a subprogram or task, activation will 18968 -- depend on the activation of the master itself. 18969 18970 -- Should dynamic checks be added in the more general case??? 18971 18972 if Ekind (Enclosing) /= E_Package then 18973 return; 18974 end if; 18975 18976 -- For task types defined in other units, we want the unit containing 18977 -- the task body to be elaborated before the current one. 18978 18979 Elmt := First_Elmt (Inter_Procs); 18980 while Present (Elmt) loop 18981 Ent := Node (Elmt); 18982 Task_Scope := Outer_Unit (Scope (Ent)); 18983 18984 if not Is_Compilation_Unit (Task_Scope) then 18985 null; 18986 18987 elsif Suppress_Elaboration_Warnings (Task_Scope) 18988 or else Elaboration_Checks_Suppressed (Task_Scope) 18989 then 18990 null; 18991 18992 elsif Dynamic_Elaboration_Checks then 18993 if not Elaboration_Checks_Suppressed (Ent) 18994 and then not Cunit_SC 18995 and then not Restriction_Active 18996 (No_Entry_Calls_In_Elaboration_Code) 18997 then 18998 -- Runtime elaboration check required. Generate check of the 18999 -- elaboration counter for the unit containing the entity. 19000 19001 Insert_Elab_Check (N, 19002 Make_Attribute_Reference (Loc, 19003 Prefix => 19004 New_Occurrence_Of (Spec_Entity (Task_Scope), Loc), 19005 Attribute_Name => Name_Elaborated)); 19006 end if; 19007 19008 else 19009 -- Force the binder to elaborate other unit first 19010 19011 if Elab_Info_Messages 19012 and then not Suppress_Elaboration_Warnings (Ent) 19013 and then not Elaboration_Checks_Suppressed (Ent) 19014 and then not Suppress_Elaboration_Warnings (Task_Scope) 19015 and then not Elaboration_Checks_Suppressed (Task_Scope) 19016 then 19017 Error_Msg_Node_2 := Task_Scope; 19018 Error_Msg_NE 19019 ("info: activation of an instance of task type & requires " 19020 & "pragma Elaborate_All on &?$?", N, Ent); 19021 end if; 19022 19023 Activate_Elaborate_All_Desirable (N, Task_Scope); 19024 Set_Suppress_Elaboration_Warnings (Task_Scope); 19025 end if; 19026 19027 Next_Elmt (Elmt); 19028 end loop; 19029 19030 -- For tasks declared in the current unit, trace other calls within the 19031 -- task procedure bodies, which are available. 19032 19033 if not Debug_Flag_Dot_Y then 19034 In_Task_Activation := True; 19035 19036 Elmt := First_Elmt (Intra_Procs); 19037 while Present (Elmt) loop 19038 Ent := Node (Elmt); 19039 Check_Internal_Call_Continue (N, Ent, Enclosing, Ent); 19040 Next_Elmt (Elmt); 19041 end loop; 19042 19043 In_Task_Activation := False; 19044 end if; 19045 end Check_Task_Activation; 19046 19047 ------------------------ 19048 -- Get_Referenced_Ent -- 19049 ------------------------ 19050 19051 function Get_Referenced_Ent (N : Node_Id) return Entity_Id is 19052 Nam : Node_Id; 19053 19054 begin 19055 if Nkind (N) in N_Has_Entity 19056 and then Present (Entity (N)) 19057 and then Ekind (Entity (N)) = E_Variable 19058 then 19059 return Entity (N); 19060 end if; 19061 19062 if Nkind (N) = N_Attribute_Reference then 19063 Nam := Prefix (N); 19064 else 19065 Nam := Name (N); 19066 end if; 19067 19068 if No (Nam) then 19069 return Empty; 19070 elsif Nkind (Nam) = N_Selected_Component then 19071 return Entity (Selector_Name (Nam)); 19072 elsif not Is_Entity_Name (Nam) then 19073 return Empty; 19074 else 19075 return Entity (Nam); 19076 end if; 19077 end Get_Referenced_Ent; 19078 19079 ---------------------- 19080 -- Has_Generic_Body -- 19081 ---------------------- 19082 19083 function Has_Generic_Body (N : Node_Id) return Boolean is 19084 Ent : constant Entity_Id := Get_Generic_Entity (N); 19085 Decl : constant Node_Id := Unit_Declaration_Node (Ent); 19086 Scop : Entity_Id; 19087 19088 function Find_Body_In (E : Entity_Id; N : Node_Id) return Node_Id; 19089 -- Determine if the list of nodes headed by N and linked by Next 19090 -- contains a package body for the package spec entity E, and if so 19091 -- return the package body. If not, then returns Empty. 19092 19093 function Load_Package_Body (Nam : Unit_Name_Type) return Node_Id; 19094 -- This procedure is called load the unit whose name is given by Nam. 19095 -- This unit is being loaded to see whether it contains an optional 19096 -- generic body. The returned value is the loaded unit, which is always 19097 -- a package body (only package bodies can contain other entities in the 19098 -- sense in which Has_Generic_Body is interested). We only attempt to 19099 -- load bodies if we are generating code. If we are in semantics check 19100 -- only mode, then it would be wrong to load bodies that are not 19101 -- required from a semantic point of view, so in this case we return 19102 -- Empty. The result is that the caller may incorrectly decide that a 19103 -- generic spec does not have a body when in fact it does, but the only 19104 -- harm in this is that some warnings on elaboration problems may be 19105 -- lost in semantic checks only mode, which is not big loss. We also 19106 -- return Empty if we go for a body and it is not there. 19107 19108 function Locate_Corresponding_Body (PE : Entity_Id) return Node_Id; 19109 -- PE is the entity for a package spec. This function locates the 19110 -- corresponding package body, returning Empty if none is found. The 19111 -- package body returned is fully parsed but may not yet be analyzed, 19112 -- so only syntactic fields should be referenced. 19113 19114 ------------------ 19115 -- Find_Body_In -- 19116 ------------------ 19117 19118 function Find_Body_In (E : Entity_Id; N : Node_Id) return Node_Id is 19119 Nod : Node_Id; 19120 19121 begin 19122 Nod := N; 19123 while Present (Nod) loop 19124 19125 -- If we found the package body we are looking for, return it 19126 19127 if Nkind (Nod) = N_Package_Body 19128 and then Chars (Defining_Unit_Name (Nod)) = Chars (E) 19129 then 19130 return Nod; 19131 19132 -- If we found the stub for the body, go after the subunit, 19133 -- loading it if necessary. 19134 19135 elsif Nkind (Nod) = N_Package_Body_Stub 19136 and then Chars (Defining_Identifier (Nod)) = Chars (E) 19137 then 19138 if Present (Library_Unit (Nod)) then 19139 return Unit (Library_Unit (Nod)); 19140 19141 else 19142 return Load_Package_Body (Get_Unit_Name (Nod)); 19143 end if; 19144 19145 -- If neither package body nor stub, keep looking on chain 19146 19147 else 19148 Next (Nod); 19149 end if; 19150 end loop; 19151 19152 return Empty; 19153 end Find_Body_In; 19154 19155 ----------------------- 19156 -- Load_Package_Body -- 19157 ----------------------- 19158 19159 function Load_Package_Body (Nam : Unit_Name_Type) return Node_Id is 19160 U : Unit_Number_Type; 19161 19162 begin 19163 if Operating_Mode /= Generate_Code then 19164 return Empty; 19165 else 19166 U := 19167 Load_Unit 19168 (Load_Name => Nam, 19169 Required => False, 19170 Subunit => False, 19171 Error_Node => N); 19172 19173 if U = No_Unit then 19174 return Empty; 19175 else 19176 return Unit (Cunit (U)); 19177 end if; 19178 end if; 19179 end Load_Package_Body; 19180 19181 ------------------------------- 19182 -- Locate_Corresponding_Body -- 19183 ------------------------------- 19184 19185 function Locate_Corresponding_Body (PE : Entity_Id) return Node_Id is 19186 Spec : constant Node_Id := Declaration_Node (PE); 19187 Decl : constant Node_Id := Parent (Spec); 19188 Scop : constant Entity_Id := Scope (PE); 19189 PBody : Node_Id; 19190 19191 begin 19192 if Is_Library_Level_Entity (PE) then 19193 19194 -- If package is a library unit that requires a body, we have no 19195 -- choice but to go after that body because it might contain an 19196 -- optional body for the original generic package. 19197 19198 if Unit_Requires_Body (PE) then 19199 19200 -- Load the body. Note that we are a little careful here to use 19201 -- Spec to get the unit number, rather than PE or Decl, since 19202 -- in the case where the package is itself a library level 19203 -- instantiation, Spec will properly reference the generic 19204 -- template, which is what we really want. 19205 19206 return 19207 Load_Package_Body 19208 (Get_Body_Name (Unit_Name (Get_Source_Unit (Spec)))); 19209 19210 -- But if the package is a library unit that does NOT require 19211 -- a body, then no body is permitted, so we are sure that there 19212 -- is no body for the original generic package. 19213 19214 else 19215 return Empty; 19216 end if; 19217 19218 -- Otherwise look and see if we are embedded in a further package 19219 19220 elsif Is_Package_Or_Generic_Package (Scop) then 19221 19222 -- If so, get the body of the enclosing package, and look in 19223 -- its package body for the package body we are looking for. 19224 19225 PBody := Locate_Corresponding_Body (Scop); 19226 19227 if No (PBody) then 19228 return Empty; 19229 else 19230 return Find_Body_In (PE, First (Declarations (PBody))); 19231 end if; 19232 19233 -- If we are not embedded in a further package, then the body 19234 -- must be in the same declarative part as we are. 19235 19236 else 19237 return Find_Body_In (PE, Next (Decl)); 19238 end if; 19239 end Locate_Corresponding_Body; 19240 19241 -- Start of processing for Has_Generic_Body 19242 19243 begin 19244 if Present (Corresponding_Body (Decl)) then 19245 return True; 19246 19247 elsif Unit_Requires_Body (Ent) then 19248 return True; 19249 19250 -- Compilation units cannot have optional bodies 19251 19252 elsif Is_Compilation_Unit (Ent) then 19253 return False; 19254 19255 -- Otherwise look at what scope we are in 19256 19257 else 19258 Scop := Scope (Ent); 19259 19260 -- Case of entity is in other than a package spec, in this case 19261 -- the body, if present, must be in the same declarative part. 19262 19263 if not Is_Package_Or_Generic_Package (Scop) then 19264 declare 19265 P : Node_Id; 19266 19267 begin 19268 -- Declaration node may get us a spec, so if so, go to 19269 -- the parent declaration. 19270 19271 P := Declaration_Node (Ent); 19272 while not Is_List_Member (P) loop 19273 P := Parent (P); 19274 end loop; 19275 19276 return Present (Find_Body_In (Ent, Next (P))); 19277 end; 19278 19279 -- If the entity is in a package spec, then we have to locate 19280 -- the corresponding package body, and look there. 19281 19282 else 19283 declare 19284 PBody : constant Node_Id := Locate_Corresponding_Body (Scop); 19285 19286 begin 19287 if No (PBody) then 19288 return False; 19289 else 19290 return 19291 Present 19292 (Find_Body_In (Ent, (First (Declarations (PBody))))); 19293 end if; 19294 end; 19295 end if; 19296 end if; 19297 end Has_Generic_Body; 19298 19299 ----------------------- 19300 -- Insert_Elab_Check -- 19301 ----------------------- 19302 19303 procedure Insert_Elab_Check (N : Node_Id; C : Node_Id := Empty) is 19304 Nod : Node_Id; 19305 Loc : constant Source_Ptr := Sloc (N); 19306 19307 Chk : Node_Id; 19308 -- The check (N_Raise_Program_Error) node to be inserted 19309 19310 begin 19311 -- If expansion is disabled, do not generate any checks. Also 19312 -- skip checks if any subunits are missing because in either 19313 -- case we lack the full information that we need, and no object 19314 -- file will be created in any case. 19315 19316 if not Expander_Active or else Subunits_Missing then 19317 return; 19318 end if; 19319 19320 -- If we have a generic instantiation, where Instance_Spec is set, 19321 -- then this field points to a generic instance spec that has 19322 -- been inserted before the instantiation node itself, so that 19323 -- is where we want to insert a check. 19324 19325 if Nkind (N) in N_Generic_Instantiation 19326 and then Present (Instance_Spec (N)) 19327 then 19328 Nod := Instance_Spec (N); 19329 else 19330 Nod := N; 19331 end if; 19332 19333 -- Build check node, possibly with condition 19334 19335 Chk := 19336 Make_Raise_Program_Error (Loc, Reason => PE_Access_Before_Elaboration); 19337 19338 if Present (C) then 19339 Set_Condition (Chk, Make_Op_Not (Loc, Right_Opnd => C)); 19340 end if; 19341 19342 -- If we are inserting at the top level, insert in Aux_Decls 19343 19344 if Nkind (Parent (Nod)) = N_Compilation_Unit then 19345 declare 19346 ADN : constant Node_Id := Aux_Decls_Node (Parent (Nod)); 19347 19348 begin 19349 if No (Declarations (ADN)) then 19350 Set_Declarations (ADN, New_List (Chk)); 19351 else 19352 Append_To (Declarations (ADN), Chk); 19353 end if; 19354 19355 Analyze (Chk); 19356 end; 19357 19358 -- Otherwise just insert as an action on the node in question 19359 19360 else 19361 Insert_Action (Nod, Chk); 19362 end if; 19363 end Insert_Elab_Check; 19364 19365 ------------------------------- 19366 -- Is_Call_Of_Generic_Formal -- 19367 ------------------------------- 19368 19369 function Is_Call_Of_Generic_Formal (N : Node_Id) return Boolean is 19370 begin 19371 return Nkind (N) in N_Subprogram_Call 19372 19373 -- Always return False if debug flag -gnatd.G is set 19374 19375 and then not Debug_Flag_Dot_GG 19376 19377 -- For now, we detect this by looking for the strange identifier 19378 -- node, whose Chars reflect the name of the generic formal, but 19379 -- the Chars of the Entity references the generic actual. 19380 19381 and then Nkind (Name (N)) = N_Identifier 19382 and then Chars (Name (N)) /= Chars (Entity (Name (N))); 19383 end Is_Call_Of_Generic_Formal; 19384 19385 ------------------------------- 19386 -- Is_Finalization_Procedure -- 19387 ------------------------------- 19388 19389 function Is_Finalization_Procedure (Id : Entity_Id) return Boolean is 19390 begin 19391 -- Check whether Id is a procedure with at least one parameter 19392 19393 if Ekind (Id) = E_Procedure and then Present (First_Formal (Id)) then 19394 declare 19395 Typ : constant Entity_Id := Etype (First_Formal (Id)); 19396 Deep_Fin : Entity_Id := Empty; 19397 Fin : Entity_Id := Empty; 19398 19399 begin 19400 -- If the type of the first formal does not require finalization 19401 -- actions, then this is definitely not [Deep_]Finalize. 19402 19403 if not Needs_Finalization (Typ) then 19404 return False; 19405 end if; 19406 19407 -- At this point we have the following scenario: 19408 19409 -- procedure Name (Param1 : [in] [out] Ctrl[; Param2 : ...]); 19410 19411 -- Recover the two possible versions of [Deep_]Finalize using the 19412 -- type of the first parameter and compare with the input. 19413 19414 Deep_Fin := TSS (Typ, TSS_Deep_Finalize); 19415 19416 if Is_Controlled (Typ) then 19417 Fin := Find_Prim_Op (Typ, Name_Finalize); 19418 end if; 19419 19420 return (Present (Deep_Fin) and then Id = Deep_Fin) 19421 or else (Present (Fin) and then Id = Fin); 19422 end; 19423 end if; 19424 19425 return False; 19426 end Is_Finalization_Procedure; 19427 19428 ------------------ 19429 -- Output_Calls -- 19430 ------------------ 19431 19432 procedure Output_Calls 19433 (N : Node_Id; 19434 Check_Elab_Flag : Boolean) 19435 is 19436 function Emit (Flag : Boolean) return Boolean; 19437 -- Determine whether to emit an error message based on the combination 19438 -- of flags Check_Elab_Flag and Flag. 19439 19440 function Is_Printable_Error_Name return Boolean; 19441 -- An internal function, used to determine if a name, stored in the 19442 -- Name_Buffer, is either a non-internal name, or is an internal name 19443 -- that is printable by the error message circuits (i.e. it has a single 19444 -- upper case letter at the end). 19445 19446 ---------- 19447 -- Emit -- 19448 ---------- 19449 19450 function Emit (Flag : Boolean) return Boolean is 19451 begin 19452 if Check_Elab_Flag then 19453 return Flag; 19454 else 19455 return True; 19456 end if; 19457 end Emit; 19458 19459 ----------------------------- 19460 -- Is_Printable_Error_Name -- 19461 ----------------------------- 19462 19463 function Is_Printable_Error_Name return Boolean is 19464 begin 19465 if not Is_Internal_Name then 19466 return True; 19467 19468 elsif Name_Len = 1 then 19469 return False; 19470 19471 else 19472 Name_Len := Name_Len - 1; 19473 return not Is_Internal_Name; 19474 end if; 19475 end Is_Printable_Error_Name; 19476 19477 -- Local variables 19478 19479 Ent : Entity_Id; 19480 19481 -- Start of processing for Output_Calls 19482 19483 begin 19484 for J in reverse 1 .. Elab_Call.Last loop 19485 Error_Msg_Sloc := Elab_Call.Table (J).Cloc; 19486 19487 Ent := Elab_Call.Table (J).Ent; 19488 Get_Name_String (Chars (Ent)); 19489 19490 -- Dynamic elaboration model, warnings controlled by -gnatwl 19491 19492 if Dynamic_Elaboration_Checks then 19493 if Emit (Elab_Warnings) then 19494 if Is_Generic_Unit (Ent) then 19495 Error_Msg_NE ("\\?l?& instantiated #", N, Ent); 19496 elsif Is_Init_Proc (Ent) then 19497 Error_Msg_N ("\\?l?initialization procedure called #", N); 19498 elsif Is_Printable_Error_Name then 19499 Error_Msg_NE ("\\?l?& called #", N, Ent); 19500 else 19501 Error_Msg_N ("\\?l?called #", N); 19502 end if; 19503 end if; 19504 19505 -- Static elaboration model, info messages controlled by -gnatel 19506 19507 else 19508 if Emit (Elab_Info_Messages) then 19509 if Is_Generic_Unit (Ent) then 19510 Error_Msg_NE ("\\?$?& instantiated #", N, Ent); 19511 elsif Is_Init_Proc (Ent) then 19512 Error_Msg_N ("\\?$?initialization procedure called #", N); 19513 elsif Is_Printable_Error_Name then 19514 Error_Msg_NE ("\\?$?& called #", N, Ent); 19515 else 19516 Error_Msg_N ("\\?$?called #", N); 19517 end if; 19518 end if; 19519 end if; 19520 end loop; 19521 end Output_Calls; 19522 19523 ---------------------------- 19524 -- Same_Elaboration_Scope -- 19525 ---------------------------- 19526 19527 function Same_Elaboration_Scope (Scop1, Scop2 : Entity_Id) return Boolean is 19528 S1 : Entity_Id; 19529 S2 : Entity_Id; 19530 19531 begin 19532 -- Find elaboration scope for Scop1 19533 -- This is either a subprogram or a compilation unit. 19534 19535 S1 := Scop1; 19536 while S1 /= Standard_Standard 19537 and then not Is_Compilation_Unit (S1) 19538 and then Ekind (S1) in E_Package | E_Protected_Type | E_Block 19539 loop 19540 S1 := Scope (S1); 19541 end loop; 19542 19543 -- Find elaboration scope for Scop2 19544 19545 S2 := Scop2; 19546 while S2 /= Standard_Standard 19547 and then not Is_Compilation_Unit (S2) 19548 and then Ekind (S2) in E_Package | E_Protected_Type | E_Block 19549 loop 19550 S2 := Scope (S2); 19551 end loop; 19552 19553 return S1 = S2; 19554 end Same_Elaboration_Scope; 19555 19556 ----------------- 19557 -- Set_C_Scope -- 19558 ----------------- 19559 19560 procedure Set_C_Scope is 19561 begin 19562 while not Is_Compilation_Unit (C_Scope) loop 19563 C_Scope := Scope (C_Scope); 19564 end loop; 19565 end Set_C_Scope; 19566 19567 -------------------------------- 19568 -- Set_Elaboration_Constraint -- 19569 -------------------------------- 19570 19571 procedure Set_Elaboration_Constraint 19572 (Call : Node_Id; 19573 Subp : Entity_Id; 19574 Scop : Entity_Id) 19575 is 19576 Elab_Unit : Entity_Id; 19577 19578 -- Check whether this is a call to an Initialize subprogram for a 19579 -- controlled type. Note that Call can also be a 'Access attribute 19580 -- reference, which now generates an elaboration check. 19581 19582 Init_Call : constant Boolean := 19583 Nkind (Call) = N_Procedure_Call_Statement 19584 and then Chars (Subp) = Name_Initialize 19585 and then Comes_From_Source (Subp) 19586 and then Present (Parameter_Associations (Call)) 19587 and then Is_Controlled (Etype (First_Actual (Call))); 19588 19589 begin 19590 -- If the unit is mentioned in a with_clause of the current unit, it is 19591 -- visible, and we can set the elaboration flag. 19592 19593 if Is_Immediately_Visible (Scop) 19594 or else (Is_Child_Unit (Scop) and then Is_Visible_Lib_Unit (Scop)) 19595 then 19596 Activate_Elaborate_All_Desirable (Call, Scop); 19597 Set_Suppress_Elaboration_Warnings (Scop); 19598 return; 19599 end if; 19600 19601 -- If this is not an initialization call or a call using object notation 19602 -- we know that the unit of the called entity is in the context, and we 19603 -- can set the flag as well. The unit need not be visible if the call 19604 -- occurs within an instantiation. 19605 19606 if Is_Init_Proc (Subp) 19607 or else Init_Call 19608 or else Nkind (Original_Node (Call)) = N_Selected_Component 19609 then 19610 null; -- detailed processing follows. 19611 19612 else 19613 Activate_Elaborate_All_Desirable (Call, Scop); 19614 Set_Suppress_Elaboration_Warnings (Scop); 19615 return; 19616 end if; 19617 19618 -- If the unit is not in the context, there must be an intermediate unit 19619 -- that is, on which we need to place to elaboration flag. This happens 19620 -- with init proc calls. 19621 19622 if Is_Init_Proc (Subp) or else Init_Call then 19623 19624 -- The initialization call is on an object whose type is not declared 19625 -- in the same scope as the subprogram. The type of the object must 19626 -- be a subtype of the type of operation. This object is the first 19627 -- actual in the call. 19628 19629 declare 19630 Typ : constant Entity_Id := 19631 Etype (First (Parameter_Associations (Call))); 19632 begin 19633 Elab_Unit := Scope (Typ); 19634 while (Present (Elab_Unit)) 19635 and then not Is_Compilation_Unit (Elab_Unit) 19636 loop 19637 Elab_Unit := Scope (Elab_Unit); 19638 end loop; 19639 end; 19640 19641 -- If original node uses selected component notation, the prefix is 19642 -- visible and determines the scope that must be elaborated. After 19643 -- rewriting, the prefix is the first actual in the call. 19644 19645 elsif Nkind (Original_Node (Call)) = N_Selected_Component then 19646 Elab_Unit := Scope (Etype (First (Parameter_Associations (Call)))); 19647 19648 -- Not one of special cases above 19649 19650 else 19651 -- Using previously computed scope. If the elaboration check is 19652 -- done after analysis, the scope is not visible any longer, but 19653 -- must still be in the context. 19654 19655 Elab_Unit := Scop; 19656 end if; 19657 19658 Activate_Elaborate_All_Desirable (Call, Elab_Unit); 19659 Set_Suppress_Elaboration_Warnings (Elab_Unit); 19660 end Set_Elaboration_Constraint; 19661 19662 ----------------- 19663 -- Spec_Entity -- 19664 ----------------- 19665 19666 function Spec_Entity (E : Entity_Id) return Entity_Id is 19667 Decl : Node_Id; 19668 19669 begin 19670 -- Check for case of body entity 19671 -- Why is the check for E_Void needed??? 19672 19673 if Ekind (E) in E_Void | E_Subprogram_Body | E_Package_Body then 19674 Decl := E; 19675 19676 loop 19677 Decl := Parent (Decl); 19678 exit when Nkind (Decl) in N_Proper_Body; 19679 end loop; 19680 19681 return Corresponding_Spec (Decl); 19682 19683 else 19684 return E; 19685 end if; 19686 end Spec_Entity; 19687 19688 ------------ 19689 -- Within -- 19690 ------------ 19691 19692 function Within (E1, E2 : Entity_Id) return Boolean is 19693 Scop : Entity_Id; 19694 begin 19695 Scop := E1; 19696 loop 19697 if Scop = E2 then 19698 return True; 19699 elsif Scop = Standard_Standard then 19700 return False; 19701 else 19702 Scop := Scope (Scop); 19703 end if; 19704 end loop; 19705 end Within; 19706 19707 -------------------------- 19708 -- Within_Elaborate_All -- 19709 -------------------------- 19710 19711 function Within_Elaborate_All 19712 (Unit : Unit_Number_Type; 19713 E : Entity_Id) return Boolean 19714 is 19715 type Unit_Number_Set is array (Main_Unit .. Last_Unit) of Boolean; 19716 pragma Pack (Unit_Number_Set); 19717 19718 Seen : Unit_Number_Set := (others => False); 19719 -- Seen (X) is True after we have seen unit X in the walk. This is used 19720 -- to prevent processing the same unit more than once. 19721 19722 Result : Boolean := False; 19723 19724 procedure Helper (Unit : Unit_Number_Type); 19725 -- This helper procedure does all the work for Within_Elaborate_All. It 19726 -- walks the dependency graph, and sets Result to True if it finds an 19727 -- appropriate Elaborate_All. 19728 19729 ------------ 19730 -- Helper -- 19731 ------------ 19732 19733 procedure Helper (Unit : Unit_Number_Type) is 19734 CU : constant Node_Id := Cunit (Unit); 19735 19736 Item : Node_Id; 19737 Item2 : Node_Id; 19738 Elab_Id : Entity_Id; 19739 Par : Node_Id; 19740 19741 begin 19742 if Seen (Unit) then 19743 return; 19744 else 19745 Seen (Unit) := True; 19746 end if; 19747 19748 -- First, check for Elaborate_Alls on this unit 19749 19750 Item := First (Context_Items (CU)); 19751 while Present (Item) loop 19752 if Nkind (Item) = N_Pragma 19753 and then Pragma_Name (Item) = Name_Elaborate_All 19754 then 19755 -- Return if some previous error on the pragma itself. The 19756 -- pragma may be unanalyzed, because of a previous error, or 19757 -- if it is the context of a subunit, inherited by its parent. 19758 19759 if Error_Posted (Item) or else not Analyzed (Item) then 19760 return; 19761 end if; 19762 19763 Elab_Id := 19764 Entity 19765 (Expression (First (Pragma_Argument_Associations (Item)))); 19766 19767 if E = Elab_Id then 19768 Result := True; 19769 return; 19770 end if; 19771 19772 Par := Parent (Unit_Declaration_Node (Elab_Id)); 19773 19774 Item2 := First (Context_Items (Par)); 19775 while Present (Item2) loop 19776 if Nkind (Item2) = N_With_Clause 19777 and then Entity (Name (Item2)) = E 19778 and then not Limited_Present (Item2) 19779 then 19780 Result := True; 19781 return; 19782 end if; 19783 19784 Next (Item2); 19785 end loop; 19786 end if; 19787 19788 Next (Item); 19789 end loop; 19790 19791 -- Second, recurse on with's. We could do this as part of the above 19792 -- loop, but it's probably more efficient to have two loops, because 19793 -- the relevant Elaborate_All is likely to be on the initial unit. In 19794 -- other words, we're walking the with's breadth-first. This part is 19795 -- only necessary in the dynamic elaboration model. 19796 19797 if Dynamic_Elaboration_Checks then 19798 Item := First (Context_Items (CU)); 19799 while Present (Item) loop 19800 if Nkind (Item) = N_With_Clause 19801 and then not Limited_Present (Item) 19802 then 19803 -- Note: the following call to Get_Cunit_Unit_Number does a 19804 -- linear search, which could be slow, but it's OK because 19805 -- we're about to give a warning anyway. Also, there might 19806 -- be hundreds of units, but not millions. If it turns out 19807 -- to be a problem, we could store the Get_Cunit_Unit_Number 19808 -- in each N_Compilation_Unit node, but that would involve 19809 -- rearranging N_Compilation_Unit_Aux to make room. 19810 19811 Helper (Get_Cunit_Unit_Number (Library_Unit (Item))); 19812 19813 if Result then 19814 return; 19815 end if; 19816 end if; 19817 19818 Next (Item); 19819 end loop; 19820 end if; 19821 end Helper; 19822 19823 -- Start of processing for Within_Elaborate_All 19824 19825 begin 19826 Helper (Unit); 19827 return Result; 19828 end Within_Elaborate_All; 19829 19830end Sem_Elab; 19831