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-2021, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with ALI; use ALI; 27with Atree; use Atree; 28with Checks; use Checks; 29with Debug; use Debug; 30with Einfo; use Einfo; 31with Einfo.Entities; use Einfo.Entities; 32with Einfo.Utils; use Einfo.Utils; 33with Elists; use Elists; 34with Errout; use Errout; 35with Exp_Ch11; use Exp_Ch11; 36with Exp_Tss; use Exp_Tss; 37with Exp_Util; use Exp_Util; 38with Expander; use Expander; 39with Lib; use Lib; 40with Lib.Load; use Lib.Load; 41with Namet; use Namet; 42with Nlists; use Nlists; 43with Nmake; use Nmake; 44with Opt; use Opt; 45with Output; use Output; 46with Restrict; use Restrict; 47with Rident; use Rident; 48with Rtsfind; use Rtsfind; 49with Sem; use Sem; 50with Sem_Aux; use Sem_Aux; 51with Sem_Cat; use Sem_Cat; 52with Sem_Ch7; use Sem_Ch7; 53with Sem_Ch8; use Sem_Ch8; 54with Sem_Disp; use Sem_Disp; 55with Sem_Prag; use Sem_Prag; 56with Sem_Util; use Sem_Util; 57with Sinfo; use Sinfo; 58with Sinfo.Nodes; use Sinfo.Nodes; 59with Sinfo.Utils; use Sinfo.Utils; 60with Sinput; use Sinput; 61with Snames; use Snames; 62with Stand; use Stand; 63with Table; 64with Tbuild; use Tbuild; 65with Uintp; use Uintp; 66with Uname; use Uname; 67 68with GNAT; use GNAT; 69with GNAT.Dynamic_HTables; use GNAT.Dynamic_HTables; 70with GNAT.Lists; use GNAT.Lists; 71with GNAT.Sets; use GNAT.Sets; 72 73package body Sem_Elab is 74 75 ----------------------------------------- 76 -- Access-before-elaboration mechanism -- 77 ----------------------------------------- 78 79 -- The access-before-elaboration (ABE) mechanism implemented in this unit 80 -- has the following objectives: 81 -- 82 -- * Diagnose at compile time or install run-time checks to prevent ABE 83 -- access to data and behavior. 84 -- 85 -- The high-level idea is to accurately diagnose ABE issues within a 86 -- single unit because the ABE mechanism can inspect the whole unit. 87 -- As soon as the elaboration graph extends to an external unit, the 88 -- diagnostics stop because the body of the unit may not be available. 89 -- Due to control and data flow, the ABE mechanism cannot accurately 90 -- determine whether a particular scenario will be elaborated or not. 91 -- Conditional ABE checks are therefore used to verify the elaboration 92 -- status of local and external targets at run time. 93 -- 94 -- * Supply implicit elaboration dependencies for a unit to binde 95 -- 96 -- The ABE mechanism creates implicit dependencies in the form of with 97 -- clauses subject to pragma Elaborate[_All] when the elaboration graph 98 -- reaches into an external unit. The implicit dependencies are encoded 99 -- in the ALI file of the main unit. GNATbind and binde then use these 100 -- dependencies to augment the library item graph and determine the 101 -- elaboration order of all units in the compilation. 102 -- 103 -- * Supply pieces of the invocation graph for a unit to bindo 104 -- 105 -- The ABE mechanism captures paths starting from elaboration code or 106 -- top level constructs that reach into an external unit. The paths are 107 -- encoded in the ALI file of the main unit in the form of declarations 108 -- which represent nodes, and relations which represent edges. GNATbind 109 -- and bindo then build the full invocation graph in order to augment 110 -- the library item graph and determine the elaboration order of all 111 -- units in the compilation. 112 -- 113 -- The ABE mechanism supports three models of elaboration: 114 -- 115 -- * Dynamic model - This is the most permissive of the three models. 116 -- When the dynamic model is in effect, the mechanism diagnoses and 117 -- installs run-time checks to detect ABE issues in the main unit. 118 -- The behavior of this model is identical to that specified by the 119 -- Ada RM. This model is enabled with switch -gnatE. 120 -- 121 -- Static model - This is the middle ground of the three models. When 122 -- the static model is in effect, the mechanism diagnoses and installs 123 -- run-time checks to detect ABE issues in the main unit. In addition, 124 -- the mechanism generates implicit dependencies between units in the 125 -- form of with clauses subject to pragma Elaborate[_All] to ensure 126 -- the prior elaboration of withed units. This is the default model. 127 -- 128 -- * SPARK model - This is the most conservative of the three models and 129 -- implements the semantics defined in SPARK RM 7.7. The SPARK model 130 -- is in effect only when a context resides in a SPARK_Mode On region, 131 -- otherwise the mechanism falls back to one of the previous models. 132 -- 133 -- The ABE mechanism consists of a "recording" phase and a "processing" 134 -- phase. 135 136 ----------------- 137 -- Terminology -- 138 ----------------- 139 140 -- * ABE - An attempt to invoke a scenario which has not been elaborated 141 -- yet. 142 -- 143 -- * Bridge target - A type of target. A bridge target is a link between 144 -- scenarios. It is usually a byproduct of expansion and does not have 145 -- any direct ABE ramifications. 146 -- 147 -- * Call marker - A special node used to indicate the presence of a call 148 -- in the tree in case expansion transforms or eliminates the original 149 -- call. N_Call_Marker nodes do not have static and run-time semantics. 150 -- 151 -- * Conditional ABE - A type of ABE. A conditional ABE occurs when the 152 -- invocation of a target by a scenario within the main unit causes an 153 -- ABE, but does not cause an ABE for another scenarios within the main 154 -- unit. 155 -- 156 -- * Declaration level - A type of enclosing level. A scenario or target is 157 -- at the declaration level when it appears within the declarations of a 158 -- block statement, entry body, subprogram body, or task body, ignoring 159 -- enclosing packages. 160 -- 161 -- * Early call region - A section of code which ends at a subprogram body 162 -- and starts from the nearest non-preelaborable construct which precedes 163 -- the subprogram body. The early call region extends from a package body 164 -- to a package spec when the spec carries pragma Elaborate_Body. 165 -- 166 -- * Generic library level - A type of enclosing level. A scenario or 167 -- target is at the generic library level if it appears in a generic 168 -- package library unit, ignoring enclosing packages. 169 -- 170 -- * Guaranteed ABE - A type of ABE. A guaranteed ABE occurs when the 171 -- invocation of a target by all scenarios within the main unit causes 172 -- an ABE. 173 -- 174 -- * Instantiation library level - A type of enclosing level. A scenario 175 -- or target is at the instantiation library level if it appears in an 176 -- instantiation library unit, ignoring enclosing packages. 177 -- 178 -- * Invocation - The act of activating a task, calling a subprogram, or 179 -- instantiating a generic. 180 -- 181 -- * Invocation construct - An entry declaration, [single] protected type, 182 -- subprogram declaration, subprogram instantiation, or a [single] task 183 -- type declared in the visible, private, or body declarations of the 184 -- main unit. 185 -- 186 -- * Invocation relation - A flow link between two invocation constructs 187 -- 188 -- * Invocation signature - A set of attributes that uniquely identify an 189 -- invocation construct within the namespace of all ALI files. 190 -- 191 -- * Library level - A type of enclosing level. A scenario or target is at 192 -- the library level if it appears in a package library unit, ignoring 193 -- enclosing packages. 194 -- 195 -- * Non-library-level encapsulator - A construct that cannot be elaborated 196 -- on its own and requires elaboration by a top-level scenario. 197 -- 198 -- * Scenario - A construct or context which is invoked by elaboration code 199 -- or invocation construct. The scenarios recognized by the ABE mechanism 200 -- are as follows: 201 -- 202 -- - '[Unrestricted_]Access of entries, operators, and subprograms 203 -- 204 -- - Assignments to variables 205 -- 206 -- - Calls to entries, operators, and subprograms 207 -- 208 -- - Derived type declarations 209 -- 210 -- - Instantiations 211 -- 212 -- - Pragma Refined_State 213 -- 214 -- - Reads of variables 215 -- 216 -- - Task activation 217 -- 218 -- * Target - A construct invoked by a scenario. The targets recognized by 219 -- the ABE mechanism are as follows: 220 -- 221 -- - For '[Unrestricted_]Access of entries, operators, and subprograms, 222 -- the target is the entry, operator, or subprogram. 223 -- 224 -- - For assignments to variables, the target is the variable 225 -- 226 -- - For calls, the target is the entry, operator, or subprogram 227 -- 228 -- - For derived type declarations, the target is the derived type 229 -- 230 -- - For instantiations, the target is the generic template 231 -- 232 -- - For pragma Refined_State, the targets are the constituents 233 -- 234 -- - For reads of variables, the target is the variable 235 -- 236 -- - For task activation, the target is the task body 237 238 ------------------ 239 -- Architecture -- 240 ------------------ 241 242 -- Analysis/Resolution 243 -- | 244 -- +- Build_Call_Marker 245 -- | 246 -- +- Build_Variable_Reference_Marker 247 -- | 248 -- +- | -------------------- Recording phase ---------------------------+ 249 -- | v | 250 -- | Record_Elaboration_Scenario | 251 -- | | | 252 -- | +--> Check_Preelaborated_Call | 253 -- | | | 254 -- | +--> Process_Guaranteed_ABE | 255 -- | | | | 256 -- | | +--> Process_Guaranteed_ABE_Activation | 257 -- | | +--> Process_Guaranteed_ABE_Call | 258 -- | | +--> Process_Guaranteed_ABE_Instantiation | 259 -- | | | 260 -- +- | ----------------------------------------------------------------+ 261 -- | 262 -- | 263 -- +--> Internal_Representation 264 -- | 265 -- +--> Scenario_Storage 266 -- | 267 -- End of Compilation 268 -- | 269 -- +- | --------------------- Processing phase -------------------------+ 270 -- | v | 271 -- | Check_Elaboration_Scenarios | 272 -- | | | 273 -- | +--> Check_Conditional_ABE_Scenarios | 274 -- | | | | 275 -- | | +--> Process_Conditional_ABE <----------------------+ | 276 -- | | | | | 277 -- | | +--> Process_Conditional_ABE_Activation | | 278 -- | | | | | | 279 -- | | | +-----------------------------+ | | 280 -- | | | | | | 281 -- | | +--> Process_Conditional_ABE_Call +---> Traverse_Body | 282 -- | | | | | | 283 -- | | | +-----------------------------+ | 284 -- | | | | 285 -- | | +--> Process_Conditional_ABE_Access_Taken | 286 -- | | +--> Process_Conditional_ABE_Instantiation | 287 -- | | +--> Process_Conditional_ABE_Variable_Assignment | 288 -- | | +--> Process_Conditional_ABE_Variable_Reference | 289 -- | | | 290 -- | +--> Check_SPARK_Scenario | 291 -- | | | | 292 -- | | +--> Process_SPARK_Scenario | 293 -- | | | | 294 -- | | +--> Process_SPARK_Derived_Type | 295 -- | | +--> Process_SPARK_Instantiation | 296 -- | | +--> Process_SPARK_Refined_State_Pragma | 297 -- | | | 298 -- | +--> Record_Invocation_Graph | 299 -- | | | 300 -- | +--> Process_Invocation_Body_Scenarios | 301 -- | +--> Process_Invocation_Spec_Scenarios | 302 -- | +--> Process_Main_Unit | 303 -- | | | 304 -- | +--> Process_Invocation_Scenario <-------------+ | 305 -- | | | | 306 -- | +--> Process_Invocation_Activation | | 307 -- | | | | | 308 -- | | +------------------------+ | | 309 -- | | | | | 310 -- | +--> Process_Invocation_Call +---> Traverse_Body | 311 -- | | | | 312 -- | +------------------------+ | 313 -- | | 314 -- +--------------------------------------------------------------------+ 315 316 --------------------- 317 -- Recording phase -- 318 --------------------- 319 320 -- The Recording phase coincides with the analysis/resolution phase of the 321 -- compiler. It has the following objectives: 322 -- 323 -- * Record all suitable scenarios for examination by the Processing 324 -- phase. 325 -- 326 -- Saving only a certain number of nodes improves the performance of 327 -- the ABE mechanism. This eliminates the need to examine the whole 328 -- tree in a separate pass. 329 -- 330 -- * Record certain SPARK scenarios which are not necessarily invoked 331 -- during elaboration, but still require elaboration-related checks. 332 -- 333 -- Saving only a certain number of nodes improves the performance of 334 -- the ABE mechanism. This eliminates the need to examine the whole 335 -- tree in a separate pass. 336 -- 337 -- * Detect and diagnose calls in preelaborable or pure units, including 338 -- generic bodies. 339 -- 340 -- This diagnostic is carried out during the Recording phase because it 341 -- does not need the heavy recursive traversal done by the Processing 342 -- phase. 343 -- 344 -- * Detect and diagnose guaranteed ABEs caused by instantiations, calls, 345 -- and task activation. 346 -- 347 -- The issues detected by the ABE mechanism are reported as warnings 348 -- because they do not violate Ada semantics. Forward instantiations 349 -- may thus reach gigi, however gigi cannot handle certain kinds of 350 -- premature instantiations and may crash. To avoid this limitation, 351 -- the ABE mechanism must identify forward instantiations as early as 352 -- possible and suppress their bodies. Calls and task activations are 353 -- included in this category for completeness. 354 355 ---------------------- 356 -- Processing phase -- 357 ---------------------- 358 359 -- The Processing phase is a separate pass which starts after instantiating 360 -- and/or inlining of bodies, but before the removal of Ghost code. It has 361 -- the following objectives: 362 -- 363 -- * Examine all scenarios saved during the Recording phase, and perform 364 -- the following actions: 365 -- 366 -- - Dynamic model 367 -- 368 -- Diagnose conditional ABEs, and install run-time conditional ABE 369 -- checks for all scenarios. 370 -- 371 -- - SPARK model 372 -- 373 -- Enforce the SPARK elaboration rules 374 -- 375 -- - Static model 376 -- 377 -- Diagnose conditional ABEs, install run-time conditional ABE 378 -- checks only for scenarios are reachable from elaboration code, 379 -- and guarantee the elaboration of external units by creating 380 -- implicit with clauses subject to pragma Elaborate[_All]. 381 -- 382 -- * Examine library-level scenarios and invocation constructs, and 383 -- perform the following actions: 384 -- 385 -- - Determine whether the flow of execution reaches into an external 386 -- unit. If this is the case, encode the path in the ALI file of 387 -- the main unit. 388 -- 389 -- - Create declarations for invocation constructs in the ALI file of 390 -- the main unit. 391 392 ---------------------- 393 -- Important points -- 394 ---------------------- 395 396 -- The Processing phase starts after the analysis, resolution, expansion 397 -- phase has completed. As a result, no current semantic information is 398 -- available. The scope stack is empty, global flags such as In_Instance 399 -- or Inside_A_Generic become useless. To remedy this, the ABE mechanism 400 -- must either save or recompute semantic information. 401 -- 402 -- Expansion heavily transforms calls and to some extent instantiations. To 403 -- remedy this, the ABE mechanism generates N_Call_Marker nodes in order to 404 -- capture the target and relevant attributes of the original call. 405 -- 406 -- The diagnostics of the ABE mechanism depend on accurate source locations 407 -- to determine the spatial relation of nodes. 408 409 ----------------------------------------- 410 -- Suppression of elaboration warnings -- 411 ----------------------------------------- 412 413 -- Elaboration warnings along multiple traversal paths rooted at a scenario 414 -- are suppressed when the scenario has elaboration warnings suppressed. 415 -- 416 -- Root scenario 417 -- | 418 -- +-- Child scenario 1 419 -- | | 420 -- | +-- Grandchild scenario 1 421 -- | | 422 -- | +-- Grandchild scenario N 423 -- | 424 -- +-- Child scenario N 425 -- 426 -- If the root scenario has elaboration warnings suppressed, then all its 427 -- child, grandchild, etc. scenarios will have their elaboration warnings 428 -- suppressed. 429 -- 430 -- In addition to switch -gnatwL, pragma Warnings may be used to suppress 431 -- elaboration-related warnings when used in the following manner: 432 -- 433 -- pragma Warnings ("L"); 434 -- <scenario-or-target> 435 -- 436 -- <target> 437 -- pragma Warnings (Off, target); 438 -- 439 -- pragma Warnings (Off); 440 -- <scenario-or-target> 441 -- 442 -- * To suppress elaboration warnings for '[Unrestricted_]Access of 443 -- entries, operators, and subprograms, either: 444 -- 445 -- - Suppress the entry, operator, or subprogram, or 446 -- - Suppress the attribute, or 447 -- - Use switch -gnatw.f 448 -- 449 -- * To suppress elaboration warnings for calls to entries, operators, 450 -- and subprograms, either: 451 -- 452 -- - Suppress the entry, operator, or subprogram, or 453 -- - Suppress the call 454 -- 455 -- * To suppress elaboration warnings for instantiations, suppress the 456 -- instantiation. 457 -- 458 -- * To suppress elaboration warnings for task activations, either: 459 -- 460 -- - Suppress the task object, or 461 -- - Suppress the task type, or 462 -- - Suppress the activation call 463 464 -------------- 465 -- Switches -- 466 -------------- 467 468 -- The following switches may be used to control the behavior of the ABE 469 -- mechanism. 470 -- 471 -- -gnatd_a stop elaboration checks on accept or select statement 472 -- 473 -- The ABE mechanism stops the traversal of a task body when it 474 -- encounters an accept or a select statement. This behavior is 475 -- equivalent to restriction No_Entry_Calls_In_Elaboration_Code, 476 -- but without penalizing actual entry calls during elaboration. 477 -- 478 -- -gnatd_e ignore entry calls and requeue statements for elaboration 479 -- 480 -- The ABE mechanism does not generate N_Call_Marker nodes for 481 -- protected or task entry calls as well as requeue statements. 482 -- As a result, the calls and requeues are not recorded or 483 -- processed. 484 -- 485 -- -gnatdE elaboration checks on predefined units 486 -- 487 -- The ABE mechanism considers scenarios which appear in internal 488 -- units (Ada, GNAT, Interfaces, System). 489 -- 490 -- -gnatd_F encode full invocation paths in ALI files 491 -- 492 -- The ABE mechanism encodes the full path from an elaboration 493 -- procedure or invocable construct to an external target. The 494 -- path contains all intermediate activations, instantiations, 495 -- and calls. 496 -- 497 -- -gnatd.G ignore calls through generic formal parameters for elaboration 498 -- 499 -- The ABE mechanism does not generate N_Call_Marker nodes for 500 -- calls which occur in expanded instances, and invoke generic 501 -- actual subprograms through generic formal subprograms. As a 502 -- result, the calls are not recorded or processed. 503 -- 504 -- -gnatd_i ignore activations and calls to instances for elaboration 505 -- 506 -- The ABE mechanism ignores calls and task activations when they 507 -- target a subprogram or task type defined an external instance. 508 -- As a result, the calls and task activations are not processed. 509 -- 510 -- -gnatdL ignore external calls from instances for elaboration 511 -- 512 -- The ABE mechanism does not generate N_Call_Marker nodes for 513 -- calls which occur in expanded instances, do not invoke generic 514 -- actual subprograms through formal subprograms, and the target 515 -- is external to the instance. As a result, the calls are not 516 -- recorded or processed. 517 -- 518 -- -gnatd.o conservative elaboration order for indirect calls 519 -- 520 -- The ABE mechanism treats '[Unrestricted_]Access of an entry, 521 -- operator, or subprogram as an immediate invocation of the 522 -- target. As a result, it performs ABE checks and diagnostics on 523 -- the immediate call. 524 -- 525 -- -gnatd_p ignore assertion pragmas for elaboration 526 -- 527 -- The ABE mechanism does not generate N_Call_Marker nodes for 528 -- calls to subprograms which verify the run-time semantics of 529 -- the following assertion pragmas: 530 -- 531 -- Default_Initial_Condition 532 -- Initial_Condition 533 -- Invariant 534 -- Invariant'Class 535 -- Post 536 -- Post'Class 537 -- Postcondition 538 -- Type_Invariant 539 -- Type_Invariant_Class 540 -- 541 -- As a result, the assertion expressions of the pragmas are not 542 -- processed. 543 -- 544 -- -gnatd_s stop elaboration checks on synchronous suspension 545 -- 546 -- The ABE mechanism stops the traversal of a task body when it 547 -- encounters a call to one of the following routines: 548 -- 549 -- Ada.Synchronous_Barriers.Wait_For_Release 550 -- Ada.Synchronous_Task_Control.Suspend_Until_True 551 -- 552 -- -gnatd_T output trace information on invocation relation construction 553 -- 554 -- The ABE mechanism outputs text information concerning relation 555 -- construction to standard output. 556 -- 557 -- -gnatd.U ignore indirect calls for static elaboration 558 -- 559 -- The ABE mechanism does not consider '[Unrestricted_]Access of 560 -- entries, operators, and subprograms. As a result, the scenarios 561 -- are not recorder or processed. 562 -- 563 -- -gnatd.v enforce SPARK elaboration rules in SPARK code 564 -- 565 -- The ABE mechanism applies some of the SPARK elaboration rules 566 -- defined in the SPARK reference manual, chapter 7.7. Note that 567 -- certain rules are always enforced, regardless of whether the 568 -- switch is active. 569 -- 570 -- -gnatd.y disable implicit pragma Elaborate_All on task bodies 571 -- 572 -- The ABE mechanism does not generate implicit Elaborate_All when 573 -- the need for the pragma came from a task body. 574 -- 575 -- -gnatE dynamic elaboration checking mode enabled 576 -- 577 -- The ABE mechanism assumes that any scenario is elaborated or 578 -- invoked by elaboration code. The ABE mechanism performs very 579 -- little diagnostics and generates condintional ABE checks to 580 -- detect ABE issues at run-time. 581 -- 582 -- -gnatel turn on info messages on generated Elaborate[_All] pragmas 583 -- 584 -- The ABE mechanism produces information messages on generated 585 -- implicit Elabote[_All] pragmas along with traceback showing 586 -- why the pragma was generated. In addition, the ABE mechanism 587 -- produces information messages for each scenario elaborated or 588 -- invoked by elaboration code. 589 -- 590 -- -gnateL turn off info messages on generated Elaborate[_All] pragmas 591 -- 592 -- The complementary switch for -gnatel. 593 -- 594 -- -gnatH legacy elaboration checking mode enabled 595 -- 596 -- When this switch is in effect, the pre-18.x ABE model becomes 597 -- the de facto ABE model. This amounts to cutting off all entry 598 -- points into the new ABE mechanism, and giving full control to 599 -- the old ABE mechanism. 600 -- 601 -- -gnatJ permissive elaboration checking mode enabled 602 -- 603 -- This switch activates the following switches: 604 -- 605 -- -gnatd_a 606 -- -gnatd_e 607 -- -gnatd.G 608 -- -gnatd_i 609 -- -gnatdL 610 -- -gnatd_p 611 -- -gnatd_s 612 -- -gnatd.U 613 -- -gnatd.y 614 -- 615 -- IMPORTANT: The behavior of the ABE mechanism becomes more 616 -- permissive at the cost of accurate diagnostics and runtime 617 -- ABE checks. 618 -- 619 -- -gnatw.f turn on warnings for suspicious Subp'Access 620 -- 621 -- The ABE mechanism treats '[Unrestricted_]Access of an entry, 622 -- operator, or subprogram as a pseudo invocation of the target. 623 -- As a result, it performs ABE diagnostics on the pseudo call. 624 -- 625 -- -gnatw.F turn off warnings for suspicious Subp'Access 626 -- 627 -- The complementary switch for -gnatw.f. 628 -- 629 -- -gnatwl turn on warnings for elaboration problems 630 -- 631 -- The ABE mechanism produces warnings on detected ABEs along with 632 -- a traceback showing the graph of the ABE. 633 -- 634 -- -gnatwL turn off warnings for elaboration problems 635 -- 636 -- The complementary switch for -gnatwl. 637 638 -------------------------- 639 -- Debugging ABE issues -- 640 -------------------------- 641 642 -- * If the issue involves a call, ensure that the call is eligible for ABE 643 -- processing and receives a corresponding call marker. The routines of 644 -- interest are 645 -- 646 -- Build_Call_Marker 647 -- Record_Elaboration_Scenario 648 -- 649 -- * If the issue involves an arbitrary scenario, ensure that the scenario 650 -- is either recorded, or is successfully recognized while traversing a 651 -- body. The routines of interest are 652 -- 653 -- Record_Elaboration_Scenario 654 -- Process_Conditional_ABE 655 -- Process_Guaranteed_ABE 656 -- Traverse_Body 657 -- 658 -- * If the issue involves a circularity in the elaboration order, examine 659 -- the ALI files and look for the following encodings next to units: 660 -- 661 -- E indicates a source Elaborate 662 -- 663 -- EA indicates a source Elaborate_All 664 -- 665 -- AD indicates an implicit Elaborate_All 666 -- 667 -- ED indicates an implicit Elaborate 668 -- 669 -- If possible, compare these encodings with those generated by the old 670 -- ABE mechanism. The routines of interest are 671 -- 672 -- Ensure_Prior_Elaboration 673 674 ----------- 675 -- Kinds -- 676 ----------- 677 678 -- The following type enumerates all possible elaboration phase statutes 679 680 type Elaboration_Phase_Status is 681 (Inactive, 682 -- The elaboration phase of the compiler has not started yet 683 684 Active, 685 -- The elaboration phase of the compiler is currently in progress 686 687 Completed); 688 -- The elaboration phase of the compiler has finished 689 690 Elaboration_Phase : Elaboration_Phase_Status := Inactive; 691 -- The status of the elaboration phase. Use routine Set_Elaboration_Phase 692 -- to alter its value. 693 694 -- The following type enumerates all subprogram body traversal modes 695 696 type Body_Traversal_Kind is 697 (Deep_Traversal, 698 -- The traversal examines the internals of a subprogram 699 700 No_Traversal); 701 702 -- The following type enumerates all operation modes 703 704 type Processing_Kind is 705 (Conditional_ABE_Processing, 706 -- The ABE mechanism detects and diagnoses conditional ABEs for library 707 -- and declaration-level scenarios. 708 709 Dynamic_Model_Processing, 710 -- The ABE mechanism installs conditional ABE checks for all eligible 711 -- scenarios when the dynamic model is in effect. 712 713 Guaranteed_ABE_Processing, 714 -- The ABE mechanism detects and diagnoses guaranteed ABEs caused by 715 -- calls, instantiations, and task activations. 716 717 Invocation_Construct_Processing, 718 -- The ABE mechanism locates all invocation constructs within the main 719 -- unit and utilizes them as roots of miltiple DFS traversals aimed at 720 -- detecting transitions from the main unit to an external unit. 721 722 Invocation_Body_Processing, 723 -- The ABE mechanism utilizes all library-level body scenarios as roots 724 -- of miltiple DFS traversals aimed at detecting transitions from the 725 -- main unit to an external unit. 726 727 Invocation_Spec_Processing, 728 -- The ABE mechanism utilizes all library-level spec scenarios as roots 729 -- of miltiple DFS traversals aimed at detecting transitions from the 730 -- main unit to an external unit. 731 732 SPARK_Processing, 733 -- The ABE mechanism detects and diagnoses violations of the SPARK 734 -- elaboration rules for SPARK-specific scenarios. 735 736 No_Processing); 737 738 -- The following type enumerates all possible scenario kinds 739 740 type Scenario_Kind is 741 (Access_Taken_Scenario, 742 -- An attribute reference which takes 'Access or 'Unrestricted_Access of 743 -- an entry, operator, or subprogram. 744 745 Call_Scenario, 746 -- A call which invokes an entry, operator, or subprogram 747 748 Derived_Type_Scenario, 749 -- A declaration of a derived type. This is a SPARK-specific scenario. 750 751 Instantiation_Scenario, 752 -- An instantiation which instantiates a generic package or subprogram. 753 -- This scenario is also subject to SPARK-specific rules. 754 755 Refined_State_Pragma_Scenario, 756 -- A Refined_State pragma. This is a SPARK-specific scenario. 757 758 Task_Activation_Scenario, 759 -- A call which activates objects of various task types 760 761 Variable_Assignment_Scenario, 762 -- An assignment statement which modifies the value of some variable 763 764 Variable_Reference_Scenario, 765 -- A reference to a variable. This is a SPARK-specific scenario. 766 767 No_Scenario); 768 769 -- The following type enumerates all possible consistency models of target 770 -- and scenario representations. 771 772 type Representation_Kind is 773 (Inconsistent_Representation, 774 -- A representation is said to be "inconsistent" when it is created from 775 -- a partially analyzed tree. In such an environment, certain attributes 776 -- such as a completing body may not be available yet. 777 778 Consistent_Representation, 779 -- A representation is said to be "consistent" when it is created from a 780 -- fully analyzed tree, where all attributes are available. 781 782 No_Representation); 783 784 -- The following type enumerates all possible target kinds 785 786 type Target_Kind is 787 (Generic_Target, 788 -- A generic unit being instantiated 789 790 Package_Target, 791 -- The package form of an instantiation 792 793 Subprogram_Target, 794 -- An entry, operator, or subprogram being invoked, or aliased through 795 -- 'Access or 'Unrestricted_Access. 796 797 Task_Target, 798 -- A task being activated by an activation call 799 800 Variable_Target, 801 -- A variable being updated through an assignment statement, or read 802 -- through a variable reference. 803 804 No_Target); 805 806 ----------- 807 -- Types -- 808 ----------- 809 810 procedure Destroy (NE : in out Node_Or_Entity_Id); 811 pragma Inline (Destroy); 812 -- Destroy node or entity NE 813 814 function Hash (NE : Node_Or_Entity_Id) return Bucket_Range_Type; 815 pragma Inline (Hash); 816 -- Obtain the hash value of key NE 817 818 -- The following is a general purpose list for nodes and entities 819 820 package NE_List is new Doubly_Linked_Lists 821 (Element_Type => Node_Or_Entity_Id, 822 "=" => "=", 823 Destroy_Element => Destroy); 824 825 -- The following is a general purpose map which relates nodes and entities 826 -- to lists of nodes and entities. 827 828 package NE_List_Map is new Dynamic_Hash_Tables 829 (Key_Type => Node_Or_Entity_Id, 830 Value_Type => NE_List.Doubly_Linked_List, 831 No_Value => NE_List.Nil, 832 Expansion_Threshold => 1.5, 833 Expansion_Factor => 2, 834 Compression_Threshold => 0.3, 835 Compression_Factor => 2, 836 "=" => "=", 837 Destroy_Value => NE_List.Destroy, 838 Hash => Hash); 839 840 -- The following is a general purpose membership set for nodes and entities 841 842 package NE_Set is new Membership_Sets 843 (Element_Type => Node_Or_Entity_Id, 844 "=" => "=", 845 Hash => Hash); 846 847 -- The following type captures relevant attributes which pertain to the 848 -- in state of the Processing phase. 849 850 type Processing_In_State is record 851 Processing : Processing_Kind := No_Processing; 852 -- Operation mode of the Processing phase. Once set, this value should 853 -- not be changed. 854 855 Representation : Representation_Kind := No_Representation; 856 -- Required level of scenario and target representation. Once set, this 857 -- value should not be changed. 858 859 Suppress_Checks : Boolean := False; 860 -- This flag is set when the Processing phase must not generate any ABE 861 -- checks. 862 863 Suppress_Implicit_Pragmas : Boolean := False; 864 -- This flag is set when the Processing phase must not generate any 865 -- implicit Elaborate[_All] pragmas. 866 867 Suppress_Info_Messages : Boolean := False; 868 -- This flag is set when the Processing phase must not emit any info 869 -- messages. 870 871 Suppress_Up_Level_Targets : Boolean := False; 872 -- This flag is set when the Processing phase must ignore up-level 873 -- targets. 874 875 Suppress_Warnings : Boolean := False; 876 -- This flag is set when the Processing phase must not emit any warnings 877 -- on elaboration problems. 878 879 Traversal : Body_Traversal_Kind := No_Traversal; 880 -- The subprogram body traversal mode. Once set, this value should not 881 -- be changed. 882 883 Within_Generic : Boolean := False; 884 -- This flag is set when the Processing phase is currently within a 885 -- generic unit. 886 887 Within_Initial_Condition : Boolean := False; 888 -- This flag is set when the Processing phase is currently examining a 889 -- scenario which was reached from an initial condition procedure. 890 891 Within_Partial_Finalization : Boolean := False; 892 -- This flag is set when the Processing phase is currently examining a 893 -- scenario which was reached from a partial finalization procedure. 894 895 Within_Task_Body : Boolean := False; 896 -- This flag is set when the Processing phase is currently examining a 897 -- scenario which was reached from a task body. 898 end record; 899 900 -- The following constants define the various operational states of the 901 -- Processing phase. 902 903 -- The conditional ABE state is used when processing scenarios that appear 904 -- at the declaration, instantiation, and library levels to detect errors 905 -- and install conditional ABE checks. 906 907 Conditional_ABE_State : constant Processing_In_State := 908 (Processing => Conditional_ABE_Processing, 909 Representation => Consistent_Representation, 910 Traversal => Deep_Traversal, 911 others => False); 912 913 -- The dynamic model state is used to install conditional ABE checks when 914 -- switch -gnatE (dynamic elaboration checking mode enabled) is in effect. 915 916 Dynamic_Model_State : constant Processing_In_State := 917 (Processing => Dynamic_Model_Processing, 918 Representation => Consistent_Representation, 919 Suppress_Implicit_Pragmas => True, 920 Suppress_Info_Messages => True, 921 Suppress_Up_Level_Targets => True, 922 Suppress_Warnings => True, 923 Traversal => No_Traversal, 924 others => False); 925 926 -- The guaranteed ABE state is used when processing scenarios that appear 927 -- at the declaration, instantiation, and library levels to detect errors 928 -- and install guarateed ABE failures. 929 930 Guaranteed_ABE_State : constant Processing_In_State := 931 (Processing => Guaranteed_ABE_Processing, 932 Representation => Inconsistent_Representation, 933 Suppress_Implicit_Pragmas => True, 934 Traversal => No_Traversal, 935 others => False); 936 937 -- The invocation body state is used when processing scenarios that appear 938 -- at the body library level to encode paths that start from elaboration 939 -- code and ultimately reach into external units. 940 941 Invocation_Body_State : constant Processing_In_State := 942 (Processing => Invocation_Body_Processing, 943 Representation => Consistent_Representation, 944 Suppress_Checks => True, 945 Suppress_Implicit_Pragmas => True, 946 Suppress_Info_Messages => True, 947 Suppress_Up_Level_Targets => True, 948 Suppress_Warnings => True, 949 Traversal => Deep_Traversal, 950 others => False); 951 952 -- The invocation construct state is used when processing constructs that 953 -- appear within the spec and body of the main unit and eventually reach 954 -- into external units. 955 956 Invocation_Construct_State : constant Processing_In_State := 957 (Processing => Invocation_Construct_Processing, 958 Representation => Consistent_Representation, 959 Suppress_Checks => True, 960 Suppress_Implicit_Pragmas => True, 961 Suppress_Info_Messages => True, 962 Suppress_Up_Level_Targets => True, 963 Suppress_Warnings => True, 964 Traversal => Deep_Traversal, 965 others => False); 966 967 -- The invocation spec state is used when processing scenarios that appear 968 -- at the spec library level to encode paths that start from elaboration 969 -- code and ultimately reach into external units. 970 971 Invocation_Spec_State : constant Processing_In_State := 972 (Processing => Invocation_Spec_Processing, 973 Representation => Consistent_Representation, 974 Suppress_Checks => True, 975 Suppress_Implicit_Pragmas => True, 976 Suppress_Info_Messages => True, 977 Suppress_Up_Level_Targets => True, 978 Suppress_Warnings => True, 979 Traversal => Deep_Traversal, 980 others => False); 981 982 -- The SPARK state is used when verying SPARK-specific semantics of certain 983 -- scenarios. 984 985 SPARK_State : constant Processing_In_State := 986 (Processing => SPARK_Processing, 987 Representation => Consistent_Representation, 988 Traversal => No_Traversal, 989 others => False); 990 991 -- The following type identifies a scenario representation 992 993 type Scenario_Rep_Id is new Natural; 994 995 No_Scenario_Rep : constant Scenario_Rep_Id := Scenario_Rep_Id'First; 996 First_Scenario_Rep : constant Scenario_Rep_Id := No_Scenario_Rep + 1; 997 998 -- The following type identifies a target representation 999 1000 type Target_Rep_Id is new Natural; 1001 1002 No_Target_Rep : constant Target_Rep_Id := Target_Rep_Id'First; 1003 First_Target_Rep : constant Target_Rep_Id := No_Target_Rep + 1; 1004 1005 -------------- 1006 -- Services -- 1007 -------------- 1008 1009 -- The following package keeps track of all active scenarios during a DFS 1010 -- traversal. 1011 1012 package Active_Scenarios is 1013 1014 ----------- 1015 -- Types -- 1016 ----------- 1017 1018 -- The following type defines the position within the active scenario 1019 -- stack. 1020 1021 type Active_Scenario_Pos is new Natural; 1022 1023 --------------------- 1024 -- Data structures -- 1025 --------------------- 1026 1027 -- The following table stores all active scenarios in a DFS traversal. 1028 -- This table must be maintained in a FIFO fashion. 1029 1030 package Active_Scenario_Stack is new Table.Table 1031 (Table_Index_Type => Active_Scenario_Pos, 1032 Table_Component_Type => Node_Id, 1033 Table_Low_Bound => 1, 1034 Table_Initial => 50, 1035 Table_Increment => 200, 1036 Table_Name => "Active_Scenario_Stack"); 1037 1038 --------- 1039 -- API -- 1040 --------- 1041 1042 procedure Output_Active_Scenarios 1043 (Error_Nod : Node_Id; 1044 In_State : Processing_In_State); 1045 pragma Inline (Output_Active_Scenarios); 1046 -- Output the contents of the active scenario stack from earliest to 1047 -- latest to supplement an earlier error emitted for node Error_Nod. 1048 -- In_State denotes the current state of the Processing phase. 1049 1050 procedure Pop_Active_Scenario (N : Node_Id); 1051 pragma Inline (Pop_Active_Scenario); 1052 -- Pop the top of the scenario stack. A check is made to ensure that the 1053 -- scenario being removed is the same as N. 1054 1055 procedure Push_Active_Scenario (N : Node_Id); 1056 pragma Inline (Push_Active_Scenario); 1057 -- Push scenario N on top of the scenario stack 1058 1059 function Root_Scenario return Node_Id; 1060 pragma Inline (Root_Scenario); 1061 -- Return the scenario which started a DFS traversal 1062 1063 end Active_Scenarios; 1064 use Active_Scenarios; 1065 1066 -- The following package provides the main entry point for task activation 1067 -- processing. 1068 1069 package Activation_Processor is 1070 1071 ----------- 1072 -- Types -- 1073 ----------- 1074 1075 type Activation_Processor_Ptr is access procedure 1076 (Call : Node_Id; 1077 Call_Rep : Scenario_Rep_Id; 1078 Obj_Id : Entity_Id; 1079 Obj_Rep : Target_Rep_Id; 1080 Task_Typ : Entity_Id; 1081 Task_Rep : Target_Rep_Id; 1082 In_State : Processing_In_State); 1083 -- Reference to a procedure that takes all attributes of an activation 1084 -- and performs a desired action. Call is the activation call. Call_Rep 1085 -- is the representation of the call. Obj_Id is the task object being 1086 -- activated. Obj_Rep is the representation of the object. Task_Typ is 1087 -- the task type whose body is being activated. Task_Rep denotes the 1088 -- representation of the task type. In_State is the current state of 1089 -- the Processing phase. 1090 1091 --------- 1092 -- API -- 1093 --------- 1094 1095 procedure Process_Activation 1096 (Call : Node_Id; 1097 Call_Rep : Scenario_Rep_Id; 1098 Processor : Activation_Processor_Ptr; 1099 In_State : Processing_In_State); 1100 -- Find all task objects activated by activation call Call and invoke 1101 -- Processor on them. Call_Rep denotes the representation of the call. 1102 -- In_State is the current state of the Processing phase. 1103 1104 end Activation_Processor; 1105 use Activation_Processor; 1106 1107 -- The following package profides functionality for traversing subprogram 1108 -- bodies in DFS manner and processing of eligible scenarios within. 1109 1110 package Body_Processor is 1111 1112 ----------- 1113 -- Types -- 1114 ----------- 1115 1116 type Scenario_Predicate_Ptr is access function 1117 (N : Node_Id) return Boolean; 1118 -- Reference to a function which determines whether arbitrary node N 1119 -- denotes a suitable scenario for processing. 1120 1121 type Scenario_Processor_Ptr is access procedure 1122 (N : Node_Id; In_State : Processing_In_State); 1123 -- Reference to a procedure which processes scenario N. In_State is the 1124 -- current state of the Processing phase. 1125 1126 --------- 1127 -- API -- 1128 --------- 1129 1130 procedure Traverse_Body 1131 (N : Node_Id; 1132 Requires_Processing : Scenario_Predicate_Ptr; 1133 Processor : Scenario_Processor_Ptr; 1134 In_State : Processing_In_State); 1135 pragma Inline (Traverse_Body); 1136 -- Traverse the declarations and handled statements of subprogram body 1137 -- N, looking for scenarios that satisfy predicate Requires_Processing. 1138 -- Routine Processor is invoked for each such scenario. 1139 1140 procedure Reset_Traversed_Bodies; 1141 pragma Inline (Reset_Traversed_Bodies); 1142 -- Reset the visited status of all subprogram bodies that have already 1143 -- been processed by routine Traverse_Body. 1144 1145 ----------------- 1146 -- Maintenance -- 1147 ----------------- 1148 1149 procedure Finalize_Body_Processor; 1150 pragma Inline (Finalize_Body_Processor); 1151 -- Finalize all internal data structures 1152 1153 procedure Initialize_Body_Processor; 1154 pragma Inline (Initialize_Body_Processor); 1155 -- Initialize all internal data structures 1156 1157 end Body_Processor; 1158 use Body_Processor; 1159 1160 -- The following package provides functionality for installing ABE-related 1161 -- checks and failures. 1162 1163 package Check_Installer is 1164 1165 --------- 1166 -- API -- 1167 --------- 1168 1169 function Check_Or_Failure_Generation_OK return Boolean; 1170 pragma Inline (Check_Or_Failure_Generation_OK); 1171 -- Determine whether a conditional ABE check or guaranteed ABE failure 1172 -- can be generated. 1173 1174 procedure Install_Dynamic_ABE_Checks; 1175 pragma Inline (Install_Dynamic_ABE_Checks); 1176 -- Install conditional ABE checks for all saved scenarios when the 1177 -- dynamic model is in effect. 1178 1179 procedure Install_Scenario_ABE_Check 1180 (N : Node_Id; 1181 Targ_Id : Entity_Id; 1182 Targ_Rep : Target_Rep_Id; 1183 Disable : Scenario_Rep_Id); 1184 pragma Inline (Install_Scenario_ABE_Check); 1185 -- Install a conditional ABE check for scenario N to ensure that target 1186 -- Targ_Id is properly elaborated. Targ_Rep is the representation of the 1187 -- target. If the check is installed, disable the elaboration checks of 1188 -- scenario Disable. 1189 1190 procedure Install_Scenario_ABE_Check 1191 (N : Node_Id; 1192 Targ_Id : Entity_Id; 1193 Targ_Rep : Target_Rep_Id; 1194 Disable : Target_Rep_Id); 1195 pragma Inline (Install_Scenario_ABE_Check); 1196 -- Install a conditional ABE check for scenario N to ensure that target 1197 -- Targ_Id is properly elaborated. Targ_Rep is the representation of the 1198 -- target. If the check is installed, disable the elaboration checks of 1199 -- target Disable. 1200 1201 procedure Install_Scenario_ABE_Failure 1202 (N : Node_Id; 1203 Targ_Id : Entity_Id; 1204 Targ_Rep : Target_Rep_Id; 1205 Disable : Scenario_Rep_Id); 1206 pragma Inline (Install_Scenario_ABE_Failure); 1207 -- Install a guaranteed ABE failure for scenario N with target Targ_Id. 1208 -- Targ_Rep denotes the representation of the target. If the failure is 1209 -- installed, disable the elaboration checks of scenario Disable. 1210 1211 procedure Install_Scenario_ABE_Failure 1212 (N : Node_Id; 1213 Targ_Id : Entity_Id; 1214 Targ_Rep : Target_Rep_Id; 1215 Disable : Target_Rep_Id); 1216 pragma Inline (Install_Scenario_ABE_Failure); 1217 -- Install a guaranteed ABE failure for scenario N with target Targ_Id. 1218 -- Targ_Rep denotes the representation of the target. If the failure is 1219 -- installed, disable the elaboration checks of target Disable. 1220 1221 procedure Install_Unit_ABE_Check 1222 (N : Node_Id; 1223 Unit_Id : Entity_Id; 1224 Disable : Scenario_Rep_Id); 1225 pragma Inline (Install_Unit_ABE_Check); 1226 -- Install a conditional ABE check for scenario N to ensure that unit 1227 -- Unit_Id is properly elaborated. If the check is installed, disable 1228 -- the elaboration checks of scenario Disable. 1229 1230 procedure Install_Unit_ABE_Check 1231 (N : Node_Id; 1232 Unit_Id : Entity_Id; 1233 Disable : Target_Rep_Id); 1234 pragma Inline (Install_Unit_ABE_Check); 1235 -- Install a conditional ABE check for scenario N to ensure that unit 1236 -- Unit_Id is properly elaborated. If the check is installed, disable 1237 -- the elaboration checks of target Disable. 1238 1239 end Check_Installer; 1240 use Check_Installer; 1241 1242 -- The following package provides the main entry point for conditional ABE 1243 -- checks and diagnostics. 1244 1245 package Conditional_ABE_Processor is 1246 1247 --------- 1248 -- API -- 1249 --------- 1250 1251 procedure Check_Conditional_ABE_Scenarios 1252 (Iter : in out NE_Set.Iterator); 1253 pragma Inline (Check_Conditional_ABE_Scenarios); 1254 -- Perform conditional ABE checks and diagnostics for all scenarios 1255 -- available through iterator Iter. 1256 1257 procedure Process_Conditional_ABE 1258 (N : Node_Id; 1259 In_State : Processing_In_State); 1260 pragma Inline (Process_Conditional_ABE); 1261 -- Perform conditional ABE checks and diagnostics for scenario N. 1262 -- In_State denotes the current state of the Processing phase. 1263 1264 end Conditional_ABE_Processor; 1265 use Conditional_ABE_Processor; 1266 1267 -- The following package provides functionality to emit errors, information 1268 -- messages, and warnings. 1269 1270 package Diagnostics is 1271 1272 --------- 1273 -- API -- 1274 --------- 1275 1276 procedure Elab_Msg_NE 1277 (Msg : String; 1278 N : Node_Id; 1279 Id : Entity_Id; 1280 Info_Msg : Boolean; 1281 In_SPARK : Boolean); 1282 pragma Inline (Elab_Msg_NE); 1283 -- Wrapper around Error_Msg_NE. Emit message Msg concerning arbitrary 1284 -- node N and entity. If flag Info_Msg is set, the routine emits an 1285 -- information message, otherwise it emits an error. If flag In_SPARK 1286 -- is set, then string " in SPARK" is added to the end of the message. 1287 1288 procedure Info_Call 1289 (Call : Node_Id; 1290 Subp_Id : Entity_Id; 1291 Info_Msg : Boolean; 1292 In_SPARK : Boolean); 1293 pragma Inline (Info_Call); 1294 -- Output information concerning call Call that invokes subprogram 1295 -- Subp_Id. When flag Info_Msg is set, the routine emits an information 1296 -- message, otherwise it emits an error. When flag In_SPARK is set, " in 1297 -- SPARK" is added to the end of the message. 1298 1299 procedure Info_Instantiation 1300 (Inst : Node_Id; 1301 Gen_Id : Entity_Id; 1302 Info_Msg : Boolean; 1303 In_SPARK : Boolean); 1304 pragma Inline (Info_Instantiation); 1305 -- Output information concerning instantiation Inst which instantiates 1306 -- generic unit Gen_Id. If flag Info_Msg is set, the routine emits an 1307 -- information message, otherwise it emits an error. If flag In_SPARK 1308 -- is set, then string " in SPARK" is added to the end of the message. 1309 1310 procedure Info_Variable_Reference 1311 (Ref : Node_Id; 1312 Var_Id : Entity_Id); 1313 pragma Inline (Info_Variable_Reference); 1314 -- Output information concerning reference Ref which mentions variable 1315 -- Var_Id. The routine emits an error suffixed with " in SPARK". 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 : Entity_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 (N : Node_Id); 3036 pragma Inline (Set_Is_Traversed_Body); 3037 -- Mark subprogram body N as traversed 3038 3039 procedure Set_Nested_Scenarios 3040 (N : Node_Id; 3041 Scenarios : NE_List.Doubly_Linked_List); 3042 pragma Inline (Set_Nested_Scenarios); 3043 -- Associate scenario list Scenarios with subprogram body N 3044 3045 ----------------------------- 3046 -- Finalize_Body_Processor -- 3047 ----------------------------- 3048 3049 procedure Finalize_Body_Processor is 3050 begin 3051 NE_List_Map.Destroy (Nested_Scenarios_Map); 3052 NE_Set.Destroy (Traversed_Bodies_Set); 3053 end Finalize_Body_Processor; 3054 3055 ------------------------------- 3056 -- Initialize_Body_Processor -- 3057 ------------------------------- 3058 3059 procedure Initialize_Body_Processor is 3060 begin 3061 Nested_Scenarios_Map := NE_List_Map.Create (250); 3062 Traversed_Bodies_Set := NE_Set.Create (250); 3063 end Initialize_Body_Processor; 3064 3065 ----------------------- 3066 -- Is_Traversed_Body -- 3067 ----------------------- 3068 3069 function Is_Traversed_Body (N : Node_Id) return Boolean is 3070 pragma Assert (Present (N)); 3071 begin 3072 return NE_Set.Contains (Traversed_Bodies_Set, N); 3073 end Is_Traversed_Body; 3074 3075 ---------------------- 3076 -- Nested_Scenarios -- 3077 ---------------------- 3078 3079 function Nested_Scenarios 3080 (N : Node_Id) return NE_List.Doubly_Linked_List 3081 is 3082 pragma Assert (Present (N)); 3083 pragma Assert (Nkind (N) = N_Subprogram_Body); 3084 3085 begin 3086 return NE_List_Map.Get (Nested_Scenarios_Map, N); 3087 end Nested_Scenarios; 3088 3089 ---------------------------- 3090 -- Reset_Traversed_Bodies -- 3091 ---------------------------- 3092 3093 procedure Reset_Traversed_Bodies is 3094 begin 3095 NE_Set.Reset (Traversed_Bodies_Set); 3096 end Reset_Traversed_Bodies; 3097 3098 --------------------------- 3099 -- Set_Is_Traversed_Body -- 3100 --------------------------- 3101 3102 procedure Set_Is_Traversed_Body (N : Node_Id) is 3103 pragma Assert (Present (N)); 3104 3105 begin 3106 NE_Set.Insert (Traversed_Bodies_Set, N); 3107 end Set_Is_Traversed_Body; 3108 3109 -------------------------- 3110 -- Set_Nested_Scenarios -- 3111 -------------------------- 3112 3113 procedure Set_Nested_Scenarios 3114 (N : Node_Id; 3115 Scenarios : NE_List.Doubly_Linked_List) 3116 is 3117 pragma Assert (Present (N)); 3118 begin 3119 NE_List_Map.Put (Nested_Scenarios_Map, N, Scenarios); 3120 end Set_Nested_Scenarios; 3121 3122 ------------------- 3123 -- Traverse_Body -- 3124 ------------------- 3125 3126 procedure Traverse_Body 3127 (N : Node_Id; 3128 Requires_Processing : Scenario_Predicate_Ptr; 3129 Processor : Scenario_Processor_Ptr; 3130 In_State : Processing_In_State) 3131 is 3132 Scenarios : NE_List.Doubly_Linked_List := NE_List.Nil; 3133 -- The list of scenarios that appear within the declarations and 3134 -- statement of subprogram body N. The variable is intentionally 3135 -- global because Is_Potential_Scenario needs to populate it. 3136 3137 function In_Task_Body (Nod : Node_Id) return Boolean; 3138 pragma Inline (In_Task_Body); 3139 -- Determine whether arbitrary node Nod appears within a task body 3140 3141 function Is_Synchronous_Suspension_Call 3142 (Nod : Node_Id) return Boolean; 3143 pragma Inline (Is_Synchronous_Suspension_Call); 3144 -- Determine whether arbitrary node Nod denotes a call to one of 3145 -- these routines: 3146 -- 3147 -- Ada.Synchronous_Barriers.Wait_For_Release 3148 -- Ada.Synchronous_Task_Control.Suspend_Until_True 3149 3150 procedure Traverse_Collected_Scenarios; 3151 pragma Inline (Traverse_Collected_Scenarios); 3152 -- Traverse the already collected scenarios in list Scenarios by 3153 -- invoking Processor on each individual one. 3154 3155 procedure Traverse_List (List : List_Id); 3156 pragma Inline (Traverse_List); 3157 -- Invoke Traverse_Potential_Scenarios on each node in list List 3158 3159 function Traverse_Potential_Scenario 3160 (Scen : Node_Id) return Traverse_Result; 3161 pragma Inline (Traverse_Potential_Scenario); 3162 -- Determine whether arbitrary node Scen is a suitable scenario using 3163 -- predicate Is_Scenario and traverse it by invoking Processor on it. 3164 3165 procedure Traverse_Potential_Scenarios is 3166 new Traverse_Proc (Traverse_Potential_Scenario); 3167 3168 ------------------ 3169 -- In_Task_Body -- 3170 ------------------ 3171 3172 function In_Task_Body (Nod : Node_Id) return Boolean is 3173 Par : Node_Id; 3174 3175 begin 3176 -- Climb the parent chain looking for a task body [procedure] 3177 3178 Par := Nod; 3179 while Present (Par) loop 3180 if Nkind (Par) = N_Task_Body then 3181 return True; 3182 3183 elsif Nkind (Par) = N_Subprogram_Body 3184 and then Is_Task_Body_Procedure (Par) 3185 then 3186 return True; 3187 3188 -- Prevent the search from going too far. Note that this test 3189 -- shares nodes with the two cases above, and must come last. 3190 3191 elsif Is_Body_Or_Package_Declaration (Par) then 3192 return False; 3193 end if; 3194 3195 Par := Parent (Par); 3196 end loop; 3197 3198 return False; 3199 end In_Task_Body; 3200 3201 ------------------------------------ 3202 -- Is_Synchronous_Suspension_Call -- 3203 ------------------------------------ 3204 3205 function Is_Synchronous_Suspension_Call 3206 (Nod : Node_Id) return Boolean 3207 is 3208 Subp_Id : Entity_Id; 3209 3210 begin 3211 -- To qualify, the call must invoke one of the runtime routines 3212 -- which perform synchronous suspension. 3213 3214 if Is_Suitable_Call (Nod) then 3215 Subp_Id := Target (Nod); 3216 3217 return 3218 Is_RTE (Subp_Id, RE_Suspend_Until_True) 3219 or else 3220 Is_RTE (Subp_Id, RE_Wait_For_Release); 3221 end if; 3222 3223 return False; 3224 end Is_Synchronous_Suspension_Call; 3225 3226 ---------------------------------- 3227 -- Traverse_Collected_Scenarios -- 3228 ---------------------------------- 3229 3230 procedure Traverse_Collected_Scenarios is 3231 Iter : NE_List.Iterator; 3232 Scen : Node_Id; 3233 3234 begin 3235 Iter := NE_List.Iterate (Scenarios); 3236 while NE_List.Has_Next (Iter) loop 3237 NE_List.Next (Iter, Scen); 3238 3239 -- The current scenario satisfies the input predicate, process 3240 -- it. 3241 3242 if Requires_Processing.all (Scen) then 3243 Processor.all (Scen, In_State); 3244 end if; 3245 end loop; 3246 end Traverse_Collected_Scenarios; 3247 3248 ------------------- 3249 -- Traverse_List -- 3250 ------------------- 3251 3252 procedure Traverse_List (List : List_Id) is 3253 Scen : Node_Id; 3254 3255 begin 3256 Scen := First (List); 3257 while Present (Scen) loop 3258 Traverse_Potential_Scenarios (Scen); 3259 Next (Scen); 3260 end loop; 3261 end Traverse_List; 3262 3263 --------------------------------- 3264 -- Traverse_Potential_Scenario -- 3265 --------------------------------- 3266 3267 function Traverse_Potential_Scenario 3268 (Scen : Node_Id) return Traverse_Result 3269 is 3270 begin 3271 -- Special cases 3272 3273 -- Skip constructs which do not have elaboration of their own and 3274 -- need to be elaborated by other means such as invocation, task 3275 -- activation, etc. 3276 3277 if Is_Non_Library_Level_Encapsulator (Scen) then 3278 return Skip; 3279 3280 -- Terminate the traversal of a task body when encountering an 3281 -- accept or select statement, and 3282 -- 3283 -- * Entry calls during elaboration are not allowed. In this 3284 -- case the accept or select statement will cause the task 3285 -- to block at elaboration time because there are no entry 3286 -- calls to unblock it. 3287 -- 3288 -- or 3289 -- 3290 -- * Switch -gnatd_a (stop elaboration checks on accept or 3291 -- select statement) is in effect. 3292 3293 elsif (Debug_Flag_Underscore_A 3294 or else Restriction_Active 3295 (No_Entry_Calls_In_Elaboration_Code)) 3296 and then Nkind (Original_Node (Scen)) in 3297 N_Accept_Statement | N_Selective_Accept 3298 then 3299 return Abandon; 3300 3301 -- Terminate the traversal of a task body when encountering a 3302 -- suspension call, and 3303 -- 3304 -- * Entry calls during elaboration are not allowed. In this 3305 -- case the suspension call emulates an entry call and will 3306 -- cause the task to block at elaboration time. 3307 -- 3308 -- or 3309 -- 3310 -- * Switch -gnatd_s (stop elaboration checks on synchronous 3311 -- suspension) is in effect. 3312 -- 3313 -- Note that the guard should not be checking the state of flag 3314 -- Within_Task_Body because only suspension calls which appear 3315 -- immediately within the statements of the task are supported. 3316 -- Flag Within_Task_Body carries over to deeper levels of the 3317 -- traversal. 3318 3319 elsif (Debug_Flag_Underscore_S 3320 or else Restriction_Active 3321 (No_Entry_Calls_In_Elaboration_Code)) 3322 and then Is_Synchronous_Suspension_Call (Scen) 3323 and then In_Task_Body (Scen) 3324 then 3325 return Abandon; 3326 3327 -- Certain nodes carry semantic lists which act as repositories 3328 -- until expansion transforms the node and relocates the contents. 3329 -- Examine these lists in case expansion is disabled. 3330 3331 elsif Nkind (Scen) in N_And_Then | N_Or_Else then 3332 Traverse_List (Actions (Scen)); 3333 3334 elsif Nkind (Scen) in N_Elsif_Part | N_Iteration_Scheme then 3335 Traverse_List (Condition_Actions (Scen)); 3336 3337 elsif Nkind (Scen) = N_If_Expression then 3338 Traverse_List (Then_Actions (Scen)); 3339 Traverse_List (Else_Actions (Scen)); 3340 3341 elsif Nkind (Scen) in 3342 N_Component_Association | N_Iterated_Component_Association 3343 then 3344 Traverse_List (Loop_Actions (Scen)); 3345 3346 -- General case 3347 3348 -- The current node satisfies the input predicate, process it 3349 3350 elsif Requires_Processing.all (Scen) then 3351 Processor.all (Scen, In_State); 3352 end if; 3353 3354 -- Save a general scenario regardless of whether it satisfies the 3355 -- input predicate. This allows for quick subsequent traversals of 3356 -- general scenarios, even with different predicates. 3357 3358 if Is_Suitable_Access_Taken (Scen) 3359 or else Is_Suitable_Call (Scen) 3360 or else Is_Suitable_Instantiation (Scen) 3361 or else Is_Suitable_Variable_Assignment (Scen) 3362 or else Is_Suitable_Variable_Reference (Scen) 3363 then 3364 NE_List.Append (Scenarios, Scen); 3365 end if; 3366 3367 return OK; 3368 end Traverse_Potential_Scenario; 3369 3370 -- Start of processing for Traverse_Body 3371 3372 begin 3373 -- Nothing to do when the traversal is suppressed 3374 3375 if In_State.Traversal = No_Traversal then 3376 return; 3377 3378 -- Nothing to do when there is no input 3379 3380 elsif No (N) then 3381 return; 3382 3383 -- Nothing to do when the input is not a subprogram body 3384 3385 elsif Nkind (N) /= N_Subprogram_Body then 3386 return; 3387 3388 -- Nothing to do if the subprogram body was already traversed 3389 3390 elsif Is_Traversed_Body (N) then 3391 return; 3392 end if; 3393 3394 -- Mark the subprogram body as traversed 3395 3396 Set_Is_Traversed_Body (N); 3397 3398 Scenarios := Nested_Scenarios (N); 3399 3400 -- The subprogram body has been traversed at least once, and all 3401 -- scenarios that appear within its declarations and statements 3402 -- have already been collected. Directly retraverse the scenarios 3403 -- without having to retraverse the subprogram body subtree. 3404 3405 if NE_List.Present (Scenarios) then 3406 Traverse_Collected_Scenarios; 3407 3408 -- Otherwise the subprogram body is being traversed for the first 3409 -- time. Collect all scenarios that appear within its declarations 3410 -- and statements in case the subprogram body has to be retraversed 3411 -- multiple times. 3412 3413 else 3414 Scenarios := NE_List.Create; 3415 Set_Nested_Scenarios (N, Scenarios); 3416 3417 Traverse_List (Declarations (N)); 3418 Traverse_Potential_Scenarios (Handled_Statement_Sequence (N)); 3419 end if; 3420 end Traverse_Body; 3421 end Body_Processor; 3422 3423 ----------------------- 3424 -- Build_Call_Marker -- 3425 ----------------------- 3426 3427 procedure Build_Call_Marker (N : Node_Id) is 3428 function In_External_Context 3429 (Call : Node_Id; 3430 Subp_Id : Entity_Id) return Boolean; 3431 pragma Inline (In_External_Context); 3432 -- Determine whether entry, operator, or subprogram Subp_Id is external 3433 -- to call Call which must reside within an instance. 3434 3435 function In_Premature_Context (Call : Node_Id) return Boolean; 3436 pragma Inline (In_Premature_Context); 3437 -- Determine whether call Call appears within a premature context 3438 3439 function Is_Default_Expression (Call : Node_Id) return Boolean; 3440 pragma Inline (Is_Default_Expression); 3441 -- Determine whether call Call acts as the expression of a defaulted 3442 -- parameter within a source call. 3443 3444 function Is_Generic_Formal_Subp (Subp_Id : Entity_Id) return Boolean; 3445 pragma Inline (Is_Generic_Formal_Subp); 3446 -- Determine whether subprogram Subp_Id denotes a generic formal 3447 -- subprogram which appears in the "prologue" of an instantiation. 3448 3449 ------------------------- 3450 -- In_External_Context -- 3451 ------------------------- 3452 3453 function In_External_Context 3454 (Call : Node_Id; 3455 Subp_Id : Entity_Id) return Boolean 3456 is 3457 Spec_Decl : constant Entity_Id := Unit_Declaration_Node (Subp_Id); 3458 3459 Inst : Node_Id; 3460 Inst_Body : Node_Id; 3461 Inst_Spec : Node_Id; 3462 3463 begin 3464 Inst := Find_Enclosing_Instance (Call); 3465 3466 -- The call appears within an instance 3467 3468 if Present (Inst) then 3469 3470 -- The call comes from the main unit and the target does not 3471 3472 if In_Extended_Main_Code_Unit (Call) 3473 and then not In_Extended_Main_Code_Unit (Spec_Decl) 3474 then 3475 return True; 3476 3477 -- Otherwise the target declaration must not appear within the 3478 -- instance spec or body. 3479 3480 else 3481 Spec_And_Body_From_Node 3482 (N => Inst, 3483 Spec_Decl => Inst_Spec, 3484 Body_Decl => Inst_Body); 3485 3486 return not In_Subtree 3487 (N => Spec_Decl, 3488 Root1 => Inst_Spec, 3489 Root2 => Inst_Body); 3490 end if; 3491 end if; 3492 3493 return False; 3494 end In_External_Context; 3495 3496 -------------------------- 3497 -- In_Premature_Context -- 3498 -------------------------- 3499 3500 function In_Premature_Context (Call : Node_Id) return Boolean is 3501 Par : Node_Id; 3502 3503 begin 3504 -- Climb the parent chain looking for premature contexts 3505 3506 Par := Parent (Call); 3507 while Present (Par) loop 3508 3509 -- Aspect specifications and generic associations are premature 3510 -- contexts because nested calls has not been relocated to their 3511 -- final context. 3512 3513 if Nkind (Par) in N_Aspect_Specification | N_Generic_Association 3514 then 3515 return True; 3516 3517 -- Prevent the search from going too far 3518 3519 elsif Is_Body_Or_Package_Declaration (Par) then 3520 exit; 3521 end if; 3522 3523 Par := Parent (Par); 3524 end loop; 3525 3526 return False; 3527 end In_Premature_Context; 3528 3529 --------------------------- 3530 -- Is_Default_Expression -- 3531 --------------------------- 3532 3533 function Is_Default_Expression (Call : Node_Id) return Boolean is 3534 Outer_Call : constant Node_Id := Parent (Call); 3535 Outer_Nam : Node_Id; 3536 3537 begin 3538 -- To qualify, the node must appear immediately within a source call 3539 -- which invokes a source target. 3540 3541 if Nkind (Outer_Call) in N_Entry_Call_Statement 3542 | N_Function_Call 3543 | N_Procedure_Call_Statement 3544 and then Comes_From_Source (Outer_Call) 3545 then 3546 Outer_Nam := Call_Name (Outer_Call); 3547 3548 return 3549 Is_Entity_Name (Outer_Nam) 3550 and then Present (Entity (Outer_Nam)) 3551 and then Is_Subprogram_Or_Entry (Entity (Outer_Nam)) 3552 and then Comes_From_Source (Entity (Outer_Nam)); 3553 end if; 3554 3555 return False; 3556 end Is_Default_Expression; 3557 3558 ---------------------------- 3559 -- Is_Generic_Formal_Subp -- 3560 ---------------------------- 3561 3562 function Is_Generic_Formal_Subp (Subp_Id : Entity_Id) return Boolean is 3563 Subp_Decl : constant Node_Id := Unit_Declaration_Node (Subp_Id); 3564 Context : constant Node_Id := Parent (Subp_Decl); 3565 3566 begin 3567 -- To qualify, the subprogram must rename a generic actual subprogram 3568 -- where the enclosing context is an instantiation. 3569 3570 return 3571 Nkind (Subp_Decl) = N_Subprogram_Renaming_Declaration 3572 and then not Comes_From_Source (Subp_Decl) 3573 and then Nkind (Context) in N_Function_Specification 3574 | N_Package_Specification 3575 | N_Procedure_Specification 3576 and then Present (Generic_Parent (Context)); 3577 end Is_Generic_Formal_Subp; 3578 3579 -- Local variables 3580 3581 Call_Nam : Node_Id; 3582 Marker : Node_Id; 3583 Subp_Id : Entity_Id; 3584 3585 -- Start of processing for Build_Call_Marker 3586 3587 begin 3588 -- Nothing to do when switch -gnatH (legacy elaboration checking mode 3589 -- enabled) is in effect because the legacy ABE mechanism does not need 3590 -- to carry out this action. 3591 3592 if Legacy_Elaboration_Checks then 3593 return; 3594 3595 -- Nothing to do when the call is being preanalyzed as the marker will 3596 -- be inserted in the wrong place. 3597 3598 elsif Preanalysis_Active then 3599 return; 3600 3601 -- Nothing to do when the elaboration phase of the compiler is not 3602 -- active. 3603 3604 elsif not Elaboration_Phase_Active then 3605 return; 3606 3607 -- Nothing to do when the input does not denote a call or a requeue 3608 3609 elsif Nkind (N) not in N_Entry_Call_Statement 3610 | N_Function_Call 3611 | N_Procedure_Call_Statement 3612 | N_Requeue_Statement 3613 then 3614 return; 3615 3616 -- Nothing to do when the input denotes entry call or requeue statement, 3617 -- and switch -gnatd_e (ignore entry calls and requeue statements for 3618 -- elaboration) is in effect. 3619 3620 elsif Debug_Flag_Underscore_E 3621 and then Nkind (N) in N_Entry_Call_Statement | N_Requeue_Statement 3622 then 3623 return; 3624 3625 -- Nothing to do when the call is analyzed/resolved too early within an 3626 -- intermediate context. This check is saved for last because it incurs 3627 -- a performance penalty. 3628 3629 elsif In_Premature_Context (N) then 3630 return; 3631 end if; 3632 3633 Call_Nam := Call_Name (N); 3634 3635 -- Nothing to do when the call is erroneous or left in a bad state 3636 3637 if not (Is_Entity_Name (Call_Nam) 3638 and then Present (Entity (Call_Nam)) 3639 and then Is_Subprogram_Or_Entry (Entity (Call_Nam))) 3640 then 3641 return; 3642 end if; 3643 3644 Subp_Id := Canonical_Subprogram (Entity (Call_Nam)); 3645 3646 -- Nothing to do when the call invokes a generic formal subprogram and 3647 -- switch -gnatd.G (ignore calls through generic formal parameters for 3648 -- elaboration) is in effect. This check must be performed with the 3649 -- direct target of the call to avoid the side effects of mapping 3650 -- actuals to formals using renamings. 3651 3652 if Debug_Flag_Dot_GG 3653 and then Is_Generic_Formal_Subp (Entity (Call_Nam)) 3654 then 3655 return; 3656 3657 -- Nothing to do when the call appears within the expanded spec or 3658 -- body of an instantiated generic, the call does not invoke a generic 3659 -- formal subprogram, the target is external to the instance, and switch 3660 -- -gnatdL (ignore external calls from instances for elaboration) is in 3661 -- effect. This check must be performed with the direct target of the 3662 -- call to avoid the side effects of mapping actuals to formals using 3663 -- renamings. 3664 3665 elsif Debug_Flag_LL 3666 and then not Is_Generic_Formal_Subp (Entity (Call_Nam)) 3667 and then In_External_Context 3668 (Call => N, 3669 Subp_Id => Subp_Id) 3670 then 3671 return; 3672 3673 -- Nothing to do when the call invokes an assertion pragma procedure 3674 -- and switch -gnatd_p (ignore assertion pragmas for elaboration) is 3675 -- in effect. 3676 3677 elsif Debug_Flag_Underscore_P 3678 and then Is_Assertion_Pragma_Target (Subp_Id) 3679 then 3680 return; 3681 3682 -- Static expression functions require no ABE processing 3683 3684 elsif Is_Static_Function (Subp_Id) then 3685 return; 3686 3687 -- Source calls to source targets are always considered because they 3688 -- reflect the original call graph. 3689 3690 elsif Comes_From_Source (N) and then Comes_From_Source (Subp_Id) then 3691 null; 3692 3693 -- A call to a source function which acts as the default expression in 3694 -- another call requires special detection. 3695 3696 elsif Comes_From_Source (Subp_Id) 3697 and then Nkind (N) = N_Function_Call 3698 and then Is_Default_Expression (N) 3699 then 3700 null; 3701 3702 -- The target emulates Ada semantics 3703 3704 elsif Is_Ada_Semantic_Target (Subp_Id) then 3705 null; 3706 3707 -- The target acts as a link between scenarios 3708 3709 elsif Is_Bridge_Target (Subp_Id) then 3710 null; 3711 3712 -- The target emulates SPARK semantics 3713 3714 elsif Is_SPARK_Semantic_Target (Subp_Id) then 3715 null; 3716 3717 -- Otherwise the call is not suitable for ABE processing. This prevents 3718 -- the generation of call markers which will never play a role in ABE 3719 -- diagnostics. 3720 3721 else 3722 return; 3723 end if; 3724 3725 -- At this point it is known that the call will play some role in ABE 3726 -- checks and diagnostics. Create a corresponding call marker in case 3727 -- the original call is heavily transformed by expansion later on. 3728 3729 Marker := Make_Call_Marker (Sloc (N)); 3730 3731 -- Inherit the attributes of the original call 3732 3733 Set_Is_Declaration_Level_Node 3734 (Marker, Find_Enclosing_Level (N) = Declaration_Level); 3735 3736 Set_Is_Dispatching_Call 3737 (Marker, 3738 Nkind (N) in N_Subprogram_Call 3739 and then Present (Controlling_Argument (N))); 3740 3741 Set_Is_Elaboration_Checks_OK_Node 3742 (Marker, Is_Elaboration_Checks_OK_Node (N)); 3743 3744 Set_Is_Elaboration_Warnings_OK_Node 3745 (Marker, Is_Elaboration_Warnings_OK_Node (N)); 3746 3747 Set_Is_Ignored_Ghost_Node (Marker, Is_Ignored_Ghost_Node (N)); 3748 Set_Is_Source_Call (Marker, Comes_From_Source (N)); 3749 Set_Is_SPARK_Mode_On_Node (Marker, Is_SPARK_Mode_On_Node (N)); 3750 Set_Target (Marker, Subp_Id); 3751 3752 -- Ada 2022 (AI12-0175): Calls to certain functions that are essentially 3753 -- unchecked conversions are preelaborable. 3754 3755 if Ada_Version >= Ada_2022 then 3756 Set_Is_Preelaborable_Call (Marker, Is_Preelaborable_Construct (N)); 3757 else 3758 Set_Is_Preelaborable_Call (Marker, False); 3759 end if; 3760 3761 -- The marker is inserted prior to the original call. This placement has 3762 -- several desirable effects: 3763 3764 -- 1) The marker appears in the same context, in close proximity to 3765 -- the call. 3766 3767 -- <marker> 3768 -- <call> 3769 3770 -- 2) Inserting the marker prior to the call ensures that an ABE check 3771 -- will take effect prior to the call. 3772 3773 -- <ABE check> 3774 -- <marker> 3775 -- <call> 3776 3777 -- 3) The above two properties are preserved even when the call is a 3778 -- function which is subsequently relocated in order to capture its 3779 -- result. Note that if the call is relocated to a new context, the 3780 -- relocated call will receive a marker of its own. 3781 3782 -- <ABE check> 3783 -- <maker> 3784 -- Temp : ... := Func_Call ...; 3785 -- ... Temp ... 3786 3787 -- The insertion must take place even when the call does not occur in 3788 -- the main unit to keep the tree symmetric. This ensures that internal 3789 -- name serialization is consistent in case the call marker causes the 3790 -- tree to transform in some way. 3791 3792 Insert_Action (N, Marker); 3793 3794 -- The marker becomes the "corresponding" scenario for the call. Save 3795 -- the marker for later processing by the ABE phase. 3796 3797 Record_Elaboration_Scenario (Marker); 3798 end Build_Call_Marker; 3799 3800 ------------------------------------- 3801 -- Build_Variable_Reference_Marker -- 3802 ------------------------------------- 3803 3804 procedure Build_Variable_Reference_Marker 3805 (N : Node_Id; 3806 Read : Boolean; 3807 Write : Boolean) 3808 is 3809 function Ultimate_Variable (Var_Id : Entity_Id) return Entity_Id; 3810 pragma Inline (Ultimate_Variable); 3811 -- Obtain the ultimate renamed variable of variable Var_Id 3812 3813 ----------------------- 3814 -- Ultimate_Variable -- 3815 ----------------------- 3816 3817 function Ultimate_Variable (Var_Id : Entity_Id) return Entity_Id is 3818 pragma Assert (Ekind (Var_Id) = E_Variable); 3819 Ren_Id : Entity_Id; 3820 begin 3821 Ren_Id := Var_Id; 3822 while Present (Renamed_Object (Ren_Id)) 3823 and then Nkind (Renamed_Object (Ren_Id)) in N_Entity 3824 loop 3825 Ren_Id := Renamed_Object (Ren_Id); 3826 end loop; 3827 3828 return Ren_Id; 3829 end Ultimate_Variable; 3830 3831 -- Local variables 3832 3833 Var_Id : constant Entity_Id := Ultimate_Variable (Entity (N)); 3834 Marker : Node_Id; 3835 3836 -- Start of processing for Build_Variable_Reference_Marker 3837 3838 begin 3839 -- Nothing to do when the elaboration phase of the compiler is not 3840 -- active. 3841 3842 if not Elaboration_Phase_Active then 3843 return; 3844 end if; 3845 3846 Marker := Make_Variable_Reference_Marker (Sloc (N)); 3847 3848 -- Inherit the attributes of the original variable reference 3849 3850 Set_Is_Elaboration_Checks_OK_Node 3851 (Marker, Is_Elaboration_Checks_OK_Node (N)); 3852 3853 Set_Is_Elaboration_Warnings_OK_Node 3854 (Marker, Is_Elaboration_Warnings_OK_Node (N)); 3855 3856 Set_Is_Read (Marker, Read); 3857 Set_Is_SPARK_Mode_On_Node (Marker, Is_SPARK_Mode_On_Node (N)); 3858 Set_Is_Write (Marker, Write); 3859 Set_Target (Marker, Var_Id); 3860 3861 -- The marker is inserted prior to the original variable reference. The 3862 -- insertion must take place even when the reference does not occur in 3863 -- the main unit to keep the tree symmetric. This ensures that internal 3864 -- name serialization is consistent in case the variable marker causes 3865 -- the tree to transform in some way. 3866 3867 Insert_Action (N, Marker); 3868 3869 -- The marker becomes the "corresponding" scenario for the reference. 3870 -- Save the marker for later processing for the ABE phase. 3871 3872 Record_Elaboration_Scenario (Marker); 3873 end Build_Variable_Reference_Marker; 3874 3875 --------------- 3876 -- Call_Name -- 3877 --------------- 3878 3879 function Call_Name (Call : Node_Id) return Node_Id is 3880 Nam : Node_Id; 3881 3882 begin 3883 Nam := Name (Call); 3884 3885 -- When the call invokes an entry family, the name appears as an indexed 3886 -- component. 3887 3888 if Nkind (Nam) = N_Indexed_Component then 3889 Nam := Prefix (Nam); 3890 end if; 3891 3892 -- When the call employs the object.operation form, the name appears as 3893 -- a selected component. 3894 3895 if Nkind (Nam) = N_Selected_Component then 3896 Nam := Selector_Name (Nam); 3897 end if; 3898 3899 return Nam; 3900 end Call_Name; 3901 3902 -------------------------- 3903 -- Canonical_Subprogram -- 3904 -------------------------- 3905 3906 function Canonical_Subprogram (Subp_Id : Entity_Id) return Entity_Id is 3907 Canon_Id : Entity_Id; 3908 3909 begin 3910 Canon_Id := Subp_Id; 3911 3912 -- Use the original protected subprogram when dealing with one of the 3913 -- specialized lock-manipulating versions. 3914 3915 if Is_Protected_Body_Subp (Canon_Id) then 3916 Canon_Id := Protected_Subprogram (Canon_Id); 3917 end if; 3918 3919 -- Obtain the original subprogram except when the subprogram is also 3920 -- an instantiation. In this case the alias is the internally generated 3921 -- subprogram which appears within the anonymous package created for the 3922 -- instantiation, making it unuitable. 3923 3924 if not Is_Generic_Instance (Canon_Id) then 3925 Canon_Id := Get_Renamed_Entity (Canon_Id); 3926 end if; 3927 3928 return Canon_Id; 3929 end Canonical_Subprogram; 3930 3931 --------------------------------- 3932 -- Check_Elaboration_Scenarios -- 3933 --------------------------------- 3934 3935 procedure Check_Elaboration_Scenarios is 3936 Iter : NE_Set.Iterator; 3937 3938 begin 3939 -- Nothing to do when switch -gnatH (legacy elaboration checking mode 3940 -- enabled) is in effect because the legacy ABE mechanism does not need 3941 -- to carry out this action. 3942 3943 if Legacy_Elaboration_Checks then 3944 Finalize_All_Data_Structures; 3945 return; 3946 3947 -- Nothing to do when the elaboration phase of the compiler is not 3948 -- active. 3949 3950 elsif not Elaboration_Phase_Active then 3951 Finalize_All_Data_Structures; 3952 return; 3953 end if; 3954 3955 -- Restore the original elaboration model which was in effect when the 3956 -- scenarios were first recorded. The model may be specified by pragma 3957 -- Elaboration_Checks which appears on the initial declaration of the 3958 -- main unit. 3959 3960 Install_Elaboration_Model (Unit_Entity (Main_Unit_Entity)); 3961 3962 -- Examine the context of the main unit and record all units with prior 3963 -- elaboration with respect to it. 3964 3965 Collect_Elaborated_Units; 3966 3967 -- Examine all scenarios saved during the Recording phase applying the 3968 -- Ada or SPARK elaboration rules in order to detect and diagnose ABE 3969 -- issues, install conditional ABE checks, and ensure the elaboration 3970 -- of units. 3971 3972 Iter := Iterate_Declaration_Scenarios; 3973 Check_Conditional_ABE_Scenarios (Iter); 3974 3975 Iter := Iterate_Library_Body_Scenarios; 3976 Check_Conditional_ABE_Scenarios (Iter); 3977 3978 Iter := Iterate_Library_Spec_Scenarios; 3979 Check_Conditional_ABE_Scenarios (Iter); 3980 3981 -- Examine each SPARK scenario saved during the Recording phase which 3982 -- is not necessarily executable during elaboration, but still requires 3983 -- elaboration-related checks. 3984 3985 Check_SPARK_Scenarios; 3986 3987 -- Add conditional ABE checks for all scenarios that require one when 3988 -- the dynamic model is in effect. 3989 3990 Install_Dynamic_ABE_Checks; 3991 3992 -- Examine all scenarios saved during the Recording phase along with 3993 -- invocation constructs within the spec and body of the main unit. 3994 -- Record the declarations and paths that reach into an external unit 3995 -- in the ALI file of the main unit. 3996 3997 Record_Invocation_Graph; 3998 3999 -- Destroy all internal data structures and complete the elaboration 4000 -- phase of the compiler. 4001 4002 Finalize_All_Data_Structures; 4003 Set_Elaboration_Phase (Completed); 4004 end Check_Elaboration_Scenarios; 4005 4006 --------------------- 4007 -- Check_Installer -- 4008 --------------------- 4009 4010 package body Check_Installer is 4011 4012 ----------------------- 4013 -- Local subprograms -- 4014 ----------------------- 4015 4016 function ABE_Check_Or_Failure_OK 4017 (N : Node_Id; 4018 Targ_Id : Entity_Id; 4019 Unit_Id : Entity_Id) return Boolean; 4020 pragma Inline (ABE_Check_Or_Failure_OK); 4021 -- Determine whether a conditional ABE check or guaranteed ABE failure 4022 -- can be installed for scenario N with target Targ_Id which resides in 4023 -- unit Unit_Id. 4024 4025 function Insertion_Node (N : Node_Id) return Node_Id; 4026 pragma Inline (Insertion_Node); 4027 -- Obtain the proper insertion node of an ABE check or failure for 4028 -- scenario N. 4029 4030 procedure Insert_ABE_Check_Or_Failure (N : Node_Id; Check : Node_Id); 4031 pragma Inline (Insert_ABE_Check_Or_Failure); 4032 -- Insert conditional ABE check or guaranteed ABE failure Check prior to 4033 -- scenario N. 4034 4035 procedure Install_Scenario_ABE_Check_Common 4036 (N : Node_Id; 4037 Targ_Id : Entity_Id; 4038 Targ_Rep : Target_Rep_Id); 4039 pragma Inline (Install_Scenario_ABE_Check_Common); 4040 -- Install a conditional ABE check for scenario N to ensure that target 4041 -- Targ_Id is properly elaborated. Targ_Rep is the representation of the 4042 -- target. 4043 4044 procedure Install_Scenario_ABE_Failure_Common (N : Node_Id); 4045 pragma Inline (Install_Scenario_ABE_Failure_Common); 4046 -- Install a guaranteed ABE failure for scenario N 4047 4048 procedure Install_Unit_ABE_Check_Common 4049 (N : Node_Id; 4050 Unit_Id : Entity_Id); 4051 pragma Inline (Install_Unit_ABE_Check_Common); 4052 -- Install a conditional ABE check for scenario N to ensure that unit 4053 -- Unit_Id is properly elaborated. 4054 4055 ----------------------------- 4056 -- ABE_Check_Or_Failure_OK -- 4057 ----------------------------- 4058 4059 function ABE_Check_Or_Failure_OK 4060 (N : Node_Id; 4061 Targ_Id : Entity_Id; 4062 Unit_Id : Entity_Id) return Boolean 4063 is 4064 pragma Unreferenced (Targ_Id); 4065 4066 Ins_Node : constant Node_Id := Insertion_Node (N); 4067 4068 begin 4069 if not Check_Or_Failure_Generation_OK then 4070 return False; 4071 4072 -- Nothing to do when the scenario denots a compilation unit because 4073 -- there is no executable environment at that level. 4074 4075 elsif Nkind (Parent (Ins_Node)) = N_Compilation_Unit then 4076 return False; 4077 4078 -- An ABE check or failure is not needed when the target is defined 4079 -- in a unit which is elaborated prior to the main unit. This check 4080 -- must also consider the following cases: 4081 -- 4082 -- * The unit of the target appears in the context of the main unit 4083 -- 4084 -- * The unit of the target is subject to pragma Elaborate_Body. An 4085 -- ABE check MUST NOT be generated because the unit is always 4086 -- elaborated prior to the main unit. 4087 -- 4088 -- * The unit of the target is the main unit. An ABE check MUST be 4089 -- added in this case because a conditional ABE may be raised 4090 -- depending on the flow of execution within the main unit (flag 4091 -- Same_Unit_OK is False). 4092 4093 elsif Has_Prior_Elaboration 4094 (Unit_Id => Unit_Id, 4095 Context_OK => True, 4096 Elab_Body_OK => True) 4097 then 4098 return False; 4099 end if; 4100 4101 return True; 4102 end ABE_Check_Or_Failure_OK; 4103 4104 ------------------------------------ 4105 -- Check_Or_Failure_Generation_OK -- 4106 ------------------------------------ 4107 4108 function Check_Or_Failure_Generation_OK return Boolean is 4109 begin 4110 -- An ABE check or failure is not needed when the compilation will 4111 -- not produce an executable. 4112 4113 if Serious_Errors_Detected > 0 then 4114 return False; 4115 4116 -- An ABE check or failure must not be installed when compiling for 4117 -- GNATprove because raise statements are not supported. 4118 4119 elsif GNATprove_Mode then 4120 return False; 4121 end if; 4122 4123 return True; 4124 end Check_Or_Failure_Generation_OK; 4125 4126 -------------------- 4127 -- Insertion_Node -- 4128 -------------------- 4129 4130 function Insertion_Node (N : Node_Id) return Node_Id is 4131 begin 4132 -- When the scenario denotes an instantiation, the proper insertion 4133 -- node is the instance spec. This ensures that the generic actuals 4134 -- will not be evaluated prior to a potential ABE. 4135 4136 if Nkind (N) in N_Generic_Instantiation 4137 and then Present (Instance_Spec (N)) 4138 then 4139 return Instance_Spec (N); 4140 4141 -- Otherwise the proper insertion node is the scenario itself 4142 4143 else 4144 return N; 4145 end if; 4146 end Insertion_Node; 4147 4148 --------------------------------- 4149 -- Insert_ABE_Check_Or_Failure -- 4150 --------------------------------- 4151 4152 procedure Insert_ABE_Check_Or_Failure (N : Node_Id; Check : Node_Id) is 4153 Ins_Nod : constant Node_Id := Insertion_Node (N); 4154 Scop_Id : constant Entity_Id := Find_Enclosing_Scope (Ins_Nod); 4155 4156 begin 4157 -- Install the nearest enclosing scope of the scenario as there must 4158 -- be something on the scope stack. 4159 4160 Push_Scope (Scop_Id); 4161 4162 Insert_Action (Ins_Nod, Check); 4163 4164 Pop_Scope; 4165 end Insert_ABE_Check_Or_Failure; 4166 4167 -------------------------------- 4168 -- Install_Dynamic_ABE_Checks -- 4169 -------------------------------- 4170 4171 procedure Install_Dynamic_ABE_Checks is 4172 Iter : NE_Set.Iterator; 4173 N : Node_Id; 4174 4175 begin 4176 if not Check_Or_Failure_Generation_OK then 4177 return; 4178 4179 -- Nothing to do if the dynamic model is not in effect 4180 4181 elsif not Dynamic_Elaboration_Checks then 4182 return; 4183 end if; 4184 4185 -- Install a conditional ABE check for each saved scenario 4186 4187 Iter := Iterate_Dynamic_ABE_Check_Scenarios; 4188 while NE_Set.Has_Next (Iter) loop 4189 NE_Set.Next (Iter, N); 4190 4191 Process_Conditional_ABE 4192 (N => N, 4193 In_State => Dynamic_Model_State); 4194 end loop; 4195 end Install_Dynamic_ABE_Checks; 4196 4197 -------------------------------- 4198 -- Install_Scenario_ABE_Check -- 4199 -------------------------------- 4200 4201 procedure Install_Scenario_ABE_Check 4202 (N : Node_Id; 4203 Targ_Id : Entity_Id; 4204 Targ_Rep : Target_Rep_Id; 4205 Disable : Scenario_Rep_Id) 4206 is 4207 begin 4208 -- Nothing to do when the scenario does not need an ABE check 4209 4210 if not ABE_Check_Or_Failure_OK 4211 (N => N, 4212 Targ_Id => Targ_Id, 4213 Unit_Id => Unit (Targ_Rep)) 4214 then 4215 return; 4216 end if; 4217 4218 -- Prevent multiple attempts to install the same ABE check 4219 4220 Disable_Elaboration_Checks (Disable); 4221 4222 Install_Scenario_ABE_Check_Common 4223 (N => N, 4224 Targ_Id => Targ_Id, 4225 Targ_Rep => Targ_Rep); 4226 end Install_Scenario_ABE_Check; 4227 4228 -------------------------------- 4229 -- Install_Scenario_ABE_Check -- 4230 -------------------------------- 4231 4232 procedure Install_Scenario_ABE_Check 4233 (N : Node_Id; 4234 Targ_Id : Entity_Id; 4235 Targ_Rep : Target_Rep_Id; 4236 Disable : Target_Rep_Id) 4237 is 4238 begin 4239 -- Nothing to do when the scenario does not need an ABE check 4240 4241 if not ABE_Check_Or_Failure_OK 4242 (N => N, 4243 Targ_Id => Targ_Id, 4244 Unit_Id => Unit (Targ_Rep)) 4245 then 4246 return; 4247 end if; 4248 4249 -- Prevent multiple attempts to install the same ABE check 4250 4251 Disable_Elaboration_Checks (Disable); 4252 4253 Install_Scenario_ABE_Check_Common 4254 (N => N, 4255 Targ_Id => Targ_Id, 4256 Targ_Rep => Targ_Rep); 4257 end Install_Scenario_ABE_Check; 4258 4259 --------------------------------------- 4260 -- Install_Scenario_ABE_Check_Common -- 4261 --------------------------------------- 4262 4263 procedure Install_Scenario_ABE_Check_Common 4264 (N : Node_Id; 4265 Targ_Id : Entity_Id; 4266 Targ_Rep : Target_Rep_Id) 4267 is 4268 Targ_Body : constant Node_Id := Body_Declaration (Targ_Rep); 4269 Targ_Decl : constant Node_Id := Spec_Declaration (Targ_Rep); 4270 4271 pragma Assert (Present (Targ_Body)); 4272 pragma Assert (Present (Targ_Decl)); 4273 4274 procedure Build_Elaboration_Entity; 4275 pragma Inline (Build_Elaboration_Entity); 4276 -- Create a new elaboration flag for Targ_Id, insert it prior to 4277 -- Targ_Decl, and set it after Targ_Body. 4278 4279 ------------------------------ 4280 -- Build_Elaboration_Entity -- 4281 ------------------------------ 4282 4283 procedure Build_Elaboration_Entity is 4284 Loc : constant Source_Ptr := Sloc (Targ_Id); 4285 Flag_Id : Entity_Id; 4286 4287 begin 4288 -- Nothing to do if the target has an elaboration flag 4289 4290 if Present (Elaboration_Entity (Targ_Id)) then 4291 return; 4292 end if; 4293 4294 -- Create the declaration of the elaboration flag. The name 4295 -- carries a unique counter in case the name is overloaded. 4296 4297 Flag_Id := 4298 Make_Defining_Identifier (Loc, 4299 Chars => New_External_Name (Chars (Targ_Id), 'E', -1)); 4300 4301 Set_Elaboration_Entity (Targ_Id, Flag_Id); 4302 Set_Elaboration_Entity_Required (Targ_Id); 4303 4304 Push_Scope (Scope (Targ_Id)); 4305 4306 -- Generate: 4307 -- Enn : Short_Integer := 0; 4308 4309 Insert_Action (Targ_Decl, 4310 Make_Object_Declaration (Loc, 4311 Defining_Identifier => Flag_Id, 4312 Object_Definition => 4313 New_Occurrence_Of (Standard_Short_Integer, Loc), 4314 Expression => Make_Integer_Literal (Loc, Uint_0))); 4315 4316 -- Generate: 4317 -- Enn := 1; 4318 4319 Set_Elaboration_Flag (Targ_Body, Targ_Id); 4320 4321 Pop_Scope; 4322 end Build_Elaboration_Entity; 4323 4324 -- Local variables 4325 4326 Loc : constant Source_Ptr := Sloc (N); 4327 4328 -- Start for processing for Install_Scenario_ABE_Check_Common 4329 4330 begin 4331 -- Create an elaboration flag for the target when it does not have 4332 -- one. 4333 4334 Build_Elaboration_Entity; 4335 4336 -- Generate: 4337 -- if not Targ_Id'Elaborated then 4338 -- raise Program_Error with "access before elaboration"; 4339 -- end if; 4340 4341 Insert_ABE_Check_Or_Failure 4342 (N => N, 4343 Check => 4344 Make_Raise_Program_Error (Loc, 4345 Condition => 4346 Make_Op_Not (Loc, 4347 Right_Opnd => 4348 Make_Attribute_Reference (Loc, 4349 Prefix => New_Occurrence_Of (Targ_Id, Loc), 4350 Attribute_Name => Name_Elaborated)), 4351 Reason => PE_Access_Before_Elaboration)); 4352 end Install_Scenario_ABE_Check_Common; 4353 4354 ---------------------------------- 4355 -- Install_Scenario_ABE_Failure -- 4356 ---------------------------------- 4357 4358 procedure Install_Scenario_ABE_Failure 4359 (N : Node_Id; 4360 Targ_Id : Entity_Id; 4361 Targ_Rep : Target_Rep_Id; 4362 Disable : Scenario_Rep_Id) 4363 is 4364 begin 4365 -- Nothing to do when the scenario does not require an ABE failure 4366 4367 if not ABE_Check_Or_Failure_OK 4368 (N => N, 4369 Targ_Id => Targ_Id, 4370 Unit_Id => Unit (Targ_Rep)) 4371 then 4372 return; 4373 end if; 4374 4375 -- Prevent multiple attempts to install the same ABE check 4376 4377 Disable_Elaboration_Checks (Disable); 4378 4379 Install_Scenario_ABE_Failure_Common (N); 4380 end Install_Scenario_ABE_Failure; 4381 4382 ---------------------------------- 4383 -- Install_Scenario_ABE_Failure -- 4384 ---------------------------------- 4385 4386 procedure Install_Scenario_ABE_Failure 4387 (N : Node_Id; 4388 Targ_Id : Entity_Id; 4389 Targ_Rep : Target_Rep_Id; 4390 Disable : Target_Rep_Id) 4391 is 4392 begin 4393 -- Nothing to do when the scenario does not require an ABE failure 4394 4395 if not ABE_Check_Or_Failure_OK 4396 (N => N, 4397 Targ_Id => Targ_Id, 4398 Unit_Id => Unit (Targ_Rep)) 4399 then 4400 return; 4401 end if; 4402 4403 -- Prevent multiple attempts to install the same ABE check 4404 4405 Disable_Elaboration_Checks (Disable); 4406 4407 Install_Scenario_ABE_Failure_Common (N); 4408 end Install_Scenario_ABE_Failure; 4409 4410 ----------------------------------------- 4411 -- Install_Scenario_ABE_Failure_Common -- 4412 ----------------------------------------- 4413 4414 procedure Install_Scenario_ABE_Failure_Common (N : Node_Id) is 4415 Loc : constant Source_Ptr := Sloc (N); 4416 4417 begin 4418 -- Generate: 4419 -- raise Program_Error with "access before elaboration"; 4420 4421 Insert_ABE_Check_Or_Failure 4422 (N => N, 4423 Check => 4424 Make_Raise_Program_Error (Loc, 4425 Reason => PE_Access_Before_Elaboration)); 4426 end Install_Scenario_ABE_Failure_Common; 4427 4428 ---------------------------- 4429 -- Install_Unit_ABE_Check -- 4430 ---------------------------- 4431 4432 procedure Install_Unit_ABE_Check 4433 (N : Node_Id; 4434 Unit_Id : Entity_Id; 4435 Disable : Scenario_Rep_Id) 4436 is 4437 Spec_Id : constant Entity_Id := Unique_Entity (Unit_Id); 4438 4439 begin 4440 -- Nothing to do when the scenario does not require an ABE check 4441 4442 if not ABE_Check_Or_Failure_OK 4443 (N => N, 4444 Targ_Id => Empty, 4445 Unit_Id => Spec_Id) 4446 then 4447 return; 4448 end if; 4449 4450 -- Prevent multiple attempts to install the same ABE check 4451 4452 Disable_Elaboration_Checks (Disable); 4453 4454 Install_Unit_ABE_Check_Common 4455 (N => N, 4456 Unit_Id => Unit_Id); 4457 end Install_Unit_ABE_Check; 4458 4459 ---------------------------- 4460 -- Install_Unit_ABE_Check -- 4461 ---------------------------- 4462 4463 procedure Install_Unit_ABE_Check 4464 (N : Node_Id; 4465 Unit_Id : Entity_Id; 4466 Disable : Target_Rep_Id) 4467 is 4468 Spec_Id : constant Entity_Id := Unique_Entity (Unit_Id); 4469 4470 begin 4471 -- Nothing to do when the scenario does not require an ABE check 4472 4473 if not ABE_Check_Or_Failure_OK 4474 (N => N, 4475 Targ_Id => Empty, 4476 Unit_Id => Spec_Id) 4477 then 4478 return; 4479 end if; 4480 4481 -- Prevent multiple attempts to install the same ABE check 4482 4483 Disable_Elaboration_Checks (Disable); 4484 4485 Install_Unit_ABE_Check_Common 4486 (N => N, 4487 Unit_Id => Unit_Id); 4488 end Install_Unit_ABE_Check; 4489 4490 ----------------------------------- 4491 -- Install_Unit_ABE_Check_Common -- 4492 ----------------------------------- 4493 4494 procedure Install_Unit_ABE_Check_Common 4495 (N : Node_Id; 4496 Unit_Id : Entity_Id) 4497 is 4498 Loc : constant Source_Ptr := Sloc (N); 4499 Spec_Id : constant Entity_Id := Unique_Entity (Unit_Id); 4500 4501 begin 4502 -- Generate: 4503 -- if not Spec_Id'Elaborated then 4504 -- raise Program_Error with "access before elaboration"; 4505 -- end if; 4506 4507 Insert_ABE_Check_Or_Failure 4508 (N => N, 4509 Check => 4510 Make_Raise_Program_Error (Loc, 4511 Condition => 4512 Make_Op_Not (Loc, 4513 Right_Opnd => 4514 Make_Attribute_Reference (Loc, 4515 Prefix => New_Occurrence_Of (Spec_Id, Loc), 4516 Attribute_Name => Name_Elaborated)), 4517 Reason => PE_Access_Before_Elaboration)); 4518 end Install_Unit_ABE_Check_Common; 4519 end Check_Installer; 4520 4521 ---------------------- 4522 -- Compilation_Unit -- 4523 ---------------------- 4524 4525 function Compilation_Unit (Unit_Id : Entity_Id) return Node_Id is 4526 Comp_Unit : Node_Id; 4527 4528 begin 4529 Comp_Unit := Parent (Unit_Id); 4530 4531 -- Handle the case where a concurrent subunit is rewritten as a null 4532 -- statement due to expansion activities. 4533 4534 if Nkind (Comp_Unit) = N_Null_Statement 4535 and then Nkind (Original_Node (Comp_Unit)) in 4536 N_Protected_Body | N_Task_Body 4537 then 4538 Comp_Unit := Parent (Comp_Unit); 4539 pragma Assert (Nkind (Comp_Unit) = N_Subunit); 4540 4541 -- Otherwise use the declaration node of the unit 4542 4543 else 4544 Comp_Unit := Parent (Unit_Declaration_Node (Unit_Id)); 4545 end if; 4546 4547 -- Handle the case where a subprogram instantiation which acts as a 4548 -- compilation unit is expanded into an anonymous package that wraps 4549 -- the instantiated subprogram. 4550 4551 if Nkind (Comp_Unit) = N_Package_Specification 4552 and then Nkind (Original_Node (Parent (Comp_Unit))) in 4553 N_Function_Instantiation | N_Procedure_Instantiation 4554 then 4555 Comp_Unit := Parent (Parent (Comp_Unit)); 4556 4557 -- Handle the case where the compilation unit is a subunit 4558 4559 elsif Nkind (Comp_Unit) = N_Subunit then 4560 Comp_Unit := Parent (Comp_Unit); 4561 end if; 4562 4563 pragma Assert (Nkind (Comp_Unit) = N_Compilation_Unit); 4564 4565 return Comp_Unit; 4566 end Compilation_Unit; 4567 4568 ------------------------------- 4569 -- Conditional_ABE_Processor -- 4570 ------------------------------- 4571 4572 package body Conditional_ABE_Processor is 4573 4574 ----------------------- 4575 -- Local subprograms -- 4576 ----------------------- 4577 4578 function Is_Conditional_ABE_Scenario (N : Node_Id) return Boolean; 4579 pragma Inline (Is_Conditional_ABE_Scenario); 4580 -- Determine whether node N is a suitable scenario for conditional ABE 4581 -- checks and diagnostics. 4582 4583 procedure Process_Conditional_ABE_Access_Taken 4584 (Attr : Node_Id; 4585 Attr_Rep : Scenario_Rep_Id; 4586 In_State : Processing_In_State); 4587 pragma Inline (Process_Conditional_ABE_Access_Taken); 4588 -- Perform ABE checks and diagnostics for attribute reference Attr with 4589 -- representation Attr_Rep which takes 'Access of an entry, operator, or 4590 -- subprogram. In_State is the current state of the Processing phase. 4591 4592 procedure Process_Conditional_ABE_Activation 4593 (Call : Node_Id; 4594 Call_Rep : Scenario_Rep_Id; 4595 Obj_Id : Entity_Id; 4596 Obj_Rep : Target_Rep_Id; 4597 Task_Typ : Entity_Id; 4598 Task_Rep : Target_Rep_Id; 4599 In_State : Processing_In_State); 4600 pragma Inline (Process_Conditional_ABE_Activation); 4601 -- Perform common conditional ABE checks and diagnostics for activation 4602 -- call Call which activates object Obj_Id of task type Task_Typ. Formal 4603 -- Call_Rep denotes the representation of the call. Obj_Rep denotes the 4604 -- representation of the object. Task_Rep denotes the representation of 4605 -- the task type. In_State is the current state of the Processing phase. 4606 4607 procedure Process_Conditional_ABE_Call 4608 (Call : Node_Id; 4609 Call_Rep : Scenario_Rep_Id; 4610 In_State : Processing_In_State); 4611 pragma Inline (Process_Conditional_ABE_Call); 4612 -- Top-level dispatcher for processing of calls. Perform ABE checks and 4613 -- diagnostics for call Call with representation Call_Rep. In_State is 4614 -- the current state of the Processing phase. 4615 4616 procedure Process_Conditional_ABE_Call_Ada 4617 (Call : Node_Id; 4618 Call_Rep : Scenario_Rep_Id; 4619 Subp_Id : Entity_Id; 4620 Subp_Rep : Target_Rep_Id; 4621 In_State : Processing_In_State); 4622 pragma Inline (Process_Conditional_ABE_Call_Ada); 4623 -- Perform ABE checks and diagnostics for call Call which invokes entry, 4624 -- operator, or subprogram Subp_Id using the Ada rules. Call_Rep denotes 4625 -- the representation of the call. Subp_Rep denotes the representation 4626 -- of the subprogram. In_State is the current state of the Processing 4627 -- phase. 4628 4629 procedure Process_Conditional_ABE_Call_SPARK 4630 (Call : Node_Id; 4631 Call_Rep : Scenario_Rep_Id; 4632 Subp_Id : Entity_Id; 4633 Subp_Rep : Target_Rep_Id; 4634 In_State : Processing_In_State); 4635 pragma Inline (Process_Conditional_ABE_Call_SPARK); 4636 -- Perform ABE checks and diagnostics for call Call which invokes entry, 4637 -- operator, or subprogram Subp_Id using the SPARK rules. Call_Rep is 4638 -- the representation of the call. Subp_Rep denotes the representation 4639 -- of the subprogram. In_State is the current state of the Processing 4640 -- phase. 4641 4642 procedure Process_Conditional_ABE_Instantiation 4643 (Inst : Node_Id; 4644 Inst_Rep : Scenario_Rep_Id; 4645 In_State : Processing_In_State); 4646 pragma Inline (Process_Conditional_ABE_Instantiation); 4647 -- Top-level dispatcher for processing of instantiations. Perform ABE 4648 -- checks and diagnostics for instantiation Inst with representation 4649 -- Inst_Rep. In_State is the current state of the Processing phase. 4650 4651 procedure Process_Conditional_ABE_Instantiation_Ada 4652 (Inst : Node_Id; 4653 Inst_Rep : Scenario_Rep_Id; 4654 Gen_Id : Entity_Id; 4655 Gen_Rep : Target_Rep_Id; 4656 In_State : Processing_In_State); 4657 pragma Inline (Process_Conditional_ABE_Instantiation_Ada); 4658 -- Perform ABE checks and diagnostics for instantiation Inst of generic 4659 -- Gen_Id using the Ada rules. Inst_Rep denotes the representation of 4660 -- the instnace. Gen_Rep is the representation of the generic. In_State 4661 -- is the current state of the Processing phase. 4662 4663 procedure Process_Conditional_ABE_Instantiation_SPARK 4664 (Inst : Node_Id; 4665 Inst_Rep : Scenario_Rep_Id; 4666 Gen_Id : Entity_Id; 4667 Gen_Rep : Target_Rep_Id; 4668 In_State : Processing_In_State); 4669 pragma Inline (Process_Conditional_ABE_Instantiation_SPARK); 4670 -- Perform ABE checks and diagnostics for instantiation Inst of generic 4671 -- Gen_Id using the SPARK rules. Inst_Rep denotes the representation of 4672 -- the instnace. Gen_Rep is the representation of the generic. In_State 4673 -- is the current state of the Processing phase. 4674 4675 procedure Process_Conditional_ABE_Variable_Assignment 4676 (Asmt : Node_Id; 4677 Asmt_Rep : Scenario_Rep_Id; 4678 In_State : Processing_In_State); 4679 pragma Inline (Process_Conditional_ABE_Variable_Assignment); 4680 -- Top-level dispatcher for processing of variable assignments. Perform 4681 -- ABE checks and diagnostics for assignment Asmt with representation 4682 -- Asmt_Rep. In_State denotes the current state of the Processing phase. 4683 4684 procedure Process_Conditional_ABE_Variable_Assignment_Ada 4685 (Asmt : Node_Id; 4686 Asmt_Rep : Scenario_Rep_Id; 4687 Var_Id : Entity_Id; 4688 Var_Rep : Target_Rep_Id; 4689 In_State : Processing_In_State); 4690 pragma Inline (Process_Conditional_ABE_Variable_Assignment_Ada); 4691 -- Perform ABE checks and diagnostics for assignment statement Asmt that 4692 -- modifies the value of variable Var_Id using the Ada rules. Asmt_Rep 4693 -- denotes the representation of the assignment. Var_Rep denotes the 4694 -- representation of the variable. In_State is the current state of the 4695 -- Processing phase. 4696 4697 procedure Process_Conditional_ABE_Variable_Assignment_SPARK 4698 (Asmt : Node_Id; 4699 Asmt_Rep : Scenario_Rep_Id; 4700 Var_Id : Entity_Id; 4701 Var_Rep : Target_Rep_Id; 4702 In_State : Processing_In_State); 4703 pragma Inline (Process_Conditional_ABE_Variable_Assignment_SPARK); 4704 -- Perform ABE checks and diagnostics for assignment statement Asmt that 4705 -- modifies the value of variable Var_Id using the SPARK rules. Asmt_Rep 4706 -- denotes the representation of the assignment. Var_Rep denotes the 4707 -- representation of the variable. In_State is the current state of the 4708 -- Processing phase. 4709 4710 procedure Process_Conditional_ABE_Variable_Reference 4711 (Ref : Node_Id; 4712 Ref_Rep : Scenario_Rep_Id; 4713 In_State : Processing_In_State); 4714 pragma Inline (Process_Conditional_ABE_Variable_Reference); 4715 -- Perform ABE checks and diagnostics for variable reference Ref with 4716 -- representation Ref_Rep. In_State denotes the current state of the 4717 -- Processing phase. 4718 4719 procedure Traverse_Conditional_ABE_Body 4720 (N : Node_Id; 4721 In_State : Processing_In_State); 4722 pragma Inline (Traverse_Conditional_ABE_Body); 4723 -- Traverse subprogram body N looking for suitable scenarios that need 4724 -- to be processed for conditional ABE checks and diagnostics. In_State 4725 -- is the current state of the Processing phase. 4726 4727 ------------------------------------- 4728 -- Check_Conditional_ABE_Scenarios -- 4729 ------------------------------------- 4730 4731 procedure Check_Conditional_ABE_Scenarios 4732 (Iter : in out NE_Set.Iterator) 4733 is 4734 N : Node_Id; 4735 4736 begin 4737 while NE_Set.Has_Next (Iter) loop 4738 NE_Set.Next (Iter, N); 4739 4740 -- Reset the traversed status of all subprogram bodies because the 4741 -- current conditional scenario acts as a new DFS traversal root. 4742 4743 Reset_Traversed_Bodies; 4744 4745 Process_Conditional_ABE 4746 (N => N, 4747 In_State => Conditional_ABE_State); 4748 end loop; 4749 end Check_Conditional_ABE_Scenarios; 4750 4751 --------------------------------- 4752 -- Is_Conditional_ABE_Scenario -- 4753 --------------------------------- 4754 4755 function Is_Conditional_ABE_Scenario (N : Node_Id) return Boolean is 4756 begin 4757 return 4758 Is_Suitable_Access_Taken (N) 4759 or else Is_Suitable_Call (N) 4760 or else Is_Suitable_Instantiation (N) 4761 or else Is_Suitable_Variable_Assignment (N) 4762 or else Is_Suitable_Variable_Reference (N); 4763 end Is_Conditional_ABE_Scenario; 4764 4765 ----------------------------- 4766 -- Process_Conditional_ABE -- 4767 ----------------------------- 4768 4769 procedure Process_Conditional_ABE 4770 (N : Node_Id; 4771 In_State : Processing_In_State) 4772 is 4773 Scen : constant Node_Id := Scenario (N); 4774 Scen_Rep : Scenario_Rep_Id; 4775 4776 begin 4777 -- Add the current scenario to the stack of active scenarios 4778 4779 Push_Active_Scenario (Scen); 4780 4781 -- 'Access 4782 4783 if Is_Suitable_Access_Taken (Scen) then 4784 Process_Conditional_ABE_Access_Taken 4785 (Attr => Scen, 4786 Attr_Rep => Scenario_Representation_Of (Scen, In_State), 4787 In_State => In_State); 4788 4789 -- Call or task activation 4790 4791 elsif Is_Suitable_Call (Scen) then 4792 Scen_Rep := Scenario_Representation_Of (Scen, In_State); 4793 4794 -- Routine Build_Call_Marker creates call markers regardless of 4795 -- whether the call occurs within the main unit or not. This way 4796 -- the serialization of internal names is kept consistent. Only 4797 -- call markers found within the main unit must be processed. 4798 4799 if In_Main_Context (Scen) then 4800 Scen_Rep := Scenario_Representation_Of (Scen, In_State); 4801 4802 if Kind (Scen_Rep) = Call_Scenario then 4803 Process_Conditional_ABE_Call 4804 (Call => Scen, 4805 Call_Rep => Scen_Rep, 4806 In_State => In_State); 4807 4808 else 4809 pragma Assert (Kind (Scen_Rep) = Task_Activation_Scenario); 4810 4811 Process_Activation 4812 (Call => Scen, 4813 Call_Rep => Scen_Rep, 4814 Processor => Process_Conditional_ABE_Activation'Access, 4815 In_State => In_State); 4816 end if; 4817 end if; 4818 4819 -- Instantiation 4820 4821 elsif Is_Suitable_Instantiation (Scen) then 4822 Process_Conditional_ABE_Instantiation 4823 (Inst => Scen, 4824 Inst_Rep => Scenario_Representation_Of (Scen, In_State), 4825 In_State => In_State); 4826 4827 -- Variable assignments 4828 4829 elsif Is_Suitable_Variable_Assignment (Scen) then 4830 Process_Conditional_ABE_Variable_Assignment 4831 (Asmt => Scen, 4832 Asmt_Rep => Scenario_Representation_Of (Scen, In_State), 4833 In_State => In_State); 4834 4835 -- Variable references 4836 4837 elsif Is_Suitable_Variable_Reference (Scen) then 4838 4839 -- Routine Build_Variable_Reference_Marker makes variable markers 4840 -- regardless of whether the reference occurs within the main unit 4841 -- or not. This way the serialization of internal names is kept 4842 -- consistent. Only variable markers within the main unit must be 4843 -- processed. 4844 4845 if In_Main_Context (Scen) then 4846 Process_Conditional_ABE_Variable_Reference 4847 (Ref => Scen, 4848 Ref_Rep => Scenario_Representation_Of (Scen, In_State), 4849 In_State => In_State); 4850 end if; 4851 end if; 4852 4853 -- Remove the current scenario from the stack of active scenarios 4854 -- once all ABE diagnostics and checks have been performed. 4855 4856 Pop_Active_Scenario (Scen); 4857 end Process_Conditional_ABE; 4858 4859 ------------------------------------------ 4860 -- Process_Conditional_ABE_Access_Taken -- 4861 ------------------------------------------ 4862 4863 procedure Process_Conditional_ABE_Access_Taken 4864 (Attr : Node_Id; 4865 Attr_Rep : Scenario_Rep_Id; 4866 In_State : Processing_In_State) 4867 is 4868 function Build_Access_Marker (Subp_Id : Entity_Id) return Node_Id; 4869 pragma Inline (Build_Access_Marker); 4870 -- Create a suitable call marker which invokes subprogram Subp_Id 4871 4872 ------------------------- 4873 -- Build_Access_Marker -- 4874 ------------------------- 4875 4876 function Build_Access_Marker (Subp_Id : Entity_Id) return Node_Id is 4877 Marker : Node_Id; 4878 4879 begin 4880 Marker := Make_Call_Marker (Sloc (Attr)); 4881 4882 -- Inherit relevant attributes from the attribute 4883 4884 Set_Target (Marker, Subp_Id); 4885 Set_Is_Declaration_Level_Node 4886 (Marker, Level (Attr_Rep) = Declaration_Level); 4887 Set_Is_Dispatching_Call 4888 (Marker, False); 4889 Set_Is_Elaboration_Checks_OK_Node 4890 (Marker, Elaboration_Checks_OK (Attr_Rep)); 4891 Set_Is_Elaboration_Warnings_OK_Node 4892 (Marker, Elaboration_Warnings_OK (Attr_Rep)); 4893 Set_Is_Preelaborable_Call 4894 (Marker, False); 4895 Set_Is_Source_Call 4896 (Marker, Comes_From_Source (Attr)); 4897 Set_Is_SPARK_Mode_On_Node 4898 (Marker, SPARK_Mode_Of (Attr_Rep) = Is_On); 4899 4900 -- Partially insert the call marker into the tree by setting its 4901 -- parent pointer. 4902 4903 Set_Parent (Marker, Attr); 4904 4905 return Marker; 4906 end Build_Access_Marker; 4907 4908 -- Local variables 4909 4910 Root : constant Node_Id := Root_Scenario; 4911 Subp_Id : constant Entity_Id := Target (Attr_Rep); 4912 Subp_Rep : constant Target_Rep_Id := 4913 Target_Representation_Of (Subp_Id, In_State); 4914 Body_Decl : constant Node_Id := Body_Declaration (Subp_Rep); 4915 4916 New_In_State : Processing_In_State := In_State; 4917 -- Each step of the Processing phase constitutes a new state 4918 4919 -- Start of processing for Process_Conditional_ABE_Access 4920 4921 begin 4922 -- Output relevant information when switch -gnatel (info messages on 4923 -- implicit Elaborate[_All] pragmas) is in effect. 4924 4925 if Elab_Info_Messages 4926 and then not New_In_State.Suppress_Info_Messages 4927 then 4928 Error_Msg_NE 4929 ("info: access to & during elaboration", Attr, Subp_Id); 4930 end if; 4931 4932 -- Warnings are suppressed when a prior scenario is already in that 4933 -- mode or when the attribute or the target have warnings suppressed. 4934 -- Update the state of the Processing phase to reflect this. 4935 4936 New_In_State.Suppress_Warnings := 4937 New_In_State.Suppress_Warnings 4938 or else not Elaboration_Warnings_OK (Attr_Rep) 4939 or else not Elaboration_Warnings_OK (Subp_Rep); 4940 4941 -- Do not emit any ABE diagnostics when the current or previous 4942 -- scenario in this traversal has suppressed elaboration warnings. 4943 4944 if New_In_State.Suppress_Warnings then 4945 null; 4946 4947 -- Both the attribute and the corresponding subprogram body are in 4948 -- the same unit. The body must appear prior to the root scenario 4949 -- which started the recursive search. If this is not the case, then 4950 -- there is a potential ABE if the access value is used to call the 4951 -- subprogram. Emit a warning only when switch -gnatw.f (warnings on 4952 -- suspucious 'Access) is in effect. 4953 4954 elsif Warn_On_Elab_Access 4955 and then Present (Body_Decl) 4956 and then In_Extended_Main_Code_Unit (Body_Decl) 4957 and then Earlier_In_Extended_Unit (Root, Body_Decl) 4958 then 4959 Error_Msg_Name_1 := Attribute_Name (Attr); 4960 Error_Msg_NE 4961 ("??% attribute of & before body seen", Attr, Subp_Id); 4962 Error_Msg_N ("\possible Program_Error on later references", Attr); 4963 4964 Output_Active_Scenarios (Attr, New_In_State); 4965 end if; 4966 4967 -- Treat the attribute an immediate invocation of the target when 4968 -- switch -gnatd.o (conservative elaboration order for indirect 4969 -- calls) is in effect. This has the following desirable effects: 4970 -- 4971 -- * Ensure that the unit with the corresponding body is elaborated 4972 -- prior to the main unit. 4973 -- 4974 -- * Perform conditional ABE checks and diagnostics 4975 -- 4976 -- * Traverse the body of the target (if available) 4977 4978 if Debug_Flag_Dot_O then 4979 Process_Conditional_ABE 4980 (N => Build_Access_Marker (Subp_Id), 4981 In_State => New_In_State); 4982 4983 -- Otherwise ensure that the unit with the corresponding body is 4984 -- elaborated prior to the main unit. 4985 4986 else 4987 Ensure_Prior_Elaboration 4988 (N => Attr, 4989 Unit_Id => Unit (Subp_Rep), 4990 Prag_Nam => Name_Elaborate_All, 4991 In_State => New_In_State); 4992 end if; 4993 end Process_Conditional_ABE_Access_Taken; 4994 4995 ---------------------------------------- 4996 -- Process_Conditional_ABE_Activation -- 4997 ---------------------------------------- 4998 4999 procedure Process_Conditional_ABE_Activation 5000 (Call : Node_Id; 5001 Call_Rep : Scenario_Rep_Id; 5002 Obj_Id : Entity_Id; 5003 Obj_Rep : Target_Rep_Id; 5004 Task_Typ : Entity_Id; 5005 Task_Rep : Target_Rep_Id; 5006 In_State : Processing_In_State) 5007 is 5008 pragma Unreferenced (Task_Typ); 5009 5010 Body_Decl : constant Node_Id := Body_Declaration (Task_Rep); 5011 Spec_Decl : constant Node_Id := Spec_Declaration (Task_Rep); 5012 Root : constant Node_Id := Root_Scenario; 5013 Unit_Id : constant Node_Id := Unit (Task_Rep); 5014 5015 Check_OK : constant Boolean := 5016 not In_State.Suppress_Checks 5017 and then Ghost_Mode_Of (Obj_Rep) /= Is_Ignored 5018 and then Ghost_Mode_Of (Task_Rep) /= Is_Ignored 5019 and then Elaboration_Checks_OK (Obj_Rep) 5020 and then Elaboration_Checks_OK (Task_Rep); 5021 -- A run-time ABE check may be installed only when the object and the 5022 -- task type have active elaboration checks, and both are not ignored 5023 -- Ghost constructs. 5024 5025 New_In_State : Processing_In_State := In_State; 5026 -- Each step of the Processing phase constitutes a new state 5027 5028 begin 5029 -- Output relevant information when switch -gnatel (info messages on 5030 -- implicit Elaborate[_All] pragmas) is in effect. 5031 5032 if Elab_Info_Messages 5033 and then not New_In_State.Suppress_Info_Messages 5034 then 5035 Error_Msg_NE 5036 ("info: activation of & during elaboration", Call, Obj_Id); 5037 end if; 5038 5039 -- Nothing to do when the call activates a task whose type is defined 5040 -- within an instance and switch -gnatd_i (ignore activations and 5041 -- calls to instances for elaboration) is in effect. 5042 5043 if Debug_Flag_Underscore_I 5044 and then In_External_Instance 5045 (N => Call, 5046 Target_Decl => Spec_Decl) 5047 then 5048 return; 5049 5050 -- Nothing to do when the activation is a guaranteed ABE 5051 5052 elsif Is_Known_Guaranteed_ABE (Call) then 5053 return; 5054 5055 -- Nothing to do when the root scenario appears at the declaration 5056 -- level and the task is in the same unit, but outside this context. 5057 -- 5058 -- task type Task_Typ; -- task declaration 5059 -- 5060 -- procedure Proc is 5061 -- function A ... is 5062 -- begin 5063 -- if Some_Condition then 5064 -- declare 5065 -- T : Task_Typ; 5066 -- begin 5067 -- <activation call> -- activation site 5068 -- end; 5069 -- ... 5070 -- end A; 5071 -- 5072 -- X : ... := A; -- root scenario 5073 -- ... 5074 -- 5075 -- task body Task_Typ is 5076 -- ... 5077 -- end Task_Typ; 5078 -- 5079 -- In the example above, the context of X is the declarative list of 5080 -- Proc. The "elaboration" of X may reach the activation of T whose 5081 -- body is defined outside of X's context. The task body is relevant 5082 -- only when Proc is invoked, but this happens only during "normal" 5083 -- elaboration, therefore the task body must not be considered if 5084 -- this is not the case. 5085 5086 elsif Is_Up_Level_Target 5087 (Targ_Decl => Spec_Decl, 5088 In_State => New_In_State) 5089 then 5090 return; 5091 5092 -- Nothing to do when the activation is ABE-safe 5093 -- 5094 -- generic 5095 -- package Gen is 5096 -- task type Task_Typ; 5097 -- end Gen; 5098 -- 5099 -- package body Gen is 5100 -- task body Task_Typ is 5101 -- begin 5102 -- ... 5103 -- end Task_Typ; 5104 -- end Gen; 5105 -- 5106 -- with Gen; 5107 -- procedure Main is 5108 -- package Nested is 5109 -- package Inst is new Gen; 5110 -- T : Inst.Task_Typ; 5111 -- <activation call> -- safe activation 5112 -- end Nested; 5113 -- ... 5114 5115 elsif Is_Safe_Activation (Call, Task_Rep) then 5116 5117 -- Note that the task body must still be examined for any nested 5118 -- scenarios. 5119 5120 null; 5121 5122 -- The activation call and the task body are both in the main unit 5123 -- 5124 -- If the root scenario appears prior to the task body, then this is 5125 -- a possible ABE with respect to the root scenario. 5126 -- 5127 -- task type Task_Typ; 5128 -- 5129 -- function A ... is 5130 -- begin 5131 -- if Some_Condition then 5132 -- declare 5133 -- package Pack is 5134 -- T : Task_Typ; 5135 -- end Pack; -- activation of T 5136 -- ... 5137 -- end A; 5138 -- 5139 -- X : ... := A; -- root scenario 5140 -- 5141 -- task body Task_Typ is -- task body 5142 -- ... 5143 -- end Task_Typ; 5144 -- 5145 -- Y : ... := A; -- root scenario 5146 -- 5147 -- IMPORTANT: The activation of T is a possible ABE for X, but 5148 -- not for Y. Intalling an unconditional ABE raise prior to the 5149 -- activation call would be wrong as it will fail for Y as well 5150 -- but in Y's case the activation of T is never an ABE. 5151 5152 elsif Present (Body_Decl) 5153 and then In_Extended_Main_Code_Unit (Body_Decl) 5154 then 5155 if Earlier_In_Extended_Unit (Root, Body_Decl) then 5156 5157 -- Do not emit any ABE diagnostics when a previous scenario in 5158 -- this traversal has suppressed elaboration warnings. 5159 5160 if New_In_State.Suppress_Warnings then 5161 null; 5162 5163 -- Do not emit any ABE diagnostics when the activation occurs 5164 -- in a partial finalization context because this action leads 5165 -- to confusing noise. 5166 5167 elsif New_In_State.Within_Partial_Finalization then 5168 null; 5169 5170 -- Otherwise emit the ABE disgnostic 5171 5172 else 5173 Error_Msg_Sloc := Sloc (Call); 5174 Error_Msg_N 5175 ("??task & will be activated # before elaboration of its " 5176 & "body", Obj_Id); 5177 Error_Msg_N 5178 ("\Program_Error may be raised at run time", Obj_Id); 5179 5180 Output_Active_Scenarios (Obj_Id, New_In_State); 5181 end if; 5182 5183 -- Install a conditional run-time ABE check to verify that the 5184 -- task body has been elaborated prior to the activation call. 5185 5186 if Check_OK then 5187 Install_Scenario_ABE_Check 5188 (N => Call, 5189 Targ_Id => Defining_Entity (Spec_Decl), 5190 Targ_Rep => Task_Rep, 5191 Disable => Obj_Rep); 5192 5193 -- Update the state of the Processing phase to indicate that 5194 -- no implicit Elaborate[_All] pragma must be generated from 5195 -- this point on. 5196 -- 5197 -- task type Task_Typ; 5198 -- 5199 -- function A ... is 5200 -- begin 5201 -- if Some_Condition then 5202 -- declare 5203 -- package Pack is 5204 -- <ABE check> 5205 -- T : Task_Typ; 5206 -- end Pack; -- activation of T 5207 -- ... 5208 -- end A; 5209 -- 5210 -- X : ... := A; 5211 -- 5212 -- task body Task_Typ is 5213 -- begin 5214 -- External.Subp; -- imparts Elaborate_All 5215 -- end Task_Typ; 5216 -- 5217 -- If Some_Condition is True, then the ABE check will fail 5218 -- at runtime and the call to External.Subp will never take 5219 -- place, rendering the implicit Elaborate_All useless. 5220 -- 5221 -- If the value of Some_Condition is False, then the call 5222 -- to External.Subp will never take place, rendering the 5223 -- implicit Elaborate_All useless. 5224 5225 New_In_State.Suppress_Implicit_Pragmas := True; 5226 end if; 5227 end if; 5228 5229 -- Otherwise the task body is not available in this compilation or 5230 -- it resides in an external unit. Install a run-time ABE check to 5231 -- verify that the task body has been elaborated prior to the 5232 -- activation call when the dynamic model is in effect. 5233 5234 elsif Check_OK 5235 and then New_In_State.Processing = Dynamic_Model_Processing 5236 then 5237 Install_Unit_ABE_Check 5238 (N => Call, 5239 Unit_Id => Unit_Id, 5240 Disable => Obj_Rep); 5241 end if; 5242 5243 -- Both the activation call and task type are subject to SPARK_Mode 5244 -- On, this triggers the SPARK rules for task activation. Compared 5245 -- to calls and instantiations, task activation in SPARK does not 5246 -- require the presence of Elaborate[_All] pragmas in case the task 5247 -- type is defined outside the main unit. This is because SPARK uses 5248 -- a special policy which activates all tasks after the main unit has 5249 -- finished its elaboration. 5250 5251 if SPARK_Mode_Of (Call_Rep) = Is_On 5252 and then SPARK_Mode_Of (Task_Rep) = Is_On 5253 then 5254 null; 5255 5256 -- Otherwise the Ada rules are in effect. Ensure that the unit with 5257 -- the task body is elaborated prior to the main unit. 5258 5259 else 5260 Ensure_Prior_Elaboration 5261 (N => Call, 5262 Unit_Id => Unit_Id, 5263 Prag_Nam => Name_Elaborate_All, 5264 In_State => New_In_State); 5265 end if; 5266 5267 Traverse_Conditional_ABE_Body 5268 (N => Body_Decl, 5269 In_State => New_In_State); 5270 end Process_Conditional_ABE_Activation; 5271 5272 ---------------------------------- 5273 -- Process_Conditional_ABE_Call -- 5274 ---------------------------------- 5275 5276 procedure Process_Conditional_ABE_Call 5277 (Call : Node_Id; 5278 Call_Rep : Scenario_Rep_Id; 5279 In_State : Processing_In_State) 5280 is 5281 function In_Initialization_Context (N : Node_Id) return Boolean; 5282 pragma Inline (In_Initialization_Context); 5283 -- Determine whether arbitrary node N appears within a type init 5284 -- proc, primitive [Deep_]Initialize, or a block created for 5285 -- initialization purposes. 5286 5287 function Is_Partial_Finalization_Proc 5288 (Subp_Id : Entity_Id) return Boolean; 5289 pragma Inline (Is_Partial_Finalization_Proc); 5290 -- Determine whether subprogram Subp_Id is a partial finalization 5291 -- procedure. 5292 5293 ------------------------------- 5294 -- In_Initialization_Context -- 5295 ------------------------------- 5296 5297 function In_Initialization_Context (N : Node_Id) return Boolean is 5298 Par : Node_Id; 5299 Spec_Id : Entity_Id; 5300 5301 begin 5302 -- Climb the parent chain looking for initialization actions 5303 5304 Par := Parent (N); 5305 while Present (Par) loop 5306 5307 -- A block may be part of the initialization actions of a 5308 -- default initialized object. 5309 5310 if Nkind (Par) = N_Block_Statement 5311 and then Is_Initialization_Block (Par) 5312 then 5313 return True; 5314 5315 -- A subprogram body may denote an initialization routine 5316 5317 elsif Nkind (Par) = N_Subprogram_Body then 5318 Spec_Id := Unique_Defining_Entity (Par); 5319 5320 -- The current subprogram body denotes a type init proc or 5321 -- primitive [Deep_]Initialize. 5322 5323 if Is_Init_Proc (Spec_Id) 5324 or else Is_Controlled_Proc (Spec_Id, Name_Initialize) 5325 or else Is_TSS (Spec_Id, TSS_Deep_Initialize) 5326 then 5327 return True; 5328 end if; 5329 5330 -- Prevent the search from going too far 5331 5332 elsif Is_Body_Or_Package_Declaration (Par) then 5333 exit; 5334 end if; 5335 5336 Par := Parent (Par); 5337 end loop; 5338 5339 return False; 5340 end In_Initialization_Context; 5341 5342 ---------------------------------- 5343 -- Is_Partial_Finalization_Proc -- 5344 ---------------------------------- 5345 5346 function Is_Partial_Finalization_Proc 5347 (Subp_Id : Entity_Id) return Boolean 5348 is 5349 begin 5350 -- To qualify, the subprogram must denote a finalizer procedure 5351 -- or primitive [Deep_]Finalize, and the call must appear within 5352 -- an initialization context. 5353 5354 return 5355 (Is_Controlled_Proc (Subp_Id, Name_Finalize) 5356 or else Is_Finalizer_Proc (Subp_Id) 5357 or else Is_TSS (Subp_Id, TSS_Deep_Finalize)) 5358 and then In_Initialization_Context (Call); 5359 end Is_Partial_Finalization_Proc; 5360 5361 -- Local variables 5362 5363 Subp_Id : constant Entity_Id := Target (Call_Rep); 5364 Subp_Rep : constant Target_Rep_Id := 5365 Target_Representation_Of (Subp_Id, In_State); 5366 Subp_Decl : constant Node_Id := Spec_Declaration (Subp_Rep); 5367 5368 SPARK_Rules_On : constant Boolean := 5369 SPARK_Mode_Of (Call_Rep) = Is_On 5370 and then SPARK_Mode_Of (Subp_Rep) = Is_On; 5371 5372 New_In_State : Processing_In_State := In_State; 5373 -- Each step of the Processing phase constitutes a new state 5374 5375 -- Start of processing for Process_Conditional_ABE_Call 5376 5377 begin 5378 -- Output relevant information when switch -gnatel (info messages on 5379 -- implicit Elaborate[_All] pragmas) is in effect. 5380 5381 if Elab_Info_Messages 5382 and then not New_In_State.Suppress_Info_Messages 5383 then 5384 Info_Call 5385 (Call => Call, 5386 Subp_Id => Subp_Id, 5387 Info_Msg => True, 5388 In_SPARK => SPARK_Rules_On); 5389 end if; 5390 5391 -- Check whether the invocation of an entry clashes with an existing 5392 -- restriction. This check is relevant only when the processing was 5393 -- started from some library-level scenario. 5394 5395 if Is_Protected_Entry (Subp_Id) then 5396 Check_Restriction (No_Entry_Calls_In_Elaboration_Code, Call); 5397 5398 elsif Is_Task_Entry (Subp_Id) then 5399 Check_Restriction (No_Entry_Calls_In_Elaboration_Code, Call); 5400 5401 -- Task entry calls are never processed because the entry being 5402 -- invoked does not have a corresponding "body", it has a select. 5403 5404 return; 5405 end if; 5406 5407 -- Nothing to do when the call invokes a target defined within an 5408 -- instance and switch -gnatd_i (ignore activations and calls to 5409 -- instances for elaboration) is in effect. 5410 5411 if Debug_Flag_Underscore_I 5412 and then In_External_Instance 5413 (N => Call, 5414 Target_Decl => Subp_Decl) 5415 then 5416 return; 5417 5418 -- Nothing to do when the call is a guaranteed ABE 5419 5420 elsif Is_Known_Guaranteed_ABE (Call) then 5421 return; 5422 5423 -- Nothing to do when the root scenario appears at the declaration 5424 -- level and the target is in the same unit but outside this context. 5425 -- 5426 -- function B ...; -- target declaration 5427 -- 5428 -- procedure Proc is 5429 -- function A ... is 5430 -- begin 5431 -- if Some_Condition then 5432 -- return B; -- call site 5433 -- ... 5434 -- end A; 5435 -- 5436 -- X : ... := A; -- root scenario 5437 -- ... 5438 -- 5439 -- function B ... is 5440 -- ... 5441 -- end B; 5442 -- 5443 -- In the example above, the context of X is the declarative region 5444 -- of Proc. The "elaboration" of X may eventually reach B which is 5445 -- defined outside of X's context. B is relevant only when Proc is 5446 -- invoked, but this happens only by means of "normal" elaboration, 5447 -- therefore B must not be considered if this is not the case. 5448 5449 elsif Is_Up_Level_Target 5450 (Targ_Decl => Subp_Decl, 5451 In_State => New_In_State) 5452 then 5453 return; 5454 end if; 5455 5456 -- Warnings are suppressed when a prior scenario is already in that 5457 -- mode, or the call or target have warnings suppressed. Update the 5458 -- state of the Processing phase to reflect this. 5459 5460 New_In_State.Suppress_Warnings := 5461 New_In_State.Suppress_Warnings 5462 or else not Elaboration_Warnings_OK (Call_Rep) 5463 or else not Elaboration_Warnings_OK (Subp_Rep); 5464 5465 -- The call occurs in an initial condition context when a prior 5466 -- scenario is already in that mode, or when the target is an 5467 -- Initial_Condition procedure. Update the state of the Processing 5468 -- phase to reflect this. 5469 5470 New_In_State.Within_Initial_Condition := 5471 New_In_State.Within_Initial_Condition 5472 or else Is_Initial_Condition_Proc (Subp_Id); 5473 5474 -- The call occurs in a partial finalization context when a prior 5475 -- scenario is already in that mode, or when the target denotes a 5476 -- [Deep_]Finalize primitive or a finalizer within an initialization 5477 -- context. Update the state of the Processing phase to reflect this. 5478 5479 New_In_State.Within_Partial_Finalization := 5480 New_In_State.Within_Partial_Finalization 5481 or else Is_Partial_Finalization_Proc (Subp_Id); 5482 5483 -- The SPARK rules are in effect. Note that -gnatd.v (enforce SPARK 5484 -- elaboration rules in SPARK code) is intentionally not taken into 5485 -- account here because Process_Conditional_ABE_Call_SPARK has two 5486 -- separate modes of operation. 5487 5488 if SPARK_Rules_On then 5489 Process_Conditional_ABE_Call_SPARK 5490 (Call => Call, 5491 Call_Rep => Call_Rep, 5492 Subp_Id => Subp_Id, 5493 Subp_Rep => Subp_Rep, 5494 In_State => New_In_State); 5495 5496 -- Otherwise the Ada rules are in effect 5497 5498 else 5499 Process_Conditional_ABE_Call_Ada 5500 (Call => Call, 5501 Call_Rep => Call_Rep, 5502 Subp_Id => Subp_Id, 5503 Subp_Rep => Subp_Rep, 5504 In_State => New_In_State); 5505 end if; 5506 5507 -- Inspect the target body (and barried function) for other suitable 5508 -- elaboration scenarios. 5509 5510 Traverse_Conditional_ABE_Body 5511 (N => Barrier_Body_Declaration (Subp_Rep), 5512 In_State => New_In_State); 5513 5514 Traverse_Conditional_ABE_Body 5515 (N => Body_Declaration (Subp_Rep), 5516 In_State => New_In_State); 5517 end Process_Conditional_ABE_Call; 5518 5519 -------------------------------------- 5520 -- Process_Conditional_ABE_Call_Ada -- 5521 -------------------------------------- 5522 5523 procedure Process_Conditional_ABE_Call_Ada 5524 (Call : Node_Id; 5525 Call_Rep : Scenario_Rep_Id; 5526 Subp_Id : Entity_Id; 5527 Subp_Rep : Target_Rep_Id; 5528 In_State : Processing_In_State) 5529 is 5530 Body_Decl : constant Node_Id := Body_Declaration (Subp_Rep); 5531 Root : constant Node_Id := Root_Scenario; 5532 Unit_Id : constant Node_Id := Unit (Subp_Rep); 5533 5534 Check_OK : constant Boolean := 5535 not In_State.Suppress_Checks 5536 and then Ghost_Mode_Of (Call_Rep) /= Is_Ignored 5537 and then Ghost_Mode_Of (Subp_Rep) /= Is_Ignored 5538 and then Elaboration_Checks_OK (Call_Rep) 5539 and then Elaboration_Checks_OK (Subp_Rep); 5540 -- A run-time ABE check may be installed only when both the call 5541 -- and the target have active elaboration checks, and both are not 5542 -- ignored Ghost constructs. 5543 5544 New_In_State : Processing_In_State := In_State; 5545 -- Each step of the Processing phase constitutes a new state 5546 5547 begin 5548 -- Nothing to do for an Ada dispatching call because there are no 5549 -- ABE diagnostics for either models. ABE checks for the dynamic 5550 -- model are handled by Install_Primitive_Elaboration_Check. 5551 5552 if Is_Dispatching_Call (Call_Rep) then 5553 return; 5554 5555 -- Nothing to do when the call is ABE-safe 5556 -- 5557 -- generic 5558 -- function Gen ...; 5559 -- 5560 -- function Gen ... is 5561 -- begin 5562 -- ... 5563 -- end Gen; 5564 -- 5565 -- with Gen; 5566 -- procedure Main is 5567 -- function Inst is new Gen; 5568 -- X : ... := Inst; -- safe call 5569 -- ... 5570 5571 elsif Is_Safe_Call (Call, Subp_Id, Subp_Rep) then 5572 return; 5573 5574 -- The call and the target body are both in the main unit 5575 -- 5576 -- If the root scenario appears prior to the target body, then this 5577 -- is a possible ABE with respect to the root scenario. 5578 -- 5579 -- function B ...; 5580 -- 5581 -- function A ... is 5582 -- begin 5583 -- if Some_Condition then 5584 -- return B; -- call site 5585 -- ... 5586 -- end A; 5587 -- 5588 -- X : ... := A; -- root scenario 5589 -- 5590 -- function B ... is -- target body 5591 -- ... 5592 -- end B; 5593 -- 5594 -- Y : ... := A; -- root scenario 5595 -- 5596 -- IMPORTANT: The call to B from A is a possible ABE for X, but 5597 -- not for Y. Installing an unconditional ABE raise prior to the 5598 -- call to B would be wrong as it will fail for Y as well, but in 5599 -- Y's case the call to B is never an ABE. 5600 5601 elsif Present (Body_Decl) 5602 and then In_Extended_Main_Code_Unit (Body_Decl) 5603 then 5604 if Earlier_In_Extended_Unit (Root, Body_Decl) then 5605 5606 -- Do not emit any ABE diagnostics when a previous scenario in 5607 -- this traversal has suppressed elaboration warnings. 5608 5609 if New_In_State.Suppress_Warnings then 5610 null; 5611 5612 -- Do not emit any ABE diagnostics when the call occurs in a 5613 -- partial finalization context because this leads to confusing 5614 -- noise. 5615 5616 elsif New_In_State.Within_Partial_Finalization then 5617 null; 5618 5619 -- Otherwise emit the ABE diagnostic 5620 5621 else 5622 Error_Msg_NE 5623 ("??cannot call & before body seen", Call, Subp_Id); 5624 Error_Msg_N 5625 ("\Program_Error may be raised at run time", Call); 5626 5627 Output_Active_Scenarios (Call, New_In_State); 5628 end if; 5629 5630 -- Install a conditional run-time ABE check to verify that the 5631 -- target body has been elaborated prior to the call. 5632 5633 if Check_OK then 5634 Install_Scenario_ABE_Check 5635 (N => Call, 5636 Targ_Id => Subp_Id, 5637 Targ_Rep => Subp_Rep, 5638 Disable => Call_Rep); 5639 5640 -- Update the state of the Processing phase to indicate that 5641 -- no implicit Elaborate[_All] pragma must be generated from 5642 -- this point on. 5643 -- 5644 -- function B ...; 5645 -- 5646 -- function A ... is 5647 -- begin 5648 -- if Some_Condition then 5649 -- <ABE check> 5650 -- return B; 5651 -- ... 5652 -- end A; 5653 -- 5654 -- X : ... := A; 5655 -- 5656 -- function B ... is 5657 -- External.Subp; -- imparts Elaborate_All 5658 -- end B; 5659 -- 5660 -- If Some_Condition is True, then the ABE check will fail 5661 -- at runtime and the call to External.Subp will never take 5662 -- place, rendering the implicit Elaborate_All useless. 5663 -- 5664 -- If the value of Some_Condition is False, then the call 5665 -- to External.Subp will never take place, rendering the 5666 -- implicit Elaborate_All useless. 5667 5668 New_In_State.Suppress_Implicit_Pragmas := True; 5669 end if; 5670 end if; 5671 5672 -- Otherwise the target body is not available in this compilation or 5673 -- it resides in an external unit. Install a run-time ABE check to 5674 -- verify that the target body has been elaborated prior to the call 5675 -- site when the dynamic model is in effect. 5676 5677 elsif Check_OK 5678 and then New_In_State.Processing = Dynamic_Model_Processing 5679 then 5680 Install_Unit_ABE_Check 5681 (N => Call, 5682 Unit_Id => Unit_Id, 5683 Disable => Call_Rep); 5684 end if; 5685 5686 -- Ensure that the unit with the target body is elaborated prior to 5687 -- the main unit. The implicit Elaborate[_All] is generated only when 5688 -- the call has elaboration checks enabled. This behavior parallels 5689 -- that of the old ABE mechanism. 5690 5691 if Elaboration_Checks_OK (Call_Rep) then 5692 Ensure_Prior_Elaboration 5693 (N => Call, 5694 Unit_Id => Unit_Id, 5695 Prag_Nam => Name_Elaborate_All, 5696 In_State => New_In_State); 5697 end if; 5698 end Process_Conditional_ABE_Call_Ada; 5699 5700 ---------------------------------------- 5701 -- Process_Conditional_ABE_Call_SPARK -- 5702 ---------------------------------------- 5703 5704 procedure Process_Conditional_ABE_Call_SPARK 5705 (Call : Node_Id; 5706 Call_Rep : Scenario_Rep_Id; 5707 Subp_Id : Entity_Id; 5708 Subp_Rep : Target_Rep_Id; 5709 In_State : Processing_In_State) 5710 is 5711 pragma Unreferenced (Call_Rep); 5712 5713 Body_Decl : constant Node_Id := Body_Declaration (Subp_Rep); 5714 Region : Node_Id; 5715 5716 begin 5717 -- Ensure that a suitable elaboration model is in effect for SPARK 5718 -- rule verification. 5719 5720 Check_SPARK_Model_In_Effect; 5721 5722 -- The call and the target body are both in the main unit 5723 5724 if Present (Body_Decl) 5725 and then In_Extended_Main_Code_Unit (Body_Decl) 5726 and then Earlier_In_Extended_Unit (Call, Body_Decl) 5727 then 5728 -- Do not emit any ABE diagnostics when a previous scenario in 5729 -- this traversal has suppressed elaboration warnings. 5730 5731 if In_State.Suppress_Warnings then 5732 null; 5733 5734 -- Do not emit any ABE diagnostics when the call occurs in an 5735 -- initial condition context because this leads to incorrect 5736 -- diagnostics. 5737 5738 elsif In_State.Within_Initial_Condition then 5739 null; 5740 5741 -- Do not emit any ABE diagnostics when the call occurs in a 5742 -- partial finalization context because this leads to confusing 5743 -- noise. 5744 5745 elsif In_State.Within_Partial_Finalization then 5746 null; 5747 5748 -- Ensure that a call that textually precedes the subprogram body 5749 -- it invokes appears within the early call region of the body. 5750 -- 5751 -- IMPORTANT: This check must always be performed even when switch 5752 -- -gnatd.v (enforce SPARK elaboration rules in SPARK code) is not 5753 -- specified because the static model cannot guarantee the absence 5754 -- of elaboration issues when dispatching calls are involved. 5755 5756 else 5757 Region := Find_Early_Call_Region (Body_Decl); 5758 5759 if Earlier_In_Extended_Unit (Call, Region) then 5760 Error_Msg_NE 5761 ("call must appear within early call region of subprogram " 5762 & "body & (SPARK RM 7.7(3))", 5763 Call, Subp_Id); 5764 5765 Error_Msg_Sloc := Sloc (Region); 5766 Error_Msg_N ("\region starts #", Call); 5767 5768 Error_Msg_Sloc := Sloc (Body_Decl); 5769 Error_Msg_N ("\region ends #", Call); 5770 5771 Output_Active_Scenarios (Call, In_State); 5772 end if; 5773 end if; 5774 end if; 5775 5776 -- A call to a source target or to a target which emulates Ada 5777 -- or SPARK semantics imposes an Elaborate_All requirement on the 5778 -- context of the main unit. Determine whether the context has a 5779 -- pragma strong enough to meet the requirement. 5780 -- 5781 -- IMPORTANT: This check must be performed only when switch -gnatd.v 5782 -- (enforce SPARK elaboration rules in SPARK code) is active because 5783 -- the static model can ensure the prior elaboration of the unit 5784 -- which contains a body by installing an implicit Elaborate[_All] 5785 -- pragma. 5786 5787 if Debug_Flag_Dot_V then 5788 if Comes_From_Source (Subp_Id) 5789 or else Is_Ada_Semantic_Target (Subp_Id) 5790 or else Is_SPARK_Semantic_Target (Subp_Id) 5791 then 5792 Meet_Elaboration_Requirement 5793 (N => Call, 5794 Targ_Id => Subp_Id, 5795 Req_Nam => Name_Elaborate_All, 5796 In_State => In_State); 5797 end if; 5798 5799 -- Otherwise ensure that the unit with the target body is elaborated 5800 -- prior to the main unit. 5801 5802 else 5803 Ensure_Prior_Elaboration 5804 (N => Call, 5805 Unit_Id => Unit (Subp_Rep), 5806 Prag_Nam => Name_Elaborate_All, 5807 In_State => In_State); 5808 end if; 5809 end Process_Conditional_ABE_Call_SPARK; 5810 5811 ------------------------------------------- 5812 -- Process_Conditional_ABE_Instantiation -- 5813 ------------------------------------------- 5814 5815 procedure Process_Conditional_ABE_Instantiation 5816 (Inst : Node_Id; 5817 Inst_Rep : Scenario_Rep_Id; 5818 In_State : Processing_In_State) 5819 is 5820 Gen_Id : constant Entity_Id := Target (Inst_Rep); 5821 Gen_Rep : constant Target_Rep_Id := 5822 Target_Representation_Of (Gen_Id, In_State); 5823 5824 SPARK_Rules_On : constant Boolean := 5825 SPARK_Mode_Of (Inst_Rep) = Is_On 5826 and then SPARK_Mode_Of (Gen_Rep) = Is_On; 5827 5828 New_In_State : Processing_In_State := In_State; 5829 -- Each step of the Processing phase constitutes a new state 5830 5831 begin 5832 -- Output relevant information when switch -gnatel (info messages on 5833 -- implicit Elaborate[_All] pragmas) is in effect. 5834 5835 if Elab_Info_Messages 5836 and then not New_In_State.Suppress_Info_Messages 5837 then 5838 Info_Instantiation 5839 (Inst => Inst, 5840 Gen_Id => Gen_Id, 5841 Info_Msg => True, 5842 In_SPARK => SPARK_Rules_On); 5843 end if; 5844 5845 -- Nothing to do when the instantiation is a guaranteed ABE 5846 5847 if Is_Known_Guaranteed_ABE (Inst) then 5848 return; 5849 5850 -- Nothing to do when the root scenario appears at the declaration 5851 -- level and the generic is in the same unit, but outside this 5852 -- context. 5853 -- 5854 -- generic 5855 -- procedure Gen is ...; -- generic declaration 5856 -- 5857 -- procedure Proc is 5858 -- function A ... is 5859 -- begin 5860 -- if Some_Condition then 5861 -- declare 5862 -- procedure I is new Gen; -- instantiation site 5863 -- ... 5864 -- ... 5865 -- end A; 5866 -- 5867 -- X : ... := A; -- root scenario 5868 -- ... 5869 -- 5870 -- procedure Gen is 5871 -- ... 5872 -- end Gen; 5873 -- 5874 -- In the example above, the context of X is the declarative region 5875 -- of Proc. The "elaboration" of X may eventually reach Gen which 5876 -- appears outside of X's context. Gen is relevant only when Proc is 5877 -- invoked, but this happens only by means of "normal" elaboration, 5878 -- therefore Gen must not be considered if this is not the case. 5879 5880 elsif Is_Up_Level_Target 5881 (Targ_Decl => Spec_Declaration (Gen_Rep), 5882 In_State => New_In_State) 5883 then 5884 return; 5885 end if; 5886 5887 -- Warnings are suppressed when a prior scenario is already in that 5888 -- mode, or when the instantiation has warnings suppressed. Update 5889 -- the state of the processing phase to reflect this. 5890 5891 New_In_State.Suppress_Warnings := 5892 New_In_State.Suppress_Warnings 5893 or else not Elaboration_Warnings_OK (Inst_Rep); 5894 5895 -- The SPARK rules are in effect 5896 5897 if SPARK_Rules_On then 5898 Process_Conditional_ABE_Instantiation_SPARK 5899 (Inst => Inst, 5900 Inst_Rep => Inst_Rep, 5901 Gen_Id => Gen_Id, 5902 Gen_Rep => Gen_Rep, 5903 In_State => New_In_State); 5904 5905 -- Otherwise the Ada rules are in effect, or SPARK code is allowed to 5906 -- violate the SPARK rules. 5907 5908 else 5909 Process_Conditional_ABE_Instantiation_Ada 5910 (Inst => Inst, 5911 Inst_Rep => Inst_Rep, 5912 Gen_Id => Gen_Id, 5913 Gen_Rep => Gen_Rep, 5914 In_State => New_In_State); 5915 end if; 5916 end Process_Conditional_ABE_Instantiation; 5917 5918 ----------------------------------------------- 5919 -- Process_Conditional_ABE_Instantiation_Ada -- 5920 ----------------------------------------------- 5921 5922 procedure Process_Conditional_ABE_Instantiation_Ada 5923 (Inst : Node_Id; 5924 Inst_Rep : Scenario_Rep_Id; 5925 Gen_Id : Entity_Id; 5926 Gen_Rep : Target_Rep_Id; 5927 In_State : Processing_In_State) 5928 is 5929 Body_Decl : constant Node_Id := Body_Declaration (Gen_Rep); 5930 Root : constant Node_Id := Root_Scenario; 5931 Unit_Id : constant Entity_Id := Unit (Gen_Rep); 5932 5933 Check_OK : constant Boolean := 5934 not In_State.Suppress_Checks 5935 and then Ghost_Mode_Of (Inst_Rep) /= Is_Ignored 5936 and then Ghost_Mode_Of (Gen_Rep) /= Is_Ignored 5937 and then Elaboration_Checks_OK (Inst_Rep) 5938 and then Elaboration_Checks_OK (Gen_Rep); 5939 -- A run-time ABE check may be installed only when both the instance 5940 -- and the generic have active elaboration checks and both are not 5941 -- ignored Ghost constructs. 5942 5943 New_In_State : Processing_In_State := In_State; 5944 -- Each step of the Processing phase constitutes a new state 5945 5946 begin 5947 -- Nothing to do when the instantiation is ABE-safe 5948 -- 5949 -- generic 5950 -- package Gen is 5951 -- ... 5952 -- end Gen; 5953 -- 5954 -- package body Gen is 5955 -- ... 5956 -- end Gen; 5957 -- 5958 -- with Gen; 5959 -- procedure Main is 5960 -- package Inst is new Gen (ABE); -- safe instantiation 5961 -- ... 5962 5963 if Is_Safe_Instantiation (Inst, Gen_Id, Gen_Rep) then 5964 return; 5965 5966 -- The instantiation and the generic body are both in the main unit 5967 -- 5968 -- If the root scenario appears prior to the generic body, then this 5969 -- is a possible ABE with respect to the root scenario. 5970 -- 5971 -- generic 5972 -- package Gen is 5973 -- ... 5974 -- end Gen; 5975 -- 5976 -- function A ... is 5977 -- begin 5978 -- if Some_Condition then 5979 -- declare 5980 -- package Inst is new Gen; -- instantiation site 5981 -- ... 5982 -- end A; 5983 -- 5984 -- X : ... := A; -- root scenario 5985 -- 5986 -- package body Gen is -- generic body 5987 -- ... 5988 -- end Gen; 5989 -- 5990 -- Y : ... := A; -- root scenario 5991 -- 5992 -- IMPORTANT: The instantiation of Gen is a possible ABE for X, 5993 -- but not for Y. Installing an unconditional ABE raise prior to 5994 -- the instance site would be wrong as it will fail for Y as well, 5995 -- but in Y's case the instantiation of Gen is never an ABE. 5996 5997 elsif Present (Body_Decl) 5998 and then In_Extended_Main_Code_Unit (Body_Decl) 5999 then 6000 if Earlier_In_Extended_Unit (Root, Body_Decl) then 6001 6002 -- Do not emit any ABE diagnostics when a previous scenario in 6003 -- this traversal has suppressed elaboration warnings. 6004 6005 if New_In_State.Suppress_Warnings then 6006 null; 6007 6008 -- Do not emit any ABE diagnostics when the instantiation 6009 -- occurs in partial finalization context because this leads 6010 -- to unwanted noise. 6011 6012 elsif New_In_State.Within_Partial_Finalization then 6013 null; 6014 6015 -- Otherwise output the diagnostic 6016 6017 else 6018 Error_Msg_NE 6019 ("??cannot instantiate & before body seen", Inst, Gen_Id); 6020 Error_Msg_N 6021 ("\Program_Error may be raised at run time", Inst); 6022 6023 Output_Active_Scenarios (Inst, New_In_State); 6024 end if; 6025 6026 -- Install a conditional run-time ABE check to verify that the 6027 -- generic body has been elaborated prior to the instantiation. 6028 6029 if Check_OK then 6030 Install_Scenario_ABE_Check 6031 (N => Inst, 6032 Targ_Id => Gen_Id, 6033 Targ_Rep => Gen_Rep, 6034 Disable => Inst_Rep); 6035 6036 -- Update the state of the Processing phase to indicate that 6037 -- no implicit Elaborate[_All] pragma must be generated from 6038 -- this point on. 6039 -- 6040 -- generic 6041 -- package Gen is 6042 -- ... 6043 -- end Gen; 6044 -- 6045 -- function A ... is 6046 -- begin 6047 -- if Some_Condition then 6048 -- <ABE check> 6049 -- declare Inst is new Gen; 6050 -- ... 6051 -- end A; 6052 -- 6053 -- X : ... := A; 6054 -- 6055 -- package body Gen is 6056 -- begin 6057 -- External.Subp; -- imparts Elaborate_All 6058 -- end Gen; 6059 -- 6060 -- If Some_Condition is True, then the ABE check will fail 6061 -- at runtime and the call to External.Subp will never take 6062 -- place, rendering the implicit Elaborate_All useless. 6063 -- 6064 -- If the value of Some_Condition is False, then the call 6065 -- to External.Subp will never take place, rendering the 6066 -- implicit Elaborate_All useless. 6067 6068 New_In_State.Suppress_Implicit_Pragmas := True; 6069 end if; 6070 end if; 6071 6072 -- Otherwise the generic body is not available in this compilation 6073 -- or it resides in an external unit. Install a run-time ABE check 6074 -- to verify that the generic body has been elaborated prior to the 6075 -- instantiation when the dynamic model is in effect. 6076 6077 elsif Check_OK 6078 and then New_In_State.Processing = Dynamic_Model_Processing 6079 then 6080 Install_Unit_ABE_Check 6081 (N => Inst, 6082 Unit_Id => Unit_Id, 6083 Disable => Inst_Rep); 6084 end if; 6085 6086 -- Ensure that the unit with the generic body is elaborated prior 6087 -- to the main unit. No implicit pragma has to be generated if the 6088 -- instantiation has elaboration checks suppressed. This behavior 6089 -- parallels that of the old ABE mechanism. 6090 6091 if Elaboration_Checks_OK (Inst_Rep) then 6092 Ensure_Prior_Elaboration 6093 (N => Inst, 6094 Unit_Id => Unit_Id, 6095 Prag_Nam => Name_Elaborate, 6096 In_State => New_In_State); 6097 end if; 6098 end Process_Conditional_ABE_Instantiation_Ada; 6099 6100 ------------------------------------------------- 6101 -- Process_Conditional_ABE_Instantiation_SPARK -- 6102 ------------------------------------------------- 6103 6104 procedure Process_Conditional_ABE_Instantiation_SPARK 6105 (Inst : Node_Id; 6106 Inst_Rep : Scenario_Rep_Id; 6107 Gen_Id : Entity_Id; 6108 Gen_Rep : Target_Rep_Id; 6109 In_State : Processing_In_State) 6110 is 6111 pragma Unreferenced (Inst_Rep); 6112 6113 Req_Nam : Name_Id; 6114 6115 begin 6116 -- Ensure that a suitable elaboration model is in effect for SPARK 6117 -- rule verification. 6118 6119 Check_SPARK_Model_In_Effect; 6120 6121 -- A source instantiation imposes an Elaborate[_All] requirement 6122 -- on the context of the main unit. Determine whether the context 6123 -- has a pragma strong enough to meet the requirement. The check 6124 -- is orthogonal to the ABE ramifications of the instantiation. 6125 -- 6126 -- IMPORTANT: This check must be performed only when switch -gnatd.v 6127 -- (enforce SPARK elaboration rules in SPARK code) is active because 6128 -- the static model can ensure the prior elaboration of the unit 6129 -- which contains a body by installing an implicit Elaborate[_All] 6130 -- pragma. 6131 6132 if Debug_Flag_Dot_V then 6133 if Nkind (Inst) = N_Package_Instantiation then 6134 Req_Nam := Name_Elaborate_All; 6135 else 6136 Req_Nam := Name_Elaborate; 6137 end if; 6138 6139 Meet_Elaboration_Requirement 6140 (N => Inst, 6141 Targ_Id => Gen_Id, 6142 Req_Nam => Req_Nam, 6143 In_State => In_State); 6144 6145 -- Otherwise ensure that the unit with the target body is elaborated 6146 -- prior to the main unit. 6147 6148 else 6149 Ensure_Prior_Elaboration 6150 (N => Inst, 6151 Unit_Id => Unit (Gen_Rep), 6152 Prag_Nam => Name_Elaborate, 6153 In_State => In_State); 6154 end if; 6155 end Process_Conditional_ABE_Instantiation_SPARK; 6156 6157 ------------------------------------------------- 6158 -- Process_Conditional_ABE_Variable_Assignment -- 6159 ------------------------------------------------- 6160 6161 procedure Process_Conditional_ABE_Variable_Assignment 6162 (Asmt : Node_Id; 6163 Asmt_Rep : Scenario_Rep_Id; 6164 In_State : Processing_In_State) 6165 is 6166 6167 Var_Id : constant Entity_Id := Target (Asmt_Rep); 6168 Var_Rep : constant Target_Rep_Id := 6169 Target_Representation_Of (Var_Id, In_State); 6170 6171 SPARK_Rules_On : constant Boolean := 6172 SPARK_Mode_Of (Asmt_Rep) = Is_On 6173 and then SPARK_Mode_Of (Var_Rep) = Is_On; 6174 6175 begin 6176 -- Output relevant information when switch -gnatel (info messages on 6177 -- implicit Elaborate[_All] pragmas) is in effect. 6178 6179 if Elab_Info_Messages 6180 and then not In_State.Suppress_Info_Messages 6181 then 6182 Elab_Msg_NE 6183 (Msg => "assignment to & during elaboration", 6184 N => Asmt, 6185 Id => Var_Id, 6186 Info_Msg => True, 6187 In_SPARK => SPARK_Rules_On); 6188 end if; 6189 6190 -- The SPARK rules are in effect. These rules are applied regardless 6191 -- of whether switch -gnatd.v (enforce SPARK elaboration rules in 6192 -- SPARK code) is in effect because the static model cannot ensure 6193 -- safe assignment of variables. 6194 6195 if SPARK_Rules_On then 6196 Process_Conditional_ABE_Variable_Assignment_SPARK 6197 (Asmt => Asmt, 6198 Asmt_Rep => Asmt_Rep, 6199 Var_Id => Var_Id, 6200 Var_Rep => Var_Rep, 6201 In_State => In_State); 6202 6203 -- Otherwise the Ada rules are in effect 6204 6205 else 6206 Process_Conditional_ABE_Variable_Assignment_Ada 6207 (Asmt => Asmt, 6208 Asmt_Rep => Asmt_Rep, 6209 Var_Id => Var_Id, 6210 Var_Rep => Var_Rep, 6211 In_State => In_State); 6212 end if; 6213 end Process_Conditional_ABE_Variable_Assignment; 6214 6215 ----------------------------------------------------- 6216 -- Process_Conditional_ABE_Variable_Assignment_Ada -- 6217 ----------------------------------------------------- 6218 6219 procedure Process_Conditional_ABE_Variable_Assignment_Ada 6220 (Asmt : Node_Id; 6221 Asmt_Rep : Scenario_Rep_Id; 6222 Var_Id : Entity_Id; 6223 Var_Rep : Target_Rep_Id; 6224 In_State : Processing_In_State) 6225 is 6226 pragma Unreferenced (Asmt_Rep); 6227 6228 Var_Decl : constant Node_Id := Variable_Declaration (Var_Rep); 6229 Unit_Id : constant Entity_Id := Unit (Var_Rep); 6230 6231 begin 6232 -- Emit a warning when an uninitialized variable declared in a 6233 -- package spec without a pragma Elaborate_Body is initialized 6234 -- by elaboration code within the corresponding body. 6235 6236 if Is_Elaboration_Warnings_OK_Id (Var_Id) 6237 and then not Is_Initialized (Var_Decl) 6238 and then not Has_Pragma_Elaborate_Body (Unit_Id) 6239 then 6240 -- Do not emit any ABE diagnostics when a previous scenario in 6241 -- this traversal has suppressed elaboration warnings. 6242 6243 if not In_State.Suppress_Warnings then 6244 Error_Msg_NE 6245 ("??variable & can be accessed by clients before this " 6246 & "initialization", Asmt, Var_Id); 6247 6248 Error_Msg_NE 6249 ("\add pragma ""Elaborate_Body"" to spec & to ensure proper " 6250 & "initialization", Asmt, Unit_Id); 6251 6252 Output_Active_Scenarios (Asmt, In_State); 6253 end if; 6254 6255 -- Generate an implicit Elaborate_Body in the spec 6256 6257 Set_Elaborate_Body_Desirable (Unit_Id); 6258 end if; 6259 end Process_Conditional_ABE_Variable_Assignment_Ada; 6260 6261 ------------------------------------------------------- 6262 -- Process_Conditional_ABE_Variable_Assignment_SPARK -- 6263 ------------------------------------------------------- 6264 6265 procedure Process_Conditional_ABE_Variable_Assignment_SPARK 6266 (Asmt : Node_Id; 6267 Asmt_Rep : Scenario_Rep_Id; 6268 Var_Id : Entity_Id; 6269 Var_Rep : Target_Rep_Id; 6270 In_State : Processing_In_State) 6271 is 6272 pragma Unreferenced (Asmt_Rep); 6273 6274 Var_Decl : constant Node_Id := Variable_Declaration (Var_Rep); 6275 Unit_Id : constant Entity_Id := Unit (Var_Rep); 6276 6277 begin 6278 -- Ensure that a suitable elaboration model is in effect for SPARK 6279 -- rule verification. 6280 6281 Check_SPARK_Model_In_Effect; 6282 6283 -- Do not emit any ABE diagnostics when a previous scenario in this 6284 -- traversal has suppressed elaboration warnings. 6285 6286 if In_State.Suppress_Warnings then 6287 null; 6288 6289 -- Emit an error when an initialized variable declared in a package 6290 -- spec that is missing pragma Elaborate_Body is further modified by 6291 -- elaboration code within the corresponding body. 6292 6293 elsif Is_Elaboration_Warnings_OK_Id (Var_Id) 6294 and then Is_Initialized (Var_Decl) 6295 and then not Has_Pragma_Elaborate_Body (Unit_Id) 6296 then 6297 Error_Msg_NE 6298 ("variable & modified by elaboration code in package body", 6299 Asmt, Var_Id); 6300 6301 Error_Msg_NE 6302 ("\add pragma ""Elaborate_Body"" to spec & to ensure full " 6303 & "initialization", Asmt, Unit_Id); 6304 6305 Output_Active_Scenarios (Asmt, In_State); 6306 end if; 6307 end Process_Conditional_ABE_Variable_Assignment_SPARK; 6308 6309 ------------------------------------------------ 6310 -- Process_Conditional_ABE_Variable_Reference -- 6311 ------------------------------------------------ 6312 6313 procedure Process_Conditional_ABE_Variable_Reference 6314 (Ref : Node_Id; 6315 Ref_Rep : Scenario_Rep_Id; 6316 In_State : Processing_In_State) 6317 is 6318 Var_Id : constant Entity_Id := Target (Ref); 6319 Var_Rep : Target_Rep_Id; 6320 Unit_Id : Entity_Id; 6321 6322 begin 6323 -- Nothing to do when the variable reference is not a read 6324 6325 if not Is_Read_Reference (Ref_Rep) then 6326 return; 6327 end if; 6328 6329 Var_Rep := Target_Representation_Of (Var_Id, In_State); 6330 Unit_Id := Unit (Var_Rep); 6331 6332 -- Output relevant information when switch -gnatel (info messages on 6333 -- implicit Elaborate[_All] pragmas) is in effect. 6334 6335 if Elab_Info_Messages 6336 and then not In_State.Suppress_Info_Messages 6337 then 6338 Elab_Msg_NE 6339 (Msg => "read of variable & during elaboration", 6340 N => Ref, 6341 Id => Var_Id, 6342 Info_Msg => True, 6343 In_SPARK => True); 6344 end if; 6345 6346 -- Nothing to do when the variable appears within the main unit 6347 -- because diagnostics on reads are relevant only for external 6348 -- variables. 6349 6350 if Is_Same_Unit (Unit_Id, Main_Unit_Entity) then 6351 null; 6352 6353 -- Nothing to do when the variable is already initialized. Note that 6354 -- the variable may be further modified by the external unit. 6355 6356 elsif Is_Initialized (Variable_Declaration (Var_Rep)) then 6357 null; 6358 6359 -- Nothing to do when the external unit guarantees the initialization 6360 -- of the variable by means of pragma Elaborate_Body. 6361 6362 elsif Has_Pragma_Elaborate_Body (Unit_Id) then 6363 null; 6364 6365 -- A variable read imposes an Elaborate requirement on the context of 6366 -- the main unit. Determine whether the context has a pragma strong 6367 -- enough to meet the requirement. 6368 6369 else 6370 Meet_Elaboration_Requirement 6371 (N => Ref, 6372 Targ_Id => Var_Id, 6373 Req_Nam => Name_Elaborate, 6374 In_State => In_State); 6375 end if; 6376 end Process_Conditional_ABE_Variable_Reference; 6377 6378 ----------------------------------- 6379 -- Traverse_Conditional_ABE_Body -- 6380 ----------------------------------- 6381 6382 procedure Traverse_Conditional_ABE_Body 6383 (N : Node_Id; 6384 In_State : Processing_In_State) 6385 is 6386 begin 6387 Traverse_Body 6388 (N => N, 6389 Requires_Processing => Is_Conditional_ABE_Scenario'Access, 6390 Processor => Process_Conditional_ABE'Access, 6391 In_State => In_State); 6392 end Traverse_Conditional_ABE_Body; 6393 end Conditional_ABE_Processor; 6394 6395 ------------- 6396 -- Destroy -- 6397 ------------- 6398 6399 procedure Destroy (NE : in out Node_Or_Entity_Id) is 6400 pragma Unreferenced (NE); 6401 begin 6402 null; 6403 end Destroy; 6404 6405 ----------------- 6406 -- Diagnostics -- 6407 ----------------- 6408 6409 package body Diagnostics is 6410 6411 ----------------- 6412 -- Elab_Msg_NE -- 6413 ----------------- 6414 6415 procedure Elab_Msg_NE 6416 (Msg : String; 6417 N : Node_Id; 6418 Id : Entity_Id; 6419 Info_Msg : Boolean; 6420 In_SPARK : Boolean) 6421 is 6422 function Prefix return String; 6423 pragma Inline (Prefix); 6424 -- Obtain the prefix of the message 6425 6426 function Suffix return String; 6427 pragma Inline (Suffix); 6428 -- Obtain the suffix of the message 6429 6430 ------------ 6431 -- Prefix -- 6432 ------------ 6433 6434 function Prefix return String is 6435 begin 6436 if Info_Msg then 6437 return "info: "; 6438 else 6439 return ""; 6440 end if; 6441 end Prefix; 6442 6443 ------------ 6444 -- Suffix -- 6445 ------------ 6446 6447 function Suffix return String is 6448 begin 6449 if In_SPARK then 6450 return " in SPARK"; 6451 else 6452 return ""; 6453 end if; 6454 end Suffix; 6455 6456 -- Start of processing for Elab_Msg_NE 6457 6458 begin 6459 Error_Msg_NE (Prefix & Msg & Suffix, N, Id); 6460 end Elab_Msg_NE; 6461 6462 --------------- 6463 -- Info_Call -- 6464 --------------- 6465 6466 procedure Info_Call 6467 (Call : Node_Id; 6468 Subp_Id : Entity_Id; 6469 Info_Msg : Boolean; 6470 In_SPARK : Boolean) 6471 is 6472 procedure Info_Accept_Alternative; 6473 pragma Inline (Info_Accept_Alternative); 6474 -- Output information concerning an accept alternative 6475 6476 procedure Info_Simple_Call; 6477 pragma Inline (Info_Simple_Call); 6478 -- Output information concerning the call 6479 6480 procedure Info_Type_Actions (Action : String); 6481 pragma Inline (Info_Type_Actions); 6482 -- Output information concerning action Action of a type 6483 6484 procedure Info_Verification_Call 6485 (Pred : String; 6486 Id : Entity_Id; 6487 Id_Kind : String); 6488 pragma Inline (Info_Verification_Call); 6489 -- Output information concerning the verification of predicate Pred 6490 -- applied to related entity Id with kind Id_Kind. 6491 6492 ----------------------------- 6493 -- Info_Accept_Alternative -- 6494 ----------------------------- 6495 6496 procedure Info_Accept_Alternative is 6497 Entry_Id : constant Entity_Id := Receiving_Entry (Subp_Id); 6498 pragma Assert (Present (Entry_Id)); 6499 6500 begin 6501 Elab_Msg_NE 6502 (Msg => "accept for entry & during elaboration", 6503 N => Call, 6504 Id => Entry_Id, 6505 Info_Msg => Info_Msg, 6506 In_SPARK => In_SPARK); 6507 end Info_Accept_Alternative; 6508 6509 ---------------------- 6510 -- Info_Simple_Call -- 6511 ---------------------- 6512 6513 procedure Info_Simple_Call is 6514 begin 6515 Elab_Msg_NE 6516 (Msg => "call to & during elaboration", 6517 N => Call, 6518 Id => Subp_Id, 6519 Info_Msg => Info_Msg, 6520 In_SPARK => In_SPARK); 6521 end Info_Simple_Call; 6522 6523 ----------------------- 6524 -- Info_Type_Actions -- 6525 ----------------------- 6526 6527 procedure Info_Type_Actions (Action : String) is 6528 Typ : constant Entity_Id := First_Formal_Type (Subp_Id); 6529 pragma Assert (Present (Typ)); 6530 6531 begin 6532 Elab_Msg_NE 6533 (Msg => Action & " actions for type & during elaboration", 6534 N => Call, 6535 Id => Typ, 6536 Info_Msg => Info_Msg, 6537 In_SPARK => In_SPARK); 6538 end Info_Type_Actions; 6539 6540 ---------------------------- 6541 -- Info_Verification_Call -- 6542 ---------------------------- 6543 6544 procedure Info_Verification_Call 6545 (Pred : String; 6546 Id : Entity_Id; 6547 Id_Kind : String) 6548 is 6549 pragma Assert (Present (Id)); 6550 6551 begin 6552 Elab_Msg_NE 6553 (Msg => 6554 "verification of " & Pred & " of " & Id_Kind & " & during " 6555 & "elaboration", 6556 N => Call, 6557 Id => Id, 6558 Info_Msg => Info_Msg, 6559 In_SPARK => In_SPARK); 6560 end Info_Verification_Call; 6561 6562 -- Start of processing for Info_Call 6563 6564 begin 6565 -- Do not output anything for targets defined in internal units 6566 -- because this creates noise. 6567 6568 if not In_Internal_Unit (Subp_Id) then 6569 6570 -- Accept alternative 6571 6572 if Is_Accept_Alternative_Proc (Subp_Id) then 6573 Info_Accept_Alternative; 6574 6575 -- Adjustment 6576 6577 elsif Is_TSS (Subp_Id, TSS_Deep_Adjust) then 6578 Info_Type_Actions ("adjustment"); 6579 6580 -- Default_Initial_Condition 6581 6582 elsif Is_Default_Initial_Condition_Proc (Subp_Id) then 6583 Info_Verification_Call 6584 (Pred => "Default_Initial_Condition", 6585 Id => First_Formal_Type (Subp_Id), 6586 Id_Kind => "type"); 6587 6588 -- Entries 6589 6590 elsif Is_Protected_Entry (Subp_Id) then 6591 Info_Simple_Call; 6592 6593 -- Task entry calls are never processed because the entry being 6594 -- invoked does not have a corresponding "body", it has a select. 6595 6596 elsif Is_Task_Entry (Subp_Id) then 6597 null; 6598 6599 -- Finalization 6600 6601 elsif Is_TSS (Subp_Id, TSS_Deep_Finalize) then 6602 Info_Type_Actions ("finalization"); 6603 6604 -- Calls to _Finalizer procedures must not appear in the output 6605 -- because this creates confusing noise. 6606 6607 elsif Is_Finalizer_Proc (Subp_Id) then 6608 null; 6609 6610 -- Initial_Condition 6611 6612 elsif Is_Initial_Condition_Proc (Subp_Id) then 6613 Info_Verification_Call 6614 (Pred => "Initial_Condition", 6615 Id => Find_Enclosing_Scope (Call), 6616 Id_Kind => "package"); 6617 6618 -- Initialization 6619 6620 elsif Is_Init_Proc (Subp_Id) 6621 or else Is_TSS (Subp_Id, TSS_Deep_Initialize) 6622 then 6623 Info_Type_Actions ("initialization"); 6624 6625 -- Invariant 6626 6627 elsif Is_Invariant_Proc (Subp_Id) then 6628 Info_Verification_Call 6629 (Pred => "invariants", 6630 Id => First_Formal_Type (Subp_Id), 6631 Id_Kind => "type"); 6632 6633 -- Partial invariant calls must not appear in the output because 6634 -- this creates confusing noise. 6635 6636 elsif Is_Partial_Invariant_Proc (Subp_Id) then 6637 null; 6638 6639 -- _Postconditions 6640 6641 elsif Is_Postconditions_Proc (Subp_Id) then 6642 Info_Verification_Call 6643 (Pred => "postconditions", 6644 Id => Find_Enclosing_Scope (Call), 6645 Id_Kind => "subprogram"); 6646 6647 -- Subprograms must come last because some of the previous cases 6648 -- fall under this category. 6649 6650 elsif Ekind (Subp_Id) = E_Function then 6651 Info_Simple_Call; 6652 6653 elsif Ekind (Subp_Id) = E_Procedure then 6654 Info_Simple_Call; 6655 6656 else 6657 pragma Assert (False); 6658 return; 6659 end if; 6660 end if; 6661 end Info_Call; 6662 6663 ------------------------ 6664 -- Info_Instantiation -- 6665 ------------------------ 6666 6667 procedure Info_Instantiation 6668 (Inst : Node_Id; 6669 Gen_Id : Entity_Id; 6670 Info_Msg : Boolean; 6671 In_SPARK : Boolean) 6672 is 6673 begin 6674 Elab_Msg_NE 6675 (Msg => "instantiation of & during elaboration", 6676 N => Inst, 6677 Id => Gen_Id, 6678 Info_Msg => Info_Msg, 6679 In_SPARK => In_SPARK); 6680 end Info_Instantiation; 6681 6682 ----------------------------- 6683 -- Info_Variable_Reference -- 6684 ----------------------------- 6685 6686 procedure Info_Variable_Reference 6687 (Ref : Node_Id; 6688 Var_Id : Entity_Id) 6689 is 6690 begin 6691 if Is_Read (Ref) then 6692 Elab_Msg_NE 6693 (Msg => "read of variable & during elaboration", 6694 N => Ref, 6695 Id => Var_Id, 6696 Info_Msg => False, 6697 In_SPARK => True); 6698 end if; 6699 end Info_Variable_Reference; 6700 end Diagnostics; 6701 6702 --------------------------------- 6703 -- Early_Call_Region_Processor -- 6704 --------------------------------- 6705 6706 package body Early_Call_Region_Processor is 6707 6708 --------------------- 6709 -- Data structures -- 6710 --------------------- 6711 6712 -- The following map relates early call regions to subprogram bodies 6713 6714 procedure Destroy (N : in out Node_Id); 6715 -- Destroy node N 6716 6717 package ECR_Map is new Dynamic_Hash_Tables 6718 (Key_Type => Entity_Id, 6719 Value_Type => Node_Id, 6720 No_Value => Empty, 6721 Expansion_Threshold => 1.5, 6722 Expansion_Factor => 2, 6723 Compression_Threshold => 0.3, 6724 Compression_Factor => 2, 6725 "=" => "=", 6726 Destroy_Value => Destroy, 6727 Hash => Hash); 6728 6729 Early_Call_Regions_Map : ECR_Map.Dynamic_Hash_Table := ECR_Map.Nil; 6730 6731 ----------------------- 6732 -- Local subprograms -- 6733 ----------------------- 6734 6735 function Early_Call_Region (Body_Id : Entity_Id) return Node_Id; 6736 pragma Inline (Early_Call_Region); 6737 -- Obtain the early call region associated with entry or subprogram body 6738 -- Body_Id. 6739 6740 procedure Set_Early_Call_Region (Body_Id : Entity_Id; Start : Node_Id); 6741 pragma Inline (Set_Early_Call_Region); 6742 -- Associate an early call region with begins at construct Start with 6743 -- entry or subprogram body Body_Id. 6744 6745 ------------- 6746 -- Destroy -- 6747 ------------- 6748 6749 procedure Destroy (N : in out Node_Id) is 6750 pragma Unreferenced (N); 6751 begin 6752 null; 6753 end Destroy; 6754 6755 ----------------------- 6756 -- Early_Call_Region -- 6757 ----------------------- 6758 6759 function Early_Call_Region (Body_Id : Entity_Id) return Node_Id is 6760 pragma Assert (Present (Body_Id)); 6761 begin 6762 return ECR_Map.Get (Early_Call_Regions_Map, Body_Id); 6763 end Early_Call_Region; 6764 6765 ------------------------------------------ 6766 -- Finalize_Early_Call_Region_Processor -- 6767 ------------------------------------------ 6768 6769 procedure Finalize_Early_Call_Region_Processor is 6770 begin 6771 ECR_Map.Destroy (Early_Call_Regions_Map); 6772 end Finalize_Early_Call_Region_Processor; 6773 6774 ---------------------------- 6775 -- Find_Early_Call_Region -- 6776 ---------------------------- 6777 6778 function Find_Early_Call_Region 6779 (Body_Decl : Node_Id; 6780 Assume_Elab_Body : Boolean := False; 6781 Skip_Memoization : Boolean := False) return Node_Id 6782 is 6783 -- NOTE: The routines within Find_Early_Call_Region are intentionally 6784 -- unnested to avoid deep indentation of code. 6785 6786 ECR_Found : exception; 6787 -- This exception is raised when the early call region has been found 6788 6789 Start : Node_Id := Empty; 6790 -- The start of the early call region. This variable is updated by 6791 -- the various nested routines. Due to the use of exceptions, the 6792 -- variable must be global to the nested routines. 6793 6794 -- The algorithm implemented in this routine attempts to find the 6795 -- early call region of a subprogram body by inspecting constructs 6796 -- in reverse declarative order, while navigating the tree. The 6797 -- algorithm consists of an Inspection phase and Advancement phase. 6798 -- The pseudocode is as follows: 6799 -- 6800 -- loop 6801 -- inspection phase 6802 -- advancement phase 6803 -- end loop 6804 -- 6805 -- The infinite loop is terminated by raising exception ECR_Found. 6806 -- The algorithm utilizes two pointers, Curr and Start, to represent 6807 -- the current construct to inspect and the start of the early call 6808 -- region. 6809 -- 6810 -- IMPORTANT: The algorithm must maintain the following invariant at 6811 -- all time for it to function properly: 6812 -- 6813 -- A nested construct is entered only when it contains suitable 6814 -- constructs. 6815 -- 6816 -- This guarantees that leaving a nested or encapsulating construct 6817 -- functions properly. 6818 -- 6819 -- The Inspection phase determines whether the current construct is 6820 -- non-preelaborable, and if it is, the algorithm terminates. 6821 -- 6822 -- The Advancement phase walks the tree in reverse declarative order, 6823 -- while entering and leaving nested and encapsulating constructs. It 6824 -- may also terminate the elaborithm. There are several special cases 6825 -- of advancement. 6826 -- 6827 -- 1) General case: 6828 -- 6829 -- <construct 1> 6830 -- ... 6831 -- <construct N-1> <- Curr 6832 -- <construct N> <- Start 6833 -- <subprogram body> 6834 -- 6835 -- In the general case, a declarative or statement list is traversed 6836 -- in reverse order where Curr is the lead pointer, and Start is the 6837 -- last preelaborable construct. 6838 -- 6839 -- 2) Entering handled bodies 6840 -- 6841 -- package body Nested is <- Curr (2.3) 6842 -- <declarations> <- Curr (2.2) 6843 -- begin 6844 -- <statements> <- Curr (2.1) 6845 -- end Nested; 6846 -- <construct> <- Start 6847 -- 6848 -- In this case, the algorithm enters a handled body by starting from 6849 -- the last statement (2.1), or the last declaration (2.2), or the 6850 -- body is consumed (2.3) because it is empty and thus preelaborable. 6851 -- 6852 -- 3) Entering package declarations 6853 -- 6854 -- package Nested is <- Curr (2.3) 6855 -- <visible declarations> <- Curr (2.2) 6856 -- private 6857 -- <private declarations> <- Curr (2.1) 6858 -- end Nested; 6859 -- <construct> <- Start 6860 -- 6861 -- In this case, the algorithm enters a package declaration by 6862 -- starting from the last private declaration (2.1), the last visible 6863 -- declaration (2.2), or the package is consumed (2.3) because it is 6864 -- empty and thus preelaborable. 6865 -- 6866 -- 4) Transitioning from list to list of the same construct 6867 -- 6868 -- Certain constructs have two eligible lists. The algorithm must 6869 -- thus transition from the second to the first list when the second 6870 -- list is exhausted. 6871 -- 6872 -- declare <- Curr (4.2) 6873 -- <declarations> <- Curr (4.1) 6874 -- begin 6875 -- <statements> <- Start 6876 -- end; 6877 -- 6878 -- In this case, the algorithm has exhausted the second list (the 6879 -- statements in the example above), and continues with the last 6880 -- declaration (4.1) or the construct is consumed (4.2) because it 6881 -- contains only preelaborable code. 6882 -- 6883 -- 5) Transitioning from list to construct 6884 -- 6885 -- tack body Task is <- Curr (5.1) 6886 -- <- Curr (Empty) 6887 -- <construct 1> <- Start 6888 -- 6889 -- In this case, the algorithm has exhausted a list, Curr is Empty, 6890 -- and the owner of the list is consumed (5.1). 6891 -- 6892 -- 6) Transitioning from unit to unit 6893 -- 6894 -- A package body with a spec subject to pragma Elaborate_Body 6895 -- extends the possible range of the early call region to the package 6896 -- spec. 6897 -- 6898 -- package Pack is <- Curr (6.3) 6899 -- pragma Elaborate_Body; <- Curr (6.2) 6900 -- <visible declarations> <- Curr (6.2) 6901 -- private 6902 -- <private declarations> <- Curr (6.1) 6903 -- end Pack; 6904 -- 6905 -- package body Pack is <- Curr, Start 6906 -- 6907 -- In this case, the algorithm has reached a package body compilation 6908 -- unit whose spec is subject to pragma Elaborate_Body, or the caller 6909 -- of the algorithm has specified this behavior. This transition is 6910 -- equivalent to 3). 6911 -- 6912 -- 7) Transitioning from unit to termination 6913 -- 6914 -- Reaching a compilation unit always terminates the algorithm as 6915 -- there are no more lists to examine. This must take case 6) into 6916 -- account. 6917 -- 6918 -- 8) Transitioning from subunit to stub 6919 -- 6920 -- package body Pack is separate; <- Curr (8.1) 6921 -- 6922 -- separate (...) 6923 -- package body Pack is <- Curr, Start 6924 -- 6925 -- Reaching a subunit continues the search from the corresponding 6926 -- stub (8.1). 6927 6928 procedure Advance (Curr : in out Node_Id); 6929 pragma Inline (Advance); 6930 -- Update the Curr and Start pointers depending on their location 6931 -- in the tree to the next eligible construct. This routine raises 6932 -- ECR_Found. 6933 6934 procedure Enter_Handled_Body (Curr : in out Node_Id); 6935 pragma Inline (Enter_Handled_Body); 6936 -- Update the Curr and Start pointers to enter a nested handled body 6937 -- if applicable. This routine raises ECR_Found. 6938 6939 procedure Enter_Package_Declaration (Curr : in out Node_Id); 6940 pragma Inline (Enter_Package_Declaration); 6941 -- Update the Curr and Start pointers to enter a nested package spec 6942 -- if applicable. This routine raises ECR_Found. 6943 6944 function Find_ECR (N : Node_Id) return Node_Id; 6945 pragma Inline (Find_ECR); 6946 -- Find an early call region starting from arbitrary node N 6947 6948 function Has_Suitable_Construct (List : List_Id) return Boolean; 6949 pragma Inline (Has_Suitable_Construct); 6950 -- Determine whether list List contains a suitable construct for 6951 -- inclusion into an early call region. 6952 6953 procedure Include (N : Node_Id; Curr : out Node_Id); 6954 pragma Inline (Include); 6955 -- Update the Curr and Start pointers to include arbitrary construct 6956 -- N in the early call region. This routine raises ECR_Found. 6957 6958 function Is_OK_Preelaborable_Construct (N : Node_Id) return Boolean; 6959 pragma Inline (Is_OK_Preelaborable_Construct); 6960 -- Determine whether arbitrary node N denotes a preelaboration-safe 6961 -- construct. 6962 6963 function Is_Suitable_Construct (N : Node_Id) return Boolean; 6964 pragma Inline (Is_Suitable_Construct); 6965 -- Determine whether arbitrary node N denotes a suitable construct 6966 -- for inclusion into the early call region. 6967 6968 function Previous_Suitable_Construct (N : Node_Id) return Node_Id; 6969 pragma Inline (Previous_Suitable_Construct); 6970 -- Return the previous node suitable for inclusion into the early 6971 -- call region. 6972 6973 procedure Transition_Body_Declarations 6974 (Bod : Node_Id; 6975 Curr : out Node_Id); 6976 pragma Inline (Transition_Body_Declarations); 6977 -- Update the Curr and Start pointers when construct Bod denotes a 6978 -- block statement or a suitable body. This routine raises ECR_Found. 6979 6980 procedure Transition_Handled_Statements 6981 (HSS : Node_Id; 6982 Curr : out Node_Id); 6983 pragma Inline (Transition_Handled_Statements); 6984 -- Update the Curr and Start pointers when node HSS denotes a handled 6985 -- sequence of statements. This routine raises ECR_Found. 6986 6987 procedure Transition_Spec_Declarations 6988 (Spec : Node_Id; 6989 Curr : out Node_Id); 6990 pragma Inline (Transition_Spec_Declarations); 6991 -- Update the Curr and Start pointers when construct Spec denotes 6992 -- a concurrent definition or a package spec. This routine raises 6993 -- ECR_Found. 6994 6995 procedure Transition_Unit (Unit : Node_Id; Curr : out Node_Id); 6996 pragma Inline (Transition_Unit); 6997 -- Update the Curr and Start pointers when node Unit denotes a 6998 -- potential compilation unit. This routine raises ECR_Found. 6999 7000 ------------- 7001 -- Advance -- 7002 ------------- 7003 7004 procedure Advance (Curr : in out Node_Id) is 7005 Context : Node_Id; 7006 7007 begin 7008 -- Curr denotes one of the following cases upon entry into this 7009 -- routine: 7010 -- 7011 -- * Empty - There is no current construct when a declarative or 7012 -- a statement list has been exhausted. This does not indicate 7013 -- that the early call region has been computed as it is still 7014 -- possible to transition to another list. 7015 -- 7016 -- * Encapsulator - The current construct wraps declarations 7017 -- and/or statements. This indicates that the early call 7018 -- region may extend within the nested construct. 7019 -- 7020 -- * Preelaborable - The current construct is preelaborable 7021 -- because Find_ECR would not invoke Advance if this was not 7022 -- the case. 7023 7024 -- The current construct is an encapsulator or is preelaborable 7025 7026 if Present (Curr) then 7027 7028 -- Enter encapsulators by inspecting their declarations and/or 7029 -- statements. 7030 7031 if Nkind (Curr) in N_Block_Statement | N_Package_Body then 7032 Enter_Handled_Body (Curr); 7033 7034 elsif Nkind (Curr) = N_Package_Declaration then 7035 Enter_Package_Declaration (Curr); 7036 7037 -- Early call regions have a property which can be exploited to 7038 -- optimize the algorithm. 7039 -- 7040 -- <preceding subprogram body> 7041 -- <preelaborable construct 1> 7042 -- ... 7043 -- <preelaborable construct N> 7044 -- <initiating subprogram body> 7045 -- 7046 -- If a traversal initiated from a subprogram body reaches a 7047 -- preceding subprogram body, then both bodies share the same 7048 -- early call region. 7049 -- 7050 -- The property results in the following desirable effects: 7051 -- 7052 -- * If the preceding body already has an early call region, 7053 -- then the initiating body can reuse it. This minimizes the 7054 -- amount of processing performed by the algorithm. 7055 -- 7056 -- * If the preceding body lack an early call region, then the 7057 -- algorithm can compute the early call region, and reuse it 7058 -- for the initiating body. This processing performs the same 7059 -- amount of work, but has the beneficial effect of computing 7060 -- the early call regions of all preceding bodies. 7061 7062 elsif Nkind (Curr) in N_Entry_Body | N_Subprogram_Body then 7063 Start := 7064 Find_Early_Call_Region 7065 (Body_Decl => Curr, 7066 Assume_Elab_Body => Assume_Elab_Body, 7067 Skip_Memoization => Skip_Memoization); 7068 7069 raise ECR_Found; 7070 7071 -- Otherwise current construct is preelaborable. Unpdate the 7072 -- early call region to include it. 7073 7074 else 7075 Include (Curr, Curr); 7076 end if; 7077 7078 -- Otherwise the current construct is missing, indicating that the 7079 -- current list has been exhausted. Depending on the context of 7080 -- the list, several transitions are possible. 7081 7082 else 7083 -- The invariant of the algorithm ensures that Curr and Start 7084 -- are at the same level of nesting at the point of transition. 7085 -- The algorithm can determine which list the traversal came 7086 -- from by examining Start. 7087 7088 Context := Parent (Start); 7089 7090 -- Attempt the following transitions: 7091 -- 7092 -- private declarations -> visible declarations 7093 -- private declarations -> upper level 7094 -- private declarations -> terminate 7095 -- visible declarations -> upper level 7096 -- visible declarations -> terminate 7097 7098 if Nkind (Context) in N_Package_Specification 7099 | N_Protected_Definition 7100 | N_Task_Definition 7101 then 7102 Transition_Spec_Declarations (Context, Curr); 7103 7104 -- Attempt the following transitions: 7105 -- 7106 -- statements -> declarations 7107 -- statements -> upper level 7108 -- statements -> corresponding package spec (Elab_Body) 7109 -- statements -> terminate 7110 7111 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements then 7112 Transition_Handled_Statements (Context, Curr); 7113 7114 -- Attempt the following transitions: 7115 -- 7116 -- declarations -> upper level 7117 -- declarations -> corresponding package spec (Elab_Body) 7118 -- declarations -> terminate 7119 7120 elsif Nkind (Context) in N_Block_Statement 7121 | N_Entry_Body 7122 | N_Package_Body 7123 | N_Protected_Body 7124 | N_Subprogram_Body 7125 | N_Task_Body 7126 then 7127 Transition_Body_Declarations (Context, Curr); 7128 7129 -- Otherwise it is not possible to transition. Stop the search 7130 -- because there are no more declarations or statements to 7131 -- check. 7132 7133 else 7134 raise ECR_Found; 7135 end if; 7136 end if; 7137 end Advance; 7138 7139 -------------------------- 7140 -- Enter_Handled_Body -- 7141 -------------------------- 7142 7143 procedure Enter_Handled_Body (Curr : in out Node_Id) is 7144 Decls : constant List_Id := Declarations (Curr); 7145 HSS : constant Node_Id := Handled_Statement_Sequence (Curr); 7146 Stmts : List_Id := No_List; 7147 7148 begin 7149 if Present (HSS) then 7150 Stmts := Statements (HSS); 7151 end if; 7152 7153 -- The handled body has a non-empty statement sequence. The 7154 -- construct to inspect is the last statement. 7155 7156 if Has_Suitable_Construct (Stmts) then 7157 Curr := Last (Stmts); 7158 7159 -- The handled body lacks statements, but has non-empty 7160 -- declarations. The construct to inspect is the last declaration. 7161 7162 elsif Has_Suitable_Construct (Decls) then 7163 Curr := Last (Decls); 7164 7165 -- Otherwise the handled body lacks both declarations and 7166 -- statements. The construct to inspect is the node which precedes 7167 -- the handled body. Update the early call region to include the 7168 -- handled body. 7169 7170 else 7171 Include (Curr, Curr); 7172 end if; 7173 end Enter_Handled_Body; 7174 7175 ------------------------------- 7176 -- Enter_Package_Declaration -- 7177 ------------------------------- 7178 7179 procedure Enter_Package_Declaration (Curr : in out Node_Id) is 7180 Pack_Spec : constant Node_Id := Specification (Curr); 7181 Prv_Decls : constant List_Id := Private_Declarations (Pack_Spec); 7182 Vis_Decls : constant List_Id := Visible_Declarations (Pack_Spec); 7183 7184 begin 7185 -- The package has a non-empty private declarations. The construct 7186 -- to inspect is the last private declaration. 7187 7188 if Has_Suitable_Construct (Prv_Decls) then 7189 Curr := Last (Prv_Decls); 7190 7191 -- The package lacks private declarations, but has non-empty 7192 -- visible declarations. In this case the construct to inspect 7193 -- is the last visible declaration. 7194 7195 elsif Has_Suitable_Construct (Vis_Decls) then 7196 Curr := Last (Vis_Decls); 7197 7198 -- Otherwise the package lacks any declarations. The construct 7199 -- to inspect is the node which precedes the package. Update the 7200 -- early call region to include the package declaration. 7201 7202 else 7203 Include (Curr, Curr); 7204 end if; 7205 end Enter_Package_Declaration; 7206 7207 -------------- 7208 -- Find_ECR -- 7209 -------------- 7210 7211 function Find_ECR (N : Node_Id) return Node_Id is 7212 Curr : Node_Id; 7213 7214 begin 7215 -- The early call region starts at N 7216 7217 Curr := Previous_Suitable_Construct (N); 7218 Start := N; 7219 7220 -- Inspect each node in reverse declarative order while going in 7221 -- and out of nested and enclosing constructs. Note that the only 7222 -- way to terminate this infinite loop is to raise ECR_Found. 7223 7224 loop 7225 -- The current construct is not preelaboration-safe. Terminate 7226 -- the traversal. 7227 7228 if Present (Curr) 7229 and then not Is_OK_Preelaborable_Construct (Curr) 7230 then 7231 raise ECR_Found; 7232 end if; 7233 7234 -- Advance to the next suitable construct. This may terminate 7235 -- the traversal by raising ECR_Found. 7236 7237 Advance (Curr); 7238 end loop; 7239 7240 exception 7241 when ECR_Found => 7242 return Start; 7243 end Find_ECR; 7244 7245 ---------------------------- 7246 -- Has_Suitable_Construct -- 7247 ---------------------------- 7248 7249 function Has_Suitable_Construct (List : List_Id) return Boolean is 7250 Item : Node_Id; 7251 7252 begin 7253 -- Examine the list in reverse declarative order, looking for a 7254 -- suitable construct. 7255 7256 if Present (List) then 7257 Item := Last (List); 7258 while Present (Item) loop 7259 if Is_Suitable_Construct (Item) then 7260 return True; 7261 end if; 7262 7263 Prev (Item); 7264 end loop; 7265 end if; 7266 7267 return False; 7268 end Has_Suitable_Construct; 7269 7270 ------------- 7271 -- Include -- 7272 ------------- 7273 7274 procedure Include (N : Node_Id; Curr : out Node_Id) is 7275 begin 7276 Start := N; 7277 7278 -- The input node is a compilation unit. This terminates the 7279 -- search because there are no more lists to inspect and there are 7280 -- no more enclosing constructs to climb up to. The transitions 7281 -- are: 7282 -- 7283 -- private declarations -> terminate 7284 -- visible declarations -> terminate 7285 -- statements -> terminate 7286 -- declarations -> terminate 7287 7288 if Nkind (Parent (Start)) = N_Compilation_Unit then 7289 raise ECR_Found; 7290 7291 -- Otherwise the input node is still within some list 7292 7293 else 7294 Curr := Previous_Suitable_Construct (Start); 7295 end if; 7296 end Include; 7297 7298 ----------------------------------- 7299 -- Is_OK_Preelaborable_Construct -- 7300 ----------------------------------- 7301 7302 function Is_OK_Preelaborable_Construct (N : Node_Id) return Boolean is 7303 begin 7304 -- Assignment statements are acceptable as long as they were 7305 -- produced by the ABE mechanism to update elaboration flags. 7306 7307 if Nkind (N) = N_Assignment_Statement then 7308 return Is_Elaboration_Code (N); 7309 7310 -- Block statements are acceptable even though they directly 7311 -- violate preelaborability. The intention is not to penalize 7312 -- the early call region when a block contains only preelaborable 7313 -- constructs. 7314 -- 7315 -- declare 7316 -- Val : constant Integer := 1; 7317 -- begin 7318 -- pragma Assert (Val = 1); 7319 -- null; 7320 -- end; 7321 -- 7322 -- Note that the Advancement phase does enter blocks, and will 7323 -- detect any non-preelaborable declarations or statements within. 7324 7325 elsif Nkind (N) = N_Block_Statement then 7326 return True; 7327 end if; 7328 7329 -- Otherwise the construct must be preelaborable. The check must 7330 -- take the syntactic and semantic structure of the construct. DO 7331 -- NOT use Is_Preelaborable_Construct here. 7332 7333 return not Is_Non_Preelaborable_Construct (N); 7334 end Is_OK_Preelaborable_Construct; 7335 7336 --------------------------- 7337 -- Is_Suitable_Construct -- 7338 --------------------------- 7339 7340 function Is_Suitable_Construct (N : Node_Id) return Boolean is 7341 Context : constant Node_Id := Parent (N); 7342 7343 begin 7344 -- An internally-generated statement sequence which contains only 7345 -- a single null statement is not a suitable construct because it 7346 -- is a byproduct of the parser. Such a null statement should be 7347 -- excluded from the early call region because it carries the 7348 -- source location of the "end" keyword, and may lead to confusing 7349 -- diagnistics. 7350 7351 if Nkind (N) = N_Null_Statement 7352 and then not Comes_From_Source (N) 7353 and then Present (Context) 7354 and then Nkind (Context) = N_Handled_Sequence_Of_Statements 7355 then 7356 return False; 7357 end if; 7358 7359 -- Otherwise only constructs which correspond to pure Ada 7360 -- constructs are considered suitable. 7361 7362 case Nkind (N) is 7363 when N_Call_Marker 7364 | N_Freeze_Entity 7365 | N_Freeze_Generic_Entity 7366 | N_Implicit_Label_Declaration 7367 | N_Itype_Reference 7368 | N_Pop_Constraint_Error_Label 7369 | N_Pop_Program_Error_Label 7370 | N_Pop_Storage_Error_Label 7371 | N_Push_Constraint_Error_Label 7372 | N_Push_Program_Error_Label 7373 | N_Push_Storage_Error_Label 7374 | N_SCIL_Dispatch_Table_Tag_Init 7375 | N_SCIL_Dispatching_Call 7376 | N_SCIL_Membership_Test 7377 | N_Variable_Reference_Marker 7378 => 7379 return False; 7380 7381 when others => 7382 return True; 7383 end case; 7384 end Is_Suitable_Construct; 7385 7386 --------------------------------- 7387 -- Previous_Suitable_Construct -- 7388 --------------------------------- 7389 7390 function Previous_Suitable_Construct (N : Node_Id) return Node_Id is 7391 P : Node_Id; 7392 7393 begin 7394 P := Prev (N); 7395 7396 while Present (P) and then not Is_Suitable_Construct (P) loop 7397 Prev (P); 7398 end loop; 7399 7400 return P; 7401 end Previous_Suitable_Construct; 7402 7403 ---------------------------------- 7404 -- Transition_Body_Declarations -- 7405 ---------------------------------- 7406 7407 procedure Transition_Body_Declarations 7408 (Bod : Node_Id; 7409 Curr : out Node_Id) 7410 is 7411 Decls : constant List_Id := Declarations (Bod); 7412 7413 begin 7414 -- The search must come from the declarations of the body 7415 7416 pragma Assert 7417 (Is_Non_Empty_List (Decls) 7418 and then List_Containing (Start) = Decls); 7419 7420 -- The search finished inspecting the declarations. The construct 7421 -- to inspect is the node which precedes the handled body, unless 7422 -- the body is a compilation unit. The transitions are: 7423 -- 7424 -- declarations -> upper level 7425 -- declarations -> corresponding package spec (Elab_Body) 7426 -- declarations -> terminate 7427 7428 Transition_Unit (Bod, Curr); 7429 end Transition_Body_Declarations; 7430 7431 ----------------------------------- 7432 -- Transition_Handled_Statements -- 7433 ----------------------------------- 7434 7435 procedure Transition_Handled_Statements 7436 (HSS : Node_Id; 7437 Curr : out Node_Id) 7438 is 7439 Bod : constant Node_Id := Parent (HSS); 7440 Decls : constant List_Id := Declarations (Bod); 7441 Stmts : constant List_Id := Statements (HSS); 7442 7443 begin 7444 -- The search must come from the statements of certain bodies or 7445 -- statements. 7446 7447 pragma Assert 7448 (Nkind (Bod) in 7449 N_Block_Statement | 7450 N_Entry_Body | 7451 N_Package_Body | 7452 N_Protected_Body | 7453 N_Subprogram_Body | 7454 N_Task_Body); 7455 7456 -- The search must come from the statements of the handled 7457 -- sequence. 7458 7459 pragma Assert 7460 (Is_Non_Empty_List (Stmts) 7461 and then List_Containing (Start) = Stmts); 7462 7463 -- The search finished inspecting the statements. The handled body 7464 -- has non-empty declarations. The construct to inspect is the 7465 -- last declaration. The transitions are: 7466 -- 7467 -- statements -> declarations 7468 7469 if Has_Suitable_Construct (Decls) then 7470 Curr := Last (Decls); 7471 7472 -- Otherwise the handled body lacks declarations. The construct to 7473 -- inspect is the node which precedes the handled body, unless the 7474 -- body is a compilation unit. The transitions are: 7475 -- 7476 -- statements -> upper level 7477 -- statements -> corresponding package spec (Elab_Body) 7478 -- statements -> terminate 7479 7480 else 7481 Transition_Unit (Bod, Curr); 7482 end if; 7483 end Transition_Handled_Statements; 7484 7485 ---------------------------------- 7486 -- Transition_Spec_Declarations -- 7487 ---------------------------------- 7488 7489 procedure Transition_Spec_Declarations 7490 (Spec : Node_Id; 7491 Curr : out Node_Id) 7492 is 7493 Prv_Decls : constant List_Id := Private_Declarations (Spec); 7494 Vis_Decls : constant List_Id := Visible_Declarations (Spec); 7495 7496 begin 7497 pragma Assert (Present (Start) and then Is_List_Member (Start)); 7498 7499 -- The search came from the private declarations and finished 7500 -- their inspection. 7501 7502 if Has_Suitable_Construct (Prv_Decls) 7503 and then List_Containing (Start) = Prv_Decls 7504 then 7505 -- The context has non-empty visible declarations. The node to 7506 -- inspect is the last visible declaration. The transitions 7507 -- are: 7508 -- 7509 -- private declarations -> visible declarations 7510 7511 if Has_Suitable_Construct (Vis_Decls) then 7512 Curr := Last (Vis_Decls); 7513 7514 -- Otherwise the context lacks visible declarations. The 7515 -- construct to inspect is the node which precedes the context 7516 -- unless the context is a compilation unit. The transitions 7517 -- are: 7518 -- 7519 -- private declarations -> upper level 7520 -- private declarations -> terminate 7521 7522 else 7523 Transition_Unit (Parent (Spec), Curr); 7524 end if; 7525 7526 -- The search came from the visible declarations and finished 7527 -- their inspections. The construct to inspect is the node which 7528 -- precedes the context, unless the context is a compilaton unit. 7529 -- The transitions are: 7530 -- 7531 -- visible declarations -> upper level 7532 -- visible declarations -> terminate 7533 7534 elsif Has_Suitable_Construct (Vis_Decls) 7535 and then List_Containing (Start) = Vis_Decls 7536 then 7537 Transition_Unit (Parent (Spec), Curr); 7538 7539 -- At this point both declarative lists are empty, but the 7540 -- traversal still came from within the spec. This indicates 7541 -- that the invariant of the algorithm has been violated. 7542 7543 else 7544 pragma Assert (False); 7545 raise ECR_Found; 7546 end if; 7547 end Transition_Spec_Declarations; 7548 7549 --------------------- 7550 -- Transition_Unit -- 7551 --------------------- 7552 7553 procedure Transition_Unit 7554 (Unit : Node_Id; 7555 Curr : out Node_Id) 7556 is 7557 Context : constant Node_Id := Parent (Unit); 7558 7559 begin 7560 -- The unit is a compilation unit. This terminates the search 7561 -- because there are no more lists to inspect and there are no 7562 -- more enclosing constructs to climb up to. 7563 7564 if Nkind (Context) = N_Compilation_Unit then 7565 7566 -- A package body with a corresponding spec subject to pragma 7567 -- Elaborate_Body is an exception to the above. The annotation 7568 -- allows the search to continue into the package declaration. 7569 -- The transitions are: 7570 -- 7571 -- statements -> corresponding package spec (Elab_Body) 7572 -- declarations -> corresponding package spec (Elab_Body) 7573 7574 if Nkind (Unit) = N_Package_Body 7575 and then (Assume_Elab_Body 7576 or else Has_Pragma_Elaborate_Body 7577 (Corresponding_Spec (Unit))) 7578 then 7579 Curr := Unit_Declaration_Node (Corresponding_Spec (Unit)); 7580 Enter_Package_Declaration (Curr); 7581 7582 -- Otherwise terminate the search. The transitions are: 7583 -- 7584 -- private declarations -> terminate 7585 -- visible declarations -> terminate 7586 -- statements -> terminate 7587 -- declarations -> terminate 7588 7589 else 7590 raise ECR_Found; 7591 end if; 7592 7593 -- The unit is a subunit. The construct to inspect is the node 7594 -- which precedes the corresponding stub. Update the early call 7595 -- region to include the unit. 7596 7597 elsif Nkind (Context) = N_Subunit then 7598 Start := Unit; 7599 Curr := Corresponding_Stub (Context); 7600 7601 -- Otherwise the unit is nested. The construct to inspect is the 7602 -- node which precedes the unit. Update the early call region to 7603 -- include the unit. 7604 7605 else 7606 Include (Unit, Curr); 7607 end if; 7608 end Transition_Unit; 7609 7610 -- Local variables 7611 7612 Body_Id : constant Entity_Id := Unique_Defining_Entity (Body_Decl); 7613 Region : Node_Id; 7614 7615 -- Start of processing for Find_Early_Call_Region 7616 7617 begin 7618 -- The caller demands the start of the early call region without 7619 -- saving or retrieving it to/from internal data structures. 7620 7621 if Skip_Memoization then 7622 Region := Find_ECR (Body_Decl); 7623 7624 -- Default behavior 7625 7626 else 7627 -- Check whether the early call region of the subprogram body is 7628 -- available. 7629 7630 Region := Early_Call_Region (Body_Id); 7631 7632 if No (Region) then 7633 Region := Find_ECR (Body_Decl); 7634 7635 -- Associate the early call region with the subprogram body in 7636 -- case other scenarios need it. 7637 7638 Set_Early_Call_Region (Body_Id, Region); 7639 end if; 7640 end if; 7641 7642 -- A subprogram body must always have an early call region 7643 7644 pragma Assert (Present (Region)); 7645 7646 return Region; 7647 end Find_Early_Call_Region; 7648 7649 -------------------------------------------- 7650 -- Initialize_Early_Call_Region_Processor -- 7651 -------------------------------------------- 7652 7653 procedure Initialize_Early_Call_Region_Processor is 7654 begin 7655 Early_Call_Regions_Map := ECR_Map.Create (100); 7656 end Initialize_Early_Call_Region_Processor; 7657 7658 --------------------------- 7659 -- Set_Early_Call_Region -- 7660 --------------------------- 7661 7662 procedure Set_Early_Call_Region (Body_Id : Entity_Id; Start : Node_Id) is 7663 pragma Assert (Present (Body_Id)); 7664 pragma Assert (Present (Start)); 7665 7666 begin 7667 ECR_Map.Put (Early_Call_Regions_Map, Body_Id, Start); 7668 end Set_Early_Call_Region; 7669 end Early_Call_Region_Processor; 7670 7671 ---------------------- 7672 -- Elaborated_Units -- 7673 ---------------------- 7674 7675 package body Elaborated_Units is 7676 7677 ----------- 7678 -- Types -- 7679 ----------- 7680 7681 -- The following type idenfities the elaboration attributes of a unit 7682 7683 type Elaboration_Attributes_Id is new Natural; 7684 7685 No_Elaboration_Attributes : constant Elaboration_Attributes_Id := 7686 Elaboration_Attributes_Id'First; 7687 First_Elaboration_Attributes : constant Elaboration_Attributes_Id := 7688 No_Elaboration_Attributes + 1; 7689 7690 -- The following type represents the elaboration attributes of a unit 7691 7692 type Elaboration_Attributes_Record is record 7693 Elab_Pragma : Node_Id := Empty; 7694 -- This attribute denotes a source Elaborate or Elaborate_All pragma 7695 -- which guarantees the prior elaboration of some unit with respect 7696 -- to the main unit. The pragma may come from the following contexts: 7697 -- 7698 -- * The main unit 7699 -- * The spec of the main unit (if applicable) 7700 -- * Any parent spec of the main unit (if applicable) 7701 -- * Any parent subunit of the main unit (if applicable) 7702 -- 7703 -- The attribute remains Empty if no such pragma is available. Source 7704 -- pragmas play a role in satisfying SPARK elaboration requirements. 7705 7706 With_Clause : Node_Id := Empty; 7707 -- This attribute denotes an internally-generated or a source with 7708 -- clause for some unit withed by the main unit. With clauses carry 7709 -- flags which represent implicit Elaborate or Elaborate_All pragmas. 7710 -- These clauses play a role in supplying elaboration dependencies to 7711 -- binde. 7712 end record; 7713 7714 --------------------- 7715 -- Data structures -- 7716 --------------------- 7717 7718 -- The following table stores all elaboration attributes 7719 7720 package Elaboration_Attributes is new Table.Table 7721 (Table_Index_Type => Elaboration_Attributes_Id, 7722 Table_Component_Type => Elaboration_Attributes_Record, 7723 Table_Low_Bound => First_Elaboration_Attributes, 7724 Table_Initial => 250, 7725 Table_Increment => 200, 7726 Table_Name => "Elaboration_Attributes"); 7727 7728 procedure Destroy (EA_Id : in out Elaboration_Attributes_Id); 7729 -- Destroy elaboration attributes EA_Id 7730 7731 package UA_Map is new Dynamic_Hash_Tables 7732 (Key_Type => Entity_Id, 7733 Value_Type => Elaboration_Attributes_Id, 7734 No_Value => No_Elaboration_Attributes, 7735 Expansion_Threshold => 1.5, 7736 Expansion_Factor => 2, 7737 Compression_Threshold => 0.3, 7738 Compression_Factor => 2, 7739 "=" => "=", 7740 Destroy_Value => Destroy, 7741 Hash => Hash); 7742 7743 -- The following map relates an elaboration attributes of a unit to the 7744 -- unit. 7745 7746 Unit_To_Attributes_Map : UA_Map.Dynamic_Hash_Table := UA_Map.Nil; 7747 7748 ------------------ 7749 -- Constructors -- 7750 ------------------ 7751 7752 function Elaboration_Attributes_Of 7753 (Unit_Id : Entity_Id) return Elaboration_Attributes_Id; 7754 pragma Inline (Elaboration_Attributes_Of); 7755 -- Obtain the elaboration attributes of unit Unit_Id 7756 7757 ----------------------- 7758 -- Local subprograms -- 7759 ----------------------- 7760 7761 function Elab_Pragma (EA_Id : Elaboration_Attributes_Id) return Node_Id; 7762 pragma Inline (Elab_Pragma); 7763 -- Obtain the Elaborate[_All] pragma of elaboration attributes EA_Id 7764 7765 procedure Ensure_Prior_Elaboration_Dynamic 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_Dynamic); 7771 -- Guarantee the elaboration of unit Unit_Id with respect to the main 7772 -- unit by suggesting the use of Elaborate[_All] with name Prag_Nam. N 7773 -- denotes the related scenario. In_State is the current state of the 7774 -- Processing phase. 7775 7776 procedure Ensure_Prior_Elaboration_Static 7777 (N : Node_Id; 7778 Unit_Id : Entity_Id; 7779 Prag_Nam : Name_Id; 7780 In_State : Processing_In_State); 7781 pragma Inline (Ensure_Prior_Elaboration_Static); 7782 -- Guarantee the elaboration of unit Unit_Id with respect to the main 7783 -- unit by installing an implicit Elaborate[_All] pragma with name 7784 -- Prag_Nam. N denotes the related scenario. In_State is the current 7785 -- state of the Processing phase. 7786 7787 function Present (EA_Id : Elaboration_Attributes_Id) return Boolean; 7788 pragma Inline (Present); 7789 -- Determine whether elaboration attributes UA_Id exist 7790 7791 procedure Set_Elab_Pragma 7792 (EA_Id : Elaboration_Attributes_Id; 7793 Prag : Node_Id); 7794 pragma Inline (Set_Elab_Pragma); 7795 -- Set the Elaborate[_All] pragma of elaboration attributes EA_Id to 7796 -- Prag. 7797 7798 procedure Set_With_Clause 7799 (EA_Id : Elaboration_Attributes_Id; 7800 Clause : Node_Id); 7801 pragma Inline (Set_With_Clause); 7802 -- Set the with clause of elaboration attributes EA_Id to Clause 7803 7804 function With_Clause (EA_Id : Elaboration_Attributes_Id) return Node_Id; 7805 pragma Inline (With_Clause); 7806 -- Obtain the implicit or source with clause of elaboration attributes 7807 -- EA_Id. 7808 7809 ------------------------------ 7810 -- Collect_Elaborated_Units -- 7811 ------------------------------ 7812 7813 procedure Collect_Elaborated_Units is 7814 procedure Add_Pragma (Prag : Node_Id); 7815 pragma Inline (Add_Pragma); 7816 -- Determine whether pragma Prag denotes a legal Elaborate[_All] 7817 -- pragma. If this is the case, add the related unit to the context. 7818 -- For pragma Elaborate_All, include recursively all units withed by 7819 -- the related unit. 7820 7821 procedure Add_Unit 7822 (Unit_Id : Entity_Id; 7823 Prag : Node_Id; 7824 Full_Context : Boolean); 7825 pragma Inline (Add_Unit); 7826 -- Add unit Unit_Id to the elaboration context. Prag denotes the 7827 -- pragma which prompted the inclusion of the unit to the context. 7828 -- If flag Full_Context is set, examine the nonlimited clauses of 7829 -- unit Unit_Id and add each withed unit to the context. 7830 7831 procedure Find_Elaboration_Context (Comp_Unit : Node_Id); 7832 pragma Inline (Find_Elaboration_Context); 7833 -- Examine the context items of compilation unit Comp_Unit for 7834 -- suitable elaboration-related pragmas and add all related units 7835 -- to the context. 7836 7837 ---------------- 7838 -- Add_Pragma -- 7839 ---------------- 7840 7841 procedure Add_Pragma (Prag : Node_Id) is 7842 Prag_Args : constant List_Id := 7843 Pragma_Argument_Associations (Prag); 7844 Prag_Nam : constant Name_Id := Pragma_Name (Prag); 7845 Unit_Arg : Node_Id; 7846 7847 begin 7848 -- Nothing to do if the pragma is not related to elaboration 7849 7850 if Prag_Nam not in Name_Elaborate | Name_Elaborate_All then 7851 return; 7852 7853 -- Nothing to do when the pragma is illegal 7854 7855 elsif Error_Posted (Prag) then 7856 return; 7857 end if; 7858 7859 Unit_Arg := Get_Pragma_Arg (First (Prag_Args)); 7860 7861 -- The argument of the pragma may appear in package.package form 7862 7863 if Nkind (Unit_Arg) = N_Selected_Component then 7864 Unit_Arg := Selector_Name (Unit_Arg); 7865 end if; 7866 7867 Add_Unit 7868 (Unit_Id => Entity (Unit_Arg), 7869 Prag => Prag, 7870 Full_Context => Prag_Nam = Name_Elaborate_All); 7871 end Add_Pragma; 7872 7873 -------------- 7874 -- Add_Unit -- 7875 -------------- 7876 7877 procedure Add_Unit 7878 (Unit_Id : Entity_Id; 7879 Prag : Node_Id; 7880 Full_Context : Boolean) 7881 is 7882 Clause : Node_Id; 7883 EA_Id : Elaboration_Attributes_Id; 7884 Unit_Prag : Node_Id; 7885 7886 begin 7887 -- Nothing to do when some previous error left a with clause or a 7888 -- pragma in a bad state. 7889 7890 if No (Unit_Id) then 7891 return; 7892 end if; 7893 7894 EA_Id := Elaboration_Attributes_Of (Unit_Id); 7895 Unit_Prag := Elab_Pragma (EA_Id); 7896 7897 -- The unit is already included in the context by means of pragma 7898 -- Elaborate[_All]. 7899 7900 if Present (Unit_Prag) then 7901 7902 -- Upgrade an existing pragma Elaborate when the unit is 7903 -- subject to Elaborate_All because the new pragma covers a 7904 -- larger set of units. 7905 7906 if Pragma_Name (Unit_Prag) = Name_Elaborate 7907 and then Pragma_Name (Prag) = Name_Elaborate_All 7908 then 7909 Set_Elab_Pragma (EA_Id, Prag); 7910 7911 -- Otherwise the unit retains its existing pragma and does not 7912 -- need to be included in the context again. 7913 7914 else 7915 return; 7916 end if; 7917 7918 -- Otherwise the current unit is not included in the context 7919 7920 else 7921 Set_Elab_Pragma (EA_Id, Prag); 7922 end if; 7923 7924 -- Includes all units withed by the current one when computing the 7925 -- full context. 7926 7927 if Full_Context then 7928 7929 -- Process all nonlimited with clauses found in the context of 7930 -- the current unit. Note that limited clauses do not impose an 7931 -- elaboration order. 7932 7933 Clause := First (Context_Items (Compilation_Unit (Unit_Id))); 7934 while Present (Clause) loop 7935 if Nkind (Clause) = N_With_Clause 7936 and then not Error_Posted (Clause) 7937 and then not Limited_Present (Clause) 7938 then 7939 Add_Unit 7940 (Unit_Id => Entity (Name (Clause)), 7941 Prag => Prag, 7942 Full_Context => Full_Context); 7943 end if; 7944 7945 Next (Clause); 7946 end loop; 7947 end if; 7948 end Add_Unit; 7949 7950 ------------------------------ 7951 -- Find_Elaboration_Context -- 7952 ------------------------------ 7953 7954 procedure Find_Elaboration_Context (Comp_Unit : Node_Id) is 7955 pragma Assert (Nkind (Comp_Unit) = N_Compilation_Unit); 7956 7957 Prag : Node_Id; 7958 7959 begin 7960 -- Process all elaboration-related pragmas found in the context of 7961 -- the compilation unit. 7962 7963 Prag := First (Context_Items (Comp_Unit)); 7964 while Present (Prag) loop 7965 if Nkind (Prag) = N_Pragma then 7966 Add_Pragma (Prag); 7967 end if; 7968 7969 Next (Prag); 7970 end loop; 7971 end Find_Elaboration_Context; 7972 7973 -- Local variables 7974 7975 Par_Id : Entity_Id; 7976 Unit_Id : Node_Id; 7977 7978 -- Start of processing for Collect_Elaborated_Units 7979 7980 begin 7981 -- Perform a traversal to examines the context of the main unit. The 7982 -- traversal performs the following jumps: 7983 -- 7984 -- subunit -> parent subunit 7985 -- parent subunit -> body 7986 -- body -> spec 7987 -- spec -> parent spec 7988 -- parent spec -> grandparent spec and so on 7989 -- 7990 -- The traversal relies on units rather than scopes because the scope 7991 -- of a subunit is some spec, while this traversal must process the 7992 -- body as well. Given that protected and task bodies can also be 7993 -- subunits, this complicates the scope approach even further. 7994 7995 Unit_Id := Unit (Cunit (Main_Unit)); 7996 7997 -- Perform the following traversals when the main unit is a subunit 7998 -- 7999 -- subunit -> parent subunit 8000 -- parent subunit -> body 8001 8002 while Present (Unit_Id) and then Nkind (Unit_Id) = N_Subunit loop 8003 Find_Elaboration_Context (Parent (Unit_Id)); 8004 8005 -- Continue the traversal by going to the unit which contains the 8006 -- corresponding stub. 8007 8008 if Present (Corresponding_Stub (Unit_Id)) then 8009 Unit_Id := 8010 Unit (Cunit (Get_Source_Unit (Corresponding_Stub (Unit_Id)))); 8011 8012 -- Otherwise the subunit may be erroneous or left in a bad state 8013 8014 else 8015 exit; 8016 end if; 8017 end loop; 8018 8019 -- Perform the following traversal now that subunits have been taken 8020 -- care of, or the main unit is a body. 8021 -- 8022 -- body -> spec 8023 8024 if Present (Unit_Id) 8025 and then Nkind (Unit_Id) in N_Package_Body | N_Subprogram_Body 8026 then 8027 Find_Elaboration_Context (Parent (Unit_Id)); 8028 8029 -- Continue the traversal by going to the unit which contains the 8030 -- corresponding spec. 8031 8032 if Present (Corresponding_Spec (Unit_Id)) then 8033 Unit_Id := 8034 Unit (Cunit (Get_Source_Unit (Corresponding_Spec (Unit_Id)))); 8035 end if; 8036 end if; 8037 8038 -- Perform the following traversals now that the body has been taken 8039 -- care of, or the main unit is a spec. 8040 -- 8041 -- spec -> parent spec 8042 -- parent spec -> grandparent spec and so on 8043 8044 if Present (Unit_Id) 8045 and then Nkind (Unit_Id) in N_Generic_Package_Declaration 8046 | N_Generic_Subprogram_Declaration 8047 | N_Package_Declaration 8048 | N_Subprogram_Declaration 8049 then 8050 Find_Elaboration_Context (Parent (Unit_Id)); 8051 8052 -- Process a potential chain of parent units which ends with the 8053 -- main unit spec. The traversal can now safely rely on the scope 8054 -- chain. 8055 8056 Par_Id := Scope (Defining_Entity (Unit_Id)); 8057 while Present (Par_Id) and then Par_Id /= Standard_Standard loop 8058 Find_Elaboration_Context (Compilation_Unit (Par_Id)); 8059 8060 Par_Id := Scope (Par_Id); 8061 end loop; 8062 end if; 8063 end Collect_Elaborated_Units; 8064 8065 ------------- 8066 -- Destroy -- 8067 ------------- 8068 8069 procedure Destroy (EA_Id : in out Elaboration_Attributes_Id) is 8070 pragma Unreferenced (EA_Id); 8071 begin 8072 null; 8073 end Destroy; 8074 8075 ----------------- 8076 -- Elab_Pragma -- 8077 ----------------- 8078 8079 function Elab_Pragma 8080 (EA_Id : Elaboration_Attributes_Id) return Node_Id 8081 is 8082 pragma Assert (Present (EA_Id)); 8083 begin 8084 return Elaboration_Attributes.Table (EA_Id).Elab_Pragma; 8085 end Elab_Pragma; 8086 8087 ------------------------------- 8088 -- Elaboration_Attributes_Of -- 8089 ------------------------------- 8090 8091 function Elaboration_Attributes_Of 8092 (Unit_Id : Entity_Id) return Elaboration_Attributes_Id 8093 is 8094 EA_Id : Elaboration_Attributes_Id; 8095 8096 begin 8097 EA_Id := UA_Map.Get (Unit_To_Attributes_Map, Unit_Id); 8098 8099 -- The unit lacks elaboration attributes. This indicates that the 8100 -- unit is encountered for the first time. Create the elaboration 8101 -- attributes for it. 8102 8103 if not Present (EA_Id) then 8104 Elaboration_Attributes.Append 8105 ((Elab_Pragma => Empty, 8106 With_Clause => Empty)); 8107 EA_Id := Elaboration_Attributes.Last; 8108 8109 -- Associate the elaboration attributes with the unit 8110 8111 UA_Map.Put (Unit_To_Attributes_Map, Unit_Id, EA_Id); 8112 end if; 8113 8114 pragma Assert (Present (EA_Id)); 8115 8116 return EA_Id; 8117 end Elaboration_Attributes_Of; 8118 8119 ------------------------------ 8120 -- Ensure_Prior_Elaboration -- 8121 ------------------------------ 8122 8123 procedure Ensure_Prior_Elaboration 8124 (N : Node_Id; 8125 Unit_Id : Entity_Id; 8126 Prag_Nam : Name_Id; 8127 In_State : Processing_In_State) 8128 is 8129 pragma Assert (Prag_Nam in Name_Elaborate | Name_Elaborate_All); 8130 8131 begin 8132 -- Nothing to do when the need for prior elaboration came from a 8133 -- partial finalization routine which occurs in an initialization 8134 -- context. This behavior parallels that of the old ABE mechanism. 8135 8136 if In_State.Within_Partial_Finalization then 8137 return; 8138 8139 -- Nothing to do when the need for prior elaboration came from a task 8140 -- body and switch -gnatd.y (disable implicit pragma Elaborate_All on 8141 -- task bodies) is in effect. 8142 8143 elsif Debug_Flag_Dot_Y and then In_State.Within_Task_Body then 8144 return; 8145 8146 -- Nothing to do when the unit is elaborated prior to the main unit. 8147 -- This check must also consider the following cases: 8148 -- 8149 -- * No check is made against the context of the main unit because 8150 -- this is specific to the elaboration model in effect and requires 8151 -- custom handling (see Ensure_xxx_Prior_Elaboration). 8152 -- 8153 -- * Unit_Id is subject to pragma Elaborate_Body. An implicit pragma 8154 -- Elaborate[_All] MUST be generated even though Unit_Id is always 8155 -- elaborated prior to the main unit. This conservative strategy 8156 -- ensures that other units withed by Unit_Id will not lead to an 8157 -- ABE. 8158 -- 8159 -- package A is package body A is 8160 -- procedure ABE; procedure ABE is ... end ABE; 8161 -- end A; end A; 8162 -- 8163 -- with A; 8164 -- package B is package body B is 8165 -- pragma Elaborate_Body; procedure Proc is 8166 -- begin 8167 -- procedure Proc; A.ABE; 8168 -- package B; end Proc; 8169 -- end B; 8170 -- 8171 -- with B; 8172 -- package C is package body C is 8173 -- ... ... 8174 -- end C; begin 8175 -- B.Proc; 8176 -- end C; 8177 -- 8178 -- In the example above, the elaboration of C invokes B.Proc. B is 8179 -- subject to pragma Elaborate_Body. If no pragma Elaborate[_All] 8180 -- is gnerated for B in C, then the following elaboratio order will 8181 -- lead to an ABE: 8182 -- 8183 -- spec of A elaborated 8184 -- spec of B elaborated 8185 -- body of B elaborated 8186 -- spec of C elaborated 8187 -- body of C elaborated <-- calls B.Proc which calls A.ABE 8188 -- body of A elaborated <-- problem 8189 -- 8190 -- The generation of an implicit pragma Elaborate_All (B) ensures 8191 -- that the elaboration-order mechanism will not pick the above 8192 -- order. 8193 -- 8194 -- An implicit Elaborate is NOT generated when the unit is subject 8195 -- to Elaborate_Body because both pragmas have the same effect. 8196 -- 8197 -- * Unit_Id is the main unit. An implicit pragma Elaborate[_All] 8198 -- MUST NOT be generated in this case because a unit cannot depend 8199 -- on its own elaboration. This case is therefore treated as valid 8200 -- prior elaboration. 8201 8202 elsif Has_Prior_Elaboration 8203 (Unit_Id => Unit_Id, 8204 Same_Unit_OK => True, 8205 Elab_Body_OK => Prag_Nam = Name_Elaborate) 8206 then 8207 return; 8208 end if; 8209 8210 -- Suggest the use of pragma Prag_Nam when the dynamic model is in 8211 -- effect. 8212 8213 if Dynamic_Elaboration_Checks then 8214 Ensure_Prior_Elaboration_Dynamic 8215 (N => N, 8216 Unit_Id => Unit_Id, 8217 Prag_Nam => Prag_Nam, 8218 In_State => In_State); 8219 8220 -- Install an implicit pragma Prag_Nam when the static model is in 8221 -- effect. 8222 8223 else 8224 pragma Assert (Static_Elaboration_Checks); 8225 8226 Ensure_Prior_Elaboration_Static 8227 (N => N, 8228 Unit_Id => Unit_Id, 8229 Prag_Nam => Prag_Nam, 8230 In_State => In_State); 8231 end if; 8232 end Ensure_Prior_Elaboration; 8233 8234 -------------------------------------- 8235 -- Ensure_Prior_Elaboration_Dynamic -- 8236 -------------------------------------- 8237 8238 procedure Ensure_Prior_Elaboration_Dynamic 8239 (N : Node_Id; 8240 Unit_Id : Entity_Id; 8241 Prag_Nam : Name_Id; 8242 In_State : Processing_In_State) 8243 is 8244 procedure Info_Missing_Pragma; 8245 pragma Inline (Info_Missing_Pragma); 8246 -- Output information concerning missing Elaborate or Elaborate_All 8247 -- pragma with name Prag_Nam for scenario N, which would ensure the 8248 -- prior elaboration of Unit_Id. 8249 8250 ------------------------- 8251 -- Info_Missing_Pragma -- 8252 ------------------------- 8253 8254 procedure Info_Missing_Pragma is 8255 begin 8256 -- Internal units are ignored as they cause unnecessary noise 8257 8258 if not In_Internal_Unit (Unit_Id) then 8259 8260 -- The name of the unit subjected to the elaboration pragma is 8261 -- fully qualified to improve the clarity of the info message. 8262 8263 Error_Msg_Name_1 := Prag_Nam; 8264 Error_Msg_Qual_Level := Nat'Last; 8265 8266 Error_Msg_NE ("info: missing pragma % for unit &", N, Unit_Id); 8267 Error_Msg_Qual_Level := 0; 8268 end if; 8269 end Info_Missing_Pragma; 8270 8271 -- Local variables 8272 8273 EA_Id : constant Elaboration_Attributes_Id := 8274 Elaboration_Attributes_Of (Unit_Id); 8275 N_Lvl : Enclosing_Level_Kind; 8276 N_Rep : Scenario_Rep_Id; 8277 8278 -- Start of processing for Ensure_Prior_Elaboration_Dynamic 8279 8280 begin 8281 -- Nothing to do when the unit is guaranteed prior elaboration by 8282 -- means of a source Elaborate[_All] pragma. 8283 8284 if Present (Elab_Pragma (EA_Id)) then 8285 return; 8286 end if; 8287 8288 -- Output extra information on a missing Elaborate[_All] pragma when 8289 -- switch -gnatel (info messages on implicit Elaborate[_All] pragmas 8290 -- is in effect. 8291 8292 if Elab_Info_Messages 8293 and then not In_State.Suppress_Info_Messages 8294 then 8295 N_Rep := Scenario_Representation_Of (N, In_State); 8296 N_Lvl := Level (N_Rep); 8297 8298 -- Declaration-level scenario 8299 8300 if (Is_Suitable_Call (N) or else Is_Suitable_Instantiation (N)) 8301 and then N_Lvl = Declaration_Level 8302 then 8303 null; 8304 8305 -- Library-level scenario 8306 8307 elsif N_Lvl in Library_Level then 8308 null; 8309 8310 -- Instantiation library-level scenario 8311 8312 elsif N_Lvl = Instantiation_Level then 8313 null; 8314 8315 -- Otherwise the scenario does not appear at the proper level 8316 8317 else 8318 return; 8319 end if; 8320 8321 Info_Missing_Pragma; 8322 end if; 8323 end Ensure_Prior_Elaboration_Dynamic; 8324 8325 ------------------------------------- 8326 -- Ensure_Prior_Elaboration_Static -- 8327 ------------------------------------- 8328 8329 procedure Ensure_Prior_Elaboration_Static 8330 (N : Node_Id; 8331 Unit_Id : Entity_Id; 8332 Prag_Nam : Name_Id; 8333 In_State : Processing_In_State) 8334 is 8335 function Find_With_Clause 8336 (Items : List_Id; 8337 Withed_Id : Entity_Id) return Node_Id; 8338 pragma Inline (Find_With_Clause); 8339 -- Find a nonlimited with clause in the list of context items Items 8340 -- that withs unit Withed_Id. Return Empty if no such clause exists. 8341 8342 procedure Info_Implicit_Pragma; 8343 pragma Inline (Info_Implicit_Pragma); 8344 -- Output information concerning an implicitly generated Elaborate 8345 -- or Elaborate_All pragma with name Prag_Nam for scenario N which 8346 -- ensures the prior elaboration of unit Unit_Id. 8347 8348 ---------------------- 8349 -- Find_With_Clause -- 8350 ---------------------- 8351 8352 function Find_With_Clause 8353 (Items : List_Id; 8354 Withed_Id : Entity_Id) return Node_Id 8355 is 8356 Item : Node_Id; 8357 8358 begin 8359 -- Examine the context clauses looking for a suitable with. Note 8360 -- that limited clauses do not affect the elaboration order. 8361 8362 Item := First (Items); 8363 while Present (Item) loop 8364 if Nkind (Item) = N_With_Clause 8365 and then not Error_Posted (Item) 8366 and then not Limited_Present (Item) 8367 and then Entity (Name (Item)) = Withed_Id 8368 then 8369 return Item; 8370 end if; 8371 8372 Next (Item); 8373 end loop; 8374 8375 return Empty; 8376 end Find_With_Clause; 8377 8378 -------------------------- 8379 -- Info_Implicit_Pragma -- 8380 -------------------------- 8381 8382 procedure Info_Implicit_Pragma is 8383 begin 8384 -- Internal units are ignored as they cause unnecessary noise 8385 8386 if not In_Internal_Unit (Unit_Id) then 8387 8388 -- The name of the unit subjected to the elaboration pragma is 8389 -- fully qualified to improve the clarity of the info message. 8390 8391 Error_Msg_Name_1 := Prag_Nam; 8392 Error_Msg_Qual_Level := Nat'Last; 8393 8394 Error_Msg_NE 8395 ("info: implicit pragma % generated for unit &", N, Unit_Id); 8396 8397 Error_Msg_Qual_Level := 0; 8398 Output_Active_Scenarios (N, In_State); 8399 end if; 8400 end Info_Implicit_Pragma; 8401 8402 -- Local variables 8403 8404 EA_Id : constant Elaboration_Attributes_Id := 8405 Elaboration_Attributes_Of (Unit_Id); 8406 8407 Main_Cunit : constant Node_Id := Cunit (Main_Unit); 8408 Loc : constant Source_Ptr := Sloc (Main_Cunit); 8409 Unit_Cunit : constant Node_Id := Compilation_Unit (Unit_Id); 8410 Unit_Prag : constant Node_Id := Elab_Pragma (EA_Id); 8411 Unit_With : constant Node_Id := With_Clause (EA_Id); 8412 8413 Clause : Node_Id; 8414 Items : List_Id; 8415 8416 -- Start of processing for Ensure_Prior_Elaboration_Static 8417 8418 begin 8419 -- Nothing to do when the caller has suppressed the generation of 8420 -- implicit Elaborate[_All] pragmas. 8421 8422 if In_State.Suppress_Implicit_Pragmas then 8423 return; 8424 8425 -- Nothing to do when the unit is guaranteed prior elaboration by 8426 -- means of a source Elaborate[_All] pragma. 8427 8428 elsif Present (Unit_Prag) then 8429 return; 8430 8431 -- Nothing to do when the unit has an existing implicit Elaborate or 8432 -- Elaborate_All pragma installed by a previous scenario. 8433 8434 elsif Present (Unit_With) then 8435 8436 -- The unit is already guaranteed prior elaboration by means of an 8437 -- implicit Elaborate pragma, however the current scenario imposes 8438 -- a stronger requirement of Elaborate_All. "Upgrade" the existing 8439 -- pragma to match this new requirement. 8440 8441 if Elaborate_Desirable (Unit_With) 8442 and then Prag_Nam = Name_Elaborate_All 8443 then 8444 Set_Elaborate_All_Desirable (Unit_With); 8445 Set_Elaborate_Desirable (Unit_With, False); 8446 end if; 8447 8448 return; 8449 end if; 8450 8451 -- At this point it is known that the unit has no prior elaboration 8452 -- according to pragmas and hierarchical relationships. 8453 8454 Items := Context_Items (Main_Cunit); 8455 8456 if No (Items) then 8457 Items := New_List; 8458 Set_Context_Items (Main_Cunit, Items); 8459 end if; 8460 8461 -- Locate the with clause for the unit. Note that there may not be a 8462 -- clause if the unit is visible through a subunit-body, body-spec, 8463 -- or spec-parent relationship. 8464 8465 Clause := 8466 Find_With_Clause 8467 (Items => Items, 8468 Withed_Id => Unit_Id); 8469 8470 -- Generate: 8471 -- with Id; 8472 8473 -- Note that adding implicit with clauses is safe because analysis, 8474 -- resolution, and expansion have already taken place and it is not 8475 -- possible to interfere with visibility. 8476 8477 if No (Clause) then 8478 Clause := 8479 Make_With_Clause (Loc, 8480 Name => New_Occurrence_Of (Unit_Id, Loc)); 8481 8482 Set_Implicit_With (Clause); 8483 Set_Library_Unit (Clause, Unit_Cunit); 8484 8485 Append_To (Items, Clause); 8486 end if; 8487 8488 -- Mark the with clause depending on the pragma required 8489 8490 if Prag_Nam = Name_Elaborate then 8491 Set_Elaborate_Desirable (Clause); 8492 else 8493 Set_Elaborate_All_Desirable (Clause); 8494 end if; 8495 8496 -- The implicit Elaborate[_All] ensures the prior elaboration of 8497 -- the unit. Include the unit in the elaboration context of the 8498 -- main unit. 8499 8500 Set_With_Clause (EA_Id, Clause); 8501 8502 -- Output extra information on an implicit Elaborate[_All] pragma 8503 -- when switch -gnatel (info messages on implicit Elaborate[_All] 8504 -- pragmas is in effect. 8505 8506 if Elab_Info_Messages then 8507 Info_Implicit_Pragma; 8508 end if; 8509 end Ensure_Prior_Elaboration_Static; 8510 8511 ------------------------------- 8512 -- Finalize_Elaborated_Units -- 8513 ------------------------------- 8514 8515 procedure Finalize_Elaborated_Units is 8516 begin 8517 UA_Map.Destroy (Unit_To_Attributes_Map); 8518 end Finalize_Elaborated_Units; 8519 8520 --------------------------- 8521 -- Has_Prior_Elaboration -- 8522 --------------------------- 8523 8524 function Has_Prior_Elaboration 8525 (Unit_Id : Entity_Id; 8526 Context_OK : Boolean := False; 8527 Elab_Body_OK : Boolean := False; 8528 Same_Unit_OK : Boolean := False) return Boolean 8529 is 8530 EA_Id : constant Elaboration_Attributes_Id := 8531 Elaboration_Attributes_Of (Unit_Id); 8532 Main_Id : constant Entity_Id := Main_Unit_Entity; 8533 Unit_Prag : constant Node_Id := Elab_Pragma (EA_Id); 8534 Unit_With : constant Node_Id := With_Clause (EA_Id); 8535 8536 begin 8537 -- A preelaborated unit is always elaborated prior to the main unit 8538 8539 if Is_Preelaborated_Unit (Unit_Id) then 8540 return True; 8541 8542 -- An internal unit is always elaborated prior to a non-internal main 8543 -- unit. 8544 8545 elsif In_Internal_Unit (Unit_Id) 8546 and then not In_Internal_Unit (Main_Id) 8547 then 8548 return True; 8549 8550 -- A unit has prior elaboration if it appears within the context 8551 -- of the main unit. Consider this case only when requested by the 8552 -- caller. 8553 8554 elsif Context_OK 8555 and then (Present (Unit_Prag) or else Present (Unit_With)) 8556 then 8557 return True; 8558 8559 -- A unit whose body is elaborated together with its spec has prior 8560 -- elaboration except with respect to itself. Consider this case only 8561 -- when requested by the caller. 8562 8563 elsif Elab_Body_OK 8564 and then Has_Pragma_Elaborate_Body (Unit_Id) 8565 and then not Is_Same_Unit (Unit_Id, Main_Id) 8566 then 8567 return True; 8568 8569 -- A unit has no prior elaboration with respect to itself, but does 8570 -- not require any means of ensuring its own elaboration either. 8571 -- Treat this case as valid prior elaboration only when requested by 8572 -- the caller. 8573 8574 elsif Same_Unit_OK and then Is_Same_Unit (Unit_Id, Main_Id) then 8575 return True; 8576 end if; 8577 8578 return False; 8579 end Has_Prior_Elaboration; 8580 8581 --------------------------------- 8582 -- Initialize_Elaborated_Units -- 8583 --------------------------------- 8584 8585 procedure Initialize_Elaborated_Units is 8586 begin 8587 Unit_To_Attributes_Map := UA_Map.Create (250); 8588 end Initialize_Elaborated_Units; 8589 8590 ---------------------------------- 8591 -- Meet_Elaboration_Requirement -- 8592 ---------------------------------- 8593 8594 procedure Meet_Elaboration_Requirement 8595 (N : Node_Id; 8596 Targ_Id : Entity_Id; 8597 Req_Nam : Name_Id; 8598 In_State : Processing_In_State) 8599 is 8600 pragma Assert (Req_Nam in Name_Elaborate | Name_Elaborate_All); 8601 8602 Main_Id : constant Entity_Id := Main_Unit_Entity; 8603 Unit_Id : constant Entity_Id := Find_Top_Unit (Targ_Id); 8604 8605 procedure Elaboration_Requirement_Error; 8606 pragma Inline (Elaboration_Requirement_Error); 8607 -- Emit an error concerning scenario N which has failed to meet the 8608 -- elaboration requirement. 8609 8610 function Find_Preelaboration_Pragma 8611 (Prag_Nam : Name_Id) return Node_Id; 8612 pragma Inline (Find_Preelaboration_Pragma); 8613 -- Traverse the visible declarations of unit Unit_Id and locate a 8614 -- source preelaboration-related pragma with name Prag_Nam. 8615 8616 procedure Info_Requirement_Met (Prag : Node_Id); 8617 pragma Inline (Info_Requirement_Met); 8618 -- Output information concerning pragma Prag which meets requirement 8619 -- Req_Nam. 8620 8621 ----------------------------------- 8622 -- Elaboration_Requirement_Error -- 8623 ----------------------------------- 8624 8625 procedure Elaboration_Requirement_Error is 8626 begin 8627 if Is_Suitable_Call (N) then 8628 Info_Call 8629 (Call => N, 8630 Subp_Id => Targ_Id, 8631 Info_Msg => False, 8632 In_SPARK => True); 8633 8634 elsif Is_Suitable_Instantiation (N) then 8635 Info_Instantiation 8636 (Inst => N, 8637 Gen_Id => Targ_Id, 8638 Info_Msg => False, 8639 In_SPARK => True); 8640 8641 elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then 8642 Error_Msg_N 8643 ("read of refinement constituents during elaboration in " 8644 & "SPARK", N); 8645 8646 elsif Is_Suitable_Variable_Reference (N) then 8647 Info_Variable_Reference 8648 (Ref => N, 8649 Var_Id => Targ_Id); 8650 8651 -- No other scenario may impose a requirement on the context of 8652 -- the main unit. 8653 8654 else 8655 pragma Assert (False); 8656 return; 8657 end if; 8658 8659 Error_Msg_Name_1 := Req_Nam; 8660 Error_Msg_Node_2 := Unit_Id; 8661 Error_Msg_NE ("\\unit & requires pragma % for &", N, Main_Id); 8662 8663 Output_Active_Scenarios (N, In_State); 8664 end Elaboration_Requirement_Error; 8665 8666 -------------------------------- 8667 -- Find_Preelaboration_Pragma -- 8668 -------------------------------- 8669 8670 function Find_Preelaboration_Pragma 8671 (Prag_Nam : Name_Id) return Node_Id 8672 is 8673 Spec : constant Node_Id := Parent (Unit_Id); 8674 Decl : Node_Id; 8675 8676 begin 8677 -- A preelaboration-related pragma comes from source and appears 8678 -- at the top of the visible declarations of a package. 8679 8680 if Nkind (Spec) = N_Package_Specification then 8681 Decl := First (Visible_Declarations (Spec)); 8682 while Present (Decl) loop 8683 if Comes_From_Source (Decl) then 8684 if Nkind (Decl) = N_Pragma 8685 and then Pragma_Name (Decl) = Prag_Nam 8686 then 8687 return Decl; 8688 8689 -- Otherwise the construct terminates the region where 8690 -- the preelaboration-related pragma may appear. 8691 8692 else 8693 exit; 8694 end if; 8695 end if; 8696 8697 Next (Decl); 8698 end loop; 8699 end if; 8700 8701 return Empty; 8702 end Find_Preelaboration_Pragma; 8703 8704 -------------------------- 8705 -- Info_Requirement_Met -- 8706 -------------------------- 8707 8708 procedure Info_Requirement_Met (Prag : Node_Id) is 8709 pragma Assert (Present (Prag)); 8710 8711 begin 8712 Error_Msg_Name_1 := Req_Nam; 8713 Error_Msg_Sloc := Sloc (Prag); 8714 Error_Msg_NE 8715 ("\\% requirement for unit & met by pragma #", N, Unit_Id); 8716 end Info_Requirement_Met; 8717 8718 -- Local variables 8719 8720 EA_Id : Elaboration_Attributes_Id; 8721 Elab_Nam : Name_Id; 8722 Req_Met : Boolean; 8723 Unit_Prag : Node_Id; 8724 8725 -- Start of processing for Meet_Elaboration_Requirement 8726 8727 begin 8728 -- Assume that the requirement has not been met 8729 8730 Req_Met := False; 8731 8732 -- If the target is within the main unit, either at the source level 8733 -- or through an instantiation, then there is no real requirement to 8734 -- meet because the main unit cannot force its own elaboration by 8735 -- means of an Elaborate[_All] pragma. Treat this case as valid 8736 -- coverage. 8737 8738 if In_Extended_Main_Code_Unit (Targ_Id) then 8739 Req_Met := True; 8740 8741 -- Otherwise the target resides in an external unit 8742 8743 -- The requirement is met when the target comes from an internal unit 8744 -- because such a unit is elaborated prior to a non-internal unit. 8745 8746 elsif In_Internal_Unit (Unit_Id) 8747 and then not In_Internal_Unit (Main_Id) 8748 then 8749 Req_Met := True; 8750 8751 -- The requirement is met when the target comes from a preelaborated 8752 -- unit. This portion must parallel predicate Is_Preelaborated_Unit. 8753 8754 elsif Is_Preelaborated_Unit (Unit_Id) then 8755 Req_Met := True; 8756 8757 -- Output extra information when switch -gnatel (info messages on 8758 -- implicit Elaborate[_All] pragmas. 8759 8760 if Elab_Info_Messages 8761 and then not In_State.Suppress_Info_Messages 8762 then 8763 if Is_Preelaborated (Unit_Id) then 8764 Elab_Nam := Name_Preelaborate; 8765 8766 elsif Is_Pure (Unit_Id) then 8767 Elab_Nam := Name_Pure; 8768 8769 elsif Is_Remote_Call_Interface (Unit_Id) then 8770 Elab_Nam := Name_Remote_Call_Interface; 8771 8772 elsif Is_Remote_Types (Unit_Id) then 8773 Elab_Nam := Name_Remote_Types; 8774 8775 else 8776 pragma Assert (Is_Shared_Passive (Unit_Id)); 8777 Elab_Nam := Name_Shared_Passive; 8778 end if; 8779 8780 Info_Requirement_Met (Find_Preelaboration_Pragma (Elab_Nam)); 8781 end if; 8782 8783 -- Determine whether the context of the main unit has a pragma strong 8784 -- enough to meet the requirement. 8785 8786 else 8787 EA_Id := Elaboration_Attributes_Of (Unit_Id); 8788 Unit_Prag := Elab_Pragma (EA_Id); 8789 8790 -- The pragma must be either Elaborate_All or be as strong as the 8791 -- requirement. 8792 8793 if Present (Unit_Prag) 8794 and then Pragma_Name (Unit_Prag) in Name_Elaborate_All | Req_Nam 8795 then 8796 Req_Met := True; 8797 8798 -- Output extra information when switch -gnatel (info messages 8799 -- on implicit Elaborate[_All] pragmas. 8800 8801 if Elab_Info_Messages 8802 and then not In_State.Suppress_Info_Messages 8803 then 8804 Info_Requirement_Met (Unit_Prag); 8805 end if; 8806 end if; 8807 end if; 8808 8809 -- The requirement was not met by the context of the main unit, issue 8810 -- an error. 8811 8812 if not Req_Met then 8813 Elaboration_Requirement_Error; 8814 end if; 8815 end Meet_Elaboration_Requirement; 8816 8817 ------------- 8818 -- Present -- 8819 ------------- 8820 8821 function Present (EA_Id : Elaboration_Attributes_Id) return Boolean is 8822 begin 8823 return EA_Id /= No_Elaboration_Attributes; 8824 end Present; 8825 8826 --------------------- 8827 -- Set_Elab_Pragma -- 8828 --------------------- 8829 8830 procedure Set_Elab_Pragma 8831 (EA_Id : Elaboration_Attributes_Id; 8832 Prag : Node_Id) 8833 is 8834 pragma Assert (Present (EA_Id)); 8835 begin 8836 Elaboration_Attributes.Table (EA_Id).Elab_Pragma := Prag; 8837 end Set_Elab_Pragma; 8838 8839 --------------------- 8840 -- Set_With_Clause -- 8841 --------------------- 8842 8843 procedure Set_With_Clause 8844 (EA_Id : Elaboration_Attributes_Id; 8845 Clause : Node_Id) 8846 is 8847 pragma Assert (Present (EA_Id)); 8848 begin 8849 Elaboration_Attributes.Table (EA_Id).With_Clause := Clause; 8850 end Set_With_Clause; 8851 8852 ----------------- 8853 -- With_Clause -- 8854 ----------------- 8855 8856 function With_Clause 8857 (EA_Id : Elaboration_Attributes_Id) return Node_Id 8858 is 8859 pragma Assert (Present (EA_Id)); 8860 begin 8861 return Elaboration_Attributes.Table (EA_Id).With_Clause; 8862 end With_Clause; 8863 end Elaborated_Units; 8864 8865 ------------------------------ 8866 -- Elaboration_Phase_Active -- 8867 ------------------------------ 8868 8869 function Elaboration_Phase_Active return Boolean is 8870 begin 8871 return Elaboration_Phase = Active; 8872 end Elaboration_Phase_Active; 8873 8874 ------------------------------ 8875 -- Error_Preelaborated_Call -- 8876 ------------------------------ 8877 8878 procedure Error_Preelaborated_Call (N : Node_Id) is 8879 begin 8880 -- This is a warning in GNAT mode allowing such calls to be used in the 8881 -- predefined library units with appropriate care. 8882 8883 Error_Msg_Warn := GNAT_Mode; 8884 8885 -- Ada 2022 (AI12-0175): Calls to certain functions that are essentially 8886 -- unchecked conversions are preelaborable. 8887 8888 if Ada_Version >= Ada_2022 then 8889 Error_Msg_N 8890 ("<<non-preelaborable call not allowed in preelaborated unit", N); 8891 else 8892 Error_Msg_N 8893 ("<<non-static call not allowed in preelaborated unit", N); 8894 end if; 8895 end Error_Preelaborated_Call; 8896 8897 ---------------------------------- 8898 -- Finalize_All_Data_Structures -- 8899 ---------------------------------- 8900 8901 procedure Finalize_All_Data_Structures is 8902 begin 8903 Finalize_Body_Processor; 8904 Finalize_Early_Call_Region_Processor; 8905 Finalize_Elaborated_Units; 8906 Finalize_Internal_Representation; 8907 Finalize_Invocation_Graph; 8908 Finalize_Scenario_Storage; 8909 end Finalize_All_Data_Structures; 8910 8911 ----------------------------- 8912 -- Find_Enclosing_Instance -- 8913 ----------------------------- 8914 8915 function Find_Enclosing_Instance (N : Node_Id) return Node_Id is 8916 Par : Node_Id; 8917 8918 begin 8919 -- Climb the parent chain looking for an enclosing instance spec or body 8920 8921 Par := N; 8922 while Present (Par) loop 8923 if Nkind (Par) in N_Package_Body 8924 | N_Package_Declaration 8925 | N_Subprogram_Body 8926 | N_Subprogram_Declaration 8927 and then Is_Generic_Instance (Unique_Defining_Entity (Par)) 8928 then 8929 return Par; 8930 end if; 8931 8932 Par := Parent (Par); 8933 end loop; 8934 8935 return Empty; 8936 end Find_Enclosing_Instance; 8937 8938 -------------------------- 8939 -- Find_Enclosing_Level -- 8940 -------------------------- 8941 8942 function Find_Enclosing_Level (N : Node_Id) return Enclosing_Level_Kind is 8943 function Level_Of (Unit : Node_Id) return Enclosing_Level_Kind; 8944 pragma Inline (Level_Of); 8945 -- Obtain the corresponding level of unit Unit 8946 8947 -------------- 8948 -- Level_Of -- 8949 -------------- 8950 8951 function Level_Of (Unit : Node_Id) return Enclosing_Level_Kind is 8952 Spec_Id : Entity_Id; 8953 8954 begin 8955 if Nkind (Unit) in N_Generic_Instantiation then 8956 return Instantiation_Level; 8957 8958 elsif Nkind (Unit) = N_Generic_Package_Declaration then 8959 return Generic_Spec_Level; 8960 8961 elsif Nkind (Unit) = N_Package_Declaration then 8962 return Library_Spec_Level; 8963 8964 elsif Nkind (Unit) = N_Package_Body then 8965 Spec_Id := Corresponding_Spec (Unit); 8966 8967 -- The body belongs to a generic package 8968 8969 if Present (Spec_Id) 8970 and then Ekind (Spec_Id) = E_Generic_Package 8971 then 8972 return Generic_Body_Level; 8973 8974 -- Otherwise the body belongs to a non-generic package. This also 8975 -- treats an illegal package body without a corresponding spec as 8976 -- a non-generic package body. 8977 8978 else 8979 return Library_Body_Level; 8980 end if; 8981 end if; 8982 8983 return No_Level; 8984 end Level_Of; 8985 8986 -- Local variables 8987 8988 Context : Node_Id; 8989 Curr : Node_Id; 8990 Prev : Node_Id; 8991 8992 -- Start of processing for Find_Enclosing_Level 8993 8994 begin 8995 -- Call markers and instantiations which appear at the declaration level 8996 -- but are later relocated in a different context retain their original 8997 -- declaration level. 8998 8999 if Nkind (N) in N_Call_Marker 9000 | N_Function_Instantiation 9001 | N_Package_Instantiation 9002 | N_Procedure_Instantiation 9003 and then Is_Declaration_Level_Node (N) 9004 then 9005 return Declaration_Level; 9006 end if; 9007 9008 -- Climb the parent chain looking at the enclosing levels 9009 9010 Prev := N; 9011 Curr := Parent (Prev); 9012 while Present (Curr) loop 9013 9014 -- A traversal from a subunit continues via the corresponding stub 9015 9016 if Nkind (Curr) = N_Subunit then 9017 Curr := Corresponding_Stub (Curr); 9018 9019 -- The current construct is a package. Packages are ignored because 9020 -- they are always elaborated when the enclosing context is invoked 9021 -- or elaborated. 9022 9023 elsif Nkind (Curr) in N_Package_Body | N_Package_Declaration then 9024 null; 9025 9026 -- The current construct is a block statement 9027 9028 elsif Nkind (Curr) = N_Block_Statement then 9029 9030 -- Ignore internally generated blocks created by the expander for 9031 -- various purposes such as abort defer/undefer. 9032 9033 if not Comes_From_Source (Curr) then 9034 null; 9035 9036 -- If the traversal came from the handled sequence of statments, 9037 -- then the node appears at the level of the enclosing construct. 9038 -- This is a more reliable test because transients scopes within 9039 -- the declarative region of the encapsulator are hard to detect. 9040 9041 elsif Nkind (Prev) = N_Handled_Sequence_Of_Statements 9042 and then Handled_Statement_Sequence (Curr) = Prev 9043 then 9044 return Find_Enclosing_Level (Parent (Curr)); 9045 9046 -- Otherwise the traversal came from the declarations, the node is 9047 -- at the declaration level. 9048 9049 else 9050 return Declaration_Level; 9051 end if; 9052 9053 -- The current construct is a declaration-level encapsulator 9054 9055 elsif Nkind (Curr) in 9056 N_Entry_Body | N_Subprogram_Body | N_Task_Body 9057 then 9058 -- If the traversal came from the handled sequence of statments, 9059 -- then the node cannot possibly appear at any level. This is 9060 -- a more reliable test because transients scopes within the 9061 -- declarative region of the encapsulator are hard to detect. 9062 9063 if Nkind (Prev) = N_Handled_Sequence_Of_Statements 9064 and then Handled_Statement_Sequence (Curr) = Prev 9065 then 9066 return No_Level; 9067 9068 -- Otherwise the traversal came from the declarations, the node is 9069 -- at the declaration level. 9070 9071 else 9072 return Declaration_Level; 9073 end if; 9074 9075 -- The current construct is a non-library-level encapsulator which 9076 -- indicates that the node cannot possibly appear at any level. Note 9077 -- that the check must come after the declaration-level check because 9078 -- both predicates share certain nodes. 9079 9080 elsif Is_Non_Library_Level_Encapsulator (Curr) then 9081 Context := Parent (Curr); 9082 9083 -- The sole exception is when the encapsulator is the compilation 9084 -- utit itself because the compilation unit node requires special 9085 -- processing (see below). 9086 9087 if Present (Context) 9088 and then Nkind (Context) = N_Compilation_Unit 9089 then 9090 null; 9091 9092 -- Otherwise the node is not at any level 9093 9094 else 9095 return No_Level; 9096 end if; 9097 9098 -- The current construct is a compilation unit. The node appears at 9099 -- the [generic] library level when the unit is a [generic] package. 9100 9101 elsif Nkind (Curr) = N_Compilation_Unit then 9102 return Level_Of (Unit (Curr)); 9103 end if; 9104 9105 Prev := Curr; 9106 Curr := Parent (Prev); 9107 end loop; 9108 9109 return No_Level; 9110 end Find_Enclosing_Level; 9111 9112 ------------------- 9113 -- Find_Top_Unit -- 9114 ------------------- 9115 9116 function Find_Top_Unit (N : Node_Or_Entity_Id) return Entity_Id is 9117 begin 9118 return Find_Unit_Entity (Unit (Cunit (Get_Top_Level_Code_Unit (N)))); 9119 end Find_Top_Unit; 9120 9121 ---------------------- 9122 -- Find_Unit_Entity -- 9123 ---------------------- 9124 9125 function Find_Unit_Entity (N : Node_Id) return Entity_Id is 9126 Context : constant Node_Id := Parent (N); 9127 Orig_N : constant Node_Id := Original_Node (N); 9128 9129 begin 9130 -- The unit denotes a package body of an instantiation which acts as 9131 -- a compilation unit. The proper entity is that of the package spec. 9132 9133 if Nkind (N) = N_Package_Body 9134 and then Nkind (Orig_N) = N_Package_Instantiation 9135 and then Nkind (Context) = N_Compilation_Unit 9136 then 9137 return Corresponding_Spec (N); 9138 9139 -- The unit denotes an anonymous package created to wrap a subprogram 9140 -- instantiation which acts as a compilation unit. The proper entity is 9141 -- that of the "related instance". 9142 9143 elsif Nkind (N) = N_Package_Declaration 9144 and then Nkind (Orig_N) in 9145 N_Function_Instantiation | N_Procedure_Instantiation 9146 and then Nkind (Context) = N_Compilation_Unit 9147 then 9148 return Related_Instance (Defining_Entity (N)); 9149 9150 -- The unit denotes a concurrent body acting as a subunit. Such bodies 9151 -- are generally rewritten into null statements. The proper entity is 9152 -- that of the "original node". 9153 9154 elsif Nkind (N) = N_Subunit 9155 and then Nkind (Proper_Body (N)) = N_Null_Statement 9156 and then Nkind (Original_Node (Proper_Body (N))) in 9157 N_Protected_Body | N_Task_Body 9158 then 9159 return Defining_Entity (Original_Node (Proper_Body (N))); 9160 9161 -- Otherwise the proper entity is the defining entity 9162 9163 else 9164 return Defining_Entity (N); 9165 end if; 9166 end Find_Unit_Entity; 9167 9168 ----------------------- 9169 -- First_Formal_Type -- 9170 ----------------------- 9171 9172 function First_Formal_Type (Subp_Id : Entity_Id) return Entity_Id is 9173 Formal_Id : constant Entity_Id := First_Formal (Subp_Id); 9174 Typ : Entity_Id; 9175 9176 begin 9177 if Present (Formal_Id) then 9178 Typ := Etype (Formal_Id); 9179 9180 -- Handle various combinations of concurrent and private types 9181 9182 loop 9183 if Ekind (Typ) in E_Protected_Type | E_Task_Type 9184 and then Present (Anonymous_Object (Typ)) 9185 then 9186 Typ := Anonymous_Object (Typ); 9187 9188 elsif Is_Concurrent_Record_Type (Typ) then 9189 Typ := Corresponding_Concurrent_Type (Typ); 9190 9191 elsif Is_Private_Type (Typ) and then Present (Full_View (Typ)) then 9192 Typ := Full_View (Typ); 9193 9194 else 9195 exit; 9196 end if; 9197 end loop; 9198 9199 return Typ; 9200 end if; 9201 9202 return Empty; 9203 end First_Formal_Type; 9204 9205 ------------------------------ 9206 -- Guaranteed_ABE_Processor -- 9207 ------------------------------ 9208 9209 package body Guaranteed_ABE_Processor is 9210 function Is_Guaranteed_ABE 9211 (N : Node_Id; 9212 Target_Decl : Node_Id; 9213 Target_Body : Node_Id) return Boolean; 9214 pragma Inline (Is_Guaranteed_ABE); 9215 -- Determine whether scenario N with a target described by its initial 9216 -- declaration Target_Decl and body Target_Decl results in a guaranteed 9217 -- ABE. 9218 9219 procedure Process_Guaranteed_ABE_Activation 9220 (Call : Node_Id; 9221 Call_Rep : Scenario_Rep_Id; 9222 Obj_Id : Entity_Id; 9223 Obj_Rep : Target_Rep_Id; 9224 Task_Typ : Entity_Id; 9225 Task_Rep : Target_Rep_Id; 9226 In_State : Processing_In_State); 9227 pragma Inline (Process_Guaranteed_ABE_Activation); 9228 -- Perform common guaranteed ABE checks and diagnostics for activation 9229 -- call Call which activates object Obj_Id of task type Task_Typ. Formal 9230 -- Call_Rep denotes the representation of the call. Obj_Rep denotes the 9231 -- representation of the object. Task_Rep denotes the representation of 9232 -- the task type. In_State is the current state of the Processing phase. 9233 9234 procedure Process_Guaranteed_ABE_Call 9235 (Call : Node_Id; 9236 Call_Rep : Scenario_Rep_Id; 9237 In_State : Processing_In_State); 9238 pragma Inline (Process_Guaranteed_ABE_Call); 9239 -- Perform common guaranteed ABE checks and diagnostics for call Call 9240 -- with representation Call_Rep. In_State denotes the current state of 9241 -- the Processing phase. 9242 9243 procedure Process_Guaranteed_ABE_Instantiation 9244 (Inst : Node_Id; 9245 Inst_Rep : Scenario_Rep_Id; 9246 In_State : Processing_In_State); 9247 pragma Inline (Process_Guaranteed_ABE_Instantiation); 9248 -- Perform common guaranteed ABE checks and diagnostics for instance 9249 -- Inst with representation Inst_Rep. In_State is the current state of 9250 -- the Processing phase. 9251 9252 ----------------------- 9253 -- Is_Guaranteed_ABE -- 9254 ----------------------- 9255 9256 function Is_Guaranteed_ABE 9257 (N : Node_Id; 9258 Target_Decl : Node_Id; 9259 Target_Body : Node_Id) return Boolean 9260 is 9261 Spec : Node_Id; 9262 begin 9263 -- Avoid cascaded errors if there were previous serious infractions. 9264 -- As a result the scenario will not be treated as a guaranteed ABE. 9265 -- This behavior parallels that of the old ABE mechanism. 9266 9267 if Serious_Errors_Detected > 0 then 9268 return False; 9269 9270 -- The scenario and the target appear in the same context ignoring 9271 -- enclosing library levels. 9272 9273 elsif In_Same_Context (N, Target_Decl) then 9274 9275 -- The target body has already been encountered. The scenario 9276 -- results in a guaranteed ABE if it appears prior to the body. 9277 9278 if Present (Target_Body) then 9279 return Earlier_In_Extended_Unit (N, Target_Body); 9280 9281 -- Otherwise the body has not been encountered yet. The scenario 9282 -- is a guaranteed ABE since the body will appear later, unless 9283 -- this is a null specification, which can occur if expansion is 9284 -- disabled (e.g. -gnatc or GNATprove mode). It is assumed that 9285 -- the caller has already ensured that the scenario is ABE-safe 9286 -- because optional bodies are not considered here. 9287 9288 else 9289 Spec := Specification (Target_Decl); 9290 9291 if Nkind (Spec) /= N_Procedure_Specification 9292 or else not Null_Present (Spec) 9293 then 9294 return True; 9295 end if; 9296 end if; 9297 end if; 9298 9299 return False; 9300 end Is_Guaranteed_ABE; 9301 9302 ---------------------------- 9303 -- Process_Guaranteed_ABE -- 9304 ---------------------------- 9305 9306 procedure Process_Guaranteed_ABE 9307 (N : Node_Id; 9308 In_State : Processing_In_State) 9309 is 9310 Scen : constant Node_Id := Scenario (N); 9311 Scen_Rep : Scenario_Rep_Id; 9312 9313 begin 9314 -- Add the current scenario to the stack of active scenarios 9315 9316 Push_Active_Scenario (Scen); 9317 9318 -- Only calls, instantiations, and task activations may result in a 9319 -- guaranteed ABE. 9320 9321 -- Call or task activation 9322 9323 if Is_Suitable_Call (Scen) then 9324 Scen_Rep := Scenario_Representation_Of (Scen, In_State); 9325 9326 if Kind (Scen_Rep) = Call_Scenario then 9327 Process_Guaranteed_ABE_Call 9328 (Call => Scen, 9329 Call_Rep => Scen_Rep, 9330 In_State => In_State); 9331 9332 else 9333 pragma Assert (Kind (Scen_Rep) = Task_Activation_Scenario); 9334 9335 Process_Activation 9336 (Call => Scen, 9337 Call_Rep => Scenario_Representation_Of (Scen, In_State), 9338 Processor => Process_Guaranteed_ABE_Activation'Access, 9339 In_State => In_State); 9340 end if; 9341 9342 -- Instantiation 9343 9344 elsif Is_Suitable_Instantiation (Scen) then 9345 Process_Guaranteed_ABE_Instantiation 9346 (Inst => Scen, 9347 Inst_Rep => Scenario_Representation_Of (Scen, In_State), 9348 In_State => In_State); 9349 end if; 9350 9351 -- Remove the current scenario from the stack of active scenarios 9352 -- once all ABE diagnostics and checks have been performed. 9353 9354 Pop_Active_Scenario (Scen); 9355 end Process_Guaranteed_ABE; 9356 9357 --------------------------------------- 9358 -- Process_Guaranteed_ABE_Activation -- 9359 --------------------------------------- 9360 9361 procedure Process_Guaranteed_ABE_Activation 9362 (Call : Node_Id; 9363 Call_Rep : Scenario_Rep_Id; 9364 Obj_Id : Entity_Id; 9365 Obj_Rep : Target_Rep_Id; 9366 Task_Typ : Entity_Id; 9367 Task_Rep : Target_Rep_Id; 9368 In_State : Processing_In_State) 9369 is 9370 Spec_Decl : constant Node_Id := Spec_Declaration (Task_Rep); 9371 9372 Check_OK : constant Boolean := 9373 not In_State.Suppress_Checks 9374 and then Ghost_Mode_Of (Obj_Rep) /= Is_Ignored 9375 and then Ghost_Mode_Of (Task_Rep) /= Is_Ignored 9376 and then Elaboration_Checks_OK (Obj_Rep) 9377 and then Elaboration_Checks_OK (Task_Rep); 9378 -- A run-time ABE check may be installed only when the object and the 9379 -- task type have active elaboration checks, and both are not ignored 9380 -- Ghost constructs. 9381 9382 begin 9383 -- Nothing to do when the root scenario appears at the declaration 9384 -- level and the task is in the same unit, but outside this context. 9385 -- 9386 -- task type Task_Typ; -- task declaration 9387 -- 9388 -- procedure Proc is 9389 -- function A ... is 9390 -- begin 9391 -- if Some_Condition then 9392 -- declare 9393 -- T : Task_Typ; 9394 -- begin 9395 -- <activation call> -- activation site 9396 -- end; 9397 -- ... 9398 -- end A; 9399 -- 9400 -- X : ... := A; -- root scenario 9401 -- ... 9402 -- 9403 -- task body Task_Typ is 9404 -- ... 9405 -- end Task_Typ; 9406 -- 9407 -- In the example above, the context of X is the declarative list 9408 -- of Proc. The "elaboration" of X may reach the activation of T 9409 -- whose body is defined outside of X's context. The task body is 9410 -- relevant only when Proc is invoked, but this happens only in 9411 -- "normal" elaboration, therefore the task body must not be 9412 -- considered if this is not the case. 9413 9414 if Is_Up_Level_Target 9415 (Targ_Decl => Spec_Decl, 9416 In_State => In_State) 9417 then 9418 return; 9419 9420 -- Nothing to do when the activation is ABE-safe 9421 -- 9422 -- generic 9423 -- package Gen is 9424 -- task type Task_Typ; 9425 -- end Gen; 9426 -- 9427 -- package body Gen is 9428 -- task body Task_Typ is 9429 -- begin 9430 -- ... 9431 -- end Task_Typ; 9432 -- end Gen; 9433 -- 9434 -- with Gen; 9435 -- procedure Main is 9436 -- package Nested is 9437 -- package Inst is new Gen; 9438 -- T : Inst.Task_Typ; 9439 -- end Nested; -- safe activation 9440 -- ... 9441 9442 elsif Is_Safe_Activation (Call, Task_Rep) then 9443 return; 9444 9445 -- An activation call leads to a guaranteed ABE when the activation 9446 -- call and the task appear within the same context ignoring library 9447 -- levels, and the body of the task has not been seen yet or appears 9448 -- after the activation call. 9449 -- 9450 -- procedure Guaranteed_ABE is 9451 -- task type Task_Typ; 9452 -- 9453 -- package Nested is 9454 -- T : Task_Typ; 9455 -- <activation call> -- guaranteed ABE 9456 -- end Nested; 9457 -- 9458 -- task body Task_Typ is 9459 -- ... 9460 -- end Task_Typ; 9461 -- ... 9462 9463 elsif Is_Guaranteed_ABE 9464 (N => Call, 9465 Target_Decl => Spec_Decl, 9466 Target_Body => Body_Declaration (Task_Rep)) 9467 then 9468 if Elaboration_Warnings_OK (Call_Rep) then 9469 Error_Msg_Sloc := Sloc (Call); 9470 Error_Msg_N 9471 ("??task & will be activated # before elaboration of its " 9472 & "body", Obj_Id); 9473 Error_Msg_N 9474 ("\Program_Error will be raised at run time", Obj_Id); 9475 end if; 9476 9477 -- Mark the activation call as a guaranteed ABE 9478 9479 Set_Is_Known_Guaranteed_ABE (Call); 9480 9481 -- Install a run-time ABE failue because this activation call will 9482 -- always result in an ABE. 9483 9484 if Check_OK then 9485 Install_Scenario_ABE_Failure 9486 (N => Call, 9487 Targ_Id => Task_Typ, 9488 Targ_Rep => Task_Rep, 9489 Disable => Obj_Rep); 9490 end if; 9491 end if; 9492 end Process_Guaranteed_ABE_Activation; 9493 9494 --------------------------------- 9495 -- Process_Guaranteed_ABE_Call -- 9496 --------------------------------- 9497 9498 procedure Process_Guaranteed_ABE_Call 9499 (Call : Node_Id; 9500 Call_Rep : Scenario_Rep_Id; 9501 In_State : Processing_In_State) 9502 is 9503 Subp_Id : constant Entity_Id := Target (Call_Rep); 9504 Subp_Rep : constant Target_Rep_Id := 9505 Target_Representation_Of (Subp_Id, In_State); 9506 Spec_Decl : constant Node_Id := Spec_Declaration (Subp_Rep); 9507 9508 Check_OK : constant Boolean := 9509 not In_State.Suppress_Checks 9510 and then Ghost_Mode_Of (Call_Rep) /= Is_Ignored 9511 and then Ghost_Mode_Of (Subp_Rep) /= Is_Ignored 9512 and then Elaboration_Checks_OK (Call_Rep) 9513 and then Elaboration_Checks_OK (Subp_Rep); 9514 -- A run-time ABE check may be installed only when both the call 9515 -- and the target have active elaboration checks, and both are not 9516 -- ignored Ghost constructs. 9517 9518 begin 9519 -- Nothing to do when the root scenario appears at the declaration 9520 -- level and the target is in the same unit but outside this context. 9521 -- 9522 -- function B ...; -- target declaration 9523 -- 9524 -- procedure Proc is 9525 -- function A ... is 9526 -- begin 9527 -- if Some_Condition then 9528 -- return B; -- call site 9529 -- ... 9530 -- end A; 9531 -- 9532 -- X : ... := A; -- root scenario 9533 -- ... 9534 -- 9535 -- function B ... is 9536 -- ... 9537 -- end B; 9538 -- 9539 -- In the example above, the context of X is the declarative region 9540 -- of Proc. The "elaboration" of X may eventually reach B which is 9541 -- defined outside of X's context. B is relevant only when Proc is 9542 -- invoked, but this happens only by means of "normal" elaboration, 9543 -- therefore B must not be considered if this is not the case. 9544 9545 if Is_Up_Level_Target 9546 (Targ_Decl => Spec_Decl, 9547 In_State => In_State) 9548 then 9549 return; 9550 9551 -- Nothing to do when the call is ABE-safe 9552 -- 9553 -- generic 9554 -- function Gen ...; 9555 -- 9556 -- function Gen ... is 9557 -- begin 9558 -- ... 9559 -- end Gen; 9560 -- 9561 -- with Gen; 9562 -- procedure Main is 9563 -- function Inst is new Gen; 9564 -- X : ... := Inst; -- safe call 9565 -- ... 9566 9567 elsif Is_Safe_Call (Call, Subp_Id, Subp_Rep) then 9568 return; 9569 9570 -- A call leads to a guaranteed ABE when the call and the target 9571 -- appear within the same context ignoring library levels, and the 9572 -- body of the target has not been seen yet or appears after the 9573 -- call. 9574 -- 9575 -- procedure Guaranteed_ABE is 9576 -- function Func ...; 9577 -- 9578 -- package Nested is 9579 -- Obj : ... := Func; -- guaranteed ABE 9580 -- end Nested; 9581 -- 9582 -- function Func ... is 9583 -- ... 9584 -- end Func; 9585 -- ... 9586 9587 elsif Is_Guaranteed_ABE 9588 (N => Call, 9589 Target_Decl => Spec_Decl, 9590 Target_Body => Body_Declaration (Subp_Rep)) 9591 then 9592 if Elaboration_Warnings_OK (Call_Rep) then 9593 Error_Msg_NE 9594 ("??cannot call & before body seen", Call, Subp_Id); 9595 Error_Msg_N ("\Program_Error will be raised at run time", Call); 9596 end if; 9597 9598 -- Mark the call as a guaranteed ABE 9599 9600 Set_Is_Known_Guaranteed_ABE (Call); 9601 9602 -- Install a run-time ABE failure because the call will always 9603 -- result in an ABE. 9604 9605 if Check_OK then 9606 Install_Scenario_ABE_Failure 9607 (N => Call, 9608 Targ_Id => Subp_Id, 9609 Targ_Rep => Subp_Rep, 9610 Disable => Call_Rep); 9611 end if; 9612 end if; 9613 end Process_Guaranteed_ABE_Call; 9614 9615 ------------------------------------------ 9616 -- Process_Guaranteed_ABE_Instantiation -- 9617 ------------------------------------------ 9618 9619 procedure Process_Guaranteed_ABE_Instantiation 9620 (Inst : Node_Id; 9621 Inst_Rep : Scenario_Rep_Id; 9622 In_State : Processing_In_State) 9623 is 9624 Gen_Id : constant Entity_Id := Target (Inst_Rep); 9625 Gen_Rep : constant Target_Rep_Id := 9626 Target_Representation_Of (Gen_Id, In_State); 9627 Spec_Decl : constant Node_Id := Spec_Declaration (Gen_Rep); 9628 9629 Check_OK : constant Boolean := 9630 not In_State.Suppress_Checks 9631 and then Ghost_Mode_Of (Inst_Rep) /= Is_Ignored 9632 and then Ghost_Mode_Of (Gen_Rep) /= Is_Ignored 9633 and then Elaboration_Checks_OK (Inst_Rep) 9634 and then Elaboration_Checks_OK (Gen_Rep); 9635 -- A run-time ABE check may be installed only when both the instance 9636 -- and the generic have active elaboration checks and both are not 9637 -- ignored Ghost constructs. 9638 9639 begin 9640 -- Nothing to do when the root scenario appears at the declaration 9641 -- level and the generic is in the same unit, but outside this 9642 -- context. 9643 -- 9644 -- generic 9645 -- procedure Gen is ...; -- generic declaration 9646 -- 9647 -- procedure Proc is 9648 -- function A ... is 9649 -- begin 9650 -- if Some_Condition then 9651 -- declare 9652 -- procedure I is new Gen; -- instantiation site 9653 -- ... 9654 -- ... 9655 -- end A; 9656 -- 9657 -- X : ... := A; -- root scenario 9658 -- ... 9659 -- 9660 -- procedure Gen is 9661 -- ... 9662 -- end Gen; 9663 -- 9664 -- In the example above, the context of X is the declarative region 9665 -- of Proc. The "elaboration" of X may eventually reach Gen which 9666 -- appears outside of X's context. Gen is relevant only when Proc is 9667 -- invoked, but this happens only by means of "normal" elaboration, 9668 -- therefore Gen must not be considered if this is not the case. 9669 9670 if Is_Up_Level_Target 9671 (Targ_Decl => Spec_Decl, 9672 In_State => In_State) 9673 then 9674 return; 9675 9676 -- Nothing to do when the instantiation is ABE-safe 9677 -- 9678 -- generic 9679 -- package Gen is 9680 -- ... 9681 -- end Gen; 9682 -- 9683 -- package body Gen is 9684 -- ... 9685 -- end Gen; 9686 -- 9687 -- with Gen; 9688 -- procedure Main is 9689 -- package Inst is new Gen (ABE); -- safe instantiation 9690 -- ... 9691 9692 elsif Is_Safe_Instantiation (Inst, Gen_Id, Gen_Rep) then 9693 return; 9694 9695 -- An instantiation leads to a guaranteed ABE when the instantiation 9696 -- and the generic appear within the same context ignoring library 9697 -- levels, and the body of the generic has not been seen yet or 9698 -- appears after the instantiation. 9699 -- 9700 -- procedure Guaranteed_ABE is 9701 -- generic 9702 -- procedure Gen; 9703 -- 9704 -- package Nested is 9705 -- procedure Inst is new Gen; -- guaranteed ABE 9706 -- end Nested; 9707 -- 9708 -- procedure Gen is 9709 -- ... 9710 -- end Gen; 9711 -- ... 9712 9713 elsif Is_Guaranteed_ABE 9714 (N => Inst, 9715 Target_Decl => Spec_Decl, 9716 Target_Body => Body_Declaration (Gen_Rep)) 9717 then 9718 if Elaboration_Warnings_OK (Inst_Rep) then 9719 Error_Msg_NE 9720 ("??cannot instantiate & before body seen", Inst, Gen_Id); 9721 Error_Msg_N ("\Program_Error will be raised at run time", Inst); 9722 end if; 9723 9724 -- Mark the instantiation as a guarantee ABE. This automatically 9725 -- suppresses the instantiation of the generic body. 9726 9727 Set_Is_Known_Guaranteed_ABE (Inst); 9728 9729 -- Install a run-time ABE failure because the instantiation will 9730 -- always result in an ABE. 9731 9732 if Check_OK then 9733 Install_Scenario_ABE_Failure 9734 (N => Inst, 9735 Targ_Id => Gen_Id, 9736 Targ_Rep => Gen_Rep, 9737 Disable => Inst_Rep); 9738 end if; 9739 end if; 9740 end Process_Guaranteed_ABE_Instantiation; 9741 end Guaranteed_ABE_Processor; 9742 9743 -------------- 9744 -- Has_Body -- 9745 -------------- 9746 9747 function Has_Body (Pack_Decl : Node_Id) return Boolean is 9748 function Find_Corresponding_Body (Spec_Id : Entity_Id) return Node_Id; 9749 pragma Inline (Find_Corresponding_Body); 9750 -- Try to locate the corresponding body of spec Spec_Id. If no body is 9751 -- found, return Empty. 9752 9753 function Find_Body 9754 (Spec_Id : Entity_Id; 9755 From : Node_Id) return Node_Id; 9756 pragma Inline (Find_Body); 9757 -- Try to locate the corresponding body of spec Spec_Id in the node list 9758 -- which follows arbitrary node From. If no body is found, return Empty. 9759 9760 function Load_Package_Body (Unit_Nam : Unit_Name_Type) return Node_Id; 9761 pragma Inline (Load_Package_Body); 9762 -- Attempt to load the body of unit Unit_Nam. If the load failed, return 9763 -- Empty. If the compilation will not generate code, return Empty. 9764 9765 ----------------------------- 9766 -- Find_Corresponding_Body -- 9767 ----------------------------- 9768 9769 function Find_Corresponding_Body (Spec_Id : Entity_Id) return Node_Id is 9770 Context : constant Entity_Id := Scope (Spec_Id); 9771 Spec_Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id); 9772 Body_Decl : Node_Id; 9773 Body_Id : Entity_Id; 9774 9775 begin 9776 if Is_Compilation_Unit (Spec_Id) then 9777 Body_Id := Corresponding_Body (Spec_Decl); 9778 9779 if Present (Body_Id) then 9780 return Unit_Declaration_Node (Body_Id); 9781 9782 -- The package is at the library and requires a body. Load the 9783 -- corresponding body because the optional body may be declared 9784 -- there. 9785 9786 elsif Unit_Requires_Body (Spec_Id) then 9787 return 9788 Load_Package_Body 9789 (Get_Body_Name (Unit_Name (Get_Source_Unit (Spec_Decl)))); 9790 9791 -- Otherwise there is no optional body 9792 9793 else 9794 return Empty; 9795 end if; 9796 9797 -- The immediate context is a package. The optional body may be 9798 -- within the body of that package. 9799 9800 -- procedure Proc is 9801 -- package Nested_1 is 9802 -- package Nested_2 is 9803 -- generic 9804 -- package Pack is 9805 -- end Pack; 9806 -- end Nested_2; 9807 -- end Nested_1; 9808 9809 -- package body Nested_1 is 9810 -- package body Nested_2 is separate; 9811 -- end Nested_1; 9812 9813 -- separate (Proc.Nested_1.Nested_2) 9814 -- package body Nested_2 is 9815 -- package body Pack is -- optional body 9816 -- ... 9817 -- end Pack; 9818 -- end Nested_2; 9819 9820 elsif Is_Package_Or_Generic_Package (Context) then 9821 Body_Decl := Find_Corresponding_Body (Context); 9822 9823 -- The optional body is within the body of the enclosing package 9824 9825 if Present (Body_Decl) then 9826 return 9827 Find_Body 9828 (Spec_Id => Spec_Id, 9829 From => First (Declarations (Body_Decl))); 9830 9831 -- Otherwise the enclosing package does not have a body. This may 9832 -- be the result of an error or a genuine lack of a body. 9833 9834 else 9835 return Empty; 9836 end if; 9837 9838 -- Otherwise the immediate context is a body. The optional body may 9839 -- be within the same list as the spec. 9840 9841 -- procedure Proc is 9842 -- generic 9843 -- package Pack is 9844 -- end Pack; 9845 9846 -- package body Pack is -- optional body 9847 -- ... 9848 -- end Pack; 9849 9850 else 9851 return 9852 Find_Body 9853 (Spec_Id => Spec_Id, 9854 From => Next (Spec_Decl)); 9855 end if; 9856 end Find_Corresponding_Body; 9857 9858 --------------- 9859 -- Find_Body -- 9860 --------------- 9861 9862 function Find_Body 9863 (Spec_Id : Entity_Id; 9864 From : Node_Id) return Node_Id 9865 is 9866 Spec_Nam : constant Name_Id := Chars (Spec_Id); 9867 Item : Node_Id; 9868 Lib_Unit : Node_Id; 9869 9870 begin 9871 Item := From; 9872 while Present (Item) loop 9873 9874 -- The current item denotes the optional body 9875 9876 if Nkind (Item) = N_Package_Body 9877 and then Chars (Defining_Entity (Item)) = Spec_Nam 9878 then 9879 return Item; 9880 9881 -- The current item denotes a stub, the optional body may be in 9882 -- the subunit. 9883 9884 elsif Nkind (Item) = N_Package_Body_Stub 9885 and then Chars (Defining_Entity (Item)) = Spec_Nam 9886 then 9887 Lib_Unit := Library_Unit (Item); 9888 9889 -- The corresponding subunit was previously loaded 9890 9891 if Present (Lib_Unit) then 9892 return Lib_Unit; 9893 9894 -- Otherwise attempt to load the corresponding subunit 9895 9896 else 9897 return Load_Package_Body (Get_Unit_Name (Item)); 9898 end if; 9899 end if; 9900 9901 Next (Item); 9902 end loop; 9903 9904 return Empty; 9905 end Find_Body; 9906 9907 ----------------------- 9908 -- Load_Package_Body -- 9909 ----------------------- 9910 9911 function Load_Package_Body (Unit_Nam : Unit_Name_Type) return Node_Id is 9912 Body_Decl : Node_Id; 9913 Unit_Num : Unit_Number_Type; 9914 9915 begin 9916 -- The load is performed only when the compilation will generate code 9917 9918 if Operating_Mode = Generate_Code then 9919 Unit_Num := 9920 Load_Unit 9921 (Load_Name => Unit_Nam, 9922 Required => False, 9923 Subunit => False, 9924 Error_Node => Pack_Decl); 9925 9926 -- The load failed most likely because the physical file is 9927 -- missing. 9928 9929 if Unit_Num = No_Unit then 9930 return Empty; 9931 9932 -- Otherwise the load was successful, return the body of the unit 9933 9934 else 9935 Body_Decl := Unit (Cunit (Unit_Num)); 9936 9937 -- If the unit is a subunit with an available proper body, 9938 -- return the proper body. 9939 9940 if Nkind (Body_Decl) = N_Subunit 9941 and then Present (Proper_Body (Body_Decl)) 9942 then 9943 Body_Decl := Proper_Body (Body_Decl); 9944 end if; 9945 9946 return Body_Decl; 9947 end if; 9948 end if; 9949 9950 return Empty; 9951 end Load_Package_Body; 9952 9953 -- Local variables 9954 9955 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl); 9956 9957 -- Start of processing for Has_Body 9958 9959 begin 9960 -- The body is available 9961 9962 if Present (Corresponding_Body (Pack_Decl)) then 9963 return True; 9964 9965 -- The body is required if the package spec contains a construct which 9966 -- requires a completion in a body. 9967 9968 elsif Unit_Requires_Body (Pack_Id) then 9969 return True; 9970 9971 -- The body may be optional 9972 9973 else 9974 return Present (Find_Corresponding_Body (Pack_Id)); 9975 end if; 9976 end Has_Body; 9977 9978 ---------- 9979 -- Hash -- 9980 ---------- 9981 9982 function Hash (NE : Node_Or_Entity_Id) return Bucket_Range_Type is 9983 pragma Assert (Present (NE)); 9984 begin 9985 return Bucket_Range_Type (NE); 9986 end Hash; 9987 9988 -------------------------- 9989 -- In_External_Instance -- 9990 -------------------------- 9991 9992 function In_External_Instance 9993 (N : Node_Id; 9994 Target_Decl : Node_Id) return Boolean 9995 is 9996 Inst : Node_Id; 9997 Inst_Body : Node_Id; 9998 Inst_Spec : Node_Id; 9999 10000 begin 10001 Inst := Find_Enclosing_Instance (Target_Decl); 10002 10003 -- The target declaration appears within an instance spec. Visibility is 10004 -- ignored because internally generated primitives for private types may 10005 -- reside in the private declarations and still be invoked from outside. 10006 10007 if Present (Inst) and then Nkind (Inst) = N_Package_Declaration then 10008 10009 -- The scenario comes from the main unit and the instance does not 10010 10011 if In_Extended_Main_Code_Unit (N) 10012 and then not In_Extended_Main_Code_Unit (Inst) 10013 then 10014 return True; 10015 10016 -- Otherwise the scenario must not appear within the instance spec or 10017 -- body. 10018 10019 else 10020 Spec_And_Body_From_Node 10021 (N => Inst, 10022 Spec_Decl => Inst_Spec, 10023 Body_Decl => Inst_Body); 10024 10025 return not In_Subtree 10026 (N => N, 10027 Root1 => Inst_Spec, 10028 Root2 => Inst_Body); 10029 end if; 10030 end if; 10031 10032 return False; 10033 end In_External_Instance; 10034 10035 --------------------- 10036 -- In_Main_Context -- 10037 --------------------- 10038 10039 function In_Main_Context (N : Node_Id) return Boolean is 10040 begin 10041 -- Scenarios outside the main unit are not considered because the ALI 10042 -- information supplied to binde is for the main unit only. 10043 10044 if not In_Extended_Main_Code_Unit (N) then 10045 return False; 10046 10047 -- Scenarios within internal units are not considered unless switch 10048 -- -gnatdE (elaboration checks on predefined units) is in effect. 10049 10050 elsif not Debug_Flag_EE and then In_Internal_Unit (N) then 10051 return False; 10052 end if; 10053 10054 return True; 10055 end In_Main_Context; 10056 10057 --------------------- 10058 -- In_Same_Context -- 10059 --------------------- 10060 10061 function In_Same_Context 10062 (N1 : Node_Id; 10063 N2 : Node_Id; 10064 Nested_OK : Boolean := False) return Boolean 10065 is 10066 function Find_Enclosing_Context (N : Node_Id) return Node_Id; 10067 pragma Inline (Find_Enclosing_Context); 10068 -- Return the nearest enclosing non-library-level or compilation unit 10069 -- node which encapsulates arbitrary node N. Return Empty is no such 10070 -- context is available. 10071 10072 function In_Nested_Context 10073 (Outer : Node_Id; 10074 Inner : Node_Id) return Boolean; 10075 pragma Inline (In_Nested_Context); 10076 -- Determine whether arbitrary node Outer encapsulates arbitrary node 10077 -- Inner. 10078 10079 ---------------------------- 10080 -- Find_Enclosing_Context -- 10081 ---------------------------- 10082 10083 function Find_Enclosing_Context (N : Node_Id) return Node_Id is 10084 Context : Node_Id; 10085 Par : Node_Id; 10086 10087 begin 10088 Par := Parent (N); 10089 while Present (Par) loop 10090 10091 -- A traversal from a subunit continues via the corresponding stub 10092 10093 if Nkind (Par) = N_Subunit then 10094 Par := Corresponding_Stub (Par); 10095 10096 -- Stop the traversal when the nearest enclosing non-library-level 10097 -- encapsulator has been reached. 10098 10099 elsif Is_Non_Library_Level_Encapsulator (Par) then 10100 Context := Parent (Par); 10101 10102 -- The sole exception is when the encapsulator is the unit of 10103 -- compilation because this case requires special processing 10104 -- (see below). 10105 10106 if Present (Context) 10107 and then Nkind (Context) = N_Compilation_Unit 10108 then 10109 null; 10110 10111 else 10112 return Par; 10113 end if; 10114 10115 -- Reaching a compilation unit node without hitting a non-library- 10116 -- level encapsulator indicates that N is at the library level in 10117 -- which case the compilation unit is the context. 10118 10119 elsif Nkind (Par) = N_Compilation_Unit then 10120 return Par; 10121 end if; 10122 10123 Par := Parent (Par); 10124 end loop; 10125 10126 return Empty; 10127 end Find_Enclosing_Context; 10128 10129 ----------------------- 10130 -- In_Nested_Context -- 10131 ----------------------- 10132 10133 function In_Nested_Context 10134 (Outer : Node_Id; 10135 Inner : Node_Id) return Boolean 10136 is 10137 Par : Node_Id; 10138 10139 begin 10140 Par := Inner; 10141 while Present (Par) loop 10142 10143 -- A traversal from a subunit continues via the corresponding stub 10144 10145 if Nkind (Par) = N_Subunit then 10146 Par := Corresponding_Stub (Par); 10147 10148 elsif Par = Outer then 10149 return True; 10150 end if; 10151 10152 Par := Parent (Par); 10153 end loop; 10154 10155 return False; 10156 end In_Nested_Context; 10157 10158 -- Local variables 10159 10160 Context_1 : constant Node_Id := Find_Enclosing_Context (N1); 10161 Context_2 : constant Node_Id := Find_Enclosing_Context (N2); 10162 10163 -- Start of processing for In_Same_Context 10164 10165 begin 10166 -- Both nodes appear within the same context 10167 10168 if Context_1 = Context_2 then 10169 return True; 10170 10171 -- Both nodes appear in compilation units. Determine whether one unit 10172 -- is the body of the other. 10173 10174 elsif Nkind (Context_1) = N_Compilation_Unit 10175 and then Nkind (Context_2) = N_Compilation_Unit 10176 then 10177 return 10178 Is_Same_Unit 10179 (Unit_1 => Defining_Entity (Unit (Context_1)), 10180 Unit_2 => Defining_Entity (Unit (Context_2))); 10181 10182 -- The context of N1 encloses the context of N2 10183 10184 elsif Nested_OK and then In_Nested_Context (Context_1, Context_2) then 10185 return True; 10186 end if; 10187 10188 return False; 10189 end In_Same_Context; 10190 10191 ---------------- 10192 -- Initialize -- 10193 ---------------- 10194 10195 procedure Initialize is 10196 begin 10197 -- Set the soft link which enables Atree.Rewrite to update a scenario 10198 -- each time it is transformed into another node. 10199 10200 Set_Rewriting_Proc (Update_Elaboration_Scenario'Access); 10201 10202 -- Create all internal data structures and activate the elaboration 10203 -- phase of the compiler. 10204 10205 Initialize_All_Data_Structures; 10206 Set_Elaboration_Phase (Active); 10207 end Initialize; 10208 10209 ------------------------------------ 10210 -- Initialize_All_Data_Structures -- 10211 ------------------------------------ 10212 10213 procedure Initialize_All_Data_Structures is 10214 begin 10215 Initialize_Body_Processor; 10216 Initialize_Early_Call_Region_Processor; 10217 Initialize_Elaborated_Units; 10218 Initialize_Internal_Representation; 10219 Initialize_Invocation_Graph; 10220 Initialize_Scenario_Storage; 10221 end Initialize_All_Data_Structures; 10222 10223 -------------------------- 10224 -- Instantiated_Generic -- 10225 -------------------------- 10226 10227 function Instantiated_Generic (Inst : Node_Id) return Entity_Id is 10228 begin 10229 -- Traverse a possible chain of renamings to obtain the original generic 10230 -- being instantiatied. 10231 10232 return Get_Renamed_Entity (Entity (Name (Inst))); 10233 end Instantiated_Generic; 10234 10235 ----------------------------- 10236 -- Internal_Representation -- 10237 ----------------------------- 10238 10239 package body Internal_Representation is 10240 10241 ----------- 10242 -- Types -- 10243 ----------- 10244 10245 -- The following type represents the contents of a scenario 10246 10247 type Scenario_Rep_Record is record 10248 Elab_Checks_OK : Boolean := False; 10249 -- The status of elaboration checks for the scenario 10250 10251 Elab_Warnings_OK : Boolean := False; 10252 -- The status of elaboration warnings for the scenario 10253 10254 GM : Extended_Ghost_Mode := Is_Checked_Or_Not_Specified; 10255 -- The Ghost mode of the scenario 10256 10257 Kind : Scenario_Kind := No_Scenario; 10258 -- The nature of the scenario 10259 10260 Level : Enclosing_Level_Kind := No_Level; 10261 -- The enclosing level where the scenario resides 10262 10263 SM : Extended_SPARK_Mode := Is_Off_Or_Not_Specified; 10264 -- The SPARK mode of the scenario 10265 10266 Target : Entity_Id := Empty; 10267 -- The target of the scenario 10268 10269 -- The following attributes are multiplexed and depend on the Kind of 10270 -- the scenario. They are mapped as follows: 10271 -- 10272 -- Call_Scenario 10273 -- Is_Dispatching_Call (Flag_1) 10274 -- 10275 -- Task_Activation_Scenario 10276 -- Activated_Task_Objects (List_1) 10277 -- Activated_Task_Type (Field_1) 10278 -- 10279 -- Variable_Reference 10280 -- Is_Read_Reference (Flag_1) 10281 10282 Flag_1 : Boolean := False; 10283 Field_1 : Node_Or_Entity_Id := Empty; 10284 List_1 : NE_List.Doubly_Linked_List := NE_List.Nil; 10285 end record; 10286 10287 -- The following type represents the contents of a target 10288 10289 type Target_Rep_Record is record 10290 Body_Decl : Node_Id := Empty; 10291 -- The declaration of the target body 10292 10293 Elab_Checks_OK : Boolean := False; 10294 -- The status of elaboration checks for the target 10295 10296 Elab_Warnings_OK : Boolean := False; 10297 -- The status of elaboration warnings for the target 10298 10299 GM : Extended_Ghost_Mode := Is_Checked_Or_Not_Specified; 10300 -- The Ghost mode of the target 10301 10302 Kind : Target_Kind := No_Target; 10303 -- The nature of the target 10304 10305 SM : Extended_SPARK_Mode := Is_Off_Or_Not_Specified; 10306 -- The SPARK mode of the target 10307 10308 Spec_Decl : Node_Id := Empty; 10309 -- The declaration of the target spec 10310 10311 Unit : Entity_Id := Empty; 10312 -- The top unit where the target is declared 10313 10314 Version : Representation_Kind := No_Representation; 10315 -- The version of the target representation 10316 10317 -- The following attributes are multiplexed and depend on the Kind of 10318 -- the target. They are mapped as follows: 10319 -- 10320 -- Subprogram_Target 10321 -- Barrier_Body_Declaration (Field_1) 10322 -- 10323 -- Variable_Target 10324 -- Variable_Declaration (Field_1) 10325 10326 Field_1 : Node_Or_Entity_Id := Empty; 10327 end record; 10328 10329 --------------------- 10330 -- Data structures -- 10331 --------------------- 10332 10333 procedure Destroy (T_Id : in out Target_Rep_Id); 10334 -- Destroy a target representation T_Id 10335 10336 package ETT_Map is new Dynamic_Hash_Tables 10337 (Key_Type => Entity_Id, 10338 Value_Type => Target_Rep_Id, 10339 No_Value => No_Target_Rep, 10340 Expansion_Threshold => 1.5, 10341 Expansion_Factor => 2, 10342 Compression_Threshold => 0.3, 10343 Compression_Factor => 2, 10344 "=" => "=", 10345 Destroy_Value => Destroy, 10346 Hash => Hash); 10347 10348 -- The following map relates target representations to entities 10349 10350 Entity_To_Target_Map : ETT_Map.Dynamic_Hash_Table := ETT_Map.Nil; 10351 10352 procedure Destroy (S_Id : in out Scenario_Rep_Id); 10353 -- Destroy a scenario representation S_Id 10354 10355 package NTS_Map is new Dynamic_Hash_Tables 10356 (Key_Type => Node_Id, 10357 Value_Type => Scenario_Rep_Id, 10358 No_Value => No_Scenario_Rep, 10359 Expansion_Threshold => 1.5, 10360 Expansion_Factor => 2, 10361 Compression_Threshold => 0.3, 10362 Compression_Factor => 2, 10363 "=" => "=", 10364 Destroy_Value => Destroy, 10365 Hash => Hash); 10366 10367 -- The following map relates scenario representations to nodes 10368 10369 Node_To_Scenario_Map : NTS_Map.Dynamic_Hash_Table := NTS_Map.Nil; 10370 10371 -- The following table stores all scenario representations 10372 10373 package Scenario_Reps is new Table.Table 10374 (Table_Index_Type => Scenario_Rep_Id, 10375 Table_Component_Type => Scenario_Rep_Record, 10376 Table_Low_Bound => First_Scenario_Rep, 10377 Table_Initial => 1000, 10378 Table_Increment => 200, 10379 Table_Name => "Scenario_Reps"); 10380 10381 -- The following table stores all target representations 10382 10383 package Target_Reps is new Table.Table 10384 (Table_Index_Type => Target_Rep_Id, 10385 Table_Component_Type => Target_Rep_Record, 10386 Table_Low_Bound => First_Target_Rep, 10387 Table_Initial => 1000, 10388 Table_Increment => 200, 10389 Table_Name => "Target_Reps"); 10390 10391 -------------- 10392 -- Builders -- 10393 -------------- 10394 10395 function Create_Access_Taken_Rep 10396 (Attr : Node_Id) return Scenario_Rep_Record; 10397 pragma Inline (Create_Access_Taken_Rep); 10398 -- Create the representation of 'Access attribute Attr 10399 10400 function Create_Call_Or_Task_Activation_Rep 10401 (Call : Node_Id) return Scenario_Rep_Record; 10402 pragma Inline (Create_Call_Or_Task_Activation_Rep); 10403 -- Create the representation of call or task activation Call 10404 10405 function Create_Derived_Type_Rep 10406 (Typ_Decl : Node_Id) return Scenario_Rep_Record; 10407 pragma Inline (Create_Derived_Type_Rep); 10408 -- Create the representation of a derived type described by declaration 10409 -- Typ_Decl. 10410 10411 function Create_Generic_Rep 10412 (Gen_Id : Entity_Id) return Target_Rep_Record; 10413 pragma Inline (Create_Generic_Rep); 10414 -- Create the representation of generic Gen_Id 10415 10416 function Create_Instantiation_Rep 10417 (Inst : Node_Id) return Scenario_Rep_Record; 10418 pragma Inline (Create_Instantiation_Rep); 10419 -- Create the representation of instantiation Inst 10420 10421 function Create_Package_Rep 10422 (Pack_Id : Entity_Id) return Target_Rep_Record; 10423 pragma Inline (Create_Package_Rep); 10424 -- Create the representation of package Pack_Id 10425 10426 function Create_Protected_Entry_Rep 10427 (PE_Id : Entity_Id) return Target_Rep_Record; 10428 pragma Inline (Create_Protected_Entry_Rep); 10429 -- Create the representation of protected entry PE_Id 10430 10431 function Create_Protected_Subprogram_Rep 10432 (PS_Id : Entity_Id) return Target_Rep_Record; 10433 pragma Inline (Create_Protected_Subprogram_Rep); 10434 -- Create the representation of protected subprogram PS_Id 10435 10436 function Create_Refined_State_Pragma_Rep 10437 (Prag : Node_Id) return Scenario_Rep_Record; 10438 pragma Inline (Create_Refined_State_Pragma_Rep); 10439 -- Create the representation of Refined_State pragma Prag 10440 10441 function Create_Scenario_Rep 10442 (N : Node_Id; 10443 In_State : Processing_In_State) return Scenario_Rep_Record; 10444 pragma Inline (Create_Scenario_Rep); 10445 -- Top level dispatcher. Create the representation of elaboration 10446 -- scenario N. In_State is the current state of the Processing phase. 10447 10448 function Create_Subprogram_Rep 10449 (Subp_Id : Entity_Id) return Target_Rep_Record; 10450 pragma Inline (Create_Subprogram_Rep); 10451 -- Create the representation of entry, operator, or subprogram Subp_Id 10452 10453 function Create_Target_Rep 10454 (Id : Entity_Id; 10455 In_State : Processing_In_State) return Target_Rep_Record; 10456 pragma Inline (Create_Target_Rep); 10457 -- Top level dispatcher. Create the representation of elaboration target 10458 -- Id. In_State is the current state of the Processing phase. 10459 10460 function Create_Task_Entry_Rep 10461 (TE_Id : Entity_Id) return Target_Rep_Record; 10462 pragma Inline (Create_Task_Entry_Rep); 10463 -- Create the representation of task entry TE_Id 10464 10465 function Create_Task_Rep (Task_Typ : Entity_Id) return Target_Rep_Record; 10466 pragma Inline (Create_Task_Rep); 10467 -- Create the representation of task type Typ 10468 10469 function Create_Variable_Assignment_Rep 10470 (Asmt : Node_Id) return Scenario_Rep_Record; 10471 pragma Inline (Create_Variable_Assignment_Rep); 10472 -- Create the representation of variable assignment Asmt 10473 10474 function Create_Variable_Reference_Rep 10475 (Ref : Node_Id) return Scenario_Rep_Record; 10476 pragma Inline (Create_Variable_Reference_Rep); 10477 -- Create the representation of variable reference Ref 10478 10479 function Create_Variable_Rep 10480 (Var_Id : Entity_Id) return Target_Rep_Record; 10481 pragma Inline (Create_Variable_Rep); 10482 -- Create the representation of variable Var_Id 10483 10484 ----------------------- 10485 -- Local subprograms -- 10486 ----------------------- 10487 10488 function Ghost_Mode_Of_Entity 10489 (Id : Entity_Id) return Extended_Ghost_Mode; 10490 pragma Inline (Ghost_Mode_Of_Entity); 10491 -- Obtain the extended Ghost mode of arbitrary entity Id 10492 10493 function Ghost_Mode_Of_Node (N : Node_Id) return Extended_Ghost_Mode; 10494 pragma Inline (Ghost_Mode_Of_Node); 10495 -- Obtain the extended Ghost mode of arbitrary node N 10496 10497 function Present (S_Id : Scenario_Rep_Id) return Boolean; 10498 pragma Inline (Present); 10499 -- Determine whether scenario representation S_Id exists 10500 10501 function Present (T_Id : Target_Rep_Id) return Boolean; 10502 pragma Inline (Present); 10503 -- Determine whether target representation T_Id exists 10504 10505 function SPARK_Mode_Of_Entity 10506 (Id : Entity_Id) return Extended_SPARK_Mode; 10507 pragma Inline (SPARK_Mode_Of_Entity); 10508 -- Obtain the extended SPARK mode of arbitrary entity Id 10509 10510 function SPARK_Mode_Of_Node (N : Node_Id) return Extended_SPARK_Mode; 10511 pragma Inline (SPARK_Mode_Of_Node); 10512 -- Obtain the extended SPARK mode of arbitrary node N 10513 10514 function To_Ghost_Mode 10515 (Ignored_Status : Boolean) return Extended_Ghost_Mode; 10516 pragma Inline (To_Ghost_Mode); 10517 -- Convert a Ghost mode indicated by Ignored_Status into its extended 10518 -- equivalent. 10519 10520 function To_SPARK_Mode (On_Status : Boolean) return Extended_SPARK_Mode; 10521 pragma Inline (To_SPARK_Mode); 10522 -- Convert a SPARK mode indicated by On_Status into its extended 10523 -- equivalent. 10524 10525 function Version (T_Id : Target_Rep_Id) return Representation_Kind; 10526 pragma Inline (Version); 10527 -- Obtain the version of target representation T_Id 10528 10529 ---------------------------- 10530 -- Activated_Task_Objects -- 10531 ---------------------------- 10532 10533 function Activated_Task_Objects 10534 (S_Id : Scenario_Rep_Id) return NE_List.Doubly_Linked_List 10535 is 10536 pragma Assert (Present (S_Id)); 10537 pragma Assert (Kind (S_Id) = Task_Activation_Scenario); 10538 10539 begin 10540 return Scenario_Reps.Table (S_Id).List_1; 10541 end Activated_Task_Objects; 10542 10543 ------------------------- 10544 -- Activated_Task_Type -- 10545 ------------------------- 10546 10547 function Activated_Task_Type 10548 (S_Id : Scenario_Rep_Id) return Entity_Id 10549 is 10550 pragma Assert (Present (S_Id)); 10551 pragma Assert (Kind (S_Id) = Task_Activation_Scenario); 10552 10553 begin 10554 return Scenario_Reps.Table (S_Id).Field_1; 10555 end Activated_Task_Type; 10556 10557 ------------------------------ 10558 -- Barrier_Body_Declaration -- 10559 ------------------------------ 10560 10561 function Barrier_Body_Declaration 10562 (T_Id : Target_Rep_Id) return Node_Id 10563 is 10564 pragma Assert (Present (T_Id)); 10565 pragma Assert (Kind (T_Id) = Subprogram_Target); 10566 10567 begin 10568 return Target_Reps.Table (T_Id).Field_1; 10569 end Barrier_Body_Declaration; 10570 10571 ---------------------- 10572 -- Body_Declaration -- 10573 ---------------------- 10574 10575 function Body_Declaration (T_Id : Target_Rep_Id) return Node_Id is 10576 pragma Assert (Present (T_Id)); 10577 begin 10578 return Target_Reps.Table (T_Id).Body_Decl; 10579 end Body_Declaration; 10580 10581 ----------------------------- 10582 -- Create_Access_Taken_Rep -- 10583 ----------------------------- 10584 10585 function Create_Access_Taken_Rep 10586 (Attr : Node_Id) return Scenario_Rep_Record 10587 is 10588 Rec : Scenario_Rep_Record; 10589 10590 begin 10591 Rec.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Attr); 10592 Rec.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Node (Attr); 10593 Rec.GM := Is_Checked_Or_Not_Specified; 10594 Rec.SM := SPARK_Mode_Of_Node (Attr); 10595 Rec.Kind := Access_Taken_Scenario; 10596 Rec.Target := Canonical_Subprogram (Entity (Prefix (Attr))); 10597 10598 return Rec; 10599 end Create_Access_Taken_Rep; 10600 10601 ---------------------------------------- 10602 -- Create_Call_Or_Task_Activation_Rep -- 10603 ---------------------------------------- 10604 10605 function Create_Call_Or_Task_Activation_Rep 10606 (Call : Node_Id) return Scenario_Rep_Record 10607 is 10608 Subp_Id : constant Entity_Id := Canonical_Subprogram (Target (Call)); 10609 Kind : Scenario_Kind; 10610 Rec : Scenario_Rep_Record; 10611 10612 begin 10613 if Is_Activation_Proc (Subp_Id) then 10614 Kind := Task_Activation_Scenario; 10615 else 10616 Kind := Call_Scenario; 10617 end if; 10618 10619 Rec.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Call); 10620 Rec.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Node (Call); 10621 Rec.GM := Ghost_Mode_Of_Node (Call); 10622 Rec.SM := SPARK_Mode_Of_Node (Call); 10623 Rec.Kind := Kind; 10624 Rec.Target := Subp_Id; 10625 10626 -- Scenario-specific attributes 10627 10628 Rec.Flag_1 := Is_Dispatching_Call (Call); -- Dispatching_Call 10629 10630 return Rec; 10631 end Create_Call_Or_Task_Activation_Rep; 10632 10633 ----------------------------- 10634 -- Create_Derived_Type_Rep -- 10635 ----------------------------- 10636 10637 function Create_Derived_Type_Rep 10638 (Typ_Decl : Node_Id) return Scenario_Rep_Record 10639 is 10640 Typ : constant Entity_Id := Defining_Entity (Typ_Decl); 10641 Rec : Scenario_Rep_Record; 10642 10643 begin 10644 Rec.Elab_Checks_OK := False; -- not relevant 10645 Rec.Elab_Warnings_OK := False; -- not relevant 10646 Rec.GM := Ghost_Mode_Of_Entity (Typ); 10647 Rec.SM := SPARK_Mode_Of_Entity (Typ); 10648 Rec.Kind := Derived_Type_Scenario; 10649 Rec.Target := Typ; 10650 10651 return Rec; 10652 end Create_Derived_Type_Rep; 10653 10654 ------------------------ 10655 -- Create_Generic_Rep -- 10656 ------------------------ 10657 10658 function Create_Generic_Rep 10659 (Gen_Id : Entity_Id) return Target_Rep_Record 10660 is 10661 Rec : Target_Rep_Record; 10662 10663 begin 10664 Rec.Kind := Generic_Target; 10665 10666 Spec_And_Body_From_Entity 10667 (Id => Gen_Id, 10668 Body_Decl => Rec.Body_Decl, 10669 Spec_Decl => Rec.Spec_Decl); 10670 10671 return Rec; 10672 end Create_Generic_Rep; 10673 10674 ------------------------------ 10675 -- Create_Instantiation_Rep -- 10676 ------------------------------ 10677 10678 function Create_Instantiation_Rep 10679 (Inst : Node_Id) return Scenario_Rep_Record 10680 is 10681 Rec : Scenario_Rep_Record; 10682 10683 begin 10684 Rec.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Inst); 10685 Rec.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Node (Inst); 10686 Rec.GM := Ghost_Mode_Of_Node (Inst); 10687 Rec.SM := SPARK_Mode_Of_Node (Inst); 10688 Rec.Kind := Instantiation_Scenario; 10689 Rec.Target := Instantiated_Generic (Inst); 10690 10691 return Rec; 10692 end Create_Instantiation_Rep; 10693 10694 ------------------------ 10695 -- Create_Package_Rep -- 10696 ------------------------ 10697 10698 function Create_Package_Rep 10699 (Pack_Id : Entity_Id) return Target_Rep_Record 10700 is 10701 Rec : Target_Rep_Record; 10702 10703 begin 10704 Rec.Kind := Package_Target; 10705 10706 Spec_And_Body_From_Entity 10707 (Id => Pack_Id, 10708 Body_Decl => Rec.Body_Decl, 10709 Spec_Decl => Rec.Spec_Decl); 10710 10711 return Rec; 10712 end Create_Package_Rep; 10713 10714 -------------------------------- 10715 -- Create_Protected_Entry_Rep -- 10716 -------------------------------- 10717 10718 function Create_Protected_Entry_Rep 10719 (PE_Id : Entity_Id) return Target_Rep_Record 10720 is 10721 Prot_Id : constant Entity_Id := Protected_Body_Subprogram (PE_Id); 10722 10723 Barf_Id : Entity_Id; 10724 Dummy : Node_Id; 10725 Rec : Target_Rep_Record; 10726 Spec_Id : Entity_Id; 10727 10728 begin 10729 -- When the entry [family] has already been expanded, it carries both 10730 -- the procedure which emulates the behavior of the entry [family] as 10731 -- well as the barrier function. 10732 10733 if Present (Prot_Id) then 10734 Barf_Id := Barrier_Function (PE_Id); 10735 Spec_Id := Prot_Id; 10736 10737 -- Otherwise no expansion took place 10738 10739 else 10740 Barf_Id := Empty; 10741 Spec_Id := PE_Id; 10742 end if; 10743 10744 Rec.Kind := Subprogram_Target; 10745 10746 Spec_And_Body_From_Entity 10747 (Id => Spec_Id, 10748 Body_Decl => Rec.Body_Decl, 10749 Spec_Decl => Rec.Spec_Decl); 10750 10751 -- Target-specific attributes 10752 10753 if Present (Barf_Id) then 10754 Spec_And_Body_From_Entity 10755 (Id => Barf_Id, 10756 Body_Decl => Rec.Field_1, -- Barrier_Body_Declaration 10757 Spec_Decl => Dummy); 10758 end if; 10759 10760 return Rec; 10761 end Create_Protected_Entry_Rep; 10762 10763 ------------------------------------- 10764 -- Create_Protected_Subprogram_Rep -- 10765 ------------------------------------- 10766 10767 function Create_Protected_Subprogram_Rep 10768 (PS_Id : Entity_Id) return Target_Rep_Record 10769 is 10770 Prot_Id : constant Entity_Id := Protected_Body_Subprogram (PS_Id); 10771 Rec : Target_Rep_Record; 10772 Spec_Id : Entity_Id; 10773 10774 begin 10775 -- When the protected subprogram has already been expanded, it 10776 -- carries the subprogram which seizes the lock and invokes the 10777 -- original statements. 10778 10779 if Present (Prot_Id) then 10780 Spec_Id := Prot_Id; 10781 10782 -- Otherwise no expansion took place 10783 10784 else 10785 Spec_Id := PS_Id; 10786 end if; 10787 10788 Rec.Kind := Subprogram_Target; 10789 10790 Spec_And_Body_From_Entity 10791 (Id => Spec_Id, 10792 Body_Decl => Rec.Body_Decl, 10793 Spec_Decl => Rec.Spec_Decl); 10794 10795 return Rec; 10796 end Create_Protected_Subprogram_Rep; 10797 10798 ------------------------------------- 10799 -- Create_Refined_State_Pragma_Rep -- 10800 ------------------------------------- 10801 10802 function Create_Refined_State_Pragma_Rep 10803 (Prag : Node_Id) return Scenario_Rep_Record 10804 is 10805 Rec : Scenario_Rep_Record; 10806 10807 begin 10808 Rec.Elab_Checks_OK := False; -- not relevant 10809 Rec.Elab_Warnings_OK := False; -- not relevant 10810 Rec.GM := 10811 To_Ghost_Mode (Is_Ignored_Ghost_Pragma (Prag)); 10812 Rec.SM := Is_Off_Or_Not_Specified; 10813 Rec.Kind := Refined_State_Pragma_Scenario; 10814 Rec.Target := Empty; 10815 10816 return Rec; 10817 end Create_Refined_State_Pragma_Rep; 10818 10819 ------------------------- 10820 -- Create_Scenario_Rep -- 10821 ------------------------- 10822 10823 function Create_Scenario_Rep 10824 (N : Node_Id; 10825 In_State : Processing_In_State) return Scenario_Rep_Record 10826 is 10827 pragma Unreferenced (In_State); 10828 10829 Rec : Scenario_Rep_Record; 10830 10831 begin 10832 if Is_Suitable_Access_Taken (N) then 10833 Rec := Create_Access_Taken_Rep (N); 10834 10835 elsif Is_Suitable_Call (N) then 10836 Rec := Create_Call_Or_Task_Activation_Rep (N); 10837 10838 elsif Is_Suitable_Instantiation (N) then 10839 Rec := Create_Instantiation_Rep (N); 10840 10841 elsif Is_Suitable_SPARK_Derived_Type (N) then 10842 Rec := Create_Derived_Type_Rep (N); 10843 10844 elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then 10845 Rec := Create_Refined_State_Pragma_Rep (N); 10846 10847 elsif Is_Suitable_Variable_Assignment (N) then 10848 Rec := Create_Variable_Assignment_Rep (N); 10849 10850 elsif Is_Suitable_Variable_Reference (N) then 10851 Rec := Create_Variable_Reference_Rep (N); 10852 10853 else 10854 pragma Assert (False); 10855 return Rec; 10856 end if; 10857 10858 -- Common scenario attributes 10859 10860 Rec.Level := Find_Enclosing_Level (N); 10861 10862 return Rec; 10863 end Create_Scenario_Rep; 10864 10865 --------------------------- 10866 -- Create_Subprogram_Rep -- 10867 --------------------------- 10868 10869 function Create_Subprogram_Rep 10870 (Subp_Id : Entity_Id) return Target_Rep_Record 10871 is 10872 Rec : Target_Rep_Record; 10873 Spec_Id : Entity_Id; 10874 10875 begin 10876 Spec_Id := Subp_Id; 10877 10878 -- The elaboration target denotes an internal function that returns a 10879 -- constrained array type in a SPARK-to-C compilation. In this case 10880 -- the function receives a corresponding procedure which has an out 10881 -- parameter. The proper body for ABE checks and diagnostics is that 10882 -- of the procedure. 10883 10884 if Ekind (Spec_Id) = E_Function 10885 and then Rewritten_For_C (Spec_Id) 10886 then 10887 Spec_Id := Corresponding_Procedure (Spec_Id); 10888 end if; 10889 10890 Rec.Kind := Subprogram_Target; 10891 10892 Spec_And_Body_From_Entity 10893 (Id => Spec_Id, 10894 Body_Decl => Rec.Body_Decl, 10895 Spec_Decl => Rec.Spec_Decl); 10896 10897 return Rec; 10898 end Create_Subprogram_Rep; 10899 10900 ----------------------- 10901 -- Create_Target_Rep -- 10902 ----------------------- 10903 10904 function Create_Target_Rep 10905 (Id : Entity_Id; 10906 In_State : Processing_In_State) return Target_Rep_Record 10907 is 10908 Rec : Target_Rep_Record; 10909 10910 begin 10911 if Is_Generic_Unit (Id) then 10912 Rec := Create_Generic_Rep (Id); 10913 10914 elsif Is_Protected_Entry (Id) then 10915 Rec := Create_Protected_Entry_Rep (Id); 10916 10917 elsif Is_Protected_Subp (Id) then 10918 Rec := Create_Protected_Subprogram_Rep (Id); 10919 10920 elsif Is_Task_Entry (Id) then 10921 Rec := Create_Task_Entry_Rep (Id); 10922 10923 elsif Is_Task_Type (Id) then 10924 Rec := Create_Task_Rep (Id); 10925 10926 elsif Ekind (Id) in E_Constant | E_Variable then 10927 Rec := Create_Variable_Rep (Id); 10928 10929 elsif Ekind (Id) in E_Entry | E_Function | E_Operator | E_Procedure 10930 then 10931 Rec := Create_Subprogram_Rep (Id); 10932 10933 elsif Ekind (Id) = E_Package then 10934 Rec := Create_Package_Rep (Id); 10935 10936 else 10937 pragma Assert (False); 10938 return Rec; 10939 end if; 10940 10941 -- Common target attributes 10942 10943 Rec.Elab_Checks_OK := Is_Elaboration_Checks_OK_Id (Id); 10944 Rec.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Id (Id); 10945 Rec.GM := Ghost_Mode_Of_Entity (Id); 10946 Rec.SM := SPARK_Mode_Of_Entity (Id); 10947 Rec.Unit := Find_Top_Unit (Id); 10948 Rec.Version := In_State.Representation; 10949 10950 return Rec; 10951 end Create_Target_Rep; 10952 10953 --------------------------- 10954 -- Create_Task_Entry_Rep -- 10955 --------------------------- 10956 10957 function Create_Task_Entry_Rep 10958 (TE_Id : Entity_Id) return Target_Rep_Record 10959 is 10960 Task_Typ : constant Entity_Id := Non_Private_View (Scope (TE_Id)); 10961 Task_Body_Id : constant Entity_Id := Task_Body_Procedure (Task_Typ); 10962 10963 Rec : Target_Rep_Record; 10964 Spec_Id : Entity_Id; 10965 10966 begin 10967 -- The task type has already been expanded, it carries the procedure 10968 -- which emulates the behavior of the task body. 10969 10970 if Present (Task_Body_Id) then 10971 Spec_Id := Task_Body_Id; 10972 10973 -- Otherwise no expansion took place 10974 10975 else 10976 Spec_Id := TE_Id; 10977 end if; 10978 10979 Rec.Kind := Subprogram_Target; 10980 10981 Spec_And_Body_From_Entity 10982 (Id => Spec_Id, 10983 Body_Decl => Rec.Body_Decl, 10984 Spec_Decl => Rec.Spec_Decl); 10985 10986 return Rec; 10987 end Create_Task_Entry_Rep; 10988 10989 --------------------- 10990 -- Create_Task_Rep -- 10991 --------------------- 10992 10993 function Create_Task_Rep 10994 (Task_Typ : Entity_Id) return Target_Rep_Record 10995 is 10996 Task_Body_Id : constant Entity_Id := Task_Body_Procedure (Task_Typ); 10997 10998 Rec : Target_Rep_Record; 10999 Spec_Id : Entity_Id; 11000 11001 begin 11002 -- The task type has already been expanded, it carries the procedure 11003 -- which emulates the behavior of the task body. 11004 11005 if Present (Task_Body_Id) then 11006 Spec_Id := Task_Body_Id; 11007 11008 -- Otherwise no expansion took place 11009 11010 else 11011 Spec_Id := Task_Typ; 11012 end if; 11013 11014 Rec.Kind := Task_Target; 11015 11016 Spec_And_Body_From_Entity 11017 (Id => Spec_Id, 11018 Body_Decl => Rec.Body_Decl, 11019 Spec_Decl => Rec.Spec_Decl); 11020 11021 return Rec; 11022 end Create_Task_Rep; 11023 11024 ------------------------------------ 11025 -- Create_Variable_Assignment_Rep -- 11026 ------------------------------------ 11027 11028 function Create_Variable_Assignment_Rep 11029 (Asmt : Node_Id) return Scenario_Rep_Record 11030 is 11031 Var_Id : constant Entity_Id := Entity (Assignment_Target (Asmt)); 11032 Rec : Scenario_Rep_Record; 11033 11034 begin 11035 Rec.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Asmt); 11036 Rec.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Id (Var_Id); 11037 Rec.GM := Ghost_Mode_Of_Node (Asmt); 11038 Rec.SM := SPARK_Mode_Of_Node (Asmt); 11039 Rec.Kind := Variable_Assignment_Scenario; 11040 Rec.Target := Var_Id; 11041 11042 return Rec; 11043 end Create_Variable_Assignment_Rep; 11044 11045 ----------------------------------- 11046 -- Create_Variable_Reference_Rep -- 11047 ----------------------------------- 11048 11049 function Create_Variable_Reference_Rep 11050 (Ref : Node_Id) return Scenario_Rep_Record 11051 is 11052 Rec : Scenario_Rep_Record; 11053 11054 begin 11055 Rec.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Ref); 11056 Rec.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Node (Ref); 11057 Rec.GM := Ghost_Mode_Of_Node (Ref); 11058 Rec.SM := SPARK_Mode_Of_Node (Ref); 11059 Rec.Kind := Variable_Reference_Scenario; 11060 Rec.Target := Target (Ref); 11061 11062 -- Scenario-specific attributes 11063 11064 Rec.Flag_1 := Is_Read (Ref); -- Is_Read_Reference 11065 11066 return Rec; 11067 end Create_Variable_Reference_Rep; 11068 11069 ------------------------- 11070 -- Create_Variable_Rep -- 11071 ------------------------- 11072 11073 function Create_Variable_Rep 11074 (Var_Id : Entity_Id) return Target_Rep_Record 11075 is 11076 Rec : Target_Rep_Record; 11077 11078 begin 11079 Rec.Kind := Variable_Target; 11080 11081 -- Target-specific attributes 11082 11083 Rec.Field_1 := Declaration_Node (Var_Id); -- Variable_Declaration 11084 11085 return Rec; 11086 end Create_Variable_Rep; 11087 11088 ------------- 11089 -- Destroy -- 11090 ------------- 11091 11092 procedure Destroy (S_Id : in out Scenario_Rep_Id) is 11093 pragma Unreferenced (S_Id); 11094 begin 11095 null; 11096 end Destroy; 11097 11098 ------------- 11099 -- Destroy -- 11100 ------------- 11101 11102 procedure Destroy (T_Id : in out Target_Rep_Id) is 11103 pragma Unreferenced (T_Id); 11104 begin 11105 null; 11106 end Destroy; 11107 11108 -------------------------------- 11109 -- Disable_Elaboration_Checks -- 11110 -------------------------------- 11111 11112 procedure Disable_Elaboration_Checks (S_Id : Scenario_Rep_Id) is 11113 pragma Assert (Present (S_Id)); 11114 begin 11115 Scenario_Reps.Table (S_Id).Elab_Checks_OK := False; 11116 end Disable_Elaboration_Checks; 11117 11118 -------------------------------- 11119 -- Disable_Elaboration_Checks -- 11120 -------------------------------- 11121 11122 procedure Disable_Elaboration_Checks (T_Id : Target_Rep_Id) is 11123 pragma Assert (Present (T_Id)); 11124 begin 11125 Target_Reps.Table (T_Id).Elab_Checks_OK := False; 11126 end Disable_Elaboration_Checks; 11127 11128 --------------------------- 11129 -- Elaboration_Checks_OK -- 11130 --------------------------- 11131 11132 function Elaboration_Checks_OK (S_Id : Scenario_Rep_Id) return Boolean is 11133 pragma Assert (Present (S_Id)); 11134 begin 11135 return Scenario_Reps.Table (S_Id).Elab_Checks_OK; 11136 end Elaboration_Checks_OK; 11137 11138 --------------------------- 11139 -- Elaboration_Checks_OK -- 11140 --------------------------- 11141 11142 function Elaboration_Checks_OK (T_Id : Target_Rep_Id) return Boolean is 11143 pragma Assert (Present (T_Id)); 11144 begin 11145 return Target_Reps.Table (T_Id).Elab_Checks_OK; 11146 end Elaboration_Checks_OK; 11147 11148 ----------------------------- 11149 -- Elaboration_Warnings_OK -- 11150 ----------------------------- 11151 11152 function Elaboration_Warnings_OK 11153 (S_Id : Scenario_Rep_Id) return Boolean 11154 is 11155 pragma Assert (Present (S_Id)); 11156 begin 11157 return Scenario_Reps.Table (S_Id).Elab_Warnings_OK; 11158 end Elaboration_Warnings_OK; 11159 11160 ----------------------------- 11161 -- Elaboration_Warnings_OK -- 11162 ----------------------------- 11163 11164 function Elaboration_Warnings_OK (T_Id : Target_Rep_Id) return Boolean is 11165 pragma Assert (Present (T_Id)); 11166 begin 11167 return Target_Reps.Table (T_Id).Elab_Warnings_OK; 11168 end Elaboration_Warnings_OK; 11169 11170 -------------------------------------- 11171 -- Finalize_Internal_Representation -- 11172 -------------------------------------- 11173 11174 procedure Finalize_Internal_Representation is 11175 begin 11176 ETT_Map.Destroy (Entity_To_Target_Map); 11177 NTS_Map.Destroy (Node_To_Scenario_Map); 11178 end Finalize_Internal_Representation; 11179 11180 ------------------- 11181 -- Ghost_Mode_Of -- 11182 ------------------- 11183 11184 function Ghost_Mode_Of 11185 (S_Id : Scenario_Rep_Id) return Extended_Ghost_Mode 11186 is 11187 pragma Assert (Present (S_Id)); 11188 begin 11189 return Scenario_Reps.Table (S_Id).GM; 11190 end Ghost_Mode_Of; 11191 11192 ------------------- 11193 -- Ghost_Mode_Of -- 11194 ------------------- 11195 11196 function Ghost_Mode_Of 11197 (T_Id : Target_Rep_Id) return Extended_Ghost_Mode 11198 is 11199 pragma Assert (Present (T_Id)); 11200 begin 11201 return Target_Reps.Table (T_Id).GM; 11202 end Ghost_Mode_Of; 11203 11204 -------------------------- 11205 -- Ghost_Mode_Of_Entity -- 11206 -------------------------- 11207 11208 function Ghost_Mode_Of_Entity 11209 (Id : Entity_Id) return Extended_Ghost_Mode 11210 is 11211 begin 11212 return To_Ghost_Mode (Is_Ignored_Ghost_Entity (Id)); 11213 end Ghost_Mode_Of_Entity; 11214 11215 ------------------------ 11216 -- Ghost_Mode_Of_Node -- 11217 ------------------------ 11218 11219 function Ghost_Mode_Of_Node (N : Node_Id) return Extended_Ghost_Mode is 11220 begin 11221 return To_Ghost_Mode (Is_Ignored_Ghost_Node (N)); 11222 end Ghost_Mode_Of_Node; 11223 11224 ---------------------------------------- 11225 -- Initialize_Internal_Representation -- 11226 ---------------------------------------- 11227 11228 procedure Initialize_Internal_Representation is 11229 begin 11230 Entity_To_Target_Map := ETT_Map.Create (500); 11231 Node_To_Scenario_Map := NTS_Map.Create (500); 11232 end Initialize_Internal_Representation; 11233 11234 ------------------------- 11235 -- Is_Dispatching_Call -- 11236 ------------------------- 11237 11238 function Is_Dispatching_Call (S_Id : Scenario_Rep_Id) return Boolean is 11239 pragma Assert (Present (S_Id)); 11240 pragma Assert (Kind (S_Id) = Call_Scenario); 11241 11242 begin 11243 return Scenario_Reps.Table (S_Id).Flag_1; 11244 end Is_Dispatching_Call; 11245 11246 ----------------------- 11247 -- Is_Read_Reference -- 11248 ----------------------- 11249 11250 function Is_Read_Reference (S_Id : Scenario_Rep_Id) return Boolean is 11251 pragma Assert (Present (S_Id)); 11252 pragma Assert (Kind (S_Id) = Variable_Reference_Scenario); 11253 11254 begin 11255 return Scenario_Reps.Table (S_Id).Flag_1; 11256 end Is_Read_Reference; 11257 11258 ---------- 11259 -- Kind -- 11260 ---------- 11261 11262 function Kind (S_Id : Scenario_Rep_Id) return Scenario_Kind is 11263 pragma Assert (Present (S_Id)); 11264 begin 11265 return Scenario_Reps.Table (S_Id).Kind; 11266 end Kind; 11267 11268 ---------- 11269 -- Kind -- 11270 ---------- 11271 11272 function Kind (T_Id : Target_Rep_Id) return Target_Kind is 11273 pragma Assert (Present (T_Id)); 11274 begin 11275 return Target_Reps.Table (T_Id).Kind; 11276 end Kind; 11277 11278 ----------- 11279 -- Level -- 11280 ----------- 11281 11282 function Level (S_Id : Scenario_Rep_Id) return Enclosing_Level_Kind is 11283 pragma Assert (Present (S_Id)); 11284 begin 11285 return Scenario_Reps.Table (S_Id).Level; 11286 end Level; 11287 11288 ------------- 11289 -- Present -- 11290 ------------- 11291 11292 function Present (S_Id : Scenario_Rep_Id) return Boolean is 11293 begin 11294 return S_Id /= No_Scenario_Rep; 11295 end Present; 11296 11297 ------------- 11298 -- Present -- 11299 ------------- 11300 11301 function Present (T_Id : Target_Rep_Id) return Boolean is 11302 begin 11303 return T_Id /= No_Target_Rep; 11304 end Present; 11305 11306 -------------------------------- 11307 -- Scenario_Representation_Of -- 11308 -------------------------------- 11309 11310 function Scenario_Representation_Of 11311 (N : Node_Id; 11312 In_State : Processing_In_State) return Scenario_Rep_Id 11313 is 11314 S_Id : Scenario_Rep_Id; 11315 11316 begin 11317 S_Id := NTS_Map.Get (Node_To_Scenario_Map, N); 11318 11319 -- The elaboration scenario lacks a representation. This indicates 11320 -- that the scenario is encountered for the first time. Create the 11321 -- representation of it. 11322 11323 if not Present (S_Id) then 11324 Scenario_Reps.Append (Create_Scenario_Rep (N, In_State)); 11325 S_Id := Scenario_Reps.Last; 11326 11327 -- Associate the internal representation with the elaboration 11328 -- scenario. 11329 11330 NTS_Map.Put (Node_To_Scenario_Map, N, S_Id); 11331 end if; 11332 11333 pragma Assert (Present (S_Id)); 11334 11335 return S_Id; 11336 end Scenario_Representation_Of; 11337 11338 -------------------------------- 11339 -- Set_Activated_Task_Objects -- 11340 -------------------------------- 11341 11342 procedure Set_Activated_Task_Objects 11343 (S_Id : Scenario_Rep_Id; 11344 Task_Objs : NE_List.Doubly_Linked_List) 11345 is 11346 pragma Assert (Present (S_Id)); 11347 pragma Assert (Kind (S_Id) = Task_Activation_Scenario); 11348 11349 begin 11350 Scenario_Reps.Table (S_Id).List_1 := Task_Objs; 11351 end Set_Activated_Task_Objects; 11352 11353 ----------------------------- 11354 -- Set_Activated_Task_Type -- 11355 ----------------------------- 11356 11357 procedure Set_Activated_Task_Type 11358 (S_Id : Scenario_Rep_Id; 11359 Task_Typ : Entity_Id) 11360 is 11361 pragma Assert (Present (S_Id)); 11362 pragma Assert (Kind (S_Id) = Task_Activation_Scenario); 11363 11364 begin 11365 Scenario_Reps.Table (S_Id).Field_1 := Task_Typ; 11366 end Set_Activated_Task_Type; 11367 11368 ------------------- 11369 -- SPARK_Mode_Of -- 11370 ------------------- 11371 11372 function SPARK_Mode_Of 11373 (S_Id : Scenario_Rep_Id) return Extended_SPARK_Mode 11374 is 11375 pragma Assert (Present (S_Id)); 11376 begin 11377 return Scenario_Reps.Table (S_Id).SM; 11378 end SPARK_Mode_Of; 11379 11380 ------------------- 11381 -- SPARK_Mode_Of -- 11382 ------------------- 11383 11384 function SPARK_Mode_Of 11385 (T_Id : Target_Rep_Id) return Extended_SPARK_Mode 11386 is 11387 pragma Assert (Present (T_Id)); 11388 begin 11389 return Target_Reps.Table (T_Id).SM; 11390 end SPARK_Mode_Of; 11391 11392 -------------------------- 11393 -- SPARK_Mode_Of_Entity -- 11394 -------------------------- 11395 11396 function SPARK_Mode_Of_Entity 11397 (Id : Entity_Id) return Extended_SPARK_Mode 11398 is 11399 Prag : constant Node_Id := SPARK_Pragma (Id); 11400 11401 begin 11402 return 11403 To_SPARK_Mode 11404 (Present (Prag) 11405 and then Get_SPARK_Mode_From_Annotation (Prag) = On); 11406 end SPARK_Mode_Of_Entity; 11407 11408 ------------------------ 11409 -- SPARK_Mode_Of_Node -- 11410 ------------------------ 11411 11412 function SPARK_Mode_Of_Node (N : Node_Id) return Extended_SPARK_Mode is 11413 begin 11414 return To_SPARK_Mode (Is_SPARK_Mode_On_Node (N)); 11415 end SPARK_Mode_Of_Node; 11416 11417 ---------------------- 11418 -- Spec_Declaration -- 11419 ---------------------- 11420 11421 function Spec_Declaration (T_Id : Target_Rep_Id) return Node_Id is 11422 pragma Assert (Present (T_Id)); 11423 begin 11424 return Target_Reps.Table (T_Id).Spec_Decl; 11425 end Spec_Declaration; 11426 11427 ------------ 11428 -- Target -- 11429 ------------ 11430 11431 function Target (S_Id : Scenario_Rep_Id) return Entity_Id is 11432 pragma Assert (Present (S_Id)); 11433 begin 11434 return Scenario_Reps.Table (S_Id).Target; 11435 end Target; 11436 11437 ------------------------------ 11438 -- Target_Representation_Of -- 11439 ------------------------------ 11440 11441 function Target_Representation_Of 11442 (Id : Entity_Id; 11443 In_State : Processing_In_State) return Target_Rep_Id 11444 is 11445 T_Id : Target_Rep_Id; 11446 11447 begin 11448 T_Id := ETT_Map.Get (Entity_To_Target_Map, Id); 11449 11450 -- The elaboration target lacks an internal representation. This 11451 -- indicates that the target is encountered for the first time. 11452 -- Create the internal representation of it. 11453 11454 if not Present (T_Id) then 11455 Target_Reps.Append (Create_Target_Rep (Id, In_State)); 11456 T_Id := Target_Reps.Last; 11457 11458 -- Associate the internal representation with the elaboration 11459 -- target. 11460 11461 ETT_Map.Put (Entity_To_Target_Map, Id, T_Id); 11462 11463 -- The Processing phase is working with a partially analyzed tree, 11464 -- where various attributes become available as analysis continues. 11465 -- This case arrises in the context of guaranteed ABE processing. 11466 -- Update the existing representation by including new attributes. 11467 11468 elsif In_State.Representation = Inconsistent_Representation then 11469 Target_Reps.Table (T_Id) := Create_Target_Rep (Id, In_State); 11470 11471 -- Otherwise the Processing phase imposes a particular representation 11472 -- version which is not satisfied by the target. This case arrises 11473 -- when the Processing phase switches from guaranteed ABE checks and 11474 -- diagnostics to some other mode of operation. Update the existing 11475 -- representation to include all attributes. 11476 11477 elsif In_State.Representation /= Version (T_Id) then 11478 Target_Reps.Table (T_Id) := Create_Target_Rep (Id, In_State); 11479 end if; 11480 11481 pragma Assert (Present (T_Id)); 11482 11483 return T_Id; 11484 end Target_Representation_Of; 11485 11486 ------------------- 11487 -- To_Ghost_Mode -- 11488 ------------------- 11489 11490 function To_Ghost_Mode 11491 (Ignored_Status : Boolean) return Extended_Ghost_Mode 11492 is 11493 begin 11494 if Ignored_Status then 11495 return Is_Ignored; 11496 else 11497 return Is_Checked_Or_Not_Specified; 11498 end if; 11499 end To_Ghost_Mode; 11500 11501 ------------------- 11502 -- To_SPARK_Mode -- 11503 ------------------- 11504 11505 function To_SPARK_Mode 11506 (On_Status : Boolean) return Extended_SPARK_Mode 11507 is 11508 begin 11509 if On_Status then 11510 return Is_On; 11511 else 11512 return Is_Off_Or_Not_Specified; 11513 end if; 11514 end To_SPARK_Mode; 11515 11516 ---------- 11517 -- Unit -- 11518 ---------- 11519 11520 function Unit (T_Id : Target_Rep_Id) return Entity_Id is 11521 pragma Assert (Present (T_Id)); 11522 begin 11523 return Target_Reps.Table (T_Id).Unit; 11524 end Unit; 11525 11526 -------------------------- 11527 -- Variable_Declaration -- 11528 -------------------------- 11529 11530 function Variable_Declaration (T_Id : Target_Rep_Id) return Node_Id is 11531 pragma Assert (Present (T_Id)); 11532 pragma Assert (Kind (T_Id) = Variable_Target); 11533 11534 begin 11535 return Target_Reps.Table (T_Id).Field_1; 11536 end Variable_Declaration; 11537 11538 ------------- 11539 -- Version -- 11540 ------------- 11541 11542 function Version (T_Id : Target_Rep_Id) return Representation_Kind is 11543 pragma Assert (Present (T_Id)); 11544 begin 11545 return Target_Reps.Table (T_Id).Version; 11546 end Version; 11547 end Internal_Representation; 11548 11549 ---------------------- 11550 -- Invocation_Graph -- 11551 ---------------------- 11552 11553 package body Invocation_Graph is 11554 11555 ----------- 11556 -- Types -- 11557 ----------- 11558 11559 -- The following type represents simplified version of an invocation 11560 -- relation. 11561 11562 type Invoker_Target_Relation is record 11563 Invoker : Entity_Id := Empty; 11564 Target : Entity_Id := Empty; 11565 end record; 11566 11567 -- The following variables define the entities of the dummy elaboration 11568 -- procedures used as origins of library level paths. 11569 11570 Elab_Body_Id : Entity_Id := Empty; 11571 Elab_Spec_Id : Entity_Id := Empty; 11572 11573 --------------------- 11574 -- Data structures -- 11575 --------------------- 11576 11577 -- The following set contains all declared invocation constructs. It 11578 -- ensures that the same construct is not declared multiple times in 11579 -- the ALI file of the main unit. 11580 11581 Saved_Constructs_Set : NE_Set.Membership_Set := NE_Set.Nil; 11582 11583 function Hash (Key : Invoker_Target_Relation) return Bucket_Range_Type; 11584 -- Obtain the hash value of pair Key 11585 11586 package IR_Set is new Membership_Sets 11587 (Element_Type => Invoker_Target_Relation, 11588 "=" => "=", 11589 Hash => Hash); 11590 11591 -- The following set contains all recorded simple invocation relations. 11592 -- It ensures that multiple relations involving the same invoker and 11593 -- target do not appear in the ALI file of the main unit. 11594 11595 Saved_Relations_Set : IR_Set.Membership_Set := IR_Set.Nil; 11596 11597 -------------- 11598 -- Builders -- 11599 -------------- 11600 11601 function Signature_Of (Id : Entity_Id) return Invocation_Signature_Id; 11602 pragma Inline (Signature_Of); 11603 -- Obtain the invication signature id of arbitrary entity Id 11604 11605 ----------------------- 11606 -- Local subprograms -- 11607 ----------------------- 11608 11609 procedure Build_Elaborate_Body_Procedure; 11610 pragma Inline (Build_Elaborate_Body_Procedure); 11611 -- Create a dummy elaborate body procedure and store its entity in 11612 -- Elab_Body_Id. 11613 11614 procedure Build_Elaborate_Procedure 11615 (Proc_Id : out Entity_Id; 11616 Proc_Nam : Name_Id; 11617 Loc : Source_Ptr); 11618 pragma Inline (Build_Elaborate_Procedure); 11619 -- Create a dummy elaborate procedure with name Proc_Nam and source 11620 -- location Loc. The entity is returned in Proc_Id. 11621 11622 procedure Build_Elaborate_Spec_Procedure; 11623 pragma Inline (Build_Elaborate_Spec_Procedure); 11624 -- Create a dummy elaborate spec procedure and store its entity in 11625 -- Elab_Spec_Id. 11626 11627 function Build_Subprogram_Invocation 11628 (Subp_Id : Entity_Id) return Node_Id; 11629 pragma Inline (Build_Subprogram_Invocation); 11630 -- Create a dummy call marker that invokes subprogram Subp_Id 11631 11632 function Build_Task_Activation 11633 (Task_Typ : Entity_Id; 11634 In_State : Processing_In_State) return Node_Id; 11635 pragma Inline (Build_Task_Activation); 11636 -- Create a dummy call marker that activates an anonymous task object of 11637 -- type Task_Typ. 11638 11639 procedure Declare_Invocation_Construct 11640 (Constr_Id : Entity_Id; 11641 In_State : Processing_In_State); 11642 pragma Inline (Declare_Invocation_Construct); 11643 -- Declare invocation construct Constr_Id by creating a declaration for 11644 -- it in the ALI file of the main unit. In_State is the current state of 11645 -- the Processing phase. 11646 11647 function Invocation_Graph_Recording_OK return Boolean; 11648 pragma Inline (Invocation_Graph_Recording_OK); 11649 -- Determine whether the invocation graph can be recorded 11650 11651 function Is_Invocation_Scenario (N : Node_Id) return Boolean; 11652 pragma Inline (Is_Invocation_Scenario); 11653 -- Determine whether node N is a suitable scenario for invocation graph 11654 -- recording purposes. 11655 11656 function Is_Invocation_Target (Id : Entity_Id) return Boolean; 11657 pragma Inline (Is_Invocation_Target); 11658 -- Determine whether arbitrary entity Id denotes an invocation target 11659 11660 function Is_Saved_Construct (Constr : Entity_Id) return Boolean; 11661 pragma Inline (Is_Saved_Construct); 11662 -- Determine whether invocation construct Constr has already been 11663 -- declared in the ALI file of the main unit. 11664 11665 function Is_Saved_Relation 11666 (Rel : Invoker_Target_Relation) return Boolean; 11667 pragma Inline (Is_Saved_Relation); 11668 -- Determine whether simple invocation relation Rel has already been 11669 -- recorded in the ALI file of the main unit. 11670 11671 procedure Process_Declarations 11672 (Decls : List_Id; 11673 In_State : Processing_In_State); 11674 pragma Inline (Process_Declarations); 11675 -- Process declaration list Decls by processing all invocation scenarios 11676 -- within it. 11677 11678 procedure Process_Freeze_Node 11679 (Fnode : Node_Id; 11680 In_State : Processing_In_State); 11681 pragma Inline (Process_Freeze_Node); 11682 -- Process freeze node Fnode by processing all invocation scenarios in 11683 -- its Actions list. 11684 11685 procedure Process_Invocation_Activation 11686 (Call : Node_Id; 11687 Call_Rep : Scenario_Rep_Id; 11688 Obj_Id : Entity_Id; 11689 Obj_Rep : Target_Rep_Id; 11690 Task_Typ : Entity_Id; 11691 Task_Rep : Target_Rep_Id; 11692 In_State : Processing_In_State); 11693 pragma Inline (Process_Invocation_Activation); 11694 -- Process activation call Call which activates object Obj_Id of task 11695 -- type Task_Typ by processing all invocation scenarios within the task 11696 -- body. Call_Rep is the representation of the call. Obj_Rep denotes the 11697 -- representation of the object. Task_Rep is the representation of the 11698 -- task type. In_State is the current state of the Processing phase. 11699 11700 procedure Process_Invocation_Body_Scenarios; 11701 pragma Inline (Process_Invocation_Body_Scenarios); 11702 -- Process all library level body scenarios 11703 11704 procedure Process_Invocation_Call 11705 (Call : Node_Id; 11706 Call_Rep : Scenario_Rep_Id; 11707 In_State : Processing_In_State); 11708 pragma Inline (Process_Invocation_Call); 11709 -- Process invocation call scenario Call with representation Call_Rep. 11710 -- In_State is the current state of the Processing phase. 11711 11712 procedure Process_Invocation_Instantiation 11713 (Inst : Node_Id; 11714 Inst_Rep : Scenario_Rep_Id; 11715 In_State : Processing_In_State); 11716 pragma Inline (Process_Invocation_Instantiation); 11717 -- Process invocation instantiation scenario Inst with representation 11718 -- Inst_Rep. In_State is the current state of the Processing phase. 11719 11720 procedure Process_Invocation_Scenario 11721 (N : Node_Id; 11722 In_State : Processing_In_State); 11723 pragma Inline (Process_Invocation_Scenario); 11724 -- Process single invocation scenario N. In_State is the current state 11725 -- of the Processing phase. 11726 11727 procedure Process_Invocation_Scenarios 11728 (Iter : in out NE_Set.Iterator; 11729 In_State : Processing_In_State); 11730 pragma Inline (Process_Invocation_Scenarios); 11731 -- Process all invocation scenarios obtained via iterator Iter. In_State 11732 -- is the current state of the Processing phase. 11733 11734 procedure Process_Invocation_Spec_Scenarios; 11735 pragma Inline (Process_Invocation_Spec_Scenarios); 11736 -- Process all library level spec scenarios 11737 11738 procedure Process_Main_Unit; 11739 pragma Inline (Process_Main_Unit); 11740 -- Process all invocation scenarios within the main unit 11741 11742 procedure Process_Package_Declaration 11743 (Pack_Decl : Node_Id; 11744 In_State : Processing_In_State); 11745 pragma Inline (Process_Package_Declaration); 11746 -- Process package declaration Pack_Decl by processing all invocation 11747 -- scenarios in its visible and private declarations. If the main unit 11748 -- contains a generic, the declarations of the body are also examined. 11749 -- In_State is the current state of the Processing phase. 11750 11751 procedure Process_Protected_Type_Declaration 11752 (Prot_Decl : Node_Id; 11753 In_State : Processing_In_State); 11754 pragma Inline (Process_Protected_Type_Declaration); 11755 -- Process the declarations of protected type Prot_Decl. In_State is the 11756 -- current state of the Processing phase. 11757 11758 procedure Process_Subprogram_Declaration 11759 (Subp_Decl : Node_Id; 11760 In_State : Processing_In_State); 11761 pragma Inline (Process_Subprogram_Declaration); 11762 -- Process subprogram declaration Subp_Decl by processing all invocation 11763 -- scenarios within its body. In_State denotes the current state of the 11764 -- Processing phase. 11765 11766 procedure Process_Subprogram_Instantiation 11767 (Inst : Node_Id; 11768 In_State : Processing_In_State); 11769 pragma Inline (Process_Subprogram_Instantiation); 11770 -- Process subprogram instantiation Inst. In_State is the current state 11771 -- of the Processing phase. 11772 11773 procedure Process_Task_Type_Declaration 11774 (Task_Decl : Node_Id; 11775 In_State : Processing_In_State); 11776 pragma Inline (Process_Task_Type_Declaration); 11777 -- Process task declaration Task_Decl by processing all invocation 11778 -- scenarios within its body. In_State is the current state of the 11779 -- Processing phase. 11780 11781 procedure Record_Full_Invocation_Path (In_State : Processing_In_State); 11782 pragma Inline (Record_Full_Invocation_Path); 11783 -- Record all relations between scenario pairs found in the stack of 11784 -- active scenarios. In_State is the current state of the Processing 11785 -- phase. 11786 11787 procedure Record_Invocation_Graph_Encoding; 11788 pragma Inline (Record_Invocation_Graph_Encoding); 11789 -- Record the encoding format used to capture information related to 11790 -- invocation constructs and relations. 11791 11792 procedure Record_Invocation_Path (In_State : Processing_In_State); 11793 pragma Inline (Record_Invocation_Path); 11794 -- Record the invocation relations found within the path represented in 11795 -- the active scenario stack. In_State denotes the current state of the 11796 -- Processing phase. 11797 11798 procedure Record_Simple_Invocation_Path (In_State : Processing_In_State); 11799 pragma Inline (Record_Simple_Invocation_Path); 11800 -- Record a single relation from the start to the end of the stack of 11801 -- active scenarios. In_State is the current state of the Processing 11802 -- phase. 11803 11804 procedure Record_Invocation_Relation 11805 (Invk_Id : Entity_Id; 11806 Targ_Id : Entity_Id; 11807 In_State : Processing_In_State); 11808 pragma Inline (Record_Invocation_Relation); 11809 -- Record an invocation relation with invoker Invk_Id and target Targ_Id 11810 -- by creating an entry for it in the ALI file of the main unit. Formal 11811 -- In_State denotes the current state of the Processing phase. 11812 11813 procedure Set_Is_Saved_Construct (Constr : Entity_Id); 11814 pragma Inline (Set_Is_Saved_Construct); 11815 -- Mark invocation construct Constr as declared in the ALI file of the 11816 -- main unit. 11817 11818 procedure Set_Is_Saved_Relation (Rel : Invoker_Target_Relation); 11819 pragma Inline (Set_Is_Saved_Relation); 11820 -- Mark simple invocation relation Rel as recorded in the ALI file of 11821 -- the main unit. 11822 11823 function Target_Of 11824 (Pos : Active_Scenario_Pos; 11825 In_State : Processing_In_State) return Entity_Id; 11826 pragma Inline (Target_Of); 11827 -- Given position within the active scenario stack Pos, obtain the 11828 -- target of the indicated scenario. In_State is the current state 11829 -- of the Processing phase. 11830 11831 procedure Traverse_Invocation_Body 11832 (N : Node_Id; 11833 In_State : Processing_In_State); 11834 pragma Inline (Traverse_Invocation_Body); 11835 -- Traverse subprogram body N looking for suitable invocation scenarios 11836 -- that need to be processed for invocation graph recording purposes. 11837 -- In_State is the current state of the Processing phase. 11838 11839 procedure Write_Invocation_Path (In_State : Processing_In_State); 11840 pragma Inline (Write_Invocation_Path); 11841 -- Write out a path represented by the active scenario on the stack to 11842 -- standard output. In_State denotes the current state of the Processing 11843 -- phase. 11844 11845 ------------------------------------ 11846 -- Build_Elaborate_Body_Procedure -- 11847 ------------------------------------ 11848 11849 procedure Build_Elaborate_Body_Procedure is 11850 Body_Decl : Node_Id; 11851 Spec_Decl : Node_Id; 11852 11853 begin 11854 -- Nothing to do when a previous call already created the procedure 11855 11856 if Present (Elab_Body_Id) then 11857 return; 11858 end if; 11859 11860 Spec_And_Body_From_Entity 11861 (Id => Main_Unit_Entity, 11862 Body_Decl => Body_Decl, 11863 Spec_Decl => Spec_Decl); 11864 11865 pragma Assert (Present (Body_Decl)); 11866 11867 Build_Elaborate_Procedure 11868 (Proc_Id => Elab_Body_Id, 11869 Proc_Nam => Name_B, 11870 Loc => Sloc (Body_Decl)); 11871 end Build_Elaborate_Body_Procedure; 11872 11873 ------------------------------- 11874 -- Build_Elaborate_Procedure -- 11875 ------------------------------- 11876 11877 procedure Build_Elaborate_Procedure 11878 (Proc_Id : out Entity_Id; 11879 Proc_Nam : Name_Id; 11880 Loc : Source_Ptr) 11881 is 11882 Proc_Decl : Node_Id; 11883 pragma Unreferenced (Proc_Decl); 11884 11885 begin 11886 Proc_Id := Make_Defining_Identifier (Loc, Proc_Nam); 11887 11888 -- Partially decorate the elaboration procedure because it will not 11889 -- be insertred into the tree and analyzed. 11890 11891 Mutate_Ekind (Proc_Id, E_Procedure); 11892 Set_Etype (Proc_Id, Standard_Void_Type); 11893 Set_Scope (Proc_Id, Unique_Entity (Main_Unit_Entity)); 11894 11895 -- Create a dummy declaration for the elaboration procedure. The 11896 -- declaration does not need to be syntactically legal, but must 11897 -- carry an accurate source location. 11898 11899 Proc_Decl := 11900 Make_Subprogram_Body (Loc, 11901 Specification => 11902 Make_Procedure_Specification (Loc, 11903 Defining_Unit_Name => Proc_Id), 11904 Declarations => No_List, 11905 Handled_Statement_Sequence => Empty); 11906 end Build_Elaborate_Procedure; 11907 11908 ------------------------------------ 11909 -- Build_Elaborate_Spec_Procedure -- 11910 ------------------------------------ 11911 11912 procedure Build_Elaborate_Spec_Procedure is 11913 Body_Decl : Node_Id; 11914 Spec_Decl : Node_Id; 11915 11916 begin 11917 -- Nothing to do when a previous call already created the procedure 11918 11919 if Present (Elab_Spec_Id) then 11920 return; 11921 end if; 11922 11923 Spec_And_Body_From_Entity 11924 (Id => Main_Unit_Entity, 11925 Body_Decl => Body_Decl, 11926 Spec_Decl => Spec_Decl); 11927 11928 pragma Assert (Present (Spec_Decl)); 11929 11930 Build_Elaborate_Procedure 11931 (Proc_Id => Elab_Spec_Id, 11932 Proc_Nam => Name_S, 11933 Loc => Sloc (Spec_Decl)); 11934 end Build_Elaborate_Spec_Procedure; 11935 11936 --------------------------------- 11937 -- Build_Subprogram_Invocation -- 11938 --------------------------------- 11939 11940 function Build_Subprogram_Invocation 11941 (Subp_Id : Entity_Id) return Node_Id 11942 is 11943 Marker : constant Node_Id := Make_Call_Marker (Sloc (Subp_Id)); 11944 Subp_Decl : constant Node_Id := Unit_Declaration_Node (Subp_Id); 11945 11946 begin 11947 -- Create a dummy call marker which invokes the subprogram 11948 11949 Set_Is_Declaration_Level_Node (Marker, False); 11950 Set_Is_Dispatching_Call (Marker, False); 11951 Set_Is_Elaboration_Checks_OK_Node (Marker, False); 11952 Set_Is_Elaboration_Warnings_OK_Node (Marker, False); 11953 Set_Is_Ignored_Ghost_Node (Marker, False); 11954 Set_Is_Preelaborable_Call (Marker, False); 11955 Set_Is_Source_Call (Marker, False); 11956 Set_Is_SPARK_Mode_On_Node (Marker, False); 11957 11958 -- Invoke the uniform canonical entity of the subprogram 11959 11960 Set_Target (Marker, Canonical_Subprogram (Subp_Id)); 11961 11962 -- Partially insert the marker into the tree 11963 11964 Set_Parent (Marker, Parent (Subp_Decl)); 11965 11966 return Marker; 11967 end Build_Subprogram_Invocation; 11968 11969 --------------------------- 11970 -- Build_Task_Activation -- 11971 --------------------------- 11972 11973 function Build_Task_Activation 11974 (Task_Typ : Entity_Id; 11975 In_State : Processing_In_State) return Node_Id 11976 is 11977 Loc : constant Source_Ptr := Sloc (Task_Typ); 11978 Marker : constant Node_Id := Make_Call_Marker (Loc); 11979 Task_Decl : constant Node_Id := Unit_Declaration_Node (Task_Typ); 11980 11981 Activ_Id : Entity_Id; 11982 Marker_Rep_Id : Scenario_Rep_Id; 11983 Task_Obj : Entity_Id; 11984 Task_Objs : NE_List.Doubly_Linked_List; 11985 11986 begin 11987 -- Create a dummy call marker which activates some tasks 11988 11989 Set_Is_Declaration_Level_Node (Marker, False); 11990 Set_Is_Dispatching_Call (Marker, False); 11991 Set_Is_Elaboration_Checks_OK_Node (Marker, False); 11992 Set_Is_Elaboration_Warnings_OK_Node (Marker, False); 11993 Set_Is_Ignored_Ghost_Node (Marker, False); 11994 Set_Is_Preelaborable_Call (Marker, False); 11995 Set_Is_Source_Call (Marker, False); 11996 Set_Is_SPARK_Mode_On_Node (Marker, False); 11997 11998 -- Invoke the appropriate version of Activate_Tasks 11999 12000 if Restricted_Profile then 12001 Activ_Id := RTE (RE_Activate_Restricted_Tasks); 12002 else 12003 Activ_Id := RTE (RE_Activate_Tasks); 12004 end if; 12005 12006 Set_Target (Marker, Activ_Id); 12007 12008 -- Partially insert the marker into the tree 12009 12010 Set_Parent (Marker, Parent (Task_Decl)); 12011 12012 -- Create a dummy task object. Partially decorate the object because 12013 -- it will not be inserted into the tree and analyzed. 12014 12015 Task_Obj := Make_Temporary (Loc, 'T'); 12016 Mutate_Ekind (Task_Obj, E_Variable); 12017 Set_Etype (Task_Obj, Task_Typ); 12018 12019 -- Associate the dummy task object with the activation call 12020 12021 Task_Objs := NE_List.Create; 12022 NE_List.Append (Task_Objs, Task_Obj); 12023 12024 Marker_Rep_Id := Scenario_Representation_Of (Marker, In_State); 12025 Set_Activated_Task_Objects (Marker_Rep_Id, Task_Objs); 12026 Set_Activated_Task_Type (Marker_Rep_Id, Task_Typ); 12027 12028 return Marker; 12029 end Build_Task_Activation; 12030 12031 ---------------------------------- 12032 -- Declare_Invocation_Construct -- 12033 ---------------------------------- 12034 12035 procedure Declare_Invocation_Construct 12036 (Constr_Id : Entity_Id; 12037 In_State : Processing_In_State) 12038 is 12039 function Body_Placement_Of 12040 (Id : Entity_Id) return Declaration_Placement_Kind; 12041 pragma Inline (Body_Placement_Of); 12042 -- Obtain the placement of arbitrary entity Id's body 12043 12044 function Declaration_Placement_Of_Node 12045 (N : Node_Id) return Declaration_Placement_Kind; 12046 pragma Inline (Declaration_Placement_Of_Node); 12047 -- Obtain the placement of arbitrary node N 12048 12049 function Kind_Of (Id : Entity_Id) return Invocation_Construct_Kind; 12050 pragma Inline (Kind_Of); 12051 -- Obtain the invocation construct kind of arbitrary entity Id 12052 12053 function Spec_Placement_Of 12054 (Id : Entity_Id) return Declaration_Placement_Kind; 12055 pragma Inline (Spec_Placement_Of); 12056 -- Obtain the placement of arbitrary entity Id's spec 12057 12058 ----------------------- 12059 -- Body_Placement_Of -- 12060 ----------------------- 12061 12062 function Body_Placement_Of 12063 (Id : Entity_Id) return Declaration_Placement_Kind 12064 is 12065 Id_Rep : constant Target_Rep_Id := 12066 Target_Representation_Of (Id, In_State); 12067 Body_Decl : constant Node_Id := Body_Declaration (Id_Rep); 12068 Spec_Decl : constant Node_Id := Spec_Declaration (Id_Rep); 12069 12070 begin 12071 -- The entity has a body 12072 12073 if Present (Body_Decl) then 12074 return Declaration_Placement_Of_Node (Body_Decl); 12075 12076 -- Otherwise the entity must have a spec 12077 12078 else 12079 pragma Assert (Present (Spec_Decl)); 12080 return Declaration_Placement_Of_Node (Spec_Decl); 12081 end if; 12082 end Body_Placement_Of; 12083 12084 ----------------------------------- 12085 -- Declaration_Placement_Of_Node -- 12086 ----------------------------------- 12087 12088 function Declaration_Placement_Of_Node 12089 (N : Node_Id) return Declaration_Placement_Kind 12090 is 12091 Main_Unit_Id : constant Entity_Id := Main_Unit_Entity; 12092 N_Unit_Id : constant Entity_Id := Find_Top_Unit (N); 12093 12094 begin 12095 -- The node is in the main unit, its placement depends on the main 12096 -- unit kind. 12097 12098 if N_Unit_Id = Main_Unit_Id then 12099 12100 -- The main unit is a body 12101 12102 if Ekind (Main_Unit_Id) in E_Package_Body | E_Subprogram_Body 12103 then 12104 return In_Body; 12105 12106 -- The main unit is a stand-alone subprogram body 12107 12108 elsif Ekind (Main_Unit_Id) in E_Function | E_Procedure 12109 and then Nkind (Unit_Declaration_Node (Main_Unit_Id)) = 12110 N_Subprogram_Body 12111 then 12112 return In_Body; 12113 12114 -- Otherwise the main unit is a spec 12115 12116 else 12117 return In_Spec; 12118 end if; 12119 12120 -- Otherwise the node is in the complementary unit of the main 12121 -- unit. The main unit is a body, the node is in the spec. 12122 12123 elsif Ekind (Main_Unit_Id) in E_Package_Body | E_Subprogram_Body 12124 then 12125 return In_Spec; 12126 12127 -- The main unit is a spec, the node is in the body 12128 12129 else 12130 return In_Body; 12131 end if; 12132 end Declaration_Placement_Of_Node; 12133 12134 ------------- 12135 -- Kind_Of -- 12136 ------------- 12137 12138 function Kind_Of (Id : Entity_Id) return Invocation_Construct_Kind is 12139 begin 12140 if Id = Elab_Body_Id then 12141 return Elaborate_Body_Procedure; 12142 12143 elsif Id = Elab_Spec_Id then 12144 return Elaborate_Spec_Procedure; 12145 12146 else 12147 return Regular_Construct; 12148 end if; 12149 end Kind_Of; 12150 12151 ----------------------- 12152 -- Spec_Placement_Of -- 12153 ----------------------- 12154 12155 function Spec_Placement_Of 12156 (Id : Entity_Id) return Declaration_Placement_Kind 12157 is 12158 Id_Rep : constant Target_Rep_Id := 12159 Target_Representation_Of (Id, In_State); 12160 Body_Decl : constant Node_Id := Body_Declaration (Id_Rep); 12161 Spec_Decl : constant Node_Id := Spec_Declaration (Id_Rep); 12162 12163 begin 12164 -- The entity has a spec 12165 12166 if Present (Spec_Decl) then 12167 return Declaration_Placement_Of_Node (Spec_Decl); 12168 12169 -- Otherwise the entity must have a body 12170 12171 else 12172 pragma Assert (Present (Body_Decl)); 12173 return Declaration_Placement_Of_Node (Body_Decl); 12174 end if; 12175 end Spec_Placement_Of; 12176 12177 -- Start of processing for Declare_Invocation_Construct 12178 12179 begin 12180 -- Nothing to do when the construct has already been declared in the 12181 -- ALI file. 12182 12183 if Is_Saved_Construct (Constr_Id) then 12184 return; 12185 end if; 12186 12187 -- Mark the construct as declared in the ALI file 12188 12189 Set_Is_Saved_Construct (Constr_Id); 12190 12191 -- Add the construct in the ALI file 12192 12193 Add_Invocation_Construct 12194 (Body_Placement => Body_Placement_Of (Constr_Id), 12195 Kind => Kind_Of (Constr_Id), 12196 Signature => Signature_Of (Constr_Id), 12197 Spec_Placement => Spec_Placement_Of (Constr_Id), 12198 Update_Units => False); 12199 end Declare_Invocation_Construct; 12200 12201 ------------------------------- 12202 -- Finalize_Invocation_Graph -- 12203 ------------------------------- 12204 12205 procedure Finalize_Invocation_Graph is 12206 begin 12207 NE_Set.Destroy (Saved_Constructs_Set); 12208 IR_Set.Destroy (Saved_Relations_Set); 12209 end Finalize_Invocation_Graph; 12210 12211 ---------- 12212 -- Hash -- 12213 ---------- 12214 12215 function Hash (Key : Invoker_Target_Relation) return Bucket_Range_Type is 12216 pragma Assert (Present (Key.Invoker)); 12217 pragma Assert (Present (Key.Target)); 12218 12219 begin 12220 return 12221 Hash_Two_Keys 12222 (Bucket_Range_Type (Key.Invoker), 12223 Bucket_Range_Type (Key.Target)); 12224 end Hash; 12225 12226 --------------------------------- 12227 -- Initialize_Invocation_Graph -- 12228 --------------------------------- 12229 12230 procedure Initialize_Invocation_Graph is 12231 begin 12232 Saved_Constructs_Set := NE_Set.Create (100); 12233 Saved_Relations_Set := IR_Set.Create (200); 12234 end Initialize_Invocation_Graph; 12235 12236 ----------------------------------- 12237 -- Invocation_Graph_Recording_OK -- 12238 ----------------------------------- 12239 12240 function Invocation_Graph_Recording_OK return Boolean is 12241 Main_Cunit : constant Node_Id := Cunit (Main_Unit); 12242 12243 begin 12244 -- Nothing to do when compiling for GNATprove because the invocation 12245 -- graph is not needed. 12246 12247 if GNATprove_Mode then 12248 return False; 12249 12250 -- Nothing to do when the compilation will not produce an ALI file 12251 12252 elsif Serious_Errors_Detected > 0 then 12253 return False; 12254 12255 -- Nothing to do when the main unit requires a body. Processing the 12256 -- completing body will create the ALI file for the unit and record 12257 -- the invocation graph. 12258 12259 elsif Body_Required (Main_Cunit) then 12260 return False; 12261 end if; 12262 12263 return True; 12264 end Invocation_Graph_Recording_OK; 12265 12266 ---------------------------- 12267 -- Is_Invocation_Scenario -- 12268 ---------------------------- 12269 12270 function Is_Invocation_Scenario (N : Node_Id) return Boolean is 12271 begin 12272 return 12273 Is_Suitable_Access_Taken (N) 12274 or else Is_Suitable_Call (N) 12275 or else Is_Suitable_Instantiation (N); 12276 end Is_Invocation_Scenario; 12277 12278 -------------------------- 12279 -- Is_Invocation_Target -- 12280 -------------------------- 12281 12282 function Is_Invocation_Target (Id : Entity_Id) return Boolean is 12283 begin 12284 -- To qualify, the entity must either come from source, or denote an 12285 -- Ada, bridge, or SPARK target. 12286 12287 return 12288 Comes_From_Source (Id) 12289 or else Is_Ada_Semantic_Target (Id) 12290 or else Is_Bridge_Target (Id) 12291 or else Is_SPARK_Semantic_Target (Id); 12292 end Is_Invocation_Target; 12293 12294 ------------------------ 12295 -- Is_Saved_Construct -- 12296 ------------------------ 12297 12298 function Is_Saved_Construct (Constr : Entity_Id) return Boolean is 12299 pragma Assert (Present (Constr)); 12300 begin 12301 return NE_Set.Contains (Saved_Constructs_Set, Constr); 12302 end Is_Saved_Construct; 12303 12304 ----------------------- 12305 -- Is_Saved_Relation -- 12306 ----------------------- 12307 12308 function Is_Saved_Relation 12309 (Rel : Invoker_Target_Relation) return Boolean 12310 is 12311 pragma Assert (Present (Rel.Invoker)); 12312 pragma Assert (Present (Rel.Target)); 12313 12314 begin 12315 return IR_Set.Contains (Saved_Relations_Set, Rel); 12316 end Is_Saved_Relation; 12317 12318 -------------------------- 12319 -- Process_Declarations -- 12320 -------------------------- 12321 12322 procedure Process_Declarations 12323 (Decls : List_Id; 12324 In_State : Processing_In_State) 12325 is 12326 Decl : Node_Id; 12327 12328 begin 12329 Decl := First (Decls); 12330 while Present (Decl) loop 12331 12332 -- Freeze node 12333 12334 if Nkind (Decl) = N_Freeze_Entity then 12335 Process_Freeze_Node 12336 (Fnode => Decl, 12337 In_State => In_State); 12338 12339 -- Package (nested) 12340 12341 elsif Nkind (Decl) = N_Package_Declaration then 12342 Process_Package_Declaration 12343 (Pack_Decl => Decl, 12344 In_State => In_State); 12345 12346 -- Protected type 12347 12348 elsif Nkind (Decl) in N_Protected_Type_Declaration 12349 | N_Single_Protected_Declaration 12350 then 12351 Process_Protected_Type_Declaration 12352 (Prot_Decl => Decl, 12353 In_State => In_State); 12354 12355 -- Subprogram or entry 12356 12357 elsif Nkind (Decl) in N_Entry_Declaration 12358 | N_Subprogram_Declaration 12359 then 12360 Process_Subprogram_Declaration 12361 (Subp_Decl => Decl, 12362 In_State => In_State); 12363 12364 -- Subprogram body (stand alone) 12365 12366 elsif Nkind (Decl) = N_Subprogram_Body 12367 and then No (Corresponding_Spec (Decl)) 12368 then 12369 Process_Subprogram_Declaration 12370 (Subp_Decl => Decl, 12371 In_State => In_State); 12372 12373 -- Subprogram instantiation 12374 12375 elsif Nkind (Decl) in N_Subprogram_Instantiation then 12376 Process_Subprogram_Instantiation 12377 (Inst => Decl, 12378 In_State => In_State); 12379 12380 -- Task type 12381 12382 elsif Nkind (Decl) in N_Single_Task_Declaration 12383 | N_Task_Type_Declaration 12384 then 12385 Process_Task_Type_Declaration 12386 (Task_Decl => Decl, 12387 In_State => In_State); 12388 12389 -- Task type (derived) 12390 12391 elsif Nkind (Decl) = N_Full_Type_Declaration 12392 and then Is_Task_Type (Defining_Entity (Decl)) 12393 then 12394 Process_Task_Type_Declaration 12395 (Task_Decl => Decl, 12396 In_State => In_State); 12397 end if; 12398 12399 Next (Decl); 12400 end loop; 12401 end Process_Declarations; 12402 12403 ------------------------- 12404 -- Process_Freeze_Node -- 12405 ------------------------- 12406 12407 procedure Process_Freeze_Node 12408 (Fnode : Node_Id; 12409 In_State : Processing_In_State) 12410 is 12411 begin 12412 Process_Declarations 12413 (Decls => Actions (Fnode), 12414 In_State => In_State); 12415 end Process_Freeze_Node; 12416 12417 ----------------------------------- 12418 -- Process_Invocation_Activation -- 12419 ----------------------------------- 12420 12421 procedure Process_Invocation_Activation 12422 (Call : Node_Id; 12423 Call_Rep : Scenario_Rep_Id; 12424 Obj_Id : Entity_Id; 12425 Obj_Rep : Target_Rep_Id; 12426 Task_Typ : Entity_Id; 12427 Task_Rep : Target_Rep_Id; 12428 In_State : Processing_In_State) 12429 is 12430 pragma Unreferenced (Call); 12431 pragma Unreferenced (Call_Rep); 12432 pragma Unreferenced (Obj_Id); 12433 pragma Unreferenced (Obj_Rep); 12434 12435 begin 12436 -- Nothing to do when the task type appears within an internal unit 12437 12438 if In_Internal_Unit (Task_Typ) then 12439 return; 12440 end if; 12441 12442 -- The task type being activated is within the main unit. Extend the 12443 -- DFS traversal into its body. 12444 12445 if In_Extended_Main_Code_Unit (Task_Typ) then 12446 Traverse_Invocation_Body 12447 (N => Body_Declaration (Task_Rep), 12448 In_State => In_State); 12449 12450 -- The task type being activated resides within an external unit 12451 -- 12452 -- Main unit External unit 12453 -- +-----------+ +-------------+ 12454 -- | | | | 12455 -- | Start ------------> Task_Typ | 12456 -- | | | | 12457 -- +-----------+ +-------------+ 12458 -- 12459 -- Record the invocation path which originates from Start and reaches 12460 -- the task type. 12461 12462 else 12463 Record_Invocation_Path (In_State); 12464 end if; 12465 end Process_Invocation_Activation; 12466 12467 --------------------------------------- 12468 -- Process_Invocation_Body_Scenarios -- 12469 --------------------------------------- 12470 12471 procedure Process_Invocation_Body_Scenarios is 12472 Iter : NE_Set.Iterator := Iterate_Library_Body_Scenarios; 12473 begin 12474 Process_Invocation_Scenarios 12475 (Iter => Iter, 12476 In_State => Invocation_Body_State); 12477 end Process_Invocation_Body_Scenarios; 12478 12479 ----------------------------- 12480 -- Process_Invocation_Call -- 12481 ----------------------------- 12482 12483 procedure Process_Invocation_Call 12484 (Call : Node_Id; 12485 Call_Rep : Scenario_Rep_Id; 12486 In_State : Processing_In_State) 12487 is 12488 pragma Unreferenced (Call); 12489 12490 Subp_Id : constant Entity_Id := Target (Call_Rep); 12491 Subp_Rep : constant Target_Rep_Id := 12492 Target_Representation_Of (Subp_Id, In_State); 12493 12494 begin 12495 -- Nothing to do when the subprogram appears within an internal unit 12496 12497 if In_Internal_Unit (Subp_Id) then 12498 return; 12499 12500 -- Nothing to do for an abstract subprogram because it has no body to 12501 -- examine. 12502 12503 elsif Ekind (Subp_Id) in E_Function | E_Procedure 12504 and then Is_Abstract_Subprogram (Subp_Id) 12505 then 12506 return; 12507 12508 -- Nothin to do for a formal subprogram because it has no body to 12509 -- examine. 12510 12511 elsif Is_Formal_Subprogram (Subp_Id) then 12512 return; 12513 end if; 12514 12515 -- The subprogram being called is within the main unit. Extend the 12516 -- DFS traversal into its barrier function and body. 12517 12518 if In_Extended_Main_Code_Unit (Subp_Id) then 12519 if Ekind (Subp_Id) in E_Entry | E_Entry_Family | E_Procedure then 12520 Traverse_Invocation_Body 12521 (N => Barrier_Body_Declaration (Subp_Rep), 12522 In_State => In_State); 12523 end if; 12524 12525 Traverse_Invocation_Body 12526 (N => Body_Declaration (Subp_Rep), 12527 In_State => In_State); 12528 12529 -- The subprogram being called resides within an external unit 12530 -- 12531 -- Main unit External unit 12532 -- +-----------+ +-------------+ 12533 -- | | | | 12534 -- | Start ------------> Subp_Id | 12535 -- | | | | 12536 -- +-----------+ +-------------+ 12537 -- 12538 -- Record the invocation path which originates from Start and reaches 12539 -- the subprogram. 12540 12541 else 12542 Record_Invocation_Path (In_State); 12543 end if; 12544 end Process_Invocation_Call; 12545 12546 -------------------------------------- 12547 -- Process_Invocation_Instantiation -- 12548 -------------------------------------- 12549 12550 procedure Process_Invocation_Instantiation 12551 (Inst : Node_Id; 12552 Inst_Rep : Scenario_Rep_Id; 12553 In_State : Processing_In_State) 12554 is 12555 pragma Unreferenced (Inst); 12556 12557 Gen_Id : constant Entity_Id := Target (Inst_Rep); 12558 12559 begin 12560 -- Nothing to do when the generic appears within an internal unit 12561 12562 if In_Internal_Unit (Gen_Id) then 12563 return; 12564 end if; 12565 12566 -- The generic being instantiated resides within an external unit 12567 -- 12568 -- Main unit External unit 12569 -- +-----------+ +-------------+ 12570 -- | | | | 12571 -- | Start ------------> Generic | 12572 -- | | | | 12573 -- +-----------+ +-------------+ 12574 -- 12575 -- Record the invocation path which originates from Start and reaches 12576 -- the generic. 12577 12578 if not In_Extended_Main_Code_Unit (Gen_Id) then 12579 Record_Invocation_Path (In_State); 12580 end if; 12581 end Process_Invocation_Instantiation; 12582 12583 --------------------------------- 12584 -- Process_Invocation_Scenario -- 12585 --------------------------------- 12586 12587 procedure Process_Invocation_Scenario 12588 (N : Node_Id; 12589 In_State : Processing_In_State) 12590 is 12591 Scen : constant Node_Id := Scenario (N); 12592 Scen_Rep : Scenario_Rep_Id; 12593 12594 begin 12595 -- Add the current scenario to the stack of active scenarios 12596 12597 Push_Active_Scenario (Scen); 12598 12599 -- Call or task activation 12600 12601 if Is_Suitable_Call (Scen) then 12602 Scen_Rep := Scenario_Representation_Of (Scen, In_State); 12603 12604 -- Routine Build_Call_Marker creates call markers regardless of 12605 -- whether the call occurs within the main unit or not. This way 12606 -- the serialization of internal names is kept consistent. Only 12607 -- call markers found within the main unit must be processed. 12608 12609 if In_Main_Context (Scen) then 12610 Scen_Rep := Scenario_Representation_Of (Scen, In_State); 12611 12612 if Kind (Scen_Rep) = Call_Scenario then 12613 Process_Invocation_Call 12614 (Call => Scen, 12615 Call_Rep => Scen_Rep, 12616 In_State => In_State); 12617 12618 else 12619 pragma Assert (Kind (Scen_Rep) = Task_Activation_Scenario); 12620 12621 Process_Activation 12622 (Call => Scen, 12623 Call_Rep => Scen_Rep, 12624 Processor => Process_Invocation_Activation'Access, 12625 In_State => In_State); 12626 end if; 12627 end if; 12628 12629 -- Instantiation 12630 12631 elsif Is_Suitable_Instantiation (Scen) then 12632 Process_Invocation_Instantiation 12633 (Inst => Scen, 12634 Inst_Rep => Scenario_Representation_Of (Scen, In_State), 12635 In_State => In_State); 12636 end if; 12637 12638 -- Remove the current scenario from the stack of active scenarios 12639 -- once all invocation constructs and paths have been saved. 12640 12641 Pop_Active_Scenario (Scen); 12642 end Process_Invocation_Scenario; 12643 12644 ---------------------------------- 12645 -- Process_Invocation_Scenarios -- 12646 ---------------------------------- 12647 12648 procedure Process_Invocation_Scenarios 12649 (Iter : in out NE_Set.Iterator; 12650 In_State : Processing_In_State) 12651 is 12652 N : Node_Id; 12653 12654 begin 12655 while NE_Set.Has_Next (Iter) loop 12656 NE_Set.Next (Iter, N); 12657 12658 -- Reset the traversed status of all subprogram bodies because the 12659 -- current invocation scenario acts as a new DFS traversal root. 12660 12661 Reset_Traversed_Bodies; 12662 12663 Process_Invocation_Scenario (N, In_State); 12664 end loop; 12665 end Process_Invocation_Scenarios; 12666 12667 --------------------------------------- 12668 -- Process_Invocation_Spec_Scenarios -- 12669 --------------------------------------- 12670 12671 procedure Process_Invocation_Spec_Scenarios is 12672 Iter : NE_Set.Iterator := Iterate_Library_Spec_Scenarios; 12673 begin 12674 Process_Invocation_Scenarios 12675 (Iter => Iter, 12676 In_State => Invocation_Spec_State); 12677 end Process_Invocation_Spec_Scenarios; 12678 12679 ----------------------- 12680 -- Process_Main_Unit -- 12681 ----------------------- 12682 12683 procedure Process_Main_Unit is 12684 Unit_Decl : constant Node_Id := Unit (Cunit (Main_Unit)); 12685 Spec_Id : Entity_Id; 12686 12687 begin 12688 -- The main unit is a [generic] package body 12689 12690 if Nkind (Unit_Decl) = N_Package_Body then 12691 Spec_Id := Corresponding_Spec (Unit_Decl); 12692 pragma Assert (Present (Spec_Id)); 12693 12694 Process_Package_Declaration 12695 (Pack_Decl => Unit_Declaration_Node (Spec_Id), 12696 In_State => Invocation_Construct_State); 12697 12698 -- The main unit is a [generic] package declaration 12699 12700 elsif Nkind (Unit_Decl) = N_Package_Declaration then 12701 Process_Package_Declaration 12702 (Pack_Decl => Unit_Decl, 12703 In_State => Invocation_Construct_State); 12704 12705 -- The main unit is a [generic] subprogram body 12706 12707 elsif Nkind (Unit_Decl) = N_Subprogram_Body then 12708 Spec_Id := Corresponding_Spec (Unit_Decl); 12709 12710 -- The body completes a previous declaration 12711 12712 if Present (Spec_Id) then 12713 Process_Subprogram_Declaration 12714 (Subp_Decl => Unit_Declaration_Node (Spec_Id), 12715 In_State => Invocation_Construct_State); 12716 12717 -- Otherwise the body is stand-alone 12718 12719 else 12720 Process_Subprogram_Declaration 12721 (Subp_Decl => Unit_Decl, 12722 In_State => Invocation_Construct_State); 12723 end if; 12724 12725 -- The main unit is a subprogram instantiation 12726 12727 elsif Nkind (Unit_Decl) in N_Subprogram_Instantiation then 12728 Process_Subprogram_Instantiation 12729 (Inst => Unit_Decl, 12730 In_State => Invocation_Construct_State); 12731 12732 -- The main unit is an imported subprogram declaration 12733 12734 elsif Nkind (Unit_Decl) = N_Subprogram_Declaration then 12735 Process_Subprogram_Declaration 12736 (Subp_Decl => Unit_Decl, 12737 In_State => Invocation_Construct_State); 12738 end if; 12739 end Process_Main_Unit; 12740 12741 --------------------------------- 12742 -- Process_Package_Declaration -- 12743 --------------------------------- 12744 12745 procedure Process_Package_Declaration 12746 (Pack_Decl : Node_Id; 12747 In_State : Processing_In_State) 12748 is 12749 Body_Id : constant Entity_Id := Corresponding_Body (Pack_Decl); 12750 Spec : constant Node_Id := Specification (Pack_Decl); 12751 Spec_Id : constant Entity_Id := Defining_Entity (Pack_Decl); 12752 12753 begin 12754 -- Add a declaration for the generic package in the ALI of the main 12755 -- unit in case a client unit instantiates it. 12756 12757 if Ekind (Spec_Id) = E_Generic_Package then 12758 Declare_Invocation_Construct 12759 (Constr_Id => Spec_Id, 12760 In_State => In_State); 12761 12762 -- Otherwise inspect the visible and private declarations of the 12763 -- package for invocation constructs. 12764 12765 else 12766 Process_Declarations 12767 (Decls => Visible_Declarations (Spec), 12768 In_State => In_State); 12769 12770 Process_Declarations 12771 (Decls => Private_Declarations (Spec), 12772 In_State => In_State); 12773 12774 -- The package body containst at least one generic unit or an 12775 -- inlinable subprogram. Such constructs may grant clients of 12776 -- the main unit access to the private enclosing contexts of 12777 -- the constructs. Process the main unit body to discover and 12778 -- encode relevant invocation constructs and relations that 12779 -- may ultimately reach an external unit. 12780 12781 if Present (Body_Id) 12782 and then Save_Invocation_Graph_Of_Body (Cunit (Main_Unit)) 12783 then 12784 Process_Declarations 12785 (Decls => Declarations (Unit_Declaration_Node (Body_Id)), 12786 In_State => In_State); 12787 end if; 12788 end if; 12789 end Process_Package_Declaration; 12790 12791 ---------------------------------------- 12792 -- Process_Protected_Type_Declaration -- 12793 ---------------------------------------- 12794 12795 procedure Process_Protected_Type_Declaration 12796 (Prot_Decl : Node_Id; 12797 In_State : Processing_In_State) 12798 is 12799 Prot_Def : constant Node_Id := Protected_Definition (Prot_Decl); 12800 12801 begin 12802 if Present (Prot_Def) then 12803 Process_Declarations 12804 (Decls => Visible_Declarations (Prot_Def), 12805 In_State => In_State); 12806 end if; 12807 end Process_Protected_Type_Declaration; 12808 12809 ------------------------------------ 12810 -- Process_Subprogram_Declaration -- 12811 ------------------------------------ 12812 12813 procedure Process_Subprogram_Declaration 12814 (Subp_Decl : Node_Id; 12815 In_State : Processing_In_State) 12816 is 12817 Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl); 12818 12819 begin 12820 -- Nothing to do when the subprogram is not an invocation target 12821 12822 if not Is_Invocation_Target (Subp_Id) then 12823 return; 12824 end if; 12825 12826 -- Add a declaration for the subprogram in the ALI file of the main 12827 -- unit in case a client unit calls or instantiates it. 12828 12829 Declare_Invocation_Construct 12830 (Constr_Id => Subp_Id, 12831 In_State => In_State); 12832 12833 -- Do not process subprograms without a body because they do not 12834 -- contain any invocation scenarios. 12835 12836 if Is_Bodiless_Subprogram (Subp_Id) then 12837 null; 12838 12839 -- Do not process generic subprograms because generics must not be 12840 -- examined. 12841 12842 elsif Is_Generic_Subprogram (Subp_Id) then 12843 null; 12844 12845 -- Otherwise create a dummy scenario which calls the subprogram to 12846 -- act as a root for a DFS traversal. 12847 12848 else 12849 -- Reset the traversed status of all subprogram bodies because the 12850 -- subprogram acts as a new DFS traversal root. 12851 12852 Reset_Traversed_Bodies; 12853 12854 Process_Invocation_Scenario 12855 (N => Build_Subprogram_Invocation (Subp_Id), 12856 In_State => In_State); 12857 end if; 12858 end Process_Subprogram_Declaration; 12859 12860 -------------------------------------- 12861 -- Process_Subprogram_Instantiation -- 12862 -------------------------------------- 12863 12864 procedure Process_Subprogram_Instantiation 12865 (Inst : Node_Id; 12866 In_State : Processing_In_State) 12867 is 12868 begin 12869 -- Add a declaration for the instantiation in the ALI file of the 12870 -- main unit in case a client unit calls it. 12871 12872 Declare_Invocation_Construct 12873 (Constr_Id => Defining_Entity (Inst), 12874 In_State => In_State); 12875 end Process_Subprogram_Instantiation; 12876 12877 ----------------------------------- 12878 -- Process_Task_Type_Declaration -- 12879 ----------------------------------- 12880 12881 procedure Process_Task_Type_Declaration 12882 (Task_Decl : Node_Id; 12883 In_State : Processing_In_State) 12884 is 12885 Task_Typ : constant Entity_Id := Defining_Entity (Task_Decl); 12886 Task_Def : Node_Id; 12887 12888 begin 12889 -- Add a declaration for the task type the ALI file of the main unit 12890 -- in case a client unit creates a task object and activates it. 12891 12892 Declare_Invocation_Construct 12893 (Constr_Id => Task_Typ, 12894 In_State => In_State); 12895 12896 -- Process the entries of the task type because they represent valid 12897 -- entry points into the task body. 12898 12899 if Nkind (Task_Decl) in N_Single_Task_Declaration 12900 | N_Task_Type_Declaration 12901 then 12902 Task_Def := Task_Definition (Task_Decl); 12903 12904 if Present (Task_Def) then 12905 Process_Declarations 12906 (Decls => Visible_Declarations (Task_Def), 12907 In_State => In_State); 12908 end if; 12909 end if; 12910 12911 -- Reset the traversed status of all subprogram bodies because the 12912 -- task type acts as a new DFS traversal root. 12913 12914 Reset_Traversed_Bodies; 12915 12916 -- Create a dummy scenario which activates an anonymous object of the 12917 -- task type to acts as a root of a DFS traversal. 12918 12919 Process_Invocation_Scenario 12920 (N => Build_Task_Activation (Task_Typ, In_State), 12921 In_State => In_State); 12922 end Process_Task_Type_Declaration; 12923 12924 --------------------------------- 12925 -- Record_Full_Invocation_Path -- 12926 --------------------------------- 12927 12928 procedure Record_Full_Invocation_Path (In_State : Processing_In_State) is 12929 package Scenarios renames Active_Scenario_Stack; 12930 12931 begin 12932 -- The path originates from the elaboration of the body. Add an extra 12933 -- relation from the elaboration body procedure to the first active 12934 -- scenario. 12935 12936 if In_State.Processing = Invocation_Body_Processing then 12937 Build_Elaborate_Body_Procedure; 12938 12939 Record_Invocation_Relation 12940 (Invk_Id => Elab_Body_Id, 12941 Targ_Id => Target_Of (Scenarios.First, In_State), 12942 In_State => In_State); 12943 12944 -- The path originates from the elaboration of the spec. Add an extra 12945 -- relation from the elaboration spec procedure to the first active 12946 -- scenario. 12947 12948 elsif In_State.Processing = Invocation_Spec_Processing then 12949 Build_Elaborate_Spec_Procedure; 12950 12951 Record_Invocation_Relation 12952 (Invk_Id => Elab_Spec_Id, 12953 Targ_Id => Target_Of (Scenarios.First, In_State), 12954 In_State => In_State); 12955 end if; 12956 12957 -- Record individual relations formed by pairs of scenarios 12958 12959 for Index in Scenarios.First .. Scenarios.Last - 1 loop 12960 Record_Invocation_Relation 12961 (Invk_Id => Target_Of (Index, In_State), 12962 Targ_Id => Target_Of (Index + 1, In_State), 12963 In_State => In_State); 12964 end loop; 12965 end Record_Full_Invocation_Path; 12966 12967 ----------------------------- 12968 -- Record_Invocation_Graph -- 12969 ----------------------------- 12970 12971 procedure Record_Invocation_Graph is 12972 begin 12973 -- Nothing to do when the invocation graph is not recorded 12974 12975 if not Invocation_Graph_Recording_OK then 12976 return; 12977 end if; 12978 12979 -- Save the encoding format used to capture information about the 12980 -- invocation constructs and relations in the ALI file of the main 12981 -- unit. 12982 12983 Record_Invocation_Graph_Encoding; 12984 12985 -- Examine all library level invocation scenarios and perform DFS 12986 -- traversals from each one. Encode a path in the ALI file of the 12987 -- main unit if it reaches into an external unit. 12988 12989 Process_Invocation_Body_Scenarios; 12990 Process_Invocation_Spec_Scenarios; 12991 12992 -- Examine all invocation constructs within the spec and body of the 12993 -- main unit and perform DFS traversals from each one. Encode a path 12994 -- in the ALI file of the main unit if it reaches into an external 12995 -- unit. 12996 12997 Process_Main_Unit; 12998 end Record_Invocation_Graph; 12999 13000 -------------------------------------- 13001 -- Record_Invocation_Graph_Encoding -- 13002 -------------------------------------- 13003 13004 procedure Record_Invocation_Graph_Encoding is 13005 Kind : Invocation_Graph_Encoding_Kind := No_Encoding; 13006 13007 begin 13008 -- Switch -gnatd_F (encode full invocation paths in ALI files) is in 13009 -- effect. 13010 13011 if Debug_Flag_Underscore_FF then 13012 Kind := Full_Path_Encoding; 13013 else 13014 Kind := Endpoints_Encoding; 13015 end if; 13016 13017 -- Save the encoding format in the ALI file of the main unit 13018 13019 Set_Invocation_Graph_Encoding 13020 (Kind => Kind, 13021 Update_Units => False); 13022 end Record_Invocation_Graph_Encoding; 13023 13024 ---------------------------- 13025 -- Record_Invocation_Path -- 13026 ---------------------------- 13027 13028 procedure Record_Invocation_Path (In_State : Processing_In_State) is 13029 package Scenarios renames Active_Scenario_Stack; 13030 13031 begin 13032 -- Save a path when the active scenario stack contains at least one 13033 -- invocation scenario. 13034 13035 if Scenarios.Last - Scenarios.First < 0 then 13036 return; 13037 end if; 13038 13039 -- Register all relations in the path when switch -gnatd_F (encode 13040 -- full invocation paths in ALI files) is in effect. 13041 13042 if Debug_Flag_Underscore_FF then 13043 Record_Full_Invocation_Path (In_State); 13044 13045 -- Otherwise register a single relation 13046 13047 else 13048 Record_Simple_Invocation_Path (In_State); 13049 end if; 13050 13051 Write_Invocation_Path (In_State); 13052 end Record_Invocation_Path; 13053 13054 -------------------------------- 13055 -- Record_Invocation_Relation -- 13056 -------------------------------- 13057 13058 procedure Record_Invocation_Relation 13059 (Invk_Id : Entity_Id; 13060 Targ_Id : Entity_Id; 13061 In_State : Processing_In_State) 13062 is 13063 pragma Assert (Present (Invk_Id)); 13064 pragma Assert (Present (Targ_Id)); 13065 13066 procedure Get_Invocation_Attributes 13067 (Extra : out Entity_Id; 13068 Kind : out Invocation_Kind); 13069 pragma Inline (Get_Invocation_Attributes); 13070 -- Return the additional entity used in error diagnostics in Extra 13071 -- and the invocation kind in Kind which pertain to the invocation 13072 -- relation with invoker Invk_Id and target Targ_Id. 13073 13074 ------------------------------- 13075 -- Get_Invocation_Attributes -- 13076 ------------------------------- 13077 13078 procedure Get_Invocation_Attributes 13079 (Extra : out Entity_Id; 13080 Kind : out Invocation_Kind) 13081 is 13082 Targ_Rep : constant Target_Rep_Id := 13083 Target_Representation_Of (Targ_Id, In_State); 13084 Spec_Decl : constant Node_Id := Spec_Declaration (Targ_Rep); 13085 13086 begin 13087 -- Accept within a task body 13088 13089 if Is_Accept_Alternative_Proc (Targ_Id) then 13090 Extra := Receiving_Entry (Targ_Id); 13091 Kind := Accept_Alternative; 13092 13093 -- Activation of a task object 13094 13095 elsif Is_Activation_Proc (Targ_Id) 13096 or else Is_Task_Type (Targ_Id) 13097 then 13098 Extra := Empty; 13099 Kind := Task_Activation; 13100 13101 -- Controlled adjustment actions 13102 13103 elsif Is_Controlled_Proc (Targ_Id, Name_Adjust) then 13104 Extra := First_Formal_Type (Targ_Id); 13105 Kind := Controlled_Adjustment; 13106 13107 -- Controlled finalization actions 13108 13109 elsif Is_Controlled_Proc (Targ_Id, Name_Finalize) 13110 or else Is_Finalizer_Proc (Targ_Id) 13111 then 13112 Extra := First_Formal_Type (Targ_Id); 13113 Kind := Controlled_Finalization; 13114 13115 -- Controlled initialization actions 13116 13117 elsif Is_Controlled_Proc (Targ_Id, Name_Initialize) then 13118 Extra := First_Formal_Type (Targ_Id); 13119 Kind := Controlled_Initialization; 13120 13121 -- Default_Initial_Condition verification 13122 13123 elsif Is_Default_Initial_Condition_Proc (Targ_Id) then 13124 Extra := First_Formal_Type (Targ_Id); 13125 Kind := Default_Initial_Condition_Verification; 13126 13127 -- Initialization of object 13128 13129 elsif Is_Init_Proc (Targ_Id) then 13130 Extra := First_Formal_Type (Targ_Id); 13131 Kind := Type_Initialization; 13132 13133 -- Initial_Condition verification 13134 13135 elsif Is_Initial_Condition_Proc (Targ_Id) then 13136 Extra := First_Formal_Type (Targ_Id); 13137 Kind := Initial_Condition_Verification; 13138 13139 -- Instantiation 13140 13141 elsif Is_Generic_Unit (Targ_Id) then 13142 Extra := Empty; 13143 Kind := Instantiation; 13144 13145 -- Internal controlled adjustment actions 13146 13147 elsif Is_TSS (Targ_Id, TSS_Deep_Adjust) then 13148 Extra := First_Formal_Type (Targ_Id); 13149 Kind := Internal_Controlled_Adjustment; 13150 13151 -- Internal controlled finalization actions 13152 13153 elsif Is_TSS (Targ_Id, TSS_Deep_Finalize) then 13154 Extra := First_Formal_Type (Targ_Id); 13155 Kind := Internal_Controlled_Finalization; 13156 13157 -- Internal controlled initialization actions 13158 13159 elsif Is_TSS (Targ_Id, TSS_Deep_Initialize) then 13160 Extra := First_Formal_Type (Targ_Id); 13161 Kind := Internal_Controlled_Initialization; 13162 13163 -- Invariant verification 13164 13165 elsif Is_Invariant_Proc (Targ_Id) 13166 or else Is_Partial_Invariant_Proc (Targ_Id) 13167 then 13168 Extra := First_Formal_Type (Targ_Id); 13169 Kind := Invariant_Verification; 13170 13171 -- Postcondition verification 13172 13173 elsif Is_Postconditions_Proc (Targ_Id) then 13174 Extra := Find_Enclosing_Scope (Spec_Decl); 13175 Kind := Postcondition_Verification; 13176 13177 -- Protected entry call 13178 13179 elsif Is_Protected_Entry (Targ_Id) then 13180 Extra := Empty; 13181 Kind := Protected_Entry_Call; 13182 13183 -- Protected subprogram call 13184 13185 elsif Is_Protected_Subp (Targ_Id) then 13186 Extra := Empty; 13187 Kind := Protected_Subprogram_Call; 13188 13189 -- Task entry call 13190 13191 elsif Is_Task_Entry (Targ_Id) then 13192 Extra := Empty; 13193 Kind := Task_Entry_Call; 13194 13195 -- Entry, operator, or subprogram call. This case must come last 13196 -- because most invocations above are variations of this case. 13197 13198 elsif Ekind (Targ_Id) in 13199 E_Entry | E_Function | E_Operator | E_Procedure 13200 then 13201 Extra := Empty; 13202 Kind := Call; 13203 13204 else 13205 pragma Assert (False); 13206 Extra := Empty; 13207 Kind := No_Invocation; 13208 end if; 13209 end Get_Invocation_Attributes; 13210 13211 -- Local variables 13212 13213 Extra : Entity_Id; 13214 Extra_Nam : Name_Id; 13215 Kind : Invocation_Kind; 13216 Rel : Invoker_Target_Relation; 13217 13218 -- Start of processing for Record_Invocation_Relation 13219 13220 begin 13221 Rel.Invoker := Invk_Id; 13222 Rel.Target := Targ_Id; 13223 13224 -- Nothing to do when the invocation relation has already been 13225 -- recorded in ALI file of the main unit. 13226 13227 if Is_Saved_Relation (Rel) then 13228 return; 13229 end if; 13230 13231 -- Mark the relation as recorded in the ALI file 13232 13233 Set_Is_Saved_Relation (Rel); 13234 13235 -- Declare the invoker in the ALI file 13236 13237 Declare_Invocation_Construct 13238 (Constr_Id => Invk_Id, 13239 In_State => In_State); 13240 13241 -- Obtain the invocation-specific attributes of the relation 13242 13243 Get_Invocation_Attributes (Extra, Kind); 13244 13245 -- Certain invocations lack an extra entity used in error diagnostics 13246 13247 if Present (Extra) then 13248 Extra_Nam := Chars (Extra); 13249 else 13250 Extra_Nam := No_Name; 13251 end if; 13252 13253 -- Add the relation in the ALI file 13254 13255 Add_Invocation_Relation 13256 (Extra => Extra_Nam, 13257 Invoker => Signature_Of (Invk_Id), 13258 Kind => Kind, 13259 Target => Signature_Of (Targ_Id), 13260 Update_Units => False); 13261 end Record_Invocation_Relation; 13262 13263 ----------------------------------- 13264 -- Record_Simple_Invocation_Path -- 13265 ----------------------------------- 13266 13267 procedure Record_Simple_Invocation_Path 13268 (In_State : Processing_In_State) 13269 is 13270 package Scenarios renames Active_Scenario_Stack; 13271 13272 Last_Targ : constant Entity_Id := 13273 Target_Of (Scenarios.Last, In_State); 13274 First_Targ : Entity_Id; 13275 13276 begin 13277 -- The path originates from the elaboration of the body. Add an extra 13278 -- relation from the elaboration body procedure to the first active 13279 -- scenario. 13280 13281 if In_State.Processing = Invocation_Body_Processing then 13282 Build_Elaborate_Body_Procedure; 13283 First_Targ := Elab_Body_Id; 13284 13285 -- The path originates from the elaboration of the spec. Add an extra 13286 -- relation from the elaboration spec procedure to the first active 13287 -- scenario. 13288 13289 elsif In_State.Processing = Invocation_Spec_Processing then 13290 Build_Elaborate_Spec_Procedure; 13291 First_Targ := Elab_Spec_Id; 13292 13293 else 13294 First_Targ := Target_Of (Scenarios.First, In_State); 13295 end if; 13296 13297 -- Record a single relation from the first to the last scenario 13298 13299 if First_Targ /= Last_Targ then 13300 Record_Invocation_Relation 13301 (Invk_Id => First_Targ, 13302 Targ_Id => Last_Targ, 13303 In_State => In_State); 13304 end if; 13305 end Record_Simple_Invocation_Path; 13306 13307 ---------------------------- 13308 -- Set_Is_Saved_Construct -- 13309 ---------------------------- 13310 13311 procedure Set_Is_Saved_Construct (Constr : Entity_Id) is 13312 pragma Assert (Present (Constr)); 13313 13314 begin 13315 NE_Set.Insert (Saved_Constructs_Set, Constr); 13316 end Set_Is_Saved_Construct; 13317 13318 --------------------------- 13319 -- Set_Is_Saved_Relation -- 13320 --------------------------- 13321 13322 procedure Set_Is_Saved_Relation (Rel : Invoker_Target_Relation) is 13323 begin 13324 IR_Set.Insert (Saved_Relations_Set, Rel); 13325 end Set_Is_Saved_Relation; 13326 13327 ------------------ 13328 -- Signature_Of -- 13329 ------------------ 13330 13331 function Signature_Of (Id : Entity_Id) return Invocation_Signature_Id is 13332 Loc : constant Source_Ptr := Sloc (Id); 13333 13334 function Instantiation_Locations return Name_Id; 13335 pragma Inline (Instantiation_Locations); 13336 -- Create a concatenation of all lines and colums of each instance 13337 -- where source location Loc appears. Return No_Name if no instances 13338 -- exist. 13339 13340 function Qualified_Scope return Name_Id; 13341 pragma Inline (Qualified_Scope); 13342 -- Obtain the qualified name of Id's scope 13343 13344 ----------------------------- 13345 -- Instantiation_Locations -- 13346 ----------------------------- 13347 13348 function Instantiation_Locations return Name_Id is 13349 Buffer : Bounded_String (2052); 13350 Inst : Source_Ptr; 13351 Loc_Nam : Name_Id; 13352 SFI : Source_File_Index; 13353 13354 begin 13355 SFI := Get_Source_File_Index (Loc); 13356 Inst := Instantiation (SFI); 13357 13358 -- The location is within an instance. Construct a concatenation 13359 -- of all lines and colums of each individual instance using the 13360 -- following format: 13361 -- 13362 -- line1_column1_line2_column2_ ... _lineN_columnN 13363 13364 if Inst /= No_Location then 13365 loop 13366 Append (Buffer, Nat (Get_Logical_Line_Number (Inst))); 13367 Append (Buffer, '_'); 13368 Append (Buffer, Nat (Get_Column_Number (Inst))); 13369 13370 SFI := Get_Source_File_Index (Inst); 13371 Inst := Instantiation (SFI); 13372 13373 exit when Inst = No_Location; 13374 13375 Append (Buffer, '_'); 13376 end loop; 13377 13378 Loc_Nam := Name_Find (Buffer); 13379 return Loc_Nam; 13380 13381 -- Otherwise there no instances are involved 13382 13383 else 13384 return No_Name; 13385 end if; 13386 end Instantiation_Locations; 13387 13388 --------------------- 13389 -- Qualified_Scope -- 13390 --------------------- 13391 13392 function Qualified_Scope return Name_Id is 13393 Scop : Entity_Id; 13394 13395 begin 13396 Scop := Scope (Id); 13397 13398 -- The entity appears within an anonymous concurrent type created 13399 -- for a single protected or task type declaration. Use the entity 13400 -- of the anonymous object as it represents the original scope. 13401 13402 if Is_Concurrent_Type (Scop) 13403 and then Present (Anonymous_Object (Scop)) 13404 then 13405 Scop := Anonymous_Object (Scop); 13406 end if; 13407 13408 return Get_Qualified_Name (Scop); 13409 end Qualified_Scope; 13410 13411 -- Start of processing for Signature_Of 13412 13413 begin 13414 return 13415 Invocation_Signature_Of 13416 (Column => Nat (Get_Column_Number (Loc)), 13417 Line => Nat (Get_Logical_Line_Number (Loc)), 13418 Locations => Instantiation_Locations, 13419 Name => Chars (Id), 13420 Scope => Qualified_Scope); 13421 end Signature_Of; 13422 13423 --------------- 13424 -- Target_Of -- 13425 --------------- 13426 13427 function Target_Of 13428 (Pos : Active_Scenario_Pos; 13429 In_State : Processing_In_State) return Entity_Id 13430 is 13431 package Scenarios renames Active_Scenario_Stack; 13432 13433 -- Ensure that the position is within the bounds of the active 13434 -- scenario stack. 13435 13436 pragma Assert (Scenarios.First <= Pos); 13437 pragma Assert (Pos <= Scenarios.Last); 13438 13439 Scen_Rep : constant Scenario_Rep_Id := 13440 Scenario_Representation_Of 13441 (Scenarios.Table (Pos), In_State); 13442 13443 begin 13444 -- The true target of an activation call is the current task type 13445 -- rather than routine Activate_Tasks. 13446 13447 if Kind (Scen_Rep) = Task_Activation_Scenario then 13448 return Activated_Task_Type (Scen_Rep); 13449 else 13450 return Target (Scen_Rep); 13451 end if; 13452 end Target_Of; 13453 13454 ------------------------------ 13455 -- Traverse_Invocation_Body -- 13456 ------------------------------ 13457 13458 procedure Traverse_Invocation_Body 13459 (N : Node_Id; 13460 In_State : Processing_In_State) 13461 is 13462 begin 13463 Traverse_Body 13464 (N => N, 13465 Requires_Processing => Is_Invocation_Scenario'Access, 13466 Processor => Process_Invocation_Scenario'Access, 13467 In_State => In_State); 13468 end Traverse_Invocation_Body; 13469 13470 --------------------------- 13471 -- Write_Invocation_Path -- 13472 --------------------------- 13473 13474 procedure Write_Invocation_Path (In_State : Processing_In_State) is 13475 procedure Write_Target (Targ_Id : Entity_Id; Is_First : Boolean); 13476 pragma Inline (Write_Target); 13477 -- Write out invocation target Targ_Id to standard output. Flag 13478 -- Is_First should be set when the target is first in a path. 13479 13480 ------------- 13481 -- Targ_Id -- 13482 ------------- 13483 13484 procedure Write_Target (Targ_Id : Entity_Id; Is_First : Boolean) is 13485 begin 13486 if not Is_First then 13487 Write_Str (" --> "); 13488 end if; 13489 13490 Write_Name (Get_Qualified_Name (Targ_Id)); 13491 Write_Eol; 13492 end Write_Target; 13493 13494 -- Local variables 13495 13496 package Scenarios renames Active_Scenario_Stack; 13497 13498 First_Seen : Boolean := False; 13499 13500 -- Start of processing for Write_Invocation_Path 13501 13502 begin 13503 -- Nothing to do when flag -gnatd_T (output trace information on 13504 -- invocation path recording) is not in effect. 13505 13506 if not Debug_Flag_Underscore_TT then 13507 return; 13508 end if; 13509 13510 -- The path originates from the elaboration of the body. Write the 13511 -- elaboration body procedure. 13512 13513 if In_State.Processing = Invocation_Body_Processing then 13514 Write_Target (Elab_Body_Id, True); 13515 First_Seen := True; 13516 13517 -- The path originates from the elaboration of the spec. Write the 13518 -- elaboration spec procedure. 13519 13520 elsif In_State.Processing = Invocation_Spec_Processing then 13521 Write_Target (Elab_Spec_Id, True); 13522 First_Seen := True; 13523 end if; 13524 13525 -- Write each individual target invoked by its corresponding scenario 13526 -- on the active scenario stack. 13527 13528 for Index in Scenarios.First .. Scenarios.Last loop 13529 Write_Target 13530 (Targ_Id => Target_Of (Index, In_State), 13531 Is_First => Index = Scenarios.First and then not First_Seen); 13532 end loop; 13533 13534 Write_Eol; 13535 end Write_Invocation_Path; 13536 end Invocation_Graph; 13537 13538 ------------------------ 13539 -- Is_Safe_Activation -- 13540 ------------------------ 13541 13542 function Is_Safe_Activation 13543 (Call : Node_Id; 13544 Task_Rep : Target_Rep_Id) return Boolean 13545 is 13546 begin 13547 -- The activation of a task coming from an external instance cannot 13548 -- cause an ABE because the generic was already instantiated. Note 13549 -- that the instantiation itself may lead to an ABE. 13550 13551 return 13552 In_External_Instance 13553 (N => Call, 13554 Target_Decl => Spec_Declaration (Task_Rep)); 13555 end Is_Safe_Activation; 13556 13557 ------------------ 13558 -- Is_Safe_Call -- 13559 ------------------ 13560 13561 function Is_Safe_Call 13562 (Call : Node_Id; 13563 Subp_Id : Entity_Id; 13564 Subp_Rep : Target_Rep_Id) return Boolean 13565 is 13566 Body_Decl : constant Node_Id := Body_Declaration (Subp_Rep); 13567 Spec_Decl : constant Node_Id := Spec_Declaration (Subp_Rep); 13568 13569 begin 13570 -- The target is either an abstract subprogram, formal subprogram, or 13571 -- imported, in which case it does not have a body at compile or bind 13572 -- time. Assume that the call is ABE-safe. 13573 13574 if Is_Bodiless_Subprogram (Subp_Id) then 13575 return True; 13576 13577 -- The target is an instantiation of a generic subprogram. The call 13578 -- cannot cause an ABE because the generic was already instantiated. 13579 -- Note that the instantiation itself may lead to an ABE. 13580 13581 elsif Is_Generic_Instance (Subp_Id) then 13582 return True; 13583 13584 -- The invocation of a target coming from an external instance cannot 13585 -- cause an ABE because the generic was already instantiated. Note that 13586 -- the instantiation itself may lead to an ABE. 13587 13588 elsif In_External_Instance 13589 (N => Call, 13590 Target_Decl => Spec_Decl) 13591 then 13592 return True; 13593 13594 -- The target is a subprogram body without a previous declaration. The 13595 -- call cannot cause an ABE because the body has already been seen. 13596 13597 elsif Nkind (Spec_Decl) = N_Subprogram_Body 13598 and then No (Corresponding_Spec (Spec_Decl)) 13599 then 13600 return True; 13601 13602 -- The target is a subprogram body stub without a prior declaration. 13603 -- The call cannot cause an ABE because the proper body substitutes 13604 -- the stub. 13605 13606 elsif Nkind (Spec_Decl) = N_Subprogram_Body_Stub 13607 and then No (Corresponding_Spec_Of_Stub (Spec_Decl)) 13608 then 13609 return True; 13610 13611 -- A call to an expression function that is not a completion cannot 13612 -- cause an ABE because it has no prior declaration; this remains 13613 -- true even if the FE transforms the callee into something else. 13614 13615 elsif Nkind (Original_Node (Spec_Decl)) = N_Expression_Function then 13616 return True; 13617 13618 -- Subprogram bodies which wrap attribute references used as actuals 13619 -- in instantiations are always ABE-safe. These bodies are artifacts 13620 -- of expansion. 13621 13622 elsif Present (Body_Decl) 13623 and then Nkind (Body_Decl) = N_Subprogram_Body 13624 and then Was_Attribute_Reference (Body_Decl) 13625 then 13626 return True; 13627 end if; 13628 13629 return False; 13630 end Is_Safe_Call; 13631 13632 --------------------------- 13633 -- Is_Safe_Instantiation -- 13634 --------------------------- 13635 13636 function Is_Safe_Instantiation 13637 (Inst : Node_Id; 13638 Gen_Id : Entity_Id; 13639 Gen_Rep : Target_Rep_Id) return Boolean 13640 is 13641 Spec_Decl : constant Node_Id := Spec_Declaration (Gen_Rep); 13642 13643 begin 13644 -- The generic is an intrinsic subprogram in which case it does not 13645 -- have a body at compile or bind time. Assume that the instantiation 13646 -- is ABE-safe. 13647 13648 if Is_Bodiless_Subprogram (Gen_Id) then 13649 return True; 13650 13651 -- The instantiation of an external nested generic cannot cause an ABE 13652 -- if the outer generic was already instantiated. Note that the instance 13653 -- of the outer generic may lead to an ABE. 13654 13655 elsif In_External_Instance 13656 (N => Inst, 13657 Target_Decl => Spec_Decl) 13658 then 13659 return True; 13660 13661 -- The generic is a package. The instantiation cannot cause an ABE when 13662 -- the package has no body. 13663 13664 elsif Ekind (Gen_Id) = E_Generic_Package 13665 and then not Has_Body (Spec_Decl) 13666 then 13667 return True; 13668 end if; 13669 13670 return False; 13671 end Is_Safe_Instantiation; 13672 13673 ------------------ 13674 -- Is_Same_Unit -- 13675 ------------------ 13676 13677 function Is_Same_Unit 13678 (Unit_1 : Entity_Id; 13679 Unit_2 : Entity_Id) return Boolean 13680 is 13681 begin 13682 return Unit_Entity (Unit_1) = Unit_Entity (Unit_2); 13683 end Is_Same_Unit; 13684 13685 ------------------------------- 13686 -- Kill_Elaboration_Scenario -- 13687 ------------------------------- 13688 13689 procedure Kill_Elaboration_Scenario (N : Node_Id) is 13690 begin 13691 -- Nothing to do when switch -gnatH (legacy elaboration checking mode 13692 -- enabled) is in effect because the legacy ABE lechanism does not need 13693 -- to carry out this action. 13694 13695 if Legacy_Elaboration_Checks then 13696 return; 13697 13698 -- Nothing to do when the elaboration phase of the compiler is not 13699 -- active. 13700 13701 elsif not Elaboration_Phase_Active then 13702 return; 13703 end if; 13704 13705 -- Eliminate a recorded scenario when it appears within dead code 13706 -- because it will not be executed at elaboration time. 13707 13708 if Is_Scenario (N) then 13709 Delete_Scenario (N); 13710 end if; 13711 end Kill_Elaboration_Scenario; 13712 13713 ---------------------- 13714 -- Main_Unit_Entity -- 13715 ---------------------- 13716 13717 function Main_Unit_Entity return Entity_Id is 13718 begin 13719 -- Note that Cunit_Entity (Main_Unit) is not reliable in the presence of 13720 -- generic bodies and may return an outdated entity. 13721 13722 return Defining_Entity (Unit (Cunit (Main_Unit))); 13723 end Main_Unit_Entity; 13724 13725 ---------------------- 13726 -- Non_Private_View -- 13727 ---------------------- 13728 13729 function Non_Private_View (Typ : Entity_Id) return Entity_Id is 13730 begin 13731 if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then 13732 return Full_View (Typ); 13733 else 13734 return Typ; 13735 end if; 13736 end Non_Private_View; 13737 13738 --------------------------------- 13739 -- Record_Elaboration_Scenario -- 13740 --------------------------------- 13741 13742 procedure Record_Elaboration_Scenario (N : Node_Id) is 13743 procedure Check_Preelaborated_Call 13744 (Call : Node_Id; 13745 Call_Lvl : Enclosing_Level_Kind); 13746 pragma Inline (Check_Preelaborated_Call); 13747 -- Verify that entry, operator, or subprogram call Call with enclosing 13748 -- level Call_Lvl does not appear at the library level of preelaborated 13749 -- unit. 13750 13751 function Find_Code_Unit (Nod : Node_Or_Entity_Id) return Entity_Id; 13752 pragma Inline (Find_Code_Unit); 13753 -- Return the code unit which contains arbitrary node or entity Nod. 13754 -- This is the unit of the file which physically contains the related 13755 -- construct denoted by Nod except when Nod is within an instantiation. 13756 -- In that case the unit is that of the top-level instantiation. 13757 13758 function In_Preelaborated_Context (Nod : Node_Id) return Boolean; 13759 pragma Inline (In_Preelaborated_Context); 13760 -- Determine whether arbitrary node Nod appears within a preelaborated 13761 -- context. 13762 13763 procedure Record_Access_Taken 13764 (Attr : Node_Id; 13765 Attr_Lvl : Enclosing_Level_Kind); 13766 pragma Inline (Record_Access_Taken); 13767 -- Record 'Access scenario Attr with enclosing level Attr_Lvl 13768 13769 procedure Record_Call_Or_Task_Activation 13770 (Call : Node_Id; 13771 Call_Lvl : Enclosing_Level_Kind); 13772 pragma Inline (Record_Call_Or_Task_Activation); 13773 -- Record call scenario Call with enclosing level Call_Lvl 13774 13775 procedure Record_Instantiation 13776 (Inst : Node_Id; 13777 Inst_Lvl : Enclosing_Level_Kind); 13778 pragma Inline (Record_Instantiation); 13779 -- Record instantiation scenario Inst with enclosing level Inst_Lvl 13780 13781 procedure Record_Variable_Assignment 13782 (Asmt : Node_Id; 13783 Asmt_Lvl : Enclosing_Level_Kind); 13784 pragma Inline (Record_Variable_Assignment); 13785 -- Record variable assignment scenario Asmt with enclosing level 13786 -- Asmt_Lvl. 13787 13788 procedure Record_Variable_Reference 13789 (Ref : Node_Id; 13790 Ref_Lvl : Enclosing_Level_Kind); 13791 pragma Inline (Record_Variable_Reference); 13792 -- Record variable reference scenario Ref with enclosing level Ref_Lvl 13793 13794 ------------------------------ 13795 -- Check_Preelaborated_Call -- 13796 ------------------------------ 13797 13798 procedure Check_Preelaborated_Call 13799 (Call : Node_Id; 13800 Call_Lvl : Enclosing_Level_Kind) 13801 is 13802 begin 13803 -- Nothing to do when the call is internally generated because it is 13804 -- assumed that it will never violate preelaboration. 13805 13806 if not Is_Source_Call (Call) then 13807 return; 13808 13809 -- Nothing to do when the call is preelaborable by definition 13810 13811 elsif Is_Preelaborable_Call (Call) then 13812 return; 13813 13814 -- Library-level calls are always considered because they are part of 13815 -- the associated unit's elaboration actions. 13816 13817 elsif Call_Lvl in Library_Level then 13818 null; 13819 13820 -- Calls at the library level of a generic package body have to be 13821 -- checked because they would render an instantiation illegal if the 13822 -- template is marked as preelaborated. Note that this does not apply 13823 -- to calls at the library level of a generic package spec. 13824 13825 elsif Call_Lvl = Generic_Body_Level then 13826 null; 13827 13828 -- Otherwise the call does not appear at the proper level and must 13829 -- not be considered for this check. 13830 13831 else 13832 return; 13833 end if; 13834 13835 -- If the call appears within a preelaborated unit, give an error 13836 13837 if In_Preelaborated_Context (Call) then 13838 Error_Preelaborated_Call (Call); 13839 end if; 13840 end Check_Preelaborated_Call; 13841 13842 -------------------- 13843 -- Find_Code_Unit -- 13844 -------------------- 13845 13846 function Find_Code_Unit (Nod : Node_Or_Entity_Id) return Entity_Id is 13847 begin 13848 return Find_Unit_Entity (Unit (Cunit (Get_Code_Unit (Nod)))); 13849 end Find_Code_Unit; 13850 13851 ------------------------------ 13852 -- In_Preelaborated_Context -- 13853 ------------------------------ 13854 13855 function In_Preelaborated_Context (Nod : Node_Id) return Boolean is 13856 Body_Id : constant Entity_Id := Find_Code_Unit (Nod); 13857 Spec_Id : constant Entity_Id := Unique_Entity (Body_Id); 13858 13859 begin 13860 -- The node appears within a package body whose corresponding spec is 13861 -- subject to pragma Remote_Call_Interface or Remote_Types. This does 13862 -- not result in a preelaborated context because the package body may 13863 -- be on another machine. 13864 13865 if Ekind (Body_Id) = E_Package_Body 13866 and then Is_Package_Or_Generic_Package (Spec_Id) 13867 and then (Is_Remote_Call_Interface (Spec_Id) 13868 or else Is_Remote_Types (Spec_Id)) 13869 then 13870 return False; 13871 13872 -- Otherwise the node appears within a preelaborated context when the 13873 -- associated unit is preelaborated. 13874 13875 else 13876 return Is_Preelaborated_Unit (Spec_Id); 13877 end if; 13878 end In_Preelaborated_Context; 13879 13880 ------------------------- 13881 -- Record_Access_Taken -- 13882 ------------------------- 13883 13884 procedure Record_Access_Taken 13885 (Attr : Node_Id; 13886 Attr_Lvl : Enclosing_Level_Kind) 13887 is 13888 begin 13889 -- Signal any enclosing local exception handlers that the 'Access may 13890 -- raise Program_Error due to a failed ABE check when switch -gnatd.o 13891 -- (conservative elaboration order for indirect calls) is in effect. 13892 -- Marking the exception handlers ensures proper expansion by both 13893 -- the front and back end restriction when No_Exception_Propagation 13894 -- is in effect. 13895 13896 if Debug_Flag_Dot_O then 13897 Possible_Local_Raise (Attr, Standard_Program_Error); 13898 end if; 13899 13900 -- Add 'Access to the appropriate set 13901 13902 if Attr_Lvl = Library_Body_Level then 13903 Add_Library_Body_Scenario (Attr); 13904 13905 elsif Attr_Lvl = Library_Spec_Level 13906 or else Attr_Lvl = Instantiation_Level 13907 then 13908 Add_Library_Spec_Scenario (Attr); 13909 end if; 13910 13911 -- 'Access requires a conditional ABE check when the dynamic model is 13912 -- in effect. 13913 13914 Add_Dynamic_ABE_Check_Scenario (Attr); 13915 end Record_Access_Taken; 13916 13917 ------------------------------------ 13918 -- Record_Call_Or_Task_Activation -- 13919 ------------------------------------ 13920 13921 procedure Record_Call_Or_Task_Activation 13922 (Call : Node_Id; 13923 Call_Lvl : Enclosing_Level_Kind) 13924 is 13925 begin 13926 -- Signal any enclosing local exception handlers that the call may 13927 -- raise Program_Error due to failed ABE check. Marking the exception 13928 -- handlers ensures proper expansion by both the front and back end 13929 -- restriction when No_Exception_Propagation is in effect. 13930 13931 Possible_Local_Raise (Call, Standard_Program_Error); 13932 13933 -- Perform early detection of guaranteed ABEs in order to suppress 13934 -- the instantiation of generic bodies because gigi cannot handle 13935 -- certain types of premature instantiations. 13936 13937 Process_Guaranteed_ABE 13938 (N => Call, 13939 In_State => Guaranteed_ABE_State); 13940 13941 -- Add the call or task activation to the appropriate set 13942 13943 if Call_Lvl = Declaration_Level then 13944 Add_Declaration_Scenario (Call); 13945 13946 elsif Call_Lvl = Library_Body_Level then 13947 Add_Library_Body_Scenario (Call); 13948 13949 elsif Call_Lvl = Library_Spec_Level 13950 or else Call_Lvl = Instantiation_Level 13951 then 13952 Add_Library_Spec_Scenario (Call); 13953 end if; 13954 13955 -- A call or a task activation requires a conditional ABE check when 13956 -- the dynamic model is in effect. 13957 13958 Add_Dynamic_ABE_Check_Scenario (Call); 13959 end Record_Call_Or_Task_Activation; 13960 13961 -------------------------- 13962 -- Record_Instantiation -- 13963 -------------------------- 13964 13965 procedure Record_Instantiation 13966 (Inst : Node_Id; 13967 Inst_Lvl : Enclosing_Level_Kind) 13968 is 13969 begin 13970 -- Signal enclosing local exception handlers that instantiation may 13971 -- raise Program_Error due to failed ABE check. Marking the exception 13972 -- handlers ensures proper expansion by both the front and back end 13973 -- restriction when No_Exception_Propagation is in effect. 13974 13975 Possible_Local_Raise (Inst, Standard_Program_Error); 13976 13977 -- Perform early detection of guaranteed ABEs in order to suppress 13978 -- the instantiation of generic bodies because gigi cannot handle 13979 -- certain types of premature instantiations. 13980 13981 Process_Guaranteed_ABE 13982 (N => Inst, 13983 In_State => Guaranteed_ABE_State); 13984 13985 -- Add the instantiation to the appropriate set 13986 13987 if Inst_Lvl = Declaration_Level then 13988 Add_Declaration_Scenario (Inst); 13989 13990 elsif Inst_Lvl = Library_Body_Level then 13991 Add_Library_Body_Scenario (Inst); 13992 13993 elsif Inst_Lvl = Library_Spec_Level 13994 or else Inst_Lvl = Instantiation_Level 13995 then 13996 Add_Library_Spec_Scenario (Inst); 13997 end if; 13998 13999 -- Instantiations of generics subject to SPARK_Mode On require 14000 -- elaboration-related checks even though the instantiations may 14001 -- not appear within elaboration code. 14002 14003 if Is_Suitable_SPARK_Instantiation (Inst) then 14004 Add_SPARK_Scenario (Inst); 14005 end if; 14006 14007 -- An instantiation requires a conditional ABE check when the dynamic 14008 -- model is in effect. 14009 14010 Add_Dynamic_ABE_Check_Scenario (Inst); 14011 end Record_Instantiation; 14012 14013 -------------------------------- 14014 -- Record_Variable_Assignment -- 14015 -------------------------------- 14016 14017 procedure Record_Variable_Assignment 14018 (Asmt : Node_Id; 14019 Asmt_Lvl : Enclosing_Level_Kind) 14020 is 14021 begin 14022 -- Add the variable assignment to the appropriate set 14023 14024 if Asmt_Lvl = Library_Body_Level then 14025 Add_Library_Body_Scenario (Asmt); 14026 14027 elsif Asmt_Lvl = Library_Spec_Level 14028 or else Asmt_Lvl = Instantiation_Level 14029 then 14030 Add_Library_Spec_Scenario (Asmt); 14031 end if; 14032 end Record_Variable_Assignment; 14033 14034 ------------------------------- 14035 -- Record_Variable_Reference -- 14036 ------------------------------- 14037 14038 procedure Record_Variable_Reference 14039 (Ref : Node_Id; 14040 Ref_Lvl : Enclosing_Level_Kind) 14041 is 14042 begin 14043 -- Add the variable reference to the appropriate set 14044 14045 if Ref_Lvl = Library_Body_Level then 14046 Add_Library_Body_Scenario (Ref); 14047 14048 elsif Ref_Lvl = Library_Spec_Level 14049 or else Ref_Lvl = Instantiation_Level 14050 then 14051 Add_Library_Spec_Scenario (Ref); 14052 end if; 14053 end Record_Variable_Reference; 14054 14055 -- Local variables 14056 14057 Scen : constant Node_Id := Scenario (N); 14058 Scen_Lvl : Enclosing_Level_Kind; 14059 14060 -- Start of processing for Record_Elaboration_Scenario 14061 14062 begin 14063 -- Nothing to do when switch -gnatH (legacy elaboration checking mode 14064 -- enabled) is in effect because the legacy ABE mechanism does not need 14065 -- to carry out this action. 14066 14067 if Legacy_Elaboration_Checks then 14068 return; 14069 14070 -- Nothing to do when the scenario is being preanalyzed 14071 14072 elsif Preanalysis_Active then 14073 return; 14074 14075 -- Nothing to do when the elaboration phase of the compiler is not 14076 -- active. 14077 14078 elsif not Elaboration_Phase_Active then 14079 return; 14080 end if; 14081 14082 Scen_Lvl := Find_Enclosing_Level (Scen); 14083 14084 -- Ensure that a library-level call does not appear in a preelaborated 14085 -- unit. The check must come before ignoring scenarios within external 14086 -- units or inside generics because calls in those context must also be 14087 -- verified. 14088 14089 if Is_Suitable_Call (Scen) then 14090 Check_Preelaborated_Call (Scen, Scen_Lvl); 14091 end if; 14092 14093 -- Nothing to do when the scenario does not appear within the main unit 14094 14095 if not In_Main_Context (Scen) then 14096 return; 14097 14098 -- Nothing to do when the scenario appears within a generic 14099 14100 elsif Inside_A_Generic then 14101 return; 14102 14103 -- 'Access 14104 14105 elsif Is_Suitable_Access_Taken (Scen) then 14106 Record_Access_Taken 14107 (Attr => Scen, 14108 Attr_Lvl => Scen_Lvl); 14109 14110 -- Call or task activation 14111 14112 elsif Is_Suitable_Call (Scen) then 14113 Record_Call_Or_Task_Activation 14114 (Call => Scen, 14115 Call_Lvl => Scen_Lvl); 14116 14117 -- Derived type declaration 14118 14119 elsif Is_Suitable_SPARK_Derived_Type (Scen) then 14120 Add_SPARK_Scenario (Scen); 14121 14122 -- Instantiation 14123 14124 elsif Is_Suitable_Instantiation (Scen) then 14125 Record_Instantiation 14126 (Inst => Scen, 14127 Inst_Lvl => Scen_Lvl); 14128 14129 -- Refined_State pragma 14130 14131 elsif Is_Suitable_SPARK_Refined_State_Pragma (Scen) then 14132 Add_SPARK_Scenario (Scen); 14133 14134 -- Variable assignment 14135 14136 elsif Is_Suitable_Variable_Assignment (Scen) then 14137 Record_Variable_Assignment 14138 (Asmt => Scen, 14139 Asmt_Lvl => Scen_Lvl); 14140 14141 -- Variable reference 14142 14143 elsif Is_Suitable_Variable_Reference (Scen) then 14144 Record_Variable_Reference 14145 (Ref => Scen, 14146 Ref_Lvl => Scen_Lvl); 14147 end if; 14148 end Record_Elaboration_Scenario; 14149 14150 -------------- 14151 -- Scenario -- 14152 -------------- 14153 14154 function Scenario (N : Node_Id) return Node_Id is 14155 Orig_N : constant Node_Id := Original_Node (N); 14156 14157 begin 14158 -- An expanded instantiation is rewritten into a spec-body pair where 14159 -- N denotes the spec. In this case the original instantiation is the 14160 -- proper elaboration scenario. 14161 14162 if Nkind (Orig_N) in N_Generic_Instantiation then 14163 return Orig_N; 14164 14165 -- Otherwise the scenario is already in its proper form 14166 14167 else 14168 return N; 14169 end if; 14170 end Scenario; 14171 14172 ---------------------- 14173 -- Scenario_Storage -- 14174 ---------------------- 14175 14176 package body Scenario_Storage is 14177 14178 --------------------- 14179 -- Data structures -- 14180 --------------------- 14181 14182 -- The following sets store all scenarios 14183 14184 Declaration_Scenarios : NE_Set.Membership_Set := NE_Set.Nil; 14185 Dynamic_ABE_Check_Scenarios : NE_Set.Membership_Set := NE_Set.Nil; 14186 Library_Body_Scenarios : NE_Set.Membership_Set := NE_Set.Nil; 14187 Library_Spec_Scenarios : NE_Set.Membership_Set := NE_Set.Nil; 14188 SPARK_Scenarios : NE_Set.Membership_Set := NE_Set.Nil; 14189 14190 ------------------------------- 14191 -- Finalize_Scenario_Storage -- 14192 ------------------------------- 14193 14194 procedure Finalize_Scenario_Storage is 14195 begin 14196 NE_Set.Destroy (Declaration_Scenarios); 14197 NE_Set.Destroy (Dynamic_ABE_Check_Scenarios); 14198 NE_Set.Destroy (Library_Body_Scenarios); 14199 NE_Set.Destroy (Library_Spec_Scenarios); 14200 NE_Set.Destroy (SPARK_Scenarios); 14201 end Finalize_Scenario_Storage; 14202 14203 --------------------------------- 14204 -- Initialize_Scenario_Storage -- 14205 --------------------------------- 14206 14207 procedure Initialize_Scenario_Storage is 14208 begin 14209 Declaration_Scenarios := NE_Set.Create (1000); 14210 Dynamic_ABE_Check_Scenarios := NE_Set.Create (500); 14211 Library_Body_Scenarios := NE_Set.Create (1000); 14212 Library_Spec_Scenarios := NE_Set.Create (1000); 14213 SPARK_Scenarios := NE_Set.Create (100); 14214 end Initialize_Scenario_Storage; 14215 14216 ------------------------------ 14217 -- Add_Declaration_Scenario -- 14218 ------------------------------ 14219 14220 procedure Add_Declaration_Scenario (N : Node_Id) is 14221 pragma Assert (Present (N)); 14222 begin 14223 NE_Set.Insert (Declaration_Scenarios, N); 14224 end Add_Declaration_Scenario; 14225 14226 ------------------------------------ 14227 -- Add_Dynamic_ABE_Check_Scenario -- 14228 ------------------------------------ 14229 14230 procedure Add_Dynamic_ABE_Check_Scenario (N : Node_Id) is 14231 pragma Assert (Present (N)); 14232 14233 begin 14234 if not Check_Or_Failure_Generation_OK then 14235 return; 14236 14237 -- Nothing to do if the dynamic model is not in effect 14238 14239 elsif not Dynamic_Elaboration_Checks then 14240 return; 14241 end if; 14242 14243 NE_Set.Insert (Dynamic_ABE_Check_Scenarios, N); 14244 end Add_Dynamic_ABE_Check_Scenario; 14245 14246 ------------------------------- 14247 -- Add_Library_Body_Scenario -- 14248 ------------------------------- 14249 14250 procedure Add_Library_Body_Scenario (N : Node_Id) is 14251 pragma Assert (Present (N)); 14252 begin 14253 NE_Set.Insert (Library_Body_Scenarios, N); 14254 end Add_Library_Body_Scenario; 14255 14256 ------------------------------- 14257 -- Add_Library_Spec_Scenario -- 14258 ------------------------------- 14259 14260 procedure Add_Library_Spec_Scenario (N : Node_Id) is 14261 pragma Assert (Present (N)); 14262 begin 14263 NE_Set.Insert (Library_Spec_Scenarios, N); 14264 end Add_Library_Spec_Scenario; 14265 14266 ------------------------ 14267 -- Add_SPARK_Scenario -- 14268 ------------------------ 14269 14270 procedure Add_SPARK_Scenario (N : Node_Id) is 14271 pragma Assert (Present (N)); 14272 begin 14273 NE_Set.Insert (SPARK_Scenarios, N); 14274 end Add_SPARK_Scenario; 14275 14276 --------------------- 14277 -- Delete_Scenario -- 14278 --------------------- 14279 14280 procedure Delete_Scenario (N : Node_Id) is 14281 pragma Assert (Present (N)); 14282 14283 begin 14284 -- Delete the scenario from whichever set it belongs to 14285 14286 NE_Set.Delete (Declaration_Scenarios, N); 14287 NE_Set.Delete (Dynamic_ABE_Check_Scenarios, N); 14288 NE_Set.Delete (Library_Body_Scenarios, N); 14289 NE_Set.Delete (Library_Spec_Scenarios, N); 14290 NE_Set.Delete (SPARK_Scenarios, N); 14291 end Delete_Scenario; 14292 14293 ----------------------------------- 14294 -- Iterate_Declaration_Scenarios -- 14295 ----------------------------------- 14296 14297 function Iterate_Declaration_Scenarios return NE_Set.Iterator is 14298 begin 14299 return NE_Set.Iterate (Declaration_Scenarios); 14300 end Iterate_Declaration_Scenarios; 14301 14302 ----------------------------------------- 14303 -- Iterate_Dynamic_ABE_Check_Scenarios -- 14304 ----------------------------------------- 14305 14306 function Iterate_Dynamic_ABE_Check_Scenarios return NE_Set.Iterator is 14307 begin 14308 return NE_Set.Iterate (Dynamic_ABE_Check_Scenarios); 14309 end Iterate_Dynamic_ABE_Check_Scenarios; 14310 14311 ------------------------------------ 14312 -- Iterate_Library_Body_Scenarios -- 14313 ------------------------------------ 14314 14315 function Iterate_Library_Body_Scenarios return NE_Set.Iterator is 14316 begin 14317 return NE_Set.Iterate (Library_Body_Scenarios); 14318 end Iterate_Library_Body_Scenarios; 14319 14320 ------------------------------------ 14321 -- Iterate_Library_Spec_Scenarios -- 14322 ------------------------------------ 14323 14324 function Iterate_Library_Spec_Scenarios return NE_Set.Iterator is 14325 begin 14326 return NE_Set.Iterate (Library_Spec_Scenarios); 14327 end Iterate_Library_Spec_Scenarios; 14328 14329 ----------------------------- 14330 -- Iterate_SPARK_Scenarios -- 14331 ----------------------------- 14332 14333 function Iterate_SPARK_Scenarios return NE_Set.Iterator is 14334 begin 14335 return NE_Set.Iterate (SPARK_Scenarios); 14336 end Iterate_SPARK_Scenarios; 14337 14338 ---------------------- 14339 -- Replace_Scenario -- 14340 ---------------------- 14341 14342 procedure Replace_Scenario (Old_N : Node_Id; New_N : Node_Id) is 14343 procedure Replace_Scenario_In (Scenarios : NE_Set.Membership_Set); 14344 -- Determine whether scenario Old_N is present in set Scenarios, and 14345 -- if this is the case it, replace it with New_N. 14346 14347 ------------------------- 14348 -- Replace_Scenario_In -- 14349 ------------------------- 14350 14351 procedure Replace_Scenario_In (Scenarios : NE_Set.Membership_Set) is 14352 begin 14353 -- The set is intentionally checked for existance because node 14354 -- rewriting may occur after Sem_Elab has verified all scenarios 14355 -- and data structures have been destroyed. 14356 14357 if NE_Set.Present (Scenarios) 14358 and then NE_Set.Contains (Scenarios, Old_N) 14359 then 14360 NE_Set.Delete (Scenarios, Old_N); 14361 NE_Set.Insert (Scenarios, New_N); 14362 end if; 14363 end Replace_Scenario_In; 14364 14365 -- Start of processing for Replace_Scenario 14366 14367 begin 14368 Replace_Scenario_In (Declaration_Scenarios); 14369 Replace_Scenario_In (Dynamic_ABE_Check_Scenarios); 14370 Replace_Scenario_In (Library_Body_Scenarios); 14371 Replace_Scenario_In (Library_Spec_Scenarios); 14372 Replace_Scenario_In (SPARK_Scenarios); 14373 end Replace_Scenario; 14374 end Scenario_Storage; 14375 14376 --------------- 14377 -- Semantics -- 14378 --------------- 14379 14380 package body Semantics is 14381 14382 -------------------------------- 14383 -- Is_Accept_Alternative_Proc -- 14384 -------------------------------- 14385 14386 function Is_Accept_Alternative_Proc (Id : Entity_Id) return Boolean is 14387 begin 14388 -- To qualify, the entity must denote a procedure with a receiving 14389 -- entry. 14390 14391 return 14392 Ekind (Id) = E_Procedure and then Present (Receiving_Entry (Id)); 14393 end Is_Accept_Alternative_Proc; 14394 14395 ------------------------ 14396 -- Is_Activation_Proc -- 14397 ------------------------ 14398 14399 function Is_Activation_Proc (Id : Entity_Id) return Boolean is 14400 begin 14401 -- To qualify, the entity must denote one of the runtime procedures 14402 -- in charge of task activation. 14403 14404 if Ekind (Id) = E_Procedure then 14405 if Restricted_Profile then 14406 return Is_RTE (Id, RE_Activate_Restricted_Tasks); 14407 else 14408 return Is_RTE (Id, RE_Activate_Tasks); 14409 end if; 14410 end if; 14411 14412 return False; 14413 end Is_Activation_Proc; 14414 14415 ---------------------------- 14416 -- Is_Ada_Semantic_Target -- 14417 ---------------------------- 14418 14419 function Is_Ada_Semantic_Target (Id : Entity_Id) return Boolean is 14420 begin 14421 return 14422 Is_Activation_Proc (Id) 14423 or else Is_Controlled_Proc (Id, Name_Adjust) 14424 or else Is_Controlled_Proc (Id, Name_Finalize) 14425 or else Is_Controlled_Proc (Id, Name_Initialize) 14426 or else Is_Init_Proc (Id) 14427 or else Is_Invariant_Proc (Id) 14428 or else Is_Protected_Entry (Id) 14429 or else Is_Protected_Subp (Id) 14430 or else Is_Protected_Body_Subp (Id) 14431 or else Is_Subprogram_Inst (Id) 14432 or else Is_Task_Entry (Id); 14433 end Is_Ada_Semantic_Target; 14434 14435 -------------------------------- 14436 -- Is_Assertion_Pragma_Target -- 14437 -------------------------------- 14438 14439 function Is_Assertion_Pragma_Target (Id : Entity_Id) return Boolean is 14440 begin 14441 return 14442 Is_Default_Initial_Condition_Proc (Id) 14443 or else Is_Initial_Condition_Proc (Id) 14444 or else Is_Invariant_Proc (Id) 14445 or else Is_Partial_Invariant_Proc (Id) 14446 or else Is_Postconditions_Proc (Id); 14447 end Is_Assertion_Pragma_Target; 14448 14449 ---------------------------- 14450 -- Is_Bodiless_Subprogram -- 14451 ---------------------------- 14452 14453 function Is_Bodiless_Subprogram (Subp_Id : Entity_Id) return Boolean is 14454 begin 14455 -- An abstract subprogram does not have a body 14456 14457 if Ekind (Subp_Id) in E_Function | E_Operator | E_Procedure 14458 and then Is_Abstract_Subprogram (Subp_Id) 14459 then 14460 return True; 14461 14462 -- A formal subprogram does not have a body 14463 14464 elsif Is_Formal_Subprogram (Subp_Id) then 14465 return True; 14466 14467 -- An imported subprogram may have a body, however it is not known at 14468 -- compile or bind time where the body resides and whether it will be 14469 -- elaborated on time. 14470 14471 elsif Is_Imported (Subp_Id) then 14472 return True; 14473 end if; 14474 14475 return False; 14476 end Is_Bodiless_Subprogram; 14477 14478 ---------------------- 14479 -- Is_Bridge_Target -- 14480 ---------------------- 14481 14482 function Is_Bridge_Target (Id : Entity_Id) return Boolean is 14483 begin 14484 return 14485 Is_Accept_Alternative_Proc (Id) 14486 or else Is_Finalizer_Proc (Id) 14487 or else Is_Partial_Invariant_Proc (Id) 14488 or else Is_Postconditions_Proc (Id) 14489 or else Is_TSS (Id, TSS_Deep_Adjust) 14490 or else Is_TSS (Id, TSS_Deep_Finalize) 14491 or else Is_TSS (Id, TSS_Deep_Initialize); 14492 end Is_Bridge_Target; 14493 14494 ------------------------ 14495 -- Is_Controlled_Proc -- 14496 ------------------------ 14497 14498 function Is_Controlled_Proc 14499 (Subp_Id : Entity_Id; 14500 Subp_Nam : Name_Id) return Boolean 14501 is 14502 Formal_Id : Entity_Id; 14503 14504 begin 14505 pragma Assert 14506 (Subp_Nam in Name_Adjust | Name_Finalize | Name_Initialize); 14507 14508 -- To qualify, the subprogram must denote a source procedure with 14509 -- name Adjust, Finalize, or Initialize where the sole formal is 14510 -- controlled. 14511 14512 if Comes_From_Source (Subp_Id) 14513 and then Ekind (Subp_Id) = E_Procedure 14514 and then Chars (Subp_Id) = Subp_Nam 14515 then 14516 Formal_Id := First_Formal (Subp_Id); 14517 14518 return 14519 Present (Formal_Id) 14520 and then Is_Controlled (Etype (Formal_Id)) 14521 and then No (Next_Formal (Formal_Id)); 14522 end if; 14523 14524 return False; 14525 end Is_Controlled_Proc; 14526 14527 --------------------------------------- 14528 -- Is_Default_Initial_Condition_Proc -- 14529 --------------------------------------- 14530 14531 function Is_Default_Initial_Condition_Proc 14532 (Id : Entity_Id) return Boolean 14533 is 14534 begin 14535 -- To qualify, the entity must denote a Default_Initial_Condition 14536 -- procedure. 14537 14538 return Ekind (Id) = E_Procedure and then Is_DIC_Procedure (Id); 14539 end Is_Default_Initial_Condition_Proc; 14540 14541 ----------------------- 14542 -- Is_Finalizer_Proc -- 14543 ----------------------- 14544 14545 function Is_Finalizer_Proc (Id : Entity_Id) return Boolean is 14546 begin 14547 -- To qualify, the entity must denote a _Finalizer procedure 14548 14549 return Ekind (Id) = E_Procedure and then Chars (Id) = Name_uFinalizer; 14550 end Is_Finalizer_Proc; 14551 14552 ------------------------------- 14553 -- Is_Initial_Condition_Proc -- 14554 ------------------------------- 14555 14556 function Is_Initial_Condition_Proc (Id : Entity_Id) return Boolean is 14557 begin 14558 -- To qualify, the entity must denote an Initial_Condition procedure 14559 14560 return 14561 Ekind (Id) = E_Procedure 14562 and then Is_Initial_Condition_Procedure (Id); 14563 end Is_Initial_Condition_Proc; 14564 14565 -------------------- 14566 -- Is_Initialized -- 14567 -------------------- 14568 14569 function Is_Initialized (Obj_Decl : Node_Id) return Boolean is 14570 begin 14571 -- To qualify, the object declaration must have an expression 14572 14573 return 14574 Present (Expression (Obj_Decl)) 14575 or else Has_Init_Expression (Obj_Decl); 14576 end Is_Initialized; 14577 14578 ----------------------- 14579 -- Is_Invariant_Proc -- 14580 ----------------------- 14581 14582 function Is_Invariant_Proc (Id : Entity_Id) return Boolean is 14583 begin 14584 -- To qualify, the entity must denote the "full" invariant procedure 14585 14586 return Ekind (Id) = E_Procedure and then Is_Invariant_Procedure (Id); 14587 end Is_Invariant_Proc; 14588 14589 --------------------------------------- 14590 -- Is_Non_Library_Level_Encapsulator -- 14591 --------------------------------------- 14592 14593 function Is_Non_Library_Level_Encapsulator 14594 (N : Node_Id) return Boolean 14595 is 14596 begin 14597 case Nkind (N) is 14598 when N_Abstract_Subprogram_Declaration 14599 | N_Aspect_Specification 14600 | N_Component_Declaration 14601 | N_Entry_Body 14602 | N_Entry_Declaration 14603 | N_Expression_Function 14604 | N_Formal_Abstract_Subprogram_Declaration 14605 | N_Formal_Concrete_Subprogram_Declaration 14606 | N_Formal_Object_Declaration 14607 | N_Formal_Package_Declaration 14608 | N_Formal_Type_Declaration 14609 | N_Generic_Association 14610 | N_Implicit_Label_Declaration 14611 | N_Incomplete_Type_Declaration 14612 | N_Private_Extension_Declaration 14613 | N_Private_Type_Declaration 14614 | N_Protected_Body 14615 | N_Protected_Type_Declaration 14616 | N_Single_Protected_Declaration 14617 | N_Single_Task_Declaration 14618 | N_Subprogram_Body 14619 | N_Subprogram_Declaration 14620 | N_Task_Body 14621 | N_Task_Type_Declaration 14622 => 14623 return True; 14624 14625 when others => 14626 return Is_Generic_Declaration_Or_Body (N); 14627 end case; 14628 end Is_Non_Library_Level_Encapsulator; 14629 14630 ------------------------------- 14631 -- Is_Partial_Invariant_Proc -- 14632 ------------------------------- 14633 14634 function Is_Partial_Invariant_Proc (Id : Entity_Id) return Boolean is 14635 begin 14636 -- To qualify, the entity must denote the "partial" invariant 14637 -- procedure. 14638 14639 return 14640 Ekind (Id) = E_Procedure 14641 and then Is_Partial_Invariant_Procedure (Id); 14642 end Is_Partial_Invariant_Proc; 14643 14644 ---------------------------- 14645 -- Is_Postconditions_Proc -- 14646 ---------------------------- 14647 14648 function Is_Postconditions_Proc (Id : Entity_Id) return Boolean is 14649 begin 14650 -- To qualify, the entity must denote a _Postconditions procedure 14651 14652 return 14653 Ekind (Id) = E_Procedure and then Chars (Id) = Name_uPostconditions; 14654 end Is_Postconditions_Proc; 14655 14656 --------------------------- 14657 -- Is_Preelaborated_Unit -- 14658 --------------------------- 14659 14660 function Is_Preelaborated_Unit (Id : Entity_Id) return Boolean is 14661 begin 14662 return 14663 Is_Preelaborated (Id) 14664 or else Is_Pure (Id) 14665 or else Is_Remote_Call_Interface (Id) 14666 or else Is_Remote_Types (Id) 14667 or else Is_Shared_Passive (Id); 14668 end Is_Preelaborated_Unit; 14669 14670 ------------------------ 14671 -- Is_Protected_Entry -- 14672 ------------------------ 14673 14674 function Is_Protected_Entry (Id : Entity_Id) return Boolean is 14675 begin 14676 -- To qualify, the entity must denote an entry defined in a protected 14677 -- type. 14678 14679 return 14680 Is_Entry (Id) 14681 and then Is_Protected_Type (Non_Private_View (Scope (Id))); 14682 end Is_Protected_Entry; 14683 14684 ----------------------- 14685 -- Is_Protected_Subp -- 14686 ----------------------- 14687 14688 function Is_Protected_Subp (Id : Entity_Id) return Boolean is 14689 begin 14690 -- To qualify, the entity must denote a subprogram defined within a 14691 -- protected type. 14692 14693 return 14694 Ekind (Id) in E_Function | E_Procedure 14695 and then Is_Protected_Type (Non_Private_View (Scope (Id))); 14696 end Is_Protected_Subp; 14697 14698 ---------------------------- 14699 -- Is_Protected_Body_Subp -- 14700 ---------------------------- 14701 14702 function Is_Protected_Body_Subp (Id : Entity_Id) return Boolean is 14703 begin 14704 -- To qualify, the entity must denote a subprogram with attribute 14705 -- Protected_Subprogram set. 14706 14707 return 14708 Ekind (Id) in E_Function | E_Procedure 14709 and then Present (Protected_Subprogram (Id)); 14710 end Is_Protected_Body_Subp; 14711 14712 ----------------- 14713 -- Is_Scenario -- 14714 ----------------- 14715 14716 function Is_Scenario (N : Node_Id) return Boolean is 14717 begin 14718 case Nkind (N) is 14719 when N_Assignment_Statement 14720 | N_Attribute_Reference 14721 | N_Call_Marker 14722 | N_Entry_Call_Statement 14723 | N_Expanded_Name 14724 | N_Function_Call 14725 | N_Function_Instantiation 14726 | N_Identifier 14727 | N_Package_Instantiation 14728 | N_Procedure_Call_Statement 14729 | N_Procedure_Instantiation 14730 | N_Requeue_Statement 14731 => 14732 return True; 14733 14734 when others => 14735 return False; 14736 end case; 14737 end Is_Scenario; 14738 14739 ------------------------------ 14740 -- Is_SPARK_Semantic_Target -- 14741 ------------------------------ 14742 14743 function Is_SPARK_Semantic_Target (Id : Entity_Id) return Boolean is 14744 begin 14745 return 14746 Is_Default_Initial_Condition_Proc (Id) 14747 or else Is_Initial_Condition_Proc (Id); 14748 end Is_SPARK_Semantic_Target; 14749 14750 ------------------------ 14751 -- Is_Subprogram_Inst -- 14752 ------------------------ 14753 14754 function Is_Subprogram_Inst (Id : Entity_Id) return Boolean is 14755 begin 14756 -- To qualify, the entity must denote a function or a procedure which 14757 -- is hidden within an anonymous package, and is a generic instance. 14758 14759 return 14760 Ekind (Id) in E_Function | E_Procedure 14761 and then Is_Hidden (Id) 14762 and then Is_Generic_Instance (Id); 14763 end Is_Subprogram_Inst; 14764 14765 ------------------------------ 14766 -- Is_Suitable_Access_Taken -- 14767 ------------------------------ 14768 14769 function Is_Suitable_Access_Taken (N : Node_Id) return Boolean is 14770 Nam : Name_Id; 14771 Pref : Node_Id; 14772 Subp_Id : Entity_Id; 14773 14774 begin 14775 -- Nothing to do when switch -gnatd.U (ignore 'Access) is in effect 14776 14777 if Debug_Flag_Dot_UU then 14778 return False; 14779 14780 -- Nothing to do when the scenario is not an attribute reference 14781 14782 elsif Nkind (N) /= N_Attribute_Reference then 14783 return False; 14784 14785 -- Nothing to do for internally-generated attributes because they are 14786 -- assumed to be ABE safe. 14787 14788 elsif not Comes_From_Source (N) then 14789 return False; 14790 end if; 14791 14792 Nam := Attribute_Name (N); 14793 Pref := Prefix (N); 14794 14795 -- Sanitize the prefix of the attribute 14796 14797 if not Is_Entity_Name (Pref) then 14798 return False; 14799 14800 elsif No (Entity (Pref)) then 14801 return False; 14802 end if; 14803 14804 Subp_Id := Entity (Pref); 14805 14806 if not Is_Subprogram_Or_Entry (Subp_Id) then 14807 return False; 14808 end if; 14809 14810 -- Traverse a possible chain of renamings to obtain the original 14811 -- entry or subprogram which the prefix may rename. 14812 14813 Subp_Id := Get_Renamed_Entity (Subp_Id); 14814 14815 -- To qualify, the attribute must meet the following prerequisites: 14816 14817 return 14818 14819 -- The prefix must denote a source entry, operator, or subprogram 14820 -- which is not imported. 14821 14822 Comes_From_Source (Subp_Id) 14823 and then Is_Subprogram_Or_Entry (Subp_Id) 14824 and then not Is_Bodiless_Subprogram (Subp_Id) 14825 14826 -- The attribute name must be one of the 'Access forms. Note that 14827 -- 'Unchecked_Access cannot apply to a subprogram. 14828 14829 and then Nam in Name_Access | Name_Unrestricted_Access; 14830 end Is_Suitable_Access_Taken; 14831 14832 ---------------------- 14833 -- Is_Suitable_Call -- 14834 ---------------------- 14835 14836 function Is_Suitable_Call (N : Node_Id) return Boolean is 14837 begin 14838 -- Entry and subprogram calls are intentionally ignored because they 14839 -- may undergo expansion depending on the compilation mode, previous 14840 -- errors, generic context, etc. Call markers play the role of calls 14841 -- and provide a uniform foundation for ABE processing. 14842 14843 return Nkind (N) = N_Call_Marker; 14844 end Is_Suitable_Call; 14845 14846 ------------------------------- 14847 -- Is_Suitable_Instantiation -- 14848 ------------------------------- 14849 14850 function Is_Suitable_Instantiation (N : Node_Id) return Boolean is 14851 Inst : constant Node_Id := Scenario (N); 14852 14853 begin 14854 -- To qualify, the instantiation must come from source 14855 14856 return 14857 Comes_From_Source (Inst) 14858 and then Nkind (Inst) in N_Generic_Instantiation; 14859 end Is_Suitable_Instantiation; 14860 14861 ------------------------------------ 14862 -- Is_Suitable_SPARK_Derived_Type -- 14863 ------------------------------------ 14864 14865 function Is_Suitable_SPARK_Derived_Type (N : Node_Id) return Boolean is 14866 Prag : Node_Id; 14867 Typ : Entity_Id; 14868 14869 begin 14870 -- To qualify, the type declaration must denote a derived tagged type 14871 -- with primitive operations, subject to pragma SPARK_Mode On. 14872 14873 if Nkind (N) = N_Full_Type_Declaration 14874 and then Nkind (Type_Definition (N)) = N_Derived_Type_Definition 14875 then 14876 Typ := Defining_Entity (N); 14877 Prag := SPARK_Pragma (Typ); 14878 14879 return 14880 Is_Tagged_Type (Typ) 14881 and then Has_Primitive_Operations (Typ) 14882 and then Present (Prag) 14883 and then Get_SPARK_Mode_From_Annotation (Prag) = On; 14884 end if; 14885 14886 return False; 14887 end Is_Suitable_SPARK_Derived_Type; 14888 14889 ------------------------------------- 14890 -- Is_Suitable_SPARK_Instantiation -- 14891 ------------------------------------- 14892 14893 function Is_Suitable_SPARK_Instantiation (N : Node_Id) return Boolean is 14894 Inst : constant Node_Id := Scenario (N); 14895 14896 Gen_Id : Entity_Id; 14897 Prag : Node_Id; 14898 14899 begin 14900 -- To qualify, both the instantiation and the generic must be subject 14901 -- to SPARK_Mode On. 14902 14903 if Is_Suitable_Instantiation (N) then 14904 Gen_Id := Instantiated_Generic (Inst); 14905 Prag := SPARK_Pragma (Gen_Id); 14906 14907 return 14908 Is_SPARK_Mode_On_Node (Inst) 14909 and then Present (Prag) 14910 and then Get_SPARK_Mode_From_Annotation (Prag) = On; 14911 end if; 14912 14913 return False; 14914 end Is_Suitable_SPARK_Instantiation; 14915 14916 -------------------------------------------- 14917 -- Is_Suitable_SPARK_Refined_State_Pragma -- 14918 -------------------------------------------- 14919 14920 function Is_Suitable_SPARK_Refined_State_Pragma 14921 (N : Node_Id) return Boolean 14922 is 14923 begin 14924 -- To qualfy, the pragma must denote Refined_State 14925 14926 return 14927 Nkind (N) = N_Pragma 14928 and then Pragma_Name (N) = Name_Refined_State; 14929 end Is_Suitable_SPARK_Refined_State_Pragma; 14930 14931 ------------------------------------- 14932 -- Is_Suitable_Variable_Assignment -- 14933 ------------------------------------- 14934 14935 function Is_Suitable_Variable_Assignment (N : Node_Id) return Boolean is 14936 N_Unit : Node_Id; 14937 N_Unit_Id : Entity_Id; 14938 Nam : Node_Id; 14939 Var_Decl : Node_Id; 14940 Var_Id : Entity_Id; 14941 Var_Unit : Node_Id; 14942 Var_Unit_Id : Entity_Id; 14943 14944 begin 14945 -- Nothing to do when the scenario is not an assignment 14946 14947 if Nkind (N) /= N_Assignment_Statement then 14948 return False; 14949 14950 -- Nothing to do for internally-generated assignments because they 14951 -- are assumed to be ABE safe. 14952 14953 elsif not Comes_From_Source (N) then 14954 return False; 14955 14956 -- Assignments are ignored in GNAT mode on the assumption that 14957 -- they are ABE-safe. This behavior parallels that of the old 14958 -- ABE mechanism. 14959 14960 elsif GNAT_Mode then 14961 return False; 14962 end if; 14963 14964 Nam := Assignment_Target (N); 14965 14966 -- Sanitize the left hand side of the assignment 14967 14968 if not Is_Entity_Name (Nam) then 14969 return False; 14970 14971 elsif No (Entity (Nam)) then 14972 return False; 14973 end if; 14974 14975 Var_Id := Entity (Nam); 14976 14977 -- Sanitize the variable 14978 14979 if Var_Id = Any_Id then 14980 return False; 14981 14982 elsif Ekind (Var_Id) /= E_Variable then 14983 return False; 14984 end if; 14985 14986 Var_Decl := Declaration_Node (Var_Id); 14987 14988 if Nkind (Var_Decl) /= N_Object_Declaration then 14989 return False; 14990 end if; 14991 14992 N_Unit_Id := Find_Top_Unit (N); 14993 N_Unit := Unit_Declaration_Node (N_Unit_Id); 14994 14995 Var_Unit_Id := Find_Top_Unit (Var_Decl); 14996 Var_Unit := Unit_Declaration_Node (Var_Unit_Id); 14997 14998 -- To qualify, the assignment must meet the following prerequisites: 14999 15000 return 15001 Comes_From_Source (Var_Id) 15002 15003 -- The variable must be declared in the spec of compilation unit 15004 -- U. 15005 15006 and then Nkind (Var_Unit) = N_Package_Declaration 15007 and then Find_Enclosing_Level (Var_Decl) = Library_Spec_Level 15008 15009 -- The assignment must occur in the body of compilation unit U 15010 15011 and then Nkind (N_Unit) = N_Package_Body 15012 and then Present (Corresponding_Body (Var_Unit)) 15013 and then Corresponding_Body (Var_Unit) = N_Unit_Id; 15014 end Is_Suitable_Variable_Assignment; 15015 15016 ------------------------------------ 15017 -- Is_Suitable_Variable_Reference -- 15018 ------------------------------------ 15019 15020 function Is_Suitable_Variable_Reference (N : Node_Id) return Boolean is 15021 begin 15022 -- Expanded names and identifiers are intentionally ignored because 15023 -- they be folded, optimized away, etc. Variable references markers 15024 -- play the role of variable references and provide a uniform 15025 -- foundation for ABE processing. 15026 15027 return Nkind (N) = N_Variable_Reference_Marker; 15028 end Is_Suitable_Variable_Reference; 15029 15030 ------------------- 15031 -- Is_Task_Entry -- 15032 ------------------- 15033 15034 function Is_Task_Entry (Id : Entity_Id) return Boolean is 15035 begin 15036 -- To qualify, the entity must denote an entry defined in a task type 15037 15038 return 15039 Is_Entry (Id) and then Is_Task_Type (Non_Private_View (Scope (Id))); 15040 end Is_Task_Entry; 15041 15042 ------------------------ 15043 -- Is_Up_Level_Target -- 15044 ------------------------ 15045 15046 function Is_Up_Level_Target 15047 (Targ_Decl : Node_Id; 15048 In_State : Processing_In_State) return Boolean 15049 is 15050 Root : constant Node_Id := Root_Scenario; 15051 Root_Rep : constant Scenario_Rep_Id := 15052 Scenario_Representation_Of (Root, In_State); 15053 15054 begin 15055 -- The root appears within the declaratons of a block statement, 15056 -- entry body, subprogram body, or task body ignoring enclosing 15057 -- packages. The root is always within the main unit. 15058 15059 if not In_State.Suppress_Up_Level_Targets 15060 and then Level (Root_Rep) = Declaration_Level 15061 then 15062 -- The target is within the main unit. It acts as an up-level 15063 -- target when it appears within a context which encloses the 15064 -- root. 15065 -- 15066 -- package body Main_Unit is 15067 -- function Func ...; -- target 15068 -- 15069 -- procedure Proc is 15070 -- X : ... := Func; -- root scenario 15071 15072 if In_Extended_Main_Code_Unit (Targ_Decl) then 15073 return not In_Same_Context (Root, Targ_Decl, Nested_OK => True); 15074 15075 -- Otherwise the target is external to the main unit which makes 15076 -- it an up-level target. 15077 15078 else 15079 return True; 15080 end if; 15081 end if; 15082 15083 return False; 15084 end Is_Up_Level_Target; 15085 end Semantics; 15086 15087 --------------------------- 15088 -- Set_Elaboration_Phase -- 15089 --------------------------- 15090 15091 procedure Set_Elaboration_Phase (Status : Elaboration_Phase_Status) is 15092 begin 15093 Elaboration_Phase := Status; 15094 end Set_Elaboration_Phase; 15095 15096 --------------------- 15097 -- SPARK_Processor -- 15098 --------------------- 15099 15100 package body SPARK_Processor is 15101 15102 ----------------------- 15103 -- Local subprograms -- 15104 ----------------------- 15105 15106 procedure Process_SPARK_Derived_Type 15107 (Typ_Decl : Node_Id; 15108 Typ_Rep : Scenario_Rep_Id; 15109 In_State : Processing_In_State); 15110 pragma Inline (Process_SPARK_Derived_Type); 15111 -- Verify that the freeze node of a derived type denoted by declaration 15112 -- Typ_Decl is within the early call region of each overriding primitive 15113 -- body that belongs to the derived type (SPARK RM 7.7(8)). Typ_Rep is 15114 -- the representation of the type. In_State denotes the current state of 15115 -- the Processing phase. 15116 15117 procedure Process_SPARK_Instantiation 15118 (Inst : Node_Id; 15119 Inst_Rep : Scenario_Rep_Id; 15120 In_State : Processing_In_State); 15121 pragma Inline (Process_SPARK_Instantiation); 15122 -- Verify that instantiation Inst does not precede the generic body it 15123 -- instantiates (SPARK RM 7.7(6)). Inst_Rep is the representation of the 15124 -- instantiation. In_State is the current state of the Processing phase. 15125 15126 procedure Process_SPARK_Refined_State_Pragma 15127 (Prag : Node_Id; 15128 Prag_Rep : Scenario_Rep_Id; 15129 In_State : Processing_In_State); 15130 pragma Inline (Process_SPARK_Refined_State_Pragma); 15131 -- Verify that each constituent of Refined_State pragma Prag which 15132 -- belongs to abstract state mentioned in pragma Initializes has prior 15133 -- elaboration with respect to the main unit (SPARK RM 7.7.1(7)). 15134 -- Prag_Rep is the representation of the pragma. In_State denotes the 15135 -- current state of the Processing phase. 15136 15137 procedure Process_SPARK_Scenario 15138 (N : Node_Id; 15139 In_State : Processing_In_State); 15140 pragma Inline (Process_SPARK_Scenario); 15141 -- Top-level dispatcher for verifying SPARK scenarios which are not 15142 -- always executable during elaboration but still need elaboration- 15143 -- related checks. In_State is the current state of the Processing 15144 -- phase. 15145 15146 --------------------------------- 15147 -- Check_SPARK_Model_In_Effect -- 15148 --------------------------------- 15149 15150 SPARK_Model_Warning_Posted : Boolean := False; 15151 -- This flag prevents the same SPARK model-related warning from being 15152 -- emitted multiple times. 15153 15154 procedure Check_SPARK_Model_In_Effect is 15155 Spec_Id : constant Entity_Id := Unique_Entity (Main_Unit_Entity); 15156 15157 begin 15158 -- Do not emit the warning multiple times as this creates useless 15159 -- noise. 15160 15161 if SPARK_Model_Warning_Posted then 15162 null; 15163 15164 -- SPARK rule verification requires the "strict" static model 15165 15166 elsif Static_Elaboration_Checks 15167 and not Relaxed_Elaboration_Checks 15168 then 15169 null; 15170 15171 -- Any other combination of models does not guarantee the absence of 15172 -- ABE problems for SPARK rule verification purposes. Note that there 15173 -- is no need to check for the presence of the legacy ABE mechanism 15174 -- because the legacy code has its own dedicated processing for SPARK 15175 -- rules. 15176 15177 else 15178 SPARK_Model_Warning_Posted := True; 15179 15180 Error_Msg_N 15181 ("??SPARK elaboration checks require static elaboration model", 15182 Spec_Id); 15183 15184 if Dynamic_Elaboration_Checks then 15185 Error_Msg_N 15186 ("\dynamic elaboration model is in effect", Spec_Id); 15187 15188 else 15189 pragma Assert (Relaxed_Elaboration_Checks); 15190 Error_Msg_N 15191 ("\relaxed elaboration model is in effect", Spec_Id); 15192 end if; 15193 end if; 15194 end Check_SPARK_Model_In_Effect; 15195 15196 --------------------------- 15197 -- Check_SPARK_Scenarios -- 15198 --------------------------- 15199 15200 procedure Check_SPARK_Scenarios is 15201 Iter : NE_Set.Iterator; 15202 N : Node_Id; 15203 15204 begin 15205 Iter := Iterate_SPARK_Scenarios; 15206 while NE_Set.Has_Next (Iter) loop 15207 NE_Set.Next (Iter, N); 15208 15209 Process_SPARK_Scenario 15210 (N => N, 15211 In_State => SPARK_State); 15212 end loop; 15213 end Check_SPARK_Scenarios; 15214 15215 -------------------------------- 15216 -- Process_SPARK_Derived_Type -- 15217 -------------------------------- 15218 15219 procedure Process_SPARK_Derived_Type 15220 (Typ_Decl : Node_Id; 15221 Typ_Rep : Scenario_Rep_Id; 15222 In_State : Processing_In_State) 15223 is 15224 pragma Unreferenced (In_State); 15225 15226 Typ : constant Entity_Id := Target (Typ_Rep); 15227 15228 Stop_Check : exception; 15229 -- This exception is raised when the freeze node violates the 15230 -- placement rules. 15231 15232 procedure Check_Overriding_Primitive 15233 (Prim : Entity_Id; 15234 FNode : Node_Id); 15235 pragma Inline (Check_Overriding_Primitive); 15236 -- Verify that freeze node FNode is within the early call region of 15237 -- overriding primitive Prim's body. 15238 15239 function Freeze_Node_Location (FNode : Node_Id) return Source_Ptr; 15240 pragma Inline (Freeze_Node_Location); 15241 -- Return a more accurate source location associated with freeze node 15242 -- FNode. 15243 15244 function Precedes_Source_Construct (N : Node_Id) return Boolean; 15245 pragma Inline (Precedes_Source_Construct); 15246 -- Determine whether arbitrary node N appears prior to some source 15247 -- construct. 15248 15249 procedure Suggest_Elaborate_Body 15250 (N : Node_Id; 15251 Body_Decl : Node_Id; 15252 Error_Nod : Node_Id); 15253 pragma Inline (Suggest_Elaborate_Body); 15254 -- Suggest the use of pragma Elaborate_Body when the pragma will 15255 -- allow for node N to appear within the early call region of 15256 -- subprogram body Body_Decl. The suggestion is attached to 15257 -- Error_Nod as a continuation error. 15258 15259 -------------------------------- 15260 -- Check_Overriding_Primitive -- 15261 -------------------------------- 15262 15263 procedure Check_Overriding_Primitive 15264 (Prim : Entity_Id; 15265 FNode : Node_Id) 15266 is 15267 Prim_Decl : constant Node_Id := Unit_Declaration_Node (Prim); 15268 Body_Decl : Node_Id; 15269 Body_Id : Entity_Id; 15270 Region : Node_Id; 15271 15272 begin 15273 -- Nothing to do for predefined primitives because they are 15274 -- artifacts of tagged type expansion and cannot override source 15275 -- primitives. Nothing to do as well for inherited primitives, as 15276 -- the check concerns overriding ones. 15277 15278 if Is_Predefined_Dispatching_Operation (Prim) 15279 or else not Is_Overriding_Subprogram (Prim) 15280 then 15281 return; 15282 end if; 15283 15284 Body_Id := Corresponding_Body (Prim_Decl); 15285 15286 -- Nothing to do when the primitive does not have a corresponding 15287 -- body. This can happen when the unit with the bodies is not the 15288 -- main unit subjected to ABE checks. 15289 15290 if No (Body_Id) then 15291 return; 15292 15293 -- The primitive overrides a parent or progenitor primitive 15294 15295 elsif Present (Overridden_Operation (Prim)) then 15296 15297 -- Nothing to do when overriding an interface primitive happens 15298 -- by inheriting a non-interface primitive as the check would 15299 -- be done on the parent primitive. 15300 15301 if Present (Alias (Prim)) then 15302 return; 15303 end if; 15304 15305 -- Nothing to do when the primitive is not overriding. The body of 15306 -- such a primitive cannot be targeted by a dispatching call which 15307 -- is executable during elaboration, and cannot cause an ABE. 15308 15309 else 15310 return; 15311 end if; 15312 15313 Body_Decl := Unit_Declaration_Node (Body_Id); 15314 Region := Find_Early_Call_Region (Body_Decl); 15315 15316 -- The freeze node appears prior to the early call region of the 15317 -- primitive body. 15318 15319 -- IMPORTANT: This check must always be performed even when 15320 -- -gnatd.v (enforce SPARK elaboration rules in SPARK code) is not 15321 -- specified because the static model cannot guarantee the absence 15322 -- of ABEs in the presence of dispatching calls. 15323 15324 if Earlier_In_Extended_Unit (FNode, Region) then 15325 Error_Msg_Node_2 := Prim; 15326 Error_Msg_NE 15327 ("first freezing point of type & must appear within early " 15328 & "call region of primitive body & (SPARK RM 7.7(8))", 15329 Typ_Decl, Typ); 15330 15331 Error_Msg_Sloc := Sloc (Region); 15332 Error_Msg_N ("\region starts #", Typ_Decl); 15333 15334 Error_Msg_Sloc := Sloc (Body_Decl); 15335 Error_Msg_N ("\region ends #", Typ_Decl); 15336 15337 Error_Msg_Sloc := Freeze_Node_Location (FNode); 15338 Error_Msg_N ("\first freezing point #", Typ_Decl); 15339 15340 -- If applicable, suggest the use of pragma Elaborate_Body in 15341 -- the associated package spec. 15342 15343 Suggest_Elaborate_Body 15344 (N => FNode, 15345 Body_Decl => Body_Decl, 15346 Error_Nod => Typ_Decl); 15347 15348 raise Stop_Check; 15349 end if; 15350 end Check_Overriding_Primitive; 15351 15352 -------------------------- 15353 -- Freeze_Node_Location -- 15354 -------------------------- 15355 15356 function Freeze_Node_Location (FNode : Node_Id) return Source_Ptr is 15357 Context : constant Node_Id := Parent (FNode); 15358 Loc : constant Source_Ptr := Sloc (FNode); 15359 15360 Prv_Decls : List_Id; 15361 Vis_Decls : List_Id; 15362 15363 begin 15364 -- In general, the source location of the freeze node is as close 15365 -- as possible to the real freeze point, except when the freeze 15366 -- node is at the "bottom" of a package spec. 15367 15368 if Nkind (Context) = N_Package_Specification then 15369 Prv_Decls := Private_Declarations (Context); 15370 Vis_Decls := Visible_Declarations (Context); 15371 15372 -- The freeze node appears in the private declarations of the 15373 -- package. 15374 15375 if Present (Prv_Decls) 15376 and then List_Containing (FNode) = Prv_Decls 15377 then 15378 null; 15379 15380 -- The freeze node appears in the visible declarations of the 15381 -- package and there are no private declarations. 15382 15383 elsif Present (Vis_Decls) 15384 and then List_Containing (FNode) = Vis_Decls 15385 and then (No (Prv_Decls) or else Is_Empty_List (Prv_Decls)) 15386 then 15387 null; 15388 15389 -- Otherwise the freeze node is not in the "last" declarative 15390 -- list of the package. Use the existing source location of the 15391 -- freeze node. 15392 15393 else 15394 return Loc; 15395 end if; 15396 15397 -- The freeze node appears at the "bottom" of the package when 15398 -- it is in the "last" declarative list and is either the last 15399 -- in the list or is followed by internal constructs only. In 15400 -- that case the more appropriate source location is that of 15401 -- the package end label. 15402 15403 if not Precedes_Source_Construct (FNode) then 15404 return Sloc (End_Label (Context)); 15405 end if; 15406 end if; 15407 15408 return Loc; 15409 end Freeze_Node_Location; 15410 15411 ------------------------------- 15412 -- Precedes_Source_Construct -- 15413 ------------------------------- 15414 15415 function Precedes_Source_Construct (N : Node_Id) return Boolean is 15416 Decl : Node_Id; 15417 15418 begin 15419 Decl := Next (N); 15420 while Present (Decl) loop 15421 if Comes_From_Source (Decl) then 15422 return True; 15423 15424 -- A generated body for a source expression function is treated 15425 -- as a source construct. 15426 15427 elsif Nkind (Decl) = N_Subprogram_Body 15428 and then Was_Expression_Function (Decl) 15429 and then Comes_From_Source (Original_Node (Decl)) 15430 then 15431 return True; 15432 end if; 15433 15434 Next (Decl); 15435 end loop; 15436 15437 return False; 15438 end Precedes_Source_Construct; 15439 15440 ---------------------------- 15441 -- Suggest_Elaborate_Body -- 15442 ---------------------------- 15443 15444 procedure Suggest_Elaborate_Body 15445 (N : Node_Id; 15446 Body_Decl : Node_Id; 15447 Error_Nod : Node_Id) 15448 is 15449 Unit_Id : constant Node_Id := Unit (Cunit (Main_Unit)); 15450 Region : Node_Id; 15451 15452 begin 15453 -- The suggestion applies only when the subprogram body resides in 15454 -- a compilation package body, and a pragma Elaborate_Body would 15455 -- allow for the node to appear in the early call region of the 15456 -- subprogram body. This implies that all code from the subprogram 15457 -- body up to the node is preelaborable. 15458 15459 if Nkind (Unit_Id) = N_Package_Body then 15460 15461 -- Find the start of the early call region again assuming that 15462 -- the package spec has pragma Elaborate_Body. Note that the 15463 -- internal data structures are intentionally not updated 15464 -- because this is a speculative search. 15465 15466 Region := 15467 Find_Early_Call_Region 15468 (Body_Decl => Body_Decl, 15469 Assume_Elab_Body => True, 15470 Skip_Memoization => True); 15471 15472 -- If the node appears within the early call region, assuming 15473 -- that the package spec carries pragma Elaborate_Body, then it 15474 -- is safe to suggest the pragma. 15475 15476 if Earlier_In_Extended_Unit (Region, N) then 15477 Error_Msg_Name_1 := Name_Elaborate_Body; 15478 Error_Msg_NE 15479 ("\consider adding pragma % in spec of unit &", 15480 Error_Nod, Defining_Entity (Unit_Id)); 15481 end if; 15482 end if; 15483 end Suggest_Elaborate_Body; 15484 15485 -- Local variables 15486 15487 FNode : constant Node_Id := Freeze_Node (Typ); 15488 Prims : constant Elist_Id := Direct_Primitive_Operations (Typ); 15489 15490 Prim_Elmt : Elmt_Id; 15491 15492 -- Start of processing for Process_SPARK_Derived_Type 15493 15494 begin 15495 -- A type should have its freeze node set by the time SPARK scenarios 15496 -- are being verified. 15497 15498 pragma Assert (Present (FNode)); 15499 15500 -- Verify that the freeze node of the derived type is within the 15501 -- early call region of each overriding primitive body 15502 -- (SPARK RM 7.7(8)). 15503 15504 if Present (Prims) then 15505 Prim_Elmt := First_Elmt (Prims); 15506 while Present (Prim_Elmt) loop 15507 Check_Overriding_Primitive 15508 (Prim => Node (Prim_Elmt), 15509 FNode => FNode); 15510 15511 Next_Elmt (Prim_Elmt); 15512 end loop; 15513 end if; 15514 15515 exception 15516 when Stop_Check => 15517 null; 15518 end Process_SPARK_Derived_Type; 15519 15520 --------------------------------- 15521 -- Process_SPARK_Instantiation -- 15522 --------------------------------- 15523 15524 procedure Process_SPARK_Instantiation 15525 (Inst : Node_Id; 15526 Inst_Rep : Scenario_Rep_Id; 15527 In_State : Processing_In_State) 15528 is 15529 Gen_Id : constant Entity_Id := Target (Inst_Rep); 15530 Gen_Rep : constant Target_Rep_Id := 15531 Target_Representation_Of (Gen_Id, In_State); 15532 Body_Decl : constant Node_Id := Body_Declaration (Gen_Rep); 15533 15534 begin 15535 -- The instantiation and the generic body are both in the main unit 15536 15537 if Present (Body_Decl) 15538 and then In_Extended_Main_Code_Unit (Body_Decl) 15539 15540 -- If the instantiation appears prior to the generic body, then the 15541 -- instantiation is illegal (SPARK RM 7.7(6)). 15542 15543 -- IMPORTANT: This check must always be performed even when 15544 -- -gnatd.v (enforce SPARK elaboration rules in SPARK code) is not 15545 -- specified because the rule prevents use-before-declaration of 15546 -- objects that may precede the generic body. 15547 15548 and then Earlier_In_Extended_Unit (Inst, Body_Decl) 15549 then 15550 Error_Msg_NE 15551 ("cannot instantiate & before body seen", Inst, Gen_Id); 15552 end if; 15553 end Process_SPARK_Instantiation; 15554 15555 ---------------------------- 15556 -- Process_SPARK_Scenario -- 15557 ---------------------------- 15558 15559 procedure Process_SPARK_Scenario 15560 (N : Node_Id; 15561 In_State : Processing_In_State) 15562 is 15563 Scen : constant Node_Id := Scenario (N); 15564 15565 begin 15566 -- Ensure that a suitable elaboration model is in effect for SPARK 15567 -- rule verification. 15568 15569 Check_SPARK_Model_In_Effect; 15570 15571 -- Add the current scenario to the stack of active scenarios 15572 15573 Push_Active_Scenario (Scen); 15574 15575 -- Derived type 15576 15577 if Is_Suitable_SPARK_Derived_Type (Scen) then 15578 Process_SPARK_Derived_Type 15579 (Typ_Decl => Scen, 15580 Typ_Rep => Scenario_Representation_Of (Scen, In_State), 15581 In_State => In_State); 15582 15583 -- Instantiation 15584 15585 elsif Is_Suitable_SPARK_Instantiation (Scen) then 15586 Process_SPARK_Instantiation 15587 (Inst => Scen, 15588 Inst_Rep => Scenario_Representation_Of (Scen, In_State), 15589 In_State => In_State); 15590 15591 -- Refined_State pragma 15592 15593 elsif Is_Suitable_SPARK_Refined_State_Pragma (Scen) then 15594 Process_SPARK_Refined_State_Pragma 15595 (Prag => Scen, 15596 Prag_Rep => Scenario_Representation_Of (Scen, In_State), 15597 In_State => In_State); 15598 end if; 15599 15600 -- Remove the current scenario from the stack of active scenarios 15601 -- once all ABE diagnostics and checks have been performed. 15602 15603 Pop_Active_Scenario (Scen); 15604 end Process_SPARK_Scenario; 15605 15606 ---------------------------------------- 15607 -- Process_SPARK_Refined_State_Pragma -- 15608 ---------------------------------------- 15609 15610 procedure Process_SPARK_Refined_State_Pragma 15611 (Prag : Node_Id; 15612 Prag_Rep : Scenario_Rep_Id; 15613 In_State : Processing_In_State) 15614 is 15615 pragma Unreferenced (Prag_Rep); 15616 15617 procedure Check_SPARK_Constituent (Constit_Id : Entity_Id); 15618 pragma Inline (Check_SPARK_Constituent); 15619 -- Ensure that a single constituent Constit_Id is elaborated prior to 15620 -- the main unit. 15621 15622 procedure Check_SPARK_Constituents (Constits : Elist_Id); 15623 pragma Inline (Check_SPARK_Constituents); 15624 -- Ensure that all constituents found in list Constits are elaborated 15625 -- prior to the main unit. 15626 15627 procedure Check_SPARK_Initialized_State (State : Node_Id); 15628 pragma Inline (Check_SPARK_Initialized_State); 15629 -- Ensure that the constituents of single abstract state State are 15630 -- elaborated prior to the main unit. 15631 15632 procedure Check_SPARK_Initialized_States (Pack_Id : Entity_Id); 15633 pragma Inline (Check_SPARK_Initialized_States); 15634 -- Ensure that the constituents of all abstract states which appear 15635 -- in the Initializes pragma of package Pack_Id are elaborated prior 15636 -- to the main unit. 15637 15638 ----------------------------- 15639 -- Check_SPARK_Constituent -- 15640 ----------------------------- 15641 15642 procedure Check_SPARK_Constituent (Constit_Id : Entity_Id) is 15643 SM_Prag : Node_Id; 15644 15645 begin 15646 -- Nothing to do for "null" constituents 15647 15648 if Nkind (Constit_Id) = N_Null then 15649 return; 15650 15651 -- Nothing to do for illegal constituents 15652 15653 elsif Error_Posted (Constit_Id) then 15654 return; 15655 end if; 15656 15657 SM_Prag := SPARK_Pragma (Constit_Id); 15658 15659 -- The check applies only when the constituent is subject to 15660 -- pragma SPARK_Mode On. 15661 15662 if Present (SM_Prag) 15663 and then Get_SPARK_Mode_From_Annotation (SM_Prag) = On 15664 then 15665 -- An external constituent of an abstract state which appears 15666 -- in the Initializes pragma of a package spec imposes an 15667 -- Elaborate requirement on the context of the main unit. 15668 -- Determine whether the context has a pragma strong enough to 15669 -- meet the requirement. 15670 15671 -- IMPORTANT: This check is performed only when -gnatd.v 15672 -- (enforce SPARK elaboration rules in SPARK code) is in effect 15673 -- because the static model can ensure the prior elaboration of 15674 -- the unit which contains a constituent by installing implicit 15675 -- Elaborate pragma. 15676 15677 if Debug_Flag_Dot_V then 15678 Meet_Elaboration_Requirement 15679 (N => Prag, 15680 Targ_Id => Constit_Id, 15681 Req_Nam => Name_Elaborate, 15682 In_State => In_State); 15683 15684 -- Otherwise ensure that the unit with the external constituent 15685 -- is elaborated prior to the main unit. 15686 15687 else 15688 Ensure_Prior_Elaboration 15689 (N => Prag, 15690 Unit_Id => Find_Top_Unit (Constit_Id), 15691 Prag_Nam => Name_Elaborate, 15692 In_State => In_State); 15693 end if; 15694 end if; 15695 end Check_SPARK_Constituent; 15696 15697 ------------------------------ 15698 -- Check_SPARK_Constituents -- 15699 ------------------------------ 15700 15701 procedure Check_SPARK_Constituents (Constits : Elist_Id) is 15702 Constit_Elmt : Elmt_Id; 15703 15704 begin 15705 if Present (Constits) then 15706 Constit_Elmt := First_Elmt (Constits); 15707 while Present (Constit_Elmt) loop 15708 Check_SPARK_Constituent (Node (Constit_Elmt)); 15709 Next_Elmt (Constit_Elmt); 15710 end loop; 15711 end if; 15712 end Check_SPARK_Constituents; 15713 15714 ----------------------------------- 15715 -- Check_SPARK_Initialized_State -- 15716 ----------------------------------- 15717 15718 procedure Check_SPARK_Initialized_State (State : Node_Id) is 15719 SM_Prag : Node_Id; 15720 State_Id : Entity_Id; 15721 15722 begin 15723 -- Nothing to do for "null" initialization items 15724 15725 if Nkind (State) = N_Null then 15726 return; 15727 15728 -- Nothing to do for illegal states 15729 15730 elsif Error_Posted (State) then 15731 return; 15732 end if; 15733 15734 State_Id := Entity_Of (State); 15735 15736 -- Sanitize the state 15737 15738 if No (State_Id) then 15739 return; 15740 15741 elsif Error_Posted (State_Id) then 15742 return; 15743 15744 elsif Ekind (State_Id) /= E_Abstract_State then 15745 return; 15746 end if; 15747 15748 -- The check is performed only when the abstract state is subject 15749 -- to SPARK_Mode On. 15750 15751 SM_Prag := SPARK_Pragma (State_Id); 15752 15753 if Present (SM_Prag) 15754 and then Get_SPARK_Mode_From_Annotation (SM_Prag) = On 15755 then 15756 Check_SPARK_Constituents (Refinement_Constituents (State_Id)); 15757 end if; 15758 end Check_SPARK_Initialized_State; 15759 15760 ------------------------------------ 15761 -- Check_SPARK_Initialized_States -- 15762 ------------------------------------ 15763 15764 procedure Check_SPARK_Initialized_States (Pack_Id : Entity_Id) is 15765 Init_Prag : constant Node_Id := 15766 Get_Pragma (Pack_Id, Pragma_Initializes); 15767 15768 Init : Node_Id; 15769 Inits : Node_Id; 15770 15771 begin 15772 if Present (Init_Prag) then 15773 Inits := Expression (Get_Argument (Init_Prag, Pack_Id)); 15774 15775 -- Avoid processing a "null" initialization list. The only 15776 -- other alternative is an aggregate. 15777 15778 if Nkind (Inits) = N_Aggregate then 15779 15780 -- The initialization items appear in list form: 15781 -- 15782 -- (state1, state2) 15783 15784 if Present (Expressions (Inits)) then 15785 Init := First (Expressions (Inits)); 15786 while Present (Init) loop 15787 Check_SPARK_Initialized_State (Init); 15788 Next (Init); 15789 end loop; 15790 end if; 15791 15792 -- The initialization items appear in associated form: 15793 -- 15794 -- (state1 => item1, 15795 -- state2 => (item2, item3)) 15796 15797 if Present (Component_Associations (Inits)) then 15798 Init := First (Component_Associations (Inits)); 15799 while Present (Init) loop 15800 Check_SPARK_Initialized_State (Init); 15801 Next (Init); 15802 end loop; 15803 end if; 15804 end if; 15805 end if; 15806 end Check_SPARK_Initialized_States; 15807 15808 -- Local variables 15809 15810 Pack_Body : constant Node_Id := Find_Related_Package_Or_Body (Prag); 15811 15812 -- Start of processing for Process_SPARK_Refined_State_Pragma 15813 15814 begin 15815 -- Pragma Refined_State must be associated with a package body 15816 15817 pragma Assert 15818 (Present (Pack_Body) and then Nkind (Pack_Body) = N_Package_Body); 15819 15820 -- Verify that each external contitunent of an abstract state 15821 -- mentioned in pragma Initializes is properly elaborated. 15822 15823 Check_SPARK_Initialized_States (Unique_Defining_Entity (Pack_Body)); 15824 end Process_SPARK_Refined_State_Pragma; 15825 end SPARK_Processor; 15826 15827 ------------------------------- 15828 -- Spec_And_Body_From_Entity -- 15829 ------------------------------- 15830 15831 procedure Spec_And_Body_From_Entity 15832 (Id : Entity_Id; 15833 Spec_Decl : out Node_Id; 15834 Body_Decl : out Node_Id) 15835 is 15836 begin 15837 Spec_And_Body_From_Node 15838 (N => Unit_Declaration_Node (Id), 15839 Spec_Decl => Spec_Decl, 15840 Body_Decl => Body_Decl); 15841 end Spec_And_Body_From_Entity; 15842 15843 ----------------------------- 15844 -- Spec_And_Body_From_Node -- 15845 ----------------------------- 15846 15847 procedure Spec_And_Body_From_Node 15848 (N : Node_Id; 15849 Spec_Decl : out Node_Id; 15850 Body_Decl : out Node_Id) 15851 is 15852 Body_Id : Entity_Id; 15853 Spec_Id : Entity_Id; 15854 15855 begin 15856 -- Assume that the construct lacks spec and body 15857 15858 Body_Decl := Empty; 15859 Spec_Decl := Empty; 15860 15861 -- Bodies 15862 15863 if Nkind (N) in N_Package_Body 15864 | N_Protected_Body 15865 | N_Subprogram_Body 15866 | N_Task_Body 15867 then 15868 Spec_Id := Corresponding_Spec (N); 15869 15870 -- The body completes a previous declaration 15871 15872 if Present (Spec_Id) then 15873 Spec_Decl := Unit_Declaration_Node (Spec_Id); 15874 15875 -- Otherwise the body acts as the initial declaration, and is both a 15876 -- spec and body. There is no need to look for an optional body. 15877 15878 else 15879 Body_Decl := N; 15880 Spec_Decl := N; 15881 return; 15882 end if; 15883 15884 -- Declarations 15885 15886 elsif Nkind (N) in N_Entry_Declaration 15887 | N_Generic_Package_Declaration 15888 | N_Generic_Subprogram_Declaration 15889 | N_Package_Declaration 15890 | N_Protected_Type_Declaration 15891 | N_Subprogram_Declaration 15892 | N_Task_Type_Declaration 15893 then 15894 Spec_Decl := N; 15895 15896 -- Expression function 15897 15898 elsif Nkind (N) = N_Expression_Function then 15899 Spec_Id := Corresponding_Spec (N); 15900 pragma Assert (Present (Spec_Id)); 15901 15902 Spec_Decl := Unit_Declaration_Node (Spec_Id); 15903 15904 -- Instantiations 15905 15906 elsif Nkind (N) in N_Generic_Instantiation then 15907 Spec_Decl := Instance_Spec (N); 15908 pragma Assert (Present (Spec_Decl)); 15909 15910 -- Stubs 15911 15912 elsif Nkind (N) in N_Body_Stub then 15913 Spec_Id := Corresponding_Spec_Of_Stub (N); 15914 15915 -- The stub completes a previous declaration 15916 15917 if Present (Spec_Id) then 15918 Spec_Decl := Unit_Declaration_Node (Spec_Id); 15919 15920 -- Otherwise the stub acts as a spec 15921 15922 else 15923 Spec_Decl := N; 15924 end if; 15925 end if; 15926 15927 -- Obtain an optional or mandatory body 15928 15929 if Present (Spec_Decl) then 15930 Body_Id := Corresponding_Body (Spec_Decl); 15931 15932 if Present (Body_Id) then 15933 Body_Decl := Unit_Declaration_Node (Body_Id); 15934 end if; 15935 end if; 15936 end Spec_And_Body_From_Node; 15937 15938 ------------------------------- 15939 -- Static_Elaboration_Checks -- 15940 ------------------------------- 15941 15942 function Static_Elaboration_Checks return Boolean is 15943 begin 15944 return not Dynamic_Elaboration_Checks; 15945 end Static_Elaboration_Checks; 15946 15947 ----------------- 15948 -- Unit_Entity -- 15949 ----------------- 15950 15951 function Unit_Entity (Unit_Id : Entity_Id) return Entity_Id is 15952 function Is_Subunit (Id : Entity_Id) return Boolean; 15953 pragma Inline (Is_Subunit); 15954 -- Determine whether the entity of an initial declaration denotes a 15955 -- subunit. 15956 15957 ---------------- 15958 -- Is_Subunit -- 15959 ---------------- 15960 15961 function Is_Subunit (Id : Entity_Id) return Boolean is 15962 Decl : constant Node_Id := Unit_Declaration_Node (Id); 15963 15964 begin 15965 return 15966 Nkind (Decl) in N_Generic_Package_Declaration 15967 | N_Generic_Subprogram_Declaration 15968 | N_Package_Declaration 15969 | N_Protected_Type_Declaration 15970 | N_Subprogram_Declaration 15971 | N_Task_Type_Declaration 15972 and then Present (Corresponding_Body (Decl)) 15973 and then Nkind (Parent (Unit_Declaration_Node 15974 (Corresponding_Body (Decl)))) = N_Subunit; 15975 end Is_Subunit; 15976 15977 -- Local variables 15978 15979 Id : Entity_Id; 15980 15981 -- Start of processing for Unit_Entity 15982 15983 begin 15984 Id := Unique_Entity (Unit_Id); 15985 15986 -- Skip all subunits found in the scope chain which ends at the input 15987 -- unit. 15988 15989 while Is_Subunit (Id) loop 15990 Id := Scope (Id); 15991 end loop; 15992 15993 return Id; 15994 end Unit_Entity; 15995 15996 --------------------------------- 15997 -- Update_Elaboration_Scenario -- 15998 --------------------------------- 15999 16000 procedure Update_Elaboration_Scenario (New_N : Node_Id; Old_N : Node_Id) is 16001 begin 16002 -- Nothing to do when the elaboration phase of the compiler is not 16003 -- active. 16004 16005 if not Elaboration_Phase_Active then 16006 return; 16007 16008 -- Nothing to do when the old and new scenarios are one and the same 16009 16010 elsif Old_N = New_N then 16011 return; 16012 end if; 16013 16014 -- A scenario is being transformed by Atree.Rewrite. Update all relevant 16015 -- internal data structures to reflect this change. This ensures that a 16016 -- potential run-time conditional ABE check or a guaranteed ABE failure 16017 -- is inserted at the proper place in the tree. 16018 16019 if Is_Scenario (Old_N) then 16020 Replace_Scenario (Old_N, New_N); 16021 end if; 16022 end Update_Elaboration_Scenario; 16023 16024 --------------------------------------------------------------------------- 16025 -- -- 16026 -- 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 -- 16027 -- -- 16028 -- M E C H A N I S M -- 16029 -- -- 16030 --------------------------------------------------------------------------- 16031 16032 -- This section contains the implementation of the pre-18.x legacy ABE 16033 -- mechanism. The mechanism can be activated using switch -gnatH (legacy 16034 -- elaboration checking mode enabled). 16035 16036 ----------------------------- 16037 -- Description of Approach -- 16038 ----------------------------- 16039 16040 -- Every non-static call that is encountered by Sem_Res results in a call 16041 -- to Check_Elab_Call, with N being the call node, and Outer set to its 16042 -- default value of True. In addition X'Access is treated like a call 16043 -- for the access-to-procedure case, and in SPARK mode only we also 16044 -- check variable references. 16045 16046 -- The goal of Check_Elab_Call is to determine whether or not the reference 16047 -- in question can generate an access before elaboration error (raising 16048 -- Program_Error) either by directly calling a subprogram whose body 16049 -- has not yet been elaborated, or indirectly, by calling a subprogram 16050 -- whose body has been elaborated, but which contains a call to such a 16051 -- subprogram. 16052 16053 -- In addition, in SPARK mode, we are checking for a variable reference in 16054 -- another package, which requires an explicit Elaborate_All pragma. 16055 16056 -- The only references that we need to look at the outer level are 16057 -- references that occur in elaboration code. There are two cases. The 16058 -- reference can be at the outer level of elaboration code, or it can 16059 -- be within another unit, e.g. the elaboration code of a subprogram. 16060 16061 -- In the case of an elaboration call at the outer level, we must trace 16062 -- all calls to outer level routines either within the current unit or to 16063 -- other units that are with'ed. For calls within the current unit, we can 16064 -- determine if the body has been elaborated or not, and if it has not, 16065 -- then a warning is generated. 16066 16067 -- Note that there are two subcases. If the original call directly calls a 16068 -- subprogram whose body has not been elaborated, then we know that an ABE 16069 -- will take place, and we replace the call by a raise of Program_Error. 16070 -- If the call is indirect, then we don't know that the PE will be raised, 16071 -- since the call might be guarded by a conditional. In this case we set 16072 -- Do_Elab_Check on the call so that a dynamic check is generated, and 16073 -- output a warning. 16074 16075 -- For calls to a subprogram in a with'ed unit or a 'Access or variable 16076 -- reference (SPARK mode case), we require that a pragma Elaborate_All 16077 -- or pragma Elaborate be present, or that the referenced unit have a 16078 -- pragma Preelaborate, pragma Pure, or pragma Elaborate_Body. If none 16079 -- of these conditions is met, then a warning is generated that a pragma 16080 -- Elaborate_All may be needed (error in the SPARK case), or an implicit 16081 -- pragma is generated. 16082 16083 -- For the case of an elaboration call at some inner level, we are 16084 -- interested in tracing only calls to subprograms at the same level, i.e. 16085 -- those that can be called during elaboration. Any calls to outer level 16086 -- routines cannot cause ABE's as a result of the original call (there 16087 -- might be an outer level call to the subprogram from outside that causes 16088 -- the ABE, but that gets analyzed separately). 16089 16090 -- Note that we never trace calls to inner level subprograms, since these 16091 -- cannot result in ABE's unless there is an elaboration problem at a lower 16092 -- level, which will be separately detected. 16093 16094 -- Note on pragma Elaborate. The checking here assumes that a pragma 16095 -- Elaborate on a with'ed unit guarantees that subprograms within the unit 16096 -- can be called without causing an ABE. This is not in fact the case since 16097 -- pragma Elaborate does not guarantee the transitive coverage guaranteed 16098 -- by Elaborate_All. However, we decide to trust the user in this case. 16099 16100 -------------------------------------- 16101 -- Instantiation Elaboration Errors -- 16102 -------------------------------------- 16103 16104 -- A special case arises when an instantiation appears in a context that is 16105 -- known to be before the body is elaborated, e.g. 16106 16107 -- generic package x is ... 16108 -- ... 16109 -- package xx is new x; 16110 -- ... 16111 -- package body x is ... 16112 16113 -- In this situation it is certain that an elaboration error will occur, 16114 -- and an unconditional raise Program_Error statement is inserted before 16115 -- the instantiation, and a warning generated. 16116 16117 -- The problem is that in this case we have no place to put the body of 16118 -- the instantiation. We can't put it in the normal place, because it is 16119 -- too early, and will cause errors to occur as a result of referencing 16120 -- entities before they are declared. 16121 16122 -- Our approach in this case is simply to avoid creating the body of the 16123 -- instantiation in such a case. The instantiation spec is modified to 16124 -- include dummy bodies for all subprograms, so that the resulting code 16125 -- does not contain subprogram specs with no corresponding bodies. 16126 16127 -- The following table records the recursive call chain for output in the 16128 -- Output routine. Each entry records the call node and the entity of the 16129 -- called routine. The number of entries in the table (i.e. the value of 16130 -- Elab_Call.Last) indicates the current depth of recursion and is used to 16131 -- identify the outer level. 16132 16133 type Elab_Call_Element is record 16134 Cloc : Source_Ptr; 16135 Ent : Entity_Id; 16136 end record; 16137 16138 package Elab_Call is new Table.Table 16139 (Table_Component_Type => Elab_Call_Element, 16140 Table_Index_Type => Int, 16141 Table_Low_Bound => 1, 16142 Table_Initial => 50, 16143 Table_Increment => 100, 16144 Table_Name => "Elab_Call"); 16145 16146 -- The following table records all calls that have been processed starting 16147 -- from an outer level call. The table prevents both infinite recursion and 16148 -- useless reanalysis of calls within the same context. The use of context 16149 -- is important because it allows for proper checks in more complex code: 16150 16151 -- if ... then 16152 -- Call; -- requires a check 16153 -- Call; -- does not need a check thanks to the table 16154 -- elsif ... then 16155 -- Call; -- requires a check, different context 16156 -- end if; 16157 16158 -- Call; -- requires a check, different context 16159 16160 type Visited_Element is record 16161 Subp_Id : Entity_Id; 16162 -- The entity of the subprogram being called 16163 16164 Context : Node_Id; 16165 -- The context where the call to the subprogram occurs 16166 end record; 16167 16168 package Elab_Visited is new Table.Table 16169 (Table_Component_Type => Visited_Element, 16170 Table_Index_Type => Int, 16171 Table_Low_Bound => 1, 16172 Table_Initial => 200, 16173 Table_Increment => 100, 16174 Table_Name => "Elab_Visited"); 16175 16176 -- The following table records delayed calls which must be examined after 16177 -- all generic bodies have been instantiated. 16178 16179 type Delay_Element is record 16180 N : Node_Id; 16181 -- The parameter N from the call to Check_Internal_Call. Note that this 16182 -- node may get rewritten over the delay period by expansion in the call 16183 -- case (but not in the instantiation case). 16184 16185 E : Entity_Id; 16186 -- The parameter E from the call to Check_Internal_Call 16187 16188 Orig_Ent : Entity_Id; 16189 -- The parameter Orig_Ent from the call to Check_Internal_Call 16190 16191 Curscop : Entity_Id; 16192 -- The current scope of the call. This is restored when we complete the 16193 -- delayed call, so that we do this in the right scope. 16194 16195 Outer_Scope : Entity_Id; 16196 -- Save scope of outer level call 16197 16198 From_Elab_Code : Boolean; 16199 -- Save indication of whether this call is from elaboration code 16200 16201 In_Task_Activation : Boolean; 16202 -- Save indication of whether this call is from a task body. Tasks are 16203 -- activated at the "begin", which is after all local procedure bodies, 16204 -- so calls to those procedures can't fail, even if they occur after the 16205 -- task body. 16206 16207 From_SPARK_Code : Boolean; 16208 -- Save indication of whether this call is under SPARK_Mode => On 16209 end record; 16210 16211 package Delay_Check is new Table.Table 16212 (Table_Component_Type => Delay_Element, 16213 Table_Index_Type => Int, 16214 Table_Low_Bound => 1, 16215 Table_Initial => 1000, 16216 Table_Increment => 100, 16217 Table_Name => "Delay_Check"); 16218 16219 C_Scope : Entity_Id; 16220 -- Top-level scope of current scope. Compute this only once at the outer 16221 -- level, i.e. for a call to Check_Elab_Call from outside this unit. 16222 16223 Outer_Level_Sloc : Source_Ptr; 16224 -- Save Sloc value for outer level call node for comparisons of source 16225 -- locations. A body is too late if it appears after the *outer* level 16226 -- call, not the particular call that is being analyzed. 16227 16228 From_Elab_Code : Boolean; 16229 -- This flag shows whether the outer level call currently being examined 16230 -- is or is not in elaboration code. We are only interested in calls to 16231 -- routines in other units if this flag is True. 16232 16233 In_Task_Activation : Boolean := False; 16234 -- This flag indicates whether we are performing elaboration checks on task 16235 -- bodies, at the point of activation. If true, we do not raise 16236 -- Program_Error for calls to local procedures, because all local bodies 16237 -- are known to be elaborated. However, we still need to trace such calls, 16238 -- because a local procedure could call a procedure in another package, 16239 -- so we might need an implicit Elaborate_All. 16240 16241 Delaying_Elab_Checks : Boolean := True; 16242 -- This is set True till the compilation is complete, including the 16243 -- insertion of all instance bodies. Then when Check_Elab_Calls is called, 16244 -- the delay table is used to make the delayed calls and this flag is reset 16245 -- to False, so that the calls are processed. 16246 16247 ----------------------- 16248 -- Local Subprograms -- 16249 ----------------------- 16250 16251 -- Note: Outer_Scope in all following specs represents the scope of 16252 -- interest of the outer level call. If it is set to Standard_Standard, 16253 -- then it means the outer level call was at elaboration level, and that 16254 -- thus all calls are of interest. If it was set to some other scope, 16255 -- then the original call was an inner call, and we are not interested 16256 -- in calls that go outside this scope. 16257 16258 procedure Activate_Elaborate_All_Desirable (N : Node_Id; U : Entity_Id); 16259 -- Analysis of construct N shows that we should set Elaborate_All_Desirable 16260 -- for the WITH clause for unit U (which will always be present). A special 16261 -- case is when N is a function or procedure instantiation, in which case 16262 -- it is sufficient to set Elaborate_Desirable, since in this case there is 16263 -- no possibility of transitive elaboration issues. 16264 16265 procedure Check_A_Call 16266 (N : Node_Id; 16267 E : Entity_Id; 16268 Outer_Scope : Entity_Id; 16269 Inter_Unit_Only : Boolean; 16270 Generate_Warnings : Boolean := True; 16271 In_Init_Proc : Boolean := False); 16272 -- This is the internal recursive routine that is called to check for 16273 -- possible elaboration error. The argument N is a subprogram call or 16274 -- generic instantiation, or 'Access attribute reference to be checked, and 16275 -- E is the entity of the called subprogram, or instantiated generic unit, 16276 -- or subprogram referenced by 'Access. 16277 -- 16278 -- In SPARK mode, N can also be a variable reference, since in SPARK this 16279 -- also triggers a requirement for Elaborate_All, and in this case E is the 16280 -- entity being referenced. 16281 -- 16282 -- Outer_Scope is the outer level scope for the original reference. 16283 -- Inter_Unit_Only is set if the call is only to be checked in the 16284 -- case where it is to another unit (and skipped if within a unit). 16285 -- Generate_Warnings is set to False to suppress warning messages about 16286 -- missing pragma Elaborate_All's. These messages are not wanted for 16287 -- inner calls in the dynamic model. Note that an instance of the Access 16288 -- attribute applied to a subprogram also generates a call to this 16289 -- procedure (since the referenced subprogram may be called later 16290 -- indirectly). Flag In_Init_Proc should be set whenever the current 16291 -- context is a type init proc. 16292 -- 16293 -- Note: this might better be called Check_A_Reference to recognize the 16294 -- variable case for SPARK, but we prefer to retain the historical name 16295 -- since in practice this is mostly about checking calls for the possible 16296 -- occurrence of an access-before-elaboration exception. 16297 16298 procedure Check_Bad_Instantiation (N : Node_Id); 16299 -- N is a node for an instantiation (if called with any other node kind, 16300 -- Check_Bad_Instantiation ignores the call). This subprogram checks for 16301 -- the special case of a generic instantiation of a generic spec in the 16302 -- same declarative part as the instantiation where a body is present and 16303 -- has not yet been seen. This is an obvious error, but needs to be checked 16304 -- specially at the time of the instantiation, since it is a case where we 16305 -- cannot insert the body anywhere. If this case is detected, warnings are 16306 -- generated, and a raise of Program_Error is inserted. In addition any 16307 -- subprograms in the generic spec are stubbed, and the Bad_Instantiation 16308 -- flag is set on the instantiation node. The caller in Sem_Ch12 uses this 16309 -- flag as an indication that no attempt should be made to insert an 16310 -- instance body. 16311 16312 procedure Check_Internal_Call 16313 (N : Node_Id; 16314 E : Entity_Id; 16315 Outer_Scope : Entity_Id; 16316 Orig_Ent : Entity_Id); 16317 -- N is a function call or procedure statement call node and E is the 16318 -- entity of the called function, which is within the current compilation 16319 -- unit (where subunits count as part of the parent). This call checks if 16320 -- this call, or any call within any accessed body could cause an ABE, and 16321 -- if so, outputs a warning. Orig_Ent differs from E only in the case of 16322 -- renamings, and points to the original name of the entity. This is used 16323 -- for error messages. Outer_Scope is the outer level scope for the 16324 -- original call. 16325 16326 procedure Check_Internal_Call_Continue 16327 (N : Node_Id; 16328 E : Entity_Id; 16329 Outer_Scope : Entity_Id; 16330 Orig_Ent : Entity_Id); 16331 -- The processing for Check_Internal_Call is divided up into two phases, 16332 -- and this represents the second phase. The second phase is delayed if 16333 -- Delaying_Elab_Checks is set to True. In this delayed case, the first 16334 -- phase makes an entry in the Delay_Check table, which is processed when 16335 -- Check_Elab_Calls is called. N, E and Orig_Ent are as for the call to 16336 -- Check_Internal_Call. Outer_Scope is the outer level scope for the 16337 -- original call. 16338 16339 function Get_Referenced_Ent (N : Node_Id) return Entity_Id; 16340 -- N is either a function or procedure call or an access attribute that 16341 -- references a subprogram. This call retrieves the relevant entity. If 16342 -- this is a call to a protected subprogram, the entity is a selected 16343 -- component. The callable entity may be absent, in which case Empty is 16344 -- returned. This happens with non-analyzed calls in nested generics. 16345 -- 16346 -- If SPARK_Mode is On, then N can also be a reference to an E_Variable 16347 -- entity, in which case, the value returned is simply this entity. 16348 16349 function Has_Generic_Body (N : Node_Id) return Boolean; 16350 -- N is a generic package instantiation node, and this routine determines 16351 -- if this package spec does in fact have a generic body. If so, then 16352 -- True is returned, otherwise False. Note that this is not at all the 16353 -- same as checking if the unit requires a body, since it deals with 16354 -- the case of optional bodies accurately (i.e. if a body is optional, 16355 -- then it looks to see if a body is actually present). Note: this 16356 -- function can only do a fully correct job if in generating code mode 16357 -- where all bodies have to be present. If we are operating in semantics 16358 -- check only mode, then in some cases of optional bodies, a result of 16359 -- False may incorrectly be given. In practice this simply means that 16360 -- some cases of warnings for incorrect order of elaboration will only 16361 -- be given when generating code, which is not a big problem (and is 16362 -- inevitable, given the optional body semantics of Ada). 16363 16364 procedure Insert_Elab_Check (N : Node_Id; C : Node_Id := Empty); 16365 -- Given code for an elaboration check (or unconditional raise if the check 16366 -- is not needed), inserts the code in the appropriate place. N is the call 16367 -- or instantiation node for which the check code is required. C is the 16368 -- test whose failure triggers the raise. 16369 16370 function Is_Call_Of_Generic_Formal (N : Node_Id) return Boolean; 16371 -- Returns True if node N is a call to a generic formal subprogram 16372 16373 function Is_Finalization_Procedure (Id : Entity_Id) return Boolean; 16374 -- Determine whether entity Id denotes a [Deep_]Finalize procedure 16375 16376 procedure Output_Calls 16377 (N : Node_Id; 16378 Check_Elab_Flag : Boolean); 16379 -- Outputs chain of calls stored in the Elab_Call table. The caller has 16380 -- already generated the main warning message, so the warnings generated 16381 -- are all continuation messages. The argument is the call node at which 16382 -- the messages are to be placed. When Check_Elab_Flag is set, calls are 16383 -- enumerated only when flag Elab_Warning is set for the dynamic case or 16384 -- when flag Elab_Info_Messages is set for the static case. 16385 16386 function Same_Elaboration_Scope (Scop1, Scop2 : Entity_Id) return Boolean; 16387 -- Given two scopes, determine whether they are the same scope from an 16388 -- elaboration point of view, i.e. packages and blocks are ignored. 16389 16390 procedure Set_C_Scope; 16391 -- On entry C_Scope is set to some scope. On return, C_Scope is reset 16392 -- to be the enclosing compilation unit of this scope. 16393 16394 procedure Set_Elaboration_Constraint 16395 (Call : Node_Id; 16396 Subp : Entity_Id; 16397 Scop : Entity_Id); 16398 -- The current unit U may depend semantically on some unit P that is not 16399 -- in the current context. If there is an elaboration call that reaches P, 16400 -- we need to indicate that P requires an Elaborate_All, but this is not 16401 -- effective in U's ali file, if there is no with_clause for P. In this 16402 -- case we add the Elaborate_All on the unit Q that directly or indirectly 16403 -- makes P available. This can happen in two cases: 16404 -- 16405 -- a) Q declares a subtype of a type declared in P, and the call is an 16406 -- initialization call for an object of that subtype. 16407 -- 16408 -- b) Q declares an object of some tagged type whose root type is 16409 -- declared in P, and the initialization call uses object notation on 16410 -- that object to reach a primitive operation or a classwide operation 16411 -- declared in P. 16412 -- 16413 -- If P appears in the context of U, the current processing is correct. 16414 -- Otherwise we must identify these two cases to retrieve Q and place the 16415 -- Elaborate_All_Desirable on it. 16416 16417 function Spec_Entity (E : Entity_Id) return Entity_Id; 16418 -- Given a compilation unit entity, if it is a spec entity, it is returned 16419 -- unchanged. If it is a body entity, then the spec for the corresponding 16420 -- spec is returned 16421 16422 function Within (E1, E2 : Entity_Id) return Boolean; 16423 -- Given two scopes E1 and E2, returns True if E1 is equal to E2, or is one 16424 -- of its contained scopes, False otherwise. 16425 16426 function Within_Elaborate_All 16427 (Unit : Unit_Number_Type; 16428 E : Entity_Id) return Boolean; 16429 -- Return True if we are within the scope of an Elaborate_All for E, or if 16430 -- we are within the scope of an Elaborate_All for some other unit U, and U 16431 -- with's E. This prevents spurious warnings when the called entity is 16432 -- renamed within U, or in case of generic instances. 16433 16434 -------------------------------------- 16435 -- Activate_Elaborate_All_Desirable -- 16436 -------------------------------------- 16437 16438 procedure Activate_Elaborate_All_Desirable (N : Node_Id; U : Entity_Id) is 16439 UN : constant Unit_Number_Type := Get_Code_Unit (N); 16440 CU : constant Node_Id := Cunit (UN); 16441 UE : constant Entity_Id := Cunit_Entity (UN); 16442 Unm : constant Unit_Name_Type := Unit_Name (UN); 16443 CI : constant List_Id := Context_Items (CU); 16444 Itm : Node_Id; 16445 Ent : Entity_Id; 16446 16447 procedure Add_To_Context_And_Mark (Itm : Node_Id); 16448 -- This procedure is called when the elaborate indication must be 16449 -- applied to a unit not in the context of the referencing unit. The 16450 -- unit gets added to the context as an implicit with. 16451 16452 function In_Withs_Of (UEs : Entity_Id) return Boolean; 16453 -- UEs is the spec entity of a unit. If the unit to be marked is 16454 -- in the context item list of this unit spec, then the call returns 16455 -- True and Itm is left set to point to the relevant N_With_Clause node. 16456 16457 procedure Set_Elab_Flag (Itm : Node_Id); 16458 -- Sets Elaborate_[All_]Desirable as appropriate on Itm 16459 16460 ----------------------------- 16461 -- Add_To_Context_And_Mark -- 16462 ----------------------------- 16463 16464 procedure Add_To_Context_And_Mark (Itm : Node_Id) is 16465 CW : constant Node_Id := 16466 Make_With_Clause (Sloc (Itm), 16467 Name => Name (Itm)); 16468 16469 begin 16470 Set_Library_Unit (CW, Library_Unit (Itm)); 16471 Set_Implicit_With (CW); 16472 16473 -- Set elaborate all desirable on copy and then append the copy to 16474 -- the list of body with's and we are done. 16475 16476 Set_Elab_Flag (CW); 16477 Append_To (CI, CW); 16478 end Add_To_Context_And_Mark; 16479 16480 ----------------- 16481 -- In_Withs_Of -- 16482 ----------------- 16483 16484 function In_Withs_Of (UEs : Entity_Id) return Boolean is 16485 UNs : constant Unit_Number_Type := Get_Source_Unit (UEs); 16486 CUs : constant Node_Id := Cunit (UNs); 16487 CIs : constant List_Id := Context_Items (CUs); 16488 16489 begin 16490 Itm := First (CIs); 16491 while Present (Itm) loop 16492 if Nkind (Itm) = N_With_Clause then 16493 Ent := 16494 Cunit_Entity (Get_Cunit_Unit_Number (Library_Unit (Itm))); 16495 16496 if U = Ent then 16497 return True; 16498 end if; 16499 end if; 16500 16501 Next (Itm); 16502 end loop; 16503 16504 return False; 16505 end In_Withs_Of; 16506 16507 ------------------- 16508 -- Set_Elab_Flag -- 16509 ------------------- 16510 16511 procedure Set_Elab_Flag (Itm : Node_Id) is 16512 begin 16513 if Nkind (N) in N_Subprogram_Instantiation then 16514 Set_Elaborate_Desirable (Itm); 16515 else 16516 Set_Elaborate_All_Desirable (Itm); 16517 end if; 16518 end Set_Elab_Flag; 16519 16520 -- Start of processing for Activate_Elaborate_All_Desirable 16521 16522 begin 16523 -- Do not set binder indication if expansion is disabled, as when 16524 -- compiling a generic unit. 16525 16526 if not Expander_Active then 16527 return; 16528 end if; 16529 16530 -- If an instance of a generic package contains a controlled object (so 16531 -- we're calling Initialize at elaboration time), and the instance is in 16532 -- a package body P that says "with P;", then we need to return without 16533 -- adding "pragma Elaborate_All (P);" to P. 16534 16535 if U = Main_Unit_Entity then 16536 return; 16537 end if; 16538 16539 Itm := First (CI); 16540 while Present (Itm) loop 16541 if Nkind (Itm) = N_With_Clause then 16542 Ent := Cunit_Entity (Get_Cunit_Unit_Number (Library_Unit (Itm))); 16543 16544 -- If we find it, then mark elaborate all desirable and return 16545 16546 if U = Ent then 16547 Set_Elab_Flag (Itm); 16548 return; 16549 end if; 16550 end if; 16551 16552 Next (Itm); 16553 end loop; 16554 16555 -- If we fall through then the with clause is not present in the 16556 -- current unit. One legitimate possibility is that the with clause 16557 -- is present in the spec when we are a body. 16558 16559 if Is_Body_Name (Unm) 16560 and then In_Withs_Of (Spec_Entity (UE)) 16561 then 16562 Add_To_Context_And_Mark (Itm); 16563 return; 16564 end if; 16565 16566 -- Similarly, we may be in the spec or body of a child unit, where 16567 -- the unit in question is with'ed by some ancestor of the child unit. 16568 16569 if Is_Child_Name (Unm) then 16570 declare 16571 Pkg : Entity_Id; 16572 16573 begin 16574 Pkg := UE; 16575 loop 16576 Pkg := Scope (Pkg); 16577 exit when Pkg = Standard_Standard; 16578 16579 if In_Withs_Of (Pkg) then 16580 Add_To_Context_And_Mark (Itm); 16581 return; 16582 end if; 16583 end loop; 16584 end; 16585 end if; 16586 16587 -- Here if we do not find with clause on spec or body. We just ignore 16588 -- this case; it means that the elaboration involves some other unit 16589 -- than the unit being compiled, and will be caught elsewhere. 16590 end Activate_Elaborate_All_Desirable; 16591 16592 ------------------ 16593 -- Check_A_Call -- 16594 ------------------ 16595 16596 procedure Check_A_Call 16597 (N : Node_Id; 16598 E : Entity_Id; 16599 Outer_Scope : Entity_Id; 16600 Inter_Unit_Only : Boolean; 16601 Generate_Warnings : Boolean := True; 16602 In_Init_Proc : Boolean := False) 16603 is 16604 Access_Case : constant Boolean := Nkind (N) = N_Attribute_Reference; 16605 -- Indicates if we have Access attribute case 16606 16607 function Call_To_Instance_From_Outside (Id : Entity_Id) return Boolean; 16608 -- True if we're calling an instance of a generic subprogram, or a 16609 -- subprogram in an instance of a generic package, and the call is 16610 -- outside that instance. 16611 16612 procedure Elab_Warning 16613 (Msg_D : String; 16614 Msg_S : String; 16615 Ent : Node_Or_Entity_Id); 16616 -- Generate a call to Error_Msg_NE with parameters Msg_D or Msg_S (for 16617 -- dynamic or static elaboration model), N and Ent. Msg_D is a real 16618 -- warning (output if Msg_D is non-null and Elab_Warnings is set), 16619 -- Msg_S is an info message (output if Elab_Info_Messages is set). 16620 16621 function Find_W_Scope return Entity_Id; 16622 -- Find top-level scope for called entity (not following renamings 16623 -- or derivations). This is where the Elaborate_All will go if it is 16624 -- needed. We start with the called entity, except in the case of an 16625 -- initialization procedure outside the current package, where the init 16626 -- proc is in the root package, and we start from the entity of the name 16627 -- in the call. 16628 16629 ----------------------------------- 16630 -- Call_To_Instance_From_Outside -- 16631 ----------------------------------- 16632 16633 function Call_To_Instance_From_Outside (Id : Entity_Id) return Boolean is 16634 Scop : Entity_Id := Id; 16635 16636 begin 16637 loop 16638 if Scop = Standard_Standard then 16639 return False; 16640 end if; 16641 16642 if Is_Generic_Instance (Scop) then 16643 return not In_Open_Scopes (Scop); 16644 end if; 16645 16646 Scop := Scope (Scop); 16647 end loop; 16648 end Call_To_Instance_From_Outside; 16649 16650 ------------------ 16651 -- Elab_Warning -- 16652 ------------------ 16653 16654 procedure Elab_Warning 16655 (Msg_D : String; 16656 Msg_S : String; 16657 Ent : Node_Or_Entity_Id) 16658 is 16659 begin 16660 -- Dynamic elaboration checks, real warning 16661 16662 if Dynamic_Elaboration_Checks then 16663 if not Access_Case then 16664 if Msg_D /= "" and then Elab_Warnings then 16665 Error_Msg_NE (Msg_D, N, Ent); 16666 end if; 16667 16668 -- In the access case emit first warning message as well, 16669 -- otherwise list of calls will appear as errors. 16670 16671 elsif Elab_Warnings then 16672 Error_Msg_NE (Msg_S, N, Ent); 16673 end if; 16674 16675 -- Static elaboration checks, info message 16676 16677 else 16678 if Elab_Info_Messages then 16679 Error_Msg_NE (Msg_S, N, Ent); 16680 end if; 16681 end if; 16682 end Elab_Warning; 16683 16684 ------------------ 16685 -- Find_W_Scope -- 16686 ------------------ 16687 16688 function Find_W_Scope return Entity_Id is 16689 Refed_Ent : constant Entity_Id := Get_Referenced_Ent (N); 16690 W_Scope : Entity_Id; 16691 16692 begin 16693 if Is_Init_Proc (Refed_Ent) 16694 and then not In_Same_Extended_Unit (N, Refed_Ent) 16695 then 16696 W_Scope := Scope (Refed_Ent); 16697 else 16698 W_Scope := E; 16699 end if; 16700 16701 -- Now loop through scopes to get to the enclosing compilation unit 16702 16703 while not Is_Compilation_Unit (W_Scope) loop 16704 W_Scope := Scope (W_Scope); 16705 end loop; 16706 16707 return W_Scope; 16708 end Find_W_Scope; 16709 16710 -- Local variables 16711 16712 Inst_Case : constant Boolean := Nkind (N) in N_Generic_Instantiation; 16713 -- Indicates if we have instantiation case 16714 16715 Loc : constant Source_Ptr := Sloc (N); 16716 16717 Variable_Case : constant Boolean := 16718 Nkind (N) in N_Has_Entity 16719 and then Present (Entity (N)) 16720 and then Ekind (Entity (N)) = E_Variable; 16721 -- Indicates if we have variable reference case 16722 16723 W_Scope : constant Entity_Id := Find_W_Scope; 16724 -- Top-level scope of directly called entity for subprogram. This 16725 -- differs from E_Scope in the case where renamings or derivations 16726 -- are involved, since it does not follow these links. W_Scope is 16727 -- generally in a visible unit, and it is this scope that may require 16728 -- an Elaborate_All. However, there are some cases (initialization 16729 -- calls and calls involving object notation) where W_Scope might not 16730 -- be in the context of the current unit, and there is an intermediate 16731 -- package that is, in which case the Elaborate_All has to be placed 16732 -- on this intermediate package. These special cases are handled in 16733 -- Set_Elaboration_Constraint. 16734 16735 Ent : Entity_Id; 16736 Callee_Unit_Internal : Boolean; 16737 Caller_Unit_Internal : Boolean; 16738 Decl : Node_Id; 16739 Inst_Callee : Source_Ptr; 16740 Inst_Caller : Source_Ptr; 16741 Unit_Callee : Unit_Number_Type; 16742 Unit_Caller : Unit_Number_Type; 16743 16744 Body_Acts_As_Spec : Boolean; 16745 -- Set to true if call is to body acting as spec (no separate spec) 16746 16747 Cunit_SC : Boolean := False; 16748 -- Set to suppress dynamic elaboration checks where one of the 16749 -- enclosing scopes has Elaboration_Checks_Suppressed set, or else 16750 -- if a pragma Elaborate[_All] applies to that scope, in which case 16751 -- warnings on the scope are also suppressed. For the internal case, 16752 -- we ignore this flag. 16753 16754 E_Scope : Entity_Id; 16755 -- Top-level scope of entity for called subprogram. This value includes 16756 -- following renamings and derivations, so this scope can be in a 16757 -- non-visible unit. This is the scope that is to be investigated to 16758 -- see whether an elaboration check is required. 16759 16760 Is_DIC : Boolean; 16761 -- Flag set when the subprogram being invoked is the procedure generated 16762 -- for pragma Default_Initial_Condition. 16763 16764 SPARK_Elab_Errors : Boolean; 16765 -- Flag set when an entity is called or a variable is read during SPARK 16766 -- dynamic elaboration. 16767 16768 -- Start of processing for Check_A_Call 16769 16770 begin 16771 -- If the call is known to be within a local Suppress Elaboration 16772 -- pragma, nothing to check. This can happen in task bodies. But 16773 -- we ignore this for a call to a generic formal. 16774 16775 if Nkind (N) in N_Subprogram_Call 16776 and then No_Elaboration_Check (N) 16777 and then not Is_Call_Of_Generic_Formal (N) 16778 then 16779 return; 16780 16781 -- If this is a rewrite of a Valid_Scalars attribute, then nothing to 16782 -- check, we don't mind in this case if the call occurs before the body 16783 -- since this is all generated code. 16784 16785 elsif Nkind (Original_Node (N)) = N_Attribute_Reference 16786 and then Attribute_Name (Original_Node (N)) = Name_Valid_Scalars 16787 then 16788 return; 16789 16790 -- Intrinsics such as instances of Unchecked_Deallocation do not have 16791 -- any body, so elaboration checking is not needed, and would be wrong. 16792 16793 elsif Is_Intrinsic_Subprogram (E) then 16794 return; 16795 16796 -- Do not consider references to internal variables for SPARK semantics 16797 16798 elsif Variable_Case and then not Comes_From_Source (E) then 16799 return; 16800 end if; 16801 16802 -- Proceed with check 16803 16804 Ent := E; 16805 16806 -- For a variable reference, just set Body_Acts_As_Spec to False 16807 16808 if Variable_Case then 16809 Body_Acts_As_Spec := False; 16810 16811 -- Additional checks for all other cases 16812 16813 else 16814 -- Go to parent for derived subprogram, or to original subprogram in 16815 -- the case of a renaming (Alias covers both these cases). 16816 16817 loop 16818 if (Suppress_Elaboration_Warnings (Ent) 16819 or else Elaboration_Checks_Suppressed (Ent)) 16820 and then (Inst_Case or else No (Alias (Ent))) 16821 then 16822 return; 16823 end if; 16824 16825 -- Nothing to do for imported entities 16826 16827 if Is_Imported (Ent) then 16828 return; 16829 end if; 16830 16831 exit when Inst_Case or else No (Alias (Ent)); 16832 Ent := Alias (Ent); 16833 end loop; 16834 16835 Decl := Unit_Declaration_Node (Ent); 16836 16837 if Nkind (Decl) = N_Subprogram_Body then 16838 Body_Acts_As_Spec := True; 16839 16840 elsif Nkind (Decl) in 16841 N_Subprogram_Declaration | N_Subprogram_Body_Stub 16842 or else Inst_Case 16843 then 16844 Body_Acts_As_Spec := False; 16845 16846 -- If we have none of an instantiation, subprogram body or subprogram 16847 -- declaration, or in the SPARK case, a variable reference, then 16848 -- it is not a case that we want to check. (One case is a call to a 16849 -- generic formal subprogram, where we do not want the check in the 16850 -- template). 16851 16852 else 16853 return; 16854 end if; 16855 end if; 16856 16857 E_Scope := Ent; 16858 loop 16859 if Elaboration_Checks_Suppressed (E_Scope) 16860 or else Suppress_Elaboration_Warnings (E_Scope) 16861 then 16862 Cunit_SC := True; 16863 end if; 16864 16865 -- Exit when we get to compilation unit, not counting subunits 16866 16867 exit when Is_Compilation_Unit (E_Scope) 16868 and then (Is_Child_Unit (E_Scope) 16869 or else Scope (E_Scope) = Standard_Standard); 16870 16871 pragma Assert (E_Scope /= Standard_Standard); 16872 16873 -- Move up a scope looking for compilation unit 16874 16875 E_Scope := Scope (E_Scope); 16876 end loop; 16877 16878 -- No checks needed for pure or preelaborated compilation units 16879 16880 if Is_Pure (E_Scope) or else Is_Preelaborated (E_Scope) then 16881 return; 16882 end if; 16883 16884 -- If the generic entity is within a deeper instance than we are, then 16885 -- either the instantiation to which we refer itself caused an ABE, in 16886 -- which case that will be handled separately, or else we know that the 16887 -- body we need appears as needed at the point of the instantiation. 16888 -- However, this assumption is only valid if we are in static mode. 16889 16890 if not Dynamic_Elaboration_Checks 16891 and then 16892 Instantiation_Depth (Sloc (Ent)) > Instantiation_Depth (Sloc (N)) 16893 then 16894 return; 16895 end if; 16896 16897 -- Do not give a warning for a package with no body 16898 16899 if Ekind (Ent) = E_Generic_Package and then not Has_Generic_Body (N) then 16900 return; 16901 end if; 16902 16903 -- Case of entity is in same unit as call or instantiation. In the 16904 -- instantiation case, W_Scope may be different from E_Scope; we want 16905 -- the unit in which the instantiation occurs, since we're analyzing 16906 -- based on the expansion. 16907 16908 if W_Scope = C_Scope then 16909 if not Inter_Unit_Only then 16910 Check_Internal_Call (N, Ent, Outer_Scope, E); 16911 end if; 16912 16913 return; 16914 end if; 16915 16916 -- Case of entity is not in current unit (i.e. with'ed unit case) 16917 16918 -- We are only interested in such calls if the outer call was from 16919 -- elaboration code, or if we are in Dynamic_Elaboration_Checks mode. 16920 16921 if not From_Elab_Code and then not Dynamic_Elaboration_Checks then 16922 return; 16923 end if; 16924 16925 -- Nothing to do if some scope said that no checks were required 16926 16927 if Cunit_SC then 16928 return; 16929 end if; 16930 16931 -- Nothing to do for a generic instance, because a call to an instance 16932 -- cannot fail the elaboration check, because the body of the instance 16933 -- is always elaborated immediately after the spec. 16934 16935 if Call_To_Instance_From_Outside (Ent) then 16936 return; 16937 end if; 16938 16939 -- Nothing to do if subprogram with no separate spec. However, a call 16940 -- to Deep_Initialize may result in a call to a user-defined Initialize 16941 -- procedure, which imposes a body dependency. This happens only if the 16942 -- type is controlled and the Initialize procedure is not inherited. 16943 16944 if Body_Acts_As_Spec then 16945 if Is_TSS (Ent, TSS_Deep_Initialize) then 16946 declare 16947 Typ : constant Entity_Id := Etype (First_Formal (Ent)); 16948 Init : Entity_Id; 16949 16950 begin 16951 if not Is_Controlled (Typ) then 16952 return; 16953 else 16954 Init := Find_Prim_Op (Typ, Name_Initialize); 16955 16956 if Comes_From_Source (Init) then 16957 Ent := Init; 16958 else 16959 return; 16960 end if; 16961 end if; 16962 end; 16963 16964 else 16965 return; 16966 end if; 16967 end if; 16968 16969 -- Check cases of internal units 16970 16971 Callee_Unit_Internal := In_Internal_Unit (E_Scope); 16972 16973 -- Do not give a warning if the with'ed unit is internal and this is 16974 -- the generic instantiation case (this saves a lot of hassle dealing 16975 -- with the Text_IO special child units) 16976 16977 if Callee_Unit_Internal and Inst_Case then 16978 return; 16979 end if; 16980 16981 if C_Scope = Standard_Standard then 16982 Caller_Unit_Internal := False; 16983 else 16984 Caller_Unit_Internal := In_Internal_Unit (C_Scope); 16985 end if; 16986 16987 -- Do not give a warning if the with'ed unit is internal and the caller 16988 -- is not internal (since the binder always elaborates internal units 16989 -- first). 16990 16991 if Callee_Unit_Internal and not Caller_Unit_Internal then 16992 return; 16993 end if; 16994 16995 -- For now, if debug flag -gnatdE is not set, do no checking for one 16996 -- internal unit withing another. This fixes the problem with the sgi 16997 -- build and storage errors. To be resolved later ??? 16998 16999 if (Callee_Unit_Internal and Caller_Unit_Internal) 17000 and not Debug_Flag_EE 17001 then 17002 return; 17003 end if; 17004 17005 if Is_TSS (E, TSS_Deep_Initialize) then 17006 Ent := E; 17007 end if; 17008 17009 -- If the call is in an instance, and the called entity is not 17010 -- defined in the same instance, then the elaboration issue focuses 17011 -- around the unit containing the template, it is this unit that 17012 -- requires an Elaborate_All. 17013 17014 -- However, if we are doing dynamic elaboration, we need to chase the 17015 -- call in the usual manner. 17016 17017 -- We also need to chase the call in the usual manner if it is a call 17018 -- to a generic formal parameter, since that case was not handled as 17019 -- part of the processing of the template. 17020 17021 Inst_Caller := Instantiation (Get_Source_File_Index (Sloc (N))); 17022 Inst_Callee := Instantiation (Get_Source_File_Index (Sloc (Ent))); 17023 17024 if Inst_Caller = No_Location then 17025 Unit_Caller := No_Unit; 17026 else 17027 Unit_Caller := Get_Source_Unit (N); 17028 end if; 17029 17030 if Inst_Callee = No_Location then 17031 Unit_Callee := No_Unit; 17032 else 17033 Unit_Callee := Get_Source_Unit (Ent); 17034 end if; 17035 17036 if Unit_Caller /= No_Unit 17037 and then Unit_Callee /= Unit_Caller 17038 and then not Dynamic_Elaboration_Checks 17039 and then not Is_Call_Of_Generic_Formal (N) 17040 then 17041 E_Scope := Spec_Entity (Cunit_Entity (Unit_Caller)); 17042 17043 -- If we don't get a spec entity, just ignore call. Not quite 17044 -- clear why this check is necessary. ??? 17045 17046 if No (E_Scope) then 17047 return; 17048 end if; 17049 17050 -- Otherwise step to enclosing compilation unit 17051 17052 while not Is_Compilation_Unit (E_Scope) loop 17053 E_Scope := Scope (E_Scope); 17054 end loop; 17055 17056 -- For the case where N is not an instance, and is not a call within 17057 -- instance to other than a generic formal, we recompute E_Scope 17058 -- for the error message, since we do NOT want to go to the unit 17059 -- that has the ultimate declaration in the case of renaming and 17060 -- derivation and we also want to go to the generic unit in the 17061 -- case of an instance, and no further. 17062 17063 else 17064 -- Loop to carefully follow renamings and derivations one step 17065 -- outside the current unit, but not further. 17066 17067 if not (Inst_Case or Variable_Case) 17068 and then Present (Alias (Ent)) 17069 then 17070 E_Scope := Alias (Ent); 17071 else 17072 E_Scope := Ent; 17073 end if; 17074 17075 loop 17076 while not Is_Compilation_Unit (E_Scope) loop 17077 E_Scope := Scope (E_Scope); 17078 end loop; 17079 17080 -- If E_Scope is the same as C_Scope, it means that there 17081 -- definitely was a local renaming or derivation, and we 17082 -- are not yet out of the current unit. 17083 17084 exit when E_Scope /= C_Scope; 17085 Ent := Alias (Ent); 17086 E_Scope := Ent; 17087 17088 -- If no alias, there could be a previous error, but not if we've 17089 -- already reached the outermost level (Standard). 17090 17091 if No (Ent) then 17092 return; 17093 end if; 17094 end loop; 17095 end if; 17096 17097 if Within_Elaborate_All (Current_Sem_Unit, E_Scope) then 17098 return; 17099 end if; 17100 17101 -- Determine whether the Default_Initial_Condition procedure of some 17102 -- type is being invoked. 17103 17104 Is_DIC := Ekind (Ent) = E_Procedure and then Is_DIC_Procedure (Ent); 17105 17106 -- Checks related to Default_Initial_Condition fall under the SPARK 17107 -- umbrella because this is a SPARK-specific annotation. 17108 17109 SPARK_Elab_Errors := 17110 SPARK_Mode = On and (Is_DIC or Dynamic_Elaboration_Checks); 17111 17112 -- Now check if an Elaborate_All (or dynamic check) is needed 17113 17114 if (Elab_Info_Messages or Elab_Warnings or SPARK_Elab_Errors) 17115 and then Generate_Warnings 17116 and then not Suppress_Elaboration_Warnings (Ent) 17117 and then not Elaboration_Checks_Suppressed (Ent) 17118 and then not Suppress_Elaboration_Warnings (E_Scope) 17119 and then not Elaboration_Checks_Suppressed (E_Scope) 17120 then 17121 -- Instantiation case 17122 17123 if Inst_Case then 17124 if Comes_From_Source (Ent) and then SPARK_Elab_Errors then 17125 Error_Msg_NE 17126 ("instantiation of & during elaboration in SPARK", N, Ent); 17127 else 17128 Elab_Warning 17129 ("instantiation of & may raise Program_Error?l?", 17130 "info: instantiation of & during elaboration?$?", Ent); 17131 end if; 17132 17133 -- Indirect call case, info message only in static elaboration 17134 -- case, because the attribute reference itself cannot raise an 17135 -- exception. Note that SPARK does not permit indirect calls. 17136 17137 elsif Access_Case then 17138 Elab_Warning ("", "info: access to & during elaboration?$?", Ent); 17139 17140 -- Variable reference in SPARK mode 17141 17142 elsif Variable_Case then 17143 if Comes_From_Source (Ent) and then SPARK_Elab_Errors then 17144 Error_Msg_NE 17145 ("reference to & during elaboration in SPARK", N, Ent); 17146 end if; 17147 17148 -- Subprogram call case 17149 17150 else 17151 if Nkind (Name (N)) in N_Has_Entity 17152 and then Is_Init_Proc (Entity (Name (N))) 17153 and then Comes_From_Source (Ent) 17154 then 17155 Elab_Warning 17156 ("implicit call to & may raise Program_Error?l?", 17157 "info: implicit call to & during elaboration?$?", 17158 Ent); 17159 17160 elsif SPARK_Elab_Errors then 17161 17162 -- Emit a specialized error message when the elaboration of an 17163 -- object of a private type evaluates the expression of pragma 17164 -- Default_Initial_Condition. This prevents the internal name 17165 -- of the procedure from appearing in the error message. 17166 17167 if Is_DIC then 17168 Error_Msg_N 17169 ("call to Default_Initial_Condition during elaboration in " 17170 & "SPARK", N); 17171 else 17172 Error_Msg_NE 17173 ("call to & during elaboration in SPARK", N, Ent); 17174 end if; 17175 17176 else 17177 Elab_Warning 17178 ("call to & may raise Program_Error?l?", 17179 "info: call to & during elaboration?$?", 17180 Ent); 17181 end if; 17182 end if; 17183 17184 Error_Msg_Qual_Level := Nat'Last; 17185 17186 -- Case of Elaborate_All not present and required, for SPARK this 17187 -- is an error, so give an error message. 17188 17189 if SPARK_Elab_Errors then 17190 Error_Msg_NE -- CODEFIX 17191 ("\Elaborate_All pragma required for&", N, W_Scope); 17192 17193 -- Otherwise we generate an implicit pragma. For a subprogram 17194 -- instantiation, Elaborate is good enough, since no transitive 17195 -- call is possible at elaboration time in this case. 17196 17197 elsif Nkind (N) in N_Subprogram_Instantiation then 17198 Elab_Warning 17199 ("\missing pragma Elaborate for&?l?", 17200 "\implicit pragma Elaborate for& generated?$?", 17201 W_Scope); 17202 17203 -- For all other cases, we need an implicit Elaborate_All 17204 17205 else 17206 Elab_Warning 17207 ("\missing pragma Elaborate_All for&?l?", 17208 "\implicit pragma Elaborate_All for & generated?$?", 17209 W_Scope); 17210 end if; 17211 17212 Error_Msg_Qual_Level := 0; 17213 17214 -- Take into account the flags related to elaboration warning 17215 -- messages when enumerating the various calls involved. This 17216 -- ensures the proper pairing of the main warning and the 17217 -- clarification messages generated by Output_Calls. 17218 17219 Output_Calls (N, Check_Elab_Flag => True); 17220 17221 -- Set flag to prevent further warnings for same unit unless in 17222 -- All_Errors_Mode. 17223 17224 if not All_Errors_Mode and not Dynamic_Elaboration_Checks then 17225 Set_Suppress_Elaboration_Warnings (W_Scope); 17226 end if; 17227 end if; 17228 17229 -- Check for runtime elaboration check required 17230 17231 if Dynamic_Elaboration_Checks then 17232 if not Elaboration_Checks_Suppressed (Ent) 17233 and then not Elaboration_Checks_Suppressed (W_Scope) 17234 and then not Elaboration_Checks_Suppressed (E_Scope) 17235 and then not Cunit_SC 17236 then 17237 -- Runtime elaboration check required. Generate check of the 17238 -- elaboration Boolean for the unit containing the entity. 17239 17240 -- Note that for this case, we do check the real unit (the one 17241 -- from following renamings, since that is the issue). 17242 17243 -- Could this possibly miss a useless but required PE??? 17244 17245 Insert_Elab_Check (N, 17246 Make_Attribute_Reference (Loc, 17247 Attribute_Name => Name_Elaborated, 17248 Prefix => 17249 New_Occurrence_Of (Spec_Entity (E_Scope), Loc))); 17250 17251 -- Prevent duplicate elaboration checks on the same call, which 17252 -- can happen if the body enclosing the call appears itself in a 17253 -- call whose elaboration check is delayed. 17254 17255 if Nkind (N) in N_Subprogram_Call then 17256 Set_No_Elaboration_Check (N); 17257 end if; 17258 end if; 17259 17260 -- Case of static elaboration model 17261 17262 else 17263 -- Do not do anything if elaboration checks suppressed. Note that 17264 -- we check Ent here, not E, since we want the real entity for the 17265 -- body to see if checks are suppressed for it, not the dummy 17266 -- entry for renamings or derivations. 17267 17268 if Elaboration_Checks_Suppressed (Ent) 17269 or else Elaboration_Checks_Suppressed (E_Scope) 17270 or else Elaboration_Checks_Suppressed (W_Scope) 17271 then 17272 null; 17273 17274 -- Do not generate an Elaborate_All for finalization routines 17275 -- that perform partial clean up as part of initialization. 17276 17277 elsif In_Init_Proc and then Is_Finalization_Procedure (Ent) then 17278 null; 17279 17280 -- Here we need to generate an implicit elaborate all 17281 17282 else 17283 -- Generate Elaborate_All warning unless suppressed 17284 17285 if (Elab_Info_Messages and Generate_Warnings and not Inst_Case) 17286 and then not Suppress_Elaboration_Warnings (Ent) 17287 and then not Suppress_Elaboration_Warnings (E_Scope) 17288 and then not Suppress_Elaboration_Warnings (W_Scope) 17289 then 17290 Error_Msg_Node_2 := W_Scope; 17291 Error_Msg_NE 17292 ("info: call to& in elaboration code requires pragma " 17293 & "Elaborate_All on&?$?", N, E); 17294 end if; 17295 17296 -- Set indication for binder to generate Elaborate_All 17297 17298 Set_Elaboration_Constraint (N, E, W_Scope); 17299 end if; 17300 end if; 17301 end Check_A_Call; 17302 17303 ----------------------------- 17304 -- Check_Bad_Instantiation -- 17305 ----------------------------- 17306 17307 procedure Check_Bad_Instantiation (N : Node_Id) is 17308 Ent : Entity_Id; 17309 17310 begin 17311 -- Nothing to do if we do not have an instantiation (happens in some 17312 -- error cases, and also in the formal package declaration case) 17313 17314 if Nkind (N) not in N_Generic_Instantiation then 17315 return; 17316 17317 -- Nothing to do if serious errors detected (avoid cascaded errors) 17318 17319 elsif Serious_Errors_Detected /= 0 then 17320 return; 17321 17322 -- Nothing to do if not in full analysis mode 17323 17324 elsif not Full_Analysis then 17325 return; 17326 17327 -- Nothing to do if inside a generic template 17328 17329 elsif Inside_A_Generic then 17330 return; 17331 17332 -- Nothing to do if a library level instantiation 17333 17334 elsif Nkind (Parent (N)) = N_Compilation_Unit then 17335 return; 17336 17337 -- Nothing to do if we are compiling a proper body for semantic 17338 -- purposes only. The generic body may be in another proper body. 17339 17340 elsif 17341 Nkind (Parent (Unit_Declaration_Node (Main_Unit_Entity))) = N_Subunit 17342 then 17343 return; 17344 end if; 17345 17346 Ent := Get_Generic_Entity (N); 17347 17348 -- The case we are interested in is when the generic spec is in the 17349 -- current declarative part 17350 17351 if not Same_Elaboration_Scope (Current_Scope, Scope (Ent)) 17352 or else not In_Same_Extended_Unit (N, Ent) 17353 then 17354 return; 17355 end if; 17356 17357 -- If the generic entity is within a deeper instance than we are, then 17358 -- either the instantiation to which we refer itself caused an ABE, in 17359 -- which case that will be handled separately. Otherwise, we know that 17360 -- the body we need appears as needed at the point of the instantiation. 17361 -- If they are both at the same level but not within the same instance 17362 -- then the body of the generic will be in the earlier instance. 17363 17364 declare 17365 D1 : constant Nat := Instantiation_Depth (Sloc (Ent)); 17366 D2 : constant Nat := Instantiation_Depth (Sloc (N)); 17367 17368 begin 17369 if D1 > D2 then 17370 return; 17371 17372 elsif D1 = D2 17373 and then Is_Generic_Instance (Scope (Ent)) 17374 and then not In_Open_Scopes (Scope (Ent)) 17375 then 17376 return; 17377 end if; 17378 end; 17379 17380 -- Now we can proceed, if the entity being called has a completion, 17381 -- then we are definitely OK, since we have already seen the body. 17382 17383 if Has_Completion (Ent) then 17384 return; 17385 end if; 17386 17387 -- If there is no body, then nothing to do 17388 17389 if not Has_Generic_Body (N) then 17390 return; 17391 end if; 17392 17393 -- Here we definitely have a bad instantiation 17394 17395 Error_Msg_Warn := SPARK_Mode /= On; 17396 Error_Msg_NE ("cannot instantiate& before body seen<<", N, Ent); 17397 Error_Msg_N ("\Program_Error [<<", N); 17398 17399 Insert_Elab_Check (N); 17400 Set_Is_Known_Guaranteed_ABE (N); 17401 end Check_Bad_Instantiation; 17402 17403 --------------------- 17404 -- Check_Elab_Call -- 17405 --------------------- 17406 17407 procedure Check_Elab_Call 17408 (N : Node_Id; 17409 Outer_Scope : Entity_Id := Empty; 17410 In_Init_Proc : Boolean := False) 17411 is 17412 Ent : Entity_Id; 17413 P : Node_Id; 17414 17415 begin 17416 pragma Assert (Legacy_Elaboration_Checks); 17417 17418 -- If the reference is not in the main unit, there is nothing to check. 17419 -- Elaboration call from units in the context of the main unit will lead 17420 -- to semantic dependencies when those units are compiled. 17421 17422 if not In_Extended_Main_Code_Unit (N) then 17423 return; 17424 end if; 17425 17426 -- For an entry call, check relevant restriction 17427 17428 if Nkind (N) = N_Entry_Call_Statement 17429 and then not In_Subprogram_Or_Concurrent_Unit 17430 then 17431 Check_Restriction (No_Entry_Calls_In_Elaboration_Code, N); 17432 17433 -- Nothing to do if this is not an expected type of reference (happens 17434 -- in some error conditions, and in some cases where rewriting occurs). 17435 17436 elsif Nkind (N) not in N_Subprogram_Call 17437 and then Nkind (N) /= N_Attribute_Reference 17438 and then (SPARK_Mode /= On 17439 or else Nkind (N) not in N_Has_Entity 17440 or else No (Entity (N)) 17441 or else Ekind (Entity (N)) /= E_Variable) 17442 then 17443 return; 17444 17445 -- Nothing to do if this is a call already rewritten for elab checking. 17446 -- Such calls appear as the targets of If_Expressions. 17447 17448 -- This check MUST be wrong, it catches far too much 17449 17450 elsif Nkind (Parent (N)) = N_If_Expression then 17451 return; 17452 17453 -- Nothing to do if inside a generic template 17454 17455 elsif Inside_A_Generic 17456 and then No (Enclosing_Generic_Body (N)) 17457 then 17458 return; 17459 17460 -- Nothing to do if call is being preanalyzed, as when within a 17461 -- pre/postcondition, a predicate, or an invariant. 17462 17463 elsif In_Spec_Expression then 17464 return; 17465 end if; 17466 17467 -- Nothing to do if this is a call to a postcondition, which is always 17468 -- within a subprogram body, even though the current scope may be the 17469 -- enclosing scope of the subprogram. 17470 17471 if Nkind (N) = N_Procedure_Call_Statement 17472 and then Is_Entity_Name (Name (N)) 17473 and then Chars (Entity (Name (N))) = Name_uPostconditions 17474 then 17475 return; 17476 end if; 17477 17478 -- Here we have a reference at elaboration time that must be checked 17479 17480 if Debug_Flag_Underscore_LL then 17481 Write_Str (" Check_Elab_Ref: "); 17482 17483 if Nkind (N) = N_Attribute_Reference then 17484 if not Is_Entity_Name (Prefix (N)) then 17485 Write_Str ("<<not entity name>>"); 17486 else 17487 Write_Name (Chars (Entity (Prefix (N)))); 17488 end if; 17489 17490 Write_Str ("'Access"); 17491 17492 elsif No (Name (N)) or else not Is_Entity_Name (Name (N)) then 17493 Write_Str ("<<not entity name>> "); 17494 17495 else 17496 Write_Name (Chars (Entity (Name (N)))); 17497 end if; 17498 17499 Write_Str (" reference at "); 17500 Write_Location (Sloc (N)); 17501 Write_Eol; 17502 end if; 17503 17504 -- Climb up the tree to make sure we are not inside default expression 17505 -- of a parameter specification or a record component, since in both 17506 -- these cases, we will be doing the actual reference later, not now, 17507 -- and it is at the time of the actual reference (statically speaking) 17508 -- that we must do our static check, not at the time of its initial 17509 -- analysis). 17510 17511 -- However, we have to check references within component definitions 17512 -- (e.g. a function call that determines an array component bound), 17513 -- so we terminate the loop in that case. 17514 17515 P := Parent (N); 17516 while Present (P) loop 17517 if Nkind (P) in N_Parameter_Specification | N_Component_Declaration 17518 then 17519 return; 17520 17521 -- The reference occurs within the constraint of a component, 17522 -- so it must be checked. 17523 17524 elsif Nkind (P) = N_Component_Definition then 17525 exit; 17526 17527 else 17528 P := Parent (P); 17529 end if; 17530 end loop; 17531 17532 -- Stuff that happens only at the outer level 17533 17534 if No (Outer_Scope) then 17535 Elab_Visited.Set_Last (0); 17536 17537 -- Nothing to do if current scope is Standard (this is a bit odd, but 17538 -- it happens in the case of generic instantiations). 17539 17540 C_Scope := Current_Scope; 17541 17542 if C_Scope = Standard_Standard then 17543 return; 17544 end if; 17545 17546 -- First case, we are in elaboration code 17547 17548 From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit; 17549 17550 if From_Elab_Code then 17551 17552 -- Complain if ref that comes from source in preelaborated unit 17553 -- and we are not inside a subprogram (i.e. we are in elab code). 17554 17555 -- Ada 2022 (AI12-0175): Calls to certain functions that are 17556 -- essentially unchecked conversions are preelaborable. 17557 17558 if Comes_From_Source (N) 17559 and then In_Preelaborated_Unit 17560 and then not In_Inlined_Body 17561 and then Nkind (N) /= N_Attribute_Reference 17562 and then not (Ada_Version >= Ada_2022 17563 and then Is_Preelaborable_Construct (N)) 17564 then 17565 Error_Preelaborated_Call (N); 17566 return; 17567 end if; 17568 17569 -- Second case, we are inside a subprogram or concurrent unit, which 17570 -- means we are not in elaboration code. 17571 17572 else 17573 -- In this case, the issue is whether we are inside the 17574 -- declarative part of the unit in which we live, or inside its 17575 -- statements. In the latter case, there is no issue of ABE calls 17576 -- at this level (a call from outside to the unit in which we live 17577 -- might cause an ABE, but that will be detected when we analyze 17578 -- that outer level call, as it recurses into the called unit). 17579 17580 -- Climb up the tree, doing this test, and also testing for being 17581 -- inside a default expression, which, as discussed above, is not 17582 -- checked at this stage. 17583 17584 declare 17585 P : Node_Id; 17586 L : List_Id; 17587 17588 begin 17589 P := N; 17590 loop 17591 -- If we find a parentless subtree, it seems safe to assume 17592 -- that we are not in a declarative part and that no 17593 -- checking is required. 17594 17595 if No (P) then 17596 return; 17597 end if; 17598 17599 if Is_List_Member (P) then 17600 L := List_Containing (P); 17601 P := Parent (L); 17602 else 17603 L := No_List; 17604 P := Parent (P); 17605 end if; 17606 17607 exit when Nkind (P) = N_Subunit; 17608 17609 -- Filter out case of default expressions, where we do not 17610 -- do the check at this stage. 17611 17612 if Nkind (P) in 17613 N_Parameter_Specification | N_Component_Declaration 17614 then 17615 return; 17616 end if; 17617 17618 -- A protected body has no elaboration code and contains 17619 -- only other bodies. 17620 17621 if Nkind (P) = N_Protected_Body then 17622 return; 17623 17624 elsif Nkind (P) in N_Subprogram_Body 17625 | N_Task_Body 17626 | N_Block_Statement 17627 | N_Entry_Body 17628 then 17629 if L = Declarations (P) then 17630 exit; 17631 17632 -- We are not in elaboration code, but we are doing 17633 -- dynamic elaboration checks, in this case, we still 17634 -- need to do the reference, since the subprogram we are 17635 -- in could be called from another unit, also in dynamic 17636 -- elaboration check mode, at elaboration time. 17637 17638 elsif Dynamic_Elaboration_Checks then 17639 17640 -- We provide a debug flag to disable this check. That 17641 -- way we have an easy work around for regressions 17642 -- that are caused by this new check. This debug flag 17643 -- can be removed later. 17644 17645 if Debug_Flag_DD then 17646 return; 17647 end if; 17648 17649 -- Do the check in this case 17650 17651 exit; 17652 17653 elsif Nkind (P) = N_Task_Body then 17654 17655 -- The check is deferred until Check_Task_Activation 17656 -- but we need to capture local suppress pragmas 17657 -- that may inhibit checks on this call. 17658 17659 Ent := Get_Referenced_Ent (N); 17660 17661 if No (Ent) then 17662 return; 17663 17664 elsif Elaboration_Checks_Suppressed (Current_Scope) 17665 or else Elaboration_Checks_Suppressed (Ent) 17666 or else Elaboration_Checks_Suppressed (Scope (Ent)) 17667 then 17668 if Nkind (N) in N_Subprogram_Call then 17669 Set_No_Elaboration_Check (N); 17670 end if; 17671 end if; 17672 17673 return; 17674 17675 -- Static model, call is not in elaboration code, we 17676 -- never need to worry, because in the static model the 17677 -- top-level caller always takes care of things. 17678 17679 else 17680 return; 17681 end if; 17682 end if; 17683 end loop; 17684 end; 17685 end if; 17686 end if; 17687 17688 Ent := Get_Referenced_Ent (N); 17689 17690 if No (Ent) then 17691 return; 17692 end if; 17693 17694 -- Determine whether a prior call to the same subprogram was already 17695 -- examined within the same context. If this is the case, then there is 17696 -- no need to proceed with the various warnings and checks because the 17697 -- work was already done for the previous call. 17698 17699 declare 17700 Self : constant Visited_Element := 17701 (Subp_Id => Ent, Context => Parent (N)); 17702 17703 begin 17704 for Index in 1 .. Elab_Visited.Last loop 17705 if Self = Elab_Visited.Table (Index) then 17706 return; 17707 end if; 17708 end loop; 17709 end; 17710 17711 -- See if we need to analyze this reference. We analyze it if either of 17712 -- the following conditions is met: 17713 17714 -- It is an inner level call (since in this case it was triggered 17715 -- by an outer level call from elaboration code), but only if the 17716 -- call is within the scope of the original outer level call. 17717 17718 -- It is an outer level reference from elaboration code, or a call to 17719 -- an entity is in the same elaboration scope. 17720 17721 -- And in these cases, we will check both inter-unit calls and 17722 -- intra-unit (within a single unit) calls. 17723 17724 C_Scope := Current_Scope; 17725 17726 -- If not outer level reference, then we follow it if it is within the 17727 -- original scope of the outer reference. 17728 17729 if Present (Outer_Scope) 17730 and then Within (Scope (Ent), Outer_Scope) 17731 then 17732 Set_C_Scope; 17733 Check_A_Call 17734 (N => N, 17735 E => Ent, 17736 Outer_Scope => Outer_Scope, 17737 Inter_Unit_Only => False, 17738 In_Init_Proc => In_Init_Proc); 17739 17740 -- Nothing to do if elaboration checks suppressed for this scope. 17741 -- However, an interesting exception, the fact that elaboration checks 17742 -- are suppressed within an instance (because we can trace the body when 17743 -- we process the template) does not extend to calls to generic formal 17744 -- subprograms. 17745 17746 elsif Elaboration_Checks_Suppressed (Current_Scope) 17747 and then not Is_Call_Of_Generic_Formal (N) 17748 then 17749 null; 17750 17751 elsif From_Elab_Code then 17752 Set_C_Scope; 17753 Check_A_Call (N, Ent, Standard_Standard, Inter_Unit_Only => False); 17754 17755 elsif Same_Elaboration_Scope (C_Scope, Scope (Ent)) then 17756 Set_C_Scope; 17757 Check_A_Call (N, Ent, Scope (Ent), Inter_Unit_Only => False); 17758 17759 -- If none of those cases holds, but Dynamic_Elaboration_Checks mode 17760 -- is set, then we will do the check, but only in the inter-unit case 17761 -- (this is to accommodate unguarded elaboration calls from other units 17762 -- in which this same mode is set). We don't want warnings in this case, 17763 -- it would generate warnings having nothing to do with elaboration. 17764 17765 elsif Dynamic_Elaboration_Checks then 17766 Set_C_Scope; 17767 Check_A_Call 17768 (N, 17769 Ent, 17770 Standard_Standard, 17771 Inter_Unit_Only => True, 17772 Generate_Warnings => False); 17773 17774 -- Otherwise nothing to do 17775 17776 else 17777 return; 17778 end if; 17779 17780 -- A call to an Init_Proc in elaboration code may bring additional 17781 -- dependencies, if some of the record components thereof have 17782 -- initializations that are function calls that come from source. We 17783 -- treat the current node as a call to each of these functions, to check 17784 -- their elaboration impact. 17785 17786 if Is_Init_Proc (Ent) and then From_Elab_Code then 17787 Process_Init_Proc : declare 17788 Unit_Decl : constant Node_Id := Unit_Declaration_Node (Ent); 17789 17790 function Check_Init_Call (Nod : Node_Id) return Traverse_Result; 17791 -- Find subprogram calls within body of Init_Proc for Traverse 17792 -- instantiation below. 17793 17794 procedure Traverse_Body is new Traverse_Proc (Check_Init_Call); 17795 -- Traversal procedure to find all calls with body of Init_Proc 17796 17797 --------------------- 17798 -- Check_Init_Call -- 17799 --------------------- 17800 17801 function Check_Init_Call (Nod : Node_Id) return Traverse_Result is 17802 Func : Entity_Id; 17803 17804 begin 17805 if Nkind (Nod) in N_Subprogram_Call 17806 and then Is_Entity_Name (Name (Nod)) 17807 then 17808 Func := Entity (Name (Nod)); 17809 17810 if Comes_From_Source (Func) then 17811 Check_A_Call 17812 (N, Func, Standard_Standard, Inter_Unit_Only => True); 17813 end if; 17814 17815 return OK; 17816 17817 else 17818 return OK; 17819 end if; 17820 end Check_Init_Call; 17821 17822 -- Start of processing for Process_Init_Proc 17823 17824 begin 17825 if Nkind (Unit_Decl) = N_Subprogram_Body then 17826 Traverse_Body (Handled_Statement_Sequence (Unit_Decl)); 17827 end if; 17828 end Process_Init_Proc; 17829 end if; 17830 end Check_Elab_Call; 17831 17832 ----------------------- 17833 -- Check_Elab_Assign -- 17834 ----------------------- 17835 17836 procedure Check_Elab_Assign (N : Node_Id) is 17837 Ent : Entity_Id; 17838 Scop : Entity_Id; 17839 17840 Pkg_Spec : Entity_Id; 17841 Pkg_Body : Entity_Id; 17842 17843 begin 17844 pragma Assert (Legacy_Elaboration_Checks); 17845 17846 -- For record or array component, check prefix. If it is an access type, 17847 -- then there is nothing to do (we do not know what is being assigned), 17848 -- but otherwise this is an assignment to the prefix. 17849 17850 if Nkind (N) in N_Indexed_Component | N_Selected_Component | N_Slice then 17851 if not Is_Access_Type (Etype (Prefix (N))) then 17852 Check_Elab_Assign (Prefix (N)); 17853 end if; 17854 17855 return; 17856 end if; 17857 17858 -- For type conversion, check expression 17859 17860 if Nkind (N) = N_Type_Conversion then 17861 Check_Elab_Assign (Expression (N)); 17862 return; 17863 end if; 17864 17865 -- Nothing to do if this is not an entity reference otherwise get entity 17866 17867 if Is_Entity_Name (N) then 17868 Ent := Entity (N); 17869 else 17870 return; 17871 end if; 17872 17873 -- What we are looking for is a reference in the body of a package that 17874 -- modifies a variable declared in the visible part of the package spec. 17875 17876 if Present (Ent) 17877 and then Comes_From_Source (N) 17878 and then not Suppress_Elaboration_Warnings (Ent) 17879 and then Ekind (Ent) = E_Variable 17880 and then not In_Private_Part (Ent) 17881 and then Is_Library_Level_Entity (Ent) 17882 then 17883 Scop := Current_Scope; 17884 loop 17885 if No (Scop) or else Scop = Standard_Standard then 17886 return; 17887 elsif Ekind (Scop) = E_Package 17888 and then Is_Compilation_Unit (Scop) 17889 then 17890 exit; 17891 else 17892 Scop := Scope (Scop); 17893 end if; 17894 end loop; 17895 17896 -- Here Scop points to the containing library package 17897 17898 Pkg_Spec := Scop; 17899 Pkg_Body := Body_Entity (Pkg_Spec); 17900 17901 -- All OK if the package has an Elaborate_Body pragma 17902 17903 if Has_Pragma_Elaborate_Body (Scop) then 17904 return; 17905 end if; 17906 17907 -- OK if entity being modified is not in containing package spec 17908 17909 if not In_Same_Source_Unit (Scop, Ent) then 17910 return; 17911 end if; 17912 17913 -- All OK if entity appears in generic package or generic instance. 17914 -- We just get too messed up trying to give proper warnings in the 17915 -- presence of generics. Better no message than a junk one. 17916 17917 Scop := Scope (Ent); 17918 while Present (Scop) and then Scop /= Pkg_Spec loop 17919 if Ekind (Scop) = E_Generic_Package then 17920 return; 17921 elsif Ekind (Scop) = E_Package 17922 and then Is_Generic_Instance (Scop) 17923 then 17924 return; 17925 end if; 17926 17927 Scop := Scope (Scop); 17928 end loop; 17929 17930 -- All OK if in task, don't issue warnings there 17931 17932 if In_Task_Activation then 17933 return; 17934 end if; 17935 17936 -- OK if no package body 17937 17938 if No (Pkg_Body) then 17939 return; 17940 end if; 17941 17942 -- OK if reference is not in package body 17943 17944 if not In_Same_Source_Unit (Pkg_Body, N) then 17945 return; 17946 end if; 17947 17948 -- OK if package body has no handled statement sequence 17949 17950 declare 17951 HSS : constant Node_Id := 17952 Handled_Statement_Sequence (Declaration_Node (Pkg_Body)); 17953 begin 17954 if No (HSS) or else not Comes_From_Source (HSS) then 17955 return; 17956 end if; 17957 end; 17958 17959 -- We definitely have a case of a modification of an entity in 17960 -- the package spec from the elaboration code of the package body. 17961 -- We may not give the warning (because there are some additional 17962 -- checks to avoid too many false positives), but it would be a good 17963 -- idea for the binder to try to keep the body elaboration close to 17964 -- the spec elaboration. 17965 17966 Set_Elaborate_Body_Desirable (Pkg_Spec); 17967 17968 -- All OK in gnat mode (we know what we are doing) 17969 17970 if GNAT_Mode then 17971 return; 17972 end if; 17973 17974 -- All OK if all warnings suppressed 17975 17976 if Warning_Mode = Suppress then 17977 return; 17978 end if; 17979 17980 -- All OK if elaboration checks suppressed for entity 17981 17982 if Checks_May_Be_Suppressed (Ent) 17983 and then Is_Check_Suppressed (Ent, Elaboration_Check) 17984 then 17985 return; 17986 end if; 17987 17988 -- OK if the entity is initialized. Note that the No_Initialization 17989 -- flag usually means that the initialization has been rewritten into 17990 -- assignments, but that still counts for us. 17991 17992 declare 17993 Decl : constant Node_Id := Declaration_Node (Ent); 17994 begin 17995 if Nkind (Decl) = N_Object_Declaration 17996 and then (Present (Expression (Decl)) 17997 or else No_Initialization (Decl)) 17998 then 17999 return; 18000 end if; 18001 end; 18002 18003 -- Here is where we give the warning 18004 18005 -- All OK if warnings suppressed on the entity 18006 18007 if not Has_Warnings_Off (Ent) then 18008 Error_Msg_Sloc := Sloc (Ent); 18009 18010 Error_Msg_NE 18011 ("??& can be accessed by clients before this initialization", 18012 N, Ent); 18013 Error_Msg_NE 18014 ("\??add Elaborate_Body to spec to ensure & is initialized", 18015 N, Ent); 18016 end if; 18017 18018 if not All_Errors_Mode then 18019 Set_Suppress_Elaboration_Warnings (Ent); 18020 end if; 18021 end if; 18022 end Check_Elab_Assign; 18023 18024 ---------------------- 18025 -- Check_Elab_Calls -- 18026 ---------------------- 18027 18028 -- WARNING: This routine manages SPARK regions 18029 18030 procedure Check_Elab_Calls is 18031 Saved_SM : SPARK_Mode_Type; 18032 Saved_SMP : Node_Id; 18033 18034 begin 18035 pragma Assert (Legacy_Elaboration_Checks); 18036 18037 -- If expansion is disabled, do not generate any checks, unless we 18038 -- are in GNATprove mode, so that errors are issued in GNATprove for 18039 -- violations of static elaboration rules in SPARK code. Also skip 18040 -- checks if any subunits are missing because in either case we lack the 18041 -- full information that we need, and no object file will be created in 18042 -- any case. 18043 18044 if (not Expander_Active and not GNATprove_Mode) 18045 or else Is_Generic_Unit (Cunit_Entity (Main_Unit)) 18046 or else Subunits_Missing 18047 then 18048 return; 18049 end if; 18050 18051 -- Skip delayed calls if we had any errors 18052 18053 if Serious_Errors_Detected = 0 then 18054 Delaying_Elab_Checks := False; 18055 Expander_Mode_Save_And_Set (True); 18056 18057 for J in Delay_Check.First .. Delay_Check.Last loop 18058 Push_Scope (Delay_Check.Table (J).Curscop); 18059 From_Elab_Code := Delay_Check.Table (J).From_Elab_Code; 18060 In_Task_Activation := Delay_Check.Table (J).In_Task_Activation; 18061 18062 Saved_SM := SPARK_Mode; 18063 Saved_SMP := SPARK_Mode_Pragma; 18064 18065 -- Set appropriate value of SPARK_Mode 18066 18067 if Delay_Check.Table (J).From_SPARK_Code then 18068 SPARK_Mode := On; 18069 end if; 18070 18071 Check_Internal_Call_Continue 18072 (N => Delay_Check.Table (J).N, 18073 E => Delay_Check.Table (J).E, 18074 Outer_Scope => Delay_Check.Table (J).Outer_Scope, 18075 Orig_Ent => Delay_Check.Table (J).Orig_Ent); 18076 18077 Restore_SPARK_Mode (Saved_SM, Saved_SMP); 18078 Pop_Scope; 18079 end loop; 18080 18081 -- Set Delaying_Elab_Checks back on for next main compilation 18082 18083 Expander_Mode_Restore; 18084 Delaying_Elab_Checks := True; 18085 end if; 18086 end Check_Elab_Calls; 18087 18088 ------------------------------ 18089 -- Check_Elab_Instantiation -- 18090 ------------------------------ 18091 18092 procedure Check_Elab_Instantiation 18093 (N : Node_Id; 18094 Outer_Scope : Entity_Id := Empty) 18095 is 18096 Ent : Entity_Id; 18097 18098 begin 18099 pragma Assert (Legacy_Elaboration_Checks); 18100 18101 -- Check for and deal with bad instantiation case. There is some 18102 -- duplicated code here, but we will worry about this later ??? 18103 18104 Check_Bad_Instantiation (N); 18105 18106 if Is_Known_Guaranteed_ABE (N) then 18107 return; 18108 end if; 18109 18110 -- Nothing to do if we do not have an instantiation (happens in some 18111 -- error cases, and also in the formal package declaration case) 18112 18113 if Nkind (N) not in N_Generic_Instantiation then 18114 return; 18115 end if; 18116 18117 -- Nothing to do if inside a generic template 18118 18119 if Inside_A_Generic then 18120 return; 18121 end if; 18122 18123 -- Nothing to do if the instantiation is not in the main unit 18124 18125 if not In_Extended_Main_Code_Unit (N) then 18126 return; 18127 end if; 18128 18129 Ent := Get_Generic_Entity (N); 18130 From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit; 18131 18132 -- See if we need to analyze this instantiation. We analyze it if 18133 -- either of the following conditions is met: 18134 18135 -- It is an inner level instantiation (since in this case it was 18136 -- triggered by an outer level call from elaboration code), but 18137 -- only if the instantiation is within the scope of the original 18138 -- outer level call. 18139 18140 -- It is an outer level instantiation from elaboration code, or the 18141 -- instantiated entity is in the same elaboration scope. 18142 18143 -- And in these cases, we will check both the inter-unit case and 18144 -- the intra-unit (within a single unit) case. 18145 18146 C_Scope := Current_Scope; 18147 18148 if Present (Outer_Scope) and then Within (Scope (Ent), Outer_Scope) then 18149 Set_C_Scope; 18150 Check_A_Call (N, Ent, Outer_Scope, Inter_Unit_Only => False); 18151 18152 elsif From_Elab_Code then 18153 Set_C_Scope; 18154 Check_A_Call (N, Ent, Standard_Standard, Inter_Unit_Only => False); 18155 18156 elsif Same_Elaboration_Scope (C_Scope, Scope (Ent)) then 18157 Set_C_Scope; 18158 Check_A_Call (N, Ent, Scope (Ent), Inter_Unit_Only => False); 18159 18160 -- If none of those cases holds, but Dynamic_Elaboration_Checks mode is 18161 -- set, then we will do the check, but only in the inter-unit case (this 18162 -- is to accommodate unguarded elaboration calls from other units in 18163 -- which this same mode is set). We inhibit warnings in this case, since 18164 -- this instantiation is not occurring in elaboration code. 18165 18166 elsif Dynamic_Elaboration_Checks then 18167 Set_C_Scope; 18168 Check_A_Call 18169 (N, 18170 Ent, 18171 Standard_Standard, 18172 Inter_Unit_Only => True, 18173 Generate_Warnings => False); 18174 18175 else 18176 return; 18177 end if; 18178 end Check_Elab_Instantiation; 18179 18180 ------------------------- 18181 -- Check_Internal_Call -- 18182 ------------------------- 18183 18184 procedure Check_Internal_Call 18185 (N : Node_Id; 18186 E : Entity_Id; 18187 Outer_Scope : Entity_Id; 18188 Orig_Ent : Entity_Id) 18189 is 18190 function Within_Initial_Condition (Call : Node_Id) return Boolean; 18191 -- Determine whether call Call occurs within pragma Initial_Condition or 18192 -- pragma Check with check_kind set to Initial_Condition. 18193 18194 ------------------------------ 18195 -- Within_Initial_Condition -- 18196 ------------------------------ 18197 18198 function Within_Initial_Condition (Call : Node_Id) return Boolean is 18199 Args : List_Id; 18200 Nam : Name_Id; 18201 Par : Node_Id; 18202 18203 begin 18204 -- Traverse the parent chain looking for an enclosing pragma 18205 18206 Par := Call; 18207 while Present (Par) loop 18208 if Nkind (Par) = N_Pragma then 18209 Nam := Pragma_Name (Par); 18210 18211 -- Pragma Initial_Condition appears in its alternative from as 18212 -- Check (Initial_Condition, ...). 18213 18214 if Nam = Name_Check then 18215 Args := Pragma_Argument_Associations (Par); 18216 18217 -- Pragma Check should have at least two arguments 18218 18219 pragma Assert (Present (Args)); 18220 18221 return 18222 Chars (Expression (First (Args))) = Name_Initial_Condition; 18223 18224 -- Direct match 18225 18226 elsif Nam = Name_Initial_Condition then 18227 return True; 18228 18229 -- Since pragmas are never nested within other pragmas, stop 18230 -- the traversal. 18231 18232 else 18233 return False; 18234 end if; 18235 18236 -- Prevent the search from going too far 18237 18238 elsif Is_Body_Or_Package_Declaration (Par) then 18239 exit; 18240 end if; 18241 18242 Par := Parent (Par); 18243 18244 -- If assertions are not enabled, the check pragma is rewritten 18245 -- as an if_statement in sem_prag, to generate various warnings 18246 -- on boolean expressions. Retrieve the original pragma. 18247 18248 if Nkind (Original_Node (Par)) = N_Pragma then 18249 Par := Original_Node (Par); 18250 end if; 18251 end loop; 18252 18253 return False; 18254 end Within_Initial_Condition; 18255 18256 -- Local variables 18257 18258 Inst_Case : constant Boolean := Nkind (N) in N_Generic_Instantiation; 18259 18260 -- Start of processing for Check_Internal_Call 18261 18262 begin 18263 -- For P'Access, we want to warn if the -gnatw.f switch is set, and the 18264 -- node comes from source. 18265 18266 if Nkind (N) = N_Attribute_Reference 18267 and then ((not Warn_On_Elab_Access and then not Debug_Flag_Dot_O) 18268 or else not Comes_From_Source (N)) 18269 then 18270 return; 18271 18272 -- If not function or procedure call, instantiation, or 'Access, then 18273 -- ignore call (this happens in some error cases and rewriting cases). 18274 18275 elsif Nkind (N) not in N_Attribute_Reference 18276 | N_Function_Call 18277 | N_Procedure_Call_Statement 18278 and then not Inst_Case 18279 then 18280 return; 18281 18282 -- Nothing to do if this is a call or instantiation that has already 18283 -- been found to be a sure ABE. 18284 18285 elsif Nkind (N) /= N_Attribute_Reference 18286 and then Is_Known_Guaranteed_ABE (N) 18287 then 18288 return; 18289 18290 -- Nothing to do if errors already detected (avoid cascaded errors) 18291 18292 elsif Serious_Errors_Detected /= 0 then 18293 return; 18294 18295 -- Nothing to do if not in full analysis mode 18296 18297 elsif not Full_Analysis then 18298 return; 18299 18300 -- Nothing to do if analyzing in special spec-expression mode, since the 18301 -- call is not actually being made at this time. 18302 18303 elsif In_Spec_Expression then 18304 return; 18305 18306 -- Nothing to do for call to intrinsic subprogram 18307 18308 elsif Is_Intrinsic_Subprogram (E) then 18309 return; 18310 18311 -- Nothing to do if call is within a generic unit 18312 18313 elsif Inside_A_Generic then 18314 return; 18315 18316 -- Nothing to do when the call appears within pragma Initial_Condition. 18317 -- The pragma is part of the elaboration statements of a package body 18318 -- and may only call external subprograms or subprograms whose body is 18319 -- already available. 18320 18321 elsif Within_Initial_Condition (N) then 18322 return; 18323 end if; 18324 18325 -- Delay this call if we are still delaying calls 18326 18327 if Delaying_Elab_Checks then 18328 Delay_Check.Append 18329 ((N => N, 18330 E => E, 18331 Orig_Ent => Orig_Ent, 18332 Curscop => Current_Scope, 18333 Outer_Scope => Outer_Scope, 18334 From_Elab_Code => From_Elab_Code, 18335 In_Task_Activation => In_Task_Activation, 18336 From_SPARK_Code => SPARK_Mode = On)); 18337 return; 18338 18339 -- Otherwise, call phase 2 continuation right now 18340 18341 else 18342 Check_Internal_Call_Continue (N, E, Outer_Scope, Orig_Ent); 18343 end if; 18344 end Check_Internal_Call; 18345 18346 ---------------------------------- 18347 -- Check_Internal_Call_Continue -- 18348 ---------------------------------- 18349 18350 procedure Check_Internal_Call_Continue 18351 (N : Node_Id; 18352 E : Entity_Id; 18353 Outer_Scope : Entity_Id; 18354 Orig_Ent : Entity_Id) 18355 is 18356 function Find_Elab_Reference (N : Node_Id) return Traverse_Result; 18357 -- Function applied to each node as we traverse the body. Checks for 18358 -- call or entity reference that needs checking, and if so checks it. 18359 -- Always returns OK, so entire tree is traversed, except that as 18360 -- described below subprogram bodies are skipped for now. 18361 18362 procedure Traverse is new Atree.Traverse_Proc (Find_Elab_Reference); 18363 -- Traverse procedure using above Find_Elab_Reference function 18364 18365 ------------------------- 18366 -- Find_Elab_Reference -- 18367 ------------------------- 18368 18369 function Find_Elab_Reference (N : Node_Id) return Traverse_Result is 18370 Actual : Node_Id; 18371 18372 begin 18373 -- If user has specified that there are no entry calls in elaboration 18374 -- code, do not trace past an accept statement, because the rendez- 18375 -- vous will happen after elaboration. 18376 18377 if Nkind (Original_Node (N)) in 18378 N_Accept_Statement | N_Selective_Accept 18379 and then Restriction_Active (No_Entry_Calls_In_Elaboration_Code) 18380 then 18381 return Abandon; 18382 18383 -- If we have a function call, check it 18384 18385 elsif Nkind (N) = N_Function_Call then 18386 Check_Elab_Call (N, Outer_Scope); 18387 return OK; 18388 18389 -- If we have a procedure call, check the call, and also check 18390 -- arguments that are assignments (OUT or IN OUT mode formals). 18391 18392 elsif Nkind (N) = N_Procedure_Call_Statement then 18393 Check_Elab_Call (N, Outer_Scope, In_Init_Proc => Is_Init_Proc (E)); 18394 18395 Actual := First_Actual (N); 18396 while Present (Actual) loop 18397 if Known_To_Be_Assigned (Actual) then 18398 Check_Elab_Assign (Actual); 18399 end if; 18400 18401 Next_Actual (Actual); 18402 end loop; 18403 18404 return OK; 18405 18406 -- If we have an access attribute for a subprogram, check it. 18407 -- Suppress this behavior under debug flag. 18408 18409 elsif not Debug_Flag_Dot_UU 18410 and then Nkind (N) = N_Attribute_Reference 18411 and then 18412 Attribute_Name (N) in Name_Access | Name_Unrestricted_Access 18413 and then Is_Entity_Name (Prefix (N)) 18414 and then Is_Subprogram (Entity (Prefix (N))) 18415 then 18416 Check_Elab_Call (N, Outer_Scope); 18417 return OK; 18418 18419 -- In SPARK mode, if we have an entity reference to a variable, then 18420 -- check it. For now we consider any reference. 18421 18422 elsif SPARK_Mode = On 18423 and then Nkind (N) in N_Has_Entity 18424 and then Present (Entity (N)) 18425 and then Ekind (Entity (N)) = E_Variable 18426 then 18427 Check_Elab_Call (N, Outer_Scope); 18428 return OK; 18429 18430 -- If we have a generic instantiation, check it 18431 18432 elsif Nkind (N) in N_Generic_Instantiation then 18433 Check_Elab_Instantiation (N, Outer_Scope); 18434 return OK; 18435 18436 -- Skip subprogram bodies that come from source (wait for call to 18437 -- analyze these). The reason for the come from source test is to 18438 -- avoid catching task bodies. 18439 18440 -- For task bodies, we should really avoid these too, waiting for the 18441 -- task activation, but that's too much trouble to catch for now, so 18442 -- we go in unconditionally. This is not so terrible, it means the 18443 -- error backtrace is not quite complete, and we are too eager to 18444 -- scan bodies of tasks that are unused, but this is hardly very 18445 -- significant. 18446 18447 elsif Nkind (N) = N_Subprogram_Body 18448 and then Comes_From_Source (N) 18449 then 18450 return Skip; 18451 18452 elsif Nkind (N) = N_Assignment_Statement 18453 and then Comes_From_Source (N) 18454 then 18455 Check_Elab_Assign (Name (N)); 18456 return OK; 18457 18458 else 18459 return OK; 18460 end if; 18461 end Find_Elab_Reference; 18462 18463 Inst_Case : constant Boolean := Is_Generic_Unit (E); 18464 Loc : constant Source_Ptr := Sloc (N); 18465 18466 Ebody : Entity_Id; 18467 Sbody : Node_Id; 18468 18469 -- Start of processing for Check_Internal_Call_Continue 18470 18471 begin 18472 -- Save outer level call if at outer level 18473 18474 if Elab_Call.Last = 0 then 18475 Outer_Level_Sloc := Loc; 18476 end if; 18477 18478 -- If the call is to a function that renames a literal, no check needed 18479 18480 if Ekind (E) = E_Enumeration_Literal then 18481 return; 18482 end if; 18483 18484 -- Register the subprogram as examined within this particular context. 18485 -- This ensures that calls to the same subprogram but in different 18486 -- contexts receive warnings and checks of their own since the calls 18487 -- may be reached through different flow paths. 18488 18489 Elab_Visited.Append ((Subp_Id => E, Context => Parent (N))); 18490 18491 Sbody := Unit_Declaration_Node (E); 18492 18493 if Nkind (Sbody) not in N_Subprogram_Body | N_Package_Body then 18494 Ebody := Corresponding_Body (Sbody); 18495 18496 if No (Ebody) then 18497 return; 18498 else 18499 Sbody := Unit_Declaration_Node (Ebody); 18500 end if; 18501 end if; 18502 18503 -- If the body appears after the outer level call or instantiation then 18504 -- we have an error case handled below. 18505 18506 if Earlier_In_Extended_Unit (Outer_Level_Sloc, Sloc (Sbody)) 18507 and then not In_Task_Activation 18508 then 18509 null; 18510 18511 -- If we have the instantiation case we are done, since we now know that 18512 -- the body of the generic appeared earlier. 18513 18514 elsif Inst_Case then 18515 return; 18516 18517 -- Otherwise we have a call, so we trace through the called body to see 18518 -- if it has any problems. 18519 18520 else 18521 pragma Assert (Nkind (Sbody) = N_Subprogram_Body); 18522 18523 Elab_Call.Append ((Cloc => Loc, Ent => E)); 18524 18525 if Debug_Flag_Underscore_LL then 18526 Write_Str ("Elab_Call.Last = "); 18527 Write_Int (Int (Elab_Call.Last)); 18528 Write_Str (" Ent = "); 18529 Write_Name (Chars (E)); 18530 Write_Str (" at "); 18531 Write_Location (Sloc (N)); 18532 Write_Eol; 18533 end if; 18534 18535 -- Now traverse declarations and statements of subprogram body. Note 18536 -- that we cannot simply Traverse (Sbody), since traverse does not 18537 -- normally visit subprogram bodies. 18538 18539 declare 18540 Decl : Node_Id; 18541 begin 18542 Decl := First (Declarations (Sbody)); 18543 while Present (Decl) loop 18544 Traverse (Decl); 18545 Next (Decl); 18546 end loop; 18547 end; 18548 18549 Traverse (Handled_Statement_Sequence (Sbody)); 18550 18551 Elab_Call.Decrement_Last; 18552 return; 18553 end if; 18554 18555 -- Here is the case of calling a subprogram where the body has not yet 18556 -- been encountered. A warning message is needed, except if this is the 18557 -- case of appearing within an aspect specification that results in 18558 -- a check call, we do not really have such a situation, so no warning 18559 -- is needed (e.g. the case of a precondition, where the call appears 18560 -- textually before the body, but in actual fact is moved to the 18561 -- appropriate subprogram body and so does not need a check). 18562 18563 declare 18564 P : Node_Id; 18565 O : Node_Id; 18566 18567 begin 18568 P := Parent (N); 18569 loop 18570 -- Keep looking at parents if we are still in the subexpression 18571 18572 if Nkind (P) in N_Subexpr then 18573 P := Parent (P); 18574 18575 -- Here P is the parent of the expression, check for special case 18576 18577 else 18578 O := Original_Node (P); 18579 18580 -- Definitely not the special case if orig node is not a pragma 18581 18582 exit when Nkind (O) /= N_Pragma; 18583 18584 -- Check we have an If statement or a null statement (happens 18585 -- when the If has been expanded to be True). 18586 18587 exit when Nkind (P) not in N_If_Statement | N_Null_Statement; 18588 18589 -- Our special case will be indicated either by the pragma 18590 -- coming from an aspect ... 18591 18592 if Present (Corresponding_Aspect (O)) then 18593 return; 18594 18595 -- Or, in the case of an initial condition, specifically by a 18596 -- Check pragma specifying an Initial_Condition check. 18597 18598 elsif Pragma_Name (O) = Name_Check 18599 and then 18600 Chars 18601 (Expression (First (Pragma_Argument_Associations (O)))) = 18602 Name_Initial_Condition 18603 then 18604 return; 18605 18606 -- For anything else, we have an error 18607 18608 else 18609 exit; 18610 end if; 18611 end if; 18612 end loop; 18613 end; 18614 18615 -- Not that special case, warning and dynamic check is required 18616 18617 -- If we have nothing in the call stack, then this is at the outer 18618 -- level, and the ABE is bound to occur, unless it's a 'Access, or 18619 -- it's a renaming. 18620 18621 if Elab_Call.Last = 0 then 18622 Error_Msg_Warn := SPARK_Mode /= On; 18623 18624 declare 18625 Insert_Check : Boolean := True; 18626 -- This flag is set to True if an elaboration check should be 18627 -- inserted. 18628 18629 begin 18630 if In_Task_Activation then 18631 Insert_Check := False; 18632 18633 elsif Inst_Case then 18634 Error_Msg_NE 18635 ("cannot instantiate& before body seen<<", N, Orig_Ent); 18636 18637 elsif Nkind (N) = N_Attribute_Reference then 18638 Error_Msg_NE 18639 ("Access attribute of & before body seen<<", N, Orig_Ent); 18640 Error_Msg_N 18641 ("\possible Program_Error on later references<<", N); 18642 Insert_Check := False; 18643 18644 elsif Nkind (Unit_Declaration_Node (Orig_Ent)) /= 18645 N_Subprogram_Renaming_Declaration 18646 or else Is_Generic_Actual_Subprogram (Orig_Ent) 18647 then 18648 Error_Msg_NE 18649 ("cannot call& before body seen<<", N, Orig_Ent); 18650 else 18651 Insert_Check := False; 18652 end if; 18653 18654 if Insert_Check then 18655 Error_Msg_N ("\Program_Error [<<", N); 18656 Insert_Elab_Check (N); 18657 end if; 18658 end; 18659 18660 -- Call is not at outer level 18661 18662 else 18663 -- Do not generate elaboration checks in GNATprove mode because the 18664 -- elaboration counter and the check are both forms of expansion. 18665 18666 if GNATprove_Mode then 18667 null; 18668 18669 -- Generate an elaboration check 18670 18671 elsif not Elaboration_Checks_Suppressed (E) then 18672 Set_Elaboration_Entity_Required (E); 18673 18674 -- Create a declaration of the elaboration entity, and insert it 18675 -- prior to the subprogram or the generic unit, within the same 18676 -- scope. Since the subprogram may be overloaded, create a unique 18677 -- entity. 18678 18679 if No (Elaboration_Entity (E)) then 18680 declare 18681 Loce : constant Source_Ptr := Sloc (E); 18682 Ent : constant Entity_Id := 18683 Make_Defining_Identifier (Loc, 18684 New_External_Name (Chars (E), 'E', -1)); 18685 18686 begin 18687 Set_Elaboration_Entity (E, Ent); 18688 Push_Scope (Scope (E)); 18689 18690 Insert_Action (Declaration_Node (E), 18691 Make_Object_Declaration (Loce, 18692 Defining_Identifier => Ent, 18693 Object_Definition => 18694 New_Occurrence_Of (Standard_Short_Integer, Loce), 18695 Expression => 18696 Make_Integer_Literal (Loc, Uint_0))); 18697 18698 -- Set elaboration flag at the point of the body 18699 18700 Set_Elaboration_Flag (Sbody, E); 18701 18702 -- Kill current value indication. This is necessary because 18703 -- the tests of this flag are inserted out of sequence and 18704 -- must not pick up bogus indications of the wrong constant 18705 -- value. Also, this is never a true constant, since one way 18706 -- or another, it gets reset. 18707 18708 Set_Current_Value (Ent, Empty); 18709 Set_Last_Assignment (Ent, Empty); 18710 Set_Is_True_Constant (Ent, False); 18711 Pop_Scope; 18712 end; 18713 end if; 18714 18715 -- Generate: 18716 -- if Enn = 0 then 18717 -- raise Program_Error with "access before elaboration"; 18718 -- end if; 18719 18720 Insert_Elab_Check (N, 18721 Make_Attribute_Reference (Loc, 18722 Attribute_Name => Name_Elaborated, 18723 Prefix => New_Occurrence_Of (E, Loc))); 18724 end if; 18725 18726 -- Generate the warning 18727 18728 if not Suppress_Elaboration_Warnings (E) 18729 and then not Elaboration_Checks_Suppressed (E) 18730 18731 -- Suppress this warning if we have a function call that occurred 18732 -- within an assertion expression, since we can get false warnings 18733 -- in this case, due to the out of order handling in this case. 18734 18735 and then 18736 (Nkind (Original_Node (N)) /= N_Function_Call 18737 or else not In_Assertion_Expression_Pragma (Original_Node (N))) 18738 then 18739 Error_Msg_Warn := SPARK_Mode /= On; 18740 18741 if Inst_Case then 18742 Error_Msg_NE 18743 ("instantiation of& may occur before body is seen<l<", 18744 N, Orig_Ent); 18745 else 18746 -- A rather specific check. For Finalize/Adjust/Initialize, if 18747 -- the type has Warnings_Off set, suppress the warning. 18748 18749 if Chars (E) in Name_Adjust 18750 | Name_Finalize 18751 | Name_Initialize 18752 and then Present (First_Formal (E)) 18753 then 18754 declare 18755 T : constant Entity_Id := Etype (First_Formal (E)); 18756 begin 18757 if Is_Controlled (T) then 18758 if Warnings_Off (T) 18759 or else (Ekind (T) = E_Private_Type 18760 and then Warnings_Off (Full_View (T))) 18761 then 18762 goto Output; 18763 end if; 18764 end if; 18765 end; 18766 end if; 18767 18768 -- Go ahead and give warning if not this special case 18769 18770 Error_Msg_NE 18771 ("call to& may occur before body is seen<l<", N, Orig_Ent); 18772 end if; 18773 18774 Error_Msg_N ("\Program_Error ]<l<", N); 18775 18776 -- There is no need to query the elaboration warning message flags 18777 -- because the main message is an error, not a warning, therefore 18778 -- all the clarification messages produces by Output_Calls must be 18779 -- emitted unconditionally. 18780 18781 <<Output>> 18782 18783 Output_Calls (N, Check_Elab_Flag => False); 18784 end if; 18785 end if; 18786 end Check_Internal_Call_Continue; 18787 18788 --------------------------- 18789 -- Check_Task_Activation -- 18790 --------------------------- 18791 18792 procedure Check_Task_Activation (N : Node_Id) is 18793 Loc : constant Source_Ptr := Sloc (N); 18794 Inter_Procs : constant Elist_Id := New_Elmt_List; 18795 Intra_Procs : constant Elist_Id := New_Elmt_List; 18796 Ent : Entity_Id; 18797 P : Entity_Id; 18798 Task_Scope : Entity_Id; 18799 Cunit_SC : Boolean := False; 18800 Decl : Node_Id; 18801 Elmt : Elmt_Id; 18802 Enclosing : Entity_Id; 18803 18804 procedure Add_Task_Proc (Typ : Entity_Id); 18805 -- Add to Task_Procs the task body procedure(s) of task types in Typ. 18806 -- For record types, this procedure recurses over component types. 18807 18808 procedure Collect_Tasks (Decls : List_Id); 18809 -- Collect the types of the tasks that are to be activated in the given 18810 -- list of declarations, in order to perform elaboration checks on the 18811 -- corresponding task procedures that are called implicitly here. 18812 18813 function Outer_Unit (E : Entity_Id) return Entity_Id; 18814 -- find enclosing compilation unit of Entity, ignoring subunits, or 18815 -- else enclosing subprogram. If E is not a package, there is no need 18816 -- for inter-unit elaboration checks. 18817 18818 ------------------- 18819 -- Add_Task_Proc -- 18820 ------------------- 18821 18822 procedure Add_Task_Proc (Typ : Entity_Id) is 18823 Comp : Entity_Id; 18824 Proc : Entity_Id := Empty; 18825 18826 begin 18827 if Is_Task_Type (Typ) then 18828 Proc := Get_Task_Body_Procedure (Typ); 18829 18830 elsif Is_Array_Type (Typ) 18831 and then Has_Task (Base_Type (Typ)) 18832 then 18833 Add_Task_Proc (Component_Type (Typ)); 18834 18835 elsif Is_Record_Type (Typ) 18836 and then Has_Task (Base_Type (Typ)) 18837 then 18838 Comp := First_Component (Typ); 18839 while Present (Comp) loop 18840 Add_Task_Proc (Etype (Comp)); 18841 Next_Component (Comp); 18842 end loop; 18843 end if; 18844 18845 -- If the task type is another unit, we will perform the usual 18846 -- elaboration check on its enclosing unit. If the type is in the 18847 -- same unit, we can trace the task body as for an internal call, 18848 -- but we only need to examine other external calls, because at 18849 -- the point the task is activated, internal subprogram bodies 18850 -- will have been elaborated already. We keep separate lists for 18851 -- each kind of task. 18852 18853 -- Skip this test if errors have occurred, since in this case 18854 -- we can get false indications. 18855 18856 if Serious_Errors_Detected /= 0 then 18857 return; 18858 end if; 18859 18860 if Present (Proc) then 18861 if Outer_Unit (Scope (Proc)) = Enclosing then 18862 18863 if No (Corresponding_Body (Unit_Declaration_Node (Proc))) 18864 and then 18865 (not Is_Generic_Instance (Scope (Proc)) 18866 or else Scope (Proc) = Scope (Defining_Identifier (Decl))) 18867 then 18868 Error_Msg_Warn := SPARK_Mode /= On; 18869 Error_Msg_N 18870 ("task will be activated before elaboration of its body<<", 18871 Decl); 18872 Error_Msg_N ("\Program_Error [<<", Decl); 18873 18874 elsif Present 18875 (Corresponding_Body (Unit_Declaration_Node (Proc))) 18876 then 18877 Append_Elmt (Proc, Intra_Procs); 18878 end if; 18879 18880 else 18881 -- No need for multiple entries of the same type 18882 18883 Elmt := First_Elmt (Inter_Procs); 18884 while Present (Elmt) loop 18885 if Node (Elmt) = Proc then 18886 return; 18887 end if; 18888 18889 Next_Elmt (Elmt); 18890 end loop; 18891 18892 Append_Elmt (Proc, Inter_Procs); 18893 end if; 18894 end if; 18895 end Add_Task_Proc; 18896 18897 ------------------- 18898 -- Collect_Tasks -- 18899 ------------------- 18900 18901 procedure Collect_Tasks (Decls : List_Id) is 18902 begin 18903 if Present (Decls) then 18904 Decl := First (Decls); 18905 while Present (Decl) loop 18906 if Nkind (Decl) = N_Object_Declaration 18907 and then Has_Task (Etype (Defining_Identifier (Decl))) 18908 then 18909 Add_Task_Proc (Etype (Defining_Identifier (Decl))); 18910 end if; 18911 18912 Next (Decl); 18913 end loop; 18914 end if; 18915 end Collect_Tasks; 18916 18917 ---------------- 18918 -- Outer_Unit -- 18919 ---------------- 18920 18921 function Outer_Unit (E : Entity_Id) return Entity_Id is 18922 Outer : Entity_Id; 18923 18924 begin 18925 Outer := E; 18926 while Present (Outer) loop 18927 if Elaboration_Checks_Suppressed (Outer) then 18928 Cunit_SC := True; 18929 end if; 18930 18931 exit when Is_Child_Unit (Outer) 18932 or else Scope (Outer) = Standard_Standard 18933 or else Ekind (Outer) /= E_Package; 18934 Outer := Scope (Outer); 18935 end loop; 18936 18937 return Outer; 18938 end Outer_Unit; 18939 18940 -- Start of processing for Check_Task_Activation 18941 18942 begin 18943 pragma Assert (Legacy_Elaboration_Checks); 18944 18945 Enclosing := Outer_Unit (Current_Scope); 18946 18947 -- Find all tasks declared in the current unit 18948 18949 if Nkind (N) = N_Package_Body then 18950 P := Unit_Declaration_Node (Corresponding_Spec (N)); 18951 18952 Collect_Tasks (Declarations (N)); 18953 Collect_Tasks (Visible_Declarations (Specification (P))); 18954 Collect_Tasks (Private_Declarations (Specification (P))); 18955 18956 elsif Nkind (N) = N_Package_Declaration then 18957 Collect_Tasks (Visible_Declarations (Specification (N))); 18958 Collect_Tasks (Private_Declarations (Specification (N))); 18959 18960 else 18961 Collect_Tasks (Declarations (N)); 18962 end if; 18963 18964 -- We only perform detailed checks in all tasks that are library level 18965 -- entities. If the master is a subprogram or task, activation will 18966 -- depend on the activation of the master itself. 18967 18968 -- Should dynamic checks be added in the more general case??? 18969 18970 if Ekind (Enclosing) /= E_Package then 18971 return; 18972 end if; 18973 18974 -- For task types defined in other units, we want the unit containing 18975 -- the task body to be elaborated before the current one. 18976 18977 Elmt := First_Elmt (Inter_Procs); 18978 while Present (Elmt) loop 18979 Ent := Node (Elmt); 18980 Task_Scope := Outer_Unit (Scope (Ent)); 18981 18982 if not Is_Compilation_Unit (Task_Scope) then 18983 null; 18984 18985 elsif Suppress_Elaboration_Warnings (Task_Scope) 18986 or else Elaboration_Checks_Suppressed (Task_Scope) 18987 then 18988 null; 18989 18990 elsif Dynamic_Elaboration_Checks then 18991 if not Elaboration_Checks_Suppressed (Ent) 18992 and then not Cunit_SC 18993 and then not Restriction_Active 18994 (No_Entry_Calls_In_Elaboration_Code) 18995 then 18996 -- Runtime elaboration check required. Generate check of the 18997 -- elaboration counter for the unit containing the entity. 18998 18999 Insert_Elab_Check (N, 19000 Make_Attribute_Reference (Loc, 19001 Prefix => 19002 New_Occurrence_Of (Spec_Entity (Task_Scope), Loc), 19003 Attribute_Name => Name_Elaborated)); 19004 end if; 19005 19006 else 19007 -- Force the binder to elaborate other unit first 19008 19009 if Elab_Info_Messages 19010 and then not Suppress_Elaboration_Warnings (Ent) 19011 and then not Elaboration_Checks_Suppressed (Ent) 19012 and then not Suppress_Elaboration_Warnings (Task_Scope) 19013 and then not Elaboration_Checks_Suppressed (Task_Scope) 19014 then 19015 Error_Msg_Node_2 := Task_Scope; 19016 Error_Msg_NE 19017 ("info: activation of an instance of task type & requires " 19018 & "pragma Elaborate_All on &?$?", N, Ent); 19019 end if; 19020 19021 Activate_Elaborate_All_Desirable (N, Task_Scope); 19022 Set_Suppress_Elaboration_Warnings (Task_Scope); 19023 end if; 19024 19025 Next_Elmt (Elmt); 19026 end loop; 19027 19028 -- For tasks declared in the current unit, trace other calls within the 19029 -- task procedure bodies, which are available. 19030 19031 if not Debug_Flag_Dot_Y then 19032 In_Task_Activation := True; 19033 19034 Elmt := First_Elmt (Intra_Procs); 19035 while Present (Elmt) loop 19036 Ent := Node (Elmt); 19037 Check_Internal_Call_Continue (N, Ent, Enclosing, Ent); 19038 Next_Elmt (Elmt); 19039 end loop; 19040 19041 In_Task_Activation := False; 19042 end if; 19043 end Check_Task_Activation; 19044 19045 ------------------------ 19046 -- Get_Referenced_Ent -- 19047 ------------------------ 19048 19049 function Get_Referenced_Ent (N : Node_Id) return Entity_Id is 19050 Nam : Node_Id; 19051 19052 begin 19053 if Nkind (N) in N_Has_Entity 19054 and then Present (Entity (N)) 19055 and then Ekind (Entity (N)) = E_Variable 19056 then 19057 return Entity (N); 19058 end if; 19059 19060 if Nkind (N) = N_Attribute_Reference then 19061 Nam := Prefix (N); 19062 else 19063 Nam := Name (N); 19064 end if; 19065 19066 if No (Nam) then 19067 return Empty; 19068 elsif Nkind (Nam) = N_Selected_Component then 19069 return Entity (Selector_Name (Nam)); 19070 elsif not Is_Entity_Name (Nam) then 19071 return Empty; 19072 else 19073 return Entity (Nam); 19074 end if; 19075 end Get_Referenced_Ent; 19076 19077 ---------------------- 19078 -- Has_Generic_Body -- 19079 ---------------------- 19080 19081 function Has_Generic_Body (N : Node_Id) return Boolean is 19082 Ent : constant Entity_Id := Get_Generic_Entity (N); 19083 Decl : constant Node_Id := Unit_Declaration_Node (Ent); 19084 Scop : Entity_Id; 19085 19086 function Find_Body_In (E : Entity_Id; N : Node_Id) return Node_Id; 19087 -- Determine if the list of nodes headed by N and linked by Next 19088 -- contains a package body for the package spec entity E, and if so 19089 -- return the package body. If not, then returns Empty. 19090 19091 function Load_Package_Body (Nam : Unit_Name_Type) return Node_Id; 19092 -- This procedure is called load the unit whose name is given by Nam. 19093 -- This unit is being loaded to see whether it contains an optional 19094 -- generic body. The returned value is the loaded unit, which is always 19095 -- a package body (only package bodies can contain other entities in the 19096 -- sense in which Has_Generic_Body is interested). We only attempt to 19097 -- load bodies if we are generating code. If we are in semantics check 19098 -- only mode, then it would be wrong to load bodies that are not 19099 -- required from a semantic point of view, so in this case we return 19100 -- Empty. The result is that the caller may incorrectly decide that a 19101 -- generic spec does not have a body when in fact it does, but the only 19102 -- harm in this is that some warnings on elaboration problems may be 19103 -- lost in semantic checks only mode, which is not big loss. We also 19104 -- return Empty if we go for a body and it is not there. 19105 19106 function Locate_Corresponding_Body (PE : Entity_Id) return Node_Id; 19107 -- PE is the entity for a package spec. This function locates the 19108 -- corresponding package body, returning Empty if none is found. The 19109 -- package body returned is fully parsed but may not yet be analyzed, 19110 -- so only syntactic fields should be referenced. 19111 19112 ------------------ 19113 -- Find_Body_In -- 19114 ------------------ 19115 19116 function Find_Body_In (E : Entity_Id; N : Node_Id) return Node_Id is 19117 Nod : Node_Id; 19118 19119 begin 19120 Nod := N; 19121 while Present (Nod) loop 19122 19123 -- If we found the package body we are looking for, return it 19124 19125 if Nkind (Nod) = N_Package_Body 19126 and then Chars (Defining_Unit_Name (Nod)) = Chars (E) 19127 then 19128 return Nod; 19129 19130 -- If we found the stub for the body, go after the subunit, 19131 -- loading it if necessary. 19132 19133 elsif Nkind (Nod) = N_Package_Body_Stub 19134 and then Chars (Defining_Identifier (Nod)) = Chars (E) 19135 then 19136 if Present (Library_Unit (Nod)) then 19137 return Unit (Library_Unit (Nod)); 19138 19139 else 19140 return Load_Package_Body (Get_Unit_Name (Nod)); 19141 end if; 19142 19143 -- If neither package body nor stub, keep looking on chain 19144 19145 else 19146 Next (Nod); 19147 end if; 19148 end loop; 19149 19150 return Empty; 19151 end Find_Body_In; 19152 19153 ----------------------- 19154 -- Load_Package_Body -- 19155 ----------------------- 19156 19157 function Load_Package_Body (Nam : Unit_Name_Type) return Node_Id is 19158 U : Unit_Number_Type; 19159 19160 begin 19161 if Operating_Mode /= Generate_Code then 19162 return Empty; 19163 else 19164 U := 19165 Load_Unit 19166 (Load_Name => Nam, 19167 Required => False, 19168 Subunit => False, 19169 Error_Node => N); 19170 19171 if U = No_Unit then 19172 return Empty; 19173 else 19174 return Unit (Cunit (U)); 19175 end if; 19176 end if; 19177 end Load_Package_Body; 19178 19179 ------------------------------- 19180 -- Locate_Corresponding_Body -- 19181 ------------------------------- 19182 19183 function Locate_Corresponding_Body (PE : Entity_Id) return Node_Id is 19184 Spec : constant Node_Id := Declaration_Node (PE); 19185 Decl : constant Node_Id := Parent (Spec); 19186 Scop : constant Entity_Id := Scope (PE); 19187 PBody : Node_Id; 19188 19189 begin 19190 if Is_Library_Level_Entity (PE) then 19191 19192 -- If package is a library unit that requires a body, we have no 19193 -- choice but to go after that body because it might contain an 19194 -- optional body for the original generic package. 19195 19196 if Unit_Requires_Body (PE) then 19197 19198 -- Load the body. Note that we are a little careful here to use 19199 -- Spec to get the unit number, rather than PE or Decl, since 19200 -- in the case where the package is itself a library level 19201 -- instantiation, Spec will properly reference the generic 19202 -- template, which is what we really want. 19203 19204 return 19205 Load_Package_Body 19206 (Get_Body_Name (Unit_Name (Get_Source_Unit (Spec)))); 19207 19208 -- But if the package is a library unit that does NOT require 19209 -- a body, then no body is permitted, so we are sure that there 19210 -- is no body for the original generic package. 19211 19212 else 19213 return Empty; 19214 end if; 19215 19216 -- Otherwise look and see if we are embedded in a further package 19217 19218 elsif Is_Package_Or_Generic_Package (Scop) then 19219 19220 -- If so, get the body of the enclosing package, and look in 19221 -- its package body for the package body we are looking for. 19222 19223 PBody := Locate_Corresponding_Body (Scop); 19224 19225 if No (PBody) then 19226 return Empty; 19227 else 19228 return Find_Body_In (PE, First (Declarations (PBody))); 19229 end if; 19230 19231 -- If we are not embedded in a further package, then the body 19232 -- must be in the same declarative part as we are. 19233 19234 else 19235 return Find_Body_In (PE, Next (Decl)); 19236 end if; 19237 end Locate_Corresponding_Body; 19238 19239 -- Start of processing for Has_Generic_Body 19240 19241 begin 19242 if Present (Corresponding_Body (Decl)) then 19243 return True; 19244 19245 elsif Unit_Requires_Body (Ent) then 19246 return True; 19247 19248 -- Compilation units cannot have optional bodies 19249 19250 elsif Is_Compilation_Unit (Ent) then 19251 return False; 19252 19253 -- Otherwise look at what scope we are in 19254 19255 else 19256 Scop := Scope (Ent); 19257 19258 -- Case of entity is in other than a package spec, in this case 19259 -- the body, if present, must be in the same declarative part. 19260 19261 if not Is_Package_Or_Generic_Package (Scop) then 19262 declare 19263 P : Node_Id; 19264 19265 begin 19266 -- Declaration node may get us a spec, so if so, go to 19267 -- the parent declaration. 19268 19269 P := Declaration_Node (Ent); 19270 while not Is_List_Member (P) loop 19271 P := Parent (P); 19272 end loop; 19273 19274 return Present (Find_Body_In (Ent, Next (P))); 19275 end; 19276 19277 -- If the entity is in a package spec, then we have to locate 19278 -- the corresponding package body, and look there. 19279 19280 else 19281 declare 19282 PBody : constant Node_Id := Locate_Corresponding_Body (Scop); 19283 19284 begin 19285 if No (PBody) then 19286 return False; 19287 else 19288 return 19289 Present 19290 (Find_Body_In (Ent, (First (Declarations (PBody))))); 19291 end if; 19292 end; 19293 end if; 19294 end if; 19295 end Has_Generic_Body; 19296 19297 ----------------------- 19298 -- Insert_Elab_Check -- 19299 ----------------------- 19300 19301 procedure Insert_Elab_Check (N : Node_Id; C : Node_Id := Empty) is 19302 Nod : Node_Id; 19303 Loc : constant Source_Ptr := Sloc (N); 19304 19305 Chk : Node_Id; 19306 -- The check (N_Raise_Program_Error) node to be inserted 19307 19308 begin 19309 -- If expansion is disabled, do not generate any checks. Also 19310 -- skip checks if any subunits are missing because in either 19311 -- case we lack the full information that we need, and no object 19312 -- file will be created in any case. 19313 19314 if not Expander_Active or else Subunits_Missing then 19315 return; 19316 end if; 19317 19318 -- If we have a generic instantiation, where Instance_Spec is set, 19319 -- then this field points to a generic instance spec that has 19320 -- been inserted before the instantiation node itself, so that 19321 -- is where we want to insert a check. 19322 19323 if Nkind (N) in N_Generic_Instantiation 19324 and then Present (Instance_Spec (N)) 19325 then 19326 Nod := Instance_Spec (N); 19327 else 19328 Nod := N; 19329 end if; 19330 19331 -- Build check node, possibly with condition 19332 19333 Chk := 19334 Make_Raise_Program_Error (Loc, Reason => PE_Access_Before_Elaboration); 19335 19336 if Present (C) then 19337 Set_Condition (Chk, Make_Op_Not (Loc, Right_Opnd => C)); 19338 end if; 19339 19340 -- If we are inserting at the top level, insert in Aux_Decls 19341 19342 if Nkind (Parent (Nod)) = N_Compilation_Unit then 19343 declare 19344 ADN : constant Node_Id := Aux_Decls_Node (Parent (Nod)); 19345 19346 begin 19347 if No (Declarations (ADN)) then 19348 Set_Declarations (ADN, New_List (Chk)); 19349 else 19350 Append_To (Declarations (ADN), Chk); 19351 end if; 19352 19353 Analyze (Chk); 19354 end; 19355 19356 -- Otherwise just insert as an action on the node in question 19357 19358 else 19359 Insert_Action (Nod, Chk); 19360 end if; 19361 end Insert_Elab_Check; 19362 19363 ------------------------------- 19364 -- Is_Call_Of_Generic_Formal -- 19365 ------------------------------- 19366 19367 function Is_Call_Of_Generic_Formal (N : Node_Id) return Boolean is 19368 begin 19369 return Nkind (N) in N_Subprogram_Call 19370 19371 -- Always return False if debug flag -gnatd.G is set 19372 19373 and then not Debug_Flag_Dot_GG 19374 19375 -- For now, we detect this by looking for the strange identifier 19376 -- node, whose Chars reflect the name of the generic formal, but 19377 -- the Chars of the Entity references the generic actual. 19378 19379 and then Nkind (Name (N)) = N_Identifier 19380 and then Chars (Name (N)) /= Chars (Entity (Name (N))); 19381 end Is_Call_Of_Generic_Formal; 19382 19383 ------------------------------- 19384 -- Is_Finalization_Procedure -- 19385 ------------------------------- 19386 19387 function Is_Finalization_Procedure (Id : Entity_Id) return Boolean is 19388 begin 19389 -- Check whether Id is a procedure with at least one parameter 19390 19391 if Ekind (Id) = E_Procedure and then Present (First_Formal (Id)) then 19392 declare 19393 Typ : constant Entity_Id := Etype (First_Formal (Id)); 19394 Deep_Fin : Entity_Id := Empty; 19395 Fin : Entity_Id := Empty; 19396 19397 begin 19398 -- If the type of the first formal does not require finalization 19399 -- actions, then this is definitely not [Deep_]Finalize. 19400 19401 if not Needs_Finalization (Typ) then 19402 return False; 19403 end if; 19404 19405 -- At this point we have the following scenario: 19406 19407 -- procedure Name (Param1 : [in] [out] Ctrl[; Param2 : ...]); 19408 19409 -- Recover the two possible versions of [Deep_]Finalize using the 19410 -- type of the first parameter and compare with the input. 19411 19412 Deep_Fin := TSS (Typ, TSS_Deep_Finalize); 19413 19414 if Is_Controlled (Typ) then 19415 Fin := Find_Prim_Op (Typ, Name_Finalize); 19416 end if; 19417 19418 return (Present (Deep_Fin) and then Id = Deep_Fin) 19419 or else (Present (Fin) and then Id = Fin); 19420 end; 19421 end if; 19422 19423 return False; 19424 end Is_Finalization_Procedure; 19425 19426 ------------------ 19427 -- Output_Calls -- 19428 ------------------ 19429 19430 procedure Output_Calls 19431 (N : Node_Id; 19432 Check_Elab_Flag : Boolean) 19433 is 19434 function Emit (Flag : Boolean) return Boolean; 19435 -- Determine whether to emit an error message based on the combination 19436 -- of flags Check_Elab_Flag and Flag. 19437 19438 function Is_Printable_Error_Name return Boolean; 19439 -- An internal function, used to determine if a name, stored in the 19440 -- Name_Buffer, is either a non-internal name, or is an internal name 19441 -- that is printable by the error message circuits (i.e. it has a single 19442 -- upper case letter at the end). 19443 19444 ---------- 19445 -- Emit -- 19446 ---------- 19447 19448 function Emit (Flag : Boolean) return Boolean is 19449 begin 19450 if Check_Elab_Flag then 19451 return Flag; 19452 else 19453 return True; 19454 end if; 19455 end Emit; 19456 19457 ----------------------------- 19458 -- Is_Printable_Error_Name -- 19459 ----------------------------- 19460 19461 function Is_Printable_Error_Name return Boolean is 19462 begin 19463 if not Is_Internal_Name then 19464 return True; 19465 19466 elsif Name_Len = 1 then 19467 return False; 19468 19469 else 19470 Name_Len := Name_Len - 1; 19471 return not Is_Internal_Name; 19472 end if; 19473 end Is_Printable_Error_Name; 19474 19475 -- Local variables 19476 19477 Ent : Entity_Id; 19478 19479 -- Start of processing for Output_Calls 19480 19481 begin 19482 for J in reverse 1 .. Elab_Call.Last loop 19483 Error_Msg_Sloc := Elab_Call.Table (J).Cloc; 19484 19485 Ent := Elab_Call.Table (J).Ent; 19486 Get_Name_String (Chars (Ent)); 19487 19488 -- Dynamic elaboration model, warnings controlled by -gnatwl 19489 19490 if Dynamic_Elaboration_Checks then 19491 if Emit (Elab_Warnings) then 19492 if Is_Generic_Unit (Ent) then 19493 Error_Msg_NE ("\\?l?& instantiated #", N, Ent); 19494 elsif Is_Init_Proc (Ent) then 19495 Error_Msg_N ("\\?l?initialization procedure called #", N); 19496 elsif Is_Printable_Error_Name then 19497 Error_Msg_NE ("\\?l?& called #", N, Ent); 19498 else 19499 Error_Msg_N ("\\?l?called #", N); 19500 end if; 19501 end if; 19502 19503 -- Static elaboration model, info messages controlled by -gnatel 19504 19505 else 19506 if Emit (Elab_Info_Messages) then 19507 if Is_Generic_Unit (Ent) then 19508 Error_Msg_NE ("\\?$?& instantiated #", N, Ent); 19509 elsif Is_Init_Proc (Ent) then 19510 Error_Msg_N ("\\?$?initialization procedure called #", N); 19511 elsif Is_Printable_Error_Name then 19512 Error_Msg_NE ("\\?$?& called #", N, Ent); 19513 else 19514 Error_Msg_N ("\\?$?called #", N); 19515 end if; 19516 end if; 19517 end if; 19518 end loop; 19519 end Output_Calls; 19520 19521 ---------------------------- 19522 -- Same_Elaboration_Scope -- 19523 ---------------------------- 19524 19525 function Same_Elaboration_Scope (Scop1, Scop2 : Entity_Id) return Boolean is 19526 S1 : Entity_Id; 19527 S2 : Entity_Id; 19528 19529 begin 19530 -- Find elaboration scope for Scop1 19531 -- This is either a subprogram or a compilation unit. 19532 19533 S1 := Scop1; 19534 while S1 /= Standard_Standard 19535 and then not Is_Compilation_Unit (S1) 19536 and then Ekind (S1) in E_Package | E_Protected_Type | E_Block 19537 loop 19538 S1 := Scope (S1); 19539 end loop; 19540 19541 -- Find elaboration scope for Scop2 19542 19543 S2 := Scop2; 19544 while S2 /= Standard_Standard 19545 and then not Is_Compilation_Unit (S2) 19546 and then Ekind (S2) in E_Package | E_Protected_Type | E_Block 19547 loop 19548 S2 := Scope (S2); 19549 end loop; 19550 19551 return S1 = S2; 19552 end Same_Elaboration_Scope; 19553 19554 ----------------- 19555 -- Set_C_Scope -- 19556 ----------------- 19557 19558 procedure Set_C_Scope is 19559 begin 19560 while not Is_Compilation_Unit (C_Scope) loop 19561 C_Scope := Scope (C_Scope); 19562 end loop; 19563 end Set_C_Scope; 19564 19565 -------------------------------- 19566 -- Set_Elaboration_Constraint -- 19567 -------------------------------- 19568 19569 procedure Set_Elaboration_Constraint 19570 (Call : Node_Id; 19571 Subp : Entity_Id; 19572 Scop : Entity_Id) 19573 is 19574 Elab_Unit : Entity_Id; 19575 19576 -- Check whether this is a call to an Initialize subprogram for a 19577 -- controlled type. Note that Call can also be a 'Access attribute 19578 -- reference, which now generates an elaboration check. 19579 19580 Init_Call : constant Boolean := 19581 Nkind (Call) = N_Procedure_Call_Statement 19582 and then Chars (Subp) = Name_Initialize 19583 and then Comes_From_Source (Subp) 19584 and then Present (Parameter_Associations (Call)) 19585 and then Is_Controlled (Etype (First_Actual (Call))); 19586 19587 begin 19588 -- If the unit is mentioned in a with_clause of the current unit, it is 19589 -- visible, and we can set the elaboration flag. 19590 19591 if Is_Immediately_Visible (Scop) 19592 or else (Is_Child_Unit (Scop) and then Is_Visible_Lib_Unit (Scop)) 19593 then 19594 Activate_Elaborate_All_Desirable (Call, Scop); 19595 Set_Suppress_Elaboration_Warnings (Scop); 19596 return; 19597 end if; 19598 19599 -- If this is not an initialization call or a call using object notation 19600 -- we know that the unit of the called entity is in the context, and we 19601 -- can set the flag as well. The unit need not be visible if the call 19602 -- occurs within an instantiation. 19603 19604 if Is_Init_Proc (Subp) 19605 or else Init_Call 19606 or else Nkind (Original_Node (Call)) = N_Selected_Component 19607 then 19608 null; -- detailed processing follows. 19609 19610 else 19611 Activate_Elaborate_All_Desirable (Call, Scop); 19612 Set_Suppress_Elaboration_Warnings (Scop); 19613 return; 19614 end if; 19615 19616 -- If the unit is not in the context, there must be an intermediate unit 19617 -- that is, on which we need to place to elaboration flag. This happens 19618 -- with init proc calls. 19619 19620 if Is_Init_Proc (Subp) or else Init_Call then 19621 19622 -- The initialization call is on an object whose type is not declared 19623 -- in the same scope as the subprogram. The type of the object must 19624 -- be a subtype of the type of operation. This object is the first 19625 -- actual in the call. 19626 19627 declare 19628 Typ : constant Entity_Id := 19629 Etype (First (Parameter_Associations (Call))); 19630 begin 19631 Elab_Unit := Scope (Typ); 19632 while (Present (Elab_Unit)) 19633 and then not Is_Compilation_Unit (Elab_Unit) 19634 loop 19635 Elab_Unit := Scope (Elab_Unit); 19636 end loop; 19637 end; 19638 19639 -- If original node uses selected component notation, the prefix is 19640 -- visible and determines the scope that must be elaborated. After 19641 -- rewriting, the prefix is the first actual in the call. 19642 19643 elsif Nkind (Original_Node (Call)) = N_Selected_Component then 19644 Elab_Unit := Scope (Etype (First (Parameter_Associations (Call)))); 19645 19646 -- Not one of special cases above 19647 19648 else 19649 -- Using previously computed scope. If the elaboration check is 19650 -- done after analysis, the scope is not visible any longer, but 19651 -- must still be in the context. 19652 19653 Elab_Unit := Scop; 19654 end if; 19655 19656 Activate_Elaborate_All_Desirable (Call, Elab_Unit); 19657 Set_Suppress_Elaboration_Warnings (Elab_Unit); 19658 end Set_Elaboration_Constraint; 19659 19660 ----------------- 19661 -- Spec_Entity -- 19662 ----------------- 19663 19664 function Spec_Entity (E : Entity_Id) return Entity_Id is 19665 Decl : Node_Id; 19666 19667 begin 19668 -- Check for case of body entity 19669 -- Why is the check for E_Void needed??? 19670 19671 if Ekind (E) in E_Void | E_Subprogram_Body | E_Package_Body then 19672 Decl := E; 19673 19674 loop 19675 Decl := Parent (Decl); 19676 exit when Nkind (Decl) in N_Proper_Body; 19677 end loop; 19678 19679 return Corresponding_Spec (Decl); 19680 19681 else 19682 return E; 19683 end if; 19684 end Spec_Entity; 19685 19686 ------------ 19687 -- Within -- 19688 ------------ 19689 19690 function Within (E1, E2 : Entity_Id) return Boolean is 19691 Scop : Entity_Id; 19692 begin 19693 Scop := E1; 19694 loop 19695 if Scop = E2 then 19696 return True; 19697 elsif Scop = Standard_Standard then 19698 return False; 19699 else 19700 Scop := Scope (Scop); 19701 end if; 19702 end loop; 19703 end Within; 19704 19705 -------------------------- 19706 -- Within_Elaborate_All -- 19707 -------------------------- 19708 19709 function Within_Elaborate_All 19710 (Unit : Unit_Number_Type; 19711 E : Entity_Id) return Boolean 19712 is 19713 type Unit_Number_Set is array (Main_Unit .. Last_Unit) of Boolean; 19714 pragma Pack (Unit_Number_Set); 19715 19716 Seen : Unit_Number_Set := (others => False); 19717 -- Seen (X) is True after we have seen unit X in the walk. This is used 19718 -- to prevent processing the same unit more than once. 19719 19720 Result : Boolean := False; 19721 19722 procedure Helper (Unit : Unit_Number_Type); 19723 -- This helper procedure does all the work for Within_Elaborate_All. It 19724 -- walks the dependency graph, and sets Result to True if it finds an 19725 -- appropriate Elaborate_All. 19726 19727 ------------ 19728 -- Helper -- 19729 ------------ 19730 19731 procedure Helper (Unit : Unit_Number_Type) is 19732 CU : constant Node_Id := Cunit (Unit); 19733 19734 Item : Node_Id; 19735 Item2 : Node_Id; 19736 Elab_Id : Entity_Id; 19737 Par : Node_Id; 19738 19739 begin 19740 if Seen (Unit) then 19741 return; 19742 else 19743 Seen (Unit) := True; 19744 end if; 19745 19746 -- First, check for Elaborate_Alls on this unit 19747 19748 Item := First (Context_Items (CU)); 19749 while Present (Item) loop 19750 if Nkind (Item) = N_Pragma 19751 and then Pragma_Name (Item) = Name_Elaborate_All 19752 then 19753 -- Return if some previous error on the pragma itself. The 19754 -- pragma may be unanalyzed, because of a previous error, or 19755 -- if it is the context of a subunit, inherited by its parent. 19756 19757 if Error_Posted (Item) or else not Analyzed (Item) then 19758 return; 19759 end if; 19760 19761 Elab_Id := 19762 Entity 19763 (Expression (First (Pragma_Argument_Associations (Item)))); 19764 19765 if E = Elab_Id then 19766 Result := True; 19767 return; 19768 end if; 19769 19770 Par := Parent (Unit_Declaration_Node (Elab_Id)); 19771 19772 Item2 := First (Context_Items (Par)); 19773 while Present (Item2) loop 19774 if Nkind (Item2) = N_With_Clause 19775 and then Entity (Name (Item2)) = E 19776 and then not Limited_Present (Item2) 19777 then 19778 Result := True; 19779 return; 19780 end if; 19781 19782 Next (Item2); 19783 end loop; 19784 end if; 19785 19786 Next (Item); 19787 end loop; 19788 19789 -- Second, recurse on with's. We could do this as part of the above 19790 -- loop, but it's probably more efficient to have two loops, because 19791 -- the relevant Elaborate_All is likely to be on the initial unit. In 19792 -- other words, we're walking the with's breadth-first. This part is 19793 -- only necessary in the dynamic elaboration model. 19794 19795 if Dynamic_Elaboration_Checks then 19796 Item := First (Context_Items (CU)); 19797 while Present (Item) loop 19798 if Nkind (Item) = N_With_Clause 19799 and then not Limited_Present (Item) 19800 then 19801 -- Note: the following call to Get_Cunit_Unit_Number does a 19802 -- linear search, which could be slow, but it's OK because 19803 -- we're about to give a warning anyway. Also, there might 19804 -- be hundreds of units, but not millions. If it turns out 19805 -- to be a problem, we could store the Get_Cunit_Unit_Number 19806 -- in each N_Compilation_Unit node, but that would involve 19807 -- rearranging N_Compilation_Unit_Aux to make room. 19808 19809 Helper (Get_Cunit_Unit_Number (Library_Unit (Item))); 19810 19811 if Result then 19812 return; 19813 end if; 19814 end if; 19815 19816 Next (Item); 19817 end loop; 19818 end if; 19819 end Helper; 19820 19821 -- Start of processing for Within_Elaborate_All 19822 19823 begin 19824 Helper (Unit); 19825 return Result; 19826 end Within_Elaborate_All; 19827 19828end Sem_Elab; 19829