1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- S E M _ E L A B -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1997-2019, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with ALI; use ALI; 27with Atree; use Atree; 28with Checks; use Checks; 29with Debug; use Debug; 30with Einfo; use Einfo; 31with Elists; use Elists; 32with Errout; use Errout; 33with Exp_Ch11; use Exp_Ch11; 34with Exp_Tss; use Exp_Tss; 35with Exp_Util; use Exp_Util; 36with Expander; use Expander; 37with Lib; use Lib; 38with Lib.Load; use Lib.Load; 39with Namet; use Namet; 40with Nlists; use Nlists; 41with Nmake; use Nmake; 42with Opt; use Opt; 43with Output; use Output; 44with Restrict; use Restrict; 45with Rident; use Rident; 46with Rtsfind; use Rtsfind; 47with Sem; use Sem; 48with Sem_Aux; use Sem_Aux; 49with Sem_Cat; use Sem_Cat; 50with Sem_Ch7; use Sem_Ch7; 51with Sem_Ch8; use Sem_Ch8; 52with Sem_Disp; use Sem_Disp; 53with Sem_Prag; use Sem_Prag; 54with Sem_Util; use Sem_Util; 55with Sinfo; use Sinfo; 56with Sinput; use Sinput; 57with Snames; use Snames; 58with Stand; use Stand; 59with Table; 60with Tbuild; use Tbuild; 61with Uintp; use Uintp; 62with Uname; use Uname; 63 64with GNAT; use GNAT; 65with GNAT.Dynamic_HTables; use GNAT.Dynamic_HTables; 66with GNAT.Lists; use GNAT.Lists; 67with GNAT.Sets; use GNAT.Sets; 68 69package body Sem_Elab is 70 71 ----------------------------------------- 72 -- Access-before-elaboration mechanism -- 73 ----------------------------------------- 74 75 -- The access-before-elaboration (ABE) mechanism implemented in this unit 76 -- has the following objectives: 77 -- 78 -- * Diagnose at compile-time or install run-time checks to prevent ABE 79 -- access to data and behaviour. 80 -- 81 -- The high-level idea is to accurately diagnose ABE issues within a 82 -- single unit because the ABE mechanism can inspect the whole unit. 83 -- As soon as the elaboration graph extends to an external unit, the 84 -- diagnostics stop because the body of the unit may not be available. 85 -- Due to control and data flow, the ABE mechanism cannot accurately 86 -- determine whether a particular scenario will be elaborated or not. 87 -- Conditional ABE checks are therefore used to verify the elaboration 88 -- status of local and external targets at run time. 89 -- 90 -- * Supply implicit elaboration dependencies for a unit to binde 91 -- 92 -- The ABE mechanism creates implicit dependencies in the form of with 93 -- clauses subject to pragma Elaborate[_All] when the elaboration graph 94 -- reaches into an external unit. The implicit dependencies are encoded 95 -- in the ALI file of the main unit. GNATbind and binde then use these 96 -- dependencies to augment the library item graph and determine the 97 -- elaboration order of all units in the compilation. 98 -- 99 -- * Supply pieces of the invocation graph for a unit to bindo 100 -- 101 -- The ABE mechanism captures paths starting from elaboration code or 102 -- top level constructs that reach into an external unit. The paths are 103 -- encoded in the ALI file of the main unit in the form of declarations 104 -- which represent nodes, and relations which represent edges. GNATbind 105 -- and bindo then build the full invocation graph in order to augment 106 -- the library item graph and determine the elaboration order of all 107 -- units in the compilation. 108 -- 109 -- The ABE mechanism supports three models of elaboration: 110 -- 111 -- * Dynamic model - This is the most permissive of the three models. 112 -- When the dynamic model is in effect, the mechanism diagnoses and 113 -- installs run-time checks to detect ABE issues in the main unit. 114 -- The behaviour of this model is identical to that specified by the 115 -- Ada RM. This model is enabled with switch -gnatE. 116 -- 117 -- Static model - This is the middle ground of the three models. When 118 -- the static model is in effect, the mechanism diagnoses and installs 119 -- run-time checks to detect ABE issues in the main unit. In addition, 120 -- the mechanism generates implicit dependencies between units in the 121 -- form of with clauses subject to pragma Elaborate[_All] to ensure 122 -- the prior elaboration of withed units. This is the default model. 123 -- 124 -- * SPARK model - This is the most conservative of the three models and 125 -- impelements the semantics defined in SPARK RM 7.7. The SPARK model 126 -- is in effect only when a context resides in a SPARK_Mode On region, 127 -- otherwise the mechanism falls back to one of the previous models. 128 -- 129 -- The ABE mechanism consists of a "recording" phase and a "processing" 130 -- phase. 131 132 ----------------- 133 -- Terminology -- 134 ----------------- 135 136 -- * ABE - An attempt to invoke a scenario which has not been elaborated 137 -- yet. 138 -- 139 -- * Bridge target - A type of target. A bridge target is a link between 140 -- scenarios. It is usually a byproduct of expansion and does not have 141 -- any direct ABE ramifications. 142 -- 143 -- * Call marker - A special node used to indicate the presence of a call 144 -- in the tree in case expansion transforms or eliminates the original 145 -- call. N_Call_Marker nodes do not have static and run-time semantics. 146 -- 147 -- * Conditional ABE - A type of ABE. A conditional ABE occurs when the 148 -- invocation of a target by a scenario within the main unit causes an 149 -- ABE, but does not cause an ABE for another scenarios within the main 150 -- unit. 151 -- 152 -- * Declaration level - A type of enclosing level. A scenario or target is 153 -- at the declaration level when it appears within the declarations of a 154 -- block statement, entry body, subprogram body, or task body, ignoring 155 -- enclosing packages. 156 -- 157 -- * Early call region - A section of code which ends at a subprogram body 158 -- and starts from the nearest non-preelaborable construct which precedes 159 -- the subprogram body. The early call region extends from a package body 160 -- to a package spec when the spec carries pragma Elaborate_Body. 161 -- 162 -- * Generic library level - A type of enclosing level. A scenario or 163 -- target is at the generic library level if it appears in a generic 164 -- package library unit, ignoring enclosing packages. 165 -- 166 -- * Guaranteed ABE - A type of ABE. A guaranteed ABE occurs when the 167 -- invocation of a target by all scenarios within the main unit causes 168 -- an ABE. 169 -- 170 -- * Instantiation library level - A type of enclosing level. A scenario 171 -- or target is at the instantiation library level if it appears in an 172 -- instantiation library unit, ignoring enclosing packages. 173 -- 174 -- * Invocation - The act of activating a task, calling a subprogram, or 175 -- instantiating a generic. 176 -- 177 -- * Invocation construct - An entry declaration, [single] protected type, 178 -- subprogram declaration, subprogram instantiation, or a [single] task 179 -- type declared in the visible, private, or body declarations of the 180 -- main unit. 181 -- 182 -- * Invocation relation - A flow link between two invocation constructs 183 -- 184 -- * Invocation signature - A set of attributes that uniquely identify an 185 -- invocation construct within the namespace of all ALI files. 186 -- 187 -- * Library level - A type of enclosing level. A scenario or target is at 188 -- the library level if it appears in a package library unit, ignoring 189 -- enclosng packages. 190 -- 191 -- * Non-library-level encapsulator - A construct that cannot be elaborated 192 -- on its own and requires elaboration by a top-level scenario. 193 -- 194 -- * Scenario - A construct or context which is invoked by elaboration code 195 -- or invocation construct. The scenarios recognized by the ABE mechanism 196 -- are as follows: 197 -- 198 -- - '[Unrestricted_]Access of entries, operators, and subprograms 199 -- 200 -- - Assignments to variables 201 -- 202 -- - Calls to entries, operators, and subprograms 203 -- 204 -- - Derived type declarations 205 -- 206 -- - Instantiations 207 -- 208 -- - Pragma Refined_State 209 -- 210 -- - Reads of variables 211 -- 212 -- - Task activation 213 -- 214 -- * Target - A construct invoked by a scenario. The targets recognized by 215 -- the ABE mechanism are as follows: 216 -- 217 -- - For '[Unrestricted_]Access of entries, operators, and subprograms, 218 -- the target is the entry, operator, or subprogram. 219 -- 220 -- - For assignments to variables, the target is the variable 221 -- 222 -- - For calls, the target is the entry, operator, or subprogram 223 -- 224 -- - For derived type declarations, the target is the derived type 225 -- 226 -- - For instantiations, the target is the generic template 227 -- 228 -- - For pragma Refined_State, the targets are the constituents 229 -- 230 -- - For reads of variables, the target is the variable 231 -- 232 -- - For task activation, the target is the task body 233 234 ------------------ 235 -- Architecture -- 236 ------------------ 237 238 -- Analysis/Resolution 239 -- | 240 -- +- Build_Call_Marker 241 -- | 242 -- +- Build_Variable_Reference_Marker 243 -- | 244 -- +- | -------------------- Recording phase ---------------------------+ 245 -- | v | 246 -- | Record_Elaboration_Scenario | 247 -- | | | 248 -- | +--> Check_Preelaborated_Call | 249 -- | | | 250 -- | +--> Process_Guaranteed_ABE | 251 -- | | | | 252 -- | | +--> Process_Guaranteed_ABE_Activation | 253 -- | | +--> Process_Guaranteed_ABE_Call | 254 -- | | +--> Process_Guaranteed_ABE_Instantiation | 255 -- | | | 256 -- +- | ----------------------------------------------------------------+ 257 -- | 258 -- | 259 -- +--> Internal_Representation 260 -- | 261 -- +--> Scenario_Storage 262 -- | 263 -- End of Compilation 264 -- | 265 -- +- | --------------------- Processing phase -------------------------+ 266 -- | v | 267 -- | Check_Elaboration_Scenarios | 268 -- | | | 269 -- | +--> Check_Conditional_ABE_Scenarios | 270 -- | | | | 271 -- | | +--> Process_Conditional_ABE <----------------------+ | 272 -- | | | | | 273 -- | | +--> Process_Conditional_ABE_Activation | | 274 -- | | | | | | 275 -- | | | +-----------------------------+ | | 276 -- | | | | | | 277 -- | | +--> Process_Conditional_ABE_Call +---> Traverse_Body | 278 -- | | | | | | 279 -- | | | +-----------------------------+ | 280 -- | | | | 281 -- | | +--> Process_Conditional_ABE_Access_Taken | 282 -- | | +--> Process_Conditional_ABE_Instantiation | 283 -- | | +--> Process_Conditional_ABE_Variable_Assignment | 284 -- | | +--> Process_Conditional_ABE_Variable_Reference | 285 -- | | | 286 -- | +--> Check_SPARK_Scenario | 287 -- | | | | 288 -- | | +--> Process_SPARK_Scenario | 289 -- | | | | 290 -- | | +--> Process_SPARK_Derived_Type | 291 -- | | +--> Process_SPARK_Instantiation | 292 -- | | +--> Process_SPARK_Refined_State_Pragma | 293 -- | | | 294 -- | +--> Record_Invocation_Graph | 295 -- | | | 296 -- | +--> Process_Invocation_Body_Scenarios | 297 -- | +--> Process_Invocation_Spec_Scenarios | 298 -- | +--> Process_Main_Unit | 299 -- | | | 300 -- | +--> Process_Invocation_Scenario <-------------+ | 301 -- | | | | 302 -- | +--> Process_Invocation_Activation | | 303 -- | | | | | 304 -- | | +------------------------+ | | 305 -- | | | | | 306 -- | +--> Process_Invocation_Call +---> Traverse_Body | 307 -- | | | | 308 -- | +------------------------+ | 309 -- | | 310 -- +--------------------------------------------------------------------+ 311 312 --------------------- 313 -- Recording phase -- 314 --------------------- 315 316 -- The Recording phase coincides with the analysis/resolution phase of the 317 -- compiler. It has the following objectives: 318 -- 319 -- * Record all suitable scenarios for examination by the Processing 320 -- phase. 321 -- 322 -- Saving only a certain number of nodes improves the performance of 323 -- the ABE mechanism. This eliminates the need to examine the whole 324 -- tree in a separate pass. 325 -- 326 -- * Record certain SPARK scenarios which are not necessarily invoked 327 -- during elaboration, but still require elaboration-related checks. 328 -- 329 -- Saving only a certain number of nodes improves the performance of 330 -- the ABE mechanism. This eliminates the need to examine the whole 331 -- tree in a separate pass. 332 -- 333 -- * Detect and diagnose calls in preelaborable or pure units, including 334 -- generic bodies. 335 -- 336 -- This diagnostic is carried out during the Recording phase because it 337 -- does not need the heavy recursive traversal done by the Processing 338 -- phase. 339 -- 340 -- * Detect and diagnose guaranteed ABEs caused by instantiations, calls, 341 -- and task activation. 342 -- 343 -- The issues detected by the ABE mechanism are reported as warnings 344 -- because they do not violate Ada semantics. Forward instantiations 345 -- may thus reach gigi, however gigi cannot handle certain kinds of 346 -- premature instantiations and may crash. To avoid this limitation, 347 -- the ABE mechanism must identify forward instantiations as early as 348 -- possible and suppress their bodies. Calls and task activations are 349 -- included in this category for completeness. 350 351 ---------------------- 352 -- Processing phase -- 353 ---------------------- 354 355 -- The Processing phase is a separate pass which starts after instantiating 356 -- and/or inlining of bodies, but before the removal of Ghost code. It has 357 -- the following objectives: 358 -- 359 -- * Examine all scenarios saved during the Recording phase, and perform 360 -- the following actions: 361 -- 362 -- - Dynamic model 363 -- 364 -- Diagnose conditional ABEs, and install run-time conditional ABE 365 -- checks for all scenarios. 366 -- 367 -- - SPARK model 368 -- 369 -- Enforce the SPARK elaboration rules 370 -- 371 -- - Static model 372 -- 373 -- Diagnose conditional ABEs, install run-time conditional ABE 374 -- checks only for scenarios are reachable from elaboration code, 375 -- and guarantee the elaboration of external units by creating 376 -- implicit with clauses subject to pragma Elaborate[_All]. 377 -- 378 -- * Examine library-level scenarios and invocation constructs, and 379 -- perform the following actions: 380 -- 381 -- - Determine whether the flow of execution reaches into an external 382 -- unit. If this is the case, encode the path in the ALI file of 383 -- the main unit. 384 -- 385 -- - Create declarations for invocation constructs in the ALI file of 386 -- the main unit. 387 388 ---------------------- 389 -- Important points -- 390 ---------------------- 391 392 -- The Processing phase starts after the analysis, resolution, expansion 393 -- phase has completed. As a result, no current semantic information is 394 -- available. The scope stack is empty, global flags such as In_Instance 395 -- or Inside_A_Generic become useless. To remedy this, the ABE mechanism 396 -- must either save or recompute semantic information. 397 -- 398 -- Expansion heavily transforms calls and to some extent instantiations. To 399 -- remedy this, the ABE mechanism generates N_Call_Marker nodes in order to 400 -- capture the target and relevant attributes of the original call. 401 -- 402 -- The diagnostics of the ABE mechanism depend on accurate source locations 403 -- to determine the spacial relation of nodes. 404 405 ----------------------------------------- 406 -- Suppression of elaboration warnings -- 407 ----------------------------------------- 408 409 -- Elaboration warnings along multiple traversal paths rooted at a scenario 410 -- are suppressed when the scenario has elaboration warnings suppressed. 411 -- 412 -- Root scenario 413 -- | 414 -- +-- Child scenario 1 415 -- | | 416 -- | +-- Grandchild scenario 1 417 -- | | 418 -- | +-- Grandchild scenario N 419 -- | 420 -- +-- Child scenario N 421 -- 422 -- If the root scenario has elaboration warnings suppressed, then all its 423 -- child, grandchild, etc. scenarios will have their elaboration warnings 424 -- suppressed. 425 -- 426 -- In addition to switch -gnatwL, pragma Warnings may be used to suppress 427 -- elaboration-related warnings when used in the following manner: 428 -- 429 -- pragma Warnings ("L"); 430 -- <scenario-or-target> 431 -- 432 -- <target> 433 -- pragma Warnings (Off, target); 434 -- 435 -- pragma Warnings (Off); 436 -- <scenario-or-target> 437 -- 438 -- * To suppress elaboration warnings for '[Unrestricted_]Access of 439 -- entries, operators, and subprograms, either: 440 -- 441 -- - Suppress the entry, operator, or subprogram, or 442 -- - Suppress the attribute, or 443 -- - Use switch -gnatw.f 444 -- 445 -- * To suppress elaboration warnings for calls to entries, operators, 446 -- and subprograms, either: 447 -- 448 -- - Suppress the entry, operator, or subprogram, or 449 -- - Suppress the call 450 -- 451 -- * To suppress elaboration warnings for instantiations, suppress the 452 -- instantiation. 453 -- 454 -- * To suppress elaboration warnings for task activations, either: 455 -- 456 -- - Suppress the task object, or 457 -- - Suppress the task type, or 458 -- - Suppress the activation call 459 460 -------------- 461 -- Switches -- 462 -------------- 463 464 -- The following switches may be used to control the behavior of the ABE 465 -- mechanism. 466 -- 467 -- -gnatd_a stop elaboration checks on accept or select statement 468 -- 469 -- The ABE mechanism stops the traversal of a task body when it 470 -- encounters an accept or a select statement. This behavior is 471 -- equivalent to restriction No_Entry_Calls_In_Elaboration_Code, 472 -- but without penalizing actual entry calls during elaboration. 473 -- 474 -- -gnatd_e ignore entry calls and requeue statements for elaboration 475 -- 476 -- The ABE mechanism does not generate N_Call_Marker nodes for 477 -- protected or task entry calls as well as requeue statements. 478 -- As a result, the calls and requeues are not recorded or 479 -- processed. 480 -- 481 -- -gnatdE elaboration checks on predefined units 482 -- 483 -- The ABE mechanism considers scenarios which appear in internal 484 -- units (Ada, GNAT, Interfaces, System). 485 -- 486 -- -gnatd_F encode full invocation paths in ALI files 487 -- 488 -- The ABE mechanism encodes the full path from an elaboration 489 -- procedure or invocable construct to an external target. The 490 -- path contains all intermediate activations, instantiations, 491 -- and calls. 492 -- 493 -- -gnatd.G ignore calls through generic formal parameters for elaboration 494 -- 495 -- The ABE mechanism does not generate N_Call_Marker nodes for 496 -- calls which occur in expanded instances, and invoke generic 497 -- actual subprograms through generic formal subprograms. As a 498 -- result, the calls are not recorded or processed. 499 -- 500 -- -gnatd_i ignore activations and calls to instances for elaboration 501 -- 502 -- The ABE mechanism ignores calls and task activations when they 503 -- target a subprogram or task type defined an external instance. 504 -- As a result, the calls and task activations are not processed. 505 -- 506 -- -gnatdL ignore external calls from instances for elaboration 507 -- 508 -- The ABE mechanism does not generate N_Call_Marker nodes for 509 -- calls which occur in expanded instances, do not invoke generic 510 -- actual subprograms through formal subprograms, and the target 511 -- is external to the instance. As a result, the calls are not 512 -- recorded or processed. 513 -- 514 -- -gnatd.o conservative elaboration order for indirect calls 515 -- 516 -- The ABE mechanism treats '[Unrestricted_]Access of an entry, 517 -- operator, or subprogram as an immediate invocation of the 518 -- target. As a result, it performs ABE checks and diagnostics on 519 -- the immediate call. 520 -- 521 -- -gnatd_p ignore assertion pragmas for elaboration 522 -- 523 -- The ABE mechanism does not generate N_Call_Marker nodes for 524 -- calls to subprograms which verify the run-time semantics of 525 -- the following assertion pragmas: 526 -- 527 -- Default_Initial_Condition 528 -- Initial_Condition 529 -- Invariant 530 -- Invariant'Class 531 -- Post 532 -- Post'Class 533 -- Postcondition 534 -- Type_Invariant 535 -- Type_Invariant_Class 536 -- 537 -- As a result, the assertion expressions of the pragmas are not 538 -- processed. 539 -- 540 -- -gnatd_s stop elaboration checks on synchronous suspension 541 -- 542 -- The ABE mechanism stops the traversal of a task body when it 543 -- encounters a call to one of the following routines: 544 -- 545 -- Ada.Synchronous_Barriers.Wait_For_Release 546 -- Ada.Synchronous_Task_Control.Suspend_Until_True 547 -- 548 -- -gnatd_T output trace information on invocation relation construction 549 -- 550 -- The ABE mechanism outputs text information concerning relation 551 -- construction to standard output. 552 -- 553 -- -gnatd.U ignore indirect calls for static elaboration 554 -- 555 -- The ABE mechanism does not consider '[Unrestricted_]Access of 556 -- entries, operators, and subprograms. As a result, the scenarios 557 -- are not recorder or processed. 558 -- 559 -- -gnatd.v enforce SPARK elaboration rules in SPARK code 560 -- 561 -- The ABE mechanism applies some of the SPARK elaboration rules 562 -- defined in the SPARK reference manual, chapter 7.7. Note that 563 -- certain rules are always enforced, regardless of whether the 564 -- switch is active. 565 -- 566 -- -gnatd.y disable implicit pragma Elaborate_All on task bodies 567 -- 568 -- The ABE mechanism does not generate implicit Elaborate_All when 569 -- the need for the pragma came from a task body. 570 -- 571 -- -gnatE dynamic elaboration checking mode enabled 572 -- 573 -- The ABE mechanism assumes that any scenario is elaborated or 574 -- invoked by elaboration code. The ABE mechanism performs very 575 -- little diagnostics and generates condintional ABE checks to 576 -- detect ABE issues at run-time. 577 -- 578 -- -gnatel turn on info messages on generated Elaborate[_All] pragmas 579 -- 580 -- The ABE mechanism produces information messages on generated 581 -- implicit Elabote[_All] pragmas along with traceback showing 582 -- why the pragma was generated. In addition, the ABE mechanism 583 -- produces information messages for each scenario elaborated or 584 -- invoked by elaboration code. 585 -- 586 -- -gnateL turn off info messages on generated Elaborate[_All] pragmas 587 -- 588 -- The complementary switch for -gnatel. 589 -- 590 -- -gnatH legacy elaboration checking mode enabled 591 -- 592 -- When this switch is in effect, the pre-18.x ABE model becomes 593 -- the defacto ABE model. This ammounts to cutting off all entry 594 -- points into the new ABE mechanism, and giving full control to 595 -- the old ABE mechanism. 596 -- 597 -- -gnatJ permissive elaboration checking mode enabled 598 -- 599 -- This switch activates the following switches: 600 -- 601 -- -gnatd_a 602 -- -gnatd_e 603 -- -gnatd.G 604 -- -gnatd_i 605 -- -gnatdL 606 -- -gnatd_p 607 -- -gnatd_s 608 -- -gnatd.U 609 -- -gnatd.y 610 -- 611 -- IMPORTANT: The behavior of the ABE mechanism becomes more 612 -- permissive at the cost of accurate diagnostics and runtime 613 -- ABE checks. 614 -- 615 -- -gnatw.f turn on warnings for suspicious Subp'Access 616 -- 617 -- The ABE mechanism treats '[Unrestricted_]Access of an entry, 618 -- operator, or subprogram as a pseudo invocation of the target. 619 -- As a result, it performs ABE diagnostics on the pseudo call. 620 -- 621 -- -gnatw.F turn off warnings for suspicious Subp'Access 622 -- 623 -- The complementary switch for -gnatw.f. 624 -- 625 -- -gnatwl turn on warnings for elaboration problems 626 -- 627 -- The ABE mechanism produces warnings on detected ABEs along with 628 -- a traceback showing the graph of the ABE. 629 -- 630 -- -gnatwL turn off warnings for elaboration problems 631 -- 632 -- The complementary switch for -gnatwl. 633 634 -------------------------- 635 -- Debugging ABE issues -- 636 -------------------------- 637 638 -- * If the issue involves a call, ensure that the call is eligible for ABE 639 -- processing and receives a corresponding call marker. The routines of 640 -- interest are 641 -- 642 -- Build_Call_Marker 643 -- Record_Elaboration_Scenario 644 -- 645 -- * If the issue involves an arbitrary scenario, ensure that the scenario 646 -- is either recorded, or is successfully recognized while traversing a 647 -- body. The routines of interest are 648 -- 649 -- Record_Elaboration_Scenario 650 -- Process_Conditional_ABE 651 -- Process_Guaranteed_ABE 652 -- Traverse_Body 653 -- 654 -- * If the issue involves a circularity in the elaboration order, examine 655 -- the ALI files and look for the following encodings next to units: 656 -- 657 -- E indicates a source Elaborate 658 -- 659 -- EA indicates a source Elaborate_All 660 -- 661 -- AD indicates an implicit Elaborate_All 662 -- 663 -- ED indicates an implicit Elaborate 664 -- 665 -- If possible, compare these encodings with those generated by the old 666 -- ABE mechanism. The routines of interest are 667 -- 668 -- Ensure_Prior_Elaboration 669 670 ----------- 671 -- Kinds -- 672 ----------- 673 674 -- The following type enumerates all possible elaboration phase statutes 675 676 type Elaboration_Phase_Status is 677 (Inactive, 678 -- The elaboration phase of the compiler has not started yet 679 680 Active, 681 -- The elaboration phase of the compiler is currently in progress 682 683 Completed); 684 -- The elaboration phase of the compiler has finished 685 686 Elaboration_Phase : Elaboration_Phase_Status := Inactive; 687 -- The status of the elaboration phase. Use routine Set_Elaboration_Phase 688 -- to alter its value. 689 690 -- The following type enumerates all subprogram body traversal modes 691 692 type Body_Traversal_Kind is 693 (Deep_Traversal, 694 -- The traversal examines the internals of a subprogram 695 696 No_Traversal); 697 698 -- The following type enumerates all operation modes 699 700 type Processing_Kind is 701 (Conditional_ABE_Processing, 702 -- The ABE mechanism detects and diagnoses conditional ABEs for library 703 -- and declaration-level scenarios. 704 705 Dynamic_Model_Processing, 706 -- The ABE mechanism installs conditional ABE checks for all eligible 707 -- scenarios when the dynamic model is in effect. 708 709 Guaranteed_ABE_Processing, 710 -- The ABE mechanism detects and diagnoses guaranteed ABEs caused by 711 -- calls, instantiations, and task activations. 712 713 Invocation_Construct_Processing, 714 -- The ABE mechanism locates all invocation constructs within the main 715 -- unit and utilizes them as roots of miltiple DFS traversals aimed at 716 -- detecting transitions from the main unit to an external unit. 717 718 Invocation_Body_Processing, 719 -- The ABE mechanism utilizes all library-level body scenarios as roots 720 -- of miltiple DFS traversals aimed at detecting transitions from the 721 -- main unit to an external unit. 722 723 Invocation_Spec_Processing, 724 -- The ABE mechanism utilizes all library-level spec scenarios as roots 725 -- of miltiple DFS traversals aimed at detecting transitions from the 726 -- main unit to an external unit. 727 728 SPARK_Processing, 729 -- The ABE mechanism detects and diagnoses violations of the SPARK 730 -- elaboration rules for SPARK-specific scenarios. 731 732 No_Processing); 733 734 -- The following type enumerates all possible scenario kinds 735 736 type Scenario_Kind is 737 (Access_Taken_Scenario, 738 -- An attribute reference which takes 'Access or 'Unrestricted_Access of 739 -- an entry, operator, or subprogram. 740 741 Call_Scenario, 742 -- A call which invokes an entry, operator, or subprogram 743 744 Derived_Type_Scenario, 745 -- A declaration of a derived type. This is a SPARK-specific scenario. 746 747 Instantiation_Scenario, 748 -- An instantiation which instantiates a generic package or subprogram. 749 -- This scenario is also subject to SPARK-specific rules. 750 751 Refined_State_Pragma_Scenario, 752 -- A Refined_State pragma. This is a SPARK-specific scenario. 753 754 Task_Activation_Scenario, 755 -- A call which activates objects of various task types 756 757 Variable_Assignment_Scenario, 758 -- An assignment statement which modifies the value of some variable 759 760 Variable_Reference_Scenario, 761 -- A reference to a variable. This is a SPARK-specific scenario. 762 763 No_Scenario); 764 765 -- The following type enumerates all possible consistency models of target 766 -- and scenario representations. 767 768 type Representation_Kind is 769 (Inconsistent_Representation, 770 -- A representation is said to be "inconsistent" when it is created from 771 -- a partially analyzed tree. In such an environment, certain attributes 772 -- such as a completing body may not be available yet. 773 774 Consistent_Representation, 775 -- A representation is said to be "consistent" when it is created from a 776 -- fully analyzed tree, where all attributes are available. 777 778 No_Representation); 779 780 -- The following type enumerates all possible target kinds 781 782 type Target_Kind is 783 (Generic_Target, 784 -- A generic unit being instantiated 785 786 Package_Target, 787 -- The package form of an instantiation 788 789 Subprogram_Target, 790 -- An entry, operator, or subprogram being invoked, or aliased through 791 -- 'Access or 'Unrestricted_Access. 792 793 Task_Target, 794 -- A task being activated by an activation call 795 796 Variable_Target, 797 -- A variable being updated through an assignment statement, or read 798 -- through a variable reference. 799 800 No_Target); 801 802 ----------- 803 -- Types -- 804 ----------- 805 806 procedure Destroy (NE : in out Node_Or_Entity_Id); 807 pragma Inline (Destroy); 808 -- Destroy node or entity NE 809 810 function Hash (NE : Node_Or_Entity_Id) return Bucket_Range_Type; 811 pragma Inline (Hash); 812 -- Obtain the hash value of key NE 813 814 -- The following is a general purpose list for nodes and entities 815 816 package NE_List is new Doubly_Linked_Lists 817 (Element_Type => Node_Or_Entity_Id, 818 "=" => "=", 819 Destroy_Element => Destroy); 820 821 -- The following is a general purpose map which relates nodes and entities 822 -- to lists of nodes and entities. 823 824 package NE_List_Map is new Dynamic_Hash_Tables 825 (Key_Type => Node_Or_Entity_Id, 826 Value_Type => NE_List.Doubly_Linked_List, 827 No_Value => NE_List.Nil, 828 Expansion_Threshold => 1.5, 829 Expansion_Factor => 2, 830 Compression_Threshold => 0.3, 831 Compression_Factor => 2, 832 "=" => "=", 833 Destroy_Value => NE_List.Destroy, 834 Hash => Hash); 835 836 -- The following is a general purpose membership set for nodes and entities 837 838 package NE_Set is new Membership_Sets 839 (Element_Type => Node_Or_Entity_Id, 840 "=" => "=", 841 Hash => Hash); 842 843 -- The following type captures relevant attributes which pertain to the 844 -- in state of the Processing phase. 845 846 type Processing_In_State is record 847 Processing : Processing_Kind := No_Processing; 848 -- Operation mode of the Processing phase. Once set, this value should 849 -- not be changed. 850 851 Representation : Representation_Kind := No_Representation; 852 -- Required level of scenario and target representation. Once set, this 853 -- value should not be changed. 854 855 Suppress_Checks : Boolean := False; 856 -- This flag is set when the Processing phase must not generate any ABE 857 -- checks. 858 859 Suppress_Implicit_Pragmas : Boolean := False; 860 -- This flag is set when the Processing phase must not generate any 861 -- implicit Elaborate[_All] pragmas. 862 863 Suppress_Info_Messages : Boolean := False; 864 -- This flag is set when the Processing phase must not emit any info 865 -- messages. 866 867 Suppress_Up_Level_Targets : Boolean := False; 868 -- This flag is set when the Processing phase must ignore up-level 869 -- targets. 870 871 Suppress_Warnings : Boolean := False; 872 -- This flag is set when the Processing phase must not emit any warnings 873 -- on elaboration problems. 874 875 Traversal : Body_Traversal_Kind := No_Traversal; 876 -- The subprogram body traversal mode. Once set, this value should not 877 -- be changed. 878 879 Within_Generic : Boolean := False; 880 -- This flag is set when the Processing phase is currently within a 881 -- generic unit. 882 883 Within_Initial_Condition : Boolean := False; 884 -- This flag is set when the Processing phase is currently examining a 885 -- scenario which was reached from an initial condition procedure. 886 887 Within_Partial_Finalization : Boolean := False; 888 -- This flag is set when the Processing phase is currently examining a 889 -- scenario which was reached from a partial finalization procedure. 890 891 Within_Task_Body : Boolean := False; 892 -- This flag is set when the Processing phase is currently examining a 893 -- scenario which was reached from a task body. 894 end record; 895 896 -- The following constants define the various operational states of the 897 -- Processing phase. 898 899 -- The conditional ABE state is used when processing scenarios that appear 900 -- at the declaration, instantiation, and library levels to detect errors 901 -- and install conditional ABE checks. 902 903 Conditional_ABE_State : constant Processing_In_State := 904 (Processing => Conditional_ABE_Processing, 905 Representation => Consistent_Representation, 906 Traversal => Deep_Traversal, 907 others => False); 908 909 -- The dynamic model state is used to install conditional ABE checks when 910 -- switch -gnatE (dynamic elaboration checking mode enabled) is in effect. 911 912 Dynamic_Model_State : constant Processing_In_State := 913 (Processing => Dynamic_Model_Processing, 914 Representation => Consistent_Representation, 915 Suppress_Implicit_Pragmas => True, 916 Suppress_Info_Messages => True, 917 Suppress_Up_Level_Targets => True, 918 Suppress_Warnings => True, 919 Traversal => No_Traversal, 920 others => False); 921 922 -- The guaranteed ABE state is used when processing scenarios that appear 923 -- at the declaration, instantiation, and library levels to detect errors 924 -- and install guarateed ABE failures. 925 926 Guaranteed_ABE_State : constant Processing_In_State := 927 (Processing => Guaranteed_ABE_Processing, 928 Representation => Inconsistent_Representation, 929 Suppress_Implicit_Pragmas => True, 930 Traversal => No_Traversal, 931 others => False); 932 933 -- The invocation body state is used when processing scenarios that appear 934 -- at the body library level to encode paths that start from elaboration 935 -- code and ultimately reach into external units. 936 937 Invocation_Body_State : constant Processing_In_State := 938 (Processing => Invocation_Body_Processing, 939 Representation => Consistent_Representation, 940 Suppress_Checks => True, 941 Suppress_Implicit_Pragmas => True, 942 Suppress_Info_Messages => True, 943 Suppress_Up_Level_Targets => True, 944 Suppress_Warnings => True, 945 Traversal => Deep_Traversal, 946 others => False); 947 948 -- The invocation construct state is used when processing constructs that 949 -- appear within the spec and body of the main unit and eventually reach 950 -- into external units. 951 952 Invocation_Construct_State : constant Processing_In_State := 953 (Processing => Invocation_Construct_Processing, 954 Representation => Consistent_Representation, 955 Suppress_Checks => True, 956 Suppress_Implicit_Pragmas => True, 957 Suppress_Info_Messages => True, 958 Suppress_Up_Level_Targets => True, 959 Suppress_Warnings => True, 960 Traversal => Deep_Traversal, 961 others => False); 962 963 -- The invocation spec state is used when processing scenarios that appear 964 -- at the spec library level to encode paths that start from elaboration 965 -- code and ultimately reach into external units. 966 967 Invocation_Spec_State : constant Processing_In_State := 968 (Processing => Invocation_Spec_Processing, 969 Representation => Consistent_Representation, 970 Suppress_Checks => True, 971 Suppress_Implicit_Pragmas => True, 972 Suppress_Info_Messages => True, 973 Suppress_Up_Level_Targets => True, 974 Suppress_Warnings => True, 975 Traversal => Deep_Traversal, 976 others => False); 977 978 -- The SPARK state is used when verying SPARK-specific semantics of certain 979 -- scenarios. 980 981 SPARK_State : constant Processing_In_State := 982 (Processing => SPARK_Processing, 983 Representation => Consistent_Representation, 984 Traversal => No_Traversal, 985 others => False); 986 987 -- The following type identifies a scenario representation 988 989 type Scenario_Rep_Id is new Natural; 990 991 No_Scenario_Rep : constant Scenario_Rep_Id := Scenario_Rep_Id'First; 992 First_Scenario_Rep : constant Scenario_Rep_Id := No_Scenario_Rep + 1; 993 994 -- The following type identifies a target representation 995 996 type Target_Rep_Id is new Natural; 997 998 No_Target_Rep : constant Target_Rep_Id := Target_Rep_Id'First; 999 First_Target_Rep : constant Target_Rep_Id := No_Target_Rep + 1; 1000 1001 -------------- 1002 -- Services -- 1003 -------------- 1004 1005 -- The following package keeps track of all active scenarios during a DFS 1006 -- traversal. 1007 1008 package Active_Scenarios is 1009 1010 ----------- 1011 -- Types -- 1012 ----------- 1013 1014 -- The following type defines the position within the active scenario 1015 -- stack. 1016 1017 type Active_Scenario_Pos is new Natural; 1018 1019 --------------------- 1020 -- Data structures -- 1021 --------------------- 1022 1023 -- The following table stores all active scenarios in a DFS traversal. 1024 -- This table must be maintained in a FIFO fashion. 1025 1026 package Active_Scenario_Stack is new Table.Table 1027 (Table_Index_Type => Active_Scenario_Pos, 1028 Table_Component_Type => Node_Id, 1029 Table_Low_Bound => 1, 1030 Table_Initial => 50, 1031 Table_Increment => 200, 1032 Table_Name => "Active_Scenario_Stack"); 1033 1034 --------- 1035 -- API -- 1036 --------- 1037 1038 procedure Output_Active_Scenarios 1039 (Error_Nod : Node_Id; 1040 In_State : Processing_In_State); 1041 pragma Inline (Output_Active_Scenarios); 1042 -- Output the contents of the active scenario stack from earliest to 1043 -- latest to supplement an earlier error emitted for node Error_Nod. 1044 -- In_State denotes the current state of the Processing phase. 1045 1046 procedure Pop_Active_Scenario (N : Node_Id); 1047 pragma Inline (Pop_Active_Scenario); 1048 -- Pop the top of the scenario stack. A check is made to ensure that the 1049 -- scenario being removed is the same as N. 1050 1051 procedure Push_Active_Scenario (N : Node_Id); 1052 pragma Inline (Push_Active_Scenario); 1053 -- Push scenario N on top of the scenario stack 1054 1055 function Root_Scenario return Node_Id; 1056 pragma Inline (Root_Scenario); 1057 -- Return the scenario which started a DFS traversal 1058 1059 end Active_Scenarios; 1060 use Active_Scenarios; 1061 1062 -- The following package provides the main entry point for task activation 1063 -- processing. 1064 1065 package Activation_Processor is 1066 1067 ----------- 1068 -- Types -- 1069 ----------- 1070 1071 type Activation_Processor_Ptr is access procedure 1072 (Call : Node_Id; 1073 Call_Rep : Scenario_Rep_Id; 1074 Obj_Id : Entity_Id; 1075 Obj_Rep : Target_Rep_Id; 1076 Task_Typ : Entity_Id; 1077 Task_Rep : Target_Rep_Id; 1078 In_State : Processing_In_State); 1079 -- Reference to a procedure that takes all attributes of an activation 1080 -- and performs a desired action. Call is the activation call. Call_Rep 1081 -- is the representation of the call. Obj_Id is the task object being 1082 -- activated. Obj_Rep is the representation of the object. Task_Typ is 1083 -- the task type whose body is being activated. Task_Rep denotes the 1084 -- representation of the task type. In_State is the current state of 1085 -- the Processing phase. 1086 1087 --------- 1088 -- API -- 1089 --------- 1090 1091 procedure Process_Activation 1092 (Call : Node_Id; 1093 Call_Rep : Scenario_Rep_Id; 1094 Processor : Activation_Processor_Ptr; 1095 In_State : Processing_In_State); 1096 -- Find all task objects activated by activation call Call and invoke 1097 -- Processor on them. Call_Rep denotes the representation of the call. 1098 -- In_State is the current state of the Processing phase. 1099 1100 end Activation_Processor; 1101 use Activation_Processor; 1102 1103 -- The following package profides functionality for traversing subprogram 1104 -- bodies in DFS manner and processing of eligible scenarios within. 1105 1106 package Body_Processor is 1107 1108 ----------- 1109 -- Types -- 1110 ----------- 1111 1112 type Scenario_Predicate_Ptr is access function 1113 (N : Node_Id) return Boolean; 1114 -- Reference to a function which determines whether arbitrary node N 1115 -- denotes a suitable scenario for processing. 1116 1117 type Scenario_Processor_Ptr is access procedure 1118 (N : Node_Id; In_State : Processing_In_State); 1119 -- Reference to a procedure which processes scenario N. In_State is the 1120 -- current state of the Processing phase. 1121 1122 --------- 1123 -- API -- 1124 --------- 1125 1126 procedure Traverse_Body 1127 (N : Node_Id; 1128 Requires_Processing : Scenario_Predicate_Ptr; 1129 Processor : Scenario_Processor_Ptr; 1130 In_State : Processing_In_State); 1131 pragma Inline (Traverse_Body); 1132 -- Traverse the declarations and handled statements of subprogram body 1133 -- N, looking for scenarios that satisfy predicate Requires_Processing. 1134 -- Routine Processor is invoked for each such scenario. 1135 1136 procedure Reset_Traversed_Bodies; 1137 pragma Inline (Reset_Traversed_Bodies); 1138 -- Reset the visited status of all subprogram bodies that have already 1139 -- been processed by routine Traverse_Body. 1140 1141 ----------------- 1142 -- Maintenance -- 1143 ----------------- 1144 1145 procedure Finalize_Body_Processor; 1146 pragma Inline (Finalize_Body_Processor); 1147 -- Finalize all internal data structures 1148 1149 procedure Initialize_Body_Processor; 1150 pragma Inline (Initialize_Body_Processor); 1151 -- Initialize all internal data structures 1152 1153 end Body_Processor; 1154 use Body_Processor; 1155 1156 -- The following package provides functionality for installing ABE-related 1157 -- checks and failures. 1158 1159 package Check_Installer is 1160 1161 --------- 1162 -- API -- 1163 --------- 1164 1165 function Check_Or_Failure_Generation_OK return Boolean; 1166 pragma Inline (Check_Or_Failure_Generation_OK); 1167 -- Determine whether a conditional ABE check or guaranteed ABE failure 1168 -- can be generated. 1169 1170 procedure Install_Dynamic_ABE_Checks; 1171 pragma Inline (Install_Dynamic_ABE_Checks); 1172 -- Install conditional ABE checks for all saved scenarios when the 1173 -- dynamic model is in effect. 1174 1175 procedure Install_Scenario_ABE_Check 1176 (N : Node_Id; 1177 Targ_Id : Entity_Id; 1178 Targ_Rep : Target_Rep_Id; 1179 Disable : Scenario_Rep_Id); 1180 pragma Inline (Install_Scenario_ABE_Check); 1181 -- Install a conditional ABE check for scenario N to ensure that target 1182 -- Targ_Id is properly elaborated. Targ_Rep is the representation of the 1183 -- target. If the check is installed, disable the elaboration checks of 1184 -- scenario Disable. 1185 1186 procedure Install_Scenario_ABE_Check 1187 (N : Node_Id; 1188 Targ_Id : Entity_Id; 1189 Targ_Rep : Target_Rep_Id; 1190 Disable : Target_Rep_Id); 1191 pragma Inline (Install_Scenario_ABE_Check); 1192 -- Install a conditional ABE check for scenario N to ensure that target 1193 -- Targ_Id is properly elaborated. Targ_Rep is the representation of the 1194 -- target. If the check is installed, disable the elaboration checks of 1195 -- target Disable. 1196 1197 procedure Install_Scenario_ABE_Failure 1198 (N : Node_Id; 1199 Targ_Id : Entity_Id; 1200 Targ_Rep : Target_Rep_Id; 1201 Disable : Scenario_Rep_Id); 1202 pragma Inline (Install_Scenario_ABE_Failure); 1203 -- Install a guaranteed ABE failure for scenario N with target Targ_Id. 1204 -- Targ_Rep denotes the representation of the target. If the failure is 1205 -- installed, disable the elaboration checks of scenario Disable. 1206 1207 procedure Install_Scenario_ABE_Failure 1208 (N : Node_Id; 1209 Targ_Id : Entity_Id; 1210 Targ_Rep : Target_Rep_Id; 1211 Disable : Target_Rep_Id); 1212 pragma Inline (Install_Scenario_ABE_Failure); 1213 -- Install a guaranteed ABE failure for scenario N with target Targ_Id. 1214 -- Targ_Rep denotes the representation of the target. If the failure is 1215 -- installed, disable the elaboration checks of target Disable. 1216 1217 procedure Install_Unit_ABE_Check 1218 (N : Node_Id; 1219 Unit_Id : Entity_Id; 1220 Disable : Scenario_Rep_Id); 1221 pragma Inline (Install_Unit_ABE_Check); 1222 -- Install a conditional ABE check for scenario N to ensure that unit 1223 -- Unit_Id is properly elaborated. If the check is installed, disable 1224 -- the elaboration checks of scenario Disable. 1225 1226 procedure Install_Unit_ABE_Check 1227 (N : Node_Id; 1228 Unit_Id : Entity_Id; 1229 Disable : Target_Rep_Id); 1230 pragma Inline (Install_Unit_ABE_Check); 1231 -- Install a conditional ABE check for scenario N to ensure that unit 1232 -- Unit_Id is properly elaborated. If the check is installed, disable 1233 -- the elaboration checks of target Disable. 1234 1235 end Check_Installer; 1236 use Check_Installer; 1237 1238 -- The following package provides the main entry point for conditional ABE 1239 -- checks and diagnostics. 1240 1241 package Conditional_ABE_Processor is 1242 1243 --------- 1244 -- API -- 1245 --------- 1246 1247 procedure Check_Conditional_ABE_Scenarios 1248 (Iter : in out NE_Set.Iterator); 1249 pragma Inline (Check_Conditional_ABE_Scenarios); 1250 -- Perform conditional ABE checks and diagnostics for all scenarios 1251 -- available through iterator Iter. 1252 1253 procedure Process_Conditional_ABE 1254 (N : Node_Id; 1255 In_State : Processing_In_State); 1256 pragma Inline (Process_Conditional_ABE); 1257 -- Perform conditional ABE checks and diagnostics for scenario N. 1258 -- In_State denotes the current state of the Processing phase. 1259 1260 end Conditional_ABE_Processor; 1261 use Conditional_ABE_Processor; 1262 1263 -- The following package provides functionality to emit errors, information 1264 -- messages, and warnings. 1265 1266 package Diagnostics is 1267 1268 --------- 1269 -- API -- 1270 --------- 1271 1272 procedure Elab_Msg_NE 1273 (Msg : String; 1274 N : Node_Id; 1275 Id : Entity_Id; 1276 Info_Msg : Boolean; 1277 In_SPARK : Boolean); 1278 pragma Inline (Elab_Msg_NE); 1279 -- Wrapper around Error_Msg_NE. Emit message Msg concerning arbitrary 1280 -- node N and entity. If flag Info_Msg is set, the routine emits an 1281 -- information message, otherwise it emits an error. If flag In_SPARK 1282 -- is set, then string " in SPARK" is added to the end of the message. 1283 1284 procedure Info_Call 1285 (Call : Node_Id; 1286 Subp_Id : Entity_Id; 1287 Info_Msg : Boolean; 1288 In_SPARK : Boolean); 1289 pragma Inline (Info_Call); 1290 -- Output information concerning call Call that invokes subprogram 1291 -- Subp_Id. When flag Info_Msg is set, the routine emits an information 1292 -- message, otherwise it emits an error. When flag In_SPARK is set, " in 1293 -- SPARK" is added to the end of the message. 1294 1295 procedure Info_Instantiation 1296 (Inst : Node_Id; 1297 Gen_Id : Entity_Id; 1298 Info_Msg : Boolean; 1299 In_SPARK : Boolean); 1300 pragma Inline (Info_Instantiation); 1301 -- Output information concerning instantiation Inst which instantiates 1302 -- generic unit Gen_Id. If flag Info_Msg is set, the routine emits an 1303 -- information message, otherwise it emits an error. If flag In_SPARK 1304 -- is set, then string " in SPARK" is added to the end of the message. 1305 1306 procedure Info_Variable_Reference 1307 (Ref : Node_Id; 1308 Var_Id : Entity_Id; 1309 Info_Msg : Boolean; 1310 In_SPARK : Boolean); 1311 pragma Inline (Info_Variable_Reference); 1312 -- Output information concerning reference Ref which mentions variable 1313 -- Var_Id. If flag Info_Msg is set, the routine emits an information 1314 -- message, otherwise it emits an error. If flag In_SPARK is set, then 1315 -- string " in SPARK" is added to the end of the message. 1316 1317 end Diagnostics; 1318 use Diagnostics; 1319 1320 -- The following package provides functionality to locate the early call 1321 -- region of a subprogram body. 1322 1323 package Early_Call_Region_Processor is 1324 1325 --------- 1326 -- API -- 1327 --------- 1328 1329 function Find_Early_Call_Region 1330 (Body_Decl : Node_Id; 1331 Assume_Elab_Body : Boolean := False; 1332 Skip_Memoization : Boolean := False) return Node_Id; 1333 pragma Inline (Find_Early_Call_Region); 1334 -- Find the start of the early call region that belongs to subprogram 1335 -- body Body_Decl as defined in SPARK RM 7.7. This routine finds the 1336 -- early call region, memoizes it, and returns it, but this behavior 1337 -- can be altered. Flag Assume_Elab_Body should be set when a package 1338 -- spec may lack pragma Elaborate_Body, but the routine must still 1339 -- examine that spec. Flag Skip_Memoization should be set when the 1340 -- routine must avoid memoizing the region. 1341 1342 ----------------- 1343 -- Maintenance -- 1344 ----------------- 1345 1346 procedure Finalize_Early_Call_Region_Processor; 1347 pragma Inline (Finalize_Early_Call_Region_Processor); 1348 -- Finalize all internal data structures 1349 1350 procedure Initialize_Early_Call_Region_Processor; 1351 pragma Inline (Initialize_Early_Call_Region_Processor); 1352 -- Initialize all internal data structures 1353 1354 end Early_Call_Region_Processor; 1355 use Early_Call_Region_Processor; 1356 1357 -- The following package provides access to the elaboration statuses of all 1358 -- units withed by the main unit. 1359 1360 package Elaborated_Units is 1361 1362 --------- 1363 -- API -- 1364 --------- 1365 1366 procedure Collect_Elaborated_Units; 1367 pragma Inline (Collect_Elaborated_Units); 1368 -- Save the elaboration statuses of all units withed by the main unit 1369 1370 procedure Ensure_Prior_Elaboration 1371 (N : Node_Id; 1372 Unit_Id : Entity_Id; 1373 Prag_Nam : Name_Id; 1374 In_State : Processing_In_State); 1375 pragma Inline (Ensure_Prior_Elaboration); 1376 -- Guarantee the elaboration of unit Unit_Id with respect to the main 1377 -- unit by either suggesting or installing an Elaborate[_All] pragma 1378 -- denoted by Prag_Nam. N denotes the related scenario. In_State is the 1379 -- current state of the Processing phase. 1380 1381 function Has_Prior_Elaboration 1382 (Unit_Id : Entity_Id; 1383 Context_OK : Boolean := False; 1384 Elab_Body_OK : Boolean := False; 1385 Same_Unit_OK : Boolean := False) return Boolean; 1386 pragma Inline (Has_Prior_Elaboration); 1387 -- Determine whether unit Unit_Id is elaborated prior to the main unit. 1388 -- If flag Context_OK is set, the routine considers the following case 1389 -- as valid prior elaboration: 1390 -- 1391 -- * Unit_Id is in the elaboration context of the main unit 1392 -- 1393 -- If flag Elab_Body_OK is set, the routine considers the following case 1394 -- as valid prior elaboration: 1395 -- 1396 -- * Unit_Id has pragma Elaborate_Body and is not the main unit 1397 -- 1398 -- If flag Same_Unit_OK is set, the routine considers the following 1399 -- cases as valid prior elaboration: 1400 -- 1401 -- * Unit_Id is the main unit 1402 -- 1403 -- * Unit_Id denotes the spec of the main unit body 1404 1405 procedure Meet_Elaboration_Requirement 1406 (N : Node_Id; 1407 Targ_Id : Entity_Id; 1408 Req_Nam : Name_Id; 1409 In_State : Processing_In_State); 1410 pragma Inline (Meet_Elaboration_Requirement); 1411 -- Determine whether elaboration requirement Req_Nam for scenario N with 1412 -- target Targ_Id is met by the context of the main unit using the SPARK 1413 -- rules. Req_Nam must denote either Elaborate or Elaborate_All. Emit an 1414 -- error if this is not the case. In_State denotes the current state of 1415 -- the Processing phase. 1416 1417 ----------------- 1418 -- Maintenance -- 1419 ----------------- 1420 1421 procedure Finalize_Elaborated_Units; 1422 pragma Inline (Finalize_Elaborated_Units); 1423 -- Finalize all internal data structures 1424 1425 procedure Initialize_Elaborated_Units; 1426 pragma Inline (Initialize_Elaborated_Units); 1427 -- Initialize all internal data structures 1428 1429 end Elaborated_Units; 1430 use Elaborated_Units; 1431 1432 -- The following package provides the main entry point for guaranteed ABE 1433 -- checks and diagnostics. 1434 1435 package Guaranteed_ABE_Processor is 1436 1437 --------- 1438 -- API -- 1439 --------- 1440 1441 procedure Process_Guaranteed_ABE 1442 (N : Node_Id; 1443 In_State : Processing_In_State); 1444 pragma Inline (Process_Guaranteed_ABE); 1445 -- Perform guaranteed ABE checks and diagnostics for scenario N. 1446 -- In_State is the current state of the Processing phase. 1447 1448 end Guaranteed_ABE_Processor; 1449 use Guaranteed_ABE_Processor; 1450 1451 -- The following package provides access to the internal representation of 1452 -- scenarios and targets. 1453 1454 package Internal_Representation is 1455 1456 ----------- 1457 -- Types -- 1458 ----------- 1459 1460 -- The following type enumerates all possible Ghost mode kinds 1461 1462 type Extended_Ghost_Mode is 1463 (Is_Ignored, 1464 Is_Checked_Or_Not_Specified); 1465 1466 -- The following type enumerates all possible SPARK mode kinds 1467 1468 type Extended_SPARK_Mode is 1469 (Is_On, 1470 Is_Off_Or_Not_Specified); 1471 1472 -------------- 1473 -- Builders -- 1474 -------------- 1475 1476 function Scenario_Representation_Of 1477 (N : Node_Id; 1478 In_State : Processing_In_State) return Scenario_Rep_Id; 1479 pragma Inline (Scenario_Representation_Of); 1480 -- Obtain the id of elaboration scenario N's representation. The routine 1481 -- constructs the representation if it is not available. In_State is the 1482 -- current state of the Processing phase. 1483 1484 function Target_Representation_Of 1485 (Id : Entity_Id; 1486 In_State : Processing_In_State) return Target_Rep_Id; 1487 pragma Inline (Target_Representation_Of); 1488 -- Obtain the id of elaboration target Id's representation. The routine 1489 -- constructs the representation if it is not available. In_State is the 1490 -- current state of the Processing phase. 1491 1492 ------------------------- 1493 -- Scenario attributes -- 1494 ------------------------- 1495 1496 function Activated_Task_Objects 1497 (S_Id : Scenario_Rep_Id) return NE_List.Doubly_Linked_List; 1498 pragma Inline (Activated_Task_Objects); 1499 -- For Task_Activation_Scenario S_Id, obtain the list of task objects 1500 -- the scenario is activating. 1501 1502 function Activated_Task_Type (S_Id : Scenario_Rep_Id) return Entity_Id; 1503 pragma Inline (Activated_Task_Type); 1504 -- For Task_Activation_Scenario S_Id, obtain the currently activated 1505 -- task type. 1506 1507 procedure Disable_Elaboration_Checks (S_Id : Scenario_Rep_Id); 1508 pragma Inline (Disable_Elaboration_Checks); 1509 -- Disable elaboration checks of scenario S_Id 1510 1511 function Elaboration_Checks_OK (S_Id : Scenario_Rep_Id) return Boolean; 1512 pragma Inline (Elaboration_Checks_OK); 1513 -- Determine whether scenario S_Id may be subjected to elaboration 1514 -- checks. 1515 1516 function Elaboration_Warnings_OK (S_Id : Scenario_Rep_Id) return Boolean; 1517 pragma Inline (Elaboration_Warnings_OK); 1518 -- Determine whether scenario S_Id may be subjected to elaboration 1519 -- warnings. 1520 1521 function Ghost_Mode_Of 1522 (S_Id : Scenario_Rep_Id) return Extended_Ghost_Mode; 1523 pragma Inline (Ghost_Mode_Of); 1524 -- Obtain the Ghost mode of scenario S_Id 1525 1526 function Is_Dispatching_Call (S_Id : Scenario_Rep_Id) return Boolean; 1527 pragma Inline (Is_Dispatching_Call); 1528 -- For Call_Scenario S_Id, determine whether the call is dispatching 1529 1530 function Is_Read_Reference (S_Id : Scenario_Rep_Id) return Boolean; 1531 pragma Inline (Is_Read_Reference); 1532 -- For Variable_Reference_Scenario S_Id, determine whether the reference 1533 -- is a read. 1534 1535 function Kind (S_Id : Scenario_Rep_Id) return Scenario_Kind; 1536 pragma Inline (Kind); 1537 -- Obtain the nature of scenario S_Id 1538 1539 function Level (S_Id : Scenario_Rep_Id) return Enclosing_Level_Kind; 1540 pragma Inline (Level); 1541 -- Obtain the enclosing level of scenario S_Id 1542 1543 procedure Set_Activated_Task_Objects 1544 (S_Id : Scenario_Rep_Id; 1545 Task_Objs : NE_List.Doubly_Linked_List); 1546 pragma Inline (Set_Activated_Task_Objects); 1547 -- For Task_Activation_Scenario S_Id, set the list of task objects 1548 -- activated by the scenario to Task_Objs. 1549 1550 procedure Set_Activated_Task_Type 1551 (S_Id : Scenario_Rep_Id; 1552 Task_Typ : Entity_Id); 1553 pragma Inline (Set_Activated_Task_Type); 1554 -- For Task_Activation_Scenario S_Id, set the currently activated task 1555 -- type to Task_Typ. 1556 1557 function SPARK_Mode_Of 1558 (S_Id : Scenario_Rep_Id) return Extended_SPARK_Mode; 1559 pragma Inline (SPARK_Mode_Of); 1560 -- Obtain the SPARK mode of scenario S_Id 1561 1562 function Target (S_Id : Scenario_Rep_Id) return Entity_Id; 1563 pragma Inline (Target); 1564 -- Obtain the target of scenario S_Id 1565 1566 ----------------------- 1567 -- Target attributes -- 1568 ----------------------- 1569 1570 function Barrier_Body_Declaration (T_Id : Target_Rep_Id) return Node_Id; 1571 pragma Inline (Barrier_Body_Declaration); 1572 -- For Subprogram_Target T_Id, obtain the declaration of the barrier 1573 -- function's body. 1574 1575 function Body_Declaration (T_Id : Target_Rep_Id) return Node_Id; 1576 pragma Inline (Body_Declaration); 1577 -- Obtain the declaration of the body which belongs to target T_Id 1578 1579 procedure Disable_Elaboration_Checks (T_Id : Target_Rep_Id); 1580 pragma Inline (Disable_Elaboration_Checks); 1581 -- Disable elaboration checks of target T_Id 1582 1583 function Elaboration_Checks_OK (T_Id : Target_Rep_Id) return Boolean; 1584 pragma Inline (Elaboration_Checks_OK); 1585 -- Determine whether target T_Id may be subjected to elaboration checks 1586 1587 function Elaboration_Warnings_OK (T_Id : Target_Rep_Id) return Boolean; 1588 pragma Inline (Elaboration_Warnings_OK); 1589 -- Determine whether target T_Id may be subjected to elaboration 1590 -- warnings. 1591 1592 function Ghost_Mode_Of (T_Id : Target_Rep_Id) return Extended_Ghost_Mode; 1593 pragma Inline (Ghost_Mode_Of); 1594 -- Obtain the Ghost mode of target T_Id 1595 1596 function Kind (T_Id : Target_Rep_Id) return Target_Kind; 1597 pragma Inline (Kind); 1598 -- Obtain the nature of target T_Id 1599 1600 function SPARK_Mode_Of (T_Id : Target_Rep_Id) return Extended_SPARK_Mode; 1601 pragma Inline (SPARK_Mode_Of); 1602 -- Obtain the SPARK mode of target T_Id 1603 1604 function Spec_Declaration (T_Id : Target_Rep_Id) return Node_Id; 1605 pragma Inline (Spec_Declaration); 1606 -- Obtain the declaration of the spec which belongs to target T_Id 1607 1608 function Unit (T_Id : Target_Rep_Id) return Entity_Id; 1609 pragma Inline (Unit); 1610 -- Obtain the unit where the target is defined 1611 1612 function Variable_Declaration (T_Id : Target_Rep_Id) return Node_Id; 1613 pragma Inline (Variable_Declaration); 1614 -- For Variable_Target T_Id, obtain the declaration of the variable 1615 1616 ----------------- 1617 -- Maintenance -- 1618 ----------------- 1619 1620 procedure Finalize_Internal_Representation; 1621 pragma Inline (Finalize_Internal_Representation); 1622 -- Finalize all internal data structures 1623 1624 procedure Initialize_Internal_Representation; 1625 pragma Inline (Initialize_Internal_Representation); 1626 -- Initialize all internal data structures 1627 1628 end Internal_Representation; 1629 use Internal_Representation; 1630 1631 -- The following package provides functionality for recording pieces of the 1632 -- invocation graph in the ALI file of the main unit. 1633 1634 package Invocation_Graph is 1635 1636 --------- 1637 -- API -- 1638 --------- 1639 1640 procedure Record_Invocation_Graph; 1641 pragma Inline (Record_Invocation_Graph); 1642 -- Process all declaration, instantiation, and library level scenarios, 1643 -- along with invocation construct within the spec and body of the main 1644 -- unit to determine whether any of these reach into an external unit. 1645 -- If such a path exists, encode in the ALI file of the main unit. 1646 1647 ----------------- 1648 -- Maintenance -- 1649 ----------------- 1650 1651 procedure Finalize_Invocation_Graph; 1652 pragma Inline (Finalize_Invocation_Graph); 1653 -- Finalize all internal data structures 1654 1655 procedure Initialize_Invocation_Graph; 1656 pragma Inline (Initialize_Invocation_Graph); 1657 -- Initialize all internal data structures 1658 1659 end Invocation_Graph; 1660 use Invocation_Graph; 1661 1662 -- The following package stores scenarios 1663 1664 package Scenario_Storage is 1665 1666 --------- 1667 -- API -- 1668 --------- 1669 1670 procedure Add_Declaration_Scenario (N : Node_Id); 1671 pragma Inline (Add_Declaration_Scenario); 1672 -- Save declaration level scenario N 1673 1674 procedure Add_Dynamic_ABE_Check_Scenario (N : Node_Id); 1675 pragma Inline (Add_Dynamic_ABE_Check_Scenario); 1676 -- Save scenario N for conditional ABE check installation purposes when 1677 -- the dynamic model is in effect. 1678 1679 procedure Add_Library_Body_Scenario (N : Node_Id); 1680 pragma Inline (Add_Library_Body_Scenario); 1681 -- Save library-level body scenario N 1682 1683 procedure Add_Library_Spec_Scenario (N : Node_Id); 1684 pragma Inline (Add_Library_Spec_Scenario); 1685 -- Save library-level spec scenario N 1686 1687 procedure Add_SPARK_Scenario (N : Node_Id); 1688 pragma Inline (Add_SPARK_Scenario); 1689 -- Save SPARK scenario N 1690 1691 procedure Delete_Scenario (N : Node_Id); 1692 pragma Inline (Delete_Scenario); 1693 -- Delete arbitrary scenario N 1694 1695 function Iterate_Declaration_Scenarios return NE_Set.Iterator; 1696 pragma Inline (Iterate_Declaration_Scenarios); 1697 -- Obtain an iterator over all declaration level scenarios 1698 1699 function Iterate_Dynamic_ABE_Check_Scenarios return NE_Set.Iterator; 1700 pragma Inline (Iterate_Dynamic_ABE_Check_Scenarios); 1701 -- Obtain an iterator over all scenarios that require a conditional ABE 1702 -- check when the dynamic model is in effect. 1703 1704 function Iterate_Library_Body_Scenarios return NE_Set.Iterator; 1705 pragma Inline (Iterate_Library_Body_Scenarios); 1706 -- Obtain an iterator over all library level body scenarios 1707 1708 function Iterate_Library_Spec_Scenarios return NE_Set.Iterator; 1709 pragma Inline (Iterate_Library_Spec_Scenarios); 1710 -- Obtain an iterator over all library level spec scenarios 1711 1712 function Iterate_SPARK_Scenarios return NE_Set.Iterator; 1713 pragma Inline (Iterate_SPARK_Scenarios); 1714 -- Obtain an iterator over all SPARK scenarios 1715 1716 procedure Replace_Scenario (Old_N : Node_Id; New_N : Node_Id); 1717 pragma Inline (Replace_Scenario); 1718 -- Replace scenario Old_N with scenario New_N 1719 1720 ----------------- 1721 -- Maintenance -- 1722 ----------------- 1723 1724 procedure Finalize_Scenario_Storage; 1725 pragma Inline (Finalize_Scenario_Storage); 1726 -- Finalize all internal data structures 1727 1728 procedure Initialize_Scenario_Storage; 1729 pragma Inline (Initialize_Scenario_Storage); 1730 -- Initialize all internal data structures 1731 1732 end Scenario_Storage; 1733 use Scenario_Storage; 1734 1735 -- The following package provides various semantic predicates 1736 1737 package Semantics is 1738 1739 --------- 1740 -- API -- 1741 --------- 1742 1743 function Is_Accept_Alternative_Proc (Id : Entity_Id) return Boolean; 1744 pragma Inline (Is_Accept_Alternative_Proc); 1745 -- Determine whether arbitrary entity Id denotes an internally generated 1746 -- procedure which encapsulates the statements of an accept alternative. 1747 1748 function Is_Activation_Proc (Id : Entity_Id) return Boolean; 1749 pragma Inline (Is_Activation_Proc); 1750 -- Determine whether arbitrary entity Id denotes a runtime procedure in 1751 -- charge with activating tasks. 1752 1753 function Is_Ada_Semantic_Target (Id : Entity_Id) return Boolean; 1754 pragma Inline (Is_Ada_Semantic_Target); 1755 -- Determine whether arbitrary entity Id denodes a source or internally 1756 -- generated subprogram which emulates Ada semantics. 1757 1758 function Is_Assertion_Pragma_Target (Id : Entity_Id) return Boolean; 1759 pragma Inline (Is_Assertion_Pragma_Target); 1760 -- Determine whether arbitrary entity Id denotes a procedure which 1761 -- varifies the run-time semantics of an assertion pragma. 1762 1763 function Is_Bodiless_Subprogram (Subp_Id : Entity_Id) return Boolean; 1764 pragma Inline (Is_Bodiless_Subprogram); 1765 -- Determine whether subprogram Subp_Id will never have a body 1766 1767 function Is_Bridge_Target (Id : Entity_Id) return Boolean; 1768 pragma Inline (Is_Bridge_Target); 1769 -- Determine whether arbitrary entity Id denotes a bridge target 1770 1771 function Is_Controlled_Proc 1772 (Subp_Id : Entity_Id; 1773 Subp_Nam : Name_Id) return Boolean; 1774 pragma Inline (Is_Controlled_Proc); 1775 -- Determine whether subprogram Subp_Id denotes controlled type 1776 -- primitives Adjust, Finalize, or Initialize as denoted by name 1777 -- Subp_Nam. 1778 1779 function Is_Default_Initial_Condition_Proc 1780 (Id : Entity_Id) return Boolean; 1781 pragma Inline (Is_Default_Initial_Condition_Proc); 1782 -- Determine whether arbitrary entity Id denotes internally generated 1783 -- routine Default_Initial_Condition. 1784 1785 function Is_Finalizer_Proc (Id : Entity_Id) return Boolean; 1786 pragma Inline (Is_Finalizer_Proc); 1787 -- Determine whether arbitrary entity Id denotes internally generated 1788 -- routine _Finalizer. 1789 1790 function Is_Initial_Condition_Proc (Id : Entity_Id) return Boolean; 1791 pragma Inline (Is_Initial_Condition_Proc); 1792 -- Determine whether arbitrary entity Id denotes internally generated 1793 -- routine Initial_Condition. 1794 1795 function Is_Initialized (Obj_Decl : Node_Id) return Boolean; 1796 pragma Inline (Is_Initialized); 1797 -- Determine whether object declaration Obj_Decl is initialized 1798 1799 function Is_Invariant_Proc (Id : Entity_Id) return Boolean; 1800 pragma Inline (Is_Invariant_Proc); 1801 -- Determine whether arbitrary entity Id denotes an invariant procedure 1802 1803 function Is_Non_Library_Level_Encapsulator (N : Node_Id) return Boolean; 1804 pragma Inline (Is_Non_Library_Level_Encapsulator); 1805 -- Determine whether arbitrary node N is a non-library encapsulator 1806 1807 function Is_Partial_Invariant_Proc (Id : Entity_Id) return Boolean; 1808 pragma Inline (Is_Partial_Invariant_Proc); 1809 -- Determine whether arbitrary entity Id denotes a partial invariant 1810 -- procedure. 1811 1812 function Is_Postconditions_Proc (Id : Entity_Id) return Boolean; 1813 pragma Inline (Is_Postconditions_Proc); 1814 -- Determine whether arbitrary entity Id denotes internally generated 1815 -- routine _Postconditions. 1816 1817 function Is_Preelaborated_Unit (Id : Entity_Id) return Boolean; 1818 pragma Inline (Is_Preelaborated_Unit); 1819 -- Determine whether arbitrary entity Id denotes a unit which is subject 1820 -- to one of the following pragmas: 1821 -- 1822 -- * Preelaborable 1823 -- * Pure 1824 -- * Remote_Call_Interface 1825 -- * Remote_Types 1826 -- * Shared_Passive 1827 1828 function Is_Protected_Entry (Id : Entity_Id) return Boolean; 1829 pragma Inline (Is_Protected_Entry); 1830 -- Determine whether arbitrary entity Id denotes a protected entry 1831 1832 function Is_Protected_Subp (Id : Entity_Id) return Boolean; 1833 pragma Inline (Is_Protected_Subp); 1834 -- Determine whether entity Id denotes a protected subprogram 1835 1836 function Is_Protected_Body_Subp (Id : Entity_Id) return Boolean; 1837 pragma Inline (Is_Protected_Body_Subp); 1838 -- Determine whether entity Id denotes the protected or unprotected 1839 -- version of a protected subprogram. 1840 1841 function Is_Scenario (N : Node_Id) return Boolean; 1842 pragma Inline (Is_Scenario); 1843 -- Determine whether attribute node N denotes a scenario. The scenario 1844 -- may not necessarily be eligible for ABE processing. 1845 1846 function Is_SPARK_Semantic_Target (Id : Entity_Id) return Boolean; 1847 pragma Inline (Is_SPARK_Semantic_Target); 1848 -- Determine whether arbitrary entity Id nodes a source or internally 1849 -- generated subprogram which emulates SPARK semantics. 1850 1851 function Is_Subprogram_Inst (Id : Entity_Id) return Boolean; 1852 pragma Inline (Is_Subprogram_Inst); 1853 -- Determine whether arbitrary entity Id denotes a subprogram instance 1854 1855 function Is_Suitable_Access_Taken (N : Node_Id) return Boolean; 1856 pragma Inline (Is_Suitable_Access_Taken); 1857 -- Determine whether arbitrary node N denotes a suitable attribute for 1858 -- ABE processing. 1859 1860 function Is_Suitable_Call (N : Node_Id) return Boolean; 1861 pragma Inline (Is_Suitable_Call); 1862 -- Determine whether arbitrary node N denotes a suitable call for ABE 1863 -- processing. 1864 1865 function Is_Suitable_Instantiation (N : Node_Id) return Boolean; 1866 pragma Inline (Is_Suitable_Instantiation); 1867 -- Determine whether arbitrary node N is a suitable instantiation for 1868 -- ABE processing. 1869 1870 function Is_Suitable_SPARK_Derived_Type (N : Node_Id) return Boolean; 1871 pragma Inline (Is_Suitable_SPARK_Derived_Type); 1872 -- Determine whether arbitrary node N denotes a suitable derived type 1873 -- declaration for ABE processing using the SPARK rules. 1874 1875 function Is_Suitable_SPARK_Instantiation (N : Node_Id) return Boolean; 1876 pragma Inline (Is_Suitable_SPARK_Instantiation); 1877 -- Determine whether arbitrary node N denotes a suitable instantiation 1878 -- for ABE processing using the SPARK rules. 1879 1880 function Is_Suitable_SPARK_Refined_State_Pragma 1881 (N : Node_Id) return Boolean; 1882 pragma Inline (Is_Suitable_SPARK_Refined_State_Pragma); 1883 -- Determine whether arbitrary node N denotes a suitable Refined_State 1884 -- pragma for ABE processing using the SPARK rules. 1885 1886 function Is_Suitable_Variable_Assignment (N : Node_Id) return Boolean; 1887 pragma Inline (Is_Suitable_Variable_Assignment); 1888 -- Determine whether arbitrary node N denotes a suitable assignment for 1889 -- ABE processing. 1890 1891 function Is_Suitable_Variable_Reference (N : Node_Id) return Boolean; 1892 pragma Inline (Is_Suitable_Variable_Reference); 1893 -- Determine whether arbitrary node N is a suitable variable reference 1894 -- for ABE processing. 1895 1896 function Is_Task_Entry (Id : Entity_Id) return Boolean; 1897 pragma Inline (Is_Task_Entry); 1898 -- Determine whether arbitrary entity Id denotes a task entry 1899 1900 function Is_Up_Level_Target 1901 (Targ_Decl : Node_Id; 1902 In_State : Processing_In_State) return Boolean; 1903 pragma Inline (Is_Up_Level_Target); 1904 -- Determine whether the current root resides at the declaration level. 1905 -- If this is the case, determine whether a target with by declaration 1906 -- Target_Decl is within a context which encloses the current root or is 1907 -- in a different unit. In_State is the current state of the Processing 1908 -- phase. 1909 1910 end Semantics; 1911 use Semantics; 1912 1913 -- The following package provides the main entry point for SPARK-related 1914 -- checks and diagnostics. 1915 1916 package SPARK_Processor is 1917 1918 --------- 1919 -- API -- 1920 --------- 1921 1922 procedure Check_SPARK_Model_In_Effect; 1923 pragma Inline (Check_SPARK_Model_In_Effect); 1924 -- Determine whether a suitable elaboration model is currently in effect 1925 -- for verifying SPARK rules. Emit a warning if this is not the case. 1926 1927 procedure Check_SPARK_Scenarios; 1928 pragma Inline (Check_SPARK_Scenarios); 1929 -- Examine SPARK scenarios which are not necessarily executable during 1930 -- elaboration, but still requires elaboration-related checks. 1931 1932 end SPARK_Processor; 1933 use SPARK_Processor; 1934 1935 ----------------------- 1936 -- Local subprograms -- 1937 ----------------------- 1938 1939 function Assignment_Target (Asmt : Node_Id) return Node_Id; 1940 pragma Inline (Assignment_Target); 1941 -- Obtain the target of assignment statement Asmt 1942 1943 function Call_Name (Call : Node_Id) return Node_Id; 1944 pragma Inline (Call_Name); 1945 -- Obtain the name of an entry, operator, or subprogram call Call 1946 1947 function Canonical_Subprogram (Subp_Id : Entity_Id) return Entity_Id; 1948 pragma Inline (Canonical_Subprogram); 1949 -- Obtain the uniform canonical entity of subprogram Subp_Id 1950 1951 function Compilation_Unit (Unit_Id : Entity_Id) return Node_Id; 1952 pragma Inline (Compilation_Unit); 1953 -- Return the N_Compilation_Unit node of unit Unit_Id 1954 1955 function Find_Enclosing_Instance (N : Node_Id) return Node_Id; 1956 pragma Inline (Find_Enclosing_Instance); 1957 -- Find the declaration or body of the nearest expanded instance which 1958 -- encloses arbitrary node N. Return Empty if no such instance exists. 1959 1960 function Find_Top_Unit (N : Node_Or_Entity_Id) return Entity_Id; 1961 pragma Inline (Find_Top_Unit); 1962 -- Return the top unit which contains arbitrary node or entity N. The unit 1963 -- is obtained by logically unwinding instantiations and subunits when N 1964 -- resides within one. 1965 1966 function Find_Unit_Entity (N : Node_Id) return Entity_Id; 1967 pragma Inline (Find_Unit_Entity); 1968 -- Return the entity of unit N 1969 1970 function First_Formal_Type (Subp_Id : Entity_Id) return Entity_Id; 1971 pragma Inline (First_Formal_Type); 1972 -- Return the type of subprogram Subp_Id's first formal parameter. If the 1973 -- subprogram lacks formal parameters, return Empty. 1974 1975 function Elaboration_Phase_Active return Boolean; 1976 pragma Inline (Elaboration_Phase_Active); 1977 -- Determine whether the elaboration phase of the compilation has started 1978 1979 procedure Finalize_All_Data_Structures; 1980 pragma Inline (Finalize_All_Data_Structures); 1981 -- Destroy all internal data structures 1982 1983 function Has_Body (Pack_Decl : Node_Id) return Boolean; 1984 pragma Inline (Has_Body); 1985 -- Determine whether package declaration Pack_Decl has a corresponding body 1986 -- or would eventually have one. 1987 1988 function In_External_Instance 1989 (N : Node_Id; 1990 Target_Decl : Node_Id) return Boolean; 1991 pragma Inline (In_External_Instance); 1992 -- Determine whether a target desctibed by its declaration Target_Decl 1993 -- resides in a package instance which is external to scenario N. 1994 1995 function In_Main_Context (N : Node_Id) return Boolean; 1996 pragma Inline (In_Main_Context); 1997 -- Determine whether arbitrary node N appears within the main compilation 1998 -- unit. 1999 2000 function In_Same_Context 2001 (N1 : Node_Id; 2002 N2 : Node_Id; 2003 Nested_OK : Boolean := False) return Boolean; 2004 pragma Inline (In_Same_Context); 2005 -- Determine whether two arbitrary nodes N1 and N2 appear within the same 2006 -- context ignoring enclosing library levels. Nested_OK should be set when 2007 -- the context of N1 can enclose that of N2. 2008 2009 procedure Initialize_All_Data_Structures; 2010 pragma Inline (Initialize_All_Data_Structures); 2011 -- Create all internal data structures 2012 2013 function Instantiated_Generic (Inst : Node_Id) return Entity_Id; 2014 pragma Inline (Instantiated_Generic); 2015 -- Obtain the generic instantiated by instance Inst 2016 2017 function Is_Safe_Activation 2018 (Call : Node_Id; 2019 Task_Rep : Target_Rep_Id) return Boolean; 2020 pragma Inline (Is_Safe_Activation); 2021 -- Determine whether activation call Call which activates an object of a 2022 -- task type described by representation Task_Rep is always ABE-safe. 2023 2024 function Is_Safe_Call 2025 (Call : Node_Id; 2026 Subp_Id : Entity_Id; 2027 Subp_Rep : Target_Rep_Id) return Boolean; 2028 pragma Inline (Is_Safe_Call); 2029 -- Determine whether call Call which invokes entry, operator, or subprogram 2030 -- Subp_Id is always ABE-safe. Subp_Rep is the representation of the entry, 2031 -- operator, or subprogram. 2032 2033 function Is_Safe_Instantiation 2034 (Inst : Node_Id; 2035 Gen_Id : Entity_Id; 2036 Gen_Rep : Target_Rep_Id) return Boolean; 2037 pragma Inline (Is_Safe_Instantiation); 2038 -- Determine whether instantiation Inst which instantiates generic Gen_Id 2039 -- is always ABE-safe. Gen_Rep is the representation of the generic. 2040 2041 function Is_Same_Unit 2042 (Unit_1 : Entity_Id; 2043 Unit_2 : Entity_Id) return Boolean; 2044 pragma Inline (Is_Same_Unit); 2045 -- Determine whether entities Unit_1 and Unit_2 denote the same unit 2046 2047 function Main_Unit_Entity return Entity_Id; 2048 pragma Inline (Main_Unit_Entity); 2049 -- Return the entity of the main unit 2050 2051 function Non_Private_View (Typ : Entity_Id) return Entity_Id; 2052 pragma Inline (Non_Private_View); 2053 -- Return the full view of private type Typ if available, otherwise return 2054 -- type Typ. 2055 2056 function Scenario (N : Node_Id) return Node_Id; 2057 pragma Inline (Scenario); 2058 -- Return the appropriate scenario node for scenario N 2059 2060 procedure Set_Elaboration_Phase (Status : Elaboration_Phase_Status); 2061 pragma Inline (Set_Elaboration_Phase); 2062 -- Change the status of the elaboration phase of the compiler to Status 2063 2064 procedure Spec_And_Body_From_Entity 2065 (Id : Node_Id; 2066 Spec_Decl : out Node_Id; 2067 Body_Decl : out Node_Id); 2068 pragma Inline (Spec_And_Body_From_Entity); 2069 -- Given arbitrary entity Id representing a construct with a spec and body, 2070 -- retrieve declaration of the spec in Spec_Decl and the declaration of the 2071 -- body in Body_Decl. 2072 2073 procedure Spec_And_Body_From_Node 2074 (N : Node_Id; 2075 Spec_Decl : out Node_Id; 2076 Body_Decl : out Node_Id); 2077 pragma Inline (Spec_And_Body_From_Node); 2078 -- Given arbitrary node N representing a construct with a spec and body, 2079 -- retrieve declaration of the spec in Spec_Decl and the declaration of 2080 -- the body in Body_Decl. 2081 2082 function Static_Elaboration_Checks return Boolean; 2083 pragma Inline (Static_Elaboration_Checks); 2084 -- Determine whether the static model is in effect 2085 2086 function Unit_Entity (Unit_Id : Entity_Id) return Entity_Id; 2087 pragma Inline (Unit_Entity); 2088 -- Return the entity of the initial declaration for unit Unit_Id 2089 2090 procedure Update_Elaboration_Scenario (New_N : Node_Id; Old_N : Node_Id); 2091 pragma Inline (Update_Elaboration_Scenario); 2092 -- Update all relevant internal data structures when scenario Old_N is 2093 -- transformed into scenario New_N by Atree.Rewrite. 2094 2095 ---------------------- 2096 -- Active_Scenarios -- 2097 ---------------------- 2098 2099 package body Active_Scenarios is 2100 2101 ----------------------- 2102 -- Local subprograms -- 2103 ----------------------- 2104 2105 procedure Output_Access_Taken 2106 (Attr : Node_Id; 2107 Attr_Rep : Scenario_Rep_Id; 2108 Error_Nod : Node_Id); 2109 pragma Inline (Output_Access_Taken); 2110 -- Emit a specific diagnostic message for 'Access attribute reference 2111 -- Attr with representation Attr_Rep. The message is associated with 2112 -- node Error_Nod. 2113 2114 procedure Output_Active_Scenario 2115 (N : Node_Id; 2116 Error_Nod : Node_Id; 2117 In_State : Processing_In_State); 2118 pragma Inline (Output_Active_Scenario); 2119 -- Top level dispatcher for outputting a scenario. Emit a specific 2120 -- diagnostic message for scenario N. The message is associated with 2121 -- node Error_Nod. In_State is the current state of the Processing 2122 -- phase. 2123 2124 procedure Output_Call 2125 (Call : Node_Id; 2126 Call_Rep : Scenario_Rep_Id; 2127 Error_Nod : Node_Id); 2128 pragma Inline (Output_Call); 2129 -- Emit a diagnostic message for call Call with representation Call_Rep. 2130 -- The message is associated with node Error_Nod. 2131 2132 procedure Output_Header (Error_Nod : Node_Id); 2133 pragma Inline (Output_Header); 2134 -- Emit a specific diagnostic message for the unit of the root scenario. 2135 -- The message is associated with node Error_Nod. 2136 2137 procedure Output_Instantiation 2138 (Inst : Node_Id; 2139 Inst_Rep : Scenario_Rep_Id; 2140 Error_Nod : Node_Id); 2141 pragma Inline (Output_Instantiation); 2142 -- Emit a specific diagnostic message for instantiation Inst with 2143 -- representation Inst_Rep. The message is associated with node 2144 -- Error_Nod. 2145 2146 procedure Output_Refined_State_Pragma 2147 (Prag : Node_Id; 2148 Prag_Rep : Scenario_Rep_Id; 2149 Error_Nod : Node_Id); 2150 pragma Inline (Output_Refined_State_Pragma); 2151 -- Emit a specific diagnostic message for Refined_State pragma Prag 2152 -- with representation Prag_Rep. The message is associated with node 2153 -- Error_Nod. 2154 2155 procedure Output_Task_Activation 2156 (Call : Node_Id; 2157 Call_Rep : Scenario_Rep_Id; 2158 Error_Nod : Node_Id); 2159 pragma Inline (Output_Task_Activation); 2160 -- Emit a specific diagnostic message for activation call Call 2161 -- with representation Call_Rep. The message is associated with 2162 -- node Error_Nod. 2163 2164 procedure Output_Variable_Assignment 2165 (Asmt : Node_Id; 2166 Asmt_Rep : Scenario_Rep_Id; 2167 Error_Nod : Node_Id); 2168 pragma Inline (Output_Variable_Assignment); 2169 -- Emit a specific diagnostic message for assignment statement Asmt 2170 -- with representation Asmt_Rep. The message is associated with node 2171 -- Error_Nod. 2172 2173 procedure Output_Variable_Reference 2174 (Ref : Node_Id; 2175 Ref_Rep : Scenario_Rep_Id; 2176 Error_Nod : Node_Id); 2177 pragma Inline (Output_Variable_Reference); 2178 -- Emit a specific diagnostic message for read reference Ref with 2179 -- representation Ref_Rep. The message is associated with node 2180 -- Error_Nod. 2181 2182 ------------------- 2183 -- Output_Access -- 2184 ------------------- 2185 2186 procedure Output_Access_Taken 2187 (Attr : Node_Id; 2188 Attr_Rep : Scenario_Rep_Id; 2189 Error_Nod : Node_Id) 2190 is 2191 Subp_Id : constant Entity_Id := Target (Attr_Rep); 2192 2193 begin 2194 Error_Msg_Name_1 := Attribute_Name (Attr); 2195 Error_Msg_Sloc := Sloc (Attr); 2196 Error_Msg_NE ("\\ % of & taken #", Error_Nod, Subp_Id); 2197 end Output_Access_Taken; 2198 2199 ---------------------------- 2200 -- Output_Active_Scenario -- 2201 ---------------------------- 2202 2203 procedure Output_Active_Scenario 2204 (N : Node_Id; 2205 Error_Nod : Node_Id; 2206 In_State : Processing_In_State) 2207 is 2208 Scen : constant Node_Id := Scenario (N); 2209 Scen_Rep : Scenario_Rep_Id; 2210 2211 begin 2212 -- 'Access 2213 2214 if Is_Suitable_Access_Taken (Scen) then 2215 Output_Access_Taken 2216 (Attr => Scen, 2217 Attr_Rep => Scenario_Representation_Of (Scen, In_State), 2218 Error_Nod => Error_Nod); 2219 2220 -- Call or task activation 2221 2222 elsif Is_Suitable_Call (Scen) then 2223 Scen_Rep := Scenario_Representation_Of (Scen, In_State); 2224 2225 if Kind (Scen_Rep) = Call_Scenario then 2226 Output_Call 2227 (Call => Scen, 2228 Call_Rep => Scen_Rep, 2229 Error_Nod => Error_Nod); 2230 2231 else 2232 pragma Assert (Kind (Scen_Rep) = Task_Activation_Scenario); 2233 2234 Output_Task_Activation 2235 (Call => Scen, 2236 Call_Rep => Scen_Rep, 2237 Error_Nod => Error_Nod); 2238 end if; 2239 2240 -- Instantiation 2241 2242 elsif Is_Suitable_Instantiation (Scen) then 2243 Output_Instantiation 2244 (Inst => Scen, 2245 Inst_Rep => Scenario_Representation_Of (Scen, In_State), 2246 Error_Nod => Error_Nod); 2247 2248 -- Pragma Refined_State 2249 2250 elsif Is_Suitable_SPARK_Refined_State_Pragma (Scen) then 2251 Output_Refined_State_Pragma 2252 (Prag => Scen, 2253 Prag_Rep => Scenario_Representation_Of (Scen, In_State), 2254 Error_Nod => Error_Nod); 2255 2256 -- Variable assignment 2257 2258 elsif Is_Suitable_Variable_Assignment (Scen) then 2259 Output_Variable_Assignment 2260 (Asmt => Scen, 2261 Asmt_Rep => Scenario_Representation_Of (Scen, In_State), 2262 Error_Nod => Error_Nod); 2263 2264 -- Variable reference 2265 2266 elsif Is_Suitable_Variable_Reference (Scen) then 2267 Output_Variable_Reference 2268 (Ref => Scen, 2269 Ref_Rep => Scenario_Representation_Of (Scen, In_State), 2270 Error_Nod => Error_Nod); 2271 end if; 2272 end Output_Active_Scenario; 2273 2274 ----------------------------- 2275 -- Output_Active_Scenarios -- 2276 ----------------------------- 2277 2278 procedure Output_Active_Scenarios 2279 (Error_Nod : Node_Id; 2280 In_State : Processing_In_State) 2281 is 2282 package Scenarios renames Active_Scenario_Stack; 2283 2284 Header_Posted : Boolean := False; 2285 2286 begin 2287 -- Output the contents of the active scenario stack starting from the 2288 -- bottom, or the least recent scenario. 2289 2290 for Index in Scenarios.First .. Scenarios.Last loop 2291 if not Header_Posted then 2292 Output_Header (Error_Nod); 2293 Header_Posted := True; 2294 end if; 2295 2296 Output_Active_Scenario 2297 (N => Scenarios.Table (Index), 2298 Error_Nod => Error_Nod, 2299 In_State => In_State); 2300 end loop; 2301 end Output_Active_Scenarios; 2302 2303 ----------------- 2304 -- Output_Call -- 2305 ----------------- 2306 2307 procedure Output_Call 2308 (Call : Node_Id; 2309 Call_Rep : Scenario_Rep_Id; 2310 Error_Nod : Node_Id) 2311 is 2312 procedure Output_Accept_Alternative (Alt_Id : Entity_Id); 2313 pragma Inline (Output_Accept_Alternative); 2314 -- Emit a specific diagnostic message concerning accept alternative 2315 -- with entity Alt_Id. 2316 2317 procedure Output_Call (Subp_Id : Entity_Id; Kind : String); 2318 pragma Inline (Output_Call); 2319 -- Emit a specific diagnostic message concerning a call of kind Kind 2320 -- which invokes subprogram Subp_Id. 2321 2322 procedure Output_Type_Actions (Subp_Id : Entity_Id; Action : String); 2323 pragma Inline (Output_Type_Actions); 2324 -- Emit a specific diagnostic message concerning action Action of a 2325 -- type performed by subprogram Subp_Id. 2326 2327 procedure Output_Verification_Call 2328 (Pred : String; 2329 Id : Entity_Id; 2330 Id_Kind : String); 2331 pragma Inline (Output_Verification_Call); 2332 -- Emit a specific diagnostic message concerning the verification of 2333 -- predicate Pred applied to related entity Id with kind Id_Kind. 2334 2335 ------------------------------- 2336 -- Output_Accept_Alternative -- 2337 ------------------------------- 2338 2339 procedure Output_Accept_Alternative (Alt_Id : Entity_Id) is 2340 Entry_Id : constant Entity_Id := Receiving_Entry (Alt_Id); 2341 2342 begin 2343 pragma Assert (Present (Entry_Id)); 2344 2345 Error_Msg_NE ("\\ entry & selected #", Error_Nod, Entry_Id); 2346 end Output_Accept_Alternative; 2347 2348 ----------------- 2349 -- Output_Call -- 2350 ----------------- 2351 2352 procedure Output_Call (Subp_Id : Entity_Id; Kind : String) is 2353 begin 2354 Error_Msg_NE ("\\ " & Kind & " & called #", Error_Nod, Subp_Id); 2355 end Output_Call; 2356 2357 ------------------------- 2358 -- Output_Type_Actions -- 2359 ------------------------- 2360 2361 procedure Output_Type_Actions 2362 (Subp_Id : Entity_Id; 2363 Action : String) 2364 is 2365 Typ : constant Entity_Id := First_Formal_Type (Subp_Id); 2366 2367 begin 2368 pragma Assert (Present (Typ)); 2369 2370 Error_Msg_NE 2371 ("\\ " & Action & " actions for type & #", Error_Nod, Typ); 2372 end Output_Type_Actions; 2373 2374 ------------------------------ 2375 -- Output_Verification_Call -- 2376 ------------------------------ 2377 2378 procedure Output_Verification_Call 2379 (Pred : String; 2380 Id : Entity_Id; 2381 Id_Kind : String) 2382 is 2383 begin 2384 pragma Assert (Present (Id)); 2385 2386 Error_Msg_NE 2387 ("\\ " & Pred & " of " & Id_Kind & " & verified #", 2388 Error_Nod, Id); 2389 end Output_Verification_Call; 2390 2391 -- Local variables 2392 2393 Subp_Id : constant Entity_Id := Target (Call_Rep); 2394 2395 -- Start of processing for Output_Call 2396 2397 begin 2398 Error_Msg_Sloc := Sloc (Call); 2399 2400 -- Accept alternative 2401 2402 if Is_Accept_Alternative_Proc (Subp_Id) then 2403 Output_Accept_Alternative (Subp_Id); 2404 2405 -- Adjustment 2406 2407 elsif Is_TSS (Subp_Id, TSS_Deep_Adjust) then 2408 Output_Type_Actions (Subp_Id, "adjustment"); 2409 2410 -- Default_Initial_Condition 2411 2412 elsif Is_Default_Initial_Condition_Proc (Subp_Id) then 2413 Output_Verification_Call 2414 (Pred => "Default_Initial_Condition", 2415 Id => First_Formal_Type (Subp_Id), 2416 Id_Kind => "type"); 2417 2418 -- Entries 2419 2420 elsif Is_Protected_Entry (Subp_Id) then 2421 Output_Call (Subp_Id, "entry"); 2422 2423 -- Task entry calls are never processed because the entry being 2424 -- invoked does not have a corresponding "body", it has a select. A 2425 -- task entry call appears in the stack of active scenarios for the 2426 -- sole purpose of checking No_Entry_Calls_In_Elaboration_Code and 2427 -- nothing more. 2428 2429 elsif Is_Task_Entry (Subp_Id) then 2430 null; 2431 2432 -- Finalization 2433 2434 elsif Is_TSS (Subp_Id, TSS_Deep_Finalize) then 2435 Output_Type_Actions (Subp_Id, "finalization"); 2436 2437 -- Calls to _Finalizer procedures must not appear in the output 2438 -- because this creates confusing noise. 2439 2440 elsif Is_Finalizer_Proc (Subp_Id) then 2441 null; 2442 2443 -- Initial_Condition 2444 2445 elsif Is_Initial_Condition_Proc (Subp_Id) then 2446 Output_Verification_Call 2447 (Pred => "Initial_Condition", 2448 Id => Find_Enclosing_Scope (Call), 2449 Id_Kind => "package"); 2450 2451 -- Initialization 2452 2453 elsif Is_Init_Proc (Subp_Id) 2454 or else Is_TSS (Subp_Id, TSS_Deep_Initialize) 2455 then 2456 Output_Type_Actions (Subp_Id, "initialization"); 2457 2458 -- Invariant 2459 2460 elsif Is_Invariant_Proc (Subp_Id) then 2461 Output_Verification_Call 2462 (Pred => "invariants", 2463 Id => First_Formal_Type (Subp_Id), 2464 Id_Kind => "type"); 2465 2466 -- Partial invariant calls must not appear in the output because this 2467 -- creates confusing noise. Note that a partial invariant is always 2468 -- invoked by the "full" invariant which is already placed on the 2469 -- stack. 2470 2471 elsif Is_Partial_Invariant_Proc (Subp_Id) then 2472 null; 2473 2474 -- _Postconditions 2475 2476 elsif Is_Postconditions_Proc (Subp_Id) then 2477 Output_Verification_Call 2478 (Pred => "postconditions", 2479 Id => Find_Enclosing_Scope (Call), 2480 Id_Kind => "subprogram"); 2481 2482 -- Subprograms must come last because some of the previous cases fall 2483 -- under this category. 2484 2485 elsif Ekind (Subp_Id) = E_Function then 2486 Output_Call (Subp_Id, "function"); 2487 2488 elsif Ekind (Subp_Id) = E_Procedure then 2489 Output_Call (Subp_Id, "procedure"); 2490 2491 else 2492 pragma Assert (False); 2493 return; 2494 end if; 2495 end Output_Call; 2496 2497 ------------------- 2498 -- Output_Header -- 2499 ------------------- 2500 2501 procedure Output_Header (Error_Nod : Node_Id) is 2502 Unit_Id : constant Entity_Id := Find_Top_Unit (Root_Scenario); 2503 2504 begin 2505 if Ekind (Unit_Id) = E_Package then 2506 Error_Msg_NE ("\\ spec of unit & elaborated", Error_Nod, Unit_Id); 2507 2508 elsif Ekind (Unit_Id) = E_Package_Body then 2509 Error_Msg_NE ("\\ body of unit & elaborated", Error_Nod, Unit_Id); 2510 2511 else 2512 Error_Msg_NE ("\\ in body of unit &", Error_Nod, Unit_Id); 2513 end if; 2514 end Output_Header; 2515 2516 -------------------------- 2517 -- Output_Instantiation -- 2518 -------------------------- 2519 2520 procedure Output_Instantiation 2521 (Inst : Node_Id; 2522 Inst_Rep : Scenario_Rep_Id; 2523 Error_Nod : Node_Id) 2524 is 2525 procedure Output_Instantiation (Gen_Id : Entity_Id; Kind : String); 2526 pragma Inline (Output_Instantiation); 2527 -- Emit a specific diagnostic message concerning an instantiation of 2528 -- generic unit Gen_Id. Kind denotes the kind of the instantiation. 2529 2530 -------------------------- 2531 -- Output_Instantiation -- 2532 -------------------------- 2533 2534 procedure Output_Instantiation (Gen_Id : Entity_Id; Kind : String) is 2535 begin 2536 Error_Msg_NE 2537 ("\\ " & Kind & " & instantiated as & #", Error_Nod, Gen_Id); 2538 end Output_Instantiation; 2539 2540 -- Local variables 2541 2542 Gen_Id : constant Entity_Id := Target (Inst_Rep); 2543 2544 -- Start of processing for Output_Instantiation 2545 2546 begin 2547 Error_Msg_Node_2 := Defining_Entity (Inst); 2548 Error_Msg_Sloc := Sloc (Inst); 2549 2550 if Nkind (Inst) = N_Function_Instantiation then 2551 Output_Instantiation (Gen_Id, "function"); 2552 2553 elsif Nkind (Inst) = N_Package_Instantiation then 2554 Output_Instantiation (Gen_Id, "package"); 2555 2556 elsif Nkind (Inst) = N_Procedure_Instantiation then 2557 Output_Instantiation (Gen_Id, "procedure"); 2558 2559 else 2560 pragma Assert (False); 2561 return; 2562 end if; 2563 end Output_Instantiation; 2564 2565 --------------------------------- 2566 -- Output_Refined_State_Pragma -- 2567 --------------------------------- 2568 2569 procedure Output_Refined_State_Pragma 2570 (Prag : Node_Id; 2571 Prag_Rep : Scenario_Rep_Id; 2572 Error_Nod : Node_Id) 2573 is 2574 pragma Unreferenced (Prag_Rep); 2575 2576 begin 2577 Error_Msg_Sloc := Sloc (Prag); 2578 Error_Msg_N ("\\ refinement constituents read #", Error_Nod); 2579 end Output_Refined_State_Pragma; 2580 2581 ---------------------------- 2582 -- Output_Task_Activation -- 2583 ---------------------------- 2584 2585 procedure Output_Task_Activation 2586 (Call : Node_Id; 2587 Call_Rep : Scenario_Rep_Id; 2588 Error_Nod : Node_Id) 2589 is 2590 pragma Unreferenced (Call_Rep); 2591 2592 function Find_Activator return Entity_Id; 2593 -- Find the nearest enclosing construct which houses call Call 2594 2595 -------------------- 2596 -- Find_Activator -- 2597 -------------------- 2598 2599 function Find_Activator return Entity_Id is 2600 Par : Node_Id; 2601 2602 begin 2603 -- Climb the parent chain looking for a package [body] or a 2604 -- construct with a statement sequence. 2605 2606 Par := Parent (Call); 2607 while Present (Par) loop 2608 if Nkind_In (Par, N_Package_Body, N_Package_Declaration) then 2609 return Defining_Entity (Par); 2610 2611 elsif Nkind (Par) = N_Handled_Sequence_Of_Statements then 2612 return Defining_Entity (Parent (Par)); 2613 end if; 2614 2615 Par := Parent (Par); 2616 end loop; 2617 2618 return Empty; 2619 end Find_Activator; 2620 2621 -- Local variables 2622 2623 Activator : constant Entity_Id := Find_Activator; 2624 2625 -- Start of processing for Output_Task_Activation 2626 2627 begin 2628 pragma Assert (Present (Activator)); 2629 2630 Error_Msg_NE ("\\ local tasks of & activated", Error_Nod, Activator); 2631 end Output_Task_Activation; 2632 2633 -------------------------------- 2634 -- Output_Variable_Assignment -- 2635 -------------------------------- 2636 2637 procedure Output_Variable_Assignment 2638 (Asmt : Node_Id; 2639 Asmt_Rep : Scenario_Rep_Id; 2640 Error_Nod : Node_Id) 2641 is 2642 Var_Id : constant Entity_Id := Target (Asmt_Rep); 2643 2644 begin 2645 Error_Msg_Sloc := Sloc (Asmt); 2646 Error_Msg_NE ("\\ variable & assigned #", Error_Nod, Var_Id); 2647 end Output_Variable_Assignment; 2648 2649 ------------------------------- 2650 -- Output_Variable_Reference -- 2651 ------------------------------- 2652 2653 procedure Output_Variable_Reference 2654 (Ref : Node_Id; 2655 Ref_Rep : Scenario_Rep_Id; 2656 Error_Nod : Node_Id) 2657 is 2658 Var_Id : constant Entity_Id := Target (Ref_Rep); 2659 2660 begin 2661 Error_Msg_Sloc := Sloc (Ref); 2662 Error_Msg_NE ("\\ variable & read #", Error_Nod, Var_Id); 2663 end Output_Variable_Reference; 2664 2665 ------------------------- 2666 -- Pop_Active_Scenario -- 2667 ------------------------- 2668 2669 procedure Pop_Active_Scenario (N : Node_Id) is 2670 package Scenarios renames Active_Scenario_Stack; 2671 Top : Node_Id renames Scenarios.Table (Scenarios.Last); 2672 2673 begin 2674 pragma Assert (Top = N); 2675 Scenarios.Decrement_Last; 2676 end Pop_Active_Scenario; 2677 2678 -------------------------- 2679 -- Push_Active_Scenario -- 2680 -------------------------- 2681 2682 procedure Push_Active_Scenario (N : Node_Id) is 2683 begin 2684 Active_Scenario_Stack.Append (N); 2685 end Push_Active_Scenario; 2686 2687 ------------------- 2688 -- Root_Scenario -- 2689 ------------------- 2690 2691 function Root_Scenario return Node_Id is 2692 package Scenarios renames Active_Scenario_Stack; 2693 2694 begin 2695 -- Ensure that the scenario stack has at least one active scenario in 2696 -- it. The one at the bottom (index First) is the root scenario. 2697 2698 pragma Assert (Scenarios.Last >= Scenarios.First); 2699 return Scenarios.Table (Scenarios.First); 2700 end Root_Scenario; 2701 end Active_Scenarios; 2702 2703 -------------------------- 2704 -- Activation_Processor -- 2705 -------------------------- 2706 2707 package body Activation_Processor is 2708 2709 ------------------------ 2710 -- Process_Activation -- 2711 ------------------------ 2712 2713 procedure Process_Activation 2714 (Call : Node_Id; 2715 Call_Rep : Scenario_Rep_Id; 2716 Processor : Activation_Processor_Ptr; 2717 In_State : Processing_In_State) 2718 is 2719 procedure Process_Task_Object (Obj_Id : Entity_Id; Typ : Entity_Id); 2720 pragma Inline (Process_Task_Object); 2721 -- Invoke Processor for task object Obj_Id of type Typ 2722 2723 procedure Process_Task_Objects 2724 (Task_Objs : NE_List.Doubly_Linked_List); 2725 pragma Inline (Process_Task_Objects); 2726 -- Invoke Processor for all task objects found in list Task_Objs 2727 2728 procedure Traverse_List 2729 (List : List_Id; 2730 Task_Objs : NE_List.Doubly_Linked_List); 2731 pragma Inline (Traverse_List); 2732 -- Traverse declarative or statement list List while searching for 2733 -- objects of a task type, or containing task components. If such an 2734 -- object is found, first save it in list Task_Objs and then invoke 2735 -- Processor on it. 2736 2737 ------------------------- 2738 -- Process_Task_Object -- 2739 ------------------------- 2740 2741 procedure Process_Task_Object (Obj_Id : Entity_Id; Typ : Entity_Id) is 2742 Root_Typ : constant Entity_Id := 2743 Non_Private_View (Root_Type (Typ)); 2744 Comp_Id : Entity_Id; 2745 Obj_Rep : Target_Rep_Id; 2746 Root_Rep : Target_Rep_Id; 2747 2748 New_In_State : Processing_In_State := In_State; 2749 -- Each step of the Processing phase constitutes a new state 2750 2751 begin 2752 if Is_Task_Type (Typ) then 2753 Obj_Rep := Target_Representation_Of (Obj_Id, New_In_State); 2754 Root_Rep := Target_Representation_Of (Root_Typ, New_In_State); 2755 2756 -- Warnings are suppressed when a prior scenario is already in 2757 -- that mode, or when the object, activation call, or task type 2758 -- have warnings suppressed. Update the state of the Processing 2759 -- phase to reflect this. 2760 2761 New_In_State.Suppress_Warnings := 2762 New_In_State.Suppress_Warnings 2763 or else not Elaboration_Warnings_OK (Call_Rep) 2764 or else not Elaboration_Warnings_OK (Obj_Rep) 2765 or else not Elaboration_Warnings_OK (Root_Rep); 2766 2767 -- Update the state of the Processing phase to indicate that 2768 -- any further traversal is now within a task body. 2769 2770 New_In_State.Within_Task_Body := True; 2771 2772 -- Associate the current task type with the activation call 2773 2774 Set_Activated_Task_Type (Call_Rep, Root_Typ); 2775 2776 -- Process the activation of the current task object by calling 2777 -- the supplied processor. 2778 2779 Processor.all 2780 (Call => Call, 2781 Call_Rep => Call_Rep, 2782 Obj_Id => Obj_Id, 2783 Obj_Rep => Obj_Rep, 2784 Task_Typ => Root_Typ, 2785 Task_Rep => Root_Rep, 2786 In_State => New_In_State); 2787 2788 -- Reset the association between the current task and the 2789 -- activtion call. 2790 2791 Set_Activated_Task_Type (Call_Rep, Empty); 2792 2793 -- Examine the component type when the object is an array 2794 2795 elsif Is_Array_Type (Typ) and then Has_Task (Root_Typ) then 2796 Process_Task_Object 2797 (Obj_Id => Obj_Id, 2798 Typ => Component_Type (Typ)); 2799 2800 -- Examine individual component types when the object is a record 2801 2802 elsif Is_Record_Type (Typ) and then Has_Task (Root_Typ) then 2803 Comp_Id := First_Component (Typ); 2804 while Present (Comp_Id) loop 2805 Process_Task_Object 2806 (Obj_Id => Obj_Id, 2807 Typ => Etype (Comp_Id)); 2808 2809 Next_Component (Comp_Id); 2810 end loop; 2811 end if; 2812 end Process_Task_Object; 2813 2814 -------------------------- 2815 -- Process_Task_Objects -- 2816 -------------------------- 2817 2818 procedure Process_Task_Objects 2819 (Task_Objs : NE_List.Doubly_Linked_List) 2820 is 2821 Iter : NE_List.Iterator; 2822 Obj_Id : Entity_Id; 2823 2824 begin 2825 Iter := NE_List.Iterate (Task_Objs); 2826 while NE_List.Has_Next (Iter) loop 2827 NE_List.Next (Iter, Obj_Id); 2828 2829 Process_Task_Object 2830 (Obj_Id => Obj_Id, 2831 Typ => Etype (Obj_Id)); 2832 end loop; 2833 end Process_Task_Objects; 2834 2835 ------------------- 2836 -- Traverse_List -- 2837 ------------------- 2838 2839 procedure Traverse_List 2840 (List : List_Id; 2841 Task_Objs : NE_List.Doubly_Linked_List) 2842 is 2843 Item : Node_Id; 2844 Item_Id : Entity_Id; 2845 Item_Typ : Entity_Id; 2846 2847 begin 2848 -- Examine the contents of the list looking for an object 2849 -- declaration of a task type or one that contains a task 2850 -- within. 2851 2852 Item := First (List); 2853 while Present (Item) loop 2854 if Nkind (Item) = N_Object_Declaration then 2855 Item_Id := Defining_Entity (Item); 2856 Item_Typ := Etype (Item_Id); 2857 2858 if Has_Task (Item_Typ) then 2859 2860 -- The object is either of a task type, or contains a 2861 -- task component. Save it in the list of task objects 2862 -- associated with the activation call. 2863 2864 NE_List.Append (Task_Objs, Item_Id); 2865 2866 Process_Task_Object 2867 (Obj_Id => Item_Id, 2868 Typ => Item_Typ); 2869 end if; 2870 end if; 2871 2872 Next (Item); 2873 end loop; 2874 end Traverse_List; 2875 2876 -- Local variables 2877 2878 Context : Node_Id; 2879 Spec : Node_Id; 2880 Task_Objs : NE_List.Doubly_Linked_List; 2881 2882 -- Start of processing for Process_Activation 2883 2884 begin 2885 -- Nothing to do when the activation is a guaranteed ABE 2886 2887 if Is_Known_Guaranteed_ABE (Call) then 2888 return; 2889 end if; 2890 2891 Task_Objs := Activated_Task_Objects (Call_Rep); 2892 2893 -- The activation call has been processed at least once, and all 2894 -- task objects have already been collected. Directly process the 2895 -- objects without having to reexamine the context of the call. 2896 2897 if NE_List.Present (Task_Objs) then 2898 Process_Task_Objects (Task_Objs); 2899 2900 -- Otherwise the activation call is being processed for the first 2901 -- time. Collect all task objects in case the call is reprocessed 2902 -- multiple times. 2903 2904 else 2905 Task_Objs := NE_List.Create; 2906 Set_Activated_Task_Objects (Call_Rep, Task_Objs); 2907 2908 -- Find the context of the activation call where all task objects 2909 -- being activated are declared. This is usually the parent of the 2910 -- call. 2911 2912 Context := Parent (Call); 2913 2914 -- Handle the case where the activation call appears within the 2915 -- handled statements of a block or a body. 2916 2917 if Nkind (Context) = N_Handled_Sequence_Of_Statements then 2918 Context := Parent (Context); 2919 end if; 2920 2921 -- Process all task objects in both the spec and body when the 2922 -- activation call appears in a package body. 2923 2924 if Nkind (Context) = N_Package_Body then 2925 Spec := 2926 Specification 2927 (Unit_Declaration_Node (Corresponding_Spec (Context))); 2928 2929 Traverse_List 2930 (List => Visible_Declarations (Spec), 2931 Task_Objs => Task_Objs); 2932 2933 Traverse_List 2934 (List => Private_Declarations (Spec), 2935 Task_Objs => Task_Objs); 2936 2937 Traverse_List 2938 (List => Declarations (Context), 2939 Task_Objs => Task_Objs); 2940 2941 -- Process all task objects in the spec when the activation call 2942 -- appears in a package spec. 2943 2944 elsif Nkind (Context) = N_Package_Specification then 2945 Traverse_List 2946 (List => Visible_Declarations (Context), 2947 Task_Objs => Task_Objs); 2948 2949 Traverse_List 2950 (List => Private_Declarations (Context), 2951 Task_Objs => Task_Objs); 2952 2953 -- Otherwise the context must be a block or a body. Process all 2954 -- task objects found in the declarations. 2955 2956 else 2957 pragma Assert (Nkind_In (Context, N_Block_Statement, 2958 N_Entry_Body, 2959 N_Protected_Body, 2960 N_Subprogram_Body, 2961 N_Task_Body)); 2962 2963 Traverse_List 2964 (List => Declarations (Context), 2965 Task_Objs => Task_Objs); 2966 end if; 2967 end if; 2968 end Process_Activation; 2969 end Activation_Processor; 2970 2971 ----------------------- 2972 -- Assignment_Target -- 2973 ----------------------- 2974 2975 function Assignment_Target (Asmt : Node_Id) return Node_Id is 2976 Nam : Node_Id; 2977 2978 begin 2979 Nam := Name (Asmt); 2980 2981 -- When the name denotes an array or record component, find the whole 2982 -- object. 2983 2984 while Nkind_In (Nam, N_Explicit_Dereference, 2985 N_Indexed_Component, 2986 N_Selected_Component, 2987 N_Slice) 2988 loop 2989 Nam := Prefix (Nam); 2990 end loop; 2991 2992 return Nam; 2993 end Assignment_Target; 2994 2995 -------------------- 2996 -- Body_Processor -- 2997 -------------------- 2998 2999 package body Body_Processor is 3000 3001 --------------------- 3002 -- Data structures -- 3003 --------------------- 3004 3005 -- The following map relates scenario lists to subprogram bodies 3006 3007 Nested_Scenarios_Map : NE_List_Map.Dynamic_Hash_Table := NE_List_Map.Nil; 3008 3009 -- The following set contains all subprogram bodies that have been 3010 -- processed by routine Traverse_Body. 3011 3012 Traversed_Bodies_Set : NE_Set.Membership_Set := NE_Set.Nil; 3013 3014 ----------------------- 3015 -- Local subprograms -- 3016 ----------------------- 3017 3018 function Is_Traversed_Body (N : Node_Id) return Boolean; 3019 pragma Inline (Is_Traversed_Body); 3020 -- Determine whether subprogram body N has already been traversed 3021 3022 function Nested_Scenarios 3023 (N : Node_Id) return NE_List.Doubly_Linked_List; 3024 pragma Inline (Nested_Scenarios); 3025 -- Obtain the list of scenarios associated with subprogram body N 3026 3027 procedure Set_Is_Traversed_Body 3028 (N : Node_Id; 3029 Val : Boolean := True); 3030 pragma Inline (Set_Is_Traversed_Body); 3031 -- Mark subprogram body N as traversed depending on value Val 3032 3033 procedure Set_Nested_Scenarios 3034 (N : Node_Id; 3035 Scenarios : NE_List.Doubly_Linked_List); 3036 pragma Inline (Set_Nested_Scenarios); 3037 -- Associate scenario list Scenarios with subprogram body N 3038 3039 ----------------------------- 3040 -- Finalize_Body_Processor -- 3041 ----------------------------- 3042 3043 procedure Finalize_Body_Processor is 3044 begin 3045 NE_List_Map.Destroy (Nested_Scenarios_Map); 3046 NE_Set.Destroy (Traversed_Bodies_Set); 3047 end Finalize_Body_Processor; 3048 3049 ------------------------------- 3050 -- Initialize_Body_Processor -- 3051 ------------------------------- 3052 3053 procedure Initialize_Body_Processor is 3054 begin 3055 Nested_Scenarios_Map := NE_List_Map.Create (250); 3056 Traversed_Bodies_Set := NE_Set.Create (250); 3057 end Initialize_Body_Processor; 3058 3059 ----------------------- 3060 -- Is_Traversed_Body -- 3061 ----------------------- 3062 3063 function Is_Traversed_Body (N : Node_Id) return Boolean is 3064 pragma Assert (Present (N)); 3065 begin 3066 return NE_Set.Contains (Traversed_Bodies_Set, N); 3067 end Is_Traversed_Body; 3068 3069 ---------------------- 3070 -- Nested_Scenarios -- 3071 ---------------------- 3072 3073 function Nested_Scenarios 3074 (N : Node_Id) return NE_List.Doubly_Linked_List 3075 is 3076 pragma Assert (Present (N)); 3077 pragma Assert (Nkind (N) = N_Subprogram_Body); 3078 3079 begin 3080 return NE_List_Map.Get (Nested_Scenarios_Map, N); 3081 end Nested_Scenarios; 3082 3083 ---------------------------- 3084 -- Reset_Traversed_Bodies -- 3085 ---------------------------- 3086 3087 procedure Reset_Traversed_Bodies is 3088 begin 3089 NE_Set.Reset (Traversed_Bodies_Set); 3090 end Reset_Traversed_Bodies; 3091 3092 --------------------------- 3093 -- Set_Is_Traversed_Body -- 3094 --------------------------- 3095 3096 procedure Set_Is_Traversed_Body 3097 (N : Node_Id; 3098 Val : Boolean := True) 3099 is 3100 pragma Assert (Present (N)); 3101 3102 begin 3103 if Val then 3104 NE_Set.Insert (Traversed_Bodies_Set, N); 3105 else 3106 NE_Set.Delete (Traversed_Bodies_Set, N); 3107 end if; 3108 end Set_Is_Traversed_Body; 3109 3110 -------------------------- 3111 -- Set_Nested_Scenarios -- 3112 -------------------------- 3113 3114 procedure Set_Nested_Scenarios 3115 (N : Node_Id; 3116 Scenarios : NE_List.Doubly_Linked_List) 3117 is 3118 pragma Assert (Present (N)); 3119 begin 3120 NE_List_Map.Put (Nested_Scenarios_Map, N, Scenarios); 3121 end Set_Nested_Scenarios; 3122 3123 ------------------- 3124 -- Traverse_Body -- 3125 ------------------- 3126 3127 procedure Traverse_Body 3128 (N : Node_Id; 3129 Requires_Processing : Scenario_Predicate_Ptr; 3130 Processor : Scenario_Processor_Ptr; 3131 In_State : Processing_In_State) 3132 is 3133 Scenarios : NE_List.Doubly_Linked_List := NE_List.Nil; 3134 -- The list of scenarios that appear within the declarations and 3135 -- statement of subprogram body N. The variable is intentionally 3136 -- global because Is_Potential_Scenario needs to populate it. 3137 3138 function In_Task_Body (Nod : Node_Id) return Boolean; 3139 pragma Inline (In_Task_Body); 3140 -- Determine whether arbitrary node Nod appears within a task body 3141 3142 function Is_Synchronous_Suspension_Call 3143 (Nod : Node_Id) return Boolean; 3144 pragma Inline (Is_Synchronous_Suspension_Call); 3145 -- Determine whether arbitrary node Nod denotes a call to one of 3146 -- these routines: 3147 -- 3148 -- Ada.Synchronous_Barriers.Wait_For_Release 3149 -- Ada.Synchronous_Task_Control.Suspend_Until_True 3150 3151 procedure Traverse_Collected_Scenarios; 3152 pragma Inline (Traverse_Collected_Scenarios); 3153 -- Traverse the already collected scenarios in list Scenarios by 3154 -- invoking Processor on each individual one. 3155 3156 procedure Traverse_List (List : List_Id); 3157 pragma Inline (Traverse_List); 3158 -- Invoke Traverse_Potential_Scenarios on each node in list List 3159 3160 function Traverse_Potential_Scenario 3161 (Scen : Node_Id) return Traverse_Result; 3162 pragma Inline (Traverse_Potential_Scenario); 3163 -- Determine whether arbitrary node Scen is a suitable scenario using 3164 -- predicate Is_Scenario and traverse it by invoking Processor on it. 3165 3166 procedure Traverse_Potential_Scenarios is 3167 new Traverse_Proc (Traverse_Potential_Scenario); 3168 3169 ------------------ 3170 -- In_Task_Body -- 3171 ------------------ 3172 3173 function In_Task_Body (Nod : Node_Id) return Boolean is 3174 Par : Node_Id; 3175 3176 begin 3177 -- Climb the parent chain looking for a task body [procedure] 3178 3179 Par := Nod; 3180 while Present (Par) loop 3181 if Nkind (Par) = N_Task_Body then 3182 return True; 3183 3184 elsif Nkind (Par) = N_Subprogram_Body 3185 and then Is_Task_Body_Procedure (Par) 3186 then 3187 return True; 3188 3189 -- Prevent the search from going too far. Note that this test 3190 -- shares nodes with the two cases above, and must come last. 3191 3192 elsif Is_Body_Or_Package_Declaration (Par) then 3193 return False; 3194 end if; 3195 3196 Par := Parent (Par); 3197 end loop; 3198 3199 return False; 3200 end In_Task_Body; 3201 3202 ------------------------------------ 3203 -- Is_Synchronous_Suspension_Call -- 3204 ------------------------------------ 3205 3206 function Is_Synchronous_Suspension_Call 3207 (Nod : Node_Id) return Boolean 3208 is 3209 Subp_Id : Entity_Id; 3210 3211 begin 3212 -- To qualify, the call must invoke one of the runtime routines 3213 -- which perform synchronous suspension. 3214 3215 if Is_Suitable_Call (Nod) then 3216 Subp_Id := Target (Nod); 3217 3218 return 3219 Is_RTE (Subp_Id, RE_Suspend_Until_True) 3220 or else 3221 Is_RTE (Subp_Id, RE_Wait_For_Release); 3222 end if; 3223 3224 return False; 3225 end Is_Synchronous_Suspension_Call; 3226 3227 ---------------------------------- 3228 -- Traverse_Collected_Scenarios -- 3229 ---------------------------------- 3230 3231 procedure Traverse_Collected_Scenarios is 3232 Iter : NE_List.Iterator; 3233 Scen : Node_Id; 3234 3235 begin 3236 Iter := NE_List.Iterate (Scenarios); 3237 while NE_List.Has_Next (Iter) loop 3238 NE_List.Next (Iter, Scen); 3239 3240 -- The current scenario satisfies the input predicate, process 3241 -- it. 3242 3243 if Requires_Processing.all (Scen) then 3244 Processor.all (Scen, In_State); 3245 end if; 3246 end loop; 3247 end Traverse_Collected_Scenarios; 3248 3249 ------------------- 3250 -- Traverse_List -- 3251 ------------------- 3252 3253 procedure Traverse_List (List : List_Id) is 3254 Scen : Node_Id; 3255 3256 begin 3257 Scen := First (List); 3258 while Present (Scen) loop 3259 Traverse_Potential_Scenarios (Scen); 3260 Next (Scen); 3261 end loop; 3262 end Traverse_List; 3263 3264 --------------------------------- 3265 -- Traverse_Potential_Scenario -- 3266 --------------------------------- 3267 3268 function Traverse_Potential_Scenario 3269 (Scen : Node_Id) return Traverse_Result 3270 is 3271 begin 3272 -- Special cases 3273 3274 -- Skip constructs which do not have elaboration of their own and 3275 -- need to be elaborated by other means such as invocation, task 3276 -- activation, etc. 3277 3278 if Is_Non_Library_Level_Encapsulator (Scen) then 3279 return Skip; 3280 3281 -- Terminate the traversal of a task body when encountering an 3282 -- accept or select statement, and 3283 -- 3284 -- * Entry calls during elaboration are not allowed. In this 3285 -- case the accept or select statement will cause the task 3286 -- to block at elaboration time because there are no entry 3287 -- calls to unblock it. 3288 -- 3289 -- or 3290 -- 3291 -- * Switch -gnatd_a (stop elaboration checks on accept or 3292 -- select statement) is in effect. 3293 3294 elsif (Debug_Flag_Underscore_A 3295 or else Restriction_Active 3296 (No_Entry_Calls_In_Elaboration_Code)) 3297 and then Nkind_In (Original_Node (Scen), N_Accept_Statement, 3298 N_Selective_Accept) 3299 then 3300 return Abandon; 3301 3302 -- Terminate the traversal of a task body when encountering a 3303 -- suspension call, and 3304 -- 3305 -- * Entry calls during elaboration are not allowed. In this 3306 -- case the suspension call emulates an entry call and will 3307 -- cause the task to block at elaboration time. 3308 -- 3309 -- or 3310 -- 3311 -- * Switch -gnatd_s (stop elaboration checks on synchronous 3312 -- suspension) is in effect. 3313 -- 3314 -- Note that the guard should not be checking the state of flag 3315 -- Within_Task_Body because only suspension calls which appear 3316 -- immediately within the statements of the task are supported. 3317 -- Flag Within_Task_Body carries over to deeper levels of the 3318 -- traversal. 3319 3320 elsif (Debug_Flag_Underscore_S 3321 or else Restriction_Active 3322 (No_Entry_Calls_In_Elaboration_Code)) 3323 and then Is_Synchronous_Suspension_Call (Scen) 3324 and then In_Task_Body (Scen) 3325 then 3326 return Abandon; 3327 3328 -- Certain nodes carry semantic lists which act as repositories 3329 -- until expansion transforms the node and relocates the contents. 3330 -- Examine these lists in case expansion is disabled. 3331 3332 elsif Nkind_In (Scen, N_And_Then, N_Or_Else) then 3333 Traverse_List (Actions (Scen)); 3334 3335 elsif Nkind_In (Scen, N_Elsif_Part, N_Iteration_Scheme) then 3336 Traverse_List (Condition_Actions (Scen)); 3337 3338 elsif Nkind (Scen) = N_If_Expression then 3339 Traverse_List (Then_Actions (Scen)); 3340 Traverse_List (Else_Actions (Scen)); 3341 3342 elsif Nkind_In (Scen, N_Component_Association, 3343 N_Iterated_Component_Association) 3344 then 3345 Traverse_List (Loop_Actions (Scen)); 3346 3347 -- General case 3348 3349 -- The current node satisfies the input predicate, process it 3350 3351 elsif Requires_Processing.all (Scen) then 3352 Processor.all (Scen, In_State); 3353 end if; 3354 3355 -- Save a general scenario regardless of whether it satisfies the 3356 -- input predicate. This allows for quick subsequent traversals of 3357 -- general scenarios, even with different predicates. 3358 3359 if Is_Suitable_Access_Taken (Scen) 3360 or else Is_Suitable_Call (Scen) 3361 or else Is_Suitable_Instantiation (Scen) 3362 or else Is_Suitable_Variable_Assignment (Scen) 3363 or else Is_Suitable_Variable_Reference (Scen) 3364 then 3365 NE_List.Append (Scenarios, Scen); 3366 end if; 3367 3368 return OK; 3369 end Traverse_Potential_Scenario; 3370 3371 -- Start of processing for Traverse_Body 3372 3373 begin 3374 -- Nothing to do when the traversal is suppressed 3375 3376 if In_State.Traversal = No_Traversal then 3377 return; 3378 3379 -- Nothing to do when there is no input 3380 3381 elsif No (N) then 3382 return; 3383 3384 -- Nothing to do when the input is not a subprogram body 3385 3386 elsif Nkind (N) /= N_Subprogram_Body then 3387 return; 3388 3389 -- Nothing to do if the subprogram body was already traversed 3390 3391 elsif Is_Traversed_Body (N) then 3392 return; 3393 end if; 3394 3395 -- Mark the subprogram body as traversed 3396 3397 Set_Is_Traversed_Body (N); 3398 3399 Scenarios := Nested_Scenarios (N); 3400 3401 -- The subprogram body has been traversed at least once, and all 3402 -- scenarios that appear within its declarations and statements 3403 -- have already been collected. Directly retraverse the scenarios 3404 -- without having to retraverse the subprogram body subtree. 3405 3406 if NE_List.Present (Scenarios) then 3407 Traverse_Collected_Scenarios; 3408 3409 -- Otherwise the subprogram body is being traversed for the first 3410 -- time. Collect all scenarios that appear within its declarations 3411 -- and statements in case the subprogram body has to be retraversed 3412 -- multiple times. 3413 3414 else 3415 Scenarios := NE_List.Create; 3416 Set_Nested_Scenarios (N, Scenarios); 3417 3418 Traverse_List (Declarations (N)); 3419 Traverse_Potential_Scenarios (Handled_Statement_Sequence (N)); 3420 end if; 3421 end Traverse_Body; 3422 end Body_Processor; 3423 3424 ----------------------- 3425 -- Build_Call_Marker -- 3426 ----------------------- 3427 3428 procedure Build_Call_Marker (N : Node_Id) is 3429 function In_External_Context 3430 (Call : Node_Id; 3431 Subp_Id : Entity_Id) return Boolean; 3432 pragma Inline (In_External_Context); 3433 -- Determine whether entry, operator, or subprogram Subp_Id is external 3434 -- to call Call which must reside within an instance. 3435 3436 function In_Premature_Context (Call : Node_Id) return Boolean; 3437 pragma Inline (In_Premature_Context); 3438 -- Determine whether call Call appears within a premature context 3439 3440 function Is_Default_Expression (Call : Node_Id) return Boolean; 3441 pragma Inline (Is_Default_Expression); 3442 -- Determine whether call Call acts as the expression of a defaulted 3443 -- parameter within a source call. 3444 3445 function Is_Generic_Formal_Subp (Subp_Id : Entity_Id) return Boolean; 3446 pragma Inline (Is_Generic_Formal_Subp); 3447 -- Determine whether subprogram Subp_Id denotes a generic formal 3448 -- subprogram which appears in the "prologue" of an instantiation. 3449 3450 ------------------------- 3451 -- In_External_Context -- 3452 ------------------------- 3453 3454 function In_External_Context 3455 (Call : Node_Id; 3456 Subp_Id : Entity_Id) return Boolean 3457 is 3458 Spec_Decl : constant Entity_Id := Unit_Declaration_Node (Subp_Id); 3459 3460 Inst : Node_Id; 3461 Inst_Body : Node_Id; 3462 Inst_Spec : Node_Id; 3463 3464 begin 3465 Inst := Find_Enclosing_Instance (Call); 3466 3467 -- The call appears within an instance 3468 3469 if Present (Inst) then 3470 3471 -- The call comes from the main unit and the target does not 3472 3473 if In_Extended_Main_Code_Unit (Call) 3474 and then not In_Extended_Main_Code_Unit (Spec_Decl) 3475 then 3476 return True; 3477 3478 -- Otherwise the target declaration must not appear within the 3479 -- instance spec or body. 3480 3481 else 3482 Spec_And_Body_From_Node 3483 (N => Inst, 3484 Spec_Decl => Inst_Spec, 3485 Body_Decl => Inst_Body); 3486 3487 return not In_Subtree 3488 (N => Spec_Decl, 3489 Root1 => Inst_Spec, 3490 Root2 => Inst_Body); 3491 end if; 3492 end if; 3493 3494 return False; 3495 end In_External_Context; 3496 3497 -------------------------- 3498 -- In_Premature_Context -- 3499 -------------------------- 3500 3501 function In_Premature_Context (Call : Node_Id) return Boolean is 3502 Par : Node_Id; 3503 3504 begin 3505 -- Climb the parent chain looking for premature contexts 3506 3507 Par := Parent (Call); 3508 while Present (Par) loop 3509 3510 -- Aspect specifications and generic associations are premature 3511 -- contexts because nested calls has not been relocated to their 3512 -- final context. 3513 3514 if Nkind_In (Par, N_Aspect_Specification, 3515 N_Generic_Association) 3516 then 3517 return True; 3518 3519 -- Prevent the search from going too far 3520 3521 elsif Is_Body_Or_Package_Declaration (Par) then 3522 exit; 3523 end if; 3524 3525 Par := Parent (Par); 3526 end loop; 3527 3528 return False; 3529 end In_Premature_Context; 3530 3531 --------------------------- 3532 -- Is_Default_Expression -- 3533 --------------------------- 3534 3535 function Is_Default_Expression (Call : Node_Id) return Boolean is 3536 Outer_Call : constant Node_Id := Parent (Call); 3537 Outer_Nam : Node_Id; 3538 3539 begin 3540 -- To qualify, the node must appear immediately within a source call 3541 -- which invokes a source target. 3542 3543 if Nkind_In (Outer_Call, N_Entry_Call_Statement, 3544 N_Function_Call, 3545 N_Procedure_Call_Statement) 3546 and then Comes_From_Source (Outer_Call) 3547 then 3548 Outer_Nam := Call_Name (Outer_Call); 3549 3550 return 3551 Is_Entity_Name (Outer_Nam) 3552 and then Present (Entity (Outer_Nam)) 3553 and then Is_Subprogram_Or_Entry (Entity (Outer_Nam)) 3554 and then Comes_From_Source (Entity (Outer_Nam)); 3555 end if; 3556 3557 return False; 3558 end Is_Default_Expression; 3559 3560 ---------------------------- 3561 -- Is_Generic_Formal_Subp -- 3562 ---------------------------- 3563 3564 function Is_Generic_Formal_Subp (Subp_Id : Entity_Id) return Boolean is 3565 Subp_Decl : constant Node_Id := Unit_Declaration_Node (Subp_Id); 3566 Context : constant Node_Id := Parent (Subp_Decl); 3567 3568 begin 3569 -- To qualify, the subprogram must rename a generic actual subprogram 3570 -- where the enclosing context is an instantiation. 3571 3572 return 3573 Nkind (Subp_Decl) = N_Subprogram_Renaming_Declaration 3574 and then not Comes_From_Source (Subp_Decl) 3575 and then Nkind_In (Context, N_Function_Specification, 3576 N_Package_Specification, 3577 N_Procedure_Specification) 3578 and then Present (Generic_Parent (Context)); 3579 end Is_Generic_Formal_Subp; 3580 3581 -- Local variables 3582 3583 Call_Nam : Node_Id; 3584 Marker : Node_Id; 3585 Subp_Id : Entity_Id; 3586 3587 -- Start of processing for Build_Call_Marker 3588 3589 begin 3590 -- Nothing to do when switch -gnatH (legacy elaboration checking mode 3591 -- enabled) is in effect because the legacy ABE mechanism does not need 3592 -- to carry out this action. 3593 3594 if Legacy_Elaboration_Checks then 3595 return; 3596 3597 -- Nothing to do for ASIS because ABE checks and diagnostics are not 3598 -- performed in this mode. 3599 3600 elsif ASIS_Mode then 3601 return; 3602 3603 -- Nothing to do when the call is being preanalyzed as the marker will 3604 -- be inserted in the wrong place. 3605 3606 elsif Preanalysis_Active then 3607 return; 3608 3609 -- Nothing to do when the elaboration phase of the compiler is not 3610 -- active. 3611 3612 elsif not Elaboration_Phase_Active then 3613 return; 3614 3615 -- Nothing to do when the input does not denote a call or a requeue 3616 3617 elsif not Nkind_In (N, N_Entry_Call_Statement, 3618 N_Function_Call, 3619 N_Procedure_Call_Statement, 3620 N_Requeue_Statement) 3621 then 3622 return; 3623 3624 -- Nothing to do when the input denotes entry call or requeue statement, 3625 -- and switch -gnatd_e (ignore entry calls and requeue statements for 3626 -- elaboration) is in effect. 3627 3628 elsif Debug_Flag_Underscore_E 3629 and then Nkind_In (N, N_Entry_Call_Statement, N_Requeue_Statement) 3630 then 3631 return; 3632 3633 -- Nothing to do when the call is analyzed/resolved too early within an 3634 -- intermediate context. This check is saved for last because it incurs 3635 -- a performance penalty. 3636 3637 elsif In_Premature_Context (N) then 3638 return; 3639 end if; 3640 3641 Call_Nam := Call_Name (N); 3642 3643 -- Nothing to do when the call is erroneous or left in a bad state 3644 3645 if not (Is_Entity_Name (Call_Nam) 3646 and then Present (Entity (Call_Nam)) 3647 and then Is_Subprogram_Or_Entry (Entity (Call_Nam))) 3648 then 3649 return; 3650 end if; 3651 3652 Subp_Id := Canonical_Subprogram (Entity (Call_Nam)); 3653 3654 -- Nothing to do when the call invokes a generic formal subprogram and 3655 -- switch -gnatd.G (ignore calls through generic formal parameters for 3656 -- elaboration) is in effect. This check must be performed with the 3657 -- direct target of the call to avoid the side effects of mapping 3658 -- actuals to formals using renamings. 3659 3660 if Debug_Flag_Dot_GG 3661 and then Is_Generic_Formal_Subp (Entity (Call_Nam)) 3662 then 3663 return; 3664 3665 -- Nothing to do when the call appears within the expanded spec or 3666 -- body of an instantiated generic, the call does not invoke a generic 3667 -- formal subprogram, the target is external to the instance, and switch 3668 -- -gnatdL (ignore external calls from instances for elaboration) is in 3669 -- effect. This check must be performed with the direct target of the 3670 -- call to avoid the side effects of mapping actuals to formals using 3671 -- renamings. 3672 3673 elsif Debug_Flag_LL 3674 and then not Is_Generic_Formal_Subp (Entity (Call_Nam)) 3675 and then In_External_Context 3676 (Call => N, 3677 Subp_Id => Subp_Id) 3678 then 3679 return; 3680 3681 -- Nothing to do when the call invokes an assertion pragma procedure 3682 -- and switch -gnatd_p (ignore assertion pragmas for elaboration) is 3683 -- in effect. 3684 3685 elsif Debug_Flag_Underscore_P 3686 and then Is_Assertion_Pragma_Target (Subp_Id) 3687 then 3688 return; 3689 3690 -- Source calls to source targets are always considered because they 3691 -- reflect the original call graph. 3692 3693 elsif Comes_From_Source (N) and then Comes_From_Source (Subp_Id) then 3694 null; 3695 3696 -- A call to a source function which acts as the default expression in 3697 -- another call requires special detection. 3698 3699 elsif Comes_From_Source (Subp_Id) 3700 and then Nkind (N) = N_Function_Call 3701 and then Is_Default_Expression (N) 3702 then 3703 null; 3704 3705 -- The target emulates Ada semantics 3706 3707 elsif Is_Ada_Semantic_Target (Subp_Id) then 3708 null; 3709 3710 -- The target acts as a link between scenarios 3711 3712 elsif Is_Bridge_Target (Subp_Id) then 3713 null; 3714 3715 -- The target emulates SPARK semantics 3716 3717 elsif Is_SPARK_Semantic_Target (Subp_Id) then 3718 null; 3719 3720 -- Otherwise the call is not suitable for ABE processing. This prevents 3721 -- the generation of call markers which will never play a role in ABE 3722 -- diagnostics. 3723 3724 else 3725 return; 3726 end if; 3727 3728 -- At this point it is known that the call will play some role in ABE 3729 -- checks and diagnostics. Create a corresponding call marker in case 3730 -- the original call is heavily transformed by expansion later on. 3731 3732 Marker := Make_Call_Marker (Sloc (N)); 3733 3734 -- Inherit the attributes of the original call 3735 3736 Set_Is_Declaration_Level_Node 3737 (Marker, Find_Enclosing_Level (N) = Declaration_Level); 3738 3739 Set_Is_Dispatching_Call 3740 (Marker, Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement) 3741 and then Present (Controlling_Argument (N))); 3742 3743 Set_Is_Elaboration_Checks_OK_Node 3744 (Marker, Is_Elaboration_Checks_OK_Node (N)); 3745 3746 Set_Is_Elaboration_Warnings_OK_Node 3747 (Marker, Is_Elaboration_Warnings_OK_Node (N)); 3748 3749 Set_Is_Ignored_Ghost_Node (Marker, Is_Ignored_Ghost_Node (N)); 3750 Set_Is_Source_Call (Marker, Comes_From_Source (N)); 3751 Set_Is_SPARK_Mode_On_Node (Marker, Is_SPARK_Mode_On_Node (N)); 3752 Set_Target (Marker, Subp_Id); 3753 3754 -- The marker is inserted prior to the original call. This placement has 3755 -- several desirable effects: 3756 3757 -- 1) The marker appears in the same context, in close proximity to 3758 -- the call. 3759 3760 -- <marker> 3761 -- <call> 3762 3763 -- 2) Inserting the marker prior to the call ensures that an ABE check 3764 -- will take effect prior to the call. 3765 3766 -- <ABE check> 3767 -- <marker> 3768 -- <call> 3769 3770 -- 3) The above two properties are preserved even when the call is a 3771 -- function which is subsequently relocated in order to capture its 3772 -- result. Note that if the call is relocated to a new context, the 3773 -- relocated call will receive a marker of its own. 3774 3775 -- <ABE check> 3776 -- <maker> 3777 -- Temp : ... := Func_Call ...; 3778 -- ... Temp ... 3779 3780 -- The insertion must take place even when the call does not occur in 3781 -- the main unit to keep the tree symmetric. This ensures that internal 3782 -- name serialization is consistent in case the call marker causes the 3783 -- tree to transform in some way. 3784 3785 Insert_Action (N, Marker); 3786 3787 -- The marker becomes the "corresponding" scenario for the call. Save 3788 -- the marker for later processing by the ABE phase. 3789 3790 Record_Elaboration_Scenario (Marker); 3791 end Build_Call_Marker; 3792 3793 ------------------------------------- 3794 -- Build_Variable_Reference_Marker -- 3795 ------------------------------------- 3796 3797 procedure Build_Variable_Reference_Marker 3798 (N : Node_Id; 3799 Read : Boolean; 3800 Write : Boolean) 3801 is 3802 function Ultimate_Variable (Var_Id : Entity_Id) return Entity_Id; 3803 pragma Inline (Ultimate_Variable); 3804 -- Obtain the ultimate renamed variable of variable Var_Id 3805 3806 ----------------------- 3807 -- Ultimate_Variable -- 3808 ----------------------- 3809 3810 function Ultimate_Variable (Var_Id : Entity_Id) return Entity_Id is 3811 Ren_Id : Entity_Id; 3812 3813 begin 3814 Ren_Id := Var_Id; 3815 while Present (Renamed_Entity (Ren_Id)) 3816 and then Nkind (Renamed_Entity (Ren_Id)) in N_Entity 3817 loop 3818 Ren_Id := Renamed_Entity (Ren_Id); 3819 end loop; 3820 3821 return Ren_Id; 3822 end Ultimate_Variable; 3823 3824 -- Local variables 3825 3826 Var_Id : constant Entity_Id := Ultimate_Variable (Entity (N)); 3827 Marker : Node_Id; 3828 3829 -- Start of processing for Build_Variable_Reference_Marker 3830 3831 begin 3832 -- Nothing to do when the elaboration phase of the compiler is not 3833 -- active. 3834 3835 if not Elaboration_Phase_Active then 3836 return; 3837 end if; 3838 3839 Marker := Make_Variable_Reference_Marker (Sloc (N)); 3840 3841 -- Inherit the attributes of the original variable reference 3842 3843 Set_Is_Elaboration_Checks_OK_Node 3844 (Marker, Is_Elaboration_Checks_OK_Node (N)); 3845 3846 Set_Is_Elaboration_Warnings_OK_Node 3847 (Marker, Is_Elaboration_Warnings_OK_Node (N)); 3848 3849 Set_Is_Read (Marker, Read); 3850 Set_Is_SPARK_Mode_On_Node (Marker, Is_SPARK_Mode_On_Node (N)); 3851 Set_Is_Write (Marker, Write); 3852 Set_Target (Marker, Var_Id); 3853 3854 -- The marker is inserted prior to the original variable reference. The 3855 -- insertion must take place even when the reference does not occur in 3856 -- the main unit to keep the tree symmetric. This ensures that internal 3857 -- name serialization is consistent in case the variable marker causes 3858 -- the tree to transform in some way. 3859 3860 Insert_Action (N, Marker); 3861 3862 -- The marker becomes the "corresponding" scenario for the reference. 3863 -- Save the marker for later processing for the ABE phase. 3864 3865 Record_Elaboration_Scenario (Marker); 3866 end Build_Variable_Reference_Marker; 3867 3868 --------------- 3869 -- Call_Name -- 3870 --------------- 3871 3872 function Call_Name (Call : Node_Id) return Node_Id is 3873 Nam : Node_Id; 3874 3875 begin 3876 Nam := Name (Call); 3877 3878 -- When the call invokes an entry family, the name appears as an indexed 3879 -- component. 3880 3881 if Nkind (Nam) = N_Indexed_Component then 3882 Nam := Prefix (Nam); 3883 end if; 3884 3885 -- When the call employs the object.operation form, the name appears as 3886 -- a selected component. 3887 3888 if Nkind (Nam) = N_Selected_Component then 3889 Nam := Selector_Name (Nam); 3890 end if; 3891 3892 return Nam; 3893 end Call_Name; 3894 3895 -------------------------- 3896 -- Canonical_Subprogram -- 3897 -------------------------- 3898 3899 function Canonical_Subprogram (Subp_Id : Entity_Id) return Entity_Id is 3900 Canon_Id : Entity_Id; 3901 3902 begin 3903 Canon_Id := Subp_Id; 3904 3905 -- Use the original protected subprogram when dealing with one of the 3906 -- specialized lock-manipulating versions. 3907 3908 if Is_Protected_Body_Subp (Canon_Id) then 3909 Canon_Id := Protected_Subprogram (Canon_Id); 3910 end if; 3911 3912 -- Obtain the original subprogram except when the subprogram is also 3913 -- an instantiation. In this case the alias is the internally generated 3914 -- subprogram which appears within the anonymous package created for the 3915 -- instantiation, making it unuitable. 3916 3917 if not Is_Generic_Instance (Canon_Id) then 3918 Canon_Id := Get_Renamed_Entity (Canon_Id); 3919 end if; 3920 3921 return Canon_Id; 3922 end Canonical_Subprogram; 3923 3924 --------------------------------- 3925 -- Check_Elaboration_Scenarios -- 3926 --------------------------------- 3927 3928 procedure Check_Elaboration_Scenarios is 3929 Iter : NE_Set.Iterator; 3930 3931 begin 3932 -- Nothing to do when switch -gnatH (legacy elaboration checking mode 3933 -- enabled) is in effect because the legacy ABE mechanism does not need 3934 -- to carry out this action. 3935 3936 if Legacy_Elaboration_Checks then 3937 Finalize_All_Data_Structures; 3938 return; 3939 3940 -- Nothing to do for ASIS because ABE checks and diagnostics are not 3941 -- performed in this mode. 3942 3943 elsif ASIS_Mode 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_In (Original_Node (Comp_Unit), N_Protected_Body, 4536 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_In (Original_Node (Parent (Comp_Unit)), 4553 N_Function_Instantiation, 4554 N_Procedure_Instantiation) 4555 then 4556 Comp_Unit := Parent (Parent (Comp_Unit)); 4557 4558 -- Handle the case where the compilation unit is a subunit 4559 4560 elsif Nkind (Comp_Unit) = N_Subunit then 4561 Comp_Unit := Parent (Comp_Unit); 4562 end if; 4563 4564 pragma Assert (Nkind (Comp_Unit) = N_Compilation_Unit); 4565 4566 return Comp_Unit; 4567 end Compilation_Unit; 4568 4569 ------------------------------- 4570 -- Conditional_ABE_Processor -- 4571 ------------------------------- 4572 4573 package body Conditional_ABE_Processor is 4574 4575 ----------------------- 4576 -- Local subprograms -- 4577 ----------------------- 4578 4579 function Is_Conditional_ABE_Scenario (N : Node_Id) return Boolean; 4580 pragma Inline (Is_Conditional_ABE_Scenario); 4581 -- Determine whether node N is a suitable scenario for conditional ABE 4582 -- checks and diagnostics. 4583 4584 procedure Process_Conditional_ABE_Access_Taken 4585 (Attr : Node_Id; 4586 Attr_Rep : Scenario_Rep_Id; 4587 In_State : Processing_In_State); 4588 pragma Inline (Process_Conditional_ABE_Access_Taken); 4589 -- Perform ABE checks and diagnostics for attribute reference Attr with 4590 -- representation Attr_Rep which takes 'Access of an entry, operator, or 4591 -- subprogram. In_State is the current state of the Processing phase. 4592 4593 procedure Process_Conditional_ABE_Activation 4594 (Call : Node_Id; 4595 Call_Rep : Scenario_Rep_Id; 4596 Obj_Id : Entity_Id; 4597 Obj_Rep : Target_Rep_Id; 4598 Task_Typ : Entity_Id; 4599 Task_Rep : Target_Rep_Id; 4600 In_State : Processing_In_State); 4601 pragma Inline (Process_Conditional_ABE_Activation); 4602 -- Perform common conditional ABE checks and diagnostics for activation 4603 -- call Call which activates object Obj_Id of task type Task_Typ. Formal 4604 -- Call_Rep denotes the representation of the call. Obj_Rep denotes the 4605 -- representation of the object. Task_Rep denotes the representation of 4606 -- the task type. In_State is the current state of the Processing phase. 4607 4608 procedure Process_Conditional_ABE_Call 4609 (Call : Node_Id; 4610 Call_Rep : Scenario_Rep_Id; 4611 In_State : Processing_In_State); 4612 pragma Inline (Process_Conditional_ABE_Call); 4613 -- Top-level dispatcher for processing of calls. Perform ABE checks and 4614 -- diagnostics for call Call with representation Call_Rep. In_State is 4615 -- the current state of the Processing phase. 4616 4617 procedure Process_Conditional_ABE_Call_Ada 4618 (Call : Node_Id; 4619 Call_Rep : Scenario_Rep_Id; 4620 Subp_Id : Entity_Id; 4621 Subp_Rep : Target_Rep_Id; 4622 In_State : Processing_In_State); 4623 pragma Inline (Process_Conditional_ABE_Call_Ada); 4624 -- Perform ABE checks and diagnostics for call Call which invokes entry, 4625 -- operator, or subprogram Subp_Id using the Ada rules. Call_Rep denotes 4626 -- the representation of the call. Subp_Rep denotes the representation 4627 -- of the subprogram. In_State is the current state of the Processing 4628 -- phase. 4629 4630 procedure Process_Conditional_ABE_Call_SPARK 4631 (Call : Node_Id; 4632 Call_Rep : Scenario_Rep_Id; 4633 Subp_Id : Entity_Id; 4634 Subp_Rep : Target_Rep_Id; 4635 In_State : Processing_In_State); 4636 pragma Inline (Process_Conditional_ABE_Call_SPARK); 4637 -- Perform ABE checks and diagnostics for call Call which invokes entry, 4638 -- operator, or subprogram Subp_Id using the SPARK rules. Call_Rep is 4639 -- the representation of the call. Subp_Rep denotes the representation 4640 -- of the subprogram. In_State is the current state of the Processing 4641 -- phase. 4642 4643 procedure Process_Conditional_ABE_Instantiation 4644 (Inst : Node_Id; 4645 Inst_Rep : Scenario_Rep_Id; 4646 In_State : Processing_In_State); 4647 pragma Inline (Process_Conditional_ABE_Instantiation); 4648 -- Top-level dispatcher for processing of instantiations. Perform ABE 4649 -- checks and diagnostics for instantiation Inst with representation 4650 -- Inst_Rep. In_State is the current state of the Processing phase. 4651 4652 procedure Process_Conditional_ABE_Instantiation_Ada 4653 (Inst : Node_Id; 4654 Inst_Rep : Scenario_Rep_Id; 4655 Gen_Id : Entity_Id; 4656 Gen_Rep : Target_Rep_Id; 4657 In_State : Processing_In_State); 4658 pragma Inline (Process_Conditional_ABE_Instantiation_Ada); 4659 -- Perform ABE checks and diagnostics for instantiation Inst of generic 4660 -- Gen_Id using the Ada rules. Inst_Rep denotes the representation of 4661 -- the instnace. Gen_Rep is the representation of the generic. In_State 4662 -- is the current state of the Processing phase. 4663 4664 procedure Process_Conditional_ABE_Instantiation_SPARK 4665 (Inst : Node_Id; 4666 Inst_Rep : Scenario_Rep_Id; 4667 Gen_Id : Entity_Id; 4668 Gen_Rep : Target_Rep_Id; 4669 In_State : Processing_In_State); 4670 pragma Inline (Process_Conditional_ABE_Instantiation_SPARK); 4671 -- Perform ABE checks and diagnostics for instantiation Inst of generic 4672 -- Gen_Id using the SPARK rules. Inst_Rep denotes the representation of 4673 -- the instnace. Gen_Rep is the representation of the generic. In_State 4674 -- is the current state of the Processing phase. 4675 4676 procedure Process_Conditional_ABE_Variable_Assignment 4677 (Asmt : Node_Id; 4678 Asmt_Rep : Scenario_Rep_Id; 4679 In_State : Processing_In_State); 4680 pragma Inline (Process_Conditional_ABE_Variable_Assignment); 4681 -- Top-level dispatcher for processing of variable assignments. Perform 4682 -- ABE checks and diagnostics for assignment Asmt with representation 4683 -- Asmt_Rep. In_State denotes the current state of the Processing phase. 4684 4685 procedure Process_Conditional_ABE_Variable_Assignment_Ada 4686 (Asmt : Node_Id; 4687 Asmt_Rep : Scenario_Rep_Id; 4688 Var_Id : Entity_Id; 4689 Var_Rep : Target_Rep_Id; 4690 In_State : Processing_In_State); 4691 pragma Inline (Process_Conditional_ABE_Variable_Assignment_Ada); 4692 -- Perform ABE checks and diagnostics for assignment statement Asmt that 4693 -- modifies the value of variable Var_Id using the Ada rules. Asmt_Rep 4694 -- denotes the representation of the assignment. Var_Rep denotes the 4695 -- representation of the variable. In_State is the current state of the 4696 -- Processing phase. 4697 4698 procedure Process_Conditional_ABE_Variable_Assignment_SPARK 4699 (Asmt : Node_Id; 4700 Asmt_Rep : Scenario_Rep_Id; 4701 Var_Id : Entity_Id; 4702 Var_Rep : Target_Rep_Id; 4703 In_State : Processing_In_State); 4704 pragma Inline (Process_Conditional_ABE_Variable_Assignment_SPARK); 4705 -- Perform ABE checks and diagnostics for assignment statement Asmt that 4706 -- modifies the value of variable Var_Id using the SPARK rules. Asmt_Rep 4707 -- denotes the representation of the assignment. Var_Rep denotes the 4708 -- representation of the variable. In_State is the current state of the 4709 -- Processing phase. 4710 4711 procedure Process_Conditional_ABE_Variable_Reference 4712 (Ref : Node_Id; 4713 Ref_Rep : Scenario_Rep_Id; 4714 In_State : Processing_In_State); 4715 pragma Inline (Process_Conditional_ABE_Variable_Reference); 4716 -- Perform ABE checks and diagnostics for variable reference Ref with 4717 -- representation Ref_Rep. In_State denotes the current state of the 4718 -- Processing phase. 4719 4720 procedure Traverse_Conditional_ABE_Body 4721 (N : Node_Id; 4722 In_State : Processing_In_State); 4723 pragma Inline (Traverse_Conditional_ABE_Body); 4724 -- Traverse subprogram body N looking for suitable scenarios that need 4725 -- to be processed for conditional ABE checks and diagnostics. In_State 4726 -- is the current state of the Processing phase. 4727 4728 ------------------------------------- 4729 -- Check_Conditional_ABE_Scenarios -- 4730 ------------------------------------- 4731 4732 procedure Check_Conditional_ABE_Scenarios 4733 (Iter : in out NE_Set.Iterator) 4734 is 4735 N : Node_Id; 4736 4737 begin 4738 while NE_Set.Has_Next (Iter) loop 4739 NE_Set.Next (Iter, N); 4740 4741 -- Reset the traversed status of all subprogram bodies because the 4742 -- current conditional scenario acts as a new DFS traversal root. 4743 4744 Reset_Traversed_Bodies; 4745 4746 Process_Conditional_ABE 4747 (N => N, 4748 In_State => Conditional_ABE_State); 4749 end loop; 4750 end Check_Conditional_ABE_Scenarios; 4751 4752 --------------------------------- 4753 -- Is_Conditional_ABE_Scenario -- 4754 --------------------------------- 4755 4756 function Is_Conditional_ABE_Scenario (N : Node_Id) return Boolean is 4757 begin 4758 return 4759 Is_Suitable_Access_Taken (N) 4760 or else Is_Suitable_Call (N) 4761 or else Is_Suitable_Instantiation (N) 4762 or else Is_Suitable_Variable_Assignment (N) 4763 or else Is_Suitable_Variable_Reference (N); 4764 end Is_Conditional_ABE_Scenario; 4765 4766 ----------------------------- 4767 -- Process_Conditional_ABE -- 4768 ----------------------------- 4769 4770 procedure Process_Conditional_ABE 4771 (N : Node_Id; 4772 In_State : Processing_In_State) 4773 is 4774 Scen : constant Node_Id := Scenario (N); 4775 Scen_Rep : Scenario_Rep_Id; 4776 4777 begin 4778 -- Add the current scenario to the stack of active scenarios 4779 4780 Push_Active_Scenario (Scen); 4781 4782 -- 'Access 4783 4784 if Is_Suitable_Access_Taken (Scen) then 4785 Process_Conditional_ABE_Access_Taken 4786 (Attr => Scen, 4787 Attr_Rep => Scenario_Representation_Of (Scen, In_State), 4788 In_State => In_State); 4789 4790 -- Call or task activation 4791 4792 elsif Is_Suitable_Call (Scen) then 4793 Scen_Rep := Scenario_Representation_Of (Scen, In_State); 4794 4795 -- Routine Build_Call_Marker creates call markers regardless of 4796 -- whether the call occurs within the main unit or not. This way 4797 -- the serialization of internal names is kept consistent. Only 4798 -- call markers found within the main unit must be processed. 4799 4800 if In_Main_Context (Scen) then 4801 Scen_Rep := Scenario_Representation_Of (Scen, In_State); 4802 4803 if Kind (Scen_Rep) = Call_Scenario then 4804 Process_Conditional_ABE_Call 4805 (Call => Scen, 4806 Call_Rep => Scen_Rep, 4807 In_State => In_State); 4808 4809 else 4810 pragma Assert (Kind (Scen_Rep) = Task_Activation_Scenario); 4811 4812 Process_Activation 4813 (Call => Scen, 4814 Call_Rep => Scen_Rep, 4815 Processor => Process_Conditional_ABE_Activation'Access, 4816 In_State => In_State); 4817 end if; 4818 end if; 4819 4820 -- Instantiation 4821 4822 elsif Is_Suitable_Instantiation (Scen) then 4823 Process_Conditional_ABE_Instantiation 4824 (Inst => Scen, 4825 Inst_Rep => Scenario_Representation_Of (Scen, In_State), 4826 In_State => In_State); 4827 4828 -- Variable assignments 4829 4830 elsif Is_Suitable_Variable_Assignment (Scen) then 4831 Process_Conditional_ABE_Variable_Assignment 4832 (Asmt => Scen, 4833 Asmt_Rep => Scenario_Representation_Of (Scen, In_State), 4834 In_State => In_State); 4835 4836 -- Variable references 4837 4838 elsif Is_Suitable_Variable_Reference (Scen) then 4839 4840 -- Routine Build_Variable_Reference_Marker makes variable markers 4841 -- regardless of whether the reference occurs within the main unit 4842 -- or not. This way the serialization of internal names is kept 4843 -- consistent. Only variable markers within the main unit must be 4844 -- processed. 4845 4846 if In_Main_Context (Scen) then 4847 Process_Conditional_ABE_Variable_Reference 4848 (Ref => Scen, 4849 Ref_Rep => Scenario_Representation_Of (Scen, In_State), 4850 In_State => In_State); 4851 end if; 4852 end if; 4853 4854 -- Remove the current scenario from the stack of active scenarios 4855 -- once all ABE diagnostics and checks have been performed. 4856 4857 Pop_Active_Scenario (Scen); 4858 end Process_Conditional_ABE; 4859 4860 ------------------------------------------ 4861 -- Process_Conditional_ABE_Access_Taken -- 4862 ------------------------------------------ 4863 4864 procedure Process_Conditional_ABE_Access_Taken 4865 (Attr : Node_Id; 4866 Attr_Rep : Scenario_Rep_Id; 4867 In_State : Processing_In_State) 4868 is 4869 function Build_Access_Marker (Subp_Id : Entity_Id) return Node_Id; 4870 pragma Inline (Build_Access_Marker); 4871 -- Create a suitable call marker which invokes subprogram Subp_Id 4872 4873 ------------------------- 4874 -- Build_Access_Marker -- 4875 ------------------------- 4876 4877 function Build_Access_Marker (Subp_Id : Entity_Id) return Node_Id is 4878 Marker : Node_Id; 4879 4880 begin 4881 Marker := Make_Call_Marker (Sloc (Attr)); 4882 4883 -- Inherit relevant attributes from the attribute 4884 4885 Set_Target (Marker, Subp_Id); 4886 Set_Is_Declaration_Level_Node 4887 (Marker, Level (Attr_Rep) = Declaration_Level); 4888 Set_Is_Dispatching_Call 4889 (Marker, False); 4890 Set_Is_Elaboration_Checks_OK_Node 4891 (Marker, Elaboration_Checks_OK (Attr_Rep)); 4892 Set_Is_Elaboration_Warnings_OK_Node 4893 (Marker, Elaboration_Warnings_OK (Attr_Rep)); 4894 Set_Is_Source_Call 4895 (Marker, Comes_From_Source (Attr)); 4896 Set_Is_SPARK_Mode_On_Node 4897 (Marker, SPARK_Mode_Of (Attr_Rep) = Is_On); 4898 4899 -- Partially insert the call marker into the tree by setting its 4900 -- parent pointer. 4901 4902 Set_Parent (Marker, Attr); 4903 4904 return Marker; 4905 end Build_Access_Marker; 4906 4907 -- Local variables 4908 4909 Root : constant Node_Id := Root_Scenario; 4910 Subp_Id : constant Entity_Id := Target (Attr_Rep); 4911 Subp_Rep : constant Target_Rep_Id := 4912 Target_Representation_Of (Subp_Id, In_State); 4913 Body_Decl : constant Node_Id := Body_Declaration (Subp_Rep); 4914 4915 New_In_State : Processing_In_State := In_State; 4916 -- Each step of the Processing phase constitutes a new state 4917 4918 -- Start of processing for Process_Conditional_ABE_Access 4919 4920 begin 4921 -- Output relevant information when switch -gnatel (info messages on 4922 -- implicit Elaborate[_All] pragmas) is in effect. 4923 4924 if Elab_Info_Messages 4925 and then not New_In_State.Suppress_Info_Messages 4926 then 4927 Error_Msg_NE 4928 ("info: access to & during elaboration", Attr, Subp_Id); 4929 end if; 4930 4931 -- Warnings are suppressed when a prior scenario is already in that 4932 -- mode or when the attribute or the target have warnings suppressed. 4933 -- Update the state of the Processing phase to reflect this. 4934 4935 New_In_State.Suppress_Warnings := 4936 New_In_State.Suppress_Warnings 4937 or else not Elaboration_Warnings_OK (Attr_Rep) 4938 or else not Elaboration_Warnings_OK (Subp_Rep); 4939 4940 -- Do not emit any ABE diagnostics when the current or previous 4941 -- scenario in this traversal has suppressed elaboration warnings. 4942 4943 if New_In_State.Suppress_Warnings then 4944 null; 4945 4946 -- Both the attribute and the corresponding subprogram body are in 4947 -- the same unit. The body must appear prior to the root scenario 4948 -- which started the recursive search. If this is not the case, then 4949 -- there is a potential ABE if the access value is used to call the 4950 -- subprogram. Emit a warning only when switch -gnatw.f (warnings on 4951 -- suspucious 'Access) is in effect. 4952 4953 elsif Warn_On_Elab_Access 4954 and then Present (Body_Decl) 4955 and then In_Extended_Main_Code_Unit (Body_Decl) 4956 and then Earlier_In_Extended_Unit (Root, Body_Decl) 4957 then 4958 Error_Msg_Name_1 := Attribute_Name (Attr); 4959 Error_Msg_NE 4960 ("??% attribute of & before body seen", Attr, Subp_Id); 4961 Error_Msg_N ("\possible Program_Error on later references", Attr); 4962 4963 Output_Active_Scenarios (Attr, New_In_State); 4964 end if; 4965 4966 -- Treat the attribute an immediate invocation of the target when 4967 -- switch -gnatd.o (conservative elaboration order for indirect 4968 -- calls) is in effect. This has the following desirable effects: 4969 -- 4970 -- * Ensure that the unit with the corresponding body is elaborated 4971 -- prior to the main unit. 4972 -- 4973 -- * Perform conditional ABE checks and diagnostics 4974 -- 4975 -- * Traverse the body of the target (if available) 4976 4977 if Debug_Flag_Dot_O then 4978 Process_Conditional_ABE 4979 (N => Build_Access_Marker (Subp_Id), 4980 In_State => New_In_State); 4981 4982 -- Otherwise ensure that the unit with the corresponding body is 4983 -- elaborated prior to the main unit. 4984 4985 else 4986 Ensure_Prior_Elaboration 4987 (N => Attr, 4988 Unit_Id => Unit (Subp_Rep), 4989 Prag_Nam => Name_Elaborate_All, 4990 In_State => New_In_State); 4991 end if; 4992 end Process_Conditional_ABE_Access_Taken; 4993 4994 ---------------------------------------- 4995 -- Process_Conditional_ABE_Activation -- 4996 ---------------------------------------- 4997 4998 procedure Process_Conditional_ABE_Activation 4999 (Call : Node_Id; 5000 Call_Rep : Scenario_Rep_Id; 5001 Obj_Id : Entity_Id; 5002 Obj_Rep : Target_Rep_Id; 5003 Task_Typ : Entity_Id; 5004 Task_Rep : Target_Rep_Id; 5005 In_State : Processing_In_State) 5006 is 5007 pragma Unreferenced (Task_Typ); 5008 5009 Body_Decl : constant Node_Id := Body_Declaration (Task_Rep); 5010 Spec_Decl : constant Node_Id := Spec_Declaration (Task_Rep); 5011 Root : constant Node_Id := Root_Scenario; 5012 Unit_Id : constant Node_Id := Unit (Task_Rep); 5013 5014 Check_OK : constant Boolean := 5015 not In_State.Suppress_Checks 5016 and then Ghost_Mode_Of (Obj_Rep) /= Is_Ignored 5017 and then Ghost_Mode_Of (Task_Rep) /= Is_Ignored 5018 and then Elaboration_Checks_OK (Obj_Rep) 5019 and then Elaboration_Checks_OK (Task_Rep); 5020 -- A run-time ABE check may be installed only when the object and the 5021 -- task type have active elaboration checks, and both are not ignored 5022 -- Ghost constructs. 5023 5024 New_In_State : Processing_In_State := In_State; 5025 -- Each step of the Processing phase constitutes a new state 5026 5027 begin 5028 -- Output relevant information when switch -gnatel (info messages on 5029 -- implicit Elaborate[_All] pragmas) is in effect. 5030 5031 if Elab_Info_Messages 5032 and then not New_In_State.Suppress_Info_Messages 5033 then 5034 Error_Msg_NE 5035 ("info: activation of & during elaboration", Call, Obj_Id); 5036 end if; 5037 5038 -- Nothing to do when the call activates a task whose type is defined 5039 -- within an instance and switch -gnatd_i (ignore activations and 5040 -- calls to instances for elaboration) is in effect. 5041 5042 if Debug_Flag_Underscore_I 5043 and then In_External_Instance 5044 (N => Call, 5045 Target_Decl => Spec_Decl) 5046 then 5047 return; 5048 5049 -- Nothing to do when the activation is a guaranteed ABE 5050 5051 elsif Is_Known_Guaranteed_ABE (Call) then 5052 return; 5053 5054 -- Nothing to do when the root scenario appears at the declaration 5055 -- level and the task is in the same unit, but outside this context. 5056 -- 5057 -- task type Task_Typ; -- task declaration 5058 -- 5059 -- procedure Proc is 5060 -- function A ... is 5061 -- begin 5062 -- if Some_Condition then 5063 -- declare 5064 -- T : Task_Typ; 5065 -- begin 5066 -- <activation call> -- activation site 5067 -- end; 5068 -- ... 5069 -- end A; 5070 -- 5071 -- X : ... := A; -- root scenario 5072 -- ... 5073 -- 5074 -- task body Task_Typ is 5075 -- ... 5076 -- end Task_Typ; 5077 -- 5078 -- In the example above, the context of X is the declarative list of 5079 -- Proc. The "elaboration" of X may reach the activation of T whose 5080 -- body is defined outside of X's context. The task body is relevant 5081 -- only when Proc is invoked, but this happens only during "normal" 5082 -- elaboration, therefore the task body must not be considered if 5083 -- this is not the case. 5084 5085 elsif Is_Up_Level_Target 5086 (Targ_Decl => Spec_Decl, 5087 In_State => New_In_State) 5088 then 5089 return; 5090 5091 -- Nothing to do when the activation is ABE-safe 5092 -- 5093 -- generic 5094 -- package Gen is 5095 -- task type Task_Typ; 5096 -- end Gen; 5097 -- 5098 -- package body Gen is 5099 -- task body Task_Typ is 5100 -- begin 5101 -- ... 5102 -- end Task_Typ; 5103 -- end Gen; 5104 -- 5105 -- with Gen; 5106 -- procedure Main is 5107 -- package Nested is 5108 -- package Inst is new Gen; 5109 -- T : Inst.Task_Typ; 5110 -- <activation call> -- safe activation 5111 -- end Nested; 5112 -- ... 5113 5114 elsif Is_Safe_Activation (Call, Task_Rep) then 5115 5116 -- Note that the task body must still be examined for any nested 5117 -- scenarios. 5118 5119 null; 5120 5121 -- The activation call and the task body are both in the main unit 5122 -- 5123 -- If the root scenario appears prior to the task body, then this is 5124 -- a possible ABE with respect to the root scenario. 5125 -- 5126 -- task type Task_Typ; 5127 -- 5128 -- function A ... is 5129 -- begin 5130 -- if Some_Condition then 5131 -- declare 5132 -- package Pack is 5133 -- T : Task_Typ; 5134 -- end Pack; -- activation of T 5135 -- ... 5136 -- end A; 5137 -- 5138 -- X : ... := A; -- root scenario 5139 -- 5140 -- task body Task_Typ is -- task body 5141 -- ... 5142 -- end Task_Typ; 5143 -- 5144 -- Y : ... := A; -- root scenario 5145 -- 5146 -- IMPORTANT: The activation of T is a possible ABE for X, but 5147 -- not for Y. Intalling an unconditional ABE raise prior to the 5148 -- activation call would be wrong as it will fail for Y as well 5149 -- but in Y's case the activation of T is never an ABE. 5150 5151 elsif Present (Body_Decl) 5152 and then In_Extended_Main_Code_Unit (Body_Decl) 5153 then 5154 if Earlier_In_Extended_Unit (Root, Body_Decl) then 5155 5156 -- Do not emit any ABE diagnostics when a previous scenario in 5157 -- this traversal has suppressed elaboration warnings. 5158 5159 if New_In_State.Suppress_Warnings then 5160 null; 5161 5162 -- Do not emit any ABE diagnostics when the activation occurs 5163 -- in a partial finalization context because this action leads 5164 -- to confusing noise. 5165 5166 elsif New_In_State.Within_Partial_Finalization then 5167 null; 5168 5169 -- Otherwise emit the ABE disgnostic 5170 5171 else 5172 Error_Msg_Sloc := Sloc (Call); 5173 Error_Msg_N 5174 ("??task & will be activated # before elaboration of its " 5175 & "body", Obj_Id); 5176 Error_Msg_N 5177 ("\Program_Error may be raised at run time", Obj_Id); 5178 5179 Output_Active_Scenarios (Obj_Id, New_In_State); 5180 end if; 5181 5182 -- Install a conditional run-time ABE check to verify that the 5183 -- task body has been elaborated prior to the activation call. 5184 5185 if Check_OK then 5186 Install_Scenario_ABE_Check 5187 (N => Call, 5188 Targ_Id => Defining_Entity (Spec_Decl), 5189 Targ_Rep => Task_Rep, 5190 Disable => Obj_Rep); 5191 5192 -- Update the state of the Processing phase to indicate that 5193 -- no implicit Elaborate[_All] pragma must be generated from 5194 -- this point on. 5195 -- 5196 -- task type Task_Typ; 5197 -- 5198 -- function A ... is 5199 -- begin 5200 -- if Some_Condition then 5201 -- declare 5202 -- package Pack is 5203 -- <ABE check> 5204 -- T : Task_Typ; 5205 -- end Pack; -- activation of T 5206 -- ... 5207 -- end A; 5208 -- 5209 -- X : ... := A; 5210 -- 5211 -- task body Task_Typ is 5212 -- begin 5213 -- External.Subp; -- imparts Elaborate_All 5214 -- end Task_Typ; 5215 -- 5216 -- If Some_Condition is True, then the ABE check will fail 5217 -- at runtime and the call to External.Subp will never take 5218 -- place, rendering the implicit Elaborate_All useless. 5219 -- 5220 -- If the value of Some_Condition is False, then the call 5221 -- to External.Subp will never take place, rendering the 5222 -- implicit Elaborate_All useless. 5223 5224 New_In_State.Suppress_Implicit_Pragmas := True; 5225 end if; 5226 end if; 5227 5228 -- Otherwise the task body is not available in this compilation or 5229 -- it resides in an external unit. Install a run-time ABE check to 5230 -- verify that the task body has been elaborated prior to the 5231 -- activation call when the dynamic model is in effect. 5232 5233 elsif Check_OK 5234 and then New_In_State.Processing = Dynamic_Model_Processing 5235 then 5236 Install_Unit_ABE_Check 5237 (N => Call, 5238 Unit_Id => Unit_Id, 5239 Disable => Obj_Rep); 5240 end if; 5241 5242 -- Both the activation call and task type are subject to SPARK_Mode 5243 -- On, this triggers the SPARK rules for task activation. Compared 5244 -- to calls and instantiations, task activation in SPARK does not 5245 -- require the presence of Elaborate[_All] pragmas in case the task 5246 -- type is defined outside the main unit. This is because SPARK uses 5247 -- a special policy which activates all tasks after the main unit has 5248 -- finished its elaboration. 5249 5250 if SPARK_Mode_Of (Call_Rep) = Is_On 5251 and then SPARK_Mode_Of (Task_Rep) = Is_On 5252 then 5253 null; 5254 5255 -- Otherwise the Ada rules are in effect. Ensure that the unit with 5256 -- the task body is elaborated prior to the main unit. 5257 5258 else 5259 Ensure_Prior_Elaboration 5260 (N => Call, 5261 Unit_Id => Unit_Id, 5262 Prag_Nam => Name_Elaborate_All, 5263 In_State => New_In_State); 5264 end if; 5265 5266 Traverse_Conditional_ABE_Body 5267 (N => Body_Decl, 5268 In_State => New_In_State); 5269 end Process_Conditional_ABE_Activation; 5270 5271 ---------------------------------- 5272 -- Process_Conditional_ABE_Call -- 5273 ---------------------------------- 5274 5275 procedure Process_Conditional_ABE_Call 5276 (Call : Node_Id; 5277 Call_Rep : Scenario_Rep_Id; 5278 In_State : Processing_In_State) 5279 is 5280 function In_Initialization_Context (N : Node_Id) return Boolean; 5281 pragma Inline (In_Initialization_Context); 5282 -- Determine whether arbitrary node N appears within a type init 5283 -- proc, primitive [Deep_]Initialize, or a block created for 5284 -- initialization purposes. 5285 5286 function Is_Partial_Finalization_Proc 5287 (Subp_Id : Entity_Id) return Boolean; 5288 pragma Inline (Is_Partial_Finalization_Proc); 5289 -- Determine whether subprogram Subp_Id is a partial finalization 5290 -- procedure. 5291 5292 ------------------------------- 5293 -- In_Initialization_Context -- 5294 ------------------------------- 5295 5296 function In_Initialization_Context (N : Node_Id) return Boolean is 5297 Par : Node_Id; 5298 Spec_Id : Entity_Id; 5299 5300 begin 5301 -- Climb the parent chain looking for initialization actions 5302 5303 Par := Parent (N); 5304 while Present (Par) loop 5305 5306 -- A block may be part of the initialization actions of a 5307 -- default initialized object. 5308 5309 if Nkind (Par) = N_Block_Statement 5310 and then Is_Initialization_Block (Par) 5311 then 5312 return True; 5313 5314 -- A subprogram body may denote an initialization routine 5315 5316 elsif Nkind (Par) = N_Subprogram_Body then 5317 Spec_Id := Unique_Defining_Entity (Par); 5318 5319 -- The current subprogram body denotes a type init proc or 5320 -- primitive [Deep_]Initialize. 5321 5322 if Is_Init_Proc (Spec_Id) 5323 or else Is_Controlled_Proc (Spec_Id, Name_Initialize) 5324 or else Is_TSS (Spec_Id, TSS_Deep_Initialize) 5325 then 5326 return True; 5327 end if; 5328 5329 -- Prevent the search from going too far 5330 5331 elsif Is_Body_Or_Package_Declaration (Par) then 5332 exit; 5333 end if; 5334 5335 Par := Parent (Par); 5336 end loop; 5337 5338 return False; 5339 end In_Initialization_Context; 5340 5341 ---------------------------------- 5342 -- Is_Partial_Finalization_Proc -- 5343 ---------------------------------- 5344 5345 function Is_Partial_Finalization_Proc 5346 (Subp_Id : Entity_Id) return Boolean 5347 is 5348 begin 5349 -- To qualify, the subprogram must denote a finalizer procedure 5350 -- or primitive [Deep_]Finalize, and the call must appear within 5351 -- an initialization context. 5352 5353 return 5354 (Is_Controlled_Proc (Subp_Id, Name_Finalize) 5355 or else Is_Finalizer_Proc (Subp_Id) 5356 or else Is_TSS (Subp_Id, TSS_Deep_Finalize)) 5357 and then In_Initialization_Context (Call); 5358 end Is_Partial_Finalization_Proc; 5359 5360 -- Local variables 5361 5362 Subp_Id : constant Entity_Id := Target (Call_Rep); 5363 Subp_Rep : constant Target_Rep_Id := 5364 Target_Representation_Of (Subp_Id, In_State); 5365 Subp_Decl : constant Node_Id := Spec_Declaration (Subp_Rep); 5366 5367 SPARK_Rules_On : constant Boolean := 5368 SPARK_Mode_Of (Call_Rep) = Is_On 5369 and then SPARK_Mode_Of (Subp_Rep) = Is_On; 5370 5371 New_In_State : Processing_In_State := In_State; 5372 -- Each step of the Processing phase constitutes a new state 5373 5374 -- Start of processing for Process_Conditional_ABE_Call 5375 5376 begin 5377 -- Output relevant information when switch -gnatel (info messages on 5378 -- implicit Elaborate[_All] pragmas) is in effect. 5379 5380 if Elab_Info_Messages 5381 and then not New_In_State.Suppress_Info_Messages 5382 then 5383 Info_Call 5384 (Call => Call, 5385 Subp_Id => Subp_Id, 5386 Info_Msg => True, 5387 In_SPARK => SPARK_Rules_On); 5388 end if; 5389 5390 -- Check whether the invocation of an entry clashes with an existing 5391 -- restriction. This check is relevant only when the processing was 5392 -- started from some library-level scenario. 5393 5394 if Is_Protected_Entry (Subp_Id) then 5395 Check_Restriction (No_Entry_Calls_In_Elaboration_Code, Call); 5396 5397 elsif Is_Task_Entry (Subp_Id) then 5398 Check_Restriction (No_Entry_Calls_In_Elaboration_Code, Call); 5399 5400 -- Task entry calls are never processed because the entry being 5401 -- invoked does not have a corresponding "body", it has a select. 5402 5403 return; 5404 end if; 5405 5406 -- Nothing to do when the call invokes a target defined within an 5407 -- instance and switch -gnatd_i (ignore activations and calls to 5408 -- instances for elaboration) is in effect. 5409 5410 if Debug_Flag_Underscore_I 5411 and then In_External_Instance 5412 (N => Call, 5413 Target_Decl => Subp_Decl) 5414 then 5415 return; 5416 5417 -- Nothing to do when the call is a guaranteed ABE 5418 5419 elsif Is_Known_Guaranteed_ABE (Call) then 5420 return; 5421 5422 -- Nothing to do when the root scenario appears at the declaration 5423 -- level and the target is in the same unit but outside this context. 5424 -- 5425 -- function B ...; -- target declaration 5426 -- 5427 -- procedure Proc is 5428 -- function A ... is 5429 -- begin 5430 -- if Some_Condition then 5431 -- return B; -- call site 5432 -- ... 5433 -- end A; 5434 -- 5435 -- X : ... := A; -- root scenario 5436 -- ... 5437 -- 5438 -- function B ... is 5439 -- ... 5440 -- end B; 5441 -- 5442 -- In the example above, the context of X is the declarative region 5443 -- of Proc. The "elaboration" of X may eventually reach B which is 5444 -- defined outside of X's context. B is relevant only when Proc is 5445 -- invoked, but this happens only by means of "normal" elaboration, 5446 -- therefore B must not be considered if this is not the case. 5447 5448 elsif Is_Up_Level_Target 5449 (Targ_Decl => Subp_Decl, 5450 In_State => New_In_State) 5451 then 5452 return; 5453 end if; 5454 5455 -- Warnings are suppressed when a prior scenario is already in that 5456 -- mode, or the call or target have warnings suppressed. Update the 5457 -- state of the Processing phase to reflect this. 5458 5459 New_In_State.Suppress_Warnings := 5460 New_In_State.Suppress_Warnings 5461 or else not Elaboration_Warnings_OK (Call_Rep) 5462 or else not Elaboration_Warnings_OK (Subp_Rep); 5463 5464 -- The call occurs in an initial condition context when a prior 5465 -- scenario is already in that mode, or when the target is an 5466 -- Initial_Condition procedure. Update the state of the Processing 5467 -- phase to reflect this. 5468 5469 New_In_State.Within_Initial_Condition := 5470 New_In_State.Within_Initial_Condition 5471 or else Is_Initial_Condition_Proc (Subp_Id); 5472 5473 -- The call occurs in a partial finalization context when a prior 5474 -- scenario is already in that mode, or when the target denotes a 5475 -- [Deep_]Finalize primitive or a finalizer within an initialization 5476 -- context. Update the state of the Processing phase to reflect this. 5477 5478 New_In_State.Within_Partial_Finalization := 5479 New_In_State.Within_Partial_Finalization 5480 or else Is_Partial_Finalization_Proc (Subp_Id); 5481 5482 -- The SPARK rules are in effect. Note that -gnatd.v (enforce SPARK 5483 -- elaboration rules in SPARK code) is intentionally not taken into 5484 -- account here because Process_Conditional_ABE_Call_SPARK has two 5485 -- separate modes of operation. 5486 5487 if SPARK_Rules_On then 5488 Process_Conditional_ABE_Call_SPARK 5489 (Call => Call, 5490 Call_Rep => Call_Rep, 5491 Subp_Id => Subp_Id, 5492 Subp_Rep => Subp_Rep, 5493 In_State => New_In_State); 5494 5495 -- Otherwise the Ada rules are in effect 5496 5497 else 5498 Process_Conditional_ABE_Call_Ada 5499 (Call => Call, 5500 Call_Rep => Call_Rep, 5501 Subp_Id => Subp_Id, 5502 Subp_Rep => Subp_Rep, 5503 In_State => New_In_State); 5504 end if; 5505 5506 -- Inspect the target body (and barried function) for other suitable 5507 -- elaboration scenarios. 5508 5509 Traverse_Conditional_ABE_Body 5510 (N => Barrier_Body_Declaration (Subp_Rep), 5511 In_State => New_In_State); 5512 5513 Traverse_Conditional_ABE_Body 5514 (N => Body_Declaration (Subp_Rep), 5515 In_State => New_In_State); 5516 end Process_Conditional_ABE_Call; 5517 5518 -------------------------------------- 5519 -- Process_Conditional_ABE_Call_Ada -- 5520 -------------------------------------- 5521 5522 procedure Process_Conditional_ABE_Call_Ada 5523 (Call : Node_Id; 5524 Call_Rep : Scenario_Rep_Id; 5525 Subp_Id : Entity_Id; 5526 Subp_Rep : Target_Rep_Id; 5527 In_State : Processing_In_State) 5528 is 5529 Body_Decl : constant Node_Id := Body_Declaration (Subp_Rep); 5530 Root : constant Node_Id := Root_Scenario; 5531 Unit_Id : constant Node_Id := Unit (Subp_Rep); 5532 5533 Check_OK : constant Boolean := 5534 not In_State.Suppress_Checks 5535 and then Ghost_Mode_Of (Call_Rep) /= Is_Ignored 5536 and then Ghost_Mode_Of (Subp_Rep) /= Is_Ignored 5537 and then Elaboration_Checks_OK (Call_Rep) 5538 and then Elaboration_Checks_OK (Subp_Rep); 5539 -- A run-time ABE check may be installed only when both the call 5540 -- and the target have active elaboration checks, and both are not 5541 -- ignored Ghost constructs. 5542 5543 New_In_State : Processing_In_State := In_State; 5544 -- Each step of the Processing phase constitutes a new state 5545 5546 begin 5547 -- Nothing to do for an Ada dispatching call because there are no 5548 -- ABE diagnostics for either models. ABE checks for the dynamic 5549 -- model are handled by Install_Primitive_Elaboration_Check. 5550 5551 if Is_Dispatching_Call (Call_Rep) then 5552 return; 5553 5554 -- Nothing to do when the call is ABE-safe 5555 -- 5556 -- generic 5557 -- function Gen ...; 5558 -- 5559 -- function Gen ... is 5560 -- begin 5561 -- ... 5562 -- end Gen; 5563 -- 5564 -- with Gen; 5565 -- procedure Main is 5566 -- function Inst is new Gen; 5567 -- X : ... := Inst; -- safe call 5568 -- ... 5569 5570 elsif Is_Safe_Call (Call, Subp_Id, Subp_Rep) then 5571 return; 5572 5573 -- The call and the target body are both in the main unit 5574 -- 5575 -- If the root scenario appears prior to the target body, then this 5576 -- is a possible ABE with respect to the root scenario. 5577 -- 5578 -- function B ...; 5579 -- 5580 -- function A ... is 5581 -- begin 5582 -- if Some_Condition then 5583 -- return B; -- call site 5584 -- ... 5585 -- end A; 5586 -- 5587 -- X : ... := A; -- root scenario 5588 -- 5589 -- function B ... is -- target body 5590 -- ... 5591 -- end B; 5592 -- 5593 -- Y : ... := A; -- root scenario 5594 -- 5595 -- IMPORTANT: The call to B from A is a possible ABE for X, but 5596 -- not for Y. Installing an unconditional ABE raise prior to the 5597 -- call to B would be wrong as it will fail for Y as well, but in 5598 -- Y's case the call to B is never an ABE. 5599 5600 elsif Present (Body_Decl) 5601 and then In_Extended_Main_Code_Unit (Body_Decl) 5602 then 5603 if Earlier_In_Extended_Unit (Root, Body_Decl) then 5604 5605 -- Do not emit any ABE diagnostics when a previous scenario in 5606 -- this traversal has suppressed elaboration warnings. 5607 5608 if New_In_State.Suppress_Warnings then 5609 null; 5610 5611 -- Do not emit any ABE diagnostics when the call occurs in a 5612 -- partial finalization context because this leads to confusing 5613 -- noise. 5614 5615 elsif New_In_State.Within_Partial_Finalization then 5616 null; 5617 5618 -- Otherwise emit the ABE diagnostic 5619 5620 else 5621 Error_Msg_NE 5622 ("??cannot call & before body seen", Call, Subp_Id); 5623 Error_Msg_N 5624 ("\Program_Error may be raised at run time", Call); 5625 5626 Output_Active_Scenarios (Call, New_In_State); 5627 end if; 5628 5629 -- Install a conditional run-time ABE check to verify that the 5630 -- target body has been elaborated prior to the call. 5631 5632 if Check_OK then 5633 Install_Scenario_ABE_Check 5634 (N => Call, 5635 Targ_Id => Subp_Id, 5636 Targ_Rep => Subp_Rep, 5637 Disable => Call_Rep); 5638 5639 -- Update the state of the Processing phase to indicate that 5640 -- no implicit Elaborate[_All] pragma must be generated from 5641 -- this point on. 5642 -- 5643 -- function B ...; 5644 -- 5645 -- function A ... is 5646 -- begin 5647 -- if Some_Condition then 5648 -- <ABE check> 5649 -- return B; 5650 -- ... 5651 -- end A; 5652 -- 5653 -- X : ... := A; 5654 -- 5655 -- function B ... is 5656 -- External.Subp; -- imparts Elaborate_All 5657 -- end B; 5658 -- 5659 -- If Some_Condition is True, then the ABE check will fail 5660 -- at runtime and the call to External.Subp will never take 5661 -- place, rendering the implicit Elaborate_All useless. 5662 -- 5663 -- If the value of Some_Condition is False, then the call 5664 -- to External.Subp will never take place, rendering the 5665 -- implicit Elaborate_All useless. 5666 5667 New_In_State.Suppress_Implicit_Pragmas := True; 5668 end if; 5669 end if; 5670 5671 -- Otherwise the target body is not available in this compilation or 5672 -- it resides in an external unit. Install a run-time ABE check to 5673 -- verify that the target body has been elaborated prior to the call 5674 -- site when the dynamic model is in effect. 5675 5676 elsif Check_OK 5677 and then New_In_State.Processing = Dynamic_Model_Processing 5678 then 5679 Install_Unit_ABE_Check 5680 (N => Call, 5681 Unit_Id => Unit_Id, 5682 Disable => Call_Rep); 5683 end if; 5684 5685 -- Ensure that the unit with the target body is elaborated prior to 5686 -- the main unit. The implicit Elaborate[_All] is generated only when 5687 -- the call has elaboration checks enabled. This behaviour parallels 5688 -- that of the old ABE mechanism. 5689 5690 if Elaboration_Checks_OK (Call_Rep) then 5691 Ensure_Prior_Elaboration 5692 (N => Call, 5693 Unit_Id => Unit_Id, 5694 Prag_Nam => Name_Elaborate_All, 5695 In_State => New_In_State); 5696 end if; 5697 end Process_Conditional_ABE_Call_Ada; 5698 5699 ---------------------------------------- 5700 -- Process_Conditional_ABE_Call_SPARK -- 5701 ---------------------------------------- 5702 5703 procedure Process_Conditional_ABE_Call_SPARK 5704 (Call : Node_Id; 5705 Call_Rep : Scenario_Rep_Id; 5706 Subp_Id : Entity_Id; 5707 Subp_Rep : Target_Rep_Id; 5708 In_State : Processing_In_State) 5709 is 5710 pragma Unreferenced (Call_Rep); 5711 5712 Body_Decl : constant Node_Id := Body_Declaration (Subp_Rep); 5713 Region : Node_Id; 5714 5715 begin 5716 -- Ensure that a suitable elaboration model is in effect for SPARK 5717 -- rule verification. 5718 5719 Check_SPARK_Model_In_Effect; 5720 5721 -- The call and the target body are both in the main unit 5722 5723 if Present (Body_Decl) 5724 and then In_Extended_Main_Code_Unit (Body_Decl) 5725 and then Earlier_In_Extended_Unit (Call, Body_Decl) 5726 then 5727 -- Do not emit any ABE diagnostics when a previous scenario in 5728 -- this traversal has suppressed elaboration warnings. 5729 5730 if In_State.Suppress_Warnings then 5731 null; 5732 5733 -- Do not emit any ABE diagnostics when the call occurs in an 5734 -- initial condition context because this leads to incorrect 5735 -- diagnostics. 5736 5737 elsif In_State.Within_Initial_Condition then 5738 null; 5739 5740 -- Do not emit any ABE diagnostics when the call occurs in a 5741 -- partial finalization context because this leads to confusing 5742 -- noise. 5743 5744 elsif In_State.Within_Partial_Finalization then 5745 null; 5746 5747 -- Ensure that a call that textually precedes the subprogram body 5748 -- it invokes appears within the early call region of the body. 5749 -- 5750 -- IMPORTANT: This check must always be performed even when switch 5751 -- -gnatd.v (enforce SPARK elaboration rules in SPARK code) is not 5752 -- specified because the static model cannot guarantee the absence 5753 -- of elaboration issues when dispatching calls are involved. 5754 5755 else 5756 Region := Find_Early_Call_Region (Body_Decl); 5757 5758 if Earlier_In_Extended_Unit (Call, Region) then 5759 Error_Msg_NE 5760 ("call must appear within early call region of subprogram " 5761 & "body & (SPARK RM 7.7(3))", 5762 Call, Subp_Id); 5763 5764 Error_Msg_Sloc := Sloc (Region); 5765 Error_Msg_N ("\region starts #", Call); 5766 5767 Error_Msg_Sloc := Sloc (Body_Decl); 5768 Error_Msg_N ("\region ends #", Call); 5769 5770 Output_Active_Scenarios (Call, In_State); 5771 end if; 5772 end if; 5773 end if; 5774 5775 -- A call to a source target or to a target which emulates Ada 5776 -- or SPARK semantics imposes an Elaborate_All requirement on the 5777 -- context of the main unit. Determine whether the context has a 5778 -- pragma strong enough to meet the requirement. 5779 -- 5780 -- IMPORTANT: This check must be performed only when switch -gnatd.v 5781 -- (enforce SPARK elaboration rules in SPARK code) is active because 5782 -- the static model can ensure the prior elaboration of the unit 5783 -- which contains a body by installing an implicit Elaborate[_All] 5784 -- pragma. 5785 5786 if Debug_Flag_Dot_V then 5787 if Comes_From_Source (Subp_Id) 5788 or else Is_Ada_Semantic_Target (Subp_Id) 5789 or else Is_SPARK_Semantic_Target (Subp_Id) 5790 then 5791 Meet_Elaboration_Requirement 5792 (N => Call, 5793 Targ_Id => Subp_Id, 5794 Req_Nam => Name_Elaborate_All, 5795 In_State => In_State); 5796 end if; 5797 5798 -- Otherwise ensure that the unit with the target body is elaborated 5799 -- prior to the main unit. 5800 5801 else 5802 Ensure_Prior_Elaboration 5803 (N => Call, 5804 Unit_Id => Unit (Subp_Rep), 5805 Prag_Nam => Name_Elaborate_All, 5806 In_State => In_State); 5807 end if; 5808 end Process_Conditional_ABE_Call_SPARK; 5809 5810 ------------------------------------------- 5811 -- Process_Conditional_ABE_Instantiation -- 5812 ------------------------------------------- 5813 5814 procedure Process_Conditional_ABE_Instantiation 5815 (Inst : Node_Id; 5816 Inst_Rep : Scenario_Rep_Id; 5817 In_State : Processing_In_State) 5818 is 5819 Gen_Id : constant Entity_Id := Target (Inst_Rep); 5820 Gen_Rep : constant Target_Rep_Id := 5821 Target_Representation_Of (Gen_Id, In_State); 5822 5823 SPARK_Rules_On : constant Boolean := 5824 SPARK_Mode_Of (Inst_Rep) = Is_On 5825 and then SPARK_Mode_Of (Gen_Rep) = Is_On; 5826 5827 New_In_State : Processing_In_State := In_State; 5828 -- Each step of the Processing phase constitutes a new state 5829 5830 begin 5831 -- Output relevant information when switch -gnatel (info messages on 5832 -- implicit Elaborate[_All] pragmas) is in effect. 5833 5834 if Elab_Info_Messages 5835 and then not New_In_State.Suppress_Info_Messages 5836 then 5837 Info_Instantiation 5838 (Inst => Inst, 5839 Gen_Id => Gen_Id, 5840 Info_Msg => True, 5841 In_SPARK => SPARK_Rules_On); 5842 end if; 5843 5844 -- Nothing to do when the instantiation is a guaranteed ABE 5845 5846 if Is_Known_Guaranteed_ABE (Inst) then 5847 return; 5848 5849 -- Nothing to do when the root scenario appears at the declaration 5850 -- level and the generic is in the same unit, but outside this 5851 -- context. 5852 -- 5853 -- generic 5854 -- procedure Gen is ...; -- generic declaration 5855 -- 5856 -- procedure Proc is 5857 -- function A ... is 5858 -- begin 5859 -- if Some_Condition then 5860 -- declare 5861 -- procedure I is new Gen; -- instantiation site 5862 -- ... 5863 -- ... 5864 -- end A; 5865 -- 5866 -- X : ... := A; -- root scenario 5867 -- ... 5868 -- 5869 -- procedure Gen is 5870 -- ... 5871 -- end Gen; 5872 -- 5873 -- In the example above, the context of X is the declarative region 5874 -- of Proc. The "elaboration" of X may eventually reach Gen which 5875 -- appears outside of X's context. Gen is relevant only when Proc is 5876 -- invoked, but this happens only by means of "normal" elaboration, 5877 -- therefore Gen must not be considered if this is not the case. 5878 5879 elsif Is_Up_Level_Target 5880 (Targ_Decl => Spec_Declaration (Gen_Rep), 5881 In_State => New_In_State) 5882 then 5883 return; 5884 end if; 5885 5886 -- Warnings are suppressed when a prior scenario is already in that 5887 -- mode, or when the instantiation has warnings suppressed. Update 5888 -- the state of the processing phase to reflect this. 5889 5890 New_In_State.Suppress_Warnings := 5891 New_In_State.Suppress_Warnings 5892 or else not Elaboration_Warnings_OK (Inst_Rep); 5893 5894 -- The SPARK rules are in effect 5895 5896 if SPARK_Rules_On then 5897 Process_Conditional_ABE_Instantiation_SPARK 5898 (Inst => Inst, 5899 Inst_Rep => Inst_Rep, 5900 Gen_Id => Gen_Id, 5901 Gen_Rep => Gen_Rep, 5902 In_State => New_In_State); 5903 5904 -- Otherwise the Ada rules are in effect, or SPARK code is allowed to 5905 -- violate the SPARK rules. 5906 5907 else 5908 Process_Conditional_ABE_Instantiation_Ada 5909 (Inst => Inst, 5910 Inst_Rep => Inst_Rep, 5911 Gen_Id => Gen_Id, 5912 Gen_Rep => Gen_Rep, 5913 In_State => New_In_State); 5914 end if; 5915 end Process_Conditional_ABE_Instantiation; 5916 5917 ----------------------------------------------- 5918 -- Process_Conditional_ABE_Instantiation_Ada -- 5919 ----------------------------------------------- 5920 5921 procedure Process_Conditional_ABE_Instantiation_Ada 5922 (Inst : Node_Id; 5923 Inst_Rep : Scenario_Rep_Id; 5924 Gen_Id : Entity_Id; 5925 Gen_Rep : Target_Rep_Id; 5926 In_State : Processing_In_State) 5927 is 5928 Body_Decl : constant Node_Id := Body_Declaration (Gen_Rep); 5929 Root : constant Node_Id := Root_Scenario; 5930 Unit_Id : constant Entity_Id := Unit (Gen_Rep); 5931 5932 Check_OK : constant Boolean := 5933 not In_State.Suppress_Checks 5934 and then Ghost_Mode_Of (Inst_Rep) /= Is_Ignored 5935 and then Ghost_Mode_Of (Gen_Rep) /= Is_Ignored 5936 and then Elaboration_Checks_OK (Inst_Rep) 5937 and then Elaboration_Checks_OK (Gen_Rep); 5938 -- A run-time ABE check may be installed only when both the instance 5939 -- and the generic have active elaboration checks and both are not 5940 -- ignored Ghost constructs. 5941 5942 New_In_State : Processing_In_State := In_State; 5943 -- Each step of the Processing phase constitutes a new state 5944 5945 begin 5946 -- Nothing to do when the instantiation is ABE-safe 5947 -- 5948 -- generic 5949 -- package Gen is 5950 -- ... 5951 -- end Gen; 5952 -- 5953 -- package body Gen is 5954 -- ... 5955 -- end Gen; 5956 -- 5957 -- with Gen; 5958 -- procedure Main is 5959 -- package Inst is new Gen (ABE); -- safe instantiation 5960 -- ... 5961 5962 if Is_Safe_Instantiation (Inst, Gen_Id, Gen_Rep) then 5963 return; 5964 5965 -- The instantiation and the generic body are both in the main unit 5966 -- 5967 -- If the root scenario appears prior to the generic body, then this 5968 -- is a possible ABE with respect to the root scenario. 5969 -- 5970 -- generic 5971 -- package Gen is 5972 -- ... 5973 -- end Gen; 5974 -- 5975 -- function A ... is 5976 -- begin 5977 -- if Some_Condition then 5978 -- declare 5979 -- package Inst is new Gen; -- instantiation site 5980 -- ... 5981 -- end A; 5982 -- 5983 -- X : ... := A; -- root scenario 5984 -- 5985 -- package body Gen is -- generic body 5986 -- ... 5987 -- end Gen; 5988 -- 5989 -- Y : ... := A; -- root scenario 5990 -- 5991 -- IMPORTANT: The instantiation of Gen is a possible ABE for X, 5992 -- but not for Y. Installing an unconditional ABE raise prior to 5993 -- the instance site would be wrong as it will fail for Y as well, 5994 -- but in Y's case the instantiation of Gen is never an ABE. 5995 5996 elsif Present (Body_Decl) 5997 and then In_Extended_Main_Code_Unit (Body_Decl) 5998 then 5999 if Earlier_In_Extended_Unit (Root, Body_Decl) then 6000 6001 -- Do not emit any ABE diagnostics when a previous scenario in 6002 -- this traversal has suppressed elaboration warnings. 6003 6004 if New_In_State.Suppress_Warnings then 6005 null; 6006 6007 -- Do not emit any ABE diagnostics when the instantiation 6008 -- occurs in partial finalization context because this leads 6009 -- to unwanted noise. 6010 6011 elsif New_In_State.Within_Partial_Finalization then 6012 null; 6013 6014 -- Otherwise output the diagnostic 6015 6016 else 6017 Error_Msg_NE 6018 ("??cannot instantiate & before body seen", Inst, Gen_Id); 6019 Error_Msg_N 6020 ("\Program_Error may be raised at run time", Inst); 6021 6022 Output_Active_Scenarios (Inst, New_In_State); 6023 end if; 6024 6025 -- Install a conditional run-time ABE check to verify that the 6026 -- generic body has been elaborated prior to the instantiation. 6027 6028 if Check_OK then 6029 Install_Scenario_ABE_Check 6030 (N => Inst, 6031 Targ_Id => Gen_Id, 6032 Targ_Rep => Gen_Rep, 6033 Disable => Inst_Rep); 6034 6035 -- Update the state of the Processing phase to indicate that 6036 -- no implicit Elaborate[_All] pragma must be generated from 6037 -- this point on. 6038 -- 6039 -- generic 6040 -- package Gen is 6041 -- ... 6042 -- end Gen; 6043 -- 6044 -- function A ... is 6045 -- begin 6046 -- if Some_Condition then 6047 -- <ABE check> 6048 -- declare Inst is new Gen; 6049 -- ... 6050 -- end A; 6051 -- 6052 -- X : ... := A; 6053 -- 6054 -- package body Gen is 6055 -- begin 6056 -- External.Subp; -- imparts Elaborate_All 6057 -- end Gen; 6058 -- 6059 -- If Some_Condition is True, then the ABE check will fail 6060 -- at runtime and the call to External.Subp will never take 6061 -- place, rendering the implicit Elaborate_All useless. 6062 -- 6063 -- If the value of Some_Condition is False, then the call 6064 -- to External.Subp will never take place, rendering the 6065 -- implicit Elaborate_All useless. 6066 6067 New_In_State.Suppress_Implicit_Pragmas := True; 6068 end if; 6069 end if; 6070 6071 -- Otherwise the generic body is not available in this compilation 6072 -- or it resides in an external unit. Install a run-time ABE check 6073 -- to verify that the generic body has been elaborated prior to the 6074 -- instantiation when the dynamic model is in effect. 6075 6076 elsif Check_OK 6077 and then New_In_State.Processing = Dynamic_Model_Processing 6078 then 6079 Install_Unit_ABE_Check 6080 (N => Inst, 6081 Unit_Id => Unit_Id, 6082 Disable => Inst_Rep); 6083 end if; 6084 6085 -- Ensure that the unit with the generic body is elaborated prior 6086 -- to the main unit. No implicit pragma has to be generated if the 6087 -- instantiation has elaboration checks suppressed. This behaviour 6088 -- parallels that of the old ABE mechanism. 6089 6090 if Elaboration_Checks_OK (Inst_Rep) then 6091 Ensure_Prior_Elaboration 6092 (N => Inst, 6093 Unit_Id => Unit_Id, 6094 Prag_Nam => Name_Elaborate, 6095 In_State => New_In_State); 6096 end if; 6097 end Process_Conditional_ABE_Instantiation_Ada; 6098 6099 ------------------------------------------------- 6100 -- Process_Conditional_ABE_Instantiation_SPARK -- 6101 ------------------------------------------------- 6102 6103 procedure Process_Conditional_ABE_Instantiation_SPARK 6104 (Inst : Node_Id; 6105 Inst_Rep : Scenario_Rep_Id; 6106 Gen_Id : Entity_Id; 6107 Gen_Rep : Target_Rep_Id; 6108 In_State : Processing_In_State) 6109 is 6110 pragma Unreferenced (Inst_Rep); 6111 6112 Req_Nam : Name_Id; 6113 6114 begin 6115 -- Ensure that a suitable elaboration model is in effect for SPARK 6116 -- rule verification. 6117 6118 Check_SPARK_Model_In_Effect; 6119 6120 -- A source instantiation imposes an Elaborate[_All] requirement 6121 -- on the context of the main unit. Determine whether the context 6122 -- has a pragma strong enough to meet the requirement. The check 6123 -- is orthogonal to the ABE ramifications of the instantiation. 6124 -- 6125 -- IMPORTANT: This check must be performed only when switch -gnatd.v 6126 -- (enforce SPARK elaboration rules in SPARK code) is active because 6127 -- the static model can ensure the prior elaboration of the unit 6128 -- which contains a body by installing an implicit Elaborate[_All] 6129 -- pragma. 6130 6131 if Debug_Flag_Dot_V then 6132 if Nkind (Inst) = N_Package_Instantiation then 6133 Req_Nam := Name_Elaborate_All; 6134 else 6135 Req_Nam := Name_Elaborate; 6136 end if; 6137 6138 Meet_Elaboration_Requirement 6139 (N => Inst, 6140 Targ_Id => Gen_Id, 6141 Req_Nam => Req_Nam, 6142 In_State => In_State); 6143 6144 -- Otherwise ensure that the unit with the target body is elaborated 6145 -- prior to the main unit. 6146 6147 else 6148 Ensure_Prior_Elaboration 6149 (N => Inst, 6150 Unit_Id => Unit (Gen_Rep), 6151 Prag_Nam => Name_Elaborate, 6152 In_State => In_State); 6153 end if; 6154 end Process_Conditional_ABE_Instantiation_SPARK; 6155 6156 ------------------------------------------------- 6157 -- Process_Conditional_ABE_Variable_Assignment -- 6158 ------------------------------------------------- 6159 6160 procedure Process_Conditional_ABE_Variable_Assignment 6161 (Asmt : Node_Id; 6162 Asmt_Rep : Scenario_Rep_Id; 6163 In_State : Processing_In_State) 6164 is 6165 6166 Var_Id : constant Entity_Id := Target (Asmt_Rep); 6167 Var_Rep : constant Target_Rep_Id := 6168 Target_Representation_Of (Var_Id, In_State); 6169 6170 SPARK_Rules_On : constant Boolean := 6171 SPARK_Mode_Of (Asmt_Rep) = Is_On 6172 and then SPARK_Mode_Of (Var_Rep) = Is_On; 6173 6174 begin 6175 -- Output relevant information when switch -gnatel (info messages on 6176 -- implicit Elaborate[_All] pragmas) is in effect. 6177 6178 if Elab_Info_Messages 6179 and then not In_State.Suppress_Info_Messages 6180 then 6181 Elab_Msg_NE 6182 (Msg => "assignment to & during elaboration", 6183 N => Asmt, 6184 Id => Var_Id, 6185 Info_Msg => True, 6186 In_SPARK => SPARK_Rules_On); 6187 end if; 6188 6189 -- The SPARK rules are in effect. These rules are applied regardless 6190 -- of whether switch -gnatd.v (enforce SPARK elaboration rules in 6191 -- SPARK code) is in effect because the static model cannot ensure 6192 -- safe assignment of variables. 6193 6194 if SPARK_Rules_On then 6195 Process_Conditional_ABE_Variable_Assignment_SPARK 6196 (Asmt => Asmt, 6197 Asmt_Rep => Asmt_Rep, 6198 Var_Id => Var_Id, 6199 Var_Rep => Var_Rep, 6200 In_State => In_State); 6201 6202 -- Otherwise the Ada rules are in effect 6203 6204 else 6205 Process_Conditional_ABE_Variable_Assignment_Ada 6206 (Asmt => Asmt, 6207 Asmt_Rep => Asmt_Rep, 6208 Var_Id => Var_Id, 6209 Var_Rep => Var_Rep, 6210 In_State => In_State); 6211 end if; 6212 end Process_Conditional_ABE_Variable_Assignment; 6213 6214 ----------------------------------------------------- 6215 -- Process_Conditional_ABE_Variable_Assignment_Ada -- 6216 ----------------------------------------------------- 6217 6218 procedure Process_Conditional_ABE_Variable_Assignment_Ada 6219 (Asmt : Node_Id; 6220 Asmt_Rep : Scenario_Rep_Id; 6221 Var_Id : Entity_Id; 6222 Var_Rep : Target_Rep_Id; 6223 In_State : Processing_In_State) 6224 is 6225 pragma Unreferenced (Asmt_Rep); 6226 6227 Var_Decl : constant Node_Id := Variable_Declaration (Var_Rep); 6228 Unit_Id : constant Entity_Id := Unit (Var_Rep); 6229 6230 begin 6231 -- Emit a warning when an uninitialized variable declared in a 6232 -- package spec without a pragma Elaborate_Body is initialized 6233 -- by elaboration code within the corresponding body. 6234 6235 if Is_Elaboration_Warnings_OK_Id (Var_Id) 6236 and then not Is_Initialized (Var_Decl) 6237 and then not Has_Pragma_Elaborate_Body (Unit_Id) 6238 then 6239 -- Do not emit any ABE diagnostics when a previous scenario in 6240 -- this traversal has suppressed elaboration warnings. 6241 6242 if not In_State.Suppress_Warnings then 6243 Error_Msg_NE 6244 ("??variable & can be accessed by clients before this " 6245 & "initialization", Asmt, Var_Id); 6246 6247 Error_Msg_NE 6248 ("\add pragma ""Elaborate_Body"" to spec & to ensure proper " 6249 & "initialization", Asmt, Unit_Id); 6250 6251 Output_Active_Scenarios (Asmt, In_State); 6252 end if; 6253 6254 -- Generate an implicit Elaborate_Body in the spec 6255 6256 Set_Elaborate_Body_Desirable (Unit_Id); 6257 end if; 6258 end Process_Conditional_ABE_Variable_Assignment_Ada; 6259 6260 ------------------------------------------------------- 6261 -- Process_Conditional_ABE_Variable_Assignment_SPARK -- 6262 ------------------------------------------------------- 6263 6264 procedure Process_Conditional_ABE_Variable_Assignment_SPARK 6265 (Asmt : Node_Id; 6266 Asmt_Rep : Scenario_Rep_Id; 6267 Var_Id : Entity_Id; 6268 Var_Rep : Target_Rep_Id; 6269 In_State : Processing_In_State) 6270 is 6271 pragma Unreferenced (Asmt_Rep); 6272 6273 Var_Decl : constant Node_Id := Variable_Declaration (Var_Rep); 6274 Unit_Id : constant Entity_Id := Unit (Var_Rep); 6275 6276 begin 6277 -- Ensure that a suitable elaboration model is in effect for SPARK 6278 -- rule verification. 6279 6280 Check_SPARK_Model_In_Effect; 6281 6282 -- Do not emit any ABE diagnostics when a previous scenario in this 6283 -- traversal has suppressed elaboration warnings. 6284 6285 if In_State.Suppress_Warnings then 6286 null; 6287 6288 -- Emit an error when an initialized variable declared in a package 6289 -- spec that is missing pragma Elaborate_Body is further modified by 6290 -- elaboration code within the corresponding body. 6291 6292 elsif Is_Elaboration_Warnings_OK_Id (Var_Id) 6293 and then Is_Initialized (Var_Decl) 6294 and then not Has_Pragma_Elaborate_Body (Unit_Id) 6295 then 6296 Error_Msg_NE 6297 ("variable & modified by elaboration code in package body", 6298 Asmt, Var_Id); 6299 6300 Error_Msg_NE 6301 ("\add pragma ""Elaborate_Body"" to spec & to ensure full " 6302 & "initialization", Asmt, Unit_Id); 6303 6304 Output_Active_Scenarios (Asmt, In_State); 6305 end if; 6306 end Process_Conditional_ABE_Variable_Assignment_SPARK; 6307 6308 ------------------------------------------------ 6309 -- Process_Conditional_ABE_Variable_Reference -- 6310 ------------------------------------------------ 6311 6312 procedure Process_Conditional_ABE_Variable_Reference 6313 (Ref : Node_Id; 6314 Ref_Rep : Scenario_Rep_Id; 6315 In_State : Processing_In_State) 6316 is 6317 Var_Id : constant Entity_Id := Target (Ref); 6318 Var_Rep : Target_Rep_Id; 6319 Unit_Id : Entity_Id; 6320 6321 begin 6322 -- Nothing to do when the variable reference is not a read 6323 6324 if not Is_Read_Reference (Ref_Rep) then 6325 return; 6326 end if; 6327 6328 Var_Rep := Target_Representation_Of (Var_Id, In_State); 6329 Unit_Id := Unit (Var_Rep); 6330 6331 -- Output relevant information when switch -gnatel (info messages on 6332 -- implicit Elaborate[_All] pragmas) is in effect. 6333 6334 if Elab_Info_Messages 6335 and then not In_State.Suppress_Info_Messages 6336 then 6337 Elab_Msg_NE 6338 (Msg => "read of variable & during elaboration", 6339 N => Ref, 6340 Id => Var_Id, 6341 Info_Msg => True, 6342 In_SPARK => True); 6343 end if; 6344 6345 -- Nothing to do when the variable appears within the main unit 6346 -- because diagnostics on reads are relevant only for external 6347 -- variables. 6348 6349 if Is_Same_Unit (Unit_Id, Main_Unit_Entity) then 6350 null; 6351 6352 -- Nothing to do when the variable is already initialized. Note that 6353 -- the variable may be further modified by the external unit. 6354 6355 elsif Is_Initialized (Variable_Declaration (Var_Rep)) then 6356 null; 6357 6358 -- Nothing to do when the external unit guarantees the initialization 6359 -- of the variable by means of pragma Elaborate_Body. 6360 6361 elsif Has_Pragma_Elaborate_Body (Unit_Id) then 6362 null; 6363 6364 -- A variable read imposes an Elaborate requirement on the context of 6365 -- the main unit. Determine whether the context has a pragma strong 6366 -- enough to meet the requirement. 6367 6368 else 6369 Meet_Elaboration_Requirement 6370 (N => Ref, 6371 Targ_Id => Var_Id, 6372 Req_Nam => Name_Elaborate, 6373 In_State => In_State); 6374 end if; 6375 end Process_Conditional_ABE_Variable_Reference; 6376 6377 ----------------------------------- 6378 -- Traverse_Conditional_ABE_Body -- 6379 ----------------------------------- 6380 6381 procedure Traverse_Conditional_ABE_Body 6382 (N : Node_Id; 6383 In_State : Processing_In_State) 6384 is 6385 begin 6386 Traverse_Body 6387 (N => N, 6388 Requires_Processing => Is_Conditional_ABE_Scenario'Access, 6389 Processor => Process_Conditional_ABE'Access, 6390 In_State => In_State); 6391 end Traverse_Conditional_ABE_Body; 6392 end Conditional_ABE_Processor; 6393 6394 ------------- 6395 -- Destroy -- 6396 ------------- 6397 6398 procedure Destroy (NE : in out Node_Or_Entity_Id) is 6399 pragma Unreferenced (NE); 6400 begin 6401 null; 6402 end Destroy; 6403 6404 ----------------- 6405 -- Diagnostics -- 6406 ----------------- 6407 6408 package body Diagnostics is 6409 6410 ----------------- 6411 -- Elab_Msg_NE -- 6412 ----------------- 6413 6414 procedure Elab_Msg_NE 6415 (Msg : String; 6416 N : Node_Id; 6417 Id : Entity_Id; 6418 Info_Msg : Boolean; 6419 In_SPARK : Boolean) 6420 is 6421 function Prefix return String; 6422 pragma Inline (Prefix); 6423 -- Obtain the prefix of the message 6424 6425 function Suffix return String; 6426 pragma Inline (Suffix); 6427 -- Obtain the suffix of the message 6428 6429 ------------ 6430 -- Prefix -- 6431 ------------ 6432 6433 function Prefix return String is 6434 begin 6435 if Info_Msg then 6436 return "info: "; 6437 else 6438 return ""; 6439 end if; 6440 end Prefix; 6441 6442 ------------ 6443 -- Suffix -- 6444 ------------ 6445 6446 function Suffix return String is 6447 begin 6448 if In_SPARK then 6449 return " in SPARK"; 6450 else 6451 return ""; 6452 end if; 6453 end Suffix; 6454 6455 -- Start of processing for Elab_Msg_NE 6456 6457 begin 6458 Error_Msg_NE (Prefix & Msg & Suffix, N, Id); 6459 end Elab_Msg_NE; 6460 6461 --------------- 6462 -- Info_Call -- 6463 --------------- 6464 6465 procedure Info_Call 6466 (Call : Node_Id; 6467 Subp_Id : Entity_Id; 6468 Info_Msg : Boolean; 6469 In_SPARK : Boolean) 6470 is 6471 procedure Info_Accept_Alternative; 6472 pragma Inline (Info_Accept_Alternative); 6473 -- Output information concerning an accept alternative 6474 6475 procedure Info_Simple_Call; 6476 pragma Inline (Info_Simple_Call); 6477 -- Output information concerning the call 6478 6479 procedure Info_Type_Actions (Action : String); 6480 pragma Inline (Info_Type_Actions); 6481 -- Output information concerning action Action of a type 6482 6483 procedure Info_Verification_Call 6484 (Pred : String; 6485 Id : Entity_Id; 6486 Id_Kind : String); 6487 pragma Inline (Info_Verification_Call); 6488 -- Output information concerning the verification of predicate Pred 6489 -- applied to related entity Id with kind Id_Kind. 6490 6491 ----------------------------- 6492 -- Info_Accept_Alternative -- 6493 ----------------------------- 6494 6495 procedure Info_Accept_Alternative is 6496 Entry_Id : constant Entity_Id := Receiving_Entry (Subp_Id); 6497 pragma Assert (Present (Entry_Id)); 6498 6499 begin 6500 Elab_Msg_NE 6501 (Msg => "accept for entry & during elaboration", 6502 N => Call, 6503 Id => Entry_Id, 6504 Info_Msg => Info_Msg, 6505 In_SPARK => In_SPARK); 6506 end Info_Accept_Alternative; 6507 6508 ---------------------- 6509 -- Info_Simple_Call -- 6510 ---------------------- 6511 6512 procedure Info_Simple_Call is 6513 begin 6514 Elab_Msg_NE 6515 (Msg => "call to & during elaboration", 6516 N => Call, 6517 Id => Subp_Id, 6518 Info_Msg => Info_Msg, 6519 In_SPARK => In_SPARK); 6520 end Info_Simple_Call; 6521 6522 ----------------------- 6523 -- Info_Type_Actions -- 6524 ----------------------- 6525 6526 procedure Info_Type_Actions (Action : String) is 6527 Typ : constant Entity_Id := First_Formal_Type (Subp_Id); 6528 pragma Assert (Present (Typ)); 6529 6530 begin 6531 Elab_Msg_NE 6532 (Msg => Action & " actions for type & during elaboration", 6533 N => Call, 6534 Id => Typ, 6535 Info_Msg => Info_Msg, 6536 In_SPARK => In_SPARK); 6537 end Info_Type_Actions; 6538 6539 ---------------------------- 6540 -- Info_Verification_Call -- 6541 ---------------------------- 6542 6543 procedure Info_Verification_Call 6544 (Pred : String; 6545 Id : Entity_Id; 6546 Id_Kind : String) 6547 is 6548 pragma Assert (Present (Id)); 6549 6550 begin 6551 Elab_Msg_NE 6552 (Msg => 6553 "verification of " & Pred & " of " & Id_Kind & " & during " 6554 & "elaboration", 6555 N => Call, 6556 Id => Id, 6557 Info_Msg => Info_Msg, 6558 In_SPARK => In_SPARK); 6559 end Info_Verification_Call; 6560 6561 -- Start of processing for Info_Call 6562 6563 begin 6564 -- Do not output anything for targets defined in internal units 6565 -- because this creates noise. 6566 6567 if not In_Internal_Unit (Subp_Id) then 6568 6569 -- Accept alternative 6570 6571 if Is_Accept_Alternative_Proc (Subp_Id) then 6572 Info_Accept_Alternative; 6573 6574 -- Adjustment 6575 6576 elsif Is_TSS (Subp_Id, TSS_Deep_Adjust) then 6577 Info_Type_Actions ("adjustment"); 6578 6579 -- Default_Initial_Condition 6580 6581 elsif Is_Default_Initial_Condition_Proc (Subp_Id) then 6582 Info_Verification_Call 6583 (Pred => "Default_Initial_Condition", 6584 Id => First_Formal_Type (Subp_Id), 6585 Id_Kind => "type"); 6586 6587 -- Entries 6588 6589 elsif Is_Protected_Entry (Subp_Id) then 6590 Info_Simple_Call; 6591 6592 -- Task entry calls are never processed because the entry being 6593 -- invoked does not have a corresponding "body", it has a select. 6594 6595 elsif Is_Task_Entry (Subp_Id) then 6596 null; 6597 6598 -- Finalization 6599 6600 elsif Is_TSS (Subp_Id, TSS_Deep_Finalize) then 6601 Info_Type_Actions ("finalization"); 6602 6603 -- Calls to _Finalizer procedures must not appear in the output 6604 -- because this creates confusing noise. 6605 6606 elsif Is_Finalizer_Proc (Subp_Id) then 6607 null; 6608 6609 -- Initial_Condition 6610 6611 elsif Is_Initial_Condition_Proc (Subp_Id) then 6612 Info_Verification_Call 6613 (Pred => "Initial_Condition", 6614 Id => Find_Enclosing_Scope (Call), 6615 Id_Kind => "package"); 6616 6617 -- Initialization 6618 6619 elsif Is_Init_Proc (Subp_Id) 6620 or else Is_TSS (Subp_Id, TSS_Deep_Initialize) 6621 then 6622 Info_Type_Actions ("initialization"); 6623 6624 -- Invariant 6625 6626 elsif Is_Invariant_Proc (Subp_Id) then 6627 Info_Verification_Call 6628 (Pred => "invariants", 6629 Id => First_Formal_Type (Subp_Id), 6630 Id_Kind => "type"); 6631 6632 -- Partial invariant calls must not appear in the output because 6633 -- this creates confusing noise. 6634 6635 elsif Is_Partial_Invariant_Proc (Subp_Id) then 6636 null; 6637 6638 -- _Postconditions 6639 6640 elsif Is_Postconditions_Proc (Subp_Id) then 6641 Info_Verification_Call 6642 (Pred => "postconditions", 6643 Id => Find_Enclosing_Scope (Call), 6644 Id_Kind => "subprogram"); 6645 6646 -- Subprograms must come last because some of the previous cases 6647 -- fall under this category. 6648 6649 elsif Ekind (Subp_Id) = E_Function then 6650 Info_Simple_Call; 6651 6652 elsif Ekind (Subp_Id) = E_Procedure then 6653 Info_Simple_Call; 6654 6655 else 6656 pragma Assert (False); 6657 return; 6658 end if; 6659 end if; 6660 end Info_Call; 6661 6662 ------------------------ 6663 -- Info_Instantiation -- 6664 ------------------------ 6665 6666 procedure Info_Instantiation 6667 (Inst : Node_Id; 6668 Gen_Id : Entity_Id; 6669 Info_Msg : Boolean; 6670 In_SPARK : Boolean) 6671 is 6672 begin 6673 Elab_Msg_NE 6674 (Msg => "instantiation of & during elaboration", 6675 N => Inst, 6676 Id => Gen_Id, 6677 Info_Msg => Info_Msg, 6678 In_SPARK => In_SPARK); 6679 end Info_Instantiation; 6680 6681 ----------------------------- 6682 -- Info_Variable_Reference -- 6683 ----------------------------- 6684 6685 procedure Info_Variable_Reference 6686 (Ref : Node_Id; 6687 Var_Id : Entity_Id; 6688 Info_Msg : Boolean; 6689 In_SPARK : Boolean) 6690 is 6691 begin 6692 if Is_Read (Ref) then 6693 Elab_Msg_NE 6694 (Msg => "read of variable & during elaboration", 6695 N => Ref, 6696 Id => Var_Id, 6697 Info_Msg => Info_Msg, 6698 In_SPARK => In_SPARK); 6699 end if; 6700 end Info_Variable_Reference; 6701 end Diagnostics; 6702 6703 --------------------------------- 6704 -- Early_Call_Region_Processor -- 6705 --------------------------------- 6706 6707 package body Early_Call_Region_Processor is 6708 6709 --------------------- 6710 -- Data structures -- 6711 --------------------- 6712 6713 -- The following map relates early call regions to subprogram bodies 6714 6715 procedure Destroy (N : in out Node_Id); 6716 -- Destroy node N 6717 6718 package ECR_Map is new Dynamic_Hash_Tables 6719 (Key_Type => Entity_Id, 6720 Value_Type => Node_Id, 6721 No_Value => Empty, 6722 Expansion_Threshold => 1.5, 6723 Expansion_Factor => 2, 6724 Compression_Threshold => 0.3, 6725 Compression_Factor => 2, 6726 "=" => "=", 6727 Destroy_Value => Destroy, 6728 Hash => Hash); 6729 6730 Early_Call_Regions_Map : ECR_Map.Dynamic_Hash_Table := ECR_Map.Nil; 6731 6732 ----------------------- 6733 -- Local subprograms -- 6734 ----------------------- 6735 6736 function Early_Call_Region (Body_Id : Entity_Id) return Node_Id; 6737 pragma Inline (Early_Call_Region); 6738 -- Obtain the early call region associated with entry or subprogram body 6739 -- Body_Id. 6740 6741 procedure Set_Early_Call_Region (Body_Id : Entity_Id; Start : Node_Id); 6742 pragma Inline (Set_Early_Call_Region); 6743 -- Associate an early call region with begins at construct Start with 6744 -- entry or subprogram body Body_Id. 6745 6746 ------------- 6747 -- Destroy -- 6748 ------------- 6749 6750 procedure Destroy (N : in out Node_Id) is 6751 pragma Unreferenced (N); 6752 begin 6753 null; 6754 end Destroy; 6755 6756 ----------------------- 6757 -- Early_Call_Region -- 6758 ----------------------- 6759 6760 function Early_Call_Region (Body_Id : Entity_Id) return Node_Id is 6761 pragma Assert (Present (Body_Id)); 6762 begin 6763 return ECR_Map.Get (Early_Call_Regions_Map, Body_Id); 6764 end Early_Call_Region; 6765 6766 ------------------------------------------ 6767 -- Finalize_Early_Call_Region_Processor -- 6768 ------------------------------------------ 6769 6770 procedure Finalize_Early_Call_Region_Processor is 6771 begin 6772 ECR_Map.Destroy (Early_Call_Regions_Map); 6773 end Finalize_Early_Call_Region_Processor; 6774 6775 ---------------------------- 6776 -- Find_Early_Call_Region -- 6777 ---------------------------- 6778 6779 function Find_Early_Call_Region 6780 (Body_Decl : Node_Id; 6781 Assume_Elab_Body : Boolean := False; 6782 Skip_Memoization : Boolean := False) return Node_Id 6783 is 6784 -- NOTE: The routines within Find_Early_Call_Region are intentionally 6785 -- unnested to avoid deep indentation of code. 6786 6787 ECR_Found : exception; 6788 -- This exception is raised when the early call region has been found 6789 6790 Start : Node_Id := Empty; 6791 -- The start of the early call region. This variable is updated by 6792 -- the various nested routines. Due to the use of exceptions, the 6793 -- variable must be global to the nested routines. 6794 6795 -- The algorithm implemented in this routine attempts to find the 6796 -- early call region of a subprogram body by inspecting constructs 6797 -- in reverse declarative order, while navigating the tree. The 6798 -- algorithm consists of an Inspection phase and Advancement phase. 6799 -- The pseudocode is as follows: 6800 -- 6801 -- loop 6802 -- inspection phase 6803 -- advancement phase 6804 -- end loop 6805 -- 6806 -- The infinite loop is terminated by raising exception ECR_Found. 6807 -- The algorithm utilizes two pointers, Curr and Start, to represent 6808 -- the current construct to inspect and the start of the early call 6809 -- region. 6810 -- 6811 -- IMPORTANT: The algorithm must maintain the following invariant at 6812 -- all time for it to function properly: 6813 -- 6814 -- A nested construct is entered only when it contains suitable 6815 -- constructs. 6816 -- 6817 -- This guarantees that leaving a nested or encapsulating construct 6818 -- functions properly. 6819 -- 6820 -- The Inspection phase determines whether the current construct is 6821 -- non-preelaborable, and if it is, the algorithm terminates. 6822 -- 6823 -- The Advancement phase walks the tree in reverse declarative order, 6824 -- while entering and leaving nested and encapsulating constructs. It 6825 -- may also terminate the elaborithm. There are several special cases 6826 -- of advancement. 6827 -- 6828 -- 1) General case: 6829 -- 6830 -- <construct 1> 6831 -- ... 6832 -- <construct N-1> <- Curr 6833 -- <construct N> <- Start 6834 -- <subprogram body> 6835 -- 6836 -- In the general case, a declarative or statement list is traversed 6837 -- in reverse order where Curr is the lead pointer, and Start is the 6838 -- last preelaborable construct. 6839 -- 6840 -- 2) Entering handled bodies 6841 -- 6842 -- package body Nested is <- Curr (2.3) 6843 -- <declarations> <- Curr (2.2) 6844 -- begin 6845 -- <statements> <- Curr (2.1) 6846 -- end Nested; 6847 -- <construct> <- Start 6848 -- 6849 -- In this case, the algorithm enters a handled body by starting from 6850 -- the last statement (2.1), or the last declaration (2.2), or the 6851 -- body is consumed (2.3) because it is empty and thus preelaborable. 6852 -- 6853 -- 3) Entering package declarations 6854 -- 6855 -- package Nested is <- Curr (2.3) 6856 -- <visible declarations> <- Curr (2.2) 6857 -- private 6858 -- <private declarations> <- Curr (2.1) 6859 -- end Nested; 6860 -- <construct> <- Start 6861 -- 6862 -- In this case, the algorithm enters a package declaration by 6863 -- starting from the last private declaration (2.1), the last visible 6864 -- declaration (2.2), or the package is consumed (2.3) because it is 6865 -- empty and thus preelaborable. 6866 -- 6867 -- 4) Transitioning from list to list of the same construct 6868 -- 6869 -- Certain constructs have two eligible lists. The algorithm must 6870 -- thus transition from the second to the first list when the second 6871 -- list is exhausted. 6872 -- 6873 -- declare <- Curr (4.2) 6874 -- <declarations> <- Curr (4.1) 6875 -- begin 6876 -- <statements> <- Start 6877 -- end; 6878 -- 6879 -- In this case, the algorithm has exhausted the second list (the 6880 -- statements in the example above), and continues with the last 6881 -- declaration (4.1) or the construct is consumed (4.2) because it 6882 -- contains only preelaborable code. 6883 -- 6884 -- 5) Transitioning from list to construct 6885 -- 6886 -- tack body Task is <- Curr (5.1) 6887 -- <- Curr (Empty) 6888 -- <construct 1> <- Start 6889 -- 6890 -- In this case, the algorithm has exhausted a list, Curr is Empty, 6891 -- and the owner of the list is consumed (5.1). 6892 -- 6893 -- 6) Transitioning from unit to unit 6894 -- 6895 -- A package body with a spec subject to pragma Elaborate_Body 6896 -- extends the possible range of the early call region to the package 6897 -- spec. 6898 -- 6899 -- package Pack is <- Curr (6.3) 6900 -- pragma Elaborate_Body; <- Curr (6.2) 6901 -- <visible declarations> <- Curr (6.2) 6902 -- private 6903 -- <private declarations> <- Curr (6.1) 6904 -- end Pack; 6905 -- 6906 -- package body Pack is <- Curr, Start 6907 -- 6908 -- In this case, the algorithm has reached a package body compilation 6909 -- unit whose spec is subject to pragma Elaborate_Body, or the caller 6910 -- of the algorithm has specified this behavior. This transition is 6911 -- equivalent to 3). 6912 -- 6913 -- 7) Transitioning from unit to termination 6914 -- 6915 -- Reaching a compilation unit always terminates the algorithm as 6916 -- there are no more lists to examine. This must take case 6) into 6917 -- account. 6918 -- 6919 -- 8) Transitioning from subunit to stub 6920 -- 6921 -- package body Pack is separate; <- Curr (8.1) 6922 -- 6923 -- separate (...) 6924 -- package body Pack is <- Curr, Start 6925 -- 6926 -- Reaching a subunit continues the search from the corresponding 6927 -- stub (8.1). 6928 6929 procedure Advance (Curr : in out Node_Id); 6930 pragma Inline (Advance); 6931 -- Update the Curr and Start pointers depending on their location 6932 -- in the tree to the next eligible construct. This routine raises 6933 -- ECR_Found. 6934 6935 procedure Enter_Handled_Body (Curr : in out Node_Id); 6936 pragma Inline (Enter_Handled_Body); 6937 -- Update the Curr and Start pointers to enter a nested handled body 6938 -- if applicable. This routine raises ECR_Found. 6939 6940 procedure Enter_Package_Declaration (Curr : in out Node_Id); 6941 pragma Inline (Enter_Package_Declaration); 6942 -- Update the Curr and Start pointers to enter a nested package spec 6943 -- if applicable. This routine raises ECR_Found. 6944 6945 function Find_ECR (N : Node_Id) return Node_Id; 6946 pragma Inline (Find_ECR); 6947 -- Find an early call region starting from arbitrary node N 6948 6949 function Has_Suitable_Construct (List : List_Id) return Boolean; 6950 pragma Inline (Has_Suitable_Construct); 6951 -- Determine whether list List contains a suitable construct for 6952 -- inclusion into an early call region. 6953 6954 procedure Include (N : Node_Id; Curr : out Node_Id); 6955 pragma Inline (Include); 6956 -- Update the Curr and Start pointers to include arbitrary construct 6957 -- N in the early call region. This routine raises ECR_Found. 6958 6959 function Is_OK_Preelaborable_Construct (N : Node_Id) return Boolean; 6960 pragma Inline (Is_OK_Preelaborable_Construct); 6961 -- Determine whether arbitrary node N denotes a preelaboration-safe 6962 -- construct. 6963 6964 function Is_Suitable_Construct (N : Node_Id) return Boolean; 6965 pragma Inline (Is_Suitable_Construct); 6966 -- Determine whether arbitrary node N denotes a suitable construct 6967 -- for inclusion into the early call region. 6968 6969 procedure Transition_Body_Declarations 6970 (Bod : Node_Id; 6971 Curr : out Node_Id); 6972 pragma Inline (Transition_Body_Declarations); 6973 -- Update the Curr and Start pointers when construct Bod denotes a 6974 -- block statement or a suitable body. This routine raises ECR_Found. 6975 6976 procedure Transition_Handled_Statements 6977 (HSS : Node_Id; 6978 Curr : out Node_Id); 6979 pragma Inline (Transition_Handled_Statements); 6980 -- Update the Curr and Start pointers when node HSS denotes a handled 6981 -- sequence of statements. This routine raises ECR_Found. 6982 6983 procedure Transition_Spec_Declarations 6984 (Spec : Node_Id; 6985 Curr : out Node_Id); 6986 pragma Inline (Transition_Spec_Declarations); 6987 -- Update the Curr and Start pointers when construct Spec denotes 6988 -- a concurrent definition or a package spec. This routine raises 6989 -- ECR_Found. 6990 6991 procedure Transition_Unit (Unit : Node_Id; Curr : out Node_Id); 6992 pragma Inline (Transition_Unit); 6993 -- Update the Curr and Start pointers when node Unit denotes a 6994 -- potential compilation unit. This routine raises ECR_Found. 6995 6996 ------------- 6997 -- Advance -- 6998 ------------- 6999 7000 procedure Advance (Curr : in out Node_Id) is 7001 Context : Node_Id; 7002 7003 begin 7004 -- Curr denotes one of the following cases upon entry into this 7005 -- routine: 7006 -- 7007 -- * Empty - There is no current construct when a declarative or 7008 -- a statement list has been exhausted. This does not indicate 7009 -- that the early call region has been computed as it is still 7010 -- possible to transition to another list. 7011 -- 7012 -- * Encapsulator - The current construct wraps declarations 7013 -- and/or statements. This indicates that the early call 7014 -- region may extend within the nested construct. 7015 -- 7016 -- * Preelaborable - The current construct is preelaborable 7017 -- because Find_ECR would not invoke Advance if this was not 7018 -- the case. 7019 7020 -- The current construct is an encapsulator or is preelaborable 7021 7022 if Present (Curr) then 7023 7024 -- Enter encapsulators by inspecting their declarations and/or 7025 -- statements. 7026 7027 if Nkind_In (Curr, N_Block_Statement, N_Package_Body) then 7028 Enter_Handled_Body (Curr); 7029 7030 elsif Nkind (Curr) = N_Package_Declaration then 7031 Enter_Package_Declaration (Curr); 7032 7033 -- Early call regions have a property which can be exploited to 7034 -- optimize the algorithm. 7035 -- 7036 -- <preceding subprogram body> 7037 -- <preelaborable construct 1> 7038 -- ... 7039 -- <preelaborable construct N> 7040 -- <initiating subprogram body> 7041 -- 7042 -- If a traversal initiated from a subprogram body reaches a 7043 -- preceding subprogram body, then both bodies share the same 7044 -- early call region. 7045 -- 7046 -- The property results in the following desirable effects: 7047 -- 7048 -- * If the preceding body already has an early call region, 7049 -- then the initiating body can reuse it. This minimizes the 7050 -- amount of processing performed by the algorithm. 7051 -- 7052 -- * If the preceding body lack an early call region, then the 7053 -- algorithm can compute the early call region, and reuse it 7054 -- for the initiating body. This processing performs the same 7055 -- amount of work, but has the beneficial effect of computing 7056 -- the early call regions of all preceding bodies. 7057 7058 elsif Nkind_In (Curr, N_Entry_Body, N_Subprogram_Body) then 7059 Start := 7060 Find_Early_Call_Region 7061 (Body_Decl => Curr, 7062 Assume_Elab_Body => Assume_Elab_Body, 7063 Skip_Memoization => Skip_Memoization); 7064 7065 raise ECR_Found; 7066 7067 -- Otherwise current construct is preelaborable. Unpdate the 7068 -- early call region to include it. 7069 7070 else 7071 Include (Curr, Curr); 7072 end if; 7073 7074 -- Otherwise the current construct is missing, indicating that the 7075 -- current list has been exhausted. Depending on the context of 7076 -- the list, several transitions are possible. 7077 7078 else 7079 -- The invariant of the algorithm ensures that Curr and Start 7080 -- are at the same level of nesting at the point of transition. 7081 -- The algorithm can determine which list the traversal came 7082 -- from by examining Start. 7083 7084 Context := Parent (Start); 7085 7086 -- Attempt the following transitions: 7087 -- 7088 -- private declarations -> visible declarations 7089 -- private declarations -> upper level 7090 -- private declarations -> terminate 7091 -- visible declarations -> upper level 7092 -- visible declarations -> terminate 7093 7094 if Nkind_In (Context, N_Package_Specification, 7095 N_Protected_Definition, 7096 N_Task_Definition) 7097 then 7098 Transition_Spec_Declarations (Context, Curr); 7099 7100 -- Attempt the following transitions: 7101 -- 7102 -- statements -> declarations 7103 -- statements -> upper level 7104 -- statements -> corresponding package spec (Elab_Body) 7105 -- statements -> terminate 7106 7107 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements then 7108 Transition_Handled_Statements (Context, Curr); 7109 7110 -- Attempt the following transitions: 7111 -- 7112 -- declarations -> upper level 7113 -- declarations -> corresponding package spec (Elab_Body) 7114 -- declarations -> terminate 7115 7116 elsif Nkind_In (Context, N_Block_Statement, 7117 N_Entry_Body, 7118 N_Package_Body, 7119 N_Protected_Body, 7120 N_Subprogram_Body, 7121 N_Task_Body) 7122 then 7123 Transition_Body_Declarations (Context, Curr); 7124 7125 -- Otherwise it is not possible to transition. Stop the search 7126 -- because there are no more declarations or statements to 7127 -- check. 7128 7129 else 7130 raise ECR_Found; 7131 end if; 7132 end if; 7133 end Advance; 7134 7135 -------------------------- 7136 -- Enter_Handled_Body -- 7137 -------------------------- 7138 7139 procedure Enter_Handled_Body (Curr : in out Node_Id) is 7140 Decls : constant List_Id := Declarations (Curr); 7141 HSS : constant Node_Id := Handled_Statement_Sequence (Curr); 7142 Stmts : List_Id := No_List; 7143 7144 begin 7145 if Present (HSS) then 7146 Stmts := Statements (HSS); 7147 end if; 7148 7149 -- The handled body has a non-empty statement sequence. The 7150 -- construct to inspect is the last statement. 7151 7152 if Has_Suitable_Construct (Stmts) then 7153 Curr := Last (Stmts); 7154 7155 -- The handled body lacks statements, but has non-empty 7156 -- declarations. The construct to inspect is the last declaration. 7157 7158 elsif Has_Suitable_Construct (Decls) then 7159 Curr := Last (Decls); 7160 7161 -- Otherwise the handled body lacks both declarations and 7162 -- statements. The construct to inspect is the node which precedes 7163 -- the handled body. Update the early call region to include the 7164 -- handled body. 7165 7166 else 7167 Include (Curr, Curr); 7168 end if; 7169 end Enter_Handled_Body; 7170 7171 ------------------------------- 7172 -- Enter_Package_Declaration -- 7173 ------------------------------- 7174 7175 procedure Enter_Package_Declaration (Curr : in out Node_Id) is 7176 Pack_Spec : constant Node_Id := Specification (Curr); 7177 Prv_Decls : constant List_Id := Private_Declarations (Pack_Spec); 7178 Vis_Decls : constant List_Id := Visible_Declarations (Pack_Spec); 7179 7180 begin 7181 -- The package has a non-empty private declarations. The construct 7182 -- to inspect is the last private declaration. 7183 7184 if Has_Suitable_Construct (Prv_Decls) then 7185 Curr := Last (Prv_Decls); 7186 7187 -- The package lacks private declarations, but has non-empty 7188 -- visible declarations. In this case the construct to inspect 7189 -- is the last visible declaration. 7190 7191 elsif Has_Suitable_Construct (Vis_Decls) then 7192 Curr := Last (Vis_Decls); 7193 7194 -- Otherwise the package lacks any declarations. The construct 7195 -- to inspect is the node which precedes the package. Update the 7196 -- early call region to include the package declaration. 7197 7198 else 7199 Include (Curr, Curr); 7200 end if; 7201 end Enter_Package_Declaration; 7202 7203 -------------- 7204 -- Find_ECR -- 7205 -------------- 7206 7207 function Find_ECR (N : Node_Id) return Node_Id is 7208 Curr : Node_Id; 7209 7210 begin 7211 -- The early call region starts at N 7212 7213 Curr := Prev (N); 7214 Start := N; 7215 7216 -- Inspect each node in reverse declarative order while going in 7217 -- and out of nested and enclosing constructs. Note that the only 7218 -- way to terminate this infinite loop is to raise ECR_Found. 7219 7220 loop 7221 -- The current construct is not preelaboration-safe. Terminate 7222 -- the traversal. 7223 7224 if Present (Curr) 7225 and then not Is_OK_Preelaborable_Construct (Curr) 7226 then 7227 raise ECR_Found; 7228 end if; 7229 7230 -- Advance to the next suitable construct. This may terminate 7231 -- the traversal by raising ECR_Found. 7232 7233 Advance (Curr); 7234 end loop; 7235 7236 exception 7237 when ECR_Found => 7238 return Start; 7239 end Find_ECR; 7240 7241 ---------------------------- 7242 -- Has_Suitable_Construct -- 7243 ---------------------------- 7244 7245 function Has_Suitable_Construct (List : List_Id) return Boolean is 7246 Item : Node_Id; 7247 7248 begin 7249 -- Examine the list in reverse declarative order, looking for a 7250 -- suitable construct. 7251 7252 if Present (List) then 7253 Item := Last (List); 7254 while Present (Item) loop 7255 if Is_Suitable_Construct (Item) then 7256 return True; 7257 end if; 7258 7259 Prev (Item); 7260 end loop; 7261 end if; 7262 7263 return False; 7264 end Has_Suitable_Construct; 7265 7266 ------------- 7267 -- Include -- 7268 ------------- 7269 7270 procedure Include (N : Node_Id; Curr : out Node_Id) is 7271 begin 7272 Start := N; 7273 7274 -- The input node is a compilation unit. This terminates the 7275 -- search because there are no more lists to inspect and there are 7276 -- no more enclosing constructs to climb up to. The transitions 7277 -- are: 7278 -- 7279 -- private declarations -> terminate 7280 -- visible declarations -> terminate 7281 -- statements -> terminate 7282 -- declarations -> terminate 7283 7284 if Nkind (Parent (Start)) = N_Compilation_Unit then 7285 raise ECR_Found; 7286 7287 -- Otherwise the input node is still within some list 7288 7289 else 7290 Curr := Prev (Start); 7291 end if; 7292 end Include; 7293 7294 ----------------------------------- 7295 -- Is_OK_Preelaborable_Construct -- 7296 ----------------------------------- 7297 7298 function Is_OK_Preelaborable_Construct (N : Node_Id) return Boolean is 7299 begin 7300 -- Assignment statements are acceptable as long as they were 7301 -- produced by the ABE mechanism to update elaboration flags. 7302 7303 if Nkind (N) = N_Assignment_Statement then 7304 return Is_Elaboration_Code (N); 7305 7306 -- Block statements are acceptable even though they directly 7307 -- violate preelaborability. The intention is not to penalize 7308 -- the early call region when a block contains only preelaborable 7309 -- constructs. 7310 -- 7311 -- declare 7312 -- Val : constant Integer := 1; 7313 -- begin 7314 -- pragma Assert (Val = 1); 7315 -- null; 7316 -- end; 7317 -- 7318 -- Note that the Advancement phase does enter blocks, and will 7319 -- detect any non-preelaborable declarations or statements within. 7320 7321 elsif Nkind (N) = N_Block_Statement then 7322 return True; 7323 end if; 7324 7325 -- Otherwise the construct must be preelaborable. The check must 7326 -- take the syntactic and semantic structure of the construct. DO 7327 -- NOT use Is_Preelaborable_Construct here. 7328 7329 return not Is_Non_Preelaborable_Construct (N); 7330 end Is_OK_Preelaborable_Construct; 7331 7332 --------------------------- 7333 -- Is_Suitable_Construct -- 7334 --------------------------- 7335 7336 function Is_Suitable_Construct (N : Node_Id) return Boolean is 7337 Context : constant Node_Id := Parent (N); 7338 7339 begin 7340 -- An internally-generated statement sequence which contains only 7341 -- a single null statement is not a suitable construct because it 7342 -- is a byproduct of the parser. Such a null statement should be 7343 -- excluded from the early call region because it carries the 7344 -- source location of the "end" keyword, and may lead to confusing 7345 -- diagnistics. 7346 7347 if Nkind (N) = N_Null_Statement 7348 and then not Comes_From_Source (N) 7349 and then Present (Context) 7350 and then Nkind (Context) = N_Handled_Sequence_Of_Statements 7351 then 7352 return False; 7353 end if; 7354 7355 -- Otherwise only constructs which correspond to pure Ada 7356 -- constructs are considered suitable. 7357 7358 case Nkind (N) is 7359 when N_Call_Marker 7360 | N_Freeze_Entity 7361 | N_Freeze_Generic_Entity 7362 | N_Implicit_Label_Declaration 7363 | N_Itype_Reference 7364 | N_Pop_Constraint_Error_Label 7365 | N_Pop_Program_Error_Label 7366 | N_Pop_Storage_Error_Label 7367 | N_Push_Constraint_Error_Label 7368 | N_Push_Program_Error_Label 7369 | N_Push_Storage_Error_Label 7370 | N_SCIL_Dispatch_Table_Tag_Init 7371 | N_SCIL_Dispatching_Call 7372 | N_SCIL_Membership_Test 7373 | N_Variable_Reference_Marker 7374 => 7375 return False; 7376 7377 when others => 7378 return True; 7379 end case; 7380 end Is_Suitable_Construct; 7381 7382 ---------------------------------- 7383 -- Transition_Body_Declarations -- 7384 ---------------------------------- 7385 7386 procedure Transition_Body_Declarations 7387 (Bod : Node_Id; 7388 Curr : out Node_Id) 7389 is 7390 Decls : constant List_Id := Declarations (Bod); 7391 7392 begin 7393 -- The search must come from the declarations of the body 7394 7395 pragma Assert 7396 (Is_Non_Empty_List (Decls) 7397 and then List_Containing (Start) = Decls); 7398 7399 -- The search finished inspecting the declarations. The construct 7400 -- to inspect is the node which precedes the handled body, unless 7401 -- the body is a compilation unit. The transitions are: 7402 -- 7403 -- declarations -> upper level 7404 -- declarations -> corresponding package spec (Elab_Body) 7405 -- declarations -> terminate 7406 7407 Transition_Unit (Bod, Curr); 7408 end Transition_Body_Declarations; 7409 7410 ----------------------------------- 7411 -- Transition_Handled_Statements -- 7412 ----------------------------------- 7413 7414 procedure Transition_Handled_Statements 7415 (HSS : Node_Id; 7416 Curr : out Node_Id) 7417 is 7418 Bod : constant Node_Id := Parent (HSS); 7419 Decls : constant List_Id := Declarations (Bod); 7420 Stmts : constant List_Id := Statements (HSS); 7421 7422 begin 7423 -- The search must come from the statements of certain bodies or 7424 -- statements. 7425 7426 pragma Assert (Nkind_In (Bod, N_Block_Statement, 7427 N_Entry_Body, 7428 N_Package_Body, 7429 N_Protected_Body, 7430 N_Subprogram_Body, 7431 N_Task_Body)); 7432 7433 -- The search must come from the statements of the handled 7434 -- sequence. 7435 7436 pragma Assert 7437 (Is_Non_Empty_List (Stmts) 7438 and then List_Containing (Start) = Stmts); 7439 7440 -- The search finished inspecting the statements. The handled body 7441 -- has non-empty declarations. The construct to inspect is the 7442 -- last declaration. The transitions are: 7443 -- 7444 -- statements -> declarations 7445 7446 if Has_Suitable_Construct (Decls) then 7447 Curr := Last (Decls); 7448 7449 -- Otherwise the handled body lacks declarations. The construct to 7450 -- inspect is the node which precedes the handled body, unless the 7451 -- body is a compilation unit. The transitions are: 7452 -- 7453 -- statements -> upper level 7454 -- statements -> corresponding package spec (Elab_Body) 7455 -- statements -> terminate 7456 7457 else 7458 Transition_Unit (Bod, Curr); 7459 end if; 7460 end Transition_Handled_Statements; 7461 7462 ---------------------------------- 7463 -- Transition_Spec_Declarations -- 7464 ---------------------------------- 7465 7466 procedure Transition_Spec_Declarations 7467 (Spec : Node_Id; 7468 Curr : out Node_Id) 7469 is 7470 Prv_Decls : constant List_Id := Private_Declarations (Spec); 7471 Vis_Decls : constant List_Id := Visible_Declarations (Spec); 7472 7473 begin 7474 pragma Assert (Present (Start) and then Is_List_Member (Start)); 7475 7476 -- The search came from the private declarations and finished 7477 -- their inspection. 7478 7479 if Has_Suitable_Construct (Prv_Decls) 7480 and then List_Containing (Start) = Prv_Decls 7481 then 7482 -- The context has non-empty visible declarations. The node to 7483 -- inspect is the last visible declaration. The transitions 7484 -- are: 7485 -- 7486 -- private declarations -> visible declarations 7487 7488 if Has_Suitable_Construct (Vis_Decls) then 7489 Curr := Last (Vis_Decls); 7490 7491 -- Otherwise the context lacks visible declarations. The 7492 -- construct to inspect is the node which precedes the context 7493 -- unless the context is a compilation unit. The transitions 7494 -- are: 7495 -- 7496 -- private declarations -> upper level 7497 -- private declarations -> terminate 7498 7499 else 7500 Transition_Unit (Parent (Spec), Curr); 7501 end if; 7502 7503 -- The search came from the visible declarations and finished 7504 -- their inspections. The construct to inspect is the node which 7505 -- precedes the context, unless the context is a compilaton unit. 7506 -- The transitions are: 7507 -- 7508 -- visible declarations -> upper level 7509 -- visible declarations -> terminate 7510 7511 elsif Has_Suitable_Construct (Vis_Decls) 7512 and then List_Containing (Start) = Vis_Decls 7513 then 7514 Transition_Unit (Parent (Spec), Curr); 7515 7516 -- At this point both declarative lists are empty, but the 7517 -- traversal still came from within the spec. This indicates 7518 -- that the invariant of the algorithm has been violated. 7519 7520 else 7521 pragma Assert (False); 7522 raise ECR_Found; 7523 end if; 7524 end Transition_Spec_Declarations; 7525 7526 --------------------- 7527 -- Transition_Unit -- 7528 --------------------- 7529 7530 procedure Transition_Unit 7531 (Unit : Node_Id; 7532 Curr : out Node_Id) 7533 is 7534 Context : constant Node_Id := Parent (Unit); 7535 7536 begin 7537 -- The unit is a compilation unit. This terminates the search 7538 -- because there are no more lists to inspect and there are no 7539 -- more enclosing constructs to climb up to. 7540 7541 if Nkind (Context) = N_Compilation_Unit then 7542 7543 -- A package body with a corresponding spec subject to pragma 7544 -- Elaborate_Body is an exception to the above. The annotation 7545 -- allows the search to continue into the package declaration. 7546 -- The transitions are: 7547 -- 7548 -- statements -> corresponding package spec (Elab_Body) 7549 -- declarations -> corresponding package spec (Elab_Body) 7550 7551 if Nkind (Unit) = N_Package_Body 7552 and then (Assume_Elab_Body 7553 or else Has_Pragma_Elaborate_Body 7554 (Corresponding_Spec (Unit))) 7555 then 7556 Curr := Unit_Declaration_Node (Corresponding_Spec (Unit)); 7557 Enter_Package_Declaration (Curr); 7558 7559 -- Otherwise terminate the search. The transitions are: 7560 -- 7561 -- private declarations -> terminate 7562 -- visible declarations -> terminate 7563 -- statements -> terminate 7564 -- declarations -> terminate 7565 7566 else 7567 raise ECR_Found; 7568 end if; 7569 7570 -- The unit is a subunit. The construct to inspect is the node 7571 -- which precedes the corresponding stub. Update the early call 7572 -- region to include the unit. 7573 7574 elsif Nkind (Context) = N_Subunit then 7575 Start := Unit; 7576 Curr := Corresponding_Stub (Context); 7577 7578 -- Otherwise the unit is nested. The construct to inspect is the 7579 -- node which precedes the unit. Update the early call region to 7580 -- include the unit. 7581 7582 else 7583 Include (Unit, Curr); 7584 end if; 7585 end Transition_Unit; 7586 7587 -- Local variables 7588 7589 Body_Id : constant Entity_Id := Unique_Defining_Entity (Body_Decl); 7590 Region : Node_Id; 7591 7592 -- Start of processing for Find_Early_Call_Region 7593 7594 begin 7595 -- The caller demands the start of the early call region without 7596 -- saving or retrieving it to/from internal data structures. 7597 7598 if Skip_Memoization then 7599 Region := Find_ECR (Body_Decl); 7600 7601 -- Default behavior 7602 7603 else 7604 -- Check whether the early call region of the subprogram body is 7605 -- available. 7606 7607 Region := Early_Call_Region (Body_Id); 7608 7609 if No (Region) then 7610 Region := Find_ECR (Body_Decl); 7611 7612 -- Associate the early call region with the subprogram body in 7613 -- case other scenarios need it. 7614 7615 Set_Early_Call_Region (Body_Id, Region); 7616 end if; 7617 end if; 7618 7619 -- A subprogram body must always have an early call region 7620 7621 pragma Assert (Present (Region)); 7622 7623 return Region; 7624 end Find_Early_Call_Region; 7625 7626 -------------------------------------------- 7627 -- Initialize_Early_Call_Region_Processor -- 7628 -------------------------------------------- 7629 7630 procedure Initialize_Early_Call_Region_Processor is 7631 begin 7632 Early_Call_Regions_Map := ECR_Map.Create (100); 7633 end Initialize_Early_Call_Region_Processor; 7634 7635 --------------------------- 7636 -- Set_Early_Call_Region -- 7637 --------------------------- 7638 7639 procedure Set_Early_Call_Region (Body_Id : Entity_Id; Start : Node_Id) is 7640 pragma Assert (Present (Body_Id)); 7641 pragma Assert (Present (Start)); 7642 7643 begin 7644 ECR_Map.Put (Early_Call_Regions_Map, Body_Id, Start); 7645 end Set_Early_Call_Region; 7646 end Early_Call_Region_Processor; 7647 7648 ---------------------- 7649 -- Elaborated_Units -- 7650 ---------------------- 7651 7652 package body Elaborated_Units is 7653 7654 ----------- 7655 -- Types -- 7656 ----------- 7657 7658 -- The following type idenfities the elaboration attributes of a unit 7659 7660 type Elaboration_Attributes_Id is new Natural; 7661 7662 No_Elaboration_Attributes : constant Elaboration_Attributes_Id := 7663 Elaboration_Attributes_Id'First; 7664 First_Elaboration_Attributes : constant Elaboration_Attributes_Id := 7665 No_Elaboration_Attributes + 1; 7666 7667 -- The following type represents the elaboration attributes of a unit 7668 7669 type Elaboration_Attributes_Record is record 7670 Elab_Pragma : Node_Id := Empty; 7671 -- This attribute denotes a source Elaborate or Elaborate_All pragma 7672 -- which guarantees the prior elaboration of some unit with respect 7673 -- to the main unit. The pragma may come from the following contexts: 7674 -- 7675 -- * The main unit 7676 -- * The spec of the main unit (if applicable) 7677 -- * Any parent spec of the main unit (if applicable) 7678 -- * Any parent subunit of the main unit (if applicable) 7679 -- 7680 -- The attribute remains Empty if no such pragma is available. Source 7681 -- pragmas play a role in satisfying SPARK elaboration requirements. 7682 7683 With_Clause : Node_Id := Empty; 7684 -- This attribute denotes an internally-generated or a source with 7685 -- clause for some unit withed by the main unit. With clauses carry 7686 -- flags which represent implicit Elaborate or Elaborate_All pragmas. 7687 -- These clauses play a role in supplying elaboration dependencies to 7688 -- binde. 7689 end record; 7690 7691 --------------------- 7692 -- Data structures -- 7693 --------------------- 7694 7695 -- The following table stores all elaboration attributes 7696 7697 package Elaboration_Attributes is new Table.Table 7698 (Table_Index_Type => Elaboration_Attributes_Id, 7699 Table_Component_Type => Elaboration_Attributes_Record, 7700 Table_Low_Bound => First_Elaboration_Attributes, 7701 Table_Initial => 250, 7702 Table_Increment => 200, 7703 Table_Name => "Elaboration_Attributes"); 7704 7705 procedure Destroy (EA_Id : in out Elaboration_Attributes_Id); 7706 -- Destroy elaboration attributes EA_Id 7707 7708 package UA_Map is new Dynamic_Hash_Tables 7709 (Key_Type => Entity_Id, 7710 Value_Type => Elaboration_Attributes_Id, 7711 No_Value => No_Elaboration_Attributes, 7712 Expansion_Threshold => 1.5, 7713 Expansion_Factor => 2, 7714 Compression_Threshold => 0.3, 7715 Compression_Factor => 2, 7716 "=" => "=", 7717 Destroy_Value => Destroy, 7718 Hash => Hash); 7719 7720 -- The following map relates an elaboration attributes of a unit to the 7721 -- unit. 7722 7723 Unit_To_Attributes_Map : UA_Map.Dynamic_Hash_Table := UA_Map.Nil; 7724 7725 ------------------ 7726 -- Constructors -- 7727 ------------------ 7728 7729 function Elaboration_Attributes_Of 7730 (Unit_Id : Entity_Id) return Elaboration_Attributes_Id; 7731 pragma Inline (Elaboration_Attributes_Of); 7732 -- Obtain the elaboration attributes of unit Unit_Id 7733 7734 ----------------------- 7735 -- Local subprograms -- 7736 ----------------------- 7737 7738 function Elab_Pragma (EA_Id : Elaboration_Attributes_Id) return Node_Id; 7739 pragma Inline (Elab_Pragma); 7740 -- Obtain the Elaborate[_All] pragma of elaboration attributes EA_Id 7741 7742 procedure Ensure_Prior_Elaboration_Dynamic 7743 (N : Node_Id; 7744 Unit_Id : Entity_Id; 7745 Prag_Nam : Name_Id; 7746 In_State : Processing_In_State); 7747 pragma Inline (Ensure_Prior_Elaboration_Dynamic); 7748 -- Guarantee the elaboration of unit Unit_Id with respect to the main 7749 -- unit by suggesting the use of Elaborate[_All] with name Prag_Nam. N 7750 -- denotes the related scenario. In_State is the current state of the 7751 -- Processing phase. 7752 7753 procedure Ensure_Prior_Elaboration_Static 7754 (N : Node_Id; 7755 Unit_Id : Entity_Id; 7756 Prag_Nam : Name_Id; 7757 In_State : Processing_In_State); 7758 pragma Inline (Ensure_Prior_Elaboration_Static); 7759 -- Guarantee the elaboration of unit Unit_Id with respect to the main 7760 -- unit by installing an implicit Elaborate[_All] pragma with name 7761 -- Prag_Nam. N denotes the related scenario. In_State is the current 7762 -- state of the Processing phase. 7763 7764 function Present (EA_Id : Elaboration_Attributes_Id) return Boolean; 7765 pragma Inline (Present); 7766 -- Determine whether elaboration attributes UA_Id exist 7767 7768 procedure Set_Elab_Pragma 7769 (EA_Id : Elaboration_Attributes_Id; 7770 Prag : Node_Id); 7771 pragma Inline (Set_Elab_Pragma); 7772 -- Set the Elaborate[_All] pragma of elaboration attributes EA_Id to 7773 -- Prag. 7774 7775 procedure Set_With_Clause 7776 (EA_Id : Elaboration_Attributes_Id; 7777 Clause : Node_Id); 7778 pragma Inline (Set_With_Clause); 7779 -- Set the with clause of elaboration attributes EA_Id to Clause 7780 7781 function With_Clause (EA_Id : Elaboration_Attributes_Id) return Node_Id; 7782 pragma Inline (With_Clause); 7783 -- Obtain the implicit or source with clause of elaboration attributes 7784 -- EA_Id. 7785 7786 ------------------------------ 7787 -- Collect_Elaborated_Units -- 7788 ------------------------------ 7789 7790 procedure Collect_Elaborated_Units is 7791 procedure Add_Pragma (Prag : Node_Id); 7792 pragma Inline (Add_Pragma); 7793 -- Determine whether pragma Prag denotes a legal Elaborate[_All] 7794 -- pragma. If this is the case, add the related unit to the context. 7795 -- For pragma Elaborate_All, include recursively all units withed by 7796 -- the related unit. 7797 7798 procedure Add_Unit 7799 (Unit_Id : Entity_Id; 7800 Prag : Node_Id; 7801 Full_Context : Boolean); 7802 pragma Inline (Add_Unit); 7803 -- Add unit Unit_Id to the elaboration context. Prag denotes the 7804 -- pragma which prompted the inclusion of the unit to the context. 7805 -- If flag Full_Context is set, examine the nonlimited clauses of 7806 -- unit Unit_Id and add each withed unit to the context. 7807 7808 procedure Find_Elaboration_Context (Comp_Unit : Node_Id); 7809 pragma Inline (Find_Elaboration_Context); 7810 -- Examine the context items of compilation unit Comp_Unit for 7811 -- suitable elaboration-related pragmas and add all related units 7812 -- to the context. 7813 7814 ---------------- 7815 -- Add_Pragma -- 7816 ---------------- 7817 7818 procedure Add_Pragma (Prag : Node_Id) is 7819 Prag_Args : constant List_Id := 7820 Pragma_Argument_Associations (Prag); 7821 Prag_Nam : constant Name_Id := Pragma_Name (Prag); 7822 Unit_Arg : Node_Id; 7823 7824 begin 7825 -- Nothing to do if the pragma is not related to elaboration 7826 7827 if not Nam_In (Prag_Nam, Name_Elaborate, Name_Elaborate_All) then 7828 return; 7829 7830 -- Nothing to do when the pragma is illegal 7831 7832 elsif Error_Posted (Prag) then 7833 return; 7834 end if; 7835 7836 Unit_Arg := Get_Pragma_Arg (First (Prag_Args)); 7837 7838 -- The argument of the pragma may appear in package.package form 7839 7840 if Nkind (Unit_Arg) = N_Selected_Component then 7841 Unit_Arg := Selector_Name (Unit_Arg); 7842 end if; 7843 7844 Add_Unit 7845 (Unit_Id => Entity (Unit_Arg), 7846 Prag => Prag, 7847 Full_Context => Prag_Nam = Name_Elaborate_All); 7848 end Add_Pragma; 7849 7850 -------------- 7851 -- Add_Unit -- 7852 -------------- 7853 7854 procedure Add_Unit 7855 (Unit_Id : Entity_Id; 7856 Prag : Node_Id; 7857 Full_Context : Boolean) 7858 is 7859 Clause : Node_Id; 7860 EA_Id : Elaboration_Attributes_Id; 7861 Unit_Prag : Node_Id; 7862 7863 begin 7864 -- Nothing to do when some previous error left a with clause or a 7865 -- pragma in a bad state. 7866 7867 if No (Unit_Id) then 7868 return; 7869 end if; 7870 7871 EA_Id := Elaboration_Attributes_Of (Unit_Id); 7872 Unit_Prag := Elab_Pragma (EA_Id); 7873 7874 -- The unit is already included in the context by means of pragma 7875 -- Elaborate[_All]. 7876 7877 if Present (Unit_Prag) then 7878 7879 -- Upgrade an existing pragma Elaborate when the unit is 7880 -- subject to Elaborate_All because the new pragma covers a 7881 -- larger set of units. 7882 7883 if Pragma_Name (Unit_Prag) = Name_Elaborate 7884 and then Pragma_Name (Prag) = Name_Elaborate_All 7885 then 7886 Set_Elab_Pragma (EA_Id, Prag); 7887 7888 -- Otherwise the unit retains its existing pragma and does not 7889 -- need to be included in the context again. 7890 7891 else 7892 return; 7893 end if; 7894 7895 -- Otherwise the current unit is not included in the context 7896 7897 else 7898 Set_Elab_Pragma (EA_Id, Prag); 7899 end if; 7900 7901 -- Includes all units withed by the current one when computing the 7902 -- full context. 7903 7904 if Full_Context then 7905 7906 -- Process all nonlimited with clauses found in the context of 7907 -- the current unit. Note that limited clauses do not impose an 7908 -- elaboration order. 7909 7910 Clause := First (Context_Items (Compilation_Unit (Unit_Id))); 7911 while Present (Clause) loop 7912 if Nkind (Clause) = N_With_Clause 7913 and then not Error_Posted (Clause) 7914 and then not Limited_Present (Clause) 7915 then 7916 Add_Unit 7917 (Unit_Id => Entity (Name (Clause)), 7918 Prag => Prag, 7919 Full_Context => Full_Context); 7920 end if; 7921 7922 Next (Clause); 7923 end loop; 7924 end if; 7925 end Add_Unit; 7926 7927 ------------------------------ 7928 -- Find_Elaboration_Context -- 7929 ------------------------------ 7930 7931 procedure Find_Elaboration_Context (Comp_Unit : Node_Id) is 7932 pragma Assert (Nkind (Comp_Unit) = N_Compilation_Unit); 7933 7934 Prag : Node_Id; 7935 7936 begin 7937 -- Process all elaboration-related pragmas found in the context of 7938 -- the compilation unit. 7939 7940 Prag := First (Context_Items (Comp_Unit)); 7941 while Present (Prag) loop 7942 if Nkind (Prag) = N_Pragma then 7943 Add_Pragma (Prag); 7944 end if; 7945 7946 Next (Prag); 7947 end loop; 7948 end Find_Elaboration_Context; 7949 7950 -- Local variables 7951 7952 Par_Id : Entity_Id; 7953 Unit_Id : Node_Id; 7954 7955 -- Start of processing for Collect_Elaborated_Units 7956 7957 begin 7958 -- Perform a traversal to examines the context of the main unit. The 7959 -- traversal performs the following jumps: 7960 -- 7961 -- subunit -> parent subunit 7962 -- parent subunit -> body 7963 -- body -> spec 7964 -- spec -> parent spec 7965 -- parent spec -> grandparent spec and so on 7966 -- 7967 -- The traversal relies on units rather than scopes because the scope 7968 -- of a subunit is some spec, while this traversal must process the 7969 -- body as well. Given that protected and task bodies can also be 7970 -- subunits, this complicates the scope approach even further. 7971 7972 Unit_Id := Unit (Cunit (Main_Unit)); 7973 7974 -- Perform the following traversals when the main unit is a subunit 7975 -- 7976 -- subunit -> parent subunit 7977 -- parent subunit -> body 7978 7979 while Present (Unit_Id) and then Nkind (Unit_Id) = N_Subunit loop 7980 Find_Elaboration_Context (Parent (Unit_Id)); 7981 7982 -- Continue the traversal by going to the unit which contains the 7983 -- corresponding stub. 7984 7985 if Present (Corresponding_Stub (Unit_Id)) then 7986 Unit_Id := 7987 Unit (Cunit (Get_Source_Unit (Corresponding_Stub (Unit_Id)))); 7988 7989 -- Otherwise the subunit may be erroneous or left in a bad state 7990 7991 else 7992 exit; 7993 end if; 7994 end loop; 7995 7996 -- Perform the following traversal now that subunits have been taken 7997 -- care of, or the main unit is a body. 7998 -- 7999 -- body -> spec 8000 8001 if Present (Unit_Id) 8002 and then Nkind_In (Unit_Id, N_Package_Body, N_Subprogram_Body) 8003 then 8004 Find_Elaboration_Context (Parent (Unit_Id)); 8005 8006 -- Continue the traversal by going to the unit which contains the 8007 -- corresponding spec. 8008 8009 if Present (Corresponding_Spec (Unit_Id)) then 8010 Unit_Id := 8011 Unit (Cunit (Get_Source_Unit (Corresponding_Spec (Unit_Id)))); 8012 end if; 8013 end if; 8014 8015 -- Perform the following traversals now that the body has been taken 8016 -- care of, or the main unit is a spec. 8017 -- 8018 -- spec -> parent spec 8019 -- parent spec -> grandparent spec and so on 8020 8021 if Present (Unit_Id) 8022 and then Nkind_In (Unit_Id, N_Generic_Package_Declaration, 8023 N_Generic_Subprogram_Declaration, 8024 N_Package_Declaration, 8025 N_Subprogram_Declaration) 8026 then 8027 Find_Elaboration_Context (Parent (Unit_Id)); 8028 8029 -- Process a potential chain of parent units which ends with the 8030 -- main unit spec. The traversal can now safely rely on the scope 8031 -- chain. 8032 8033 Par_Id := Scope (Defining_Entity (Unit_Id)); 8034 while Present (Par_Id) and then Par_Id /= Standard_Standard loop 8035 Find_Elaboration_Context (Compilation_Unit (Par_Id)); 8036 8037 Par_Id := Scope (Par_Id); 8038 end loop; 8039 end if; 8040 end Collect_Elaborated_Units; 8041 8042 ------------- 8043 -- Destroy -- 8044 ------------- 8045 8046 procedure Destroy (EA_Id : in out Elaboration_Attributes_Id) is 8047 pragma Unreferenced (EA_Id); 8048 begin 8049 null; 8050 end Destroy; 8051 8052 ----------------- 8053 -- Elab_Pragma -- 8054 ----------------- 8055 8056 function Elab_Pragma 8057 (EA_Id : Elaboration_Attributes_Id) return Node_Id 8058 is 8059 pragma Assert (Present (EA_Id)); 8060 begin 8061 return Elaboration_Attributes.Table (EA_Id).Elab_Pragma; 8062 end Elab_Pragma; 8063 8064 ------------------------------- 8065 -- Elaboration_Attributes_Of -- 8066 ------------------------------- 8067 8068 function Elaboration_Attributes_Of 8069 (Unit_Id : Entity_Id) return Elaboration_Attributes_Id 8070 is 8071 EA_Id : Elaboration_Attributes_Id; 8072 8073 begin 8074 EA_Id := UA_Map.Get (Unit_To_Attributes_Map, Unit_Id); 8075 8076 -- The unit lacks elaboration attributes. This indicates that the 8077 -- unit is encountered for the first time. Create the elaboration 8078 -- attributes for it. 8079 8080 if not Present (EA_Id) then 8081 Elaboration_Attributes.Append 8082 ((Elab_Pragma => Empty, 8083 With_Clause => Empty)); 8084 EA_Id := Elaboration_Attributes.Last; 8085 8086 -- Associate the elaboration attributes with the unit 8087 8088 UA_Map.Put (Unit_To_Attributes_Map, Unit_Id, EA_Id); 8089 end if; 8090 8091 pragma Assert (Present (EA_Id)); 8092 8093 return EA_Id; 8094 end Elaboration_Attributes_Of; 8095 8096 ------------------------------ 8097 -- Ensure_Prior_Elaboration -- 8098 ------------------------------ 8099 8100 procedure Ensure_Prior_Elaboration 8101 (N : Node_Id; 8102 Unit_Id : Entity_Id; 8103 Prag_Nam : Name_Id; 8104 In_State : Processing_In_State) 8105 is 8106 pragma Assert (Nam_In (Prag_Nam, Name_Elaborate, Name_Elaborate_All)); 8107 8108 begin 8109 -- Nothing to do when the need for prior elaboration came from a 8110 -- partial finalization routine which occurs in an initialization 8111 -- context. This behaviour parallels that of the old ABE mechanism. 8112 8113 if In_State.Within_Partial_Finalization then 8114 return; 8115 8116 -- Nothing to do when the need for prior elaboration came from a task 8117 -- body and switch -gnatd.y (disable implicit pragma Elaborate_All on 8118 -- task bodies) is in effect. 8119 8120 elsif Debug_Flag_Dot_Y and then In_State.Within_Task_Body then 8121 return; 8122 8123 -- Nothing to do when the unit is elaborated prior to the main unit. 8124 -- This check must also consider the following cases: 8125 -- 8126 -- * No check is made against the context of the main unit because 8127 -- this is specific to the elaboration model in effect and requires 8128 -- custom handling (see Ensure_xxx_Prior_Elaboration). 8129 -- 8130 -- * Unit_Id is subject to pragma Elaborate_Body. An implicit pragma 8131 -- Elaborate[_All] MUST be generated even though Unit_Id is always 8132 -- elaborated prior to the main unit. This conservative strategy 8133 -- ensures that other units withed by Unit_Id will not lead to an 8134 -- ABE. 8135 -- 8136 -- package A is package body A is 8137 -- procedure ABE; procedure ABE is ... end ABE; 8138 -- end A; end A; 8139 -- 8140 -- with A; 8141 -- package B is package body B is 8142 -- pragma Elaborate_Body; procedure Proc is 8143 -- begin 8144 -- procedure Proc; A.ABE; 8145 -- package B; end Proc; 8146 -- end B; 8147 -- 8148 -- with B; 8149 -- package C is package body C is 8150 -- ... ... 8151 -- end C; begin 8152 -- B.Proc; 8153 -- end C; 8154 -- 8155 -- In the example above, the elaboration of C invokes B.Proc. B is 8156 -- subject to pragma Elaborate_Body. If no pragma Elaborate[_All] 8157 -- is gnerated for B in C, then the following elaboratio order will 8158 -- lead to an ABE: 8159 -- 8160 -- spec of A elaborated 8161 -- spec of B elaborated 8162 -- body of B elaborated 8163 -- spec of C elaborated 8164 -- body of C elaborated <-- calls B.Proc which calls A.ABE 8165 -- body of A elaborated <-- problem 8166 -- 8167 -- The generation of an implicit pragma Elaborate_All (B) ensures 8168 -- that the elaboration-order mechanism will not pick the above 8169 -- order. 8170 -- 8171 -- An implicit Elaborate is NOT generated when the unit is subject 8172 -- to Elaborate_Body because both pragmas have the same effect. 8173 -- 8174 -- * Unit_Id is the main unit. An implicit pragma Elaborate[_All] 8175 -- MUST NOT be generated in this case because a unit cannot depend 8176 -- on its own elaboration. This case is therefore treated as valid 8177 -- prior elaboration. 8178 8179 elsif Has_Prior_Elaboration 8180 (Unit_Id => Unit_Id, 8181 Same_Unit_OK => True, 8182 Elab_Body_OK => Prag_Nam = Name_Elaborate) 8183 then 8184 return; 8185 end if; 8186 8187 -- Suggest the use of pragma Prag_Nam when the dynamic model is in 8188 -- effect. 8189 8190 if Dynamic_Elaboration_Checks then 8191 Ensure_Prior_Elaboration_Dynamic 8192 (N => N, 8193 Unit_Id => Unit_Id, 8194 Prag_Nam => Prag_Nam, 8195 In_State => In_State); 8196 8197 -- Install an implicit pragma Prag_Nam when the static model is in 8198 -- effect. 8199 8200 else 8201 pragma Assert (Static_Elaboration_Checks); 8202 8203 Ensure_Prior_Elaboration_Static 8204 (N => N, 8205 Unit_Id => Unit_Id, 8206 Prag_Nam => Prag_Nam, 8207 In_State => In_State); 8208 end if; 8209 end Ensure_Prior_Elaboration; 8210 8211 -------------------------------------- 8212 -- Ensure_Prior_Elaboration_Dynamic -- 8213 -------------------------------------- 8214 8215 procedure Ensure_Prior_Elaboration_Dynamic 8216 (N : Node_Id; 8217 Unit_Id : Entity_Id; 8218 Prag_Nam : Name_Id; 8219 In_State : Processing_In_State) 8220 is 8221 procedure Info_Missing_Pragma; 8222 pragma Inline (Info_Missing_Pragma); 8223 -- Output information concerning missing Elaborate or Elaborate_All 8224 -- pragma with name Prag_Nam for scenario N, which would ensure the 8225 -- prior elaboration of Unit_Id. 8226 8227 ------------------------- 8228 -- Info_Missing_Pragma -- 8229 ------------------------- 8230 8231 procedure Info_Missing_Pragma is 8232 begin 8233 -- Internal units are ignored as they cause unnecessary noise 8234 8235 if not In_Internal_Unit (Unit_Id) then 8236 8237 -- The name of the unit subjected to the elaboration pragma is 8238 -- fully qualified to improve the clarity of the info message. 8239 8240 Error_Msg_Name_1 := Prag_Nam; 8241 Error_Msg_Qual_Level := Nat'Last; 8242 8243 Error_Msg_NE ("info: missing pragma % for unit &", N, Unit_Id); 8244 Error_Msg_Qual_Level := 0; 8245 end if; 8246 end Info_Missing_Pragma; 8247 8248 -- Local variables 8249 8250 EA_Id : constant Elaboration_Attributes_Id := 8251 Elaboration_Attributes_Of (Unit_Id); 8252 N_Lvl : Enclosing_Level_Kind; 8253 N_Rep : Scenario_Rep_Id; 8254 8255 -- Start of processing for Ensure_Prior_Elaboration_Dynamic 8256 8257 begin 8258 -- Nothing to do when the unit is guaranteed prior elaboration by 8259 -- means of a source Elaborate[_All] pragma. 8260 8261 if Present (Elab_Pragma (EA_Id)) then 8262 return; 8263 end if; 8264 8265 -- Output extra information on a missing Elaborate[_All] pragma when 8266 -- switch -gnatel (info messages on implicit Elaborate[_All] pragmas 8267 -- is in effect. 8268 8269 if Elab_Info_Messages 8270 and then not In_State.Suppress_Info_Messages 8271 then 8272 N_Rep := Scenario_Representation_Of (N, In_State); 8273 N_Lvl := Level (N_Rep); 8274 8275 -- Declaration-level scenario 8276 8277 if (Is_Suitable_Call (N) or else Is_Suitable_Instantiation (N)) 8278 and then N_Lvl = Declaration_Level 8279 then 8280 null; 8281 8282 -- Library-level scenario 8283 8284 elsif N_Lvl in Library_Level then 8285 null; 8286 8287 -- Instantiation library-level scenario 8288 8289 elsif N_Lvl = Instantiation_Level then 8290 null; 8291 8292 -- Otherwise the scenario does not appear at the proper level 8293 8294 else 8295 return; 8296 end if; 8297 8298 Info_Missing_Pragma; 8299 end if; 8300 end Ensure_Prior_Elaboration_Dynamic; 8301 8302 ------------------------------------- 8303 -- Ensure_Prior_Elaboration_Static -- 8304 ------------------------------------- 8305 8306 procedure Ensure_Prior_Elaboration_Static 8307 (N : Node_Id; 8308 Unit_Id : Entity_Id; 8309 Prag_Nam : Name_Id; 8310 In_State : Processing_In_State) 8311 is 8312 function Find_With_Clause 8313 (Items : List_Id; 8314 Withed_Id : Entity_Id) return Node_Id; 8315 pragma Inline (Find_With_Clause); 8316 -- Find a nonlimited with clause in the list of context items Items 8317 -- that withs unit Withed_Id. Return Empty if no such clause exists. 8318 8319 procedure Info_Implicit_Pragma; 8320 pragma Inline (Info_Implicit_Pragma); 8321 -- Output information concerning an implicitly generated Elaborate 8322 -- or Elaborate_All pragma with name Prag_Nam for scenario N which 8323 -- ensures the prior elaboration of unit Unit_Id. 8324 8325 ---------------------- 8326 -- Find_With_Clause -- 8327 ---------------------- 8328 8329 function Find_With_Clause 8330 (Items : List_Id; 8331 Withed_Id : Entity_Id) return Node_Id 8332 is 8333 Item : Node_Id; 8334 8335 begin 8336 -- Examine the context clauses looking for a suitable with. Note 8337 -- that limited clauses do not affect the elaboration order. 8338 8339 Item := First (Items); 8340 while Present (Item) loop 8341 if Nkind (Item) = N_With_Clause 8342 and then not Error_Posted (Item) 8343 and then not Limited_Present (Item) 8344 and then Entity (Name (Item)) = Withed_Id 8345 then 8346 return Item; 8347 end if; 8348 8349 Next (Item); 8350 end loop; 8351 8352 return Empty; 8353 end Find_With_Clause; 8354 8355 -------------------------- 8356 -- Info_Implicit_Pragma -- 8357 -------------------------- 8358 8359 procedure Info_Implicit_Pragma is 8360 begin 8361 -- Internal units are ignored as they cause unnecessary noise 8362 8363 if not In_Internal_Unit (Unit_Id) then 8364 8365 -- The name of the unit subjected to the elaboration pragma is 8366 -- fully qualified to improve the clarity of the info message. 8367 8368 Error_Msg_Name_1 := Prag_Nam; 8369 Error_Msg_Qual_Level := Nat'Last; 8370 8371 Error_Msg_NE 8372 ("info: implicit pragma % generated for unit &", N, Unit_Id); 8373 8374 Error_Msg_Qual_Level := 0; 8375 Output_Active_Scenarios (N, In_State); 8376 end if; 8377 end Info_Implicit_Pragma; 8378 8379 -- Local variables 8380 8381 EA_Id : constant Elaboration_Attributes_Id := 8382 Elaboration_Attributes_Of (Unit_Id); 8383 8384 Main_Cunit : constant Node_Id := Cunit (Main_Unit); 8385 Loc : constant Source_Ptr := Sloc (Main_Cunit); 8386 Unit_Cunit : constant Node_Id := Compilation_Unit (Unit_Id); 8387 Unit_Prag : constant Node_Id := Elab_Pragma (EA_Id); 8388 Unit_With : constant Node_Id := With_Clause (EA_Id); 8389 8390 Clause : Node_Id; 8391 Items : List_Id; 8392 8393 -- Start of processing for Ensure_Prior_Elaboration_Static 8394 8395 begin 8396 -- Nothing to do when the caller has suppressed the generation of 8397 -- implicit Elaborate[_All] pragmas. 8398 8399 if In_State.Suppress_Implicit_Pragmas then 8400 return; 8401 8402 -- Nothing to do when the unit is guaranteed prior elaboration by 8403 -- means of a source Elaborate[_All] pragma. 8404 8405 elsif Present (Unit_Prag) then 8406 return; 8407 8408 -- Nothing to do when the unit has an existing implicit Elaborate or 8409 -- Elaborate_All pragma installed by a previous scenario. 8410 8411 elsif Present (Unit_With) then 8412 8413 -- The unit is already guaranteed prior elaboration by means of an 8414 -- implicit Elaborate pragma, however the current scenario imposes 8415 -- a stronger requirement of Elaborate_All. "Upgrade" the existing 8416 -- pragma to match this new requirement. 8417 8418 if Elaborate_Desirable (Unit_With) 8419 and then Prag_Nam = Name_Elaborate_All 8420 then 8421 Set_Elaborate_All_Desirable (Unit_With); 8422 Set_Elaborate_Desirable (Unit_With, False); 8423 end if; 8424 8425 return; 8426 end if; 8427 8428 -- At this point it is known that the unit has no prior elaboration 8429 -- according to pragmas and hierarchical relationships. 8430 8431 Items := Context_Items (Main_Cunit); 8432 8433 if No (Items) then 8434 Items := New_List; 8435 Set_Context_Items (Main_Cunit, Items); 8436 end if; 8437 8438 -- Locate the with clause for the unit. Note that there may not be a 8439 -- clause if the unit is visible through a subunit-body, body-spec, 8440 -- or spec-parent relationship. 8441 8442 Clause := 8443 Find_With_Clause 8444 (Items => Items, 8445 Withed_Id => Unit_Id); 8446 8447 -- Generate: 8448 -- with Id; 8449 8450 -- Note that adding implicit with clauses is safe because analysis, 8451 -- resolution, and expansion have already taken place and it is not 8452 -- possible to interfere with visibility. 8453 8454 if No (Clause) then 8455 Clause := 8456 Make_With_Clause (Loc, 8457 Name => New_Occurrence_Of (Unit_Id, Loc)); 8458 8459 Set_Implicit_With (Clause); 8460 Set_Library_Unit (Clause, Unit_Cunit); 8461 8462 Append_To (Items, Clause); 8463 end if; 8464 8465 -- Mark the with clause depending on the pragma required 8466 8467 if Prag_Nam = Name_Elaborate then 8468 Set_Elaborate_Desirable (Clause); 8469 else 8470 Set_Elaborate_All_Desirable (Clause); 8471 end if; 8472 8473 -- The implicit Elaborate[_All] ensures the prior elaboration of 8474 -- the unit. Include the unit in the elaboration context of the 8475 -- main unit. 8476 8477 Set_With_Clause (EA_Id, Clause); 8478 8479 -- Output extra information on an implicit Elaborate[_All] pragma 8480 -- when switch -gnatel (info messages on implicit Elaborate[_All] 8481 -- pragmas is in effect. 8482 8483 if Elab_Info_Messages then 8484 Info_Implicit_Pragma; 8485 end if; 8486 end Ensure_Prior_Elaboration_Static; 8487 8488 ------------------------------- 8489 -- Finalize_Elaborated_Units -- 8490 ------------------------------- 8491 8492 procedure Finalize_Elaborated_Units is 8493 begin 8494 UA_Map.Destroy (Unit_To_Attributes_Map); 8495 end Finalize_Elaborated_Units; 8496 8497 --------------------------- 8498 -- Has_Prior_Elaboration -- 8499 --------------------------- 8500 8501 function Has_Prior_Elaboration 8502 (Unit_Id : Entity_Id; 8503 Context_OK : Boolean := False; 8504 Elab_Body_OK : Boolean := False; 8505 Same_Unit_OK : Boolean := False) return Boolean 8506 is 8507 EA_Id : constant Elaboration_Attributes_Id := 8508 Elaboration_Attributes_Of (Unit_Id); 8509 Main_Id : constant Entity_Id := Main_Unit_Entity; 8510 Unit_Prag : constant Node_Id := Elab_Pragma (EA_Id); 8511 Unit_With : constant Node_Id := With_Clause (EA_Id); 8512 8513 begin 8514 -- A preelaborated unit is always elaborated prior to the main unit 8515 8516 if Is_Preelaborated_Unit (Unit_Id) then 8517 return True; 8518 8519 -- An internal unit is always elaborated prior to a non-internal main 8520 -- unit. 8521 8522 elsif In_Internal_Unit (Unit_Id) 8523 and then not In_Internal_Unit (Main_Id) 8524 then 8525 return True; 8526 8527 -- A unit has prior elaboration if it appears within the context 8528 -- of the main unit. Consider this case only when requested by the 8529 -- caller. 8530 8531 elsif Context_OK 8532 and then (Present (Unit_Prag) or else Present (Unit_With)) 8533 then 8534 return True; 8535 8536 -- A unit whose body is elaborated together with its spec has prior 8537 -- elaboration except with respect to itself. Consider this case only 8538 -- when requested by the caller. 8539 8540 elsif Elab_Body_OK 8541 and then Has_Pragma_Elaborate_Body (Unit_Id) 8542 and then not Is_Same_Unit (Unit_Id, Main_Id) 8543 then 8544 return True; 8545 8546 -- A unit has no prior elaboration with respect to itself, but does 8547 -- not require any means of ensuring its own elaboration either. 8548 -- Treat this case as valid prior elaboration only when requested by 8549 -- the caller. 8550 8551 elsif Same_Unit_OK and then Is_Same_Unit (Unit_Id, Main_Id) then 8552 return True; 8553 end if; 8554 8555 return False; 8556 end Has_Prior_Elaboration; 8557 8558 --------------------------------- 8559 -- Initialize_Elaborated_Units -- 8560 --------------------------------- 8561 8562 procedure Initialize_Elaborated_Units is 8563 begin 8564 Unit_To_Attributes_Map := UA_Map.Create (250); 8565 end Initialize_Elaborated_Units; 8566 8567 ---------------------------------- 8568 -- Meet_Elaboration_Requirement -- 8569 ---------------------------------- 8570 8571 procedure Meet_Elaboration_Requirement 8572 (N : Node_Id; 8573 Targ_Id : Entity_Id; 8574 Req_Nam : Name_Id; 8575 In_State : Processing_In_State) 8576 is 8577 pragma Assert (Nam_In (Req_Nam, Name_Elaborate, Name_Elaborate_All)); 8578 8579 Main_Id : constant Entity_Id := Main_Unit_Entity; 8580 Unit_Id : constant Entity_Id := Find_Top_Unit (Targ_Id); 8581 8582 procedure Elaboration_Requirement_Error; 8583 pragma Inline (Elaboration_Requirement_Error); 8584 -- Emit an error concerning scenario N which has failed to meet the 8585 -- elaboration requirement. 8586 8587 function Find_Preelaboration_Pragma 8588 (Prag_Nam : Name_Id) return Node_Id; 8589 pragma Inline (Find_Preelaboration_Pragma); 8590 -- Traverse the visible declarations of unit Unit_Id and locate a 8591 -- source preelaboration-related pragma with name Prag_Nam. 8592 8593 procedure Info_Requirement_Met (Prag : Node_Id); 8594 pragma Inline (Info_Requirement_Met); 8595 -- Output information concerning pragma Prag which meets requirement 8596 -- Req_Nam. 8597 8598 ----------------------------------- 8599 -- Elaboration_Requirement_Error -- 8600 ----------------------------------- 8601 8602 procedure Elaboration_Requirement_Error is 8603 begin 8604 if Is_Suitable_Call (N) then 8605 Info_Call 8606 (Call => N, 8607 Subp_Id => Targ_Id, 8608 Info_Msg => False, 8609 In_SPARK => True); 8610 8611 elsif Is_Suitable_Instantiation (N) then 8612 Info_Instantiation 8613 (Inst => N, 8614 Gen_Id => Targ_Id, 8615 Info_Msg => False, 8616 In_SPARK => True); 8617 8618 elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then 8619 Error_Msg_N 8620 ("read of refinement constituents during elaboration in " 8621 & "SPARK", N); 8622 8623 elsif Is_Suitable_Variable_Reference (N) then 8624 Info_Variable_Reference 8625 (Ref => N, 8626 Var_Id => Targ_Id, 8627 Info_Msg => False, 8628 In_SPARK => True); 8629 8630 -- No other scenario may impose a requirement on the context of 8631 -- the main unit. 8632 8633 else 8634 pragma Assert (False); 8635 return; 8636 end if; 8637 8638 Error_Msg_Name_1 := Req_Nam; 8639 Error_Msg_Node_2 := Unit_Id; 8640 Error_Msg_NE ("\\unit & requires pragma % for &", N, Main_Id); 8641 8642 Output_Active_Scenarios (N, In_State); 8643 end Elaboration_Requirement_Error; 8644 8645 -------------------------------- 8646 -- Find_Preelaboration_Pragma -- 8647 -------------------------------- 8648 8649 function Find_Preelaboration_Pragma 8650 (Prag_Nam : Name_Id) return Node_Id 8651 is 8652 Spec : constant Node_Id := Parent (Unit_Id); 8653 Decl : Node_Id; 8654 8655 begin 8656 -- A preelaboration-related pragma comes from source and appears 8657 -- at the top of the visible declarations of a package. 8658 8659 if Nkind (Spec) = N_Package_Specification then 8660 Decl := First (Visible_Declarations (Spec)); 8661 while Present (Decl) loop 8662 if Comes_From_Source (Decl) then 8663 if Nkind (Decl) = N_Pragma 8664 and then Pragma_Name (Decl) = Prag_Nam 8665 then 8666 return Decl; 8667 8668 -- Otherwise the construct terminates the region where 8669 -- the preelaboration-related pragma may appear. 8670 8671 else 8672 exit; 8673 end if; 8674 end if; 8675 8676 Next (Decl); 8677 end loop; 8678 end if; 8679 8680 return Empty; 8681 end Find_Preelaboration_Pragma; 8682 8683 -------------------------- 8684 -- Info_Requirement_Met -- 8685 -------------------------- 8686 8687 procedure Info_Requirement_Met (Prag : Node_Id) is 8688 pragma Assert (Present (Prag)); 8689 8690 begin 8691 Error_Msg_Name_1 := Req_Nam; 8692 Error_Msg_Sloc := Sloc (Prag); 8693 Error_Msg_NE 8694 ("\\% requirement for unit & met by pragma #", N, Unit_Id); 8695 end Info_Requirement_Met; 8696 8697 -- Local variables 8698 8699 EA_Id : Elaboration_Attributes_Id; 8700 Elab_Nam : Name_Id; 8701 Req_Met : Boolean; 8702 Unit_Prag : Node_Id; 8703 8704 -- Start of processing for Meet_Elaboration_Requirement 8705 8706 begin 8707 -- Assume that the requirement has not been met 8708 8709 Req_Met := False; 8710 8711 -- If the target is within the main unit, either at the source level 8712 -- or through an instantiation, then there is no real requirement to 8713 -- meet because the main unit cannot force its own elaboration by 8714 -- means of an Elaborate[_All] pragma. Treat this case as valid 8715 -- coverage. 8716 8717 if In_Extended_Main_Code_Unit (Targ_Id) then 8718 Req_Met := True; 8719 8720 -- Otherwise the target resides in an external unit 8721 8722 -- The requirement is met when the target comes from an internal unit 8723 -- because such a unit is elaborated prior to a non-internal unit. 8724 8725 elsif In_Internal_Unit (Unit_Id) 8726 and then not In_Internal_Unit (Main_Id) 8727 then 8728 Req_Met := True; 8729 8730 -- The requirement is met when the target comes from a preelaborated 8731 -- unit. This portion must parallel predicate Is_Preelaborated_Unit. 8732 8733 elsif Is_Preelaborated_Unit (Unit_Id) then 8734 Req_Met := True; 8735 8736 -- Output extra information when switch -gnatel (info messages on 8737 -- implicit Elaborate[_All] pragmas. 8738 8739 if Elab_Info_Messages 8740 and then not In_State.Suppress_Info_Messages 8741 then 8742 if Is_Preelaborated (Unit_Id) then 8743 Elab_Nam := Name_Preelaborate; 8744 8745 elsif Is_Pure (Unit_Id) then 8746 Elab_Nam := Name_Pure; 8747 8748 elsif Is_Remote_Call_Interface (Unit_Id) then 8749 Elab_Nam := Name_Remote_Call_Interface; 8750 8751 elsif Is_Remote_Types (Unit_Id) then 8752 Elab_Nam := Name_Remote_Types; 8753 8754 else 8755 pragma Assert (Is_Shared_Passive (Unit_Id)); 8756 Elab_Nam := Name_Shared_Passive; 8757 end if; 8758 8759 Info_Requirement_Met (Find_Preelaboration_Pragma (Elab_Nam)); 8760 end if; 8761 8762 -- Determine whether the context of the main unit has a pragma strong 8763 -- enough to meet the requirement. 8764 8765 else 8766 EA_Id := Elaboration_Attributes_Of (Unit_Id); 8767 Unit_Prag := Elab_Pragma (EA_Id); 8768 8769 -- The pragma must be either Elaborate_All or be as strong as the 8770 -- requirement. 8771 8772 if Present (Unit_Prag) 8773 and then Nam_In (Pragma_Name (Unit_Prag), Name_Elaborate_All, 8774 Req_Nam) 8775 then 8776 Req_Met := True; 8777 8778 -- Output extra information when switch -gnatel (info messages 8779 -- on implicit Elaborate[_All] pragmas. 8780 8781 if Elab_Info_Messages 8782 and then not In_State.Suppress_Info_Messages 8783 then 8784 Info_Requirement_Met (Unit_Prag); 8785 end if; 8786 end if; 8787 end if; 8788 8789 -- The requirement was not met by the context of the main unit, issue 8790 -- an error. 8791 8792 if not Req_Met then 8793 Elaboration_Requirement_Error; 8794 end if; 8795 end Meet_Elaboration_Requirement; 8796 8797 ------------- 8798 -- Present -- 8799 ------------- 8800 8801 function Present (EA_Id : Elaboration_Attributes_Id) return Boolean is 8802 begin 8803 return EA_Id /= No_Elaboration_Attributes; 8804 end Present; 8805 8806 --------------------- 8807 -- Set_Elab_Pragma -- 8808 --------------------- 8809 8810 procedure Set_Elab_Pragma 8811 (EA_Id : Elaboration_Attributes_Id; 8812 Prag : Node_Id) 8813 is 8814 pragma Assert (Present (EA_Id)); 8815 begin 8816 Elaboration_Attributes.Table (EA_Id).Elab_Pragma := Prag; 8817 end Set_Elab_Pragma; 8818 8819 --------------------- 8820 -- Set_With_Clause -- 8821 --------------------- 8822 8823 procedure Set_With_Clause 8824 (EA_Id : Elaboration_Attributes_Id; 8825 Clause : Node_Id) 8826 is 8827 pragma Assert (Present (EA_Id)); 8828 begin 8829 Elaboration_Attributes.Table (EA_Id).With_Clause := Clause; 8830 end Set_With_Clause; 8831 8832 ----------------- 8833 -- With_Clause -- 8834 ----------------- 8835 8836 function With_Clause 8837 (EA_Id : Elaboration_Attributes_Id) return Node_Id 8838 is 8839 pragma Assert (Present (EA_Id)); 8840 begin 8841 return Elaboration_Attributes.Table (EA_Id).With_Clause; 8842 end With_Clause; 8843 end Elaborated_Units; 8844 8845 ------------------------------ 8846 -- Elaboration_Phase_Active -- 8847 ------------------------------ 8848 8849 function Elaboration_Phase_Active return Boolean is 8850 begin 8851 return Elaboration_Phase = Active; 8852 end Elaboration_Phase_Active; 8853 8854 ---------------------------------- 8855 -- Finalize_All_Data_Structures -- 8856 ---------------------------------- 8857 8858 procedure Finalize_All_Data_Structures is 8859 begin 8860 Finalize_Body_Processor; 8861 Finalize_Early_Call_Region_Processor; 8862 Finalize_Elaborated_Units; 8863 Finalize_Internal_Representation; 8864 Finalize_Invocation_Graph; 8865 Finalize_Scenario_Storage; 8866 end Finalize_All_Data_Structures; 8867 8868 ----------------------------- 8869 -- Find_Enclosing_Instance -- 8870 ----------------------------- 8871 8872 function Find_Enclosing_Instance (N : Node_Id) return Node_Id is 8873 Par : Node_Id; 8874 8875 begin 8876 -- Climb the parent chain looking for an enclosing instance spec or body 8877 8878 Par := N; 8879 while Present (Par) loop 8880 if Nkind_In (Par, N_Package_Body, 8881 N_Package_Declaration, 8882 N_Subprogram_Body, 8883 N_Subprogram_Declaration) 8884 and then Is_Generic_Instance (Unique_Defining_Entity (Par)) 8885 then 8886 return Par; 8887 end if; 8888 8889 Par := Parent (Par); 8890 end loop; 8891 8892 return Empty; 8893 end Find_Enclosing_Instance; 8894 8895 -------------------------- 8896 -- Find_Enclosing_Level -- 8897 -------------------------- 8898 8899 function Find_Enclosing_Level (N : Node_Id) return Enclosing_Level_Kind is 8900 function Level_Of (Unit : Node_Id) return Enclosing_Level_Kind; 8901 pragma Inline (Level_Of); 8902 -- Obtain the corresponding level of unit Unit 8903 8904 -------------- 8905 -- Level_Of -- 8906 -------------- 8907 8908 function Level_Of (Unit : Node_Id) return Enclosing_Level_Kind is 8909 Spec_Id : Entity_Id; 8910 8911 begin 8912 if Nkind (Unit) in N_Generic_Instantiation then 8913 return Instantiation_Level; 8914 8915 elsif Nkind (Unit) = N_Generic_Package_Declaration then 8916 return Generic_Spec_Level; 8917 8918 elsif Nkind (Unit) = N_Package_Declaration then 8919 return Library_Spec_Level; 8920 8921 elsif Nkind (Unit) = N_Package_Body then 8922 Spec_Id := Corresponding_Spec (Unit); 8923 8924 -- The body belongs to a generic package 8925 8926 if Present (Spec_Id) 8927 and then Ekind (Spec_Id) = E_Generic_Package 8928 then 8929 return Generic_Body_Level; 8930 8931 -- Otherwise the body belongs to a non-generic package. This also 8932 -- treats an illegal package body without a corresponding spec as 8933 -- a non-generic package body. 8934 8935 else 8936 return Library_Body_Level; 8937 end if; 8938 end if; 8939 8940 return No_Level; 8941 end Level_Of; 8942 8943 -- Local variables 8944 8945 Context : Node_Id; 8946 Curr : Node_Id; 8947 Prev : Node_Id; 8948 8949 -- Start of processing for Find_Enclosing_Level 8950 8951 begin 8952 -- Call markers and instantiations which appear at the declaration level 8953 -- but are later relocated in a different context retain their original 8954 -- declaration level. 8955 8956 if Nkind_In (N, N_Call_Marker, 8957 N_Function_Instantiation, 8958 N_Package_Instantiation, 8959 N_Procedure_Instantiation) 8960 and then Is_Declaration_Level_Node (N) 8961 then 8962 return Declaration_Level; 8963 end if; 8964 8965 -- Climb the parent chain looking at the enclosing levels 8966 8967 Prev := N; 8968 Curr := Parent (Prev); 8969 while Present (Curr) loop 8970 8971 -- A traversal from a subunit continues via the corresponding stub 8972 8973 if Nkind (Curr) = N_Subunit then 8974 Curr := Corresponding_Stub (Curr); 8975 8976 -- The current construct is a package. Packages are ignored because 8977 -- they are always elaborated when the enclosing context is invoked 8978 -- or elaborated. 8979 8980 elsif Nkind_In (Curr, N_Package_Body, N_Package_Declaration) then 8981 null; 8982 8983 -- The current construct is a block statement 8984 8985 elsif Nkind (Curr) = N_Block_Statement then 8986 8987 -- Ignore internally generated blocks created by the expander for 8988 -- various purposes such as abort defer/undefer. 8989 8990 if not Comes_From_Source (Curr) then 8991 null; 8992 8993 -- If the traversal came from the handled sequence of statments, 8994 -- then the node appears at the level of the enclosing construct. 8995 -- This is a more reliable test because transients scopes within 8996 -- the declarative region of the encapsulator are hard to detect. 8997 8998 elsif Nkind (Prev) = N_Handled_Sequence_Of_Statements 8999 and then Handled_Statement_Sequence (Curr) = Prev 9000 then 9001 return Find_Enclosing_Level (Parent (Curr)); 9002 9003 -- Otherwise the traversal came from the declarations, the node is 9004 -- at the declaration level. 9005 9006 else 9007 return Declaration_Level; 9008 end if; 9009 9010 -- The current construct is a declaration-level encapsulator 9011 9012 elsif Nkind_In (Curr, N_Entry_Body, 9013 N_Subprogram_Body, 9014 N_Task_Body) 9015 then 9016 -- If the traversal came from the handled sequence of statments, 9017 -- then the node cannot possibly appear at any level. This is 9018 -- a more reliable test because transients scopes within the 9019 -- declarative region of the encapsulator are hard to detect. 9020 9021 if Nkind (Prev) = N_Handled_Sequence_Of_Statements 9022 and then Handled_Statement_Sequence (Curr) = Prev 9023 then 9024 return No_Level; 9025 9026 -- Otherwise the traversal came from the declarations, the node is 9027 -- at the declaration level. 9028 9029 else 9030 return Declaration_Level; 9031 end if; 9032 9033 -- The current construct is a non-library-level encapsulator which 9034 -- indicates that the node cannot possibly appear at any level. Note 9035 -- that the check must come after the declaration-level check because 9036 -- both predicates share certain nodes. 9037 9038 elsif Is_Non_Library_Level_Encapsulator (Curr) then 9039 Context := Parent (Curr); 9040 9041 -- The sole exception is when the encapsulator is the compilation 9042 -- utit itself because the compilation unit node requires special 9043 -- processing (see below). 9044 9045 if Present (Context) 9046 and then Nkind (Context) = N_Compilation_Unit 9047 then 9048 null; 9049 9050 -- Otherwise the node is not at any level 9051 9052 else 9053 return No_Level; 9054 end if; 9055 9056 -- The current construct is a compilation unit. The node appears at 9057 -- the [generic] library level when the unit is a [generic] package. 9058 9059 elsif Nkind (Curr) = N_Compilation_Unit then 9060 return Level_Of (Unit (Curr)); 9061 end if; 9062 9063 Prev := Curr; 9064 Curr := Parent (Prev); 9065 end loop; 9066 9067 return No_Level; 9068 end Find_Enclosing_Level; 9069 9070 ------------------- 9071 -- Find_Top_Unit -- 9072 ------------------- 9073 9074 function Find_Top_Unit (N : Node_Or_Entity_Id) return Entity_Id is 9075 begin 9076 return Find_Unit_Entity (Unit (Cunit (Get_Top_Level_Code_Unit (N)))); 9077 end Find_Top_Unit; 9078 9079 ---------------------- 9080 -- Find_Unit_Entity -- 9081 ---------------------- 9082 9083 function Find_Unit_Entity (N : Node_Id) return Entity_Id is 9084 Context : constant Node_Id := Parent (N); 9085 Orig_N : constant Node_Id := Original_Node (N); 9086 9087 begin 9088 -- The unit denotes a package body of an instantiation which acts as 9089 -- a compilation unit. The proper entity is that of the package spec. 9090 9091 if Nkind (N) = N_Package_Body 9092 and then Nkind (Orig_N) = N_Package_Instantiation 9093 and then Nkind (Context) = N_Compilation_Unit 9094 then 9095 return Corresponding_Spec (N); 9096 9097 -- The unit denotes an anonymous package created to wrap a subprogram 9098 -- instantiation which acts as a compilation unit. The proper entity is 9099 -- that of the "related instance". 9100 9101 elsif Nkind (N) = N_Package_Declaration 9102 and then Nkind_In (Orig_N, N_Function_Instantiation, 9103 N_Procedure_Instantiation) 9104 and then Nkind (Context) = N_Compilation_Unit 9105 then 9106 return Related_Instance (Defining_Entity (N)); 9107 9108 -- The unit denotes a concurrent body acting as a subunit. Such bodies 9109 -- are generally rewritten into null statements. The proper entity is 9110 -- that of the "original node". 9111 9112 elsif Nkind (N) = N_Subunit 9113 and then Nkind (Proper_Body (N)) = N_Null_Statement 9114 and then Nkind_In (Original_Node (Proper_Body (N)), N_Protected_Body, 9115 N_Task_Body) 9116 then 9117 return Defining_Entity (Original_Node (Proper_Body (N))); 9118 9119 -- Otherwise the proper entity is the defining entity 9120 9121 else 9122 return Defining_Entity (N); 9123 end if; 9124 end Find_Unit_Entity; 9125 9126 ----------------------- 9127 -- First_Formal_Type -- 9128 ----------------------- 9129 9130 function First_Formal_Type (Subp_Id : Entity_Id) return Entity_Id is 9131 Formal_Id : constant Entity_Id := First_Formal (Subp_Id); 9132 Typ : Entity_Id; 9133 9134 begin 9135 if Present (Formal_Id) then 9136 Typ := Etype (Formal_Id); 9137 9138 -- Handle various combinations of concurrent and private types 9139 9140 loop 9141 if Ekind_In (Typ, E_Protected_Type, E_Task_Type) 9142 and then Present (Anonymous_Object (Typ)) 9143 then 9144 Typ := Anonymous_Object (Typ); 9145 9146 elsif Is_Concurrent_Record_Type (Typ) then 9147 Typ := Corresponding_Concurrent_Type (Typ); 9148 9149 elsif Is_Private_Type (Typ) and then Present (Full_View (Typ)) then 9150 Typ := Full_View (Typ); 9151 9152 else 9153 exit; 9154 end if; 9155 end loop; 9156 9157 return Typ; 9158 end if; 9159 9160 return Empty; 9161 end First_Formal_Type; 9162 9163 ------------------------------ 9164 -- Guaranteed_ABE_Processor -- 9165 ------------------------------ 9166 9167 package body Guaranteed_ABE_Processor is 9168 function Is_Guaranteed_ABE 9169 (N : Node_Id; 9170 Target_Decl : Node_Id; 9171 Target_Body : Node_Id) return Boolean; 9172 pragma Inline (Is_Guaranteed_ABE); 9173 -- Determine whether scenario N with a target described by its initial 9174 -- declaration Target_Decl and body Target_Decl results in a guaranteed 9175 -- ABE. 9176 9177 procedure Process_Guaranteed_ABE_Activation 9178 (Call : Node_Id; 9179 Call_Rep : Scenario_Rep_Id; 9180 Obj_Id : Entity_Id; 9181 Obj_Rep : Target_Rep_Id; 9182 Task_Typ : Entity_Id; 9183 Task_Rep : Target_Rep_Id; 9184 In_State : Processing_In_State); 9185 pragma Inline (Process_Guaranteed_ABE_Activation); 9186 -- Perform common guaranteed ABE checks and diagnostics for activation 9187 -- call Call which activates object Obj_Id of task type Task_Typ. Formal 9188 -- Call_Rep denotes the representation of the call. Obj_Rep denotes the 9189 -- representation of the object. Task_Rep denotes the representation of 9190 -- the task type. In_State is the current state of the Processing phase. 9191 9192 procedure Process_Guaranteed_ABE_Call 9193 (Call : Node_Id; 9194 Call_Rep : Scenario_Rep_Id; 9195 In_State : Processing_In_State); 9196 pragma Inline (Process_Guaranteed_ABE_Call); 9197 -- Perform common guaranteed ABE checks and diagnostics for call Call 9198 -- with representation Call_Rep. In_State denotes the current state of 9199 -- the Processing phase. 9200 9201 procedure Process_Guaranteed_ABE_Instantiation 9202 (Inst : Node_Id; 9203 Inst_Rep : Scenario_Rep_Id; 9204 In_State : Processing_In_State); 9205 pragma Inline (Process_Guaranteed_ABE_Instantiation); 9206 -- Perform common guaranteed ABE checks and diagnostics for instance 9207 -- Inst with representation Inst_Rep. In_State is the current state of 9208 -- the Processing phase. 9209 9210 ----------------------- 9211 -- Is_Guaranteed_ABE -- 9212 ----------------------- 9213 9214 function Is_Guaranteed_ABE 9215 (N : Node_Id; 9216 Target_Decl : Node_Id; 9217 Target_Body : Node_Id) return Boolean 9218 is 9219 begin 9220 -- Avoid cascaded errors if there were previous serious infractions. 9221 -- As a result the scenario will not be treated as a guaranteed ABE. 9222 -- This behaviour parallels that of the old ABE mechanism. 9223 9224 if Serious_Errors_Detected > 0 then 9225 return False; 9226 9227 -- The scenario and the target appear in the same context ignoring 9228 -- enclosing library levels. 9229 9230 elsif In_Same_Context (N, Target_Decl) then 9231 9232 -- The target body has already been encountered. The scenario 9233 -- results in a guaranteed ABE if it appears prior to the body. 9234 9235 if Present (Target_Body) then 9236 return Earlier_In_Extended_Unit (N, Target_Body); 9237 9238 -- Otherwise the body has not been encountered yet. The scenario 9239 -- is a guaranteed ABE since the body will appear later. It is 9240 -- assumed that the caller has already ensured that the scenario 9241 -- is ABE-safe because optional bodies are not considered here. 9242 9243 else 9244 return True; 9245 end if; 9246 end if; 9247 9248 return False; 9249 end Is_Guaranteed_ABE; 9250 9251 ---------------------------- 9252 -- Process_Guaranteed_ABE -- 9253 ---------------------------- 9254 9255 procedure Process_Guaranteed_ABE 9256 (N : Node_Id; 9257 In_State : Processing_In_State) 9258 is 9259 Scen : constant Node_Id := Scenario (N); 9260 Scen_Rep : Scenario_Rep_Id; 9261 9262 begin 9263 -- Add the current scenario to the stack of active scenarios 9264 9265 Push_Active_Scenario (Scen); 9266 9267 -- Only calls, instantiations, and task activations may result in a 9268 -- guaranteed ABE. 9269 9270 -- Call or task activation 9271 9272 if Is_Suitable_Call (Scen) then 9273 Scen_Rep := Scenario_Representation_Of (Scen, In_State); 9274 9275 if Kind (Scen_Rep) = Call_Scenario then 9276 Process_Guaranteed_ABE_Call 9277 (Call => Scen, 9278 Call_Rep => Scen_Rep, 9279 In_State => In_State); 9280 9281 else 9282 pragma Assert (Kind (Scen_Rep) = Task_Activation_Scenario); 9283 9284 Process_Activation 9285 (Call => Scen, 9286 Call_Rep => Scenario_Representation_Of (Scen, In_State), 9287 Processor => Process_Guaranteed_ABE_Activation'Access, 9288 In_State => In_State); 9289 end if; 9290 9291 -- Instantiation 9292 9293 elsif Is_Suitable_Instantiation (Scen) then 9294 Process_Guaranteed_ABE_Instantiation 9295 (Inst => Scen, 9296 Inst_Rep => Scenario_Representation_Of (Scen, In_State), 9297 In_State => In_State); 9298 end if; 9299 9300 -- Remove the current scenario from the stack of active scenarios 9301 -- once all ABE diagnostics and checks have been performed. 9302 9303 Pop_Active_Scenario (Scen); 9304 end Process_Guaranteed_ABE; 9305 9306 --------------------------------------- 9307 -- Process_Guaranteed_ABE_Activation -- 9308 --------------------------------------- 9309 9310 procedure Process_Guaranteed_ABE_Activation 9311 (Call : Node_Id; 9312 Call_Rep : Scenario_Rep_Id; 9313 Obj_Id : Entity_Id; 9314 Obj_Rep : Target_Rep_Id; 9315 Task_Typ : Entity_Id; 9316 Task_Rep : Target_Rep_Id; 9317 In_State : Processing_In_State) 9318 is 9319 Spec_Decl : constant Node_Id := Spec_Declaration (Task_Rep); 9320 9321 Check_OK : constant Boolean := 9322 not In_State.Suppress_Checks 9323 and then Ghost_Mode_Of (Obj_Rep) /= Is_Ignored 9324 and then Ghost_Mode_Of (Task_Rep) /= Is_Ignored 9325 and then Elaboration_Checks_OK (Obj_Rep) 9326 and then Elaboration_Checks_OK (Task_Rep); 9327 -- A run-time ABE check may be installed only when the object and the 9328 -- task type have active elaboration checks, and both are not ignored 9329 -- Ghost constructs. 9330 9331 begin 9332 -- Nothing to do when the root scenario appears at the declaration 9333 -- level and the task is in the same unit, but outside this context. 9334 -- 9335 -- task type Task_Typ; -- task declaration 9336 -- 9337 -- procedure Proc is 9338 -- function A ... is 9339 -- begin 9340 -- if Some_Condition then 9341 -- declare 9342 -- T : Task_Typ; 9343 -- begin 9344 -- <activation call> -- activation site 9345 -- end; 9346 -- ... 9347 -- end A; 9348 -- 9349 -- X : ... := A; -- root scenario 9350 -- ... 9351 -- 9352 -- task body Task_Typ is 9353 -- ... 9354 -- end Task_Typ; 9355 -- 9356 -- In the example above, the context of X is the declarative list 9357 -- of Proc. The "elaboration" of X may reach the activation of T 9358 -- whose body is defined outside of X's context. The task body is 9359 -- relevant only when Proc is invoked, but this happens only in 9360 -- "normal" elaboration, therefore the task body must not be 9361 -- considered if this is not the case. 9362 9363 if Is_Up_Level_Target 9364 (Targ_Decl => Spec_Decl, 9365 In_State => In_State) 9366 then 9367 return; 9368 9369 -- Nothing to do when the activation is ABE-safe 9370 -- 9371 -- generic 9372 -- package Gen is 9373 -- task type Task_Typ; 9374 -- end Gen; 9375 -- 9376 -- package body Gen is 9377 -- task body Task_Typ is 9378 -- begin 9379 -- ... 9380 -- end Task_Typ; 9381 -- end Gen; 9382 -- 9383 -- with Gen; 9384 -- procedure Main is 9385 -- package Nested is 9386 -- package Inst is new Gen; 9387 -- T : Inst.Task_Typ; 9388 -- end Nested; -- safe activation 9389 -- ... 9390 9391 elsif Is_Safe_Activation (Call, Task_Rep) then 9392 return; 9393 9394 -- An activation call leads to a guaranteed ABE when the activation 9395 -- call and the task appear within the same context ignoring library 9396 -- levels, and the body of the task has not been seen yet or appears 9397 -- after the activation call. 9398 -- 9399 -- procedure Guaranteed_ABE is 9400 -- task type Task_Typ; 9401 -- 9402 -- package Nested is 9403 -- T : Task_Typ; 9404 -- <activation call> -- guaranteed ABE 9405 -- end Nested; 9406 -- 9407 -- task body Task_Typ is 9408 -- ... 9409 -- end Task_Typ; 9410 -- ... 9411 9412 elsif Is_Guaranteed_ABE 9413 (N => Call, 9414 Target_Decl => Spec_Decl, 9415 Target_Body => Body_Declaration (Task_Rep)) 9416 then 9417 if Elaboration_Warnings_OK (Call_Rep) then 9418 Error_Msg_Sloc := Sloc (Call); 9419 Error_Msg_N 9420 ("??task & will be activated # before elaboration of its " 9421 & "body", Obj_Id); 9422 Error_Msg_N 9423 ("\Program_Error will be raised at run time", Obj_Id); 9424 end if; 9425 9426 -- Mark the activation call as a guaranteed ABE 9427 9428 Set_Is_Known_Guaranteed_ABE (Call); 9429 9430 -- Install a run-time ABE failue because this activation call will 9431 -- always result in an ABE. 9432 9433 if Check_OK then 9434 Install_Scenario_ABE_Failure 9435 (N => Call, 9436 Targ_Id => Task_Typ, 9437 Targ_Rep => Task_Rep, 9438 Disable => Obj_Rep); 9439 end if; 9440 end if; 9441 end Process_Guaranteed_ABE_Activation; 9442 9443 --------------------------------- 9444 -- Process_Guaranteed_ABE_Call -- 9445 --------------------------------- 9446 9447 procedure Process_Guaranteed_ABE_Call 9448 (Call : Node_Id; 9449 Call_Rep : Scenario_Rep_Id; 9450 In_State : Processing_In_State) 9451 is 9452 Subp_Id : constant Entity_Id := Target (Call_Rep); 9453 Subp_Rep : constant Target_Rep_Id := 9454 Target_Representation_Of (Subp_Id, In_State); 9455 Spec_Decl : constant Node_Id := Spec_Declaration (Subp_Rep); 9456 9457 Check_OK : constant Boolean := 9458 not In_State.Suppress_Checks 9459 and then Ghost_Mode_Of (Call_Rep) /= Is_Ignored 9460 and then Ghost_Mode_Of (Subp_Rep) /= Is_Ignored 9461 and then Elaboration_Checks_OK (Call_Rep) 9462 and then Elaboration_Checks_OK (Subp_Rep); 9463 -- A run-time ABE check may be installed only when both the call 9464 -- and the target have active elaboration checks, and both are not 9465 -- ignored Ghost constructs. 9466 9467 begin 9468 -- Nothing to do when the root scenario appears at the declaration 9469 -- level and the target is in the same unit but outside this context. 9470 -- 9471 -- function B ...; -- target declaration 9472 -- 9473 -- procedure Proc is 9474 -- function A ... is 9475 -- begin 9476 -- if Some_Condition then 9477 -- return B; -- call site 9478 -- ... 9479 -- end A; 9480 -- 9481 -- X : ... := A; -- root scenario 9482 -- ... 9483 -- 9484 -- function B ... is 9485 -- ... 9486 -- end B; 9487 -- 9488 -- In the example above, the context of X is the declarative region 9489 -- of Proc. The "elaboration" of X may eventually reach B which is 9490 -- defined outside of X's context. B is relevant only when Proc is 9491 -- invoked, but this happens only by means of "normal" elaboration, 9492 -- therefore B must not be considered if this is not the case. 9493 9494 if Is_Up_Level_Target 9495 (Targ_Decl => Spec_Decl, 9496 In_State => In_State) 9497 then 9498 return; 9499 9500 -- Nothing to do when the call is ABE-safe 9501 -- 9502 -- generic 9503 -- function Gen ...; 9504 -- 9505 -- function Gen ... is 9506 -- begin 9507 -- ... 9508 -- end Gen; 9509 -- 9510 -- with Gen; 9511 -- procedure Main is 9512 -- function Inst is new Gen; 9513 -- X : ... := Inst; -- safe call 9514 -- ... 9515 9516 elsif Is_Safe_Call (Call, Subp_Id, Subp_Rep) then 9517 return; 9518 9519 -- A call leads to a guaranteed ABE when the call and the target 9520 -- appear within the same context ignoring library levels, and the 9521 -- body of the target has not been seen yet or appears after the 9522 -- call. 9523 -- 9524 -- procedure Guaranteed_ABE is 9525 -- function Func ...; 9526 -- 9527 -- package Nested is 9528 -- Obj : ... := Func; -- guaranteed ABE 9529 -- end Nested; 9530 -- 9531 -- function Func ... is 9532 -- ... 9533 -- end Func; 9534 -- ... 9535 9536 elsif Is_Guaranteed_ABE 9537 (N => Call, 9538 Target_Decl => Spec_Decl, 9539 Target_Body => Body_Declaration (Subp_Rep)) 9540 then 9541 if Elaboration_Warnings_OK (Call_Rep) then 9542 Error_Msg_NE 9543 ("??cannot call & before body seen", Call, Subp_Id); 9544 Error_Msg_N ("\Program_Error will be raised at run time", Call); 9545 end if; 9546 9547 -- Mark the call as a guarnateed ABE 9548 9549 Set_Is_Known_Guaranteed_ABE (Call); 9550 9551 -- Install a run-time ABE failure because the call will always 9552 -- result in an ABE. 9553 9554 if Check_OK then 9555 Install_Scenario_ABE_Failure 9556 (N => Call, 9557 Targ_Id => Subp_Id, 9558 Targ_Rep => Subp_Rep, 9559 Disable => Call_Rep); 9560 end if; 9561 end if; 9562 end Process_Guaranteed_ABE_Call; 9563 9564 ------------------------------------------ 9565 -- Process_Guaranteed_ABE_Instantiation -- 9566 ------------------------------------------ 9567 9568 procedure Process_Guaranteed_ABE_Instantiation 9569 (Inst : Node_Id; 9570 Inst_Rep : Scenario_Rep_Id; 9571 In_State : Processing_In_State) 9572 is 9573 Gen_Id : constant Entity_Id := Target (Inst_Rep); 9574 Gen_Rep : constant Target_Rep_Id := 9575 Target_Representation_Of (Gen_Id, In_State); 9576 Spec_Decl : constant Node_Id := Spec_Declaration (Gen_Rep); 9577 9578 Check_OK : constant Boolean := 9579 not In_State.Suppress_Checks 9580 and then Ghost_Mode_Of (Inst_Rep) /= Is_Ignored 9581 and then Ghost_Mode_Of (Gen_Rep) /= Is_Ignored 9582 and then Elaboration_Checks_OK (Inst_Rep) 9583 and then Elaboration_Checks_OK (Gen_Rep); 9584 -- A run-time ABE check may be installed only when both the instance 9585 -- and the generic have active elaboration checks and both are not 9586 -- ignored Ghost constructs. 9587 9588 begin 9589 -- Nothing to do when the root scenario appears at the declaration 9590 -- level and the generic is in the same unit, but outside this 9591 -- context. 9592 -- 9593 -- generic 9594 -- procedure Gen is ...; -- generic declaration 9595 -- 9596 -- procedure Proc is 9597 -- function A ... is 9598 -- begin 9599 -- if Some_Condition then 9600 -- declare 9601 -- procedure I is new Gen; -- instantiation site 9602 -- ... 9603 -- ... 9604 -- end A; 9605 -- 9606 -- X : ... := A; -- root scenario 9607 -- ... 9608 -- 9609 -- procedure Gen is 9610 -- ... 9611 -- end Gen; 9612 -- 9613 -- In the example above, the context of X is the declarative region 9614 -- of Proc. The "elaboration" of X may eventually reach Gen which 9615 -- appears outside of X's context. Gen is relevant only when Proc is 9616 -- invoked, but this happens only by means of "normal" elaboration, 9617 -- therefore Gen must not be considered if this is not the case. 9618 9619 if Is_Up_Level_Target 9620 (Targ_Decl => Spec_Decl, 9621 In_State => In_State) 9622 then 9623 return; 9624 9625 -- Nothing to do when the instantiation is ABE-safe 9626 -- 9627 -- generic 9628 -- package Gen is 9629 -- ... 9630 -- end Gen; 9631 -- 9632 -- package body Gen is 9633 -- ... 9634 -- end Gen; 9635 -- 9636 -- with Gen; 9637 -- procedure Main is 9638 -- package Inst is new Gen (ABE); -- safe instantiation 9639 -- ... 9640 9641 elsif Is_Safe_Instantiation (Inst, Gen_Id, Gen_Rep) then 9642 return; 9643 9644 -- An instantiation leads to a guaranteed ABE when the instantiation 9645 -- and the generic appear within the same context ignoring library 9646 -- levels, and the body of the generic has not been seen yet or 9647 -- appears after the instantiation. 9648 -- 9649 -- procedure Guaranteed_ABE is 9650 -- generic 9651 -- procedure Gen; 9652 -- 9653 -- package Nested is 9654 -- procedure Inst is new Gen; -- guaranteed ABE 9655 -- end Nested; 9656 -- 9657 -- procedure Gen is 9658 -- ... 9659 -- end Gen; 9660 -- ... 9661 9662 elsif Is_Guaranteed_ABE 9663 (N => Inst, 9664 Target_Decl => Spec_Decl, 9665 Target_Body => Body_Declaration (Gen_Rep)) 9666 then 9667 if Elaboration_Warnings_OK (Inst_Rep) then 9668 Error_Msg_NE 9669 ("??cannot instantiate & before body seen", Inst, Gen_Id); 9670 Error_Msg_N ("\Program_Error will be raised at run time", Inst); 9671 end if; 9672 9673 -- Mark the instantiation as a guarantee ABE. This automatically 9674 -- suppresses the instantiation of the generic body. 9675 9676 Set_Is_Known_Guaranteed_ABE (Inst); 9677 9678 -- Install a run-time ABE failure because the instantiation will 9679 -- always result in an ABE. 9680 9681 if Check_OK then 9682 Install_Scenario_ABE_Failure 9683 (N => Inst, 9684 Targ_Id => Gen_Id, 9685 Targ_Rep => Gen_Rep, 9686 Disable => Inst_Rep); 9687 end if; 9688 end if; 9689 end Process_Guaranteed_ABE_Instantiation; 9690 end Guaranteed_ABE_Processor; 9691 9692 -------------- 9693 -- Has_Body -- 9694 -------------- 9695 9696 function Has_Body (Pack_Decl : Node_Id) return Boolean is 9697 function Find_Corresponding_Body (Spec_Id : Entity_Id) return Node_Id; 9698 pragma Inline (Find_Corresponding_Body); 9699 -- Try to locate the corresponding body of spec Spec_Id. If no body is 9700 -- found, return Empty. 9701 9702 function Find_Body 9703 (Spec_Id : Entity_Id; 9704 From : Node_Id) return Node_Id; 9705 pragma Inline (Find_Body); 9706 -- Try to locate the corresponding body of spec Spec_Id in the node list 9707 -- which follows arbitrary node From. If no body is found, return Empty. 9708 9709 function Load_Package_Body (Unit_Nam : Unit_Name_Type) return Node_Id; 9710 pragma Inline (Load_Package_Body); 9711 -- Attempt to load the body of unit Unit_Nam. If the load failed, return 9712 -- Empty. If the compilation will not generate code, return Empty. 9713 9714 ----------------------------- 9715 -- Find_Corresponding_Body -- 9716 ----------------------------- 9717 9718 function Find_Corresponding_Body (Spec_Id : Entity_Id) return Node_Id is 9719 Context : constant Entity_Id := Scope (Spec_Id); 9720 Spec_Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id); 9721 Body_Decl : Node_Id; 9722 Body_Id : Entity_Id; 9723 9724 begin 9725 if Is_Compilation_Unit (Spec_Id) then 9726 Body_Id := Corresponding_Body (Spec_Decl); 9727 9728 if Present (Body_Id) then 9729 return Unit_Declaration_Node (Body_Id); 9730 9731 -- The package is at the library and requires a body. Load the 9732 -- corresponding body because the optional body may be declared 9733 -- there. 9734 9735 elsif Unit_Requires_Body (Spec_Id) then 9736 return 9737 Load_Package_Body 9738 (Get_Body_Name (Unit_Name (Get_Source_Unit (Spec_Decl)))); 9739 9740 -- Otherwise there is no optional body 9741 9742 else 9743 return Empty; 9744 end if; 9745 9746 -- The immediate context is a package. The optional body may be 9747 -- within the body of that package. 9748 9749 -- procedure Proc is 9750 -- package Nested_1 is 9751 -- package Nested_2 is 9752 -- generic 9753 -- package Pack is 9754 -- end Pack; 9755 -- end Nested_2; 9756 -- end Nested_1; 9757 9758 -- package body Nested_1 is 9759 -- package body Nested_2 is separate; 9760 -- end Nested_1; 9761 9762 -- separate (Proc.Nested_1.Nested_2) 9763 -- package body Nested_2 is 9764 -- package body Pack is -- optional body 9765 -- ... 9766 -- end Pack; 9767 -- end Nested_2; 9768 9769 elsif Is_Package_Or_Generic_Package (Context) then 9770 Body_Decl := Find_Corresponding_Body (Context); 9771 9772 -- The optional body is within the body of the enclosing package 9773 9774 if Present (Body_Decl) then 9775 return 9776 Find_Body 9777 (Spec_Id => Spec_Id, 9778 From => First (Declarations (Body_Decl))); 9779 9780 -- Otherwise the enclosing package does not have a body. This may 9781 -- be the result of an error or a genuine lack of a body. 9782 9783 else 9784 return Empty; 9785 end if; 9786 9787 -- Otherwise the immediate context is a body. The optional body may 9788 -- be within the same list as the spec. 9789 9790 -- procedure Proc is 9791 -- generic 9792 -- package Pack is 9793 -- end Pack; 9794 9795 -- package body Pack is -- optional body 9796 -- ... 9797 -- end Pack; 9798 9799 else 9800 return 9801 Find_Body 9802 (Spec_Id => Spec_Id, 9803 From => Next (Spec_Decl)); 9804 end if; 9805 end Find_Corresponding_Body; 9806 9807 --------------- 9808 -- Find_Body -- 9809 --------------- 9810 9811 function Find_Body 9812 (Spec_Id : Entity_Id; 9813 From : Node_Id) return Node_Id 9814 is 9815 Spec_Nam : constant Name_Id := Chars (Spec_Id); 9816 Item : Node_Id; 9817 Lib_Unit : Node_Id; 9818 9819 begin 9820 Item := From; 9821 while Present (Item) loop 9822 9823 -- The current item denotes the optional body 9824 9825 if Nkind (Item) = N_Package_Body 9826 and then Chars (Defining_Entity (Item)) = Spec_Nam 9827 then 9828 return Item; 9829 9830 -- The current item denotes a stub, the optional body may be in 9831 -- the subunit. 9832 9833 elsif Nkind (Item) = N_Package_Body_Stub 9834 and then Chars (Defining_Entity (Item)) = Spec_Nam 9835 then 9836 Lib_Unit := Library_Unit (Item); 9837 9838 -- The corresponding subunit was previously loaded 9839 9840 if Present (Lib_Unit) then 9841 return Lib_Unit; 9842 9843 -- Otherwise attempt to load the corresponding subunit 9844 9845 else 9846 return Load_Package_Body (Get_Unit_Name (Item)); 9847 end if; 9848 end if; 9849 9850 Next (Item); 9851 end loop; 9852 9853 return Empty; 9854 end Find_Body; 9855 9856 ----------------------- 9857 -- Load_Package_Body -- 9858 ----------------------- 9859 9860 function Load_Package_Body (Unit_Nam : Unit_Name_Type) return Node_Id is 9861 Body_Decl : Node_Id; 9862 Unit_Num : Unit_Number_Type; 9863 9864 begin 9865 -- The load is performed only when the compilation will generate code 9866 9867 if Operating_Mode = Generate_Code then 9868 Unit_Num := 9869 Load_Unit 9870 (Load_Name => Unit_Nam, 9871 Required => False, 9872 Subunit => False, 9873 Error_Node => Pack_Decl); 9874 9875 -- The load failed most likely because the physical file is 9876 -- missing. 9877 9878 if Unit_Num = No_Unit then 9879 return Empty; 9880 9881 -- Otherwise the load was successful, return the body of the unit 9882 9883 else 9884 Body_Decl := Unit (Cunit (Unit_Num)); 9885 9886 -- If the unit is a subunit with an available proper body, 9887 -- return the proper body. 9888 9889 if Nkind (Body_Decl) = N_Subunit 9890 and then Present (Proper_Body (Body_Decl)) 9891 then 9892 Body_Decl := Proper_Body (Body_Decl); 9893 end if; 9894 9895 return Body_Decl; 9896 end if; 9897 end if; 9898 9899 return Empty; 9900 end Load_Package_Body; 9901 9902 -- Local variables 9903 9904 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl); 9905 9906 -- Start of processing for Has_Body 9907 9908 begin 9909 -- The body is available 9910 9911 if Present (Corresponding_Body (Pack_Decl)) then 9912 return True; 9913 9914 -- The body is required if the package spec contains a construct which 9915 -- requires a completion in a body. 9916 9917 elsif Unit_Requires_Body (Pack_Id) then 9918 return True; 9919 9920 -- The body may be optional 9921 9922 else 9923 return Present (Find_Corresponding_Body (Pack_Id)); 9924 end if; 9925 end Has_Body; 9926 9927 ---------- 9928 -- Hash -- 9929 ---------- 9930 9931 function Hash (NE : Node_Or_Entity_Id) return Bucket_Range_Type is 9932 pragma Assert (Present (NE)); 9933 begin 9934 return Bucket_Range_Type (NE); 9935 end Hash; 9936 9937 -------------------------- 9938 -- In_External_Instance -- 9939 -------------------------- 9940 9941 function In_External_Instance 9942 (N : Node_Id; 9943 Target_Decl : Node_Id) return Boolean 9944 is 9945 Inst : Node_Id; 9946 Inst_Body : Node_Id; 9947 Inst_Spec : Node_Id; 9948 9949 begin 9950 Inst := Find_Enclosing_Instance (Target_Decl); 9951 9952 -- The target declaration appears within an instance spec. Visibility is 9953 -- ignored because internally generated primitives for private types may 9954 -- reside in the private declarations and still be invoked from outside. 9955 9956 if Present (Inst) and then Nkind (Inst) = N_Package_Declaration then 9957 9958 -- The scenario comes from the main unit and the instance does not 9959 9960 if In_Extended_Main_Code_Unit (N) 9961 and then not In_Extended_Main_Code_Unit (Inst) 9962 then 9963 return True; 9964 9965 -- Otherwise the scenario must not appear within the instance spec or 9966 -- body. 9967 9968 else 9969 Spec_And_Body_From_Node 9970 (N => Inst, 9971 Spec_Decl => Inst_Spec, 9972 Body_Decl => Inst_Body); 9973 9974 return not In_Subtree 9975 (N => N, 9976 Root1 => Inst_Spec, 9977 Root2 => Inst_Body); 9978 end if; 9979 end if; 9980 9981 return False; 9982 end In_External_Instance; 9983 9984 --------------------- 9985 -- In_Main_Context -- 9986 --------------------- 9987 9988 function In_Main_Context (N : Node_Id) return Boolean is 9989 begin 9990 -- Scenarios outside the main unit are not considered because the ALI 9991 -- information supplied to binde is for the main unit only. 9992 9993 if not In_Extended_Main_Code_Unit (N) then 9994 return False; 9995 9996 -- Scenarios within internal units are not considered unless switch 9997 -- -gnatdE (elaboration checks on predefined units) is in effect. 9998 9999 elsif not Debug_Flag_EE and then In_Internal_Unit (N) then 10000 return False; 10001 end if; 10002 10003 return True; 10004 end In_Main_Context; 10005 10006 --------------------- 10007 -- In_Same_Context -- 10008 --------------------- 10009 10010 function In_Same_Context 10011 (N1 : Node_Id; 10012 N2 : Node_Id; 10013 Nested_OK : Boolean := False) return Boolean 10014 is 10015 function Find_Enclosing_Context (N : Node_Id) return Node_Id; 10016 pragma Inline (Find_Enclosing_Context); 10017 -- Return the nearest enclosing non-library-level or compilation unit 10018 -- node which encapsulates arbitrary node N. Return Empty is no such 10019 -- context is available. 10020 10021 function In_Nested_Context 10022 (Outer : Node_Id; 10023 Inner : Node_Id) return Boolean; 10024 pragma Inline (In_Nested_Context); 10025 -- Determine whether arbitrary node Outer encapsulates arbitrary node 10026 -- Inner. 10027 10028 ---------------------------- 10029 -- Find_Enclosing_Context -- 10030 ---------------------------- 10031 10032 function Find_Enclosing_Context (N : Node_Id) return Node_Id is 10033 Context : Node_Id; 10034 Par : Node_Id; 10035 10036 begin 10037 Par := Parent (N); 10038 while Present (Par) loop 10039 10040 -- A traversal from a subunit continues via the corresponding stub 10041 10042 if Nkind (Par) = N_Subunit then 10043 Par := Corresponding_Stub (Par); 10044 10045 -- Stop the traversal when the nearest enclosing non-library-level 10046 -- encapsulator has been reached. 10047 10048 elsif Is_Non_Library_Level_Encapsulator (Par) then 10049 Context := Parent (Par); 10050 10051 -- The sole exception is when the encapsulator is the unit of 10052 -- compilation because this case requires special processing 10053 -- (see below). 10054 10055 if Present (Context) 10056 and then Nkind (Context) = N_Compilation_Unit 10057 then 10058 null; 10059 10060 else 10061 return Par; 10062 end if; 10063 10064 -- Reaching a compilation unit node without hitting a non-library- 10065 -- level encapsulator indicates that N is at the library level in 10066 -- which case the compilation unit is the context. 10067 10068 elsif Nkind (Par) = N_Compilation_Unit then 10069 return Par; 10070 end if; 10071 10072 Par := Parent (Par); 10073 end loop; 10074 10075 return Empty; 10076 end Find_Enclosing_Context; 10077 10078 ----------------------- 10079 -- In_Nested_Context -- 10080 ----------------------- 10081 10082 function In_Nested_Context 10083 (Outer : Node_Id; 10084 Inner : Node_Id) return Boolean 10085 is 10086 Par : Node_Id; 10087 10088 begin 10089 Par := Inner; 10090 while Present (Par) loop 10091 10092 -- A traversal from a subunit continues via the corresponding stub 10093 10094 if Nkind (Par) = N_Subunit then 10095 Par := Corresponding_Stub (Par); 10096 10097 elsif Par = Outer then 10098 return True; 10099 end if; 10100 10101 Par := Parent (Par); 10102 end loop; 10103 10104 return False; 10105 end In_Nested_Context; 10106 10107 -- Local variables 10108 10109 Context_1 : constant Node_Id := Find_Enclosing_Context (N1); 10110 Context_2 : constant Node_Id := Find_Enclosing_Context (N2); 10111 10112 -- Start of processing for In_Same_Context 10113 10114 begin 10115 -- Both nodes appear within the same context 10116 10117 if Context_1 = Context_2 then 10118 return True; 10119 10120 -- Both nodes appear in compilation units. Determine whether one unit 10121 -- is the body of the other. 10122 10123 elsif Nkind (Context_1) = N_Compilation_Unit 10124 and then Nkind (Context_2) = N_Compilation_Unit 10125 then 10126 return 10127 Is_Same_Unit 10128 (Unit_1 => Defining_Entity (Unit (Context_1)), 10129 Unit_2 => Defining_Entity (Unit (Context_2))); 10130 10131 -- The context of N1 encloses the context of N2 10132 10133 elsif Nested_OK and then In_Nested_Context (Context_1, Context_2) then 10134 return True; 10135 end if; 10136 10137 return False; 10138 end In_Same_Context; 10139 10140 ---------------- 10141 -- Initialize -- 10142 ---------------- 10143 10144 procedure Initialize is 10145 begin 10146 -- Set the soft link which enables Atree.Rewrite to update a scenario 10147 -- each time it is transformed into another node. 10148 10149 Set_Rewriting_Proc (Update_Elaboration_Scenario'Access); 10150 10151 -- Create all internal data structures and activate the elaboration 10152 -- phase of the compiler. 10153 10154 Initialize_All_Data_Structures; 10155 Set_Elaboration_Phase (Active); 10156 end Initialize; 10157 10158 ------------------------------------ 10159 -- Initialize_All_Data_Structures -- 10160 ------------------------------------ 10161 10162 procedure Initialize_All_Data_Structures is 10163 begin 10164 Initialize_Body_Processor; 10165 Initialize_Early_Call_Region_Processor; 10166 Initialize_Elaborated_Units; 10167 Initialize_Internal_Representation; 10168 Initialize_Invocation_Graph; 10169 Initialize_Scenario_Storage; 10170 end Initialize_All_Data_Structures; 10171 10172 -------------------------- 10173 -- Instantiated_Generic -- 10174 -------------------------- 10175 10176 function Instantiated_Generic (Inst : Node_Id) return Entity_Id is 10177 begin 10178 -- Traverse a possible chain of renamings to obtain the original generic 10179 -- being instantiatied. 10180 10181 return Get_Renamed_Entity (Entity (Name (Inst))); 10182 end Instantiated_Generic; 10183 10184 ----------------------------- 10185 -- Internal_Representation -- 10186 ----------------------------- 10187 10188 package body Internal_Representation is 10189 10190 ----------- 10191 -- Types -- 10192 ----------- 10193 10194 -- The following type represents the contents of a scenario 10195 10196 type Scenario_Rep_Record is record 10197 Elab_Checks_OK : Boolean := False; 10198 -- The status of elaboration checks for the scenario 10199 10200 Elab_Warnings_OK : Boolean := False; 10201 -- The status of elaboration warnings for the scenario 10202 10203 GM : Extended_Ghost_Mode := Is_Checked_Or_Not_Specified; 10204 -- The Ghost mode of the scenario 10205 10206 Kind : Scenario_Kind := No_Scenario; 10207 -- The nature of the scenario 10208 10209 Level : Enclosing_Level_Kind := No_Level; 10210 -- The enclosing level where the scenario resides 10211 10212 SM : Extended_SPARK_Mode := Is_Off_Or_Not_Specified; 10213 -- The SPARK mode of the scenario 10214 10215 Target : Entity_Id := Empty; 10216 -- The target of the scenario 10217 10218 -- The following attributes are multiplexed and depend on the Kind of 10219 -- the scenario. They are mapped as follows: 10220 -- 10221 -- Call_Scenario 10222 -- Is_Dispatching_Call (Flag_1) 10223 -- 10224 -- Task_Activation_Scenario 10225 -- Activated_Task_Objects (List_1) 10226 -- Activated_Task_Type (Field_1) 10227 -- 10228 -- Variable_Reference 10229 -- Is_Read_Reference (Flag_1) 10230 10231 Flag_1 : Boolean := False; 10232 Field_1 : Node_Or_Entity_Id := Empty; 10233 List_1 : NE_List.Doubly_Linked_List := NE_List.Nil; 10234 end record; 10235 10236 -- The following type represents the contents of a target 10237 10238 type Target_Rep_Record is record 10239 Body_Decl : Node_Id := Empty; 10240 -- The declaration of the target body 10241 10242 Elab_Checks_OK : Boolean := False; 10243 -- The status of elaboration checks for the target 10244 10245 Elab_Warnings_OK : Boolean := False; 10246 -- The status of elaboration warnings for the target 10247 10248 GM : Extended_Ghost_Mode := Is_Checked_Or_Not_Specified; 10249 -- The Ghost mode of the target 10250 10251 Kind : Target_Kind := No_Target; 10252 -- The nature of the target 10253 10254 SM : Extended_SPARK_Mode := Is_Off_Or_Not_Specified; 10255 -- The SPARK mode of the target 10256 10257 Spec_Decl : Node_Id := Empty; 10258 -- The declaration of the target spec 10259 10260 Unit : Entity_Id := Empty; 10261 -- The top unit where the target is declared 10262 10263 Version : Representation_Kind := No_Representation; 10264 -- The version of the target representation 10265 10266 -- The following attributes are multiplexed and depend on the Kind of 10267 -- the target. They are mapped as follows: 10268 -- 10269 -- Subprogram_Target 10270 -- Barrier_Body_Declaration (Field_1) 10271 -- 10272 -- Variable_Target 10273 -- Variable_Declaration (Field_1) 10274 10275 Field_1 : Node_Or_Entity_Id := Empty; 10276 end record; 10277 10278 --------------------- 10279 -- Data structures -- 10280 --------------------- 10281 10282 procedure Destroy (T_Id : in out Target_Rep_Id); 10283 -- Destroy a target representation T_Id 10284 10285 package ETT_Map is new Dynamic_Hash_Tables 10286 (Key_Type => Entity_Id, 10287 Value_Type => Target_Rep_Id, 10288 No_Value => No_Target_Rep, 10289 Expansion_Threshold => 1.5, 10290 Expansion_Factor => 2, 10291 Compression_Threshold => 0.3, 10292 Compression_Factor => 2, 10293 "=" => "=", 10294 Destroy_Value => Destroy, 10295 Hash => Hash); 10296 10297 -- The following map relates target representations to entities 10298 10299 Entity_To_Target_Map : ETT_Map.Dynamic_Hash_Table := ETT_Map.Nil; 10300 10301 procedure Destroy (S_Id : in out Scenario_Rep_Id); 10302 -- Destroy a scenario representation S_Id 10303 10304 package NTS_Map is new Dynamic_Hash_Tables 10305 (Key_Type => Node_Id, 10306 Value_Type => Scenario_Rep_Id, 10307 No_Value => No_Scenario_Rep, 10308 Expansion_Threshold => 1.5, 10309 Expansion_Factor => 2, 10310 Compression_Threshold => 0.3, 10311 Compression_Factor => 2, 10312 "=" => "=", 10313 Destroy_Value => Destroy, 10314 Hash => Hash); 10315 10316 -- The following map relates scenario representations to nodes 10317 10318 Node_To_Scenario_Map : NTS_Map.Dynamic_Hash_Table := NTS_Map.Nil; 10319 10320 -- The following table stores all scenario representations 10321 10322 package Scenario_Reps is new Table.Table 10323 (Table_Index_Type => Scenario_Rep_Id, 10324 Table_Component_Type => Scenario_Rep_Record, 10325 Table_Low_Bound => First_Scenario_Rep, 10326 Table_Initial => 1000, 10327 Table_Increment => 200, 10328 Table_Name => "Scenario_Reps"); 10329 10330 -- The following table stores all target representations 10331 10332 package Target_Reps is new Table.Table 10333 (Table_Index_Type => Target_Rep_Id, 10334 Table_Component_Type => Target_Rep_Record, 10335 Table_Low_Bound => First_Target_Rep, 10336 Table_Initial => 1000, 10337 Table_Increment => 200, 10338 Table_Name => "Target_Reps"); 10339 10340 -------------- 10341 -- Builders -- 10342 -------------- 10343 10344 function Create_Access_Taken_Rep 10345 (Attr : Node_Id) return Scenario_Rep_Record; 10346 pragma Inline (Create_Access_Taken_Rep); 10347 -- Create the representation of 'Access attribute Attr 10348 10349 function Create_Call_Or_Task_Activation_Rep 10350 (Call : Node_Id) return Scenario_Rep_Record; 10351 pragma Inline (Create_Call_Or_Task_Activation_Rep); 10352 -- Create the representation of call or task activation Call 10353 10354 function Create_Derived_Type_Rep 10355 (Typ_Decl : Node_Id) return Scenario_Rep_Record; 10356 pragma Inline (Create_Derived_Type_Rep); 10357 -- Create the representation of a derived type described by declaration 10358 -- Typ_Decl. 10359 10360 function Create_Generic_Rep 10361 (Gen_Id : Entity_Id) return Target_Rep_Record; 10362 pragma Inline (Create_Generic_Rep); 10363 -- Create the representation of generic Gen_Id 10364 10365 function Create_Instantiation_Rep 10366 (Inst : Node_Id) return Scenario_Rep_Record; 10367 pragma Inline (Create_Instantiation_Rep); 10368 -- Create the representation of instantiation Inst 10369 10370 function Create_Package_Rep 10371 (Pack_Id : Entity_Id) return Target_Rep_Record; 10372 pragma Inline (Create_Package_Rep); 10373 -- Create the representation of package Pack_Id 10374 10375 function Create_Protected_Entry_Rep 10376 (PE_Id : Entity_Id) return Target_Rep_Record; 10377 pragma Inline (Create_Protected_Entry_Rep); 10378 -- Create the representation of protected entry PE_Id 10379 10380 function Create_Protected_Subprogram_Rep 10381 (PS_Id : Entity_Id) return Target_Rep_Record; 10382 pragma Inline (Create_Protected_Subprogram_Rep); 10383 -- Create the representation of protected subprogram PS_Id 10384 10385 function Create_Refined_State_Pragma_Rep 10386 (Prag : Node_Id) return Scenario_Rep_Record; 10387 pragma Inline (Create_Refined_State_Pragma_Rep); 10388 -- Create the representation of Refined_State pragma Prag 10389 10390 function Create_Scenario_Rep 10391 (N : Node_Id; 10392 In_State : Processing_In_State) return Scenario_Rep_Record; 10393 pragma Inline (Create_Scenario_Rep); 10394 -- Top level dispatcher. Create the representation of elaboration 10395 -- scenario N. In_State is the current state of the Processing phase. 10396 10397 function Create_Subprogram_Rep 10398 (Subp_Id : Entity_Id) return Target_Rep_Record; 10399 pragma Inline (Create_Subprogram_Rep); 10400 -- Create the representation of entry, operator, or subprogram Subp_Id 10401 10402 function Create_Target_Rep 10403 (Id : Entity_Id; 10404 In_State : Processing_In_State) return Target_Rep_Record; 10405 pragma Inline (Create_Target_Rep); 10406 -- Top level dispatcher. Create the representation of elaboration target 10407 -- Id. In_State is the current state of the Processing phase. 10408 10409 function Create_Task_Entry_Rep 10410 (TE_Id : Entity_Id) return Target_Rep_Record; 10411 pragma Inline (Create_Task_Entry_Rep); 10412 -- Create the representation of task entry TE_Id 10413 10414 function Create_Task_Rep (Task_Typ : Entity_Id) return Target_Rep_Record; 10415 pragma Inline (Create_Task_Rep); 10416 -- Create the representation of task type Typ 10417 10418 function Create_Variable_Assignment_Rep 10419 (Asmt : Node_Id) return Scenario_Rep_Record; 10420 pragma Inline (Create_Variable_Assignment_Rep); 10421 -- Create the representation of variable assignment Asmt 10422 10423 function Create_Variable_Reference_Rep 10424 (Ref : Node_Id) return Scenario_Rep_Record; 10425 pragma Inline (Create_Variable_Reference_Rep); 10426 -- Create the representation of variable reference Ref 10427 10428 function Create_Variable_Rep 10429 (Var_Id : Entity_Id) return Target_Rep_Record; 10430 pragma Inline (Create_Variable_Rep); 10431 -- Create the representation of variable Var_Id 10432 10433 ----------------------- 10434 -- Local subprograms -- 10435 ----------------------- 10436 10437 function Ghost_Mode_Of_Entity 10438 (Id : Entity_Id) return Extended_Ghost_Mode; 10439 pragma Inline (Ghost_Mode_Of_Entity); 10440 -- Obtain the extended Ghost mode of arbitrary entity Id 10441 10442 function Ghost_Mode_Of_Node (N : Node_Id) return Extended_Ghost_Mode; 10443 pragma Inline (Ghost_Mode_Of_Node); 10444 -- Obtain the extended Ghost mode of arbitrary node N 10445 10446 function Present (S_Id : Scenario_Rep_Id) return Boolean; 10447 pragma Inline (Present); 10448 -- Determine whether scenario representation S_Id exists 10449 10450 function Present (T_Id : Target_Rep_Id) return Boolean; 10451 pragma Inline (Present); 10452 -- Determine whether target representation T_Id exists 10453 10454 function SPARK_Mode_Of_Entity 10455 (Id : Entity_Id) return Extended_SPARK_Mode; 10456 pragma Inline (SPARK_Mode_Of_Entity); 10457 -- Obtain the extended SPARK mode of arbitrary entity Id 10458 10459 function SPARK_Mode_Of_Node (N : Node_Id) return Extended_SPARK_Mode; 10460 pragma Inline (SPARK_Mode_Of_Node); 10461 -- Obtain the extended SPARK mode of arbitrary node N 10462 10463 function To_Ghost_Mode 10464 (Ignored_Status : Boolean) return Extended_Ghost_Mode; 10465 pragma Inline (To_Ghost_Mode); 10466 -- Convert a Ghost mode indicated by Ignored_Status into its extended 10467 -- equivalent. 10468 10469 function To_SPARK_Mode (On_Status : Boolean) return Extended_SPARK_Mode; 10470 pragma Inline (To_SPARK_Mode); 10471 -- Convert a SPARK mode indicated by On_Status into its extended 10472 -- equivalent. 10473 10474 function Version (T_Id : Target_Rep_Id) return Representation_Kind; 10475 pragma Inline (Version); 10476 -- Obtain the version of target representation T_Id 10477 10478 ---------------------------- 10479 -- Activated_Task_Objects -- 10480 ---------------------------- 10481 10482 function Activated_Task_Objects 10483 (S_Id : Scenario_Rep_Id) return NE_List.Doubly_Linked_List 10484 is 10485 pragma Assert (Present (S_Id)); 10486 pragma Assert (Kind (S_Id) = Task_Activation_Scenario); 10487 10488 begin 10489 return Scenario_Reps.Table (S_Id).List_1; 10490 end Activated_Task_Objects; 10491 10492 ------------------------- 10493 -- Activated_Task_Type -- 10494 ------------------------- 10495 10496 function Activated_Task_Type 10497 (S_Id : Scenario_Rep_Id) return Entity_Id 10498 is 10499 pragma Assert (Present (S_Id)); 10500 pragma Assert (Kind (S_Id) = Task_Activation_Scenario); 10501 10502 begin 10503 return Scenario_Reps.Table (S_Id).Field_1; 10504 end Activated_Task_Type; 10505 10506 ------------------------------ 10507 -- Barrier_Body_Declaration -- 10508 ------------------------------ 10509 10510 function Barrier_Body_Declaration 10511 (T_Id : Target_Rep_Id) return Node_Id 10512 is 10513 pragma Assert (Present (T_Id)); 10514 pragma Assert (Kind (T_Id) = Subprogram_Target); 10515 10516 begin 10517 return Target_Reps.Table (T_Id).Field_1; 10518 end Barrier_Body_Declaration; 10519 10520 ---------------------- 10521 -- Body_Declaration -- 10522 ---------------------- 10523 10524 function Body_Declaration (T_Id : Target_Rep_Id) return Node_Id is 10525 pragma Assert (Present (T_Id)); 10526 begin 10527 return Target_Reps.Table (T_Id).Body_Decl; 10528 end Body_Declaration; 10529 10530 ----------------------------- 10531 -- Create_Access_Taken_Rep -- 10532 ----------------------------- 10533 10534 function Create_Access_Taken_Rep 10535 (Attr : Node_Id) return Scenario_Rep_Record 10536 is 10537 Rec : Scenario_Rep_Record; 10538 10539 begin 10540 Rec.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Attr); 10541 Rec.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Node (Attr); 10542 Rec.GM := Is_Checked_Or_Not_Specified; 10543 Rec.SM := SPARK_Mode_Of_Node (Attr); 10544 Rec.Kind := Access_Taken_Scenario; 10545 Rec.Target := Canonical_Subprogram (Entity (Prefix (Attr))); 10546 10547 return Rec; 10548 end Create_Access_Taken_Rep; 10549 10550 ---------------------------------------- 10551 -- Create_Call_Or_Task_Activation_Rep -- 10552 ---------------------------------------- 10553 10554 function Create_Call_Or_Task_Activation_Rep 10555 (Call : Node_Id) return Scenario_Rep_Record 10556 is 10557 Subp_Id : constant Entity_Id := Canonical_Subprogram (Target (Call)); 10558 Kind : Scenario_Kind; 10559 Rec : Scenario_Rep_Record; 10560 10561 begin 10562 if Is_Activation_Proc (Subp_Id) then 10563 Kind := Task_Activation_Scenario; 10564 else 10565 Kind := Call_Scenario; 10566 end if; 10567 10568 Rec.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Call); 10569 Rec.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Node (Call); 10570 Rec.GM := Ghost_Mode_Of_Node (Call); 10571 Rec.SM := SPARK_Mode_Of_Node (Call); 10572 Rec.Kind := Kind; 10573 Rec.Target := Subp_Id; 10574 10575 -- Scenario-specific attributes 10576 10577 Rec.Flag_1 := Is_Dispatching_Call (Call); -- Dispatching_Call 10578 10579 return Rec; 10580 end Create_Call_Or_Task_Activation_Rep; 10581 10582 ----------------------------- 10583 -- Create_Derived_Type_Rep -- 10584 ----------------------------- 10585 10586 function Create_Derived_Type_Rep 10587 (Typ_Decl : Node_Id) return Scenario_Rep_Record 10588 is 10589 Typ : constant Entity_Id := Defining_Entity (Typ_Decl); 10590 Rec : Scenario_Rep_Record; 10591 10592 begin 10593 Rec.Elab_Checks_OK := False; -- not relevant 10594 Rec.Elab_Warnings_OK := False; -- not relevant 10595 Rec.GM := Ghost_Mode_Of_Entity (Typ); 10596 Rec.SM := SPARK_Mode_Of_Entity (Typ); 10597 Rec.Kind := Derived_Type_Scenario; 10598 Rec.Target := Typ; 10599 10600 return Rec; 10601 end Create_Derived_Type_Rep; 10602 10603 ------------------------ 10604 -- Create_Generic_Rep -- 10605 ------------------------ 10606 10607 function Create_Generic_Rep 10608 (Gen_Id : Entity_Id) return Target_Rep_Record 10609 is 10610 Rec : Target_Rep_Record; 10611 10612 begin 10613 Rec.Kind := Generic_Target; 10614 10615 Spec_And_Body_From_Entity 10616 (Id => Gen_Id, 10617 Body_Decl => Rec.Body_Decl, 10618 Spec_Decl => Rec.Spec_Decl); 10619 10620 return Rec; 10621 end Create_Generic_Rep; 10622 10623 ------------------------------ 10624 -- Create_Instantiation_Rep -- 10625 ------------------------------ 10626 10627 function Create_Instantiation_Rep 10628 (Inst : Node_Id) return Scenario_Rep_Record 10629 is 10630 Rec : Scenario_Rep_Record; 10631 10632 begin 10633 Rec.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Inst); 10634 Rec.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Node (Inst); 10635 Rec.GM := Ghost_Mode_Of_Node (Inst); 10636 Rec.SM := SPARK_Mode_Of_Node (Inst); 10637 Rec.Kind := Instantiation_Scenario; 10638 Rec.Target := Instantiated_Generic (Inst); 10639 10640 return Rec; 10641 end Create_Instantiation_Rep; 10642 10643 ------------------------ 10644 -- Create_Package_Rep -- 10645 ------------------------ 10646 10647 function Create_Package_Rep 10648 (Pack_Id : Entity_Id) return Target_Rep_Record 10649 is 10650 Rec : Target_Rep_Record; 10651 10652 begin 10653 Rec.Kind := Package_Target; 10654 10655 Spec_And_Body_From_Entity 10656 (Id => Pack_Id, 10657 Body_Decl => Rec.Body_Decl, 10658 Spec_Decl => Rec.Spec_Decl); 10659 10660 return Rec; 10661 end Create_Package_Rep; 10662 10663 -------------------------------- 10664 -- Create_Protected_Entry_Rep -- 10665 -------------------------------- 10666 10667 function Create_Protected_Entry_Rep 10668 (PE_Id : Entity_Id) return Target_Rep_Record 10669 is 10670 Prot_Id : constant Entity_Id := Protected_Body_Subprogram (PE_Id); 10671 10672 Barf_Id : Entity_Id; 10673 Dummy : Node_Id; 10674 Rec : Target_Rep_Record; 10675 Spec_Id : Entity_Id; 10676 10677 begin 10678 -- When the entry [family] has already been expanded, it carries both 10679 -- the procedure which emulates the behavior of the entry [family] as 10680 -- well as the barrier function. 10681 10682 if Present (Prot_Id) then 10683 Barf_Id := Barrier_Function (PE_Id); 10684 Spec_Id := Prot_Id; 10685 10686 -- Otherwise no expansion took place 10687 10688 else 10689 Barf_Id := Empty; 10690 Spec_Id := PE_Id; 10691 end if; 10692 10693 Rec.Kind := Subprogram_Target; 10694 10695 Spec_And_Body_From_Entity 10696 (Id => Spec_Id, 10697 Body_Decl => Rec.Body_Decl, 10698 Spec_Decl => Rec.Spec_Decl); 10699 10700 -- Target-specific attributes 10701 10702 if Present (Barf_Id) then 10703 Spec_And_Body_From_Entity 10704 (Id => Barf_Id, 10705 Body_Decl => Rec.Field_1, -- Barrier_Body_Declaration 10706 Spec_Decl => Dummy); 10707 end if; 10708 10709 return Rec; 10710 end Create_Protected_Entry_Rep; 10711 10712 ------------------------------------- 10713 -- Create_Protected_Subprogram_Rep -- 10714 ------------------------------------- 10715 10716 function Create_Protected_Subprogram_Rep 10717 (PS_Id : Entity_Id) return Target_Rep_Record 10718 is 10719 Prot_Id : constant Entity_Id := Protected_Body_Subprogram (PS_Id); 10720 Rec : Target_Rep_Record; 10721 Spec_Id : Entity_Id; 10722 10723 begin 10724 -- When the protected subprogram has already been expanded, it 10725 -- carries the subprogram which seizes the lock and invokes the 10726 -- original statements. 10727 10728 if Present (Prot_Id) then 10729 Spec_Id := Prot_Id; 10730 10731 -- Otherwise no expansion took place 10732 10733 else 10734 Spec_Id := PS_Id; 10735 end if; 10736 10737 Rec.Kind := Subprogram_Target; 10738 10739 Spec_And_Body_From_Entity 10740 (Id => Spec_Id, 10741 Body_Decl => Rec.Body_Decl, 10742 Spec_Decl => Rec.Spec_Decl); 10743 10744 return Rec; 10745 end Create_Protected_Subprogram_Rep; 10746 10747 ------------------------------------- 10748 -- Create_Refined_State_Pragma_Rep -- 10749 ------------------------------------- 10750 10751 function Create_Refined_State_Pragma_Rep 10752 (Prag : Node_Id) return Scenario_Rep_Record 10753 is 10754 Rec : Scenario_Rep_Record; 10755 10756 begin 10757 Rec.Elab_Checks_OK := False; -- not relevant 10758 Rec.Elab_Warnings_OK := False; -- not relevant 10759 Rec.GM := 10760 To_Ghost_Mode (Is_Ignored_Ghost_Pragma (Prag)); 10761 Rec.SM := Is_Off_Or_Not_Specified; 10762 Rec.Kind := Refined_State_Pragma_Scenario; 10763 Rec.Target := Empty; 10764 10765 return Rec; 10766 end Create_Refined_State_Pragma_Rep; 10767 10768 ------------------------- 10769 -- Create_Scenario_Rep -- 10770 ------------------------- 10771 10772 function Create_Scenario_Rep 10773 (N : Node_Id; 10774 In_State : Processing_In_State) return Scenario_Rep_Record 10775 is 10776 pragma Unreferenced (In_State); 10777 10778 Rec : Scenario_Rep_Record; 10779 10780 begin 10781 if Is_Suitable_Access_Taken (N) then 10782 Rec := Create_Access_Taken_Rep (N); 10783 10784 elsif Is_Suitable_Call (N) then 10785 Rec := Create_Call_Or_Task_Activation_Rep (N); 10786 10787 elsif Is_Suitable_Instantiation (N) then 10788 Rec := Create_Instantiation_Rep (N); 10789 10790 elsif Is_Suitable_SPARK_Derived_Type (N) then 10791 Rec := Create_Derived_Type_Rep (N); 10792 10793 elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then 10794 Rec := Create_Refined_State_Pragma_Rep (N); 10795 10796 elsif Is_Suitable_Variable_Assignment (N) then 10797 Rec := Create_Variable_Assignment_Rep (N); 10798 10799 elsif Is_Suitable_Variable_Reference (N) then 10800 Rec := Create_Variable_Reference_Rep (N); 10801 10802 else 10803 pragma Assert (False); 10804 return Rec; 10805 end if; 10806 10807 -- Common scenario attributes 10808 10809 Rec.Level := Find_Enclosing_Level (N); 10810 10811 return Rec; 10812 end Create_Scenario_Rep; 10813 10814 --------------------------- 10815 -- Create_Subprogram_Rep -- 10816 --------------------------- 10817 10818 function Create_Subprogram_Rep 10819 (Subp_Id : Entity_Id) return Target_Rep_Record 10820 is 10821 Rec : Target_Rep_Record; 10822 Spec_Id : Entity_Id; 10823 10824 begin 10825 Spec_Id := Subp_Id; 10826 10827 -- The elaboration target denotes an internal function that returns a 10828 -- constrained array type in a SPARK-to-C compilation. In this case 10829 -- the function receives a corresponding procedure which has an out 10830 -- parameter. The proper body for ABE checks and diagnostics is that 10831 -- of the procedure. 10832 10833 if Ekind (Spec_Id) = E_Function 10834 and then Rewritten_For_C (Spec_Id) 10835 then 10836 Spec_Id := Corresponding_Procedure (Spec_Id); 10837 end if; 10838 10839 Rec.Kind := Subprogram_Target; 10840 10841 Spec_And_Body_From_Entity 10842 (Id => Spec_Id, 10843 Body_Decl => Rec.Body_Decl, 10844 Spec_Decl => Rec.Spec_Decl); 10845 10846 return Rec; 10847 end Create_Subprogram_Rep; 10848 10849 ----------------------- 10850 -- Create_Target_Rep -- 10851 ----------------------- 10852 10853 function Create_Target_Rep 10854 (Id : Entity_Id; 10855 In_State : Processing_In_State) return Target_Rep_Record 10856 is 10857 Rec : Target_Rep_Record; 10858 10859 begin 10860 if Is_Generic_Unit (Id) then 10861 Rec := Create_Generic_Rep (Id); 10862 10863 elsif Is_Protected_Entry (Id) then 10864 Rec := Create_Protected_Entry_Rep (Id); 10865 10866 elsif Is_Protected_Subp (Id) then 10867 Rec := Create_Protected_Subprogram_Rep (Id); 10868 10869 elsif Is_Task_Entry (Id) then 10870 Rec := Create_Task_Entry_Rep (Id); 10871 10872 elsif Is_Task_Type (Id) then 10873 Rec := Create_Task_Rep (Id); 10874 10875 elsif Ekind_In (Id, E_Constant, E_Variable) then 10876 Rec := Create_Variable_Rep (Id); 10877 10878 elsif Ekind_In (Id, E_Entry, 10879 E_Function, 10880 E_Operator, 10881 E_Procedure) 10882 then 10883 Rec := Create_Subprogram_Rep (Id); 10884 10885 elsif Ekind (Id) = E_Package then 10886 Rec := Create_Package_Rep (Id); 10887 10888 else 10889 pragma Assert (False); 10890 return Rec; 10891 end if; 10892 10893 -- Common target attributes 10894 10895 Rec.Elab_Checks_OK := Is_Elaboration_Checks_OK_Id (Id); 10896 Rec.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Id (Id); 10897 Rec.GM := Ghost_Mode_Of_Entity (Id); 10898 Rec.SM := SPARK_Mode_Of_Entity (Id); 10899 Rec.Unit := Find_Top_Unit (Id); 10900 Rec.Version := In_State.Representation; 10901 10902 return Rec; 10903 end Create_Target_Rep; 10904 10905 --------------------------- 10906 -- Create_Task_Entry_Rep -- 10907 --------------------------- 10908 10909 function Create_Task_Entry_Rep 10910 (TE_Id : Entity_Id) return Target_Rep_Record 10911 is 10912 Task_Typ : constant Entity_Id := Non_Private_View (Scope (TE_Id)); 10913 Task_Body_Id : constant Entity_Id := Task_Body_Procedure (Task_Typ); 10914 10915 Rec : Target_Rep_Record; 10916 Spec_Id : Entity_Id; 10917 10918 begin 10919 -- The task type has already been expanded, it carries the procedure 10920 -- which emulates the behavior of the task body. 10921 10922 if Present (Task_Body_Id) then 10923 Spec_Id := Task_Body_Id; 10924 10925 -- Otherwise no expansion took place 10926 10927 else 10928 Spec_Id := TE_Id; 10929 end if; 10930 10931 Rec.Kind := Subprogram_Target; 10932 10933 Spec_And_Body_From_Entity 10934 (Id => Spec_Id, 10935 Body_Decl => Rec.Body_Decl, 10936 Spec_Decl => Rec.Spec_Decl); 10937 10938 return Rec; 10939 end Create_Task_Entry_Rep; 10940 10941 --------------------- 10942 -- Create_Task_Rep -- 10943 --------------------- 10944 10945 function Create_Task_Rep 10946 (Task_Typ : Entity_Id) return Target_Rep_Record 10947 is 10948 Task_Body_Id : constant Entity_Id := Task_Body_Procedure (Task_Typ); 10949 10950 Rec : Target_Rep_Record; 10951 Spec_Id : Entity_Id; 10952 10953 begin 10954 -- The task type has already been expanded, it carries the procedure 10955 -- which emulates the behavior of the task body. 10956 10957 if Present (Task_Body_Id) then 10958 Spec_Id := Task_Body_Id; 10959 10960 -- Otherwise no expansion took place 10961 10962 else 10963 Spec_Id := Task_Typ; 10964 end if; 10965 10966 Rec.Kind := Task_Target; 10967 10968 Spec_And_Body_From_Entity 10969 (Id => Spec_Id, 10970 Body_Decl => Rec.Body_Decl, 10971 Spec_Decl => Rec.Spec_Decl); 10972 10973 return Rec; 10974 end Create_Task_Rep; 10975 10976 ------------------------------------ 10977 -- Create_Variable_Assignment_Rep -- 10978 ------------------------------------ 10979 10980 function Create_Variable_Assignment_Rep 10981 (Asmt : Node_Id) return Scenario_Rep_Record 10982 is 10983 Var_Id : constant Entity_Id := Entity (Assignment_Target (Asmt)); 10984 Rec : Scenario_Rep_Record; 10985 10986 begin 10987 Rec.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Asmt); 10988 Rec.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Id (Var_Id); 10989 Rec.GM := Ghost_Mode_Of_Node (Asmt); 10990 Rec.SM := SPARK_Mode_Of_Node (Asmt); 10991 Rec.Kind := Variable_Assignment_Scenario; 10992 Rec.Target := Var_Id; 10993 10994 return Rec; 10995 end Create_Variable_Assignment_Rep; 10996 10997 ----------------------------------- 10998 -- Create_Variable_Reference_Rep -- 10999 ----------------------------------- 11000 11001 function Create_Variable_Reference_Rep 11002 (Ref : Node_Id) return Scenario_Rep_Record 11003 is 11004 Rec : Scenario_Rep_Record; 11005 11006 begin 11007 Rec.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Ref); 11008 Rec.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Node (Ref); 11009 Rec.GM := Ghost_Mode_Of_Node (Ref); 11010 Rec.SM := SPARK_Mode_Of_Node (Ref); 11011 Rec.Kind := Variable_Reference_Scenario; 11012 Rec.Target := Target (Ref); 11013 11014 -- Scenario-specific attributes 11015 11016 Rec.Flag_1 := Is_Read (Ref); -- Is_Read_Reference 11017 11018 return Rec; 11019 end Create_Variable_Reference_Rep; 11020 11021 ------------------------- 11022 -- Create_Variable_Rep -- 11023 ------------------------- 11024 11025 function Create_Variable_Rep 11026 (Var_Id : Entity_Id) return Target_Rep_Record 11027 is 11028 Rec : Target_Rep_Record; 11029 11030 begin 11031 Rec.Kind := Variable_Target; 11032 11033 -- Target-specific attributes 11034 11035 Rec.Field_1 := Declaration_Node (Var_Id); -- Variable_Declaration 11036 11037 return Rec; 11038 end Create_Variable_Rep; 11039 11040 ------------- 11041 -- Destroy -- 11042 ------------- 11043 11044 procedure Destroy (S_Id : in out Scenario_Rep_Id) is 11045 pragma Unreferenced (S_Id); 11046 begin 11047 null; 11048 end Destroy; 11049 11050 ------------- 11051 -- Destroy -- 11052 ------------- 11053 11054 procedure Destroy (T_Id : in out Target_Rep_Id) is 11055 pragma Unreferenced (T_Id); 11056 begin 11057 null; 11058 end Destroy; 11059 11060 -------------------------------- 11061 -- Disable_Elaboration_Checks -- 11062 -------------------------------- 11063 11064 procedure Disable_Elaboration_Checks (S_Id : Scenario_Rep_Id) is 11065 pragma Assert (Present (S_Id)); 11066 begin 11067 Scenario_Reps.Table (S_Id).Elab_Checks_OK := False; 11068 end Disable_Elaboration_Checks; 11069 11070 -------------------------------- 11071 -- Disable_Elaboration_Checks -- 11072 -------------------------------- 11073 11074 procedure Disable_Elaboration_Checks (T_Id : Target_Rep_Id) is 11075 pragma Assert (Present (T_Id)); 11076 begin 11077 Target_Reps.Table (T_Id).Elab_Checks_OK := False; 11078 end Disable_Elaboration_Checks; 11079 11080 --------------------------- 11081 -- Elaboration_Checks_OK -- 11082 --------------------------- 11083 11084 function Elaboration_Checks_OK (S_Id : Scenario_Rep_Id) return Boolean is 11085 pragma Assert (Present (S_Id)); 11086 begin 11087 return Scenario_Reps.Table (S_Id).Elab_Checks_OK; 11088 end Elaboration_Checks_OK; 11089 11090 --------------------------- 11091 -- Elaboration_Checks_OK -- 11092 --------------------------- 11093 11094 function Elaboration_Checks_OK (T_Id : Target_Rep_Id) return Boolean is 11095 pragma Assert (Present (T_Id)); 11096 begin 11097 return Target_Reps.Table (T_Id).Elab_Checks_OK; 11098 end Elaboration_Checks_OK; 11099 11100 ----------------------------- 11101 -- Elaboration_Warnings_OK -- 11102 ----------------------------- 11103 11104 function Elaboration_Warnings_OK 11105 (S_Id : Scenario_Rep_Id) return Boolean 11106 is 11107 pragma Assert (Present (S_Id)); 11108 begin 11109 return Scenario_Reps.Table (S_Id).Elab_Warnings_OK; 11110 end Elaboration_Warnings_OK; 11111 11112 ----------------------------- 11113 -- Elaboration_Warnings_OK -- 11114 ----------------------------- 11115 11116 function Elaboration_Warnings_OK (T_Id : Target_Rep_Id) return Boolean is 11117 pragma Assert (Present (T_Id)); 11118 begin 11119 return Target_Reps.Table (T_Id).Elab_Warnings_OK; 11120 end Elaboration_Warnings_OK; 11121 11122 -------------------------------------- 11123 -- Finalize_Internal_Representation -- 11124 -------------------------------------- 11125 11126 procedure Finalize_Internal_Representation is 11127 begin 11128 ETT_Map.Destroy (Entity_To_Target_Map); 11129 NTS_Map.Destroy (Node_To_Scenario_Map); 11130 end Finalize_Internal_Representation; 11131 11132 ------------------- 11133 -- Ghost_Mode_Of -- 11134 ------------------- 11135 11136 function Ghost_Mode_Of 11137 (S_Id : Scenario_Rep_Id) return Extended_Ghost_Mode 11138 is 11139 pragma Assert (Present (S_Id)); 11140 begin 11141 return Scenario_Reps.Table (S_Id).GM; 11142 end Ghost_Mode_Of; 11143 11144 ------------------- 11145 -- Ghost_Mode_Of -- 11146 ------------------- 11147 11148 function Ghost_Mode_Of 11149 (T_Id : Target_Rep_Id) return Extended_Ghost_Mode 11150 is 11151 pragma Assert (Present (T_Id)); 11152 begin 11153 return Target_Reps.Table (T_Id).GM; 11154 end Ghost_Mode_Of; 11155 11156 -------------------------- 11157 -- Ghost_Mode_Of_Entity -- 11158 -------------------------- 11159 11160 function Ghost_Mode_Of_Entity 11161 (Id : Entity_Id) return Extended_Ghost_Mode 11162 is 11163 begin 11164 return To_Ghost_Mode (Is_Ignored_Ghost_Entity (Id)); 11165 end Ghost_Mode_Of_Entity; 11166 11167 ------------------------ 11168 -- Ghost_Mode_Of_Node -- 11169 ------------------------ 11170 11171 function Ghost_Mode_Of_Node (N : Node_Id) return Extended_Ghost_Mode is 11172 begin 11173 return To_Ghost_Mode (Is_Ignored_Ghost_Node (N)); 11174 end Ghost_Mode_Of_Node; 11175 11176 ---------------------------------------- 11177 -- Initialize_Internal_Representation -- 11178 ---------------------------------------- 11179 11180 procedure Initialize_Internal_Representation is 11181 begin 11182 Entity_To_Target_Map := ETT_Map.Create (500); 11183 Node_To_Scenario_Map := NTS_Map.Create (500); 11184 end Initialize_Internal_Representation; 11185 11186 ------------------------- 11187 -- Is_Dispatching_Call -- 11188 ------------------------- 11189 11190 function Is_Dispatching_Call (S_Id : Scenario_Rep_Id) return Boolean is 11191 pragma Assert (Present (S_Id)); 11192 pragma Assert (Kind (S_Id) = Call_Scenario); 11193 11194 begin 11195 return Scenario_Reps.Table (S_Id).Flag_1; 11196 end Is_Dispatching_Call; 11197 11198 ----------------------- 11199 -- Is_Read_Reference -- 11200 ----------------------- 11201 11202 function Is_Read_Reference (S_Id : Scenario_Rep_Id) return Boolean is 11203 pragma Assert (Present (S_Id)); 11204 pragma Assert (Kind (S_Id) = Variable_Reference_Scenario); 11205 11206 begin 11207 return Scenario_Reps.Table (S_Id).Flag_1; 11208 end Is_Read_Reference; 11209 11210 ---------- 11211 -- Kind -- 11212 ---------- 11213 11214 function Kind (S_Id : Scenario_Rep_Id) return Scenario_Kind is 11215 pragma Assert (Present (S_Id)); 11216 begin 11217 return Scenario_Reps.Table (S_Id).Kind; 11218 end Kind; 11219 11220 ---------- 11221 -- Kind -- 11222 ---------- 11223 11224 function Kind (T_Id : Target_Rep_Id) return Target_Kind is 11225 pragma Assert (Present (T_Id)); 11226 begin 11227 return Target_Reps.Table (T_Id).Kind; 11228 end Kind; 11229 11230 ----------- 11231 -- Level -- 11232 ----------- 11233 11234 function Level (S_Id : Scenario_Rep_Id) return Enclosing_Level_Kind is 11235 pragma Assert (Present (S_Id)); 11236 begin 11237 return Scenario_Reps.Table (S_Id).Level; 11238 end Level; 11239 11240 ------------- 11241 -- Present -- 11242 ------------- 11243 11244 function Present (S_Id : Scenario_Rep_Id) return Boolean is 11245 begin 11246 return S_Id /= No_Scenario_Rep; 11247 end Present; 11248 11249 ------------- 11250 -- Present -- 11251 ------------- 11252 11253 function Present (T_Id : Target_Rep_Id) return Boolean is 11254 begin 11255 return T_Id /= No_Target_Rep; 11256 end Present; 11257 11258 -------------------------------- 11259 -- Scenario_Representation_Of -- 11260 -------------------------------- 11261 11262 function Scenario_Representation_Of 11263 (N : Node_Id; 11264 In_State : Processing_In_State) return Scenario_Rep_Id 11265 is 11266 S_Id : Scenario_Rep_Id; 11267 11268 begin 11269 S_Id := NTS_Map.Get (Node_To_Scenario_Map, N); 11270 11271 -- The elaboration scenario lacks a representation. This indicates 11272 -- that the scenario is encountered for the first time. Create the 11273 -- representation of it. 11274 11275 if not Present (S_Id) then 11276 Scenario_Reps.Append (Create_Scenario_Rep (N, In_State)); 11277 S_Id := Scenario_Reps.Last; 11278 11279 -- Associate the internal representation with the elaboration 11280 -- scenario. 11281 11282 NTS_Map.Put (Node_To_Scenario_Map, N, S_Id); 11283 end if; 11284 11285 pragma Assert (Present (S_Id)); 11286 11287 return S_Id; 11288 end Scenario_Representation_Of; 11289 11290 -------------------------------- 11291 -- Set_Activated_Task_Objects -- 11292 -------------------------------- 11293 11294 procedure Set_Activated_Task_Objects 11295 (S_Id : Scenario_Rep_Id; 11296 Task_Objs : NE_List.Doubly_Linked_List) 11297 is 11298 pragma Assert (Present (S_Id)); 11299 pragma Assert (Kind (S_Id) = Task_Activation_Scenario); 11300 11301 begin 11302 Scenario_Reps.Table (S_Id).List_1 := Task_Objs; 11303 end Set_Activated_Task_Objects; 11304 11305 ----------------------------- 11306 -- Set_Activated_Task_Type -- 11307 ----------------------------- 11308 11309 procedure Set_Activated_Task_Type 11310 (S_Id : Scenario_Rep_Id; 11311 Task_Typ : Entity_Id) 11312 is 11313 pragma Assert (Present (S_Id)); 11314 pragma Assert (Kind (S_Id) = Task_Activation_Scenario); 11315 11316 begin 11317 Scenario_Reps.Table (S_Id).Field_1 := Task_Typ; 11318 end Set_Activated_Task_Type; 11319 11320 ------------------- 11321 -- SPARK_Mode_Of -- 11322 ------------------- 11323 11324 function SPARK_Mode_Of 11325 (S_Id : Scenario_Rep_Id) return Extended_SPARK_Mode 11326 is 11327 pragma Assert (Present (S_Id)); 11328 begin 11329 return Scenario_Reps.Table (S_Id).SM; 11330 end SPARK_Mode_Of; 11331 11332 ------------------- 11333 -- SPARK_Mode_Of -- 11334 ------------------- 11335 11336 function SPARK_Mode_Of 11337 (T_Id : Target_Rep_Id) return Extended_SPARK_Mode 11338 is 11339 pragma Assert (Present (T_Id)); 11340 begin 11341 return Target_Reps.Table (T_Id).SM; 11342 end SPARK_Mode_Of; 11343 11344 -------------------------- 11345 -- SPARK_Mode_Of_Entity -- 11346 -------------------------- 11347 11348 function SPARK_Mode_Of_Entity 11349 (Id : Entity_Id) return Extended_SPARK_Mode 11350 is 11351 Prag : constant Node_Id := SPARK_Pragma (Id); 11352 11353 begin 11354 return 11355 To_SPARK_Mode 11356 (Present (Prag) 11357 and then Get_SPARK_Mode_From_Annotation (Prag) = On); 11358 end SPARK_Mode_Of_Entity; 11359 11360 ------------------------ 11361 -- SPARK_Mode_Of_Node -- 11362 ------------------------ 11363 11364 function SPARK_Mode_Of_Node (N : Node_Id) return Extended_SPARK_Mode is 11365 begin 11366 return To_SPARK_Mode (Is_SPARK_Mode_On_Node (N)); 11367 end SPARK_Mode_Of_Node; 11368 11369 ---------------------- 11370 -- Spec_Declaration -- 11371 ---------------------- 11372 11373 function Spec_Declaration (T_Id : Target_Rep_Id) return Node_Id is 11374 pragma Assert (Present (T_Id)); 11375 begin 11376 return Target_Reps.Table (T_Id).Spec_Decl; 11377 end Spec_Declaration; 11378 11379 ------------ 11380 -- Target -- 11381 ------------ 11382 11383 function Target (S_Id : Scenario_Rep_Id) return Entity_Id is 11384 pragma Assert (Present (S_Id)); 11385 begin 11386 return Scenario_Reps.Table (S_Id).Target; 11387 end Target; 11388 11389 ------------------------------ 11390 -- Target_Representation_Of -- 11391 ------------------------------ 11392 11393 function Target_Representation_Of 11394 (Id : Entity_Id; 11395 In_State : Processing_In_State) return Target_Rep_Id 11396 is 11397 T_Id : Target_Rep_Id; 11398 11399 begin 11400 T_Id := ETT_Map.Get (Entity_To_Target_Map, Id); 11401 11402 -- The elaboration target lacks an internal representation. This 11403 -- indicates that the target is encountered for the first time. 11404 -- Create the internal representation of it. 11405 11406 if not Present (T_Id) then 11407 Target_Reps.Append (Create_Target_Rep (Id, In_State)); 11408 T_Id := Target_Reps.Last; 11409 11410 -- Associate the internal representation with the elaboration 11411 -- target. 11412 11413 ETT_Map.Put (Entity_To_Target_Map, Id, T_Id); 11414 11415 -- The Processing phase is working with a partially analyzed tree, 11416 -- where various attributes become available as analysis continues. 11417 -- This case arrises in the context of guaranteed ABE processing. 11418 -- Update the existing representation by including new attributes. 11419 11420 elsif In_State.Representation = Inconsistent_Representation then 11421 Target_Reps.Table (T_Id) := Create_Target_Rep (Id, In_State); 11422 11423 -- Otherwise the Processing phase imposes a particular representation 11424 -- version which is not satisfied by the target. This case arrises 11425 -- when the Processing phase switches from guaranteed ABE checks and 11426 -- diagnostics to some other mode of operation. Update the existing 11427 -- representation to include all attributes. 11428 11429 elsif In_State.Representation /= Version (T_Id) then 11430 Target_Reps.Table (T_Id) := Create_Target_Rep (Id, In_State); 11431 end if; 11432 11433 pragma Assert (Present (T_Id)); 11434 11435 return T_Id; 11436 end Target_Representation_Of; 11437 11438 ------------------- 11439 -- To_Ghost_Mode -- 11440 ------------------- 11441 11442 function To_Ghost_Mode 11443 (Ignored_Status : Boolean) return Extended_Ghost_Mode 11444 is 11445 begin 11446 if Ignored_Status then 11447 return Is_Ignored; 11448 else 11449 return Is_Checked_Or_Not_Specified; 11450 end if; 11451 end To_Ghost_Mode; 11452 11453 ------------------- 11454 -- To_SPARK_Mode -- 11455 ------------------- 11456 11457 function To_SPARK_Mode 11458 (On_Status : Boolean) return Extended_SPARK_Mode 11459 is 11460 begin 11461 if On_Status then 11462 return Is_On; 11463 else 11464 return Is_Off_Or_Not_Specified; 11465 end if; 11466 end To_SPARK_Mode; 11467 11468 ---------- 11469 -- Unit -- 11470 ---------- 11471 11472 function Unit (T_Id : Target_Rep_Id) return Entity_Id is 11473 pragma Assert (Present (T_Id)); 11474 begin 11475 return Target_Reps.Table (T_Id).Unit; 11476 end Unit; 11477 11478 -------------------------- 11479 -- Variable_Declaration -- 11480 -------------------------- 11481 11482 function Variable_Declaration (T_Id : Target_Rep_Id) return Node_Id is 11483 pragma Assert (Present (T_Id)); 11484 pragma Assert (Kind (T_Id) = Variable_Target); 11485 11486 begin 11487 return Target_Reps.Table (T_Id).Field_1; 11488 end Variable_Declaration; 11489 11490 ------------- 11491 -- Version -- 11492 ------------- 11493 11494 function Version (T_Id : Target_Rep_Id) return Representation_Kind is 11495 pragma Assert (Present (T_Id)); 11496 begin 11497 return Target_Reps.Table (T_Id).Version; 11498 end Version; 11499 end Internal_Representation; 11500 11501 ---------------------- 11502 -- Invocation_Graph -- 11503 ---------------------- 11504 11505 package body Invocation_Graph is 11506 11507 ----------- 11508 -- Types -- 11509 ----------- 11510 11511 -- The following type represents simplified version of an invocation 11512 -- relation. 11513 11514 type Invoker_Target_Relation is record 11515 Invoker : Entity_Id := Empty; 11516 Target : Entity_Id := Empty; 11517 end record; 11518 11519 -- The following variables define the entities of the dummy elaboration 11520 -- procedures used as origins of library level paths. 11521 11522 Elab_Body_Id : Entity_Id := Empty; 11523 Elab_Spec_Id : Entity_Id := Empty; 11524 11525 --------------------- 11526 -- Data structures -- 11527 --------------------- 11528 11529 -- The following set contains all declared invocation constructs. It 11530 -- ensures that the same construct is not declared multiple times in 11531 -- the ALI file of the main unit. 11532 11533 Saved_Constructs_Set : NE_Set.Membership_Set := NE_Set.Nil; 11534 11535 function Hash (Key : Invoker_Target_Relation) return Bucket_Range_Type; 11536 -- Obtain the hash value of pair Key 11537 11538 package IR_Set is new Membership_Sets 11539 (Element_Type => Invoker_Target_Relation, 11540 "=" => "=", 11541 Hash => Hash); 11542 11543 -- The following set contains all recorded simple invocation relations. 11544 -- It ensures that multiple relations involving the same invoker and 11545 -- target do not appear in the ALI file of the main unit. 11546 11547 Saved_Relations_Set : IR_Set.Membership_Set := IR_Set.Nil; 11548 11549 -------------- 11550 -- Builders -- 11551 -------------- 11552 11553 function Signature_Of (Id : Entity_Id) return Invocation_Signature_Id; 11554 pragma Inline (Signature_Of); 11555 -- Obtain the invication signature id of arbitrary entity Id 11556 11557 ----------------------- 11558 -- Local subprograms -- 11559 ----------------------- 11560 11561 procedure Build_Elaborate_Body_Procedure; 11562 pragma Inline (Build_Elaborate_Body_Procedure); 11563 -- Create a dummy elaborate body procedure and store its entity in 11564 -- Elab_Body_Id. 11565 11566 procedure Build_Elaborate_Procedure 11567 (Proc_Id : out Entity_Id; 11568 Proc_Nam : Name_Id; 11569 Loc : Source_Ptr); 11570 pragma Inline (Build_Elaborate_Procedure); 11571 -- Create a dummy elaborate procedure with name Proc_Nam and source 11572 -- location Loc. The entity is returned in Proc_Id. 11573 11574 procedure Build_Elaborate_Spec_Procedure; 11575 pragma Inline (Build_Elaborate_Spec_Procedure); 11576 -- Create a dummy elaborate spec procedure and store its entity in 11577 -- Elab_Spec_Id. 11578 11579 function Build_Subprogram_Invocation 11580 (Subp_Id : Entity_Id) return Node_Id; 11581 pragma Inline (Build_Subprogram_Invocation); 11582 -- Create a dummy call marker that invokes subprogram Subp_Id 11583 11584 function Build_Task_Activation 11585 (Task_Typ : Entity_Id; 11586 In_State : Processing_In_State) return Node_Id; 11587 pragma Inline (Build_Task_Activation); 11588 -- Create a dummy call marker that activates an anonymous task object of 11589 -- type Task_Typ. 11590 11591 procedure Declare_Invocation_Construct 11592 (Constr_Id : Entity_Id; 11593 In_State : Processing_In_State); 11594 pragma Inline (Declare_Invocation_Construct); 11595 -- Declare invocation construct Constr_Id by creating a declaration for 11596 -- it in the ALI file of the main unit. In_State is the current state of 11597 -- the Processing phase. 11598 11599 function Invocation_Graph_Recording_OK return Boolean; 11600 pragma Inline (Invocation_Graph_Recording_OK); 11601 -- Determine whether the invocation graph can be recorded 11602 11603 function Is_Invocation_Scenario (N : Node_Id) return Boolean; 11604 pragma Inline (Is_Invocation_Scenario); 11605 -- Determine whether node N is a suitable scenario for invocation graph 11606 -- recording purposes. 11607 11608 function Is_Invocation_Target (Id : Entity_Id) return Boolean; 11609 pragma Inline (Is_Invocation_Target); 11610 -- Determine whether arbitrary entity Id denotes an invocation target 11611 11612 function Is_Saved_Construct (Constr : Entity_Id) return Boolean; 11613 pragma Inline (Is_Saved_Construct); 11614 -- Determine whether invocation construct Constr has already been 11615 -- declared in the ALI file of the main unit. 11616 11617 function Is_Saved_Relation 11618 (Rel : Invoker_Target_Relation) return Boolean; 11619 pragma Inline (Is_Saved_Relation); 11620 -- Determine whether simple invocation relation Rel has already been 11621 -- recorded in the ALI file of the main unit. 11622 11623 procedure Process_Declarations 11624 (Decls : List_Id; 11625 In_State : Processing_In_State); 11626 pragma Inline (Process_Declarations); 11627 -- Process declaration list Decls by processing all invocation scenarios 11628 -- within it. 11629 11630 procedure Process_Freeze_Node 11631 (Fnode : Node_Id; 11632 In_State : Processing_In_State); 11633 pragma Inline (Process_Freeze_Node); 11634 -- Process freeze node Fnode by processing all invocation scenarios in 11635 -- its Actions list. 11636 11637 procedure Process_Invocation_Activation 11638 (Call : Node_Id; 11639 Call_Rep : Scenario_Rep_Id; 11640 Obj_Id : Entity_Id; 11641 Obj_Rep : Target_Rep_Id; 11642 Task_Typ : Entity_Id; 11643 Task_Rep : Target_Rep_Id; 11644 In_State : Processing_In_State); 11645 pragma Inline (Process_Invocation_Activation); 11646 -- Process activation call Call which activates object Obj_Id of task 11647 -- type Task_Typ by processing all invocation scenarios within the task 11648 -- body. Call_Rep is the representation of the call. Obj_Rep denotes the 11649 -- representation of the object. Task_Rep is the representation of the 11650 -- task type. In_State is the current state of the Processing phase. 11651 11652 procedure Process_Invocation_Body_Scenarios; 11653 pragma Inline (Process_Invocation_Body_Scenarios); 11654 -- Process all library level body scenarios 11655 11656 procedure Process_Invocation_Call 11657 (Call : Node_Id; 11658 Call_Rep : Scenario_Rep_Id; 11659 In_State : Processing_In_State); 11660 pragma Inline (Process_Invocation_Call); 11661 -- Process invocation call scenario Call with representation Call_Rep. 11662 -- In_State is the current state of the Processing phase. 11663 11664 procedure Process_Invocation_Instantiation 11665 (Inst : Node_Id; 11666 Inst_Rep : Scenario_Rep_Id; 11667 In_State : Processing_In_State); 11668 pragma Inline (Process_Invocation_Instantiation); 11669 -- Process invocation instantiation scenario Inst with representation 11670 -- Inst_Rep. In_State is the current state of the Processing phase. 11671 11672 procedure Process_Invocation_Scenario 11673 (N : Node_Id; 11674 In_State : Processing_In_State); 11675 pragma Inline (Process_Invocation_Scenario); 11676 -- Process single invocation scenario N. In_State is the current state 11677 -- of the Processing phase. 11678 11679 procedure Process_Invocation_Scenarios 11680 (Iter : in out NE_Set.Iterator; 11681 In_State : Processing_In_State); 11682 pragma Inline (Process_Invocation_Scenarios); 11683 -- Process all invocation scenarios obtained via iterator Iter. In_State 11684 -- is the current state of the Processing phase. 11685 11686 procedure Process_Invocation_Spec_Scenarios; 11687 pragma Inline (Process_Invocation_Spec_Scenarios); 11688 -- Process all library level spec scenarios 11689 11690 procedure Process_Main_Unit; 11691 pragma Inline (Process_Main_Unit); 11692 -- Process all invocation scenarios within the main unit 11693 11694 procedure Process_Package_Declaration 11695 (Pack_Decl : Node_Id; 11696 In_State : Processing_In_State); 11697 pragma Inline (Process_Package_Declaration); 11698 -- Process package declaration Pack_Decl by processing all invocation 11699 -- scenarios in its visible and private declarations. If the main unit 11700 -- contains a generic, the declarations of the body are also examined. 11701 -- In_State is the current state of the Processing phase. 11702 11703 procedure Process_Protected_Type_Declaration 11704 (Prot_Decl : Node_Id; 11705 In_State : Processing_In_State); 11706 pragma Inline (Process_Protected_Type_Declaration); 11707 -- Process the declarations of protected type Prot_Decl. In_State is the 11708 -- current state of the Processing phase. 11709 11710 procedure Process_Subprogram_Declaration 11711 (Subp_Decl : Node_Id; 11712 In_State : Processing_In_State); 11713 pragma Inline (Process_Subprogram_Declaration); 11714 -- Process subprogram declaration Subp_Decl by processing all invocation 11715 -- scenarios within its body. In_State denotes the current state of the 11716 -- Processing phase. 11717 11718 procedure Process_Subprogram_Instantiation 11719 (Inst : Node_Id; 11720 In_State : Processing_In_State); 11721 pragma Inline (Process_Subprogram_Instantiation); 11722 -- Process subprogram instantiation Inst. In_State is the current state 11723 -- of the Processing phase. 11724 11725 procedure Process_Task_Type_Declaration 11726 (Task_Decl : Node_Id; 11727 In_State : Processing_In_State); 11728 pragma Inline (Process_Task_Type_Declaration); 11729 -- Process task declaration Task_Decl by processing all invocation 11730 -- scenarios within its body. In_State is the current state of the 11731 -- Processing phase. 11732 11733 procedure Record_Full_Invocation_Path (In_State : Processing_In_State); 11734 pragma Inline (Record_Full_Invocation_Path); 11735 -- Record all relations between scenario pairs found in the stack of 11736 -- active scenarios. In_State is the current state of the Processing 11737 -- phase. 11738 11739 procedure Record_Invocation_Graph_Encoding; 11740 pragma Inline (Record_Invocation_Graph_Encoding); 11741 -- Record the encoding format used to capture information related to 11742 -- invocation constructs and relations. 11743 11744 procedure Record_Invocation_Path (In_State : Processing_In_State); 11745 pragma Inline (Record_Invocation_Path); 11746 -- Record the invocation relations found within the path represented in 11747 -- the active scenario stack. In_State denotes the current state of the 11748 -- Processing phase. 11749 11750 procedure Record_Simple_Invocation_Path (In_State : Processing_In_State); 11751 pragma Inline (Record_Simple_Invocation_Path); 11752 -- Record a single relation from the start to the end of the stack of 11753 -- active scenarios. In_State is the current state of the Processing 11754 -- phase. 11755 11756 procedure Record_Invocation_Relation 11757 (Invk_Id : Entity_Id; 11758 Targ_Id : Entity_Id; 11759 In_State : Processing_In_State); 11760 pragma Inline (Record_Invocation_Relation); 11761 -- Record an invocation relation with invoker Invk_Id and target Targ_Id 11762 -- by creating an entry for it in the ALI file of the main unit. Formal 11763 -- In_State denotes the current state of the Processing phase. 11764 11765 procedure Set_Is_Saved_Construct 11766 (Constr : Entity_Id; 11767 Val : Boolean := True); 11768 pragma Inline (Set_Is_Saved_Construct); 11769 -- Mark invocation construct Constr as declared in the ALI file of the 11770 -- main unit depending on value Val. 11771 11772 procedure Set_Is_Saved_Relation 11773 (Rel : Invoker_Target_Relation; 11774 Val : Boolean := True); 11775 pragma Inline (Set_Is_Saved_Relation); 11776 -- Mark simple invocation relation Rel as recorded in the ALI file of 11777 -- the main unit depending on value Val. 11778 11779 function Target_Of 11780 (Pos : Active_Scenario_Pos; 11781 In_State : Processing_In_State) return Entity_Id; 11782 pragma Inline (Target_Of); 11783 -- Given position within the active scenario stack Pos, obtain the 11784 -- target of the indicated scenario. In_State is the current state 11785 -- of the Processing phase. 11786 11787 procedure Traverse_Invocation_Body 11788 (N : Node_Id; 11789 In_State : Processing_In_State); 11790 pragma Inline (Traverse_Invocation_Body); 11791 -- Traverse subprogram body N looking for suitable invocation scenarios 11792 -- that need to be processed for invocation graph recording purposes. 11793 -- In_State is the current state of the Processing phase. 11794 11795 procedure Write_Invocation_Path (In_State : Processing_In_State); 11796 pragma Inline (Write_Invocation_Path); 11797 -- Write out a path represented by the active scenario on the stack to 11798 -- standard output. In_State denotes the current state of the Processing 11799 -- phase. 11800 11801 ------------------------------------ 11802 -- Build_Elaborate_Body_Procedure -- 11803 ------------------------------------ 11804 11805 procedure Build_Elaborate_Body_Procedure is 11806 Body_Decl : Node_Id; 11807 Spec_Decl : Node_Id; 11808 11809 begin 11810 -- Nothing to do when a previous call already created the procedure 11811 11812 if Present (Elab_Body_Id) then 11813 return; 11814 end if; 11815 11816 Spec_And_Body_From_Entity 11817 (Id => Main_Unit_Entity, 11818 Body_Decl => Body_Decl, 11819 Spec_Decl => Spec_Decl); 11820 11821 pragma Assert (Present (Body_Decl)); 11822 11823 Build_Elaborate_Procedure 11824 (Proc_Id => Elab_Body_Id, 11825 Proc_Nam => Name_B, 11826 Loc => Sloc (Body_Decl)); 11827 end Build_Elaborate_Body_Procedure; 11828 11829 ------------------------------- 11830 -- Build_Elaborate_Procedure -- 11831 ------------------------------- 11832 11833 procedure Build_Elaborate_Procedure 11834 (Proc_Id : out Entity_Id; 11835 Proc_Nam : Name_Id; 11836 Loc : Source_Ptr) 11837 is 11838 Proc_Decl : Node_Id; 11839 pragma Unreferenced (Proc_Decl); 11840 11841 begin 11842 Proc_Id := Make_Defining_Identifier (Loc, Proc_Nam); 11843 11844 -- Partially decorate the elaboration procedure because it will not 11845 -- be insertred into the tree and analyzed. 11846 11847 Set_Ekind (Proc_Id, E_Procedure); 11848 Set_Etype (Proc_Id, Standard_Void_Type); 11849 Set_Scope (Proc_Id, Unique_Entity (Main_Unit_Entity)); 11850 11851 -- Create a dummy declaration for the elaboration procedure. The 11852 -- declaration does not need to be syntactically legal, but must 11853 -- carry an accurate source location. 11854 11855 Proc_Decl := 11856 Make_Subprogram_Body (Loc, 11857 Specification => 11858 Make_Procedure_Specification (Loc, 11859 Defining_Unit_Name => Proc_Id), 11860 Declarations => No_List, 11861 Handled_Statement_Sequence => Empty); 11862 end Build_Elaborate_Procedure; 11863 11864 ------------------------------------ 11865 -- Build_Elaborate_Spec_Procedure -- 11866 ------------------------------------ 11867 11868 procedure Build_Elaborate_Spec_Procedure is 11869 Body_Decl : Node_Id; 11870 Spec_Decl : Node_Id; 11871 11872 begin 11873 -- Nothing to do when a previous call already created the procedure 11874 11875 if Present (Elab_Spec_Id) then 11876 return; 11877 end if; 11878 11879 Spec_And_Body_From_Entity 11880 (Id => Main_Unit_Entity, 11881 Body_Decl => Body_Decl, 11882 Spec_Decl => Spec_Decl); 11883 11884 pragma Assert (Present (Spec_Decl)); 11885 11886 Build_Elaborate_Procedure 11887 (Proc_Id => Elab_Spec_Id, 11888 Proc_Nam => Name_S, 11889 Loc => Sloc (Spec_Decl)); 11890 end Build_Elaborate_Spec_Procedure; 11891 11892 --------------------------------- 11893 -- Build_Subprogram_Invocation -- 11894 --------------------------------- 11895 11896 function Build_Subprogram_Invocation 11897 (Subp_Id : Entity_Id) return Node_Id 11898 is 11899 Marker : constant Node_Id := Make_Call_Marker (Sloc (Subp_Id)); 11900 Subp_Decl : constant Node_Id := Unit_Declaration_Node (Subp_Id); 11901 11902 begin 11903 -- Create a dummy call marker which invokes the subprogram 11904 11905 Set_Is_Declaration_Level_Node (Marker, False); 11906 Set_Is_Dispatching_Call (Marker, False); 11907 Set_Is_Elaboration_Checks_OK_Node (Marker, False); 11908 Set_Is_Elaboration_Warnings_OK_Node (Marker, False); 11909 Set_Is_Ignored_Ghost_Node (Marker, False); 11910 Set_Is_Source_Call (Marker, False); 11911 Set_Is_SPARK_Mode_On_Node (Marker, False); 11912 11913 -- Invoke the uniform canonical entity of the subprogram 11914 11915 Set_Target (Marker, Canonical_Subprogram (Subp_Id)); 11916 11917 -- Partially insert the marker into the tree 11918 11919 Set_Parent (Marker, Parent (Subp_Decl)); 11920 11921 return Marker; 11922 end Build_Subprogram_Invocation; 11923 11924 --------------------------- 11925 -- Build_Task_Activation -- 11926 --------------------------- 11927 11928 function Build_Task_Activation 11929 (Task_Typ : Entity_Id; 11930 In_State : Processing_In_State) return Node_Id 11931 is 11932 Loc : constant Source_Ptr := Sloc (Task_Typ); 11933 Marker : constant Node_Id := Make_Call_Marker (Loc); 11934 Task_Decl : constant Node_Id := Unit_Declaration_Node (Task_Typ); 11935 11936 Activ_Id : Entity_Id; 11937 Marker_Rep_Id : Scenario_Rep_Id; 11938 Task_Obj : Entity_Id; 11939 Task_Objs : NE_List.Doubly_Linked_List; 11940 11941 begin 11942 -- Create a dummy call marker which activates some tasks 11943 11944 Set_Is_Declaration_Level_Node (Marker, False); 11945 Set_Is_Dispatching_Call (Marker, False); 11946 Set_Is_Elaboration_Checks_OK_Node (Marker, False); 11947 Set_Is_Elaboration_Warnings_OK_Node (Marker, False); 11948 Set_Is_Ignored_Ghost_Node (Marker, False); 11949 Set_Is_Source_Call (Marker, False); 11950 Set_Is_SPARK_Mode_On_Node (Marker, False); 11951 11952 -- Invoke the appropriate version of Activate_Tasks 11953 11954 if Restricted_Profile then 11955 Activ_Id := RTE (RE_Activate_Restricted_Tasks); 11956 else 11957 Activ_Id := RTE (RE_Activate_Tasks); 11958 end if; 11959 11960 Set_Target (Marker, Activ_Id); 11961 11962 -- Partially insert the marker into the tree 11963 11964 Set_Parent (Marker, Parent (Task_Decl)); 11965 11966 -- Create a dummy task object. Partially decorate the object because 11967 -- it will not be inserted into the tree and analyzed. 11968 11969 Task_Obj := Make_Temporary (Loc, 'T'); 11970 Set_Ekind (Task_Obj, E_Variable); 11971 Set_Etype (Task_Obj, Task_Typ); 11972 11973 -- Associate the dummy task object with the activation call 11974 11975 Task_Objs := NE_List.Create; 11976 NE_List.Append (Task_Objs, Task_Obj); 11977 11978 Marker_Rep_Id := Scenario_Representation_Of (Marker, In_State); 11979 Set_Activated_Task_Objects (Marker_Rep_Id, Task_Objs); 11980 Set_Activated_Task_Type (Marker_Rep_Id, Task_Typ); 11981 11982 return Marker; 11983 end Build_Task_Activation; 11984 11985 ---------------------------------- 11986 -- Declare_Invocation_Construct -- 11987 ---------------------------------- 11988 11989 procedure Declare_Invocation_Construct 11990 (Constr_Id : Entity_Id; 11991 In_State : Processing_In_State) 11992 is 11993 function Body_Placement_Of 11994 (Id : Entity_Id) return Declaration_Placement_Kind; 11995 pragma Inline (Body_Placement_Of); 11996 -- Obtain the placement of arbitrary entity Id's body 11997 11998 function Declaration_Placement_Of_Node 11999 (N : Node_Id) return Declaration_Placement_Kind; 12000 pragma Inline (Declaration_Placement_Of_Node); 12001 -- Obtain the placement of arbitrary node N 12002 12003 function Kind_Of (Id : Entity_Id) return Invocation_Construct_Kind; 12004 pragma Inline (Kind_Of); 12005 -- Obtain the invocation construct kind of arbitrary entity Id 12006 12007 function Spec_Placement_Of 12008 (Id : Entity_Id) return Declaration_Placement_Kind; 12009 pragma Inline (Spec_Placement_Of); 12010 -- Obtain the placement of arbitrary entity Id's spec 12011 12012 ----------------------- 12013 -- Body_Placement_Of -- 12014 ----------------------- 12015 12016 function Body_Placement_Of 12017 (Id : Entity_Id) return Declaration_Placement_Kind 12018 is 12019 Id_Rep : constant Target_Rep_Id := 12020 Target_Representation_Of (Id, In_State); 12021 Body_Decl : constant Node_Id := Body_Declaration (Id_Rep); 12022 Spec_Decl : constant Node_Id := Spec_Declaration (Id_Rep); 12023 12024 begin 12025 -- The entity has a body 12026 12027 if Present (Body_Decl) then 12028 return Declaration_Placement_Of_Node (Body_Decl); 12029 12030 -- Otherwise the entity must have a spec 12031 12032 else 12033 pragma Assert (Present (Spec_Decl)); 12034 return Declaration_Placement_Of_Node (Spec_Decl); 12035 end if; 12036 end Body_Placement_Of; 12037 12038 ----------------------------------- 12039 -- Declaration_Placement_Of_Node -- 12040 ----------------------------------- 12041 12042 function Declaration_Placement_Of_Node 12043 (N : Node_Id) return Declaration_Placement_Kind 12044 is 12045 Main_Unit_Id : constant Entity_Id := Main_Unit_Entity; 12046 N_Unit_Id : constant Entity_Id := Find_Top_Unit (N); 12047 12048 begin 12049 -- The node is in the main unit, its placement depends on the main 12050 -- unit kind. 12051 12052 if N_Unit_Id = Main_Unit_Id then 12053 12054 -- The main unit is a body 12055 12056 if Ekind_In (Main_Unit_Id, E_Package_Body, 12057 E_Subprogram_Body) 12058 then 12059 return In_Body; 12060 12061 -- The main unit is a stand-alone subprogram body 12062 12063 elsif Ekind_In (Main_Unit_Id, E_Function, E_Procedure) 12064 and then Nkind (Unit_Declaration_Node (Main_Unit_Id)) = 12065 N_Subprogram_Body 12066 then 12067 return In_Body; 12068 12069 -- Otherwise the main unit is a spec 12070 12071 else 12072 return In_Spec; 12073 end if; 12074 12075 -- Otherwise the node is in the complementary unit of the main 12076 -- unit. The main unit is a body, the node is in the spec. 12077 12078 elsif Ekind_In (Main_Unit_Id, E_Package_Body, 12079 E_Subprogram_Body) 12080 then 12081 return In_Spec; 12082 12083 -- The main unit is a spec, the node is in the body 12084 12085 else 12086 return In_Body; 12087 end if; 12088 end Declaration_Placement_Of_Node; 12089 12090 ------------- 12091 -- Kind_Of -- 12092 ------------- 12093 12094 function Kind_Of (Id : Entity_Id) return Invocation_Construct_Kind is 12095 begin 12096 if Id = Elab_Body_Id then 12097 return Elaborate_Body_Procedure; 12098 12099 elsif Id = Elab_Spec_Id then 12100 return Elaborate_Spec_Procedure; 12101 12102 else 12103 return Regular_Construct; 12104 end if; 12105 end Kind_Of; 12106 12107 ----------------------- 12108 -- Spec_Placement_Of -- 12109 ----------------------- 12110 12111 function Spec_Placement_Of 12112 (Id : Entity_Id) return Declaration_Placement_Kind 12113 is 12114 Id_Rep : constant Target_Rep_Id := 12115 Target_Representation_Of (Id, In_State); 12116 Body_Decl : constant Node_Id := Body_Declaration (Id_Rep); 12117 Spec_Decl : constant Node_Id := Spec_Declaration (Id_Rep); 12118 12119 begin 12120 -- The entity has a spec 12121 12122 if Present (Spec_Decl) then 12123 return Declaration_Placement_Of_Node (Spec_Decl); 12124 12125 -- Otherwise the entity must have a body 12126 12127 else 12128 pragma Assert (Present (Body_Decl)); 12129 return Declaration_Placement_Of_Node (Body_Decl); 12130 end if; 12131 end Spec_Placement_Of; 12132 12133 -- Start of processing for Declare_Invocation_Construct 12134 12135 begin 12136 -- Nothing to do when the construct has already been declared in the 12137 -- ALI file. 12138 12139 if Is_Saved_Construct (Constr_Id) then 12140 return; 12141 end if; 12142 12143 -- Mark the construct as declared in the ALI file 12144 12145 Set_Is_Saved_Construct (Constr_Id); 12146 12147 -- Add the construct in the ALI file 12148 12149 Add_Invocation_Construct 12150 (Body_Placement => Body_Placement_Of (Constr_Id), 12151 Kind => Kind_Of (Constr_Id), 12152 Signature => Signature_Of (Constr_Id), 12153 Spec_Placement => Spec_Placement_Of (Constr_Id), 12154 Update_Units => False); 12155 end Declare_Invocation_Construct; 12156 12157 ------------------------------- 12158 -- Finalize_Invocation_Graph -- 12159 ------------------------------- 12160 12161 procedure Finalize_Invocation_Graph is 12162 begin 12163 NE_Set.Destroy (Saved_Constructs_Set); 12164 IR_Set.Destroy (Saved_Relations_Set); 12165 end Finalize_Invocation_Graph; 12166 12167 ---------- 12168 -- Hash -- 12169 ---------- 12170 12171 function Hash (Key : Invoker_Target_Relation) return Bucket_Range_Type is 12172 pragma Assert (Present (Key.Invoker)); 12173 pragma Assert (Present (Key.Target)); 12174 12175 begin 12176 return 12177 Hash_Two_Keys 12178 (Bucket_Range_Type (Key.Invoker), 12179 Bucket_Range_Type (Key.Target)); 12180 end Hash; 12181 12182 --------------------------------- 12183 -- Initialize_Invocation_Graph -- 12184 --------------------------------- 12185 12186 procedure Initialize_Invocation_Graph is 12187 begin 12188 Saved_Constructs_Set := NE_Set.Create (100); 12189 Saved_Relations_Set := IR_Set.Create (200); 12190 end Initialize_Invocation_Graph; 12191 12192 ----------------------------------- 12193 -- Invocation_Graph_Recording_OK -- 12194 ----------------------------------- 12195 12196 function Invocation_Graph_Recording_OK return Boolean is 12197 Main_Cunit : constant Node_Id := Cunit (Main_Unit); 12198 12199 begin 12200 -- Nothing to do when compiling for GNATprove because the invocation 12201 -- graph is not needed. 12202 12203 if GNATprove_Mode then 12204 return False; 12205 12206 -- Nothing to do when the compilation will not produce an ALI file 12207 12208 elsif Serious_Errors_Detected > 0 then 12209 return False; 12210 12211 -- Nothing to do when the main unit requires a body. Processing the 12212 -- completing body will create the ALI file for the unit and record 12213 -- the invocation graph. 12214 12215 elsif Body_Required (Main_Cunit) then 12216 return False; 12217 end if; 12218 12219 return True; 12220 end Invocation_Graph_Recording_OK; 12221 12222 ---------------------------- 12223 -- Is_Invocation_Scenario -- 12224 ---------------------------- 12225 12226 function Is_Invocation_Scenario (N : Node_Id) return Boolean is 12227 begin 12228 return 12229 Is_Suitable_Access_Taken (N) 12230 or else Is_Suitable_Call (N) 12231 or else Is_Suitable_Instantiation (N); 12232 end Is_Invocation_Scenario; 12233 12234 -------------------------- 12235 -- Is_Invocation_Target -- 12236 -------------------------- 12237 12238 function Is_Invocation_Target (Id : Entity_Id) return Boolean is 12239 begin 12240 -- To qualify, the entity must either come from source, or denote an 12241 -- Ada, bridge, or SPARK target. 12242 12243 return 12244 Comes_From_Source (Id) 12245 or else Is_Ada_Semantic_Target (Id) 12246 or else Is_Bridge_Target (Id) 12247 or else Is_SPARK_Semantic_Target (Id); 12248 end Is_Invocation_Target; 12249 12250 ------------------------ 12251 -- Is_Saved_Construct -- 12252 ------------------------ 12253 12254 function Is_Saved_Construct (Constr : Entity_Id) return Boolean is 12255 pragma Assert (Present (Constr)); 12256 begin 12257 return NE_Set.Contains (Saved_Constructs_Set, Constr); 12258 end Is_Saved_Construct; 12259 12260 ----------------------- 12261 -- Is_Saved_Relation -- 12262 ----------------------- 12263 12264 function Is_Saved_Relation 12265 (Rel : Invoker_Target_Relation) return Boolean 12266 is 12267 pragma Assert (Present (Rel.Invoker)); 12268 pragma Assert (Present (Rel.Target)); 12269 12270 begin 12271 return IR_Set.Contains (Saved_Relations_Set, Rel); 12272 end Is_Saved_Relation; 12273 12274 -------------------------- 12275 -- Process_Declarations -- 12276 -------------------------- 12277 12278 procedure Process_Declarations 12279 (Decls : List_Id; 12280 In_State : Processing_In_State) 12281 is 12282 Decl : Node_Id; 12283 12284 begin 12285 Decl := First (Decls); 12286 while Present (Decl) loop 12287 12288 -- Freeze node 12289 12290 if Nkind (Decl) = N_Freeze_Entity then 12291 Process_Freeze_Node 12292 (Fnode => Decl, 12293 In_State => In_State); 12294 12295 -- Package (nested) 12296 12297 elsif Nkind (Decl) = N_Package_Declaration then 12298 Process_Package_Declaration 12299 (Pack_Decl => Decl, 12300 In_State => In_State); 12301 12302 -- Protected type 12303 12304 elsif Nkind_In (Decl, N_Protected_Type_Declaration, 12305 N_Single_Protected_Declaration) 12306 then 12307 Process_Protected_Type_Declaration 12308 (Prot_Decl => Decl, 12309 In_State => In_State); 12310 12311 -- Subprogram or entry 12312 12313 elsif Nkind_In (Decl, N_Entry_Declaration, 12314 N_Subprogram_Declaration) 12315 then 12316 Process_Subprogram_Declaration 12317 (Subp_Decl => Decl, 12318 In_State => In_State); 12319 12320 -- Subprogram body (stand alone) 12321 12322 elsif Nkind (Decl) = N_Subprogram_Body 12323 and then No (Corresponding_Spec (Decl)) 12324 then 12325 Process_Subprogram_Declaration 12326 (Subp_Decl => Decl, 12327 In_State => In_State); 12328 12329 -- Subprogram instantiation 12330 12331 elsif Nkind (Decl) in N_Subprogram_Instantiation then 12332 Process_Subprogram_Instantiation 12333 (Inst => Decl, 12334 In_State => In_State); 12335 12336 -- Task type 12337 12338 elsif Nkind_In (Decl, N_Single_Task_Declaration, 12339 N_Task_Type_Declaration) 12340 then 12341 Process_Task_Type_Declaration 12342 (Task_Decl => Decl, 12343 In_State => In_State); 12344 12345 -- Task type (derived) 12346 12347 elsif Nkind (Decl) = N_Full_Type_Declaration 12348 and then Is_Task_Type (Defining_Entity (Decl)) 12349 then 12350 Process_Task_Type_Declaration 12351 (Task_Decl => Decl, 12352 In_State => In_State); 12353 end if; 12354 12355 Next (Decl); 12356 end loop; 12357 end Process_Declarations; 12358 12359 ------------------------- 12360 -- Process_Freeze_Node -- 12361 ------------------------- 12362 12363 procedure Process_Freeze_Node 12364 (Fnode : Node_Id; 12365 In_State : Processing_In_State) 12366 is 12367 begin 12368 Process_Declarations 12369 (Decls => Actions (Fnode), 12370 In_State => In_State); 12371 end Process_Freeze_Node; 12372 12373 ----------------------------------- 12374 -- Process_Invocation_Activation -- 12375 ----------------------------------- 12376 12377 procedure Process_Invocation_Activation 12378 (Call : Node_Id; 12379 Call_Rep : Scenario_Rep_Id; 12380 Obj_Id : Entity_Id; 12381 Obj_Rep : Target_Rep_Id; 12382 Task_Typ : Entity_Id; 12383 Task_Rep : Target_Rep_Id; 12384 In_State : Processing_In_State) 12385 is 12386 pragma Unreferenced (Call); 12387 pragma Unreferenced (Call_Rep); 12388 pragma Unreferenced (Obj_Id); 12389 pragma Unreferenced (Obj_Rep); 12390 12391 begin 12392 -- Nothing to do when the task type appears within an internal unit 12393 12394 if In_Internal_Unit (Task_Typ) then 12395 return; 12396 end if; 12397 12398 -- The task type being activated is within the main unit. Extend the 12399 -- DFS traversal into its body. 12400 12401 if In_Extended_Main_Code_Unit (Task_Typ) then 12402 Traverse_Invocation_Body 12403 (N => Body_Declaration (Task_Rep), 12404 In_State => In_State); 12405 12406 -- The task type being activated resides within an external unit 12407 -- 12408 -- Main unit External unit 12409 -- +-----------+ +-------------+ 12410 -- | | | | 12411 -- | Start ------------> Task_Typ | 12412 -- | | | | 12413 -- +-----------+ +-------------+ 12414 -- 12415 -- Record the invocation path which originates from Start and reaches 12416 -- the task type. 12417 12418 else 12419 Record_Invocation_Path (In_State); 12420 end if; 12421 end Process_Invocation_Activation; 12422 12423 --------------------------------------- 12424 -- Process_Invocation_Body_Scenarios -- 12425 --------------------------------------- 12426 12427 procedure Process_Invocation_Body_Scenarios is 12428 Iter : NE_Set.Iterator := Iterate_Library_Body_Scenarios; 12429 begin 12430 Process_Invocation_Scenarios 12431 (Iter => Iter, 12432 In_State => Invocation_Body_State); 12433 end Process_Invocation_Body_Scenarios; 12434 12435 ----------------------------- 12436 -- Process_Invocation_Call -- 12437 ----------------------------- 12438 12439 procedure Process_Invocation_Call 12440 (Call : Node_Id; 12441 Call_Rep : Scenario_Rep_Id; 12442 In_State : Processing_In_State) 12443 is 12444 pragma Unreferenced (Call); 12445 12446 Subp_Id : constant Entity_Id := Target (Call_Rep); 12447 Subp_Rep : constant Target_Rep_Id := 12448 Target_Representation_Of (Subp_Id, In_State); 12449 12450 begin 12451 -- Nothing to do when the subprogram appears within an internal unit 12452 12453 if In_Internal_Unit (Subp_Id) then 12454 return; 12455 12456 -- Nothing to do for an abstract subprogram because it has no body to 12457 -- examine. 12458 12459 elsif Ekind_In (Subp_Id, E_Function, E_Procedure) 12460 and then Is_Abstract_Subprogram (Subp_Id) 12461 then 12462 return; 12463 12464 -- Nothin to do for a formal subprogram because it has no body to 12465 -- examine. 12466 12467 elsif Is_Formal_Subprogram (Subp_Id) then 12468 return; 12469 end if; 12470 12471 -- The subprogram being called is within the main unit. Extend the 12472 -- DFS traversal into its barrier function and body. 12473 12474 if In_Extended_Main_Code_Unit (Subp_Id) then 12475 if Ekind_In (Subp_Id, E_Entry, E_Entry_Family, E_Procedure) then 12476 Traverse_Invocation_Body 12477 (N => Barrier_Body_Declaration (Subp_Rep), 12478 In_State => In_State); 12479 end if; 12480 12481 Traverse_Invocation_Body 12482 (N => Body_Declaration (Subp_Rep), 12483 In_State => In_State); 12484 12485 -- The subprogram being called resides within an external unit 12486 -- 12487 -- Main unit External unit 12488 -- +-----------+ +-------------+ 12489 -- | | | | 12490 -- | Start ------------> Subp_Id | 12491 -- | | | | 12492 -- +-----------+ +-------------+ 12493 -- 12494 -- Record the invocation path which originates from Start and reaches 12495 -- the subprogram. 12496 12497 else 12498 Record_Invocation_Path (In_State); 12499 end if; 12500 end Process_Invocation_Call; 12501 12502 -------------------------------------- 12503 -- Process_Invocation_Instantiation -- 12504 -------------------------------------- 12505 12506 procedure Process_Invocation_Instantiation 12507 (Inst : Node_Id; 12508 Inst_Rep : Scenario_Rep_Id; 12509 In_State : Processing_In_State) 12510 is 12511 pragma Unreferenced (Inst); 12512 12513 Gen_Id : constant Entity_Id := Target (Inst_Rep); 12514 12515 begin 12516 -- Nothing to do when the generic appears within an internal unit 12517 12518 if In_Internal_Unit (Gen_Id) then 12519 return; 12520 end if; 12521 12522 -- The generic being instantiated resides within an external unit 12523 -- 12524 -- Main unit External unit 12525 -- +-----------+ +-------------+ 12526 -- | | | | 12527 -- | Start ------------> Generic | 12528 -- | | | | 12529 -- +-----------+ +-------------+ 12530 -- 12531 -- Record the invocation path which originates from Start and reaches 12532 -- the generic. 12533 12534 if not In_Extended_Main_Code_Unit (Gen_Id) then 12535 Record_Invocation_Path (In_State); 12536 end if; 12537 end Process_Invocation_Instantiation; 12538 12539 --------------------------------- 12540 -- Process_Invocation_Scenario -- 12541 --------------------------------- 12542 12543 procedure Process_Invocation_Scenario 12544 (N : Node_Id; 12545 In_State : Processing_In_State) 12546 is 12547 Scen : constant Node_Id := Scenario (N); 12548 Scen_Rep : Scenario_Rep_Id; 12549 12550 begin 12551 -- Add the current scenario to the stack of active scenarios 12552 12553 Push_Active_Scenario (Scen); 12554 12555 -- Call or task activation 12556 12557 if Is_Suitable_Call (Scen) then 12558 Scen_Rep := Scenario_Representation_Of (Scen, In_State); 12559 12560 -- Routine Build_Call_Marker creates call markers regardless of 12561 -- whether the call occurs within the main unit or not. This way 12562 -- the serialization of internal names is kept consistent. Only 12563 -- call markers found within the main unit must be processed. 12564 12565 if In_Main_Context (Scen) then 12566 Scen_Rep := Scenario_Representation_Of (Scen, In_State); 12567 12568 if Kind (Scen_Rep) = Call_Scenario then 12569 Process_Invocation_Call 12570 (Call => Scen, 12571 Call_Rep => Scen_Rep, 12572 In_State => In_State); 12573 12574 else 12575 pragma Assert (Kind (Scen_Rep) = Task_Activation_Scenario); 12576 12577 Process_Activation 12578 (Call => Scen, 12579 Call_Rep => Scen_Rep, 12580 Processor => Process_Invocation_Activation'Access, 12581 In_State => In_State); 12582 end if; 12583 end if; 12584 12585 -- Instantiation 12586 12587 elsif Is_Suitable_Instantiation (Scen) then 12588 Process_Invocation_Instantiation 12589 (Inst => Scen, 12590 Inst_Rep => Scenario_Representation_Of (Scen, In_State), 12591 In_State => In_State); 12592 end if; 12593 12594 -- Remove the current scenario from the stack of active scenarios 12595 -- once all invocation constructs and paths have been saved. 12596 12597 Pop_Active_Scenario (Scen); 12598 end Process_Invocation_Scenario; 12599 12600 ---------------------------------- 12601 -- Process_Invocation_Scenarios -- 12602 ---------------------------------- 12603 12604 procedure Process_Invocation_Scenarios 12605 (Iter : in out NE_Set.Iterator; 12606 In_State : Processing_In_State) 12607 is 12608 N : Node_Id; 12609 12610 begin 12611 while NE_Set.Has_Next (Iter) loop 12612 NE_Set.Next (Iter, N); 12613 12614 -- Reset the traversed status of all subprogram bodies because the 12615 -- current invocation scenario acts as a new DFS traversal root. 12616 12617 Reset_Traversed_Bodies; 12618 12619 Process_Invocation_Scenario (N, In_State); 12620 end loop; 12621 end Process_Invocation_Scenarios; 12622 12623 --------------------------------------- 12624 -- Process_Invocation_Spec_Scenarios -- 12625 --------------------------------------- 12626 12627 procedure Process_Invocation_Spec_Scenarios is 12628 Iter : NE_Set.Iterator := Iterate_Library_Spec_Scenarios; 12629 begin 12630 Process_Invocation_Scenarios 12631 (Iter => Iter, 12632 In_State => Invocation_Spec_State); 12633 end Process_Invocation_Spec_Scenarios; 12634 12635 ----------------------- 12636 -- Process_Main_Unit -- 12637 ----------------------- 12638 12639 procedure Process_Main_Unit is 12640 Unit_Decl : constant Node_Id := Unit (Cunit (Main_Unit)); 12641 Spec_Id : Entity_Id; 12642 12643 begin 12644 -- The main unit is a [generic] package body 12645 12646 if Nkind (Unit_Decl) = N_Package_Body then 12647 Spec_Id := Corresponding_Spec (Unit_Decl); 12648 pragma Assert (Present (Spec_Id)); 12649 12650 Process_Package_Declaration 12651 (Pack_Decl => Unit_Declaration_Node (Spec_Id), 12652 In_State => Invocation_Construct_State); 12653 12654 -- The main unit is a [generic] package declaration 12655 12656 elsif Nkind (Unit_Decl) = N_Package_Declaration then 12657 Process_Package_Declaration 12658 (Pack_Decl => Unit_Decl, 12659 In_State => Invocation_Construct_State); 12660 12661 -- The main unit is a [generic] subprogram body 12662 12663 elsif Nkind (Unit_Decl) = N_Subprogram_Body then 12664 Spec_Id := Corresponding_Spec (Unit_Decl); 12665 12666 -- The body completes a previous declaration 12667 12668 if Present (Spec_Id) then 12669 Process_Subprogram_Declaration 12670 (Subp_Decl => Unit_Declaration_Node (Spec_Id), 12671 In_State => Invocation_Construct_State); 12672 12673 -- Otherwise the body is stand-alone 12674 12675 else 12676 Process_Subprogram_Declaration 12677 (Subp_Decl => Unit_Decl, 12678 In_State => Invocation_Construct_State); 12679 end if; 12680 12681 -- The main unit is a subprogram instantiation 12682 12683 elsif Nkind (Unit_Decl) in N_Subprogram_Instantiation then 12684 Process_Subprogram_Instantiation 12685 (Inst => Unit_Decl, 12686 In_State => Invocation_Construct_State); 12687 12688 -- The main unit is an imported subprogram declaration 12689 12690 elsif Nkind (Unit_Decl) = N_Subprogram_Declaration then 12691 Process_Subprogram_Declaration 12692 (Subp_Decl => Unit_Decl, 12693 In_State => Invocation_Construct_State); 12694 end if; 12695 end Process_Main_Unit; 12696 12697 --------------------------------- 12698 -- Process_Package_Declaration -- 12699 --------------------------------- 12700 12701 procedure Process_Package_Declaration 12702 (Pack_Decl : Node_Id; 12703 In_State : Processing_In_State) 12704 is 12705 Body_Id : constant Entity_Id := Corresponding_Body (Pack_Decl); 12706 Spec : constant Node_Id := Specification (Pack_Decl); 12707 Spec_Id : constant Entity_Id := Defining_Entity (Pack_Decl); 12708 12709 begin 12710 -- Add a declaration for the generic package in the ALI of the main 12711 -- unit in case a client unit instantiates it. 12712 12713 if Ekind (Spec_Id) = E_Generic_Package then 12714 Declare_Invocation_Construct 12715 (Constr_Id => Spec_Id, 12716 In_State => In_State); 12717 12718 -- Otherwise inspect the visible and private declarations of the 12719 -- package for invocation constructs. 12720 12721 else 12722 Process_Declarations 12723 (Decls => Visible_Declarations (Spec), 12724 In_State => In_State); 12725 12726 Process_Declarations 12727 (Decls => Private_Declarations (Spec), 12728 In_State => In_State); 12729 12730 -- The package body containst at least one generic unit or an 12731 -- inlinable subprogram. Such constructs may grant clients of 12732 -- the main unit access to the private enclosing contexts of 12733 -- the constructs. Process the main unit body to discover and 12734 -- encode relevant invocation constructs and relations that 12735 -- may ultimately reach an external unit. 12736 12737 if Present (Body_Id) 12738 and then Save_Invocation_Graph_Of_Body (Cunit (Main_Unit)) 12739 then 12740 Process_Declarations 12741 (Decls => Declarations (Unit_Declaration_Node (Body_Id)), 12742 In_State => In_State); 12743 end if; 12744 end if; 12745 end Process_Package_Declaration; 12746 12747 ---------------------------------------- 12748 -- Process_Protected_Type_Declaration -- 12749 ---------------------------------------- 12750 12751 procedure Process_Protected_Type_Declaration 12752 (Prot_Decl : Node_Id; 12753 In_State : Processing_In_State) 12754 is 12755 Prot_Def : constant Node_Id := Protected_Definition (Prot_Decl); 12756 12757 begin 12758 if Present (Prot_Def) then 12759 Process_Declarations 12760 (Decls => Visible_Declarations (Prot_Def), 12761 In_State => In_State); 12762 end if; 12763 end Process_Protected_Type_Declaration; 12764 12765 ------------------------------------ 12766 -- Process_Subprogram_Declaration -- 12767 ------------------------------------ 12768 12769 procedure Process_Subprogram_Declaration 12770 (Subp_Decl : Node_Id; 12771 In_State : Processing_In_State) 12772 is 12773 Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl); 12774 12775 begin 12776 -- Nothing to do when the subprogram is not an invocation target 12777 12778 if not Is_Invocation_Target (Subp_Id) then 12779 return; 12780 end if; 12781 12782 -- Add a declaration for the subprogram in the ALI file of the main 12783 -- unit in case a client unit calls or instantiates it. 12784 12785 Declare_Invocation_Construct 12786 (Constr_Id => Subp_Id, 12787 In_State => In_State); 12788 12789 -- Do not process subprograms without a body because they do not 12790 -- contain any invocation scenarios. 12791 12792 if Is_Bodiless_Subprogram (Subp_Id) then 12793 null; 12794 12795 -- Do not process generic subprograms because generics must not be 12796 -- examined. 12797 12798 elsif Is_Generic_Subprogram (Subp_Id) then 12799 null; 12800 12801 -- Otherwise create a dummy scenario which calls the subprogram to 12802 -- act as a root for a DFS traversal. 12803 12804 else 12805 -- Reset the traversed status of all subprogram bodies because the 12806 -- subprogram acts as a new DFS traversal root. 12807 12808 Reset_Traversed_Bodies; 12809 12810 Process_Invocation_Scenario 12811 (N => Build_Subprogram_Invocation (Subp_Id), 12812 In_State => In_State); 12813 end if; 12814 end Process_Subprogram_Declaration; 12815 12816 -------------------------------------- 12817 -- Process_Subprogram_Instantiation -- 12818 -------------------------------------- 12819 12820 procedure Process_Subprogram_Instantiation 12821 (Inst : Node_Id; 12822 In_State : Processing_In_State) 12823 is 12824 begin 12825 -- Add a declaration for the instantiation in the ALI file of the 12826 -- main unit in case a client unit calls it. 12827 12828 Declare_Invocation_Construct 12829 (Constr_Id => Defining_Entity (Inst), 12830 In_State => In_State); 12831 end Process_Subprogram_Instantiation; 12832 12833 ----------------------------------- 12834 -- Process_Task_Type_Declaration -- 12835 ----------------------------------- 12836 12837 procedure Process_Task_Type_Declaration 12838 (Task_Decl : Node_Id; 12839 In_State : Processing_In_State) 12840 is 12841 Task_Typ : constant Entity_Id := Defining_Entity (Task_Decl); 12842 Task_Def : Node_Id; 12843 12844 begin 12845 -- Add a declaration for the task type the ALI file of the main unit 12846 -- in case a client unit creates a task object and activates it. 12847 12848 Declare_Invocation_Construct 12849 (Constr_Id => Task_Typ, 12850 In_State => In_State); 12851 12852 -- Process the entries of the task type because they represent valid 12853 -- entry points into the task body. 12854 12855 if Nkind_In (Task_Decl, N_Single_Task_Declaration, 12856 N_Task_Type_Declaration) 12857 then 12858 Task_Def := Task_Definition (Task_Decl); 12859 12860 if Present (Task_Def) then 12861 Process_Declarations 12862 (Decls => Visible_Declarations (Task_Def), 12863 In_State => In_State); 12864 end if; 12865 end if; 12866 12867 -- Reset the traversed status of all subprogram bodies because the 12868 -- task type acts as a new DFS traversal root. 12869 12870 Reset_Traversed_Bodies; 12871 12872 -- Create a dummy scenario which activates an anonymous object of the 12873 -- task type to acts as a root of a DFS traversal. 12874 12875 Process_Invocation_Scenario 12876 (N => Build_Task_Activation (Task_Typ, In_State), 12877 In_State => In_State); 12878 end Process_Task_Type_Declaration; 12879 12880 --------------------------------- 12881 -- Record_Full_Invocation_Path -- 12882 --------------------------------- 12883 12884 procedure Record_Full_Invocation_Path (In_State : Processing_In_State) is 12885 package Scenarios renames Active_Scenario_Stack; 12886 12887 begin 12888 -- The path originates from the elaboration of the body. Add an extra 12889 -- relation from the elaboration body procedure to the first active 12890 -- scenario. 12891 12892 if In_State.Processing = Invocation_Body_Processing then 12893 Build_Elaborate_Body_Procedure; 12894 12895 Record_Invocation_Relation 12896 (Invk_Id => Elab_Body_Id, 12897 Targ_Id => Target_Of (Scenarios.First, In_State), 12898 In_State => In_State); 12899 12900 -- The path originates from the elaboration of the spec. Add an extra 12901 -- relation from the elaboration spec procedure to the first active 12902 -- scenario. 12903 12904 elsif In_State.Processing = Invocation_Spec_Processing then 12905 Build_Elaborate_Spec_Procedure; 12906 12907 Record_Invocation_Relation 12908 (Invk_Id => Elab_Spec_Id, 12909 Targ_Id => Target_Of (Scenarios.First, In_State), 12910 In_State => In_State); 12911 end if; 12912 12913 -- Record individual relations formed by pairs of scenarios 12914 12915 for Index in Scenarios.First .. Scenarios.Last - 1 loop 12916 Record_Invocation_Relation 12917 (Invk_Id => Target_Of (Index, In_State), 12918 Targ_Id => Target_Of (Index + 1, In_State), 12919 In_State => In_State); 12920 end loop; 12921 end Record_Full_Invocation_Path; 12922 12923 ----------------------------- 12924 -- Record_Invocation_Graph -- 12925 ----------------------------- 12926 12927 procedure Record_Invocation_Graph is 12928 begin 12929 -- Nothing to do when the invocation graph is not recorded 12930 12931 if not Invocation_Graph_Recording_OK then 12932 return; 12933 end if; 12934 12935 -- Save the encoding format used to capture information about the 12936 -- invocation constructs and relations in the ALI file of the main 12937 -- unit. 12938 12939 Record_Invocation_Graph_Encoding; 12940 12941 -- Examine all library level invocation scenarios and perform DFS 12942 -- traversals from each one. Encode a path in the ALI file of the 12943 -- main unit if it reaches into an external unit. 12944 12945 Process_Invocation_Body_Scenarios; 12946 Process_Invocation_Spec_Scenarios; 12947 12948 -- Examine all invocation constructs within the spec and body of the 12949 -- main unit and perform DFS traversals from each one. Encode a path 12950 -- in the ALI file of the main unit if it reaches into an external 12951 -- unit. 12952 12953 Process_Main_Unit; 12954 end Record_Invocation_Graph; 12955 12956 -------------------------------------- 12957 -- Record_Invocation_Graph_Encoding -- 12958 -------------------------------------- 12959 12960 procedure Record_Invocation_Graph_Encoding is 12961 Kind : Invocation_Graph_Encoding_Kind := No_Encoding; 12962 12963 begin 12964 -- Switch -gnatd_F (encode full invocation paths in ALI files) is in 12965 -- effect. 12966 12967 if Debug_Flag_Underscore_FF then 12968 Kind := Full_Path_Encoding; 12969 else 12970 Kind := Endpoints_Encoding; 12971 end if; 12972 12973 -- Save the encoding format in the ALI file of the main unit 12974 12975 Set_Invocation_Graph_Encoding 12976 (Kind => Kind, 12977 Update_Units => False); 12978 end Record_Invocation_Graph_Encoding; 12979 12980 ---------------------------- 12981 -- Record_Invocation_Path -- 12982 ---------------------------- 12983 12984 procedure Record_Invocation_Path (In_State : Processing_In_State) is 12985 package Scenarios renames Active_Scenario_Stack; 12986 12987 begin 12988 -- Save a path when the active scenario stack contains at least one 12989 -- invocation scenario. 12990 12991 if Scenarios.Last - Scenarios.First < 0 then 12992 return; 12993 end if; 12994 12995 -- Register all relations in the path when switch -gnatd_F (encode 12996 -- full invocation paths in ALI files) is in effect. 12997 12998 if Debug_Flag_Underscore_FF then 12999 Record_Full_Invocation_Path (In_State); 13000 13001 -- Otherwise register a single relation 13002 13003 else 13004 Record_Simple_Invocation_Path (In_State); 13005 end if; 13006 13007 Write_Invocation_Path (In_State); 13008 end Record_Invocation_Path; 13009 13010 -------------------------------- 13011 -- Record_Invocation_Relation -- 13012 -------------------------------- 13013 13014 procedure Record_Invocation_Relation 13015 (Invk_Id : Entity_Id; 13016 Targ_Id : Entity_Id; 13017 In_State : Processing_In_State) 13018 is 13019 pragma Assert (Present (Invk_Id)); 13020 pragma Assert (Present (Targ_Id)); 13021 13022 procedure Get_Invocation_Attributes 13023 (Extra : out Entity_Id; 13024 Kind : out Invocation_Kind); 13025 pragma Inline (Get_Invocation_Attributes); 13026 -- Return the additional entity used in error diagnostics in Extra 13027 -- and the invocation kind in Kind which pertain to the invocation 13028 -- relation with invoker Invk_Id and target Targ_Id. 13029 13030 ------------------------------- 13031 -- Get_Invocation_Attributes -- 13032 ------------------------------- 13033 13034 procedure Get_Invocation_Attributes 13035 (Extra : out Entity_Id; 13036 Kind : out Invocation_Kind) 13037 is 13038 Targ_Rep : constant Target_Rep_Id := 13039 Target_Representation_Of (Targ_Id, In_State); 13040 Spec_Decl : constant Node_Id := Spec_Declaration (Targ_Rep); 13041 13042 begin 13043 -- Accept within a task body 13044 13045 if Is_Accept_Alternative_Proc (Targ_Id) then 13046 Extra := Receiving_Entry (Targ_Id); 13047 Kind := Accept_Alternative; 13048 13049 -- Activation of a task object 13050 13051 elsif Is_Activation_Proc (Targ_Id) 13052 or else Is_Task_Type (Targ_Id) 13053 then 13054 Extra := Empty; 13055 Kind := Task_Activation; 13056 13057 -- Controlled adjustment actions 13058 13059 elsif Is_Controlled_Proc (Targ_Id, Name_Adjust) then 13060 Extra := First_Formal_Type (Targ_Id); 13061 Kind := Controlled_Adjustment; 13062 13063 -- Controlled finalization actions 13064 13065 elsif Is_Controlled_Proc (Targ_Id, Name_Finalize) 13066 or else Is_Finalizer_Proc (Targ_Id) 13067 then 13068 Extra := First_Formal_Type (Targ_Id); 13069 Kind := Controlled_Finalization; 13070 13071 -- Controlled initialization actions 13072 13073 elsif Is_Controlled_Proc (Targ_Id, Name_Initialize) then 13074 Extra := First_Formal_Type (Targ_Id); 13075 Kind := Controlled_Initialization; 13076 13077 -- Default_Initial_Condition verification 13078 13079 elsif Is_Default_Initial_Condition_Proc (Targ_Id) then 13080 Extra := First_Formal_Type (Targ_Id); 13081 Kind := Default_Initial_Condition_Verification; 13082 13083 -- Initialization of object 13084 13085 elsif Is_Init_Proc (Targ_Id) then 13086 Extra := First_Formal_Type (Targ_Id); 13087 Kind := Type_Initialization; 13088 13089 -- Initial_Condition verification 13090 13091 elsif Is_Initial_Condition_Proc (Targ_Id) then 13092 Extra := First_Formal_Type (Targ_Id); 13093 Kind := Initial_Condition_Verification; 13094 13095 -- Instantiation 13096 13097 elsif Is_Generic_Unit (Targ_Id) then 13098 Extra := Empty; 13099 Kind := Instantiation; 13100 13101 -- Internal controlled adjustment actions 13102 13103 elsif Is_TSS (Targ_Id, TSS_Deep_Adjust) then 13104 Extra := First_Formal_Type (Targ_Id); 13105 Kind := Internal_Controlled_Adjustment; 13106 13107 -- Internal controlled finalization actions 13108 13109 elsif Is_TSS (Targ_Id, TSS_Deep_Finalize) then 13110 Extra := First_Formal_Type (Targ_Id); 13111 Kind := Internal_Controlled_Finalization; 13112 13113 -- Internal controlled initialization actions 13114 13115 elsif Is_TSS (Targ_Id, TSS_Deep_Initialize) then 13116 Extra := First_Formal_Type (Targ_Id); 13117 Kind := Internal_Controlled_Initialization; 13118 13119 -- Invariant verification 13120 13121 elsif Is_Invariant_Proc (Targ_Id) 13122 or else Is_Partial_Invariant_Proc (Targ_Id) 13123 then 13124 Extra := First_Formal_Type (Targ_Id); 13125 Kind := Invariant_Verification; 13126 13127 -- Postcondition verification 13128 13129 elsif Is_Postconditions_Proc (Targ_Id) then 13130 Extra := Find_Enclosing_Scope (Spec_Decl); 13131 Kind := Postcondition_Verification; 13132 13133 -- Protected entry call 13134 13135 elsif Is_Protected_Entry (Targ_Id) then 13136 Extra := Empty; 13137 Kind := Protected_Entry_Call; 13138 13139 -- Protected subprogram call 13140 13141 elsif Is_Protected_Subp (Targ_Id) then 13142 Extra := Empty; 13143 Kind := Protected_Subprogram_Call; 13144 13145 -- Task entry call 13146 13147 elsif Is_Task_Entry (Targ_Id) then 13148 Extra := Empty; 13149 Kind := Task_Entry_Call; 13150 13151 -- Entry, operator, or subprogram call. This case must come last 13152 -- because most invocations above are variations of this case. 13153 13154 elsif Ekind_In (Targ_Id, E_Entry, 13155 E_Function, 13156 E_Operator, 13157 E_Procedure) 13158 then 13159 Extra := Empty; 13160 Kind := Call; 13161 13162 else 13163 pragma Assert (False); 13164 Extra := Empty; 13165 Kind := No_Invocation; 13166 end if; 13167 end Get_Invocation_Attributes; 13168 13169 -- Local variables 13170 13171 Extra : Entity_Id; 13172 Extra_Nam : Name_Id; 13173 Kind : Invocation_Kind; 13174 Rel : Invoker_Target_Relation; 13175 13176 -- Start of processing for Record_Invocation_Relation 13177 13178 begin 13179 Rel.Invoker := Invk_Id; 13180 Rel.Target := Targ_Id; 13181 13182 -- Nothing to do when the invocation relation has already been 13183 -- recorded in ALI file of the main unit. 13184 13185 if Is_Saved_Relation (Rel) then 13186 return; 13187 end if; 13188 13189 -- Mark the relation as recorded in the ALI file 13190 13191 Set_Is_Saved_Relation (Rel); 13192 13193 -- Declare the invoker in the ALI file 13194 13195 Declare_Invocation_Construct 13196 (Constr_Id => Invk_Id, 13197 In_State => In_State); 13198 13199 -- Obtain the invocation-specific attributes of the relation 13200 13201 Get_Invocation_Attributes (Extra, Kind); 13202 13203 -- Certain invocations lack an extra entity used in error diagnostics 13204 13205 if Present (Extra) then 13206 Extra_Nam := Chars (Extra); 13207 else 13208 Extra_Nam := No_Name; 13209 end if; 13210 13211 -- Add the relation in the ALI file 13212 13213 Add_Invocation_Relation 13214 (Extra => Extra_Nam, 13215 Invoker => Signature_Of (Invk_Id), 13216 Kind => Kind, 13217 Target => Signature_Of (Targ_Id), 13218 Update_Units => False); 13219 end Record_Invocation_Relation; 13220 13221 ----------------------------------- 13222 -- Record_Simple_Invocation_Path -- 13223 ----------------------------------- 13224 13225 procedure Record_Simple_Invocation_Path 13226 (In_State : Processing_In_State) 13227 is 13228 package Scenarios renames Active_Scenario_Stack; 13229 13230 Last_Targ : constant Entity_Id := 13231 Target_Of (Scenarios.Last, In_State); 13232 First_Targ : Entity_Id; 13233 13234 begin 13235 -- The path originates from the elaboration of the body. Add an extra 13236 -- relation from the elaboration body procedure to the first active 13237 -- scenario. 13238 13239 if In_State.Processing = Invocation_Body_Processing then 13240 Build_Elaborate_Body_Procedure; 13241 First_Targ := Elab_Body_Id; 13242 13243 -- The path originates from the elaboration of the spec. Add an extra 13244 -- relation from the elaboration spec procedure to the first active 13245 -- scenario. 13246 13247 elsif In_State.Processing = Invocation_Spec_Processing then 13248 Build_Elaborate_Spec_Procedure; 13249 First_Targ := Elab_Spec_Id; 13250 13251 else 13252 First_Targ := Target_Of (Scenarios.First, In_State); 13253 end if; 13254 13255 -- Record a single relation from the first to the last scenario 13256 13257 if First_Targ /= Last_Targ then 13258 Record_Invocation_Relation 13259 (Invk_Id => First_Targ, 13260 Targ_Id => Last_Targ, 13261 In_State => In_State); 13262 end if; 13263 end Record_Simple_Invocation_Path; 13264 13265 ---------------------------- 13266 -- Set_Is_Saved_Construct -- 13267 ---------------------------- 13268 13269 procedure Set_Is_Saved_Construct 13270 (Constr : Entity_Id; 13271 Val : Boolean := True) 13272 is 13273 pragma Assert (Present (Constr)); 13274 13275 begin 13276 if Val then 13277 NE_Set.Insert (Saved_Constructs_Set, Constr); 13278 else 13279 NE_Set.Delete (Saved_Constructs_Set, Constr); 13280 end if; 13281 end Set_Is_Saved_Construct; 13282 13283 --------------------------- 13284 -- Set_Is_Saved_Relation -- 13285 --------------------------- 13286 13287 procedure Set_Is_Saved_Relation 13288 (Rel : Invoker_Target_Relation; 13289 Val : Boolean := True) 13290 is 13291 begin 13292 if Val then 13293 IR_Set.Insert (Saved_Relations_Set, Rel); 13294 else 13295 IR_Set.Delete (Saved_Relations_Set, Rel); 13296 end if; 13297 end Set_Is_Saved_Relation; 13298 13299 ------------------ 13300 -- Signature_Of -- 13301 ------------------ 13302 13303 function Signature_Of (Id : Entity_Id) return Invocation_Signature_Id is 13304 Loc : constant Source_Ptr := Sloc (Id); 13305 13306 function Instantiation_Locations return Name_Id; 13307 pragma Inline (Instantiation_Locations); 13308 -- Create a concatenation of all lines and colums of each instance 13309 -- where source location Loc appears. Return No_Name if no instances 13310 -- exist. 13311 13312 function Qualified_Scope return Name_Id; 13313 pragma Inline (Qualified_Scope); 13314 -- Obtain the qualified name of Id's scope 13315 13316 ----------------------------- 13317 -- Instantiation_Locations -- 13318 ----------------------------- 13319 13320 function Instantiation_Locations return Name_Id is 13321 Buffer : Bounded_String (2052); 13322 Inst : Source_Ptr; 13323 Loc_Nam : Name_Id; 13324 SFI : Source_File_Index; 13325 13326 begin 13327 SFI := Get_Source_File_Index (Loc); 13328 Inst := Instantiation (SFI); 13329 13330 -- The location is within an instance. Construct a concatenation 13331 -- of all lines and colums of each individual instance using the 13332 -- following format: 13333 -- 13334 -- line1_column1_line2_column2_ ... _lineN_columnN 13335 13336 if Inst /= No_Location then 13337 loop 13338 Append (Buffer, Nat (Get_Logical_Line_Number (Inst))); 13339 Append (Buffer, '_'); 13340 Append (Buffer, Nat (Get_Column_Number (Inst))); 13341 13342 SFI := Get_Source_File_Index (Inst); 13343 Inst := Instantiation (SFI); 13344 13345 exit when Inst = No_Location; 13346 13347 Append (Buffer, '_'); 13348 end loop; 13349 13350 Loc_Nam := Name_Find (Buffer); 13351 return Loc_Nam; 13352 13353 -- Otherwise there no instances are involved 13354 13355 else 13356 return No_Name; 13357 end if; 13358 end Instantiation_Locations; 13359 13360 --------------------- 13361 -- Qualified_Scope -- 13362 --------------------- 13363 13364 function Qualified_Scope return Name_Id is 13365 Scop : Entity_Id; 13366 13367 begin 13368 Scop := Scope (Id); 13369 13370 -- The entity appears within an anonymous concurrent type created 13371 -- for a single protected or task type declaration. Use the entity 13372 -- of the anonymous object as it represents the original scope. 13373 13374 if Is_Concurrent_Type (Scop) 13375 and then Present (Anonymous_Object (Scop)) 13376 then 13377 Scop := Anonymous_Object (Scop); 13378 end if; 13379 13380 return Get_Qualified_Name (Scop); 13381 end Qualified_Scope; 13382 13383 -- Start of processing for Signature_Of 13384 13385 begin 13386 return 13387 Invocation_Signature_Of 13388 (Column => Nat (Get_Column_Number (Loc)), 13389 Line => Nat (Get_Logical_Line_Number (Loc)), 13390 Locations => Instantiation_Locations, 13391 Name => Chars (Id), 13392 Scope => Qualified_Scope); 13393 end Signature_Of; 13394 13395 --------------- 13396 -- Target_Of -- 13397 --------------- 13398 13399 function Target_Of 13400 (Pos : Active_Scenario_Pos; 13401 In_State : Processing_In_State) return Entity_Id 13402 is 13403 package Scenarios renames Active_Scenario_Stack; 13404 13405 -- Ensure that the position is within the bounds of the active 13406 -- scenario stack. 13407 13408 pragma Assert (Scenarios.First <= Pos); 13409 pragma Assert (Pos <= Scenarios.Last); 13410 13411 Scen_Rep : constant Scenario_Rep_Id := 13412 Scenario_Representation_Of 13413 (Scenarios.Table (Pos), In_State); 13414 13415 begin 13416 -- The true target of an activation call is the current task type 13417 -- rather than routine Activate_Tasks. 13418 13419 if Kind (Scen_Rep) = Task_Activation_Scenario then 13420 return Activated_Task_Type (Scen_Rep); 13421 else 13422 return Target (Scen_Rep); 13423 end if; 13424 end Target_Of; 13425 13426 ------------------------------ 13427 -- Traverse_Invocation_Body -- 13428 ------------------------------ 13429 13430 procedure Traverse_Invocation_Body 13431 (N : Node_Id; 13432 In_State : Processing_In_State) 13433 is 13434 begin 13435 Traverse_Body 13436 (N => N, 13437 Requires_Processing => Is_Invocation_Scenario'Access, 13438 Processor => Process_Invocation_Scenario'Access, 13439 In_State => In_State); 13440 end Traverse_Invocation_Body; 13441 13442 --------------------------- 13443 -- Write_Invocation_Path -- 13444 --------------------------- 13445 13446 procedure Write_Invocation_Path (In_State : Processing_In_State) is 13447 procedure Write_Target (Targ_Id : Entity_Id; Is_First : Boolean); 13448 pragma Inline (Write_Target); 13449 -- Write out invocation target Targ_Id to standard output. Flag 13450 -- Is_First should be set when the target is first in a path. 13451 13452 ------------- 13453 -- Targ_Id -- 13454 ------------- 13455 13456 procedure Write_Target (Targ_Id : Entity_Id; Is_First : Boolean) is 13457 begin 13458 if not Is_First then 13459 Write_Str (" --> "); 13460 end if; 13461 13462 Write_Name (Get_Qualified_Name (Targ_Id)); 13463 Write_Eol; 13464 end Write_Target; 13465 13466 -- Local variables 13467 13468 package Scenarios renames Active_Scenario_Stack; 13469 13470 First_Seen : Boolean := False; 13471 13472 -- Start of processing for Write_Invocation_Path 13473 13474 begin 13475 -- Nothing to do when flag -gnatd_T (output trace information on 13476 -- invocation path recording) is not in effect. 13477 13478 if not Debug_Flag_Underscore_TT then 13479 return; 13480 end if; 13481 13482 -- The path originates from the elaboration of the body. Write the 13483 -- elaboration body procedure. 13484 13485 if In_State.Processing = Invocation_Body_Processing then 13486 Write_Target (Elab_Body_Id, True); 13487 First_Seen := True; 13488 13489 -- The path originates from the elaboration of the spec. Write the 13490 -- elaboration spec procedure. 13491 13492 elsif In_State.Processing = Invocation_Spec_Processing then 13493 Write_Target (Elab_Spec_Id, True); 13494 First_Seen := True; 13495 end if; 13496 13497 -- Write each individual target invoked by its corresponding scenario 13498 -- on the active scenario stack. 13499 13500 for Index in Scenarios.First .. Scenarios.Last loop 13501 Write_Target 13502 (Targ_Id => Target_Of (Index, In_State), 13503 Is_First => Index = Scenarios.First and then not First_Seen); 13504 end loop; 13505 13506 Write_Eol; 13507 end Write_Invocation_Path; 13508 end Invocation_Graph; 13509 13510 ------------------------ 13511 -- Is_Safe_Activation -- 13512 ------------------------ 13513 13514 function Is_Safe_Activation 13515 (Call : Node_Id; 13516 Task_Rep : Target_Rep_Id) return Boolean 13517 is 13518 begin 13519 -- The activation of a task coming from an external instance cannot 13520 -- cause an ABE because the generic was already instantiated. Note 13521 -- that the instantiation itself may lead to an ABE. 13522 13523 return 13524 In_External_Instance 13525 (N => Call, 13526 Target_Decl => Spec_Declaration (Task_Rep)); 13527 end Is_Safe_Activation; 13528 13529 ------------------ 13530 -- Is_Safe_Call -- 13531 ------------------ 13532 13533 function Is_Safe_Call 13534 (Call : Node_Id; 13535 Subp_Id : Entity_Id; 13536 Subp_Rep : Target_Rep_Id) return Boolean 13537 is 13538 Body_Decl : constant Node_Id := Body_Declaration (Subp_Rep); 13539 Spec_Decl : constant Node_Id := Spec_Declaration (Subp_Rep); 13540 13541 begin 13542 -- The target is either an abstract subprogram, formal subprogram, or 13543 -- imported, in which case it does not have a body at compile or bind 13544 -- time. Assume that the call is ABE-safe. 13545 13546 if Is_Bodiless_Subprogram (Subp_Id) then 13547 return True; 13548 13549 -- The target is an instantiation of a generic subprogram. The call 13550 -- cannot cause an ABE because the generic was already instantiated. 13551 -- Note that the instantiation itself may lead to an ABE. 13552 13553 elsif Is_Generic_Instance (Subp_Id) then 13554 return True; 13555 13556 -- The invocation of a target coming from an external instance cannot 13557 -- cause an ABE because the generic was already instantiated. Note that 13558 -- the instantiation itself may lead to an ABE. 13559 13560 elsif In_External_Instance 13561 (N => Call, 13562 Target_Decl => Spec_Decl) 13563 then 13564 return True; 13565 13566 -- The target is a subprogram body without a previous declaration. The 13567 -- call cannot cause an ABE because the body has already been seen. 13568 13569 elsif Nkind (Spec_Decl) = N_Subprogram_Body 13570 and then No (Corresponding_Spec (Spec_Decl)) 13571 then 13572 return True; 13573 13574 -- The target is a subprogram body stub without a prior declaration. 13575 -- The call cannot cause an ABE because the proper body substitutes 13576 -- the stub. 13577 13578 elsif Nkind (Spec_Decl) = N_Subprogram_Body_Stub 13579 and then No (Corresponding_Spec_Of_Stub (Spec_Decl)) 13580 then 13581 return True; 13582 13583 -- Subprogram bodies which wrap attribute references used as actuals 13584 -- in instantiations are always ABE-safe. These bodies are artifacts 13585 -- of expansion. 13586 13587 elsif Present (Body_Decl) 13588 and then Nkind (Body_Decl) = N_Subprogram_Body 13589 and then Was_Attribute_Reference (Body_Decl) 13590 then 13591 return True; 13592 end if; 13593 13594 return False; 13595 end Is_Safe_Call; 13596 13597 --------------------------- 13598 -- Is_Safe_Instantiation -- 13599 --------------------------- 13600 13601 function Is_Safe_Instantiation 13602 (Inst : Node_Id; 13603 Gen_Id : Entity_Id; 13604 Gen_Rep : Target_Rep_Id) return Boolean 13605 is 13606 Spec_Decl : constant Node_Id := Spec_Declaration (Gen_Rep); 13607 13608 begin 13609 -- The generic is an intrinsic subprogram in which case it does not 13610 -- have a body at compile or bind time. Assume that the instantiation 13611 -- is ABE-safe. 13612 13613 if Is_Bodiless_Subprogram (Gen_Id) then 13614 return True; 13615 13616 -- The instantiation of an external nested generic cannot cause an ABE 13617 -- if the outer generic was already instantiated. Note that the instance 13618 -- of the outer generic may lead to an ABE. 13619 13620 elsif In_External_Instance 13621 (N => Inst, 13622 Target_Decl => Spec_Decl) 13623 then 13624 return True; 13625 13626 -- The generic is a package. The instantiation cannot cause an ABE when 13627 -- the package has no body. 13628 13629 elsif Ekind (Gen_Id) = E_Generic_Package 13630 and then not Has_Body (Spec_Decl) 13631 then 13632 return True; 13633 end if; 13634 13635 return False; 13636 end Is_Safe_Instantiation; 13637 13638 ------------------ 13639 -- Is_Same_Unit -- 13640 ------------------ 13641 13642 function Is_Same_Unit 13643 (Unit_1 : Entity_Id; 13644 Unit_2 : Entity_Id) return Boolean 13645 is 13646 begin 13647 return Unit_Entity (Unit_1) = Unit_Entity (Unit_2); 13648 end Is_Same_Unit; 13649 13650 ------------------------------- 13651 -- Kill_Elaboration_Scenario -- 13652 ------------------------------- 13653 13654 procedure Kill_Elaboration_Scenario (N : Node_Id) is 13655 begin 13656 -- Nothing to do when switch -gnatH (legacy elaboration checking mode 13657 -- enabled) is in effect because the legacy ABE lechanism does not need 13658 -- to carry out this action. 13659 13660 if Legacy_Elaboration_Checks then 13661 return; 13662 13663 -- Nothing to do when the elaboration phase of the compiler is not 13664 -- active. 13665 13666 elsif not Elaboration_Phase_Active then 13667 return; 13668 end if; 13669 13670 -- Eliminate a recorded scenario when it appears within dead code 13671 -- because it will not be executed at elaboration time. 13672 13673 if Is_Scenario (N) then 13674 Delete_Scenario (N); 13675 end if; 13676 end Kill_Elaboration_Scenario; 13677 13678 ---------------------- 13679 -- Main_Unit_Entity -- 13680 ---------------------- 13681 13682 function Main_Unit_Entity return Entity_Id is 13683 begin 13684 -- Note that Cunit_Entity (Main_Unit) is not reliable in the presence of 13685 -- generic bodies and may return an outdated entity. 13686 13687 return Defining_Entity (Unit (Cunit (Main_Unit))); 13688 end Main_Unit_Entity; 13689 13690 ---------------------- 13691 -- Non_Private_View -- 13692 ---------------------- 13693 13694 function Non_Private_View (Typ : Entity_Id) return Entity_Id is 13695 begin 13696 if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then 13697 return Full_View (Typ); 13698 else 13699 return Typ; 13700 end if; 13701 end Non_Private_View; 13702 13703 --------------------------------- 13704 -- Record_Elaboration_Scenario -- 13705 --------------------------------- 13706 13707 procedure Record_Elaboration_Scenario (N : Node_Id) is 13708 procedure Check_Preelaborated_Call 13709 (Call : Node_Id; 13710 Call_Lvl : Enclosing_Level_Kind); 13711 pragma Inline (Check_Preelaborated_Call); 13712 -- Verify that entry, operator, or subprogram call Call with enclosing 13713 -- level Call_Lvl does not appear at the library level of preelaborated 13714 -- unit. 13715 13716 function Find_Code_Unit (Nod : Node_Or_Entity_Id) return Entity_Id; 13717 pragma Inline (Find_Code_Unit); 13718 -- Return the code unit which contains arbitrary node or entity Nod. 13719 -- This is the unit of the file which physically contains the related 13720 -- construct denoted by Nod except when Nod is within an instantiation. 13721 -- In that case the unit is that of the top-level instantiation. 13722 13723 function In_Preelaborated_Context (Nod : Node_Id) return Boolean; 13724 pragma Inline (In_Preelaborated_Context); 13725 -- Determine whether arbitrary node Nod appears within a preelaborated 13726 -- context. 13727 13728 procedure Record_Access_Taken 13729 (Attr : Node_Id; 13730 Attr_Lvl : Enclosing_Level_Kind); 13731 pragma Inline (Record_Access_Taken); 13732 -- Record 'Access scenario Attr with enclosing level Attr_Lvl 13733 13734 procedure Record_Call_Or_Task_Activation 13735 (Call : Node_Id; 13736 Call_Lvl : Enclosing_Level_Kind); 13737 pragma Inline (Record_Call_Or_Task_Activation); 13738 -- Record call scenario Call with enclosing level Call_Lvl 13739 13740 procedure Record_Instantiation 13741 (Inst : Node_Id; 13742 Inst_Lvl : Enclosing_Level_Kind); 13743 pragma Inline (Record_Instantiation); 13744 -- Record instantiation scenario Inst with enclosing level Inst_Lvl 13745 13746 procedure Record_Variable_Assignment 13747 (Asmt : Node_Id; 13748 Asmt_Lvl : Enclosing_Level_Kind); 13749 pragma Inline (Record_Variable_Assignment); 13750 -- Record variable assignment scenario Asmt with enclosing level 13751 -- Asmt_Lvl. 13752 13753 procedure Record_Variable_Reference 13754 (Ref : Node_Id; 13755 Ref_Lvl : Enclosing_Level_Kind); 13756 pragma Inline (Record_Variable_Reference); 13757 -- Record variable reference scenario Ref with enclosing level Ref_Lvl 13758 13759 ------------------------------ 13760 -- Check_Preelaborated_Call -- 13761 ------------------------------ 13762 13763 procedure Check_Preelaborated_Call 13764 (Call : Node_Id; 13765 Call_Lvl : Enclosing_Level_Kind) 13766 is 13767 begin 13768 -- Nothing to do when the call is internally generated because it is 13769 -- assumed that it will never violate preelaboration. 13770 13771 if not Is_Source_Call (Call) then 13772 return; 13773 13774 -- Library-level calls are always considered because they are part of 13775 -- the associated unit's elaboration actions. 13776 13777 elsif Call_Lvl in Library_Level then 13778 null; 13779 13780 -- Calls at the library level of a generic package body have to be 13781 -- checked because they would render an instantiation illegal if the 13782 -- template is marked as preelaborated. Note that this does not apply 13783 -- to calls at the library level of a generic package spec. 13784 13785 elsif Call_Lvl = Generic_Body_Level then 13786 null; 13787 13788 -- Otherwise the call does not appear at the proper level and must 13789 -- not be considered for this check. 13790 13791 else 13792 return; 13793 end if; 13794 13795 -- The call appears within a preelaborated unit. Emit a warning only 13796 -- for internal uses, otherwise this is an error. 13797 13798 if In_Preelaborated_Context (Call) then 13799 Error_Msg_Warn := GNAT_Mode; 13800 Error_Msg_N 13801 ("<<non-static call not allowed in preelaborated unit", Call); 13802 end if; 13803 end Check_Preelaborated_Call; 13804 13805 -------------------- 13806 -- Find_Code_Unit -- 13807 -------------------- 13808 13809 function Find_Code_Unit (Nod : Node_Or_Entity_Id) return Entity_Id is 13810 begin 13811 return Find_Unit_Entity (Unit (Cunit (Get_Code_Unit (Nod)))); 13812 end Find_Code_Unit; 13813 13814 ------------------------------ 13815 -- In_Preelaborated_Context -- 13816 ------------------------------ 13817 13818 function In_Preelaborated_Context (Nod : Node_Id) return Boolean is 13819 Body_Id : constant Entity_Id := Find_Code_Unit (Nod); 13820 Spec_Id : constant Entity_Id := Unique_Entity (Body_Id); 13821 13822 begin 13823 -- The node appears within a package body whose corresponding spec is 13824 -- subject to pragma Remote_Call_Interface or Remote_Types. This does 13825 -- not result in a preelaborated context because the package body may 13826 -- be on another machine. 13827 13828 if Ekind (Body_Id) = E_Package_Body 13829 and then Ekind_In (Spec_Id, E_Generic_Package, E_Package) 13830 and then (Is_Remote_Call_Interface (Spec_Id) 13831 or else Is_Remote_Types (Spec_Id)) 13832 then 13833 return False; 13834 13835 -- Otherwise the node appears within a preelaborated context when the 13836 -- associated unit is preelaborated. 13837 13838 else 13839 return Is_Preelaborated_Unit (Spec_Id); 13840 end if; 13841 end In_Preelaborated_Context; 13842 13843 ------------------------- 13844 -- Record_Access_Taken -- 13845 ------------------------- 13846 13847 procedure Record_Access_Taken 13848 (Attr : Node_Id; 13849 Attr_Lvl : Enclosing_Level_Kind) 13850 is 13851 begin 13852 -- Signal any enclosing local exception handlers that the 'Access may 13853 -- raise Program_Error due to a failed ABE check when switch -gnatd.o 13854 -- (conservative elaboration order for indirect calls) is in effect. 13855 -- Marking the exception handlers ensures proper expansion by both 13856 -- the front and back end restriction when No_Exception_Propagation 13857 -- is in effect. 13858 13859 if Debug_Flag_Dot_O then 13860 Possible_Local_Raise (Attr, Standard_Program_Error); 13861 end if; 13862 13863 -- Add 'Access to the appropriate set 13864 13865 if Attr_Lvl = Library_Body_Level then 13866 Add_Library_Body_Scenario (Attr); 13867 13868 elsif Attr_Lvl = Library_Spec_Level 13869 or else Attr_Lvl = Instantiation_Level 13870 then 13871 Add_Library_Spec_Scenario (Attr); 13872 end if; 13873 13874 -- 'Access requires a conditional ABE check when the dynamic model is 13875 -- in effect. 13876 13877 Add_Dynamic_ABE_Check_Scenario (Attr); 13878 end Record_Access_Taken; 13879 13880 ------------------------------------ 13881 -- Record_Call_Or_Task_Activation -- 13882 ------------------------------------ 13883 13884 procedure Record_Call_Or_Task_Activation 13885 (Call : Node_Id; 13886 Call_Lvl : Enclosing_Level_Kind) 13887 is 13888 begin 13889 -- Signal any enclosing local exception handlers that the call may 13890 -- raise Program_Error due to failed ABE check. Marking the exception 13891 -- handlers ensures proper expansion by both the front and back end 13892 -- restriction when No_Exception_Propagation is in effect. 13893 13894 Possible_Local_Raise (Call, Standard_Program_Error); 13895 13896 -- Perform early detection of guaranteed ABEs in order to suppress 13897 -- the instantiation of generic bodies because gigi cannot handle 13898 -- certain types of premature instantiations. 13899 13900 Process_Guaranteed_ABE 13901 (N => Call, 13902 In_State => Guaranteed_ABE_State); 13903 13904 -- Add the call or task activation to the appropriate set 13905 13906 if Call_Lvl = Declaration_Level then 13907 Add_Declaration_Scenario (Call); 13908 13909 elsif Call_Lvl = Library_Body_Level then 13910 Add_Library_Body_Scenario (Call); 13911 13912 elsif Call_Lvl = Library_Spec_Level 13913 or else Call_Lvl = Instantiation_Level 13914 then 13915 Add_Library_Spec_Scenario (Call); 13916 end if; 13917 13918 -- A call or a task activation requires a conditional ABE check when 13919 -- the dynamic model is in effect. 13920 13921 Add_Dynamic_ABE_Check_Scenario (Call); 13922 end Record_Call_Or_Task_Activation; 13923 13924 -------------------------- 13925 -- Record_Instantiation -- 13926 -------------------------- 13927 13928 procedure Record_Instantiation 13929 (Inst : Node_Id; 13930 Inst_Lvl : Enclosing_Level_Kind) 13931 is 13932 begin 13933 -- Signal enclosing local exception handlers that instantiation may 13934 -- raise Program_Error due to failed ABE check. Marking the exception 13935 -- handlers ensures proper expansion by both the front and back end 13936 -- restriction when No_Exception_Propagation is in effect. 13937 13938 Possible_Local_Raise (Inst, Standard_Program_Error); 13939 13940 -- Perform early detection of guaranteed ABEs in order to suppress 13941 -- the instantiation of generic bodies because gigi cannot handle 13942 -- certain types of premature instantiations. 13943 13944 Process_Guaranteed_ABE 13945 (N => Inst, 13946 In_State => Guaranteed_ABE_State); 13947 13948 -- Add the instantiation to the appropriate set 13949 13950 if Inst_Lvl = Declaration_Level then 13951 Add_Declaration_Scenario (Inst); 13952 13953 elsif Inst_Lvl = Library_Body_Level then 13954 Add_Library_Body_Scenario (Inst); 13955 13956 elsif Inst_Lvl = Library_Spec_Level 13957 or else Inst_Lvl = Instantiation_Level 13958 then 13959 Add_Library_Spec_Scenario (Inst); 13960 end if; 13961 13962 -- Instantiations of generics subject to SPARK_Mode On require 13963 -- elaboration-related checks even though the instantiations may 13964 -- not appear within elaboration code. 13965 13966 if Is_Suitable_SPARK_Instantiation (Inst) then 13967 Add_SPARK_Scenario (Inst); 13968 end if; 13969 13970 -- An instantiation requires a conditional ABE check when the dynamic 13971 -- model is in effect. 13972 13973 Add_Dynamic_ABE_Check_Scenario (Inst); 13974 end Record_Instantiation; 13975 13976 -------------------------------- 13977 -- Record_Variable_Assignment -- 13978 -------------------------------- 13979 13980 procedure Record_Variable_Assignment 13981 (Asmt : Node_Id; 13982 Asmt_Lvl : Enclosing_Level_Kind) 13983 is 13984 begin 13985 -- Add the variable assignment to the appropriate set 13986 13987 if Asmt_Lvl = Library_Body_Level then 13988 Add_Library_Body_Scenario (Asmt); 13989 13990 elsif Asmt_Lvl = Library_Spec_Level 13991 or else Asmt_Lvl = Instantiation_Level 13992 then 13993 Add_Library_Spec_Scenario (Asmt); 13994 end if; 13995 end Record_Variable_Assignment; 13996 13997 ------------------------------- 13998 -- Record_Variable_Reference -- 13999 ------------------------------- 14000 14001 procedure Record_Variable_Reference 14002 (Ref : Node_Id; 14003 Ref_Lvl : Enclosing_Level_Kind) 14004 is 14005 begin 14006 -- Add the variable reference to the appropriate set 14007 14008 if Ref_Lvl = Library_Body_Level then 14009 Add_Library_Body_Scenario (Ref); 14010 14011 elsif Ref_Lvl = Library_Spec_Level 14012 or else Ref_Lvl = Instantiation_Level 14013 then 14014 Add_Library_Spec_Scenario (Ref); 14015 end if; 14016 end Record_Variable_Reference; 14017 14018 -- Local variables 14019 14020 Scen : constant Node_Id := Scenario (N); 14021 Scen_Lvl : Enclosing_Level_Kind; 14022 14023 -- Start of processing for Record_Elaboration_Scenario 14024 14025 begin 14026 -- Nothing to do when switch -gnatH (legacy elaboration checking mode 14027 -- enabled) is in effect because the legacy ABE mechanism does not need 14028 -- to carry out this action. 14029 14030 if Legacy_Elaboration_Checks then 14031 return; 14032 14033 -- Nothing to do for ASIS because ABE checks and diagnostics are not 14034 -- performed in this mode. 14035 14036 elsif ASIS_Mode then 14037 return; 14038 14039 -- Nothing to do when the scenario is being preanalyzed 14040 14041 elsif Preanalysis_Active then 14042 return; 14043 14044 -- Nothing to do when the elaboration phase of the compiler is not 14045 -- active. 14046 14047 elsif not Elaboration_Phase_Active then 14048 return; 14049 end if; 14050 14051 Scen_Lvl := Find_Enclosing_Level (Scen); 14052 14053 -- Ensure that a library-level call does not appear in a preelaborated 14054 -- unit. The check must come before ignoring scenarios within external 14055 -- units or inside generics because calls in those context must also be 14056 -- verified. 14057 14058 if Is_Suitable_Call (Scen) then 14059 Check_Preelaborated_Call (Scen, Scen_Lvl); 14060 end if; 14061 14062 -- Nothing to do when the scenario does not appear within the main unit 14063 14064 if not In_Main_Context (Scen) then 14065 return; 14066 14067 -- Nothing to do when the scenario appears within a generic 14068 14069 elsif Inside_A_Generic then 14070 return; 14071 14072 -- 'Access 14073 14074 elsif Is_Suitable_Access_Taken (Scen) then 14075 Record_Access_Taken 14076 (Attr => Scen, 14077 Attr_Lvl => Scen_Lvl); 14078 14079 -- Call or task activation 14080 14081 elsif Is_Suitable_Call (Scen) then 14082 Record_Call_Or_Task_Activation 14083 (Call => Scen, 14084 Call_Lvl => Scen_Lvl); 14085 14086 -- Derived type declaration 14087 14088 elsif Is_Suitable_SPARK_Derived_Type (Scen) then 14089 Add_SPARK_Scenario (Scen); 14090 14091 -- Instantiation 14092 14093 elsif Is_Suitable_Instantiation (Scen) then 14094 Record_Instantiation 14095 (Inst => Scen, 14096 Inst_Lvl => Scen_Lvl); 14097 14098 -- Refined_State pragma 14099 14100 elsif Is_Suitable_SPARK_Refined_State_Pragma (Scen) then 14101 Add_SPARK_Scenario (Scen); 14102 14103 -- Variable assignment 14104 14105 elsif Is_Suitable_Variable_Assignment (Scen) then 14106 Record_Variable_Assignment 14107 (Asmt => Scen, 14108 Asmt_Lvl => Scen_Lvl); 14109 14110 -- Variable reference 14111 14112 elsif Is_Suitable_Variable_Reference (Scen) then 14113 Record_Variable_Reference 14114 (Ref => Scen, 14115 Ref_Lvl => Scen_Lvl); 14116 end if; 14117 end Record_Elaboration_Scenario; 14118 14119 -------------- 14120 -- Scenario -- 14121 -------------- 14122 14123 function Scenario (N : Node_Id) return Node_Id is 14124 Orig_N : constant Node_Id := Original_Node (N); 14125 14126 begin 14127 -- An expanded instantiation is rewritten into a spec-body pair where 14128 -- N denotes the spec. In this case the original instantiation is the 14129 -- proper elaboration scenario. 14130 14131 if Nkind (Orig_N) in N_Generic_Instantiation then 14132 return Orig_N; 14133 14134 -- Otherwise the scenario is already in its proper form 14135 14136 else 14137 return N; 14138 end if; 14139 end Scenario; 14140 14141 ---------------------- 14142 -- Scenario_Storage -- 14143 ---------------------- 14144 14145 package body Scenario_Storage is 14146 14147 --------------------- 14148 -- Data structures -- 14149 --------------------- 14150 14151 -- The following sets store all scenarios 14152 14153 Declaration_Scenarios : NE_Set.Membership_Set := NE_Set.Nil; 14154 Dynamic_ABE_Check_Scenarios : NE_Set.Membership_Set := NE_Set.Nil; 14155 Library_Body_Scenarios : NE_Set.Membership_Set := NE_Set.Nil; 14156 Library_Spec_Scenarios : NE_Set.Membership_Set := NE_Set.Nil; 14157 SPARK_Scenarios : NE_Set.Membership_Set := NE_Set.Nil; 14158 14159 ------------------------------- 14160 -- Finalize_Scenario_Storage -- 14161 ------------------------------- 14162 14163 procedure Finalize_Scenario_Storage is 14164 begin 14165 NE_Set.Destroy (Declaration_Scenarios); 14166 NE_Set.Destroy (Dynamic_ABE_Check_Scenarios); 14167 NE_Set.Destroy (Library_Body_Scenarios); 14168 NE_Set.Destroy (Library_Spec_Scenarios); 14169 NE_Set.Destroy (SPARK_Scenarios); 14170 end Finalize_Scenario_Storage; 14171 14172 --------------------------------- 14173 -- Initialize_Scenario_Storage -- 14174 --------------------------------- 14175 14176 procedure Initialize_Scenario_Storage is 14177 begin 14178 Declaration_Scenarios := NE_Set.Create (1000); 14179 Dynamic_ABE_Check_Scenarios := NE_Set.Create (500); 14180 Library_Body_Scenarios := NE_Set.Create (1000); 14181 Library_Spec_Scenarios := NE_Set.Create (1000); 14182 SPARK_Scenarios := NE_Set.Create (100); 14183 end Initialize_Scenario_Storage; 14184 14185 ------------------------------ 14186 -- Add_Declaration_Scenario -- 14187 ------------------------------ 14188 14189 procedure Add_Declaration_Scenario (N : Node_Id) is 14190 pragma Assert (Present (N)); 14191 begin 14192 NE_Set.Insert (Declaration_Scenarios, N); 14193 end Add_Declaration_Scenario; 14194 14195 ------------------------------------ 14196 -- Add_Dynamic_ABE_Check_Scenario -- 14197 ------------------------------------ 14198 14199 procedure Add_Dynamic_ABE_Check_Scenario (N : Node_Id) is 14200 pragma Assert (Present (N)); 14201 14202 begin 14203 if not Check_Or_Failure_Generation_OK then 14204 return; 14205 14206 -- Nothing to do if the dynamic model is not in effect 14207 14208 elsif not Dynamic_Elaboration_Checks then 14209 return; 14210 end if; 14211 14212 NE_Set.Insert (Dynamic_ABE_Check_Scenarios, N); 14213 end Add_Dynamic_ABE_Check_Scenario; 14214 14215 ------------------------------- 14216 -- Add_Library_Body_Scenario -- 14217 ------------------------------- 14218 14219 procedure Add_Library_Body_Scenario (N : Node_Id) is 14220 pragma Assert (Present (N)); 14221 begin 14222 NE_Set.Insert (Library_Body_Scenarios, N); 14223 end Add_Library_Body_Scenario; 14224 14225 ------------------------------- 14226 -- Add_Library_Spec_Scenario -- 14227 ------------------------------- 14228 14229 procedure Add_Library_Spec_Scenario (N : Node_Id) is 14230 pragma Assert (Present (N)); 14231 begin 14232 NE_Set.Insert (Library_Spec_Scenarios, N); 14233 end Add_Library_Spec_Scenario; 14234 14235 ------------------------ 14236 -- Add_SPARK_Scenario -- 14237 ------------------------ 14238 14239 procedure Add_SPARK_Scenario (N : Node_Id) is 14240 pragma Assert (Present (N)); 14241 begin 14242 NE_Set.Insert (SPARK_Scenarios, N); 14243 end Add_SPARK_Scenario; 14244 14245 --------------------- 14246 -- Delete_Scenario -- 14247 --------------------- 14248 14249 procedure Delete_Scenario (N : Node_Id) is 14250 pragma Assert (Present (N)); 14251 14252 begin 14253 -- Delete the scenario from whichever set it belongs to 14254 14255 NE_Set.Delete (Declaration_Scenarios, N); 14256 NE_Set.Delete (Dynamic_ABE_Check_Scenarios, N); 14257 NE_Set.Delete (Library_Body_Scenarios, N); 14258 NE_Set.Delete (Library_Spec_Scenarios, N); 14259 NE_Set.Delete (SPARK_Scenarios, N); 14260 end Delete_Scenario; 14261 14262 ----------------------------------- 14263 -- Iterate_Declaration_Scenarios -- 14264 ----------------------------------- 14265 14266 function Iterate_Declaration_Scenarios return NE_Set.Iterator is 14267 begin 14268 return NE_Set.Iterate (Declaration_Scenarios); 14269 end Iterate_Declaration_Scenarios; 14270 14271 ----------------------------------------- 14272 -- Iterate_Dynamic_ABE_Check_Scenarios -- 14273 ----------------------------------------- 14274 14275 function Iterate_Dynamic_ABE_Check_Scenarios return NE_Set.Iterator is 14276 begin 14277 return NE_Set.Iterate (Dynamic_ABE_Check_Scenarios); 14278 end Iterate_Dynamic_ABE_Check_Scenarios; 14279 14280 ------------------------------------ 14281 -- Iterate_Library_Body_Scenarios -- 14282 ------------------------------------ 14283 14284 function Iterate_Library_Body_Scenarios return NE_Set.Iterator is 14285 begin 14286 return NE_Set.Iterate (Library_Body_Scenarios); 14287 end Iterate_Library_Body_Scenarios; 14288 14289 ------------------------------------ 14290 -- Iterate_Library_Spec_Scenarios -- 14291 ------------------------------------ 14292 14293 function Iterate_Library_Spec_Scenarios return NE_Set.Iterator is 14294 begin 14295 return NE_Set.Iterate (Library_Spec_Scenarios); 14296 end Iterate_Library_Spec_Scenarios; 14297 14298 ----------------------------- 14299 -- Iterate_SPARK_Scenarios -- 14300 ----------------------------- 14301 14302 function Iterate_SPARK_Scenarios return NE_Set.Iterator is 14303 begin 14304 return NE_Set.Iterate (SPARK_Scenarios); 14305 end Iterate_SPARK_Scenarios; 14306 14307 ---------------------- 14308 -- Replace_Scenario -- 14309 ---------------------- 14310 14311 procedure Replace_Scenario (Old_N : Node_Id; New_N : Node_Id) is 14312 procedure Replace_Scenario_In (Scenarios : NE_Set.Membership_Set); 14313 -- Determine whether scenario Old_N is present in set Scenarios, and 14314 -- if this is the case it, replace it with New_N. 14315 14316 ------------------------- 14317 -- Replace_Scenario_In -- 14318 ------------------------- 14319 14320 procedure Replace_Scenario_In (Scenarios : NE_Set.Membership_Set) is 14321 begin 14322 -- The set is intentionally checked for existance because node 14323 -- rewriting may occur after Sem_Elab has verified all scenarios 14324 -- and data structures have been destroyed. 14325 14326 if NE_Set.Present (Scenarios) 14327 and then NE_Set.Contains (Scenarios, Old_N) 14328 then 14329 NE_Set.Delete (Scenarios, Old_N); 14330 NE_Set.Insert (Scenarios, New_N); 14331 end if; 14332 end Replace_Scenario_In; 14333 14334 -- Start of processing for Replace_Scenario 14335 14336 begin 14337 Replace_Scenario_In (Declaration_Scenarios); 14338 Replace_Scenario_In (Dynamic_ABE_Check_Scenarios); 14339 Replace_Scenario_In (Library_Body_Scenarios); 14340 Replace_Scenario_In (Library_Spec_Scenarios); 14341 Replace_Scenario_In (SPARK_Scenarios); 14342 end Replace_Scenario; 14343 end Scenario_Storage; 14344 14345 --------------- 14346 -- Semantics -- 14347 --------------- 14348 14349 package body Semantics is 14350 14351 -------------------------------- 14352 -- Is_Accept_Alternative_Proc -- 14353 -------------------------------- 14354 14355 function Is_Accept_Alternative_Proc (Id : Entity_Id) return Boolean is 14356 begin 14357 -- To qualify, the entity must denote a procedure with a receiving 14358 -- entry. 14359 14360 return 14361 Ekind (Id) = E_Procedure and then Present (Receiving_Entry (Id)); 14362 end Is_Accept_Alternative_Proc; 14363 14364 ------------------------ 14365 -- Is_Activation_Proc -- 14366 ------------------------ 14367 14368 function Is_Activation_Proc (Id : Entity_Id) return Boolean is 14369 begin 14370 -- To qualify, the entity must denote one of the runtime procedures 14371 -- in charge of task activation. 14372 14373 if Ekind (Id) = E_Procedure then 14374 if Restricted_Profile then 14375 return Is_RTE (Id, RE_Activate_Restricted_Tasks); 14376 else 14377 return Is_RTE (Id, RE_Activate_Tasks); 14378 end if; 14379 end if; 14380 14381 return False; 14382 end Is_Activation_Proc; 14383 14384 ---------------------------- 14385 -- Is_Ada_Semantic_Target -- 14386 ---------------------------- 14387 14388 function Is_Ada_Semantic_Target (Id : Entity_Id) return Boolean is 14389 begin 14390 return 14391 Is_Activation_Proc (Id) 14392 or else Is_Controlled_Proc (Id, Name_Adjust) 14393 or else Is_Controlled_Proc (Id, Name_Finalize) 14394 or else Is_Controlled_Proc (Id, Name_Initialize) 14395 or else Is_Init_Proc (Id) 14396 or else Is_Invariant_Proc (Id) 14397 or else Is_Protected_Entry (Id) 14398 or else Is_Protected_Subp (Id) 14399 or else Is_Protected_Body_Subp (Id) 14400 or else Is_Subprogram_Inst (Id) 14401 or else Is_Task_Entry (Id); 14402 end Is_Ada_Semantic_Target; 14403 14404 -------------------------------- 14405 -- Is_Assertion_Pragma_Target -- 14406 -------------------------------- 14407 14408 function Is_Assertion_Pragma_Target (Id : Entity_Id) return Boolean is 14409 begin 14410 return 14411 Is_Default_Initial_Condition_Proc (Id) 14412 or else Is_Initial_Condition_Proc (Id) 14413 or else Is_Invariant_Proc (Id) 14414 or else Is_Partial_Invariant_Proc (Id) 14415 or else Is_Postconditions_Proc (Id); 14416 end Is_Assertion_Pragma_Target; 14417 14418 ---------------------------- 14419 -- Is_Bodiless_Subprogram -- 14420 ---------------------------- 14421 14422 function Is_Bodiless_Subprogram (Subp_Id : Entity_Id) return Boolean is 14423 begin 14424 -- An abstract subprogram does not have a body 14425 14426 if Ekind_In (Subp_Id, E_Function, 14427 E_Operator, 14428 E_Procedure) 14429 and then Is_Abstract_Subprogram (Subp_Id) 14430 then 14431 return True; 14432 14433 -- A formal subprogram does not have a body 14434 14435 elsif Is_Formal_Subprogram (Subp_Id) then 14436 return True; 14437 14438 -- An imported subprogram may have a body, however it is not known at 14439 -- compile or bind time where the body resides and whether it will be 14440 -- elaborated on time. 14441 14442 elsif Is_Imported (Subp_Id) then 14443 return True; 14444 end if; 14445 14446 return False; 14447 end Is_Bodiless_Subprogram; 14448 14449 ---------------------- 14450 -- Is_Bridge_Target -- 14451 ---------------------- 14452 14453 function Is_Bridge_Target (Id : Entity_Id) return Boolean is 14454 begin 14455 return 14456 Is_Accept_Alternative_Proc (Id) 14457 or else Is_Finalizer_Proc (Id) 14458 or else Is_Partial_Invariant_Proc (Id) 14459 or else Is_Postconditions_Proc (Id) 14460 or else Is_TSS (Id, TSS_Deep_Adjust) 14461 or else Is_TSS (Id, TSS_Deep_Finalize) 14462 or else Is_TSS (Id, TSS_Deep_Initialize); 14463 end Is_Bridge_Target; 14464 14465 ------------------------ 14466 -- Is_Controlled_Proc -- 14467 ------------------------ 14468 14469 function Is_Controlled_Proc 14470 (Subp_Id : Entity_Id; 14471 Subp_Nam : Name_Id) return Boolean 14472 is 14473 Formal_Id : Entity_Id; 14474 14475 begin 14476 pragma Assert (Nam_In (Subp_Nam, Name_Adjust, 14477 Name_Finalize, 14478 Name_Initialize)); 14479 14480 -- To qualify, the subprogram must denote a source procedure with 14481 -- name Adjust, Finalize, or Initialize where the sole formal is 14482 -- controlled. 14483 14484 if Comes_From_Source (Subp_Id) 14485 and then Ekind (Subp_Id) = E_Procedure 14486 and then Chars (Subp_Id) = Subp_Nam 14487 then 14488 Formal_Id := First_Formal (Subp_Id); 14489 14490 return 14491 Present (Formal_Id) 14492 and then Is_Controlled (Etype (Formal_Id)) 14493 and then No (Next_Formal (Formal_Id)); 14494 end if; 14495 14496 return False; 14497 end Is_Controlled_Proc; 14498 14499 --------------------------------------- 14500 -- Is_Default_Initial_Condition_Proc -- 14501 --------------------------------------- 14502 14503 function Is_Default_Initial_Condition_Proc 14504 (Id : Entity_Id) return Boolean 14505 is 14506 begin 14507 -- To qualify, the entity must denote a Default_Initial_Condition 14508 -- procedure. 14509 14510 return Ekind (Id) = E_Procedure and then Is_DIC_Procedure (Id); 14511 end Is_Default_Initial_Condition_Proc; 14512 14513 ----------------------- 14514 -- Is_Finalizer_Proc -- 14515 ----------------------- 14516 14517 function Is_Finalizer_Proc (Id : Entity_Id) return Boolean is 14518 begin 14519 -- To qualify, the entity must denote a _Finalizer procedure 14520 14521 return Ekind (Id) = E_Procedure and then Chars (Id) = Name_uFinalizer; 14522 end Is_Finalizer_Proc; 14523 14524 ------------------------------- 14525 -- Is_Initial_Condition_Proc -- 14526 ------------------------------- 14527 14528 function Is_Initial_Condition_Proc (Id : Entity_Id) return Boolean is 14529 begin 14530 -- To qualify, the entity must denote an Initial_Condition procedure 14531 14532 return 14533 Ekind (Id) = E_Procedure 14534 and then Is_Initial_Condition_Procedure (Id); 14535 end Is_Initial_Condition_Proc; 14536 14537 -------------------- 14538 -- Is_Initialized -- 14539 -------------------- 14540 14541 function Is_Initialized (Obj_Decl : Node_Id) return Boolean is 14542 begin 14543 -- To qualify, the object declaration must have an expression 14544 14545 return 14546 Present (Expression (Obj_Decl)) 14547 or else Has_Init_Expression (Obj_Decl); 14548 end Is_Initialized; 14549 14550 ----------------------- 14551 -- Is_Invariant_Proc -- 14552 ----------------------- 14553 14554 function Is_Invariant_Proc (Id : Entity_Id) return Boolean is 14555 begin 14556 -- To qualify, the entity must denote the "full" invariant procedure 14557 14558 return Ekind (Id) = E_Procedure and then Is_Invariant_Procedure (Id); 14559 end Is_Invariant_Proc; 14560 14561 --------------------------------------- 14562 -- Is_Non_Library_Level_Encapsulator -- 14563 --------------------------------------- 14564 14565 function Is_Non_Library_Level_Encapsulator 14566 (N : Node_Id) return Boolean 14567 is 14568 begin 14569 case Nkind (N) is 14570 when N_Abstract_Subprogram_Declaration 14571 | N_Aspect_Specification 14572 | N_Component_Declaration 14573 | N_Entry_Body 14574 | N_Entry_Declaration 14575 | N_Expression_Function 14576 | N_Formal_Abstract_Subprogram_Declaration 14577 | N_Formal_Concrete_Subprogram_Declaration 14578 | N_Formal_Object_Declaration 14579 | N_Formal_Package_Declaration 14580 | N_Formal_Type_Declaration 14581 | N_Generic_Association 14582 | N_Implicit_Label_Declaration 14583 | N_Incomplete_Type_Declaration 14584 | N_Private_Extension_Declaration 14585 | N_Private_Type_Declaration 14586 | N_Protected_Body 14587 | N_Protected_Type_Declaration 14588 | N_Single_Protected_Declaration 14589 | N_Single_Task_Declaration 14590 | N_Subprogram_Body 14591 | N_Subprogram_Declaration 14592 | N_Task_Body 14593 | N_Task_Type_Declaration 14594 => 14595 return True; 14596 14597 when others => 14598 return Is_Generic_Declaration_Or_Body (N); 14599 end case; 14600 end Is_Non_Library_Level_Encapsulator; 14601 14602 ------------------------------- 14603 -- Is_Partial_Invariant_Proc -- 14604 ------------------------------- 14605 14606 function Is_Partial_Invariant_Proc (Id : Entity_Id) return Boolean is 14607 begin 14608 -- To qualify, the entity must denote the "partial" invariant 14609 -- procedure. 14610 14611 return 14612 Ekind (Id) = E_Procedure 14613 and then Is_Partial_Invariant_Procedure (Id); 14614 end Is_Partial_Invariant_Proc; 14615 14616 ---------------------------- 14617 -- Is_Postconditions_Proc -- 14618 ---------------------------- 14619 14620 function Is_Postconditions_Proc (Id : Entity_Id) return Boolean is 14621 begin 14622 -- To qualify, the entity must denote a _Postconditions procedure 14623 14624 return 14625 Ekind (Id) = E_Procedure and then Chars (Id) = Name_uPostconditions; 14626 end Is_Postconditions_Proc; 14627 14628 --------------------------- 14629 -- Is_Preelaborated_Unit -- 14630 --------------------------- 14631 14632 function Is_Preelaborated_Unit (Id : Entity_Id) return Boolean is 14633 begin 14634 return 14635 Is_Preelaborated (Id) 14636 or else Is_Pure (Id) 14637 or else Is_Remote_Call_Interface (Id) 14638 or else Is_Remote_Types (Id) 14639 or else Is_Shared_Passive (Id); 14640 end Is_Preelaborated_Unit; 14641 14642 ------------------------ 14643 -- Is_Protected_Entry -- 14644 ------------------------ 14645 14646 function Is_Protected_Entry (Id : Entity_Id) return Boolean is 14647 begin 14648 -- To qualify, the entity must denote an entry defined in a protected 14649 -- type. 14650 14651 return 14652 Is_Entry (Id) 14653 and then Is_Protected_Type (Non_Private_View (Scope (Id))); 14654 end Is_Protected_Entry; 14655 14656 ----------------------- 14657 -- Is_Protected_Subp -- 14658 ----------------------- 14659 14660 function Is_Protected_Subp (Id : Entity_Id) return Boolean is 14661 begin 14662 -- To qualify, the entity must denote a subprogram defined within a 14663 -- protected type. 14664 14665 return 14666 Ekind_In (Id, E_Function, E_Procedure) 14667 and then Is_Protected_Type (Non_Private_View (Scope (Id))); 14668 end Is_Protected_Subp; 14669 14670 ---------------------------- 14671 -- Is_Protected_Body_Subp -- 14672 ---------------------------- 14673 14674 function Is_Protected_Body_Subp (Id : Entity_Id) return Boolean is 14675 begin 14676 -- To qualify, the entity must denote a subprogram with attribute 14677 -- Protected_Subprogram set. 14678 14679 return 14680 Ekind_In (Id, E_Function, E_Procedure) 14681 and then Present (Protected_Subprogram (Id)); 14682 end Is_Protected_Body_Subp; 14683 14684 ----------------- 14685 -- Is_Scenario -- 14686 ----------------- 14687 14688 function Is_Scenario (N : Node_Id) return Boolean is 14689 begin 14690 case Nkind (N) is 14691 when N_Assignment_Statement 14692 | N_Attribute_Reference 14693 | N_Call_Marker 14694 | N_Entry_Call_Statement 14695 | N_Expanded_Name 14696 | N_Function_Call 14697 | N_Function_Instantiation 14698 | N_Identifier 14699 | N_Package_Instantiation 14700 | N_Procedure_Call_Statement 14701 | N_Procedure_Instantiation 14702 | N_Requeue_Statement 14703 => 14704 return True; 14705 14706 when others => 14707 return False; 14708 end case; 14709 end Is_Scenario; 14710 14711 ------------------------------ 14712 -- Is_SPARK_Semantic_Target -- 14713 ------------------------------ 14714 14715 function Is_SPARK_Semantic_Target (Id : Entity_Id) return Boolean is 14716 begin 14717 return 14718 Is_Default_Initial_Condition_Proc (Id) 14719 or else Is_Initial_Condition_Proc (Id); 14720 end Is_SPARK_Semantic_Target; 14721 14722 ------------------------ 14723 -- Is_Subprogram_Inst -- 14724 ------------------------ 14725 14726 function Is_Subprogram_Inst (Id : Entity_Id) return Boolean is 14727 begin 14728 -- To qualify, the entity must denote a function or a procedure which 14729 -- is hidden within an anonymous package, and is a generic instance. 14730 14731 return 14732 Ekind_In (Id, E_Function, E_Procedure) 14733 and then Is_Hidden (Id) 14734 and then Is_Generic_Instance (Id); 14735 end Is_Subprogram_Inst; 14736 14737 ------------------------------ 14738 -- Is_Suitable_Access_Taken -- 14739 ------------------------------ 14740 14741 function Is_Suitable_Access_Taken (N : Node_Id) return Boolean is 14742 Nam : Name_Id; 14743 Pref : Node_Id; 14744 Subp_Id : Entity_Id; 14745 14746 begin 14747 -- Nothing to do when switch -gnatd.U (ignore 'Access) is in effect 14748 14749 if Debug_Flag_Dot_UU then 14750 return False; 14751 14752 -- Nothing to do when the scenario is not an attribute reference 14753 14754 elsif Nkind (N) /= N_Attribute_Reference then 14755 return False; 14756 14757 -- Nothing to do for internally-generated attributes because they are 14758 -- assumed to be ABE safe. 14759 14760 elsif not Comes_From_Source (N) then 14761 return False; 14762 end if; 14763 14764 Nam := Attribute_Name (N); 14765 Pref := Prefix (N); 14766 14767 -- Sanitize the prefix of the attribute 14768 14769 if not Is_Entity_Name (Pref) then 14770 return False; 14771 14772 elsif No (Entity (Pref)) then 14773 return False; 14774 end if; 14775 14776 Subp_Id := Entity (Pref); 14777 14778 if not Is_Subprogram_Or_Entry (Subp_Id) then 14779 return False; 14780 end if; 14781 14782 -- Traverse a possible chain of renamings to obtain the original 14783 -- entry or subprogram which the prefix may rename. 14784 14785 Subp_Id := Get_Renamed_Entity (Subp_Id); 14786 14787 -- To qualify, the attribute must meet the following prerequisites: 14788 14789 return 14790 14791 -- The prefix must denote a source entry, operator, or subprogram 14792 -- which is not imported. 14793 14794 Comes_From_Source (Subp_Id) 14795 and then Is_Subprogram_Or_Entry (Subp_Id) 14796 and then not Is_Bodiless_Subprogram (Subp_Id) 14797 14798 -- The attribute name must be one of the 'Access forms. Note that 14799 -- 'Unchecked_Access cannot apply to a subprogram. 14800 14801 and then Nam_In (Nam, Name_Access, Name_Unrestricted_Access); 14802 end Is_Suitable_Access_Taken; 14803 14804 ---------------------- 14805 -- Is_Suitable_Call -- 14806 ---------------------- 14807 14808 function Is_Suitable_Call (N : Node_Id) return Boolean is 14809 begin 14810 -- Entry and subprogram calls are intentionally ignored because they 14811 -- may undergo expansion depending on the compilation mode, previous 14812 -- errors, generic context, etc. Call markers play the role of calls 14813 -- and provide a uniform foundation for ABE processing. 14814 14815 return Nkind (N) = N_Call_Marker; 14816 end Is_Suitable_Call; 14817 14818 ------------------------------- 14819 -- Is_Suitable_Instantiation -- 14820 ------------------------------- 14821 14822 function Is_Suitable_Instantiation (N : Node_Id) return Boolean is 14823 Inst : constant Node_Id := Scenario (N); 14824 14825 begin 14826 -- To qualify, the instantiation must come from source 14827 14828 return 14829 Comes_From_Source (Inst) 14830 and then Nkind (Inst) in N_Generic_Instantiation; 14831 end Is_Suitable_Instantiation; 14832 14833 ------------------------------------ 14834 -- Is_Suitable_SPARK_Derived_Type -- 14835 ------------------------------------ 14836 14837 function Is_Suitable_SPARK_Derived_Type (N : Node_Id) return Boolean is 14838 Prag : Node_Id; 14839 Typ : Entity_Id; 14840 14841 begin 14842 -- To qualify, the type declaration must denote a derived tagged type 14843 -- with primitive operations, subject to pragma SPARK_Mode On. 14844 14845 if Nkind (N) = N_Full_Type_Declaration 14846 and then Nkind (Type_Definition (N)) = N_Derived_Type_Definition 14847 then 14848 Typ := Defining_Entity (N); 14849 Prag := SPARK_Pragma (Typ); 14850 14851 return 14852 Is_Tagged_Type (Typ) 14853 and then Has_Primitive_Operations (Typ) 14854 and then Present (Prag) 14855 and then Get_SPARK_Mode_From_Annotation (Prag) = On; 14856 end if; 14857 14858 return False; 14859 end Is_Suitable_SPARK_Derived_Type; 14860 14861 ------------------------------------- 14862 -- Is_Suitable_SPARK_Instantiation -- 14863 ------------------------------------- 14864 14865 function Is_Suitable_SPARK_Instantiation (N : Node_Id) return Boolean is 14866 Inst : constant Node_Id := Scenario (N); 14867 14868 Gen_Id : Entity_Id; 14869 Prag : Node_Id; 14870 14871 begin 14872 -- To qualify, both the instantiation and the generic must be subject 14873 -- to SPARK_Mode On. 14874 14875 if Is_Suitable_Instantiation (N) then 14876 Gen_Id := Instantiated_Generic (Inst); 14877 Prag := SPARK_Pragma (Gen_Id); 14878 14879 return 14880 Is_SPARK_Mode_On_Node (Inst) 14881 and then Present (Prag) 14882 and then Get_SPARK_Mode_From_Annotation (Prag) = On; 14883 end if; 14884 14885 return False; 14886 end Is_Suitable_SPARK_Instantiation; 14887 14888 -------------------------------------------- 14889 -- Is_Suitable_SPARK_Refined_State_Pragma -- 14890 -------------------------------------------- 14891 14892 function Is_Suitable_SPARK_Refined_State_Pragma 14893 (N : Node_Id) return Boolean 14894 is 14895 begin 14896 -- To qualfy, the pragma must denote Refined_State 14897 14898 return 14899 Nkind (N) = N_Pragma 14900 and then Pragma_Name (N) = Name_Refined_State; 14901 end Is_Suitable_SPARK_Refined_State_Pragma; 14902 14903 ------------------------------------- 14904 -- Is_Suitable_Variable_Assignment -- 14905 ------------------------------------- 14906 14907 function Is_Suitable_Variable_Assignment (N : Node_Id) return Boolean is 14908 N_Unit : Node_Id; 14909 N_Unit_Id : Entity_Id; 14910 Nam : Node_Id; 14911 Var_Decl : Node_Id; 14912 Var_Id : Entity_Id; 14913 Var_Unit : Node_Id; 14914 Var_Unit_Id : Entity_Id; 14915 14916 begin 14917 -- Nothing to do when the scenario is not an assignment 14918 14919 if Nkind (N) /= N_Assignment_Statement then 14920 return False; 14921 14922 -- Nothing to do for internally-generated assignments because they 14923 -- are assumed to be ABE safe. 14924 14925 elsif not Comes_From_Source (N) then 14926 return False; 14927 14928 -- Assignments are ignored in GNAT mode on the assumption that 14929 -- they are ABE-safe. This behaviour parallels that of the old 14930 -- ABE mechanism. 14931 14932 elsif GNAT_Mode then 14933 return False; 14934 end if; 14935 14936 Nam := Assignment_Target (N); 14937 14938 -- Sanitize the left hand side of the assignment 14939 14940 if not Is_Entity_Name (Nam) then 14941 return False; 14942 14943 elsif No (Entity (Nam)) then 14944 return False; 14945 end if; 14946 14947 Var_Id := Entity (Nam); 14948 14949 -- Sanitize the variable 14950 14951 if Var_Id = Any_Id then 14952 return False; 14953 14954 elsif Ekind (Var_Id) /= E_Variable then 14955 return False; 14956 end if; 14957 14958 Var_Decl := Declaration_Node (Var_Id); 14959 14960 if Nkind (Var_Decl) /= N_Object_Declaration then 14961 return False; 14962 end if; 14963 14964 N_Unit_Id := Find_Top_Unit (N); 14965 N_Unit := Unit_Declaration_Node (N_Unit_Id); 14966 14967 Var_Unit_Id := Find_Top_Unit (Var_Decl); 14968 Var_Unit := Unit_Declaration_Node (Var_Unit_Id); 14969 14970 -- To qualify, the assignment must meet the following prerequisites: 14971 14972 return 14973 Comes_From_Source (Var_Id) 14974 14975 -- The variable must be declared in the spec of compilation unit 14976 -- U. 14977 14978 and then Nkind (Var_Unit) = N_Package_Declaration 14979 and then Find_Enclosing_Level (Var_Decl) = Library_Spec_Level 14980 14981 -- The assignment must occur in the body of compilation unit U 14982 14983 and then Nkind (N_Unit) = N_Package_Body 14984 and then Present (Corresponding_Body (Var_Unit)) 14985 and then Corresponding_Body (Var_Unit) = N_Unit_Id; 14986 end Is_Suitable_Variable_Assignment; 14987 14988 ------------------------------------ 14989 -- Is_Suitable_Variable_Reference -- 14990 ------------------------------------ 14991 14992 function Is_Suitable_Variable_Reference (N : Node_Id) return Boolean is 14993 begin 14994 -- Expanded names and identifiers are intentionally ignored because 14995 -- they be folded, optimized away, etc. Variable references markers 14996 -- play the role of variable references and provide a uniform 14997 -- foundation for ABE processing. 14998 14999 return Nkind (N) = N_Variable_Reference_Marker; 15000 end Is_Suitable_Variable_Reference; 15001 15002 ------------------- 15003 -- Is_Task_Entry -- 15004 ------------------- 15005 15006 function Is_Task_Entry (Id : Entity_Id) return Boolean is 15007 begin 15008 -- To qualify, the entity must denote an entry defined in a task type 15009 15010 return 15011 Is_Entry (Id) and then Is_Task_Type (Non_Private_View (Scope (Id))); 15012 end Is_Task_Entry; 15013 15014 ------------------------ 15015 -- Is_Up_Level_Target -- 15016 ------------------------ 15017 15018 function Is_Up_Level_Target 15019 (Targ_Decl : Node_Id; 15020 In_State : Processing_In_State) return Boolean 15021 is 15022 Root : constant Node_Id := Root_Scenario; 15023 Root_Rep : constant Scenario_Rep_Id := 15024 Scenario_Representation_Of (Root, In_State); 15025 15026 begin 15027 -- The root appears within the declaratons of a block statement, 15028 -- entry body, subprogram body, or task body ignoring enclosing 15029 -- packages. The root is always within the main unit. 15030 15031 if not In_State.Suppress_Up_Level_Targets 15032 and then Level (Root_Rep) = Declaration_Level 15033 then 15034 -- The target is within the main unit. It acts as an up-level 15035 -- target when it appears within a context which encloses the 15036 -- root. 15037 -- 15038 -- package body Main_Unit is 15039 -- function Func ...; -- target 15040 -- 15041 -- procedure Proc is 15042 -- X : ... := Func; -- root scenario 15043 15044 if In_Extended_Main_Code_Unit (Targ_Decl) then 15045 return not In_Same_Context (Root, Targ_Decl, Nested_OK => True); 15046 15047 -- Otherwise the target is external to the main unit which makes 15048 -- it an up-level target. 15049 15050 else 15051 return True; 15052 end if; 15053 end if; 15054 15055 return False; 15056 end Is_Up_Level_Target; 15057 end Semantics; 15058 15059 --------------------------- 15060 -- Set_Elaboration_Phase -- 15061 --------------------------- 15062 15063 procedure Set_Elaboration_Phase (Status : Elaboration_Phase_Status) is 15064 begin 15065 Elaboration_Phase := Status; 15066 end Set_Elaboration_Phase; 15067 15068 --------------------- 15069 -- SPARK_Processor -- 15070 --------------------- 15071 15072 package body SPARK_Processor is 15073 15074 ----------------------- 15075 -- Local subprograms -- 15076 ----------------------- 15077 15078 procedure Process_SPARK_Derived_Type 15079 (Typ_Decl : Node_Id; 15080 Typ_Rep : Scenario_Rep_Id; 15081 In_State : Processing_In_State); 15082 pragma Inline (Process_SPARK_Derived_Type); 15083 -- Verify that the freeze node of a derived type denoted by declaration 15084 -- Typ_Decl is within the early call region of each overriding primitive 15085 -- body that belongs to the derived type (SPARK RM 7.7(8)). Typ_Rep is 15086 -- the representation of the type. In_State denotes the current state of 15087 -- the Processing phase. 15088 15089 procedure Process_SPARK_Instantiation 15090 (Inst : Node_Id; 15091 Inst_Rep : Scenario_Rep_Id; 15092 In_State : Processing_In_State); 15093 pragma Inline (Process_SPARK_Instantiation); 15094 -- Verify that instanciation Inst does not precede the generic body it 15095 -- instantiates (SPARK RM 7.7(6)). Inst_Rep is the representation of the 15096 -- instantiation. In_State is the current state of the Processing phase. 15097 15098 procedure Process_SPARK_Refined_State_Pragma 15099 (Prag : Node_Id; 15100 Prag_Rep : Scenario_Rep_Id; 15101 In_State : Processing_In_State); 15102 pragma Inline (Process_SPARK_Refined_State_Pragma); 15103 -- Verify that each constituent of Refined_State pragma Prag which 15104 -- belongs to abstract state mentioned in pragma Initializes has prior 15105 -- elaboration with respect to the main unit (SPARK RM 7.7.1(7)). 15106 -- Prag_Rep is the representation of the pragma. In_State denotes the 15107 -- current state of the Processing phase. 15108 15109 procedure Process_SPARK_Scenario 15110 (N : Node_Id; 15111 In_State : Processing_In_State); 15112 pragma Inline (Process_SPARK_Scenario); 15113 -- Top-level dispatcher for verifying SPARK scenarios which are not 15114 -- always executable during elaboration but still need elaboration- 15115 -- related checks. In_State is the current state of the Processing 15116 -- phase. 15117 15118 --------------------------------- 15119 -- Check_SPARK_Model_In_Effect -- 15120 --------------------------------- 15121 15122 SPARK_Model_Warning_Posted : Boolean := False; 15123 -- This flag prevents the same SPARK model-related warning from being 15124 -- emitted multiple times. 15125 15126 procedure Check_SPARK_Model_In_Effect is 15127 Spec_Id : constant Entity_Id := Unique_Entity (Main_Unit_Entity); 15128 15129 begin 15130 -- Do not emit the warning multiple times as this creates useless 15131 -- noise. 15132 15133 if SPARK_Model_Warning_Posted then 15134 null; 15135 15136 -- SPARK rule verification requires the "strict" static model 15137 15138 elsif Static_Elaboration_Checks 15139 and not Relaxed_Elaboration_Checks 15140 then 15141 null; 15142 15143 -- Any other combination of models does not guarantee the absence of 15144 -- ABE problems for SPARK rule verification purposes. Note that there 15145 -- is no need to check for the presence of the legacy ABE mechanism 15146 -- because the legacy code has its own dedicated processing for SPARK 15147 -- rules. 15148 15149 else 15150 SPARK_Model_Warning_Posted := True; 15151 15152 Error_Msg_N 15153 ("??SPARK elaboration checks require static elaboration model", 15154 Spec_Id); 15155 15156 if Dynamic_Elaboration_Checks then 15157 Error_Msg_N 15158 ("\dynamic elaboration model is in effect", Spec_Id); 15159 15160 else 15161 pragma Assert (Relaxed_Elaboration_Checks); 15162 Error_Msg_N 15163 ("\relaxed elaboration model is in effect", Spec_Id); 15164 end if; 15165 end if; 15166 end Check_SPARK_Model_In_Effect; 15167 15168 --------------------------- 15169 -- Check_SPARK_Scenarios -- 15170 --------------------------- 15171 15172 procedure Check_SPARK_Scenarios is 15173 Iter : NE_Set.Iterator; 15174 N : Node_Id; 15175 15176 begin 15177 Iter := Iterate_SPARK_Scenarios; 15178 while NE_Set.Has_Next (Iter) loop 15179 NE_Set.Next (Iter, N); 15180 15181 Process_SPARK_Scenario 15182 (N => N, 15183 In_State => SPARK_State); 15184 end loop; 15185 end Check_SPARK_Scenarios; 15186 15187 -------------------------------- 15188 -- Process_SPARK_Derived_Type -- 15189 -------------------------------- 15190 15191 procedure Process_SPARK_Derived_Type 15192 (Typ_Decl : Node_Id; 15193 Typ_Rep : Scenario_Rep_Id; 15194 In_State : Processing_In_State) 15195 is 15196 pragma Unreferenced (In_State); 15197 15198 Typ : constant Entity_Id := Target (Typ_Rep); 15199 15200 Stop_Check : exception; 15201 -- This exception is raised when the freeze node violates the 15202 -- placement rules. 15203 15204 procedure Check_Overriding_Primitive 15205 (Prim : Entity_Id; 15206 FNode : Node_Id); 15207 pragma Inline (Check_Overriding_Primitive); 15208 -- Verify that freeze node FNode is within the early call region of 15209 -- overriding primitive Prim's body. 15210 15211 function Freeze_Node_Location (FNode : Node_Id) return Source_Ptr; 15212 pragma Inline (Freeze_Node_Location); 15213 -- Return a more accurate source location associated with freeze node 15214 -- FNode. 15215 15216 function Precedes_Source_Construct (N : Node_Id) return Boolean; 15217 pragma Inline (Precedes_Source_Construct); 15218 -- Determine whether arbitrary node N appears prior to some source 15219 -- construct. 15220 15221 procedure Suggest_Elaborate_Body 15222 (N : Node_Id; 15223 Body_Decl : Node_Id; 15224 Error_Nod : Node_Id); 15225 pragma Inline (Suggest_Elaborate_Body); 15226 -- Suggest the use of pragma Elaborate_Body when the pragma will 15227 -- allow for node N to appear within the early call region of 15228 -- subprogram body Body_Decl. The suggestion is attached to 15229 -- Error_Nod as a continuation error. 15230 15231 -------------------------------- 15232 -- Check_Overriding_Primitive -- 15233 -------------------------------- 15234 15235 procedure Check_Overriding_Primitive 15236 (Prim : Entity_Id; 15237 FNode : Node_Id) 15238 is 15239 Prim_Decl : constant Node_Id := Unit_Declaration_Node (Prim); 15240 Body_Decl : Node_Id; 15241 Body_Id : Entity_Id; 15242 Region : Node_Id; 15243 15244 begin 15245 -- Nothing to do for predefined primitives because they are 15246 -- artifacts of tagged type expansion and cannot override source 15247 -- primitives. Nothing to do as well for inherited primitives, as 15248 -- the check concerns overriding ones. 15249 15250 if Is_Predefined_Dispatching_Operation (Prim) 15251 or else not Is_Overriding_Subprogram (Prim) 15252 then 15253 return; 15254 end if; 15255 15256 Body_Id := Corresponding_Body (Prim_Decl); 15257 15258 -- Nothing to do when the primitive does not have a corresponding 15259 -- body. This can happen when the unit with the bodies is not the 15260 -- main unit subjected to ABE checks. 15261 15262 if No (Body_Id) then 15263 return; 15264 15265 -- The primitive overrides a parent or progenitor primitive 15266 15267 elsif Present (Overridden_Operation (Prim)) then 15268 15269 -- Nothing to do when overriding an interface primitive happens 15270 -- by inheriting a non-interface primitive as the check would 15271 -- be done on the parent primitive. 15272 15273 if Present (Alias (Prim)) then 15274 return; 15275 end if; 15276 15277 -- Nothing to do when the primitive is not overriding. The body of 15278 -- such a primitive cannot be targeted by a dispatching call which 15279 -- is executable during elaboration, and cannot cause an ABE. 15280 15281 else 15282 return; 15283 end if; 15284 15285 Body_Decl := Unit_Declaration_Node (Body_Id); 15286 Region := Find_Early_Call_Region (Body_Decl); 15287 15288 -- The freeze node appears prior to the early call region of the 15289 -- primitive body. 15290 15291 -- IMPORTANT: This check must always be performed even when 15292 -- -gnatd.v (enforce SPARK elaboration rules in SPARK code) is not 15293 -- specified because the static model cannot guarantee the absence 15294 -- of ABEs in the presence of dispatching calls. 15295 15296 if Earlier_In_Extended_Unit (FNode, Region) then 15297 Error_Msg_Node_2 := Prim; 15298 Error_Msg_NE 15299 ("first freezing point of type & must appear within early " 15300 & "call region of primitive body & (SPARK RM 7.7(8))", 15301 Typ_Decl, Typ); 15302 15303 Error_Msg_Sloc := Sloc (Region); 15304 Error_Msg_N ("\region starts #", Typ_Decl); 15305 15306 Error_Msg_Sloc := Sloc (Body_Decl); 15307 Error_Msg_N ("\region ends #", Typ_Decl); 15308 15309 Error_Msg_Sloc := Freeze_Node_Location (FNode); 15310 Error_Msg_N ("\first freezing point #", Typ_Decl); 15311 15312 -- If applicable, suggest the use of pragma Elaborate_Body in 15313 -- the associated package spec. 15314 15315 Suggest_Elaborate_Body 15316 (N => FNode, 15317 Body_Decl => Body_Decl, 15318 Error_Nod => Typ_Decl); 15319 15320 raise Stop_Check; 15321 end if; 15322 end Check_Overriding_Primitive; 15323 15324 -------------------------- 15325 -- Freeze_Node_Location -- 15326 -------------------------- 15327 15328 function Freeze_Node_Location (FNode : Node_Id) return Source_Ptr is 15329 Context : constant Node_Id := Parent (FNode); 15330 Loc : constant Source_Ptr := Sloc (FNode); 15331 15332 Prv_Decls : List_Id; 15333 Vis_Decls : List_Id; 15334 15335 begin 15336 -- In general, the source location of the freeze node is as close 15337 -- as possible to the real freeze point, except when the freeze 15338 -- node is at the "bottom" of a package spec. 15339 15340 if Nkind (Context) = N_Package_Specification then 15341 Prv_Decls := Private_Declarations (Context); 15342 Vis_Decls := Visible_Declarations (Context); 15343 15344 -- The freeze node appears in the private declarations of the 15345 -- package. 15346 15347 if Present (Prv_Decls) 15348 and then List_Containing (FNode) = Prv_Decls 15349 then 15350 null; 15351 15352 -- The freeze node appears in the visible declarations of the 15353 -- package and there are no private declarations. 15354 15355 elsif Present (Vis_Decls) 15356 and then List_Containing (FNode) = Vis_Decls 15357 and then (No (Prv_Decls) or else Is_Empty_List (Prv_Decls)) 15358 then 15359 null; 15360 15361 -- Otherwise the freeze node is not in the "last" declarative 15362 -- list of the package. Use the existing source location of the 15363 -- freeze node. 15364 15365 else 15366 return Loc; 15367 end if; 15368 15369 -- The freeze node appears at the "bottom" of the package when 15370 -- it is in the "last" declarative list and is either the last 15371 -- in the list or is followed by internal constructs only. In 15372 -- that case the more appropriate source location is that of 15373 -- the package end label. 15374 15375 if not Precedes_Source_Construct (FNode) then 15376 return Sloc (End_Label (Context)); 15377 end if; 15378 end if; 15379 15380 return Loc; 15381 end Freeze_Node_Location; 15382 15383 ------------------------------- 15384 -- Precedes_Source_Construct -- 15385 ------------------------------- 15386 15387 function Precedes_Source_Construct (N : Node_Id) return Boolean is 15388 Decl : Node_Id; 15389 15390 begin 15391 Decl := Next (N); 15392 while Present (Decl) loop 15393 if Comes_From_Source (Decl) then 15394 return True; 15395 15396 -- A generated body for a source expression function is treated 15397 -- as a source construct. 15398 15399 elsif Nkind (Decl) = N_Subprogram_Body 15400 and then Was_Expression_Function (Decl) 15401 and then Comes_From_Source (Original_Node (Decl)) 15402 then 15403 return True; 15404 end if; 15405 15406 Next (Decl); 15407 end loop; 15408 15409 return False; 15410 end Precedes_Source_Construct; 15411 15412 ---------------------------- 15413 -- Suggest_Elaborate_Body -- 15414 ---------------------------- 15415 15416 procedure Suggest_Elaborate_Body 15417 (N : Node_Id; 15418 Body_Decl : Node_Id; 15419 Error_Nod : Node_Id) 15420 is 15421 Unit_Id : constant Node_Id := Unit (Cunit (Main_Unit)); 15422 Region : Node_Id; 15423 15424 begin 15425 -- The suggestion applies only when the subprogram body resides in 15426 -- a compilation package body, and a pragma Elaborate_Body would 15427 -- allow for the node to appear in the early call region of the 15428 -- subprogram body. This implies that all code from the subprogram 15429 -- body up to the node is preelaborable. 15430 15431 if Nkind (Unit_Id) = N_Package_Body then 15432 15433 -- Find the start of the early call region again assuming that 15434 -- the package spec has pragma Elaborate_Body. Note that the 15435 -- internal data structures are intentionally not updated 15436 -- because this is a speculative search. 15437 15438 Region := 15439 Find_Early_Call_Region 15440 (Body_Decl => Body_Decl, 15441 Assume_Elab_Body => True, 15442 Skip_Memoization => True); 15443 15444 -- If the node appears within the early call region, assuming 15445 -- that the package spec carries pragma Elaborate_Body, then it 15446 -- is safe to suggest the pragma. 15447 15448 if Earlier_In_Extended_Unit (Region, N) then 15449 Error_Msg_Name_1 := Name_Elaborate_Body; 15450 Error_Msg_NE 15451 ("\consider adding pragma % in spec of unit &", 15452 Error_Nod, Defining_Entity (Unit_Id)); 15453 end if; 15454 end if; 15455 end Suggest_Elaborate_Body; 15456 15457 -- Local variables 15458 15459 FNode : constant Node_Id := Freeze_Node (Typ); 15460 Prims : constant Elist_Id := Direct_Primitive_Operations (Typ); 15461 15462 Prim_Elmt : Elmt_Id; 15463 15464 -- Start of processing for Process_SPARK_Derived_Type 15465 15466 begin 15467 -- A type should have its freeze node set by the time SPARK scenarios 15468 -- are being verified. 15469 15470 pragma Assert (Present (FNode)); 15471 15472 -- Verify that the freeze node of the derived type is within the 15473 -- early call region of each overriding primitive body 15474 -- (SPARK RM 7.7(8)). 15475 15476 if Present (Prims) then 15477 Prim_Elmt := First_Elmt (Prims); 15478 while Present (Prim_Elmt) loop 15479 Check_Overriding_Primitive 15480 (Prim => Node (Prim_Elmt), 15481 FNode => FNode); 15482 15483 Next_Elmt (Prim_Elmt); 15484 end loop; 15485 end if; 15486 15487 exception 15488 when Stop_Check => 15489 null; 15490 end Process_SPARK_Derived_Type; 15491 15492 --------------------------------- 15493 -- Process_SPARK_Instantiation -- 15494 --------------------------------- 15495 15496 procedure Process_SPARK_Instantiation 15497 (Inst : Node_Id; 15498 Inst_Rep : Scenario_Rep_Id; 15499 In_State : Processing_In_State) 15500 is 15501 Gen_Id : constant Entity_Id := Target (Inst_Rep); 15502 Gen_Rep : constant Target_Rep_Id := 15503 Target_Representation_Of (Gen_Id, In_State); 15504 Body_Decl : constant Node_Id := Body_Declaration (Gen_Rep); 15505 15506 begin 15507 -- The instantiation and the generic body are both in the main unit 15508 15509 if Present (Body_Decl) 15510 and then In_Extended_Main_Code_Unit (Body_Decl) 15511 15512 -- If the instantiation appears prior to the generic body, then the 15513 -- instantiation is illegal (SPARK RM 7.7(6)). 15514 15515 -- IMPORTANT: This check must always be performed even when 15516 -- -gnatd.v (enforce SPARK elaboration rules in SPARK code) is not 15517 -- specified because the rule prevents use-before-declaration of 15518 -- objects that may precede the generic body. 15519 15520 and then Earlier_In_Extended_Unit (Inst, Body_Decl) 15521 then 15522 Error_Msg_NE 15523 ("cannot instantiate & before body seen", Inst, Gen_Id); 15524 end if; 15525 end Process_SPARK_Instantiation; 15526 15527 ---------------------------- 15528 -- Process_SPARK_Scenario -- 15529 ---------------------------- 15530 15531 procedure Process_SPARK_Scenario 15532 (N : Node_Id; 15533 In_State : Processing_In_State) 15534 is 15535 Scen : constant Node_Id := Scenario (N); 15536 15537 begin 15538 -- Ensure that a suitable elaboration model is in effect for SPARK 15539 -- rule verification. 15540 15541 Check_SPARK_Model_In_Effect; 15542 15543 -- Add the current scenario to the stack of active scenarios 15544 15545 Push_Active_Scenario (Scen); 15546 15547 -- Derived type 15548 15549 if Is_Suitable_SPARK_Derived_Type (Scen) then 15550 Process_SPARK_Derived_Type 15551 (Typ_Decl => Scen, 15552 Typ_Rep => Scenario_Representation_Of (Scen, In_State), 15553 In_State => In_State); 15554 15555 -- Instantiation 15556 15557 elsif Is_Suitable_SPARK_Instantiation (Scen) then 15558 Process_SPARK_Instantiation 15559 (Inst => Scen, 15560 Inst_Rep => Scenario_Representation_Of (Scen, In_State), 15561 In_State => In_State); 15562 15563 -- Refined_State pragma 15564 15565 elsif Is_Suitable_SPARK_Refined_State_Pragma (Scen) then 15566 Process_SPARK_Refined_State_Pragma 15567 (Prag => Scen, 15568 Prag_Rep => Scenario_Representation_Of (Scen, In_State), 15569 In_State => In_State); 15570 end if; 15571 15572 -- Remove the current scenario from the stack of active scenarios 15573 -- once all ABE diagnostics and checks have been performed. 15574 15575 Pop_Active_Scenario (Scen); 15576 end Process_SPARK_Scenario; 15577 15578 ---------------------------------------- 15579 -- Process_SPARK_Refined_State_Pragma -- 15580 ---------------------------------------- 15581 15582 procedure Process_SPARK_Refined_State_Pragma 15583 (Prag : Node_Id; 15584 Prag_Rep : Scenario_Rep_Id; 15585 In_State : Processing_In_State) 15586 is 15587 pragma Unreferenced (Prag_Rep); 15588 15589 procedure Check_SPARK_Constituent (Constit_Id : Entity_Id); 15590 pragma Inline (Check_SPARK_Constituent); 15591 -- Ensure that a single constituent Constit_Id is elaborated prior to 15592 -- the main unit. 15593 15594 procedure Check_SPARK_Constituents (Constits : Elist_Id); 15595 pragma Inline (Check_SPARK_Constituents); 15596 -- Ensure that all constituents found in list Constits are elaborated 15597 -- prior to the main unit. 15598 15599 procedure Check_SPARK_Initialized_State (State : Node_Id); 15600 pragma Inline (Check_SPARK_Initialized_State); 15601 -- Ensure that the constituents of single abstract state State are 15602 -- elaborated prior to the main unit. 15603 15604 procedure Check_SPARK_Initialized_States (Pack_Id : Entity_Id); 15605 pragma Inline (Check_SPARK_Initialized_States); 15606 -- Ensure that the constituents of all abstract states which appear 15607 -- in the Initializes pragma of package Pack_Id are elaborated prior 15608 -- to the main unit. 15609 15610 ----------------------------- 15611 -- Check_SPARK_Constituent -- 15612 ----------------------------- 15613 15614 procedure Check_SPARK_Constituent (Constit_Id : Entity_Id) is 15615 SM_Prag : Node_Id; 15616 15617 begin 15618 -- Nothing to do for "null" constituents 15619 15620 if Nkind (Constit_Id) = N_Null then 15621 return; 15622 15623 -- Nothing to do for illegal constituents 15624 15625 elsif Error_Posted (Constit_Id) then 15626 return; 15627 end if; 15628 15629 SM_Prag := SPARK_Pragma (Constit_Id); 15630 15631 -- The check applies only when the constituent is subject to 15632 -- pragma SPARK_Mode On. 15633 15634 if Present (SM_Prag) 15635 and then Get_SPARK_Mode_From_Annotation (SM_Prag) = On 15636 then 15637 -- An external constituent of an abstract state which appears 15638 -- in the Initializes pragma of a package spec imposes an 15639 -- Elaborate requirement on the context of the main unit. 15640 -- Determine whether the context has a pragma strong enough to 15641 -- meet the requirement. 15642 15643 -- IMPORTANT: This check is performed only when -gnatd.v 15644 -- (enforce SPARK elaboration rules in SPARK code) is in effect 15645 -- because the static model can ensure the prior elaboration of 15646 -- the unit which contains a constituent by installing implicit 15647 -- Elaborate pragma. 15648 15649 if Debug_Flag_Dot_V then 15650 Meet_Elaboration_Requirement 15651 (N => Prag, 15652 Targ_Id => Constit_Id, 15653 Req_Nam => Name_Elaborate, 15654 In_State => In_State); 15655 15656 -- Otherwise ensure that the unit with the external constituent 15657 -- is elaborated prior to the main unit. 15658 15659 else 15660 Ensure_Prior_Elaboration 15661 (N => Prag, 15662 Unit_Id => Find_Top_Unit (Constit_Id), 15663 Prag_Nam => Name_Elaborate, 15664 In_State => In_State); 15665 end if; 15666 end if; 15667 end Check_SPARK_Constituent; 15668 15669 ------------------------------ 15670 -- Check_SPARK_Constituents -- 15671 ------------------------------ 15672 15673 procedure Check_SPARK_Constituents (Constits : Elist_Id) is 15674 Constit_Elmt : Elmt_Id; 15675 15676 begin 15677 if Present (Constits) then 15678 Constit_Elmt := First_Elmt (Constits); 15679 while Present (Constit_Elmt) loop 15680 Check_SPARK_Constituent (Node (Constit_Elmt)); 15681 Next_Elmt (Constit_Elmt); 15682 end loop; 15683 end if; 15684 end Check_SPARK_Constituents; 15685 15686 ----------------------------------- 15687 -- Check_SPARK_Initialized_State -- 15688 ----------------------------------- 15689 15690 procedure Check_SPARK_Initialized_State (State : Node_Id) is 15691 SM_Prag : Node_Id; 15692 State_Id : Entity_Id; 15693 15694 begin 15695 -- Nothing to do for "null" initialization items 15696 15697 if Nkind (State) = N_Null then 15698 return; 15699 15700 -- Nothing to do for illegal states 15701 15702 elsif Error_Posted (State) then 15703 return; 15704 end if; 15705 15706 State_Id := Entity_Of (State); 15707 15708 -- Sanitize the state 15709 15710 if No (State_Id) then 15711 return; 15712 15713 elsif Error_Posted (State_Id) then 15714 return; 15715 15716 elsif Ekind (State_Id) /= E_Abstract_State then 15717 return; 15718 end if; 15719 15720 -- The check is performed only when the abstract state is subject 15721 -- to SPARK_Mode On. 15722 15723 SM_Prag := SPARK_Pragma (State_Id); 15724 15725 if Present (SM_Prag) 15726 and then Get_SPARK_Mode_From_Annotation (SM_Prag) = On 15727 then 15728 Check_SPARK_Constituents (Refinement_Constituents (State_Id)); 15729 end if; 15730 end Check_SPARK_Initialized_State; 15731 15732 ------------------------------------ 15733 -- Check_SPARK_Initialized_States -- 15734 ------------------------------------ 15735 15736 procedure Check_SPARK_Initialized_States (Pack_Id : Entity_Id) is 15737 Init_Prag : constant Node_Id := 15738 Get_Pragma (Pack_Id, Pragma_Initializes); 15739 15740 Init : Node_Id; 15741 Inits : Node_Id; 15742 15743 begin 15744 if Present (Init_Prag) then 15745 Inits := Expression (Get_Argument (Init_Prag, Pack_Id)); 15746 15747 -- Avoid processing a "null" initialization list. The only 15748 -- other alternative is an aggregate. 15749 15750 if Nkind (Inits) = N_Aggregate then 15751 15752 -- The initialization items appear in list form: 15753 -- 15754 -- (state1, state2) 15755 15756 if Present (Expressions (Inits)) then 15757 Init := First (Expressions (Inits)); 15758 while Present (Init) loop 15759 Check_SPARK_Initialized_State (Init); 15760 Next (Init); 15761 end loop; 15762 end if; 15763 15764 -- The initialization items appear in associated form: 15765 -- 15766 -- (state1 => item1, 15767 -- state2 => (item2, item3)) 15768 15769 if Present (Component_Associations (Inits)) then 15770 Init := First (Component_Associations (Inits)); 15771 while Present (Init) loop 15772 Check_SPARK_Initialized_State (Init); 15773 Next (Init); 15774 end loop; 15775 end if; 15776 end if; 15777 end if; 15778 end Check_SPARK_Initialized_States; 15779 15780 -- Local variables 15781 15782 Pack_Body : constant Node_Id := Find_Related_Package_Or_Body (Prag); 15783 15784 -- Start of processing for Process_SPARK_Refined_State_Pragma 15785 15786 begin 15787 -- Pragma Refined_State must be associated with a package body 15788 15789 pragma Assert 15790 (Present (Pack_Body) and then Nkind (Pack_Body) = N_Package_Body); 15791 15792 -- Verify that each external contitunent of an abstract state 15793 -- mentioned in pragma Initializes is properly elaborated. 15794 15795 Check_SPARK_Initialized_States (Unique_Defining_Entity (Pack_Body)); 15796 end Process_SPARK_Refined_State_Pragma; 15797 end SPARK_Processor; 15798 15799 ------------------------------- 15800 -- Spec_And_Body_From_Entity -- 15801 ------------------------------- 15802 15803 procedure Spec_And_Body_From_Entity 15804 (Id : Node_Id; 15805 Spec_Decl : out Node_Id; 15806 Body_Decl : out Node_Id) 15807 is 15808 begin 15809 Spec_And_Body_From_Node 15810 (N => Unit_Declaration_Node (Id), 15811 Spec_Decl => Spec_Decl, 15812 Body_Decl => Body_Decl); 15813 end Spec_And_Body_From_Entity; 15814 15815 ----------------------------- 15816 -- Spec_And_Body_From_Node -- 15817 ----------------------------- 15818 15819 procedure Spec_And_Body_From_Node 15820 (N : Node_Id; 15821 Spec_Decl : out Node_Id; 15822 Body_Decl : out Node_Id) 15823 is 15824 Body_Id : Entity_Id; 15825 Spec_Id : Entity_Id; 15826 15827 begin 15828 -- Assume that the construct lacks spec and body 15829 15830 Body_Decl := Empty; 15831 Spec_Decl := Empty; 15832 15833 -- Bodies 15834 15835 if Nkind_In (N, N_Package_Body, 15836 N_Protected_Body, 15837 N_Subprogram_Body, 15838 N_Task_Body) 15839 then 15840 Spec_Id := Corresponding_Spec (N); 15841 15842 -- The body completes a previous declaration 15843 15844 if Present (Spec_Id) then 15845 Spec_Decl := Unit_Declaration_Node (Spec_Id); 15846 15847 -- Otherwise the body acts as the initial declaration, and is both a 15848 -- spec and body. There is no need to look for an optional body. 15849 15850 else 15851 Body_Decl := N; 15852 Spec_Decl := N; 15853 return; 15854 end if; 15855 15856 -- Declarations 15857 15858 elsif Nkind_In (N, N_Entry_Declaration, 15859 N_Generic_Package_Declaration, 15860 N_Generic_Subprogram_Declaration, 15861 N_Package_Declaration, 15862 N_Protected_Type_Declaration, 15863 N_Subprogram_Declaration, 15864 N_Task_Type_Declaration) 15865 then 15866 Spec_Decl := N; 15867 15868 -- Expression function 15869 15870 elsif Nkind (N) = N_Expression_Function then 15871 Spec_Id := Corresponding_Spec (N); 15872 pragma Assert (Present (Spec_Id)); 15873 15874 Spec_Decl := Unit_Declaration_Node (Spec_Id); 15875 15876 -- Instantiations 15877 15878 elsif Nkind (N) in N_Generic_Instantiation then 15879 Spec_Decl := Instance_Spec (N); 15880 pragma Assert (Present (Spec_Decl)); 15881 15882 -- Stubs 15883 15884 elsif Nkind (N) in N_Body_Stub then 15885 Spec_Id := Corresponding_Spec_Of_Stub (N); 15886 15887 -- The stub completes a previous declaration 15888 15889 if Present (Spec_Id) then 15890 Spec_Decl := Unit_Declaration_Node (Spec_Id); 15891 15892 -- Otherwise the stub acts as a spec 15893 15894 else 15895 Spec_Decl := N; 15896 end if; 15897 end if; 15898 15899 -- Obtain an optional or mandatory body 15900 15901 if Present (Spec_Decl) then 15902 Body_Id := Corresponding_Body (Spec_Decl); 15903 15904 if Present (Body_Id) then 15905 Body_Decl := Unit_Declaration_Node (Body_Id); 15906 end if; 15907 end if; 15908 end Spec_And_Body_From_Node; 15909 15910 ------------------------------- 15911 -- Static_Elaboration_Checks -- 15912 ------------------------------- 15913 15914 function Static_Elaboration_Checks return Boolean is 15915 begin 15916 return not Dynamic_Elaboration_Checks; 15917 end Static_Elaboration_Checks; 15918 15919 ----------------- 15920 -- Unit_Entity -- 15921 ----------------- 15922 15923 function Unit_Entity (Unit_Id : Entity_Id) return Entity_Id is 15924 function Is_Subunit (Id : Entity_Id) return Boolean; 15925 pragma Inline (Is_Subunit); 15926 -- Determine whether the entity of an initial declaration denotes a 15927 -- subunit. 15928 15929 ---------------- 15930 -- Is_Subunit -- 15931 ---------------- 15932 15933 function Is_Subunit (Id : Entity_Id) return Boolean is 15934 Decl : constant Node_Id := Unit_Declaration_Node (Id); 15935 15936 begin 15937 return 15938 Nkind_In (Decl, N_Generic_Package_Declaration, 15939 N_Generic_Subprogram_Declaration, 15940 N_Package_Declaration, 15941 N_Protected_Type_Declaration, 15942 N_Subprogram_Declaration, 15943 N_Task_Type_Declaration) 15944 and then Present (Corresponding_Body (Decl)) 15945 and then Nkind (Parent (Unit_Declaration_Node 15946 (Corresponding_Body (Decl)))) = N_Subunit; 15947 end Is_Subunit; 15948 15949 -- Local variables 15950 15951 Id : Entity_Id; 15952 15953 -- Start of processing for Unit_Entity 15954 15955 begin 15956 Id := Unique_Entity (Unit_Id); 15957 15958 -- Skip all subunits found in the scope chain which ends at the input 15959 -- unit. 15960 15961 while Is_Subunit (Id) loop 15962 Id := Scope (Id); 15963 end loop; 15964 15965 return Id; 15966 end Unit_Entity; 15967 15968 --------------------------------- 15969 -- Update_Elaboration_Scenario -- 15970 --------------------------------- 15971 15972 procedure Update_Elaboration_Scenario (New_N : Node_Id; Old_N : Node_Id) is 15973 begin 15974 -- Nothing to do when the elaboration phase of the compiler is not 15975 -- active. 15976 15977 if not Elaboration_Phase_Active then 15978 return; 15979 15980 -- Nothing to do when the old and new scenarios are one and the same 15981 15982 elsif Old_N = New_N then 15983 return; 15984 end if; 15985 15986 -- A scenario is being transformed by Atree.Rewrite. Update all relevant 15987 -- internal data structures to reflect this change. This ensures that a 15988 -- potential run-time conditional ABE check or a guaranteed ABE failure 15989 -- is inserted at the proper place in the tree. 15990 15991 if Is_Scenario (Old_N) then 15992 Replace_Scenario (Old_N, New_N); 15993 end if; 15994 end Update_Elaboration_Scenario; 15995 15996 --------------------------------------------------------------------------- 15997 -- -- 15998 -- 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 -- 15999 -- -- 16000 -- M E C H A N I S M -- 16001 -- -- 16002 --------------------------------------------------------------------------- 16003 16004 -- This section contains the implementation of the pre-18.x legacy ABE 16005 -- mechanism. The mechanism can be activated using switch -gnatH (legacy 16006 -- elaboration checking mode enabled). 16007 16008 ----------------------------- 16009 -- Description of Approach -- 16010 ----------------------------- 16011 16012 -- Every non-static call that is encountered by Sem_Res results in a call 16013 -- to Check_Elab_Call, with N being the call node, and Outer set to its 16014 -- default value of True. In addition X'Access is treated like a call 16015 -- for the access-to-procedure case, and in SPARK mode only we also 16016 -- check variable references. 16017 16018 -- The goal of Check_Elab_Call is to determine whether or not the reference 16019 -- in question can generate an access before elaboration error (raising 16020 -- Program_Error) either by directly calling a subprogram whose body 16021 -- has not yet been elaborated, or indirectly, by calling a subprogram 16022 -- whose body has been elaborated, but which contains a call to such a 16023 -- subprogram. 16024 16025 -- In addition, in SPARK mode, we are checking for a variable reference in 16026 -- another package, which requires an explicit Elaborate_All pragma. 16027 16028 -- The only references that we need to look at the outer level are 16029 -- references that occur in elaboration code. There are two cases. The 16030 -- reference can be at the outer level of elaboration code, or it can 16031 -- be within another unit, e.g. the elaboration code of a subprogram. 16032 16033 -- In the case of an elaboration call at the outer level, we must trace 16034 -- all calls to outer level routines either within the current unit or to 16035 -- other units that are with'ed. For calls within the current unit, we can 16036 -- determine if the body has been elaborated or not, and if it has not, 16037 -- then a warning is generated. 16038 16039 -- Note that there are two subcases. If the original call directly calls a 16040 -- subprogram whose body has not been elaborated, then we know that an ABE 16041 -- will take place, and we replace the call by a raise of Program_Error. 16042 -- If the call is indirect, then we don't know that the PE will be raised, 16043 -- since the call might be guarded by a conditional. In this case we set 16044 -- Do_Elab_Check on the call so that a dynamic check is generated, and 16045 -- output a warning. 16046 16047 -- For calls to a subprogram in a with'ed unit or a 'Access or variable 16048 -- reference (SPARK mode case), we require that a pragma Elaborate_All 16049 -- or pragma Elaborate be present, or that the referenced unit have a 16050 -- pragma Preelaborate, pragma Pure, or pragma Elaborate_Body. If none 16051 -- of these conditions is met, then a warning is generated that a pragma 16052 -- Elaborate_All may be needed (error in the SPARK case), or an implicit 16053 -- pragma is generated. 16054 16055 -- For the case of an elaboration call at some inner level, we are 16056 -- interested in tracing only calls to subprograms at the same level, i.e. 16057 -- those that can be called during elaboration. Any calls to outer level 16058 -- routines cannot cause ABE's as a result of the original call (there 16059 -- might be an outer level call to the subprogram from outside that causes 16060 -- the ABE, but that gets analyzed separately). 16061 16062 -- Note that we never trace calls to inner level subprograms, since these 16063 -- cannot result in ABE's unless there is an elaboration problem at a lower 16064 -- level, which will be separately detected. 16065 16066 -- Note on pragma Elaborate. The checking here assumes that a pragma 16067 -- Elaborate on a with'ed unit guarantees that subprograms within the unit 16068 -- can be called without causing an ABE. This is not in fact the case since 16069 -- pragma Elaborate does not guarantee the transitive coverage guaranteed 16070 -- by Elaborate_All. However, we decide to trust the user in this case. 16071 16072 -------------------------------------- 16073 -- Instantiation Elaboration Errors -- 16074 -------------------------------------- 16075 16076 -- A special case arises when an instantiation appears in a context that is 16077 -- known to be before the body is elaborated, e.g. 16078 16079 -- generic package x is ... 16080 -- ... 16081 -- package xx is new x; 16082 -- ... 16083 -- package body x is ... 16084 16085 -- In this situation it is certain that an elaboration error will occur, 16086 -- and an unconditional raise Program_Error statement is inserted before 16087 -- the instantiation, and a warning generated. 16088 16089 -- The problem is that in this case we have no place to put the body of 16090 -- the instantiation. We can't put it in the normal place, because it is 16091 -- too early, and will cause errors to occur as a result of referencing 16092 -- entities before they are declared. 16093 16094 -- Our approach in this case is simply to avoid creating the body of the 16095 -- instantiation in such a case. The instantiation spec is modified to 16096 -- include dummy bodies for all subprograms, so that the resulting code 16097 -- does not contain subprogram specs with no corresponding bodies. 16098 16099 -- The following table records the recursive call chain for output in the 16100 -- Output routine. Each entry records the call node and the entity of the 16101 -- called routine. The number of entries in the table (i.e. the value of 16102 -- Elab_Call.Last) indicates the current depth of recursion and is used to 16103 -- identify the outer level. 16104 16105 type Elab_Call_Element is record 16106 Cloc : Source_Ptr; 16107 Ent : Entity_Id; 16108 end record; 16109 16110 package Elab_Call is new Table.Table 16111 (Table_Component_Type => Elab_Call_Element, 16112 Table_Index_Type => Int, 16113 Table_Low_Bound => 1, 16114 Table_Initial => 50, 16115 Table_Increment => 100, 16116 Table_Name => "Elab_Call"); 16117 16118 -- The following table records all calls that have been processed starting 16119 -- from an outer level call. The table prevents both infinite recursion and 16120 -- useless reanalysis of calls within the same context. The use of context 16121 -- is important because it allows for proper checks in more complex code: 16122 16123 -- if ... then 16124 -- Call; -- requires a check 16125 -- Call; -- does not need a check thanks to the table 16126 -- elsif ... then 16127 -- Call; -- requires a check, different context 16128 -- end if; 16129 16130 -- Call; -- requires a check, different context 16131 16132 type Visited_Element is record 16133 Subp_Id : Entity_Id; 16134 -- The entity of the subprogram being called 16135 16136 Context : Node_Id; 16137 -- The context where the call to the subprogram occurs 16138 end record; 16139 16140 package Elab_Visited is new Table.Table 16141 (Table_Component_Type => Visited_Element, 16142 Table_Index_Type => Int, 16143 Table_Low_Bound => 1, 16144 Table_Initial => 200, 16145 Table_Increment => 100, 16146 Table_Name => "Elab_Visited"); 16147 16148 -- The following table records delayed calls which must be examined after 16149 -- all generic bodies have been instantiated. 16150 16151 type Delay_Element is record 16152 N : Node_Id; 16153 -- The parameter N from the call to Check_Internal_Call. Note that this 16154 -- node may get rewritten over the delay period by expansion in the call 16155 -- case (but not in the instantiation case). 16156 16157 E : Entity_Id; 16158 -- The parameter E from the call to Check_Internal_Call 16159 16160 Orig_Ent : Entity_Id; 16161 -- The parameter Orig_Ent from the call to Check_Internal_Call 16162 16163 Curscop : Entity_Id; 16164 -- The current scope of the call. This is restored when we complete the 16165 -- delayed call, so that we do this in the right scope. 16166 16167 Outer_Scope : Entity_Id; 16168 -- Save scope of outer level call 16169 16170 From_Elab_Code : Boolean; 16171 -- Save indication of whether this call is from elaboration code 16172 16173 In_Task_Activation : Boolean; 16174 -- Save indication of whether this call is from a task body. Tasks are 16175 -- activated at the "begin", which is after all local procedure bodies, 16176 -- so calls to those procedures can't fail, even if they occur after the 16177 -- task body. 16178 16179 From_SPARK_Code : Boolean; 16180 -- Save indication of whether this call is under SPARK_Mode => On 16181 end record; 16182 16183 package Delay_Check is new Table.Table 16184 (Table_Component_Type => Delay_Element, 16185 Table_Index_Type => Int, 16186 Table_Low_Bound => 1, 16187 Table_Initial => 1000, 16188 Table_Increment => 100, 16189 Table_Name => "Delay_Check"); 16190 16191 C_Scope : Entity_Id; 16192 -- Top-level scope of current scope. Compute this only once at the outer 16193 -- level, i.e. for a call to Check_Elab_Call from outside this unit. 16194 16195 Outer_Level_Sloc : Source_Ptr; 16196 -- Save Sloc value for outer level call node for comparisons of source 16197 -- locations. A body is too late if it appears after the *outer* level 16198 -- call, not the particular call that is being analyzed. 16199 16200 From_Elab_Code : Boolean; 16201 -- This flag shows whether the outer level call currently being examined 16202 -- is or is not in elaboration code. We are only interested in calls to 16203 -- routines in other units if this flag is True. 16204 16205 In_Task_Activation : Boolean := False; 16206 -- This flag indicates whether we are performing elaboration checks on task 16207 -- bodies, at the point of activation. If true, we do not raise 16208 -- Program_Error for calls to local procedures, because all local bodies 16209 -- are known to be elaborated. However, we still need to trace such calls, 16210 -- because a local procedure could call a procedure in another package, 16211 -- so we might need an implicit Elaborate_All. 16212 16213 Delaying_Elab_Checks : Boolean := True; 16214 -- This is set True till the compilation is complete, including the 16215 -- insertion of all instance bodies. Then when Check_Elab_Calls is called, 16216 -- the delay table is used to make the delayed calls and this flag is reset 16217 -- to False, so that the calls are processed. 16218 16219 ----------------------- 16220 -- Local Subprograms -- 16221 ----------------------- 16222 16223 -- Note: Outer_Scope in all following specs represents the scope of 16224 -- interest of the outer level call. If it is set to Standard_Standard, 16225 -- then it means the outer level call was at elaboration level, and that 16226 -- thus all calls are of interest. If it was set to some other scope, 16227 -- then the original call was an inner call, and we are not interested 16228 -- in calls that go outside this scope. 16229 16230 procedure Activate_Elaborate_All_Desirable (N : Node_Id; U : Entity_Id); 16231 -- Analysis of construct N shows that we should set Elaborate_All_Desirable 16232 -- for the WITH clause for unit U (which will always be present). A special 16233 -- case is when N is a function or procedure instantiation, in which case 16234 -- it is sufficient to set Elaborate_Desirable, since in this case there is 16235 -- no possibility of transitive elaboration issues. 16236 16237 procedure Check_A_Call 16238 (N : Node_Id; 16239 E : Entity_Id; 16240 Outer_Scope : Entity_Id; 16241 Inter_Unit_Only : Boolean; 16242 Generate_Warnings : Boolean := True; 16243 In_Init_Proc : Boolean := False); 16244 -- This is the internal recursive routine that is called to check for 16245 -- possible elaboration error. The argument N is a subprogram call or 16246 -- generic instantiation, or 'Access attribute reference to be checked, and 16247 -- E is the entity of the called subprogram, or instantiated generic unit, 16248 -- or subprogram referenced by 'Access. 16249 -- 16250 -- In SPARK mode, N can also be a variable reference, since in SPARK this 16251 -- also triggers a requirement for Elaborate_All, and in this case E is the 16252 -- entity being referenced. 16253 -- 16254 -- Outer_Scope is the outer level scope for the original reference. 16255 -- Inter_Unit_Only is set if the call is only to be checked in the 16256 -- case where it is to another unit (and skipped if within a unit). 16257 -- Generate_Warnings is set to False to suppress warning messages about 16258 -- missing pragma Elaborate_All's. These messages are not wanted for 16259 -- inner calls in the dynamic model. Note that an instance of the Access 16260 -- attribute applied to a subprogram also generates a call to this 16261 -- procedure (since the referenced subprogram may be called later 16262 -- indirectly). Flag In_Init_Proc should be set whenever the current 16263 -- context is a type init proc. 16264 -- 16265 -- Note: this might better be called Check_A_Reference to recognize the 16266 -- variable case for SPARK, but we prefer to retain the historical name 16267 -- since in practice this is mostly about checking calls for the possible 16268 -- occurrence of an access-before-elaboration exception. 16269 16270 procedure Check_Bad_Instantiation (N : Node_Id); 16271 -- N is a node for an instantiation (if called with any other node kind, 16272 -- Check_Bad_Instantiation ignores the call). This subprogram checks for 16273 -- the special case of a generic instantiation of a generic spec in the 16274 -- same declarative part as the instantiation where a body is present and 16275 -- has not yet been seen. This is an obvious error, but needs to be checked 16276 -- specially at the time of the instantiation, since it is a case where we 16277 -- cannot insert the body anywhere. If this case is detected, warnings are 16278 -- generated, and a raise of Program_Error is inserted. In addition any 16279 -- subprograms in the generic spec are stubbed, and the Bad_Instantiation 16280 -- flag is set on the instantiation node. The caller in Sem_Ch12 uses this 16281 -- flag as an indication that no attempt should be made to insert an 16282 -- instance body. 16283 16284 procedure Check_Internal_Call 16285 (N : Node_Id; 16286 E : Entity_Id; 16287 Outer_Scope : Entity_Id; 16288 Orig_Ent : Entity_Id); 16289 -- N is a function call or procedure statement call node and E is the 16290 -- entity of the called function, which is within the current compilation 16291 -- unit (where subunits count as part of the parent). This call checks if 16292 -- this call, or any call within any accessed body could cause an ABE, and 16293 -- if so, outputs a warning. Orig_Ent differs from E only in the case of 16294 -- renamings, and points to the original name of the entity. This is used 16295 -- for error messages. Outer_Scope is the outer level scope for the 16296 -- original call. 16297 16298 procedure Check_Internal_Call_Continue 16299 (N : Node_Id; 16300 E : Entity_Id; 16301 Outer_Scope : Entity_Id; 16302 Orig_Ent : Entity_Id); 16303 -- The processing for Check_Internal_Call is divided up into two phases, 16304 -- and this represents the second phase. The second phase is delayed if 16305 -- Delaying_Elab_Checks is set to True. In this delayed case, the first 16306 -- phase makes an entry in the Delay_Check table, which is processed when 16307 -- Check_Elab_Calls is called. N, E and Orig_Ent are as for the call to 16308 -- Check_Internal_Call. Outer_Scope is the outer level scope for the 16309 -- original call. 16310 16311 function Get_Referenced_Ent (N : Node_Id) return Entity_Id; 16312 -- N is either a function or procedure call or an access attribute that 16313 -- references a subprogram. This call retrieves the relevant entity. If 16314 -- this is a call to a protected subprogram, the entity is a selected 16315 -- component. The callable entity may be absent, in which case Empty is 16316 -- returned. This happens with non-analyzed calls in nested generics. 16317 -- 16318 -- If SPARK_Mode is On, then N can also be a reference to an E_Variable 16319 -- entity, in which case, the value returned is simply this entity. 16320 16321 function Has_Generic_Body (N : Node_Id) return Boolean; 16322 -- N is a generic package instantiation node, and this routine determines 16323 -- if this package spec does in fact have a generic body. If so, then 16324 -- True is returned, otherwise False. Note that this is not at all the 16325 -- same as checking if the unit requires a body, since it deals with 16326 -- the case of optional bodies accurately (i.e. if a body is optional, 16327 -- then it looks to see if a body is actually present). Note: this 16328 -- function can only do a fully correct job if in generating code mode 16329 -- where all bodies have to be present. If we are operating in semantics 16330 -- check only mode, then in some cases of optional bodies, a result of 16331 -- False may incorrectly be given. In practice this simply means that 16332 -- some cases of warnings for incorrect order of elaboration will only 16333 -- be given when generating code, which is not a big problem (and is 16334 -- inevitable, given the optional body semantics of Ada). 16335 16336 procedure Insert_Elab_Check (N : Node_Id; C : Node_Id := Empty); 16337 -- Given code for an elaboration check (or unconditional raise if the check 16338 -- is not needed), inserts the code in the appropriate place. N is the call 16339 -- or instantiation node for which the check code is required. C is the 16340 -- test whose failure triggers the raise. 16341 16342 function Is_Call_Of_Generic_Formal (N : Node_Id) return Boolean; 16343 -- Returns True if node N is a call to a generic formal subprogram 16344 16345 function Is_Finalization_Procedure (Id : Entity_Id) return Boolean; 16346 -- Determine whether entity Id denotes a [Deep_]Finalize procedure 16347 16348 procedure Output_Calls 16349 (N : Node_Id; 16350 Check_Elab_Flag : Boolean); 16351 -- Outputs chain of calls stored in the Elab_Call table. The caller has 16352 -- already generated the main warning message, so the warnings generated 16353 -- are all continuation messages. The argument is the call node at which 16354 -- the messages are to be placed. When Check_Elab_Flag is set, calls are 16355 -- enumerated only when flag Elab_Warning is set for the dynamic case or 16356 -- when flag Elab_Info_Messages is set for the static case. 16357 16358 function Same_Elaboration_Scope (Scop1, Scop2 : Entity_Id) return Boolean; 16359 -- Given two scopes, determine whether they are the same scope from an 16360 -- elaboration point of view, i.e. packages and blocks are ignored. 16361 16362 procedure Set_C_Scope; 16363 -- On entry C_Scope is set to some scope. On return, C_Scope is reset 16364 -- to be the enclosing compilation unit of this scope. 16365 16366 procedure Set_Elaboration_Constraint 16367 (Call : Node_Id; 16368 Subp : Entity_Id; 16369 Scop : Entity_Id); 16370 -- The current unit U may depend semantically on some unit P that is not 16371 -- in the current context. If there is an elaboration call that reaches P, 16372 -- we need to indicate that P requires an Elaborate_All, but this is not 16373 -- effective in U's ali file, if there is no with_clause for P. In this 16374 -- case we add the Elaborate_All on the unit Q that directly or indirectly 16375 -- makes P available. This can happen in two cases: 16376 -- 16377 -- a) Q declares a subtype of a type declared in P, and the call is an 16378 -- initialization call for an object of that subtype. 16379 -- 16380 -- b) Q declares an object of some tagged type whose root type is 16381 -- declared in P, and the initialization call uses object notation on 16382 -- that object to reach a primitive operation or a classwide operation 16383 -- declared in P. 16384 -- 16385 -- If P appears in the context of U, the current processing is correct. 16386 -- Otherwise we must identify these two cases to retrieve Q and place the 16387 -- Elaborate_All_Desirable on it. 16388 16389 function Spec_Entity (E : Entity_Id) return Entity_Id; 16390 -- Given a compilation unit entity, if it is a spec entity, it is returned 16391 -- unchanged. If it is a body entity, then the spec for the corresponding 16392 -- spec is returned 16393 16394 function Within (E1, E2 : Entity_Id) return Boolean; 16395 -- Given two scopes E1 and E2, returns True if E1 is equal to E2, or is one 16396 -- of its contained scopes, False otherwise. 16397 16398 function Within_Elaborate_All 16399 (Unit : Unit_Number_Type; 16400 E : Entity_Id) return Boolean; 16401 -- Return True if we are within the scope of an Elaborate_All for E, or if 16402 -- we are within the scope of an Elaborate_All for some other unit U, and U 16403 -- with's E. This prevents spurious warnings when the called entity is 16404 -- renamed within U, or in case of generic instances. 16405 16406 -------------------------------------- 16407 -- Activate_Elaborate_All_Desirable -- 16408 -------------------------------------- 16409 16410 procedure Activate_Elaborate_All_Desirable (N : Node_Id; U : Entity_Id) is 16411 UN : constant Unit_Number_Type := Get_Code_Unit (N); 16412 CU : constant Node_Id := Cunit (UN); 16413 UE : constant Entity_Id := Cunit_Entity (UN); 16414 Unm : constant Unit_Name_Type := Unit_Name (UN); 16415 CI : constant List_Id := Context_Items (CU); 16416 Itm : Node_Id; 16417 Ent : Entity_Id; 16418 16419 procedure Add_To_Context_And_Mark (Itm : Node_Id); 16420 -- This procedure is called when the elaborate indication must be 16421 -- applied to a unit not in the context of the referencing unit. The 16422 -- unit gets added to the context as an implicit with. 16423 16424 function In_Withs_Of (UEs : Entity_Id) return Boolean; 16425 -- UEs is the spec entity of a unit. If the unit to be marked is 16426 -- in the context item list of this unit spec, then the call returns 16427 -- True and Itm is left set to point to the relevant N_With_Clause node. 16428 16429 procedure Set_Elab_Flag (Itm : Node_Id); 16430 -- Sets Elaborate_[All_]Desirable as appropriate on Itm 16431 16432 ----------------------------- 16433 -- Add_To_Context_And_Mark -- 16434 ----------------------------- 16435 16436 procedure Add_To_Context_And_Mark (Itm : Node_Id) is 16437 CW : constant Node_Id := 16438 Make_With_Clause (Sloc (Itm), 16439 Name => Name (Itm)); 16440 16441 begin 16442 Set_Library_Unit (CW, Library_Unit (Itm)); 16443 Set_Implicit_With (CW); 16444 16445 -- Set elaborate all desirable on copy and then append the copy to 16446 -- the list of body with's and we are done. 16447 16448 Set_Elab_Flag (CW); 16449 Append_To (CI, CW); 16450 end Add_To_Context_And_Mark; 16451 16452 ----------------- 16453 -- In_Withs_Of -- 16454 ----------------- 16455 16456 function In_Withs_Of (UEs : Entity_Id) return Boolean is 16457 UNs : constant Unit_Number_Type := Get_Source_Unit (UEs); 16458 CUs : constant Node_Id := Cunit (UNs); 16459 CIs : constant List_Id := Context_Items (CUs); 16460 16461 begin 16462 Itm := First (CIs); 16463 while Present (Itm) loop 16464 if Nkind (Itm) = N_With_Clause then 16465 Ent := 16466 Cunit_Entity (Get_Cunit_Unit_Number (Library_Unit (Itm))); 16467 16468 if U = Ent then 16469 return True; 16470 end if; 16471 end if; 16472 16473 Next (Itm); 16474 end loop; 16475 16476 return False; 16477 end In_Withs_Of; 16478 16479 ------------------- 16480 -- Set_Elab_Flag -- 16481 ------------------- 16482 16483 procedure Set_Elab_Flag (Itm : Node_Id) is 16484 begin 16485 if Nkind (N) in N_Subprogram_Instantiation then 16486 Set_Elaborate_Desirable (Itm); 16487 else 16488 Set_Elaborate_All_Desirable (Itm); 16489 end if; 16490 end Set_Elab_Flag; 16491 16492 -- Start of processing for Activate_Elaborate_All_Desirable 16493 16494 begin 16495 -- Do not set binder indication if expansion is disabled, as when 16496 -- compiling a generic unit. 16497 16498 if not Expander_Active then 16499 return; 16500 end if; 16501 16502 -- If an instance of a generic package contains a controlled object (so 16503 -- we're calling Initialize at elaboration time), and the instance is in 16504 -- a package body P that says "with P;", then we need to return without 16505 -- adding "pragma Elaborate_All (P);" to P. 16506 16507 if U = Main_Unit_Entity then 16508 return; 16509 end if; 16510 16511 Itm := First (CI); 16512 while Present (Itm) loop 16513 if Nkind (Itm) = N_With_Clause then 16514 Ent := Cunit_Entity (Get_Cunit_Unit_Number (Library_Unit (Itm))); 16515 16516 -- If we find it, then mark elaborate all desirable and return 16517 16518 if U = Ent then 16519 Set_Elab_Flag (Itm); 16520 return; 16521 end if; 16522 end if; 16523 16524 Next (Itm); 16525 end loop; 16526 16527 -- If we fall through then the with clause is not present in the 16528 -- current unit. One legitimate possibility is that the with clause 16529 -- is present in the spec when we are a body. 16530 16531 if Is_Body_Name (Unm) 16532 and then In_Withs_Of (Spec_Entity (UE)) 16533 then 16534 Add_To_Context_And_Mark (Itm); 16535 return; 16536 end if; 16537 16538 -- Similarly, we may be in the spec or body of a child unit, where 16539 -- the unit in question is with'ed by some ancestor of the child unit. 16540 16541 if Is_Child_Name (Unm) then 16542 declare 16543 Pkg : Entity_Id; 16544 16545 begin 16546 Pkg := UE; 16547 loop 16548 Pkg := Scope (Pkg); 16549 exit when Pkg = Standard_Standard; 16550 16551 if In_Withs_Of (Pkg) then 16552 Add_To_Context_And_Mark (Itm); 16553 return; 16554 end if; 16555 end loop; 16556 end; 16557 end if; 16558 16559 -- Here if we do not find with clause on spec or body. We just ignore 16560 -- this case; it means that the elaboration involves some other unit 16561 -- than the unit being compiled, and will be caught elsewhere. 16562 end Activate_Elaborate_All_Desirable; 16563 16564 ------------------ 16565 -- Check_A_Call -- 16566 ------------------ 16567 16568 procedure Check_A_Call 16569 (N : Node_Id; 16570 E : Entity_Id; 16571 Outer_Scope : Entity_Id; 16572 Inter_Unit_Only : Boolean; 16573 Generate_Warnings : Boolean := True; 16574 In_Init_Proc : Boolean := False) 16575 is 16576 Access_Case : constant Boolean := Nkind (N) = N_Attribute_Reference; 16577 -- Indicates if we have Access attribute case 16578 16579 function Call_To_Instance_From_Outside (Id : Entity_Id) return Boolean; 16580 -- True if we're calling an instance of a generic subprogram, or a 16581 -- subprogram in an instance of a generic package, and the call is 16582 -- outside that instance. 16583 16584 procedure Elab_Warning 16585 (Msg_D : String; 16586 Msg_S : String; 16587 Ent : Node_Or_Entity_Id); 16588 -- Generate a call to Error_Msg_NE with parameters Msg_D or Msg_S (for 16589 -- dynamic or static elaboration model), N and Ent. Msg_D is a real 16590 -- warning (output if Msg_D is non-null and Elab_Warnings is set), 16591 -- Msg_S is an info message (output if Elab_Info_Messages is set). 16592 16593 function Find_W_Scope return Entity_Id; 16594 -- Find top-level scope for called entity (not following renamings 16595 -- or derivations). This is where the Elaborate_All will go if it is 16596 -- needed. We start with the called entity, except in the case of an 16597 -- initialization procedure outside the current package, where the init 16598 -- proc is in the root package, and we start from the entity of the name 16599 -- in the call. 16600 16601 ----------------------------------- 16602 -- Call_To_Instance_From_Outside -- 16603 ----------------------------------- 16604 16605 function Call_To_Instance_From_Outside (Id : Entity_Id) return Boolean is 16606 Scop : Entity_Id := Id; 16607 16608 begin 16609 loop 16610 if Scop = Standard_Standard then 16611 return False; 16612 end if; 16613 16614 if Is_Generic_Instance (Scop) then 16615 return not In_Open_Scopes (Scop); 16616 end if; 16617 16618 Scop := Scope (Scop); 16619 end loop; 16620 end Call_To_Instance_From_Outside; 16621 16622 ------------------ 16623 -- Elab_Warning -- 16624 ------------------ 16625 16626 procedure Elab_Warning 16627 (Msg_D : String; 16628 Msg_S : String; 16629 Ent : Node_Or_Entity_Id) 16630 is 16631 begin 16632 -- Dynamic elaboration checks, real warning 16633 16634 if Dynamic_Elaboration_Checks then 16635 if not Access_Case then 16636 if Msg_D /= "" and then Elab_Warnings then 16637 Error_Msg_NE (Msg_D, N, Ent); 16638 end if; 16639 16640 -- In the access case emit first warning message as well, 16641 -- otherwise list of calls will appear as errors. 16642 16643 elsif Elab_Warnings then 16644 Error_Msg_NE (Msg_S, N, Ent); 16645 end if; 16646 16647 -- Static elaboration checks, info message 16648 16649 else 16650 if Elab_Info_Messages then 16651 Error_Msg_NE (Msg_S, N, Ent); 16652 end if; 16653 end if; 16654 end Elab_Warning; 16655 16656 ------------------ 16657 -- Find_W_Scope -- 16658 ------------------ 16659 16660 function Find_W_Scope return Entity_Id is 16661 Refed_Ent : constant Entity_Id := Get_Referenced_Ent (N); 16662 W_Scope : Entity_Id; 16663 16664 begin 16665 if Is_Init_Proc (Refed_Ent) 16666 and then not In_Same_Extended_Unit (N, Refed_Ent) 16667 then 16668 W_Scope := Scope (Refed_Ent); 16669 else 16670 W_Scope := E; 16671 end if; 16672 16673 -- Now loop through scopes to get to the enclosing compilation unit 16674 16675 while not Is_Compilation_Unit (W_Scope) loop 16676 W_Scope := Scope (W_Scope); 16677 end loop; 16678 16679 return W_Scope; 16680 end Find_W_Scope; 16681 16682 -- Local variables 16683 16684 Inst_Case : constant Boolean := Nkind (N) in N_Generic_Instantiation; 16685 -- Indicates if we have instantiation case 16686 16687 Loc : constant Source_Ptr := Sloc (N); 16688 16689 Variable_Case : constant Boolean := 16690 Nkind (N) in N_Has_Entity 16691 and then Present (Entity (N)) 16692 and then Ekind (Entity (N)) = E_Variable; 16693 -- Indicates if we have variable reference case 16694 16695 W_Scope : constant Entity_Id := Find_W_Scope; 16696 -- Top-level scope of directly called entity for subprogram. This 16697 -- differs from E_Scope in the case where renamings or derivations 16698 -- are involved, since it does not follow these links. W_Scope is 16699 -- generally in a visible unit, and it is this scope that may require 16700 -- an Elaborate_All. However, there are some cases (initialization 16701 -- calls and calls involving object notation) where W_Scope might not 16702 -- be in the context of the current unit, and there is an intermediate 16703 -- package that is, in which case the Elaborate_All has to be placed 16704 -- on this intermediate package. These special cases are handled in 16705 -- Set_Elaboration_Constraint. 16706 16707 Ent : Entity_Id; 16708 Callee_Unit_Internal : Boolean; 16709 Caller_Unit_Internal : Boolean; 16710 Decl : Node_Id; 16711 Inst_Callee : Source_Ptr; 16712 Inst_Caller : Source_Ptr; 16713 Unit_Callee : Unit_Number_Type; 16714 Unit_Caller : Unit_Number_Type; 16715 16716 Body_Acts_As_Spec : Boolean; 16717 -- Set to true if call is to body acting as spec (no separate spec) 16718 16719 Cunit_SC : Boolean := False; 16720 -- Set to suppress dynamic elaboration checks where one of the 16721 -- enclosing scopes has Elaboration_Checks_Suppressed set, or else 16722 -- if a pragma Elaborate[_All] applies to that scope, in which case 16723 -- warnings on the scope are also suppressed. For the internal case, 16724 -- we ignore this flag. 16725 16726 E_Scope : Entity_Id; 16727 -- Top-level scope of entity for called subprogram. This value includes 16728 -- following renamings and derivations, so this scope can be in a 16729 -- non-visible unit. This is the scope that is to be investigated to 16730 -- see whether an elaboration check is required. 16731 16732 Is_DIC : Boolean; 16733 -- Flag set when the subprogram being invoked is the procedure generated 16734 -- for pragma Default_Initial_Condition. 16735 16736 SPARK_Elab_Errors : Boolean; 16737 -- Flag set when an entity is called or a variable is read during SPARK 16738 -- dynamic elaboration. 16739 16740 -- Start of processing for Check_A_Call 16741 16742 begin 16743 -- If the call is known to be within a local Suppress Elaboration 16744 -- pragma, nothing to check. This can happen in task bodies. But 16745 -- we ignore this for a call to a generic formal. 16746 16747 if Nkind (N) in N_Subprogram_Call 16748 and then No_Elaboration_Check (N) 16749 and then not Is_Call_Of_Generic_Formal (N) 16750 then 16751 return; 16752 16753 -- If this is a rewrite of a Valid_Scalars attribute, then nothing to 16754 -- check, we don't mind in this case if the call occurs before the body 16755 -- since this is all generated code. 16756 16757 elsif Nkind (Original_Node (N)) = N_Attribute_Reference 16758 and then Attribute_Name (Original_Node (N)) = Name_Valid_Scalars 16759 then 16760 return; 16761 16762 -- Intrinsics such as instances of Unchecked_Deallocation do not have 16763 -- any body, so elaboration checking is not needed, and would be wrong. 16764 16765 elsif Is_Intrinsic_Subprogram (E) then 16766 return; 16767 16768 -- Do not consider references to internal variables for SPARK semantics 16769 16770 elsif Variable_Case and then not Comes_From_Source (E) then 16771 return; 16772 end if; 16773 16774 -- Proceed with check 16775 16776 Ent := E; 16777 16778 -- For a variable reference, just set Body_Acts_As_Spec to False 16779 16780 if Variable_Case then 16781 Body_Acts_As_Spec := False; 16782 16783 -- Additional checks for all other cases 16784 16785 else 16786 -- Go to parent for derived subprogram, or to original subprogram in 16787 -- the case of a renaming (Alias covers both these cases). 16788 16789 loop 16790 if (Suppress_Elaboration_Warnings (Ent) 16791 or else Elaboration_Checks_Suppressed (Ent)) 16792 and then (Inst_Case or else No (Alias (Ent))) 16793 then 16794 return; 16795 end if; 16796 16797 -- Nothing to do for imported entities 16798 16799 if Is_Imported (Ent) then 16800 return; 16801 end if; 16802 16803 exit when Inst_Case or else No (Alias (Ent)); 16804 Ent := Alias (Ent); 16805 end loop; 16806 16807 Decl := Unit_Declaration_Node (Ent); 16808 16809 if Nkind (Decl) = N_Subprogram_Body then 16810 Body_Acts_As_Spec := True; 16811 16812 elsif Nkind_In (Decl, N_Subprogram_Declaration, 16813 N_Subprogram_Body_Stub) 16814 or else Inst_Case 16815 then 16816 Body_Acts_As_Spec := False; 16817 16818 -- If we have none of an instantiation, subprogram body or subprogram 16819 -- declaration, or in the SPARK case, a variable reference, then 16820 -- it is not a case that we want to check. (One case is a call to a 16821 -- generic formal subprogram, where we do not want the check in the 16822 -- template). 16823 16824 else 16825 return; 16826 end if; 16827 end if; 16828 16829 E_Scope := Ent; 16830 loop 16831 if Elaboration_Checks_Suppressed (E_Scope) 16832 or else Suppress_Elaboration_Warnings (E_Scope) 16833 then 16834 Cunit_SC := True; 16835 end if; 16836 16837 -- Exit when we get to compilation unit, not counting subunits 16838 16839 exit when Is_Compilation_Unit (E_Scope) 16840 and then (Is_Child_Unit (E_Scope) 16841 or else Scope (E_Scope) = Standard_Standard); 16842 16843 pragma Assert (E_Scope /= Standard_Standard); 16844 16845 -- Move up a scope looking for compilation unit 16846 16847 E_Scope := Scope (E_Scope); 16848 end loop; 16849 16850 -- No checks needed for pure or preelaborated compilation units 16851 16852 if Is_Pure (E_Scope) or else Is_Preelaborated (E_Scope) then 16853 return; 16854 end if; 16855 16856 -- If the generic entity is within a deeper instance than we are, then 16857 -- either the instantiation to which we refer itself caused an ABE, in 16858 -- which case that will be handled separately, or else we know that the 16859 -- body we need appears as needed at the point of the instantiation. 16860 -- However, this assumption is only valid if we are in static mode. 16861 16862 if not Dynamic_Elaboration_Checks 16863 and then 16864 Instantiation_Depth (Sloc (Ent)) > Instantiation_Depth (Sloc (N)) 16865 then 16866 return; 16867 end if; 16868 16869 -- Do not give a warning for a package with no body 16870 16871 if Ekind (Ent) = E_Generic_Package and then not Has_Generic_Body (N) then 16872 return; 16873 end if; 16874 16875 -- Case of entity is in same unit as call or instantiation. In the 16876 -- instantiation case, W_Scope may be different from E_Scope; we want 16877 -- the unit in which the instantiation occurs, since we're analyzing 16878 -- based on the expansion. 16879 16880 if W_Scope = C_Scope then 16881 if not Inter_Unit_Only then 16882 Check_Internal_Call (N, Ent, Outer_Scope, E); 16883 end if; 16884 16885 return; 16886 end if; 16887 16888 -- Case of entity is not in current unit (i.e. with'ed unit case) 16889 16890 -- We are only interested in such calls if the outer call was from 16891 -- elaboration code, or if we are in Dynamic_Elaboration_Checks mode. 16892 16893 if not From_Elab_Code and then not Dynamic_Elaboration_Checks then 16894 return; 16895 end if; 16896 16897 -- Nothing to do if some scope said that no checks were required 16898 16899 if Cunit_SC then 16900 return; 16901 end if; 16902 16903 -- Nothing to do for a generic instance, because a call to an instance 16904 -- cannot fail the elaboration check, because the body of the instance 16905 -- is always elaborated immediately after the spec. 16906 16907 if Call_To_Instance_From_Outside (Ent) then 16908 return; 16909 end if; 16910 16911 -- Nothing to do if subprogram with no separate spec. However, a call 16912 -- to Deep_Initialize may result in a call to a user-defined Initialize 16913 -- procedure, which imposes a body dependency. This happens only if the 16914 -- type is controlled and the Initialize procedure is not inherited. 16915 16916 if Body_Acts_As_Spec then 16917 if Is_TSS (Ent, TSS_Deep_Initialize) then 16918 declare 16919 Typ : constant Entity_Id := Etype (First_Formal (Ent)); 16920 Init : Entity_Id; 16921 16922 begin 16923 if not Is_Controlled (Typ) then 16924 return; 16925 else 16926 Init := Find_Prim_Op (Typ, Name_Initialize); 16927 16928 if Comes_From_Source (Init) then 16929 Ent := Init; 16930 else 16931 return; 16932 end if; 16933 end if; 16934 end; 16935 16936 else 16937 return; 16938 end if; 16939 end if; 16940 16941 -- Check cases of internal units 16942 16943 Callee_Unit_Internal := In_Internal_Unit (E_Scope); 16944 16945 -- Do not give a warning if the with'ed unit is internal and this is 16946 -- the generic instantiation case (this saves a lot of hassle dealing 16947 -- with the Text_IO special child units) 16948 16949 if Callee_Unit_Internal and Inst_Case then 16950 return; 16951 end if; 16952 16953 if C_Scope = Standard_Standard then 16954 Caller_Unit_Internal := False; 16955 else 16956 Caller_Unit_Internal := In_Internal_Unit (C_Scope); 16957 end if; 16958 16959 -- Do not give a warning if the with'ed unit is internal and the caller 16960 -- is not internal (since the binder always elaborates internal units 16961 -- first). 16962 16963 if Callee_Unit_Internal and not Caller_Unit_Internal then 16964 return; 16965 end if; 16966 16967 -- For now, if debug flag -gnatdE is not set, do no checking for one 16968 -- internal unit withing another. This fixes the problem with the sgi 16969 -- build and storage errors. To be resolved later ??? 16970 16971 if (Callee_Unit_Internal and Caller_Unit_Internal) 16972 and not Debug_Flag_EE 16973 then 16974 return; 16975 end if; 16976 16977 if Is_TSS (E, TSS_Deep_Initialize) then 16978 Ent := E; 16979 end if; 16980 16981 -- If the call is in an instance, and the called entity is not 16982 -- defined in the same instance, then the elaboration issue focuses 16983 -- around the unit containing the template, it is this unit that 16984 -- requires an Elaborate_All. 16985 16986 -- However, if we are doing dynamic elaboration, we need to chase the 16987 -- call in the usual manner. 16988 16989 -- We also need to chase the call in the usual manner if it is a call 16990 -- to a generic formal parameter, since that case was not handled as 16991 -- part of the processing of the template. 16992 16993 Inst_Caller := Instantiation (Get_Source_File_Index (Sloc (N))); 16994 Inst_Callee := Instantiation (Get_Source_File_Index (Sloc (Ent))); 16995 16996 if Inst_Caller = No_Location then 16997 Unit_Caller := No_Unit; 16998 else 16999 Unit_Caller := Get_Source_Unit (N); 17000 end if; 17001 17002 if Inst_Callee = No_Location then 17003 Unit_Callee := No_Unit; 17004 else 17005 Unit_Callee := Get_Source_Unit (Ent); 17006 end if; 17007 17008 if Unit_Caller /= No_Unit 17009 and then Unit_Callee /= Unit_Caller 17010 and then not Dynamic_Elaboration_Checks 17011 and then not Is_Call_Of_Generic_Formal (N) 17012 then 17013 E_Scope := Spec_Entity (Cunit_Entity (Unit_Caller)); 17014 17015 -- If we don't get a spec entity, just ignore call. Not quite 17016 -- clear why this check is necessary. ??? 17017 17018 if No (E_Scope) then 17019 return; 17020 end if; 17021 17022 -- Otherwise step to enclosing compilation unit 17023 17024 while not Is_Compilation_Unit (E_Scope) loop 17025 E_Scope := Scope (E_Scope); 17026 end loop; 17027 17028 -- For the case where N is not an instance, and is not a call within 17029 -- instance to other than a generic formal, we recompute E_Scope 17030 -- for the error message, since we do NOT want to go to the unit 17031 -- that has the ultimate declaration in the case of renaming and 17032 -- derivation and we also want to go to the generic unit in the 17033 -- case of an instance, and no further. 17034 17035 else 17036 -- Loop to carefully follow renamings and derivations one step 17037 -- outside the current unit, but not further. 17038 17039 if not (Inst_Case or Variable_Case) 17040 and then Present (Alias (Ent)) 17041 then 17042 E_Scope := Alias (Ent); 17043 else 17044 E_Scope := Ent; 17045 end if; 17046 17047 loop 17048 while not Is_Compilation_Unit (E_Scope) loop 17049 E_Scope := Scope (E_Scope); 17050 end loop; 17051 17052 -- If E_Scope is the same as C_Scope, it means that there 17053 -- definitely was a local renaming or derivation, and we 17054 -- are not yet out of the current unit. 17055 17056 exit when E_Scope /= C_Scope; 17057 Ent := Alias (Ent); 17058 E_Scope := Ent; 17059 17060 -- If no alias, there could be a previous error, but not if we've 17061 -- already reached the outermost level (Standard). 17062 17063 if No (Ent) then 17064 return; 17065 end if; 17066 end loop; 17067 end if; 17068 17069 if Within_Elaborate_All (Current_Sem_Unit, E_Scope) then 17070 return; 17071 end if; 17072 17073 -- Determine whether the Default_Initial_Condition procedure of some 17074 -- type is being invoked. 17075 17076 Is_DIC := Ekind (Ent) = E_Procedure and then Is_DIC_Procedure (Ent); 17077 17078 -- Checks related to Default_Initial_Condition fall under the SPARK 17079 -- umbrella because this is a SPARK-specific annotation. 17080 17081 SPARK_Elab_Errors := 17082 SPARK_Mode = On and (Is_DIC or Dynamic_Elaboration_Checks); 17083 17084 -- Now check if an Elaborate_All (or dynamic check) is needed 17085 17086 if (Elab_Info_Messages or Elab_Warnings or SPARK_Elab_Errors) 17087 and then Generate_Warnings 17088 and then not Suppress_Elaboration_Warnings (Ent) 17089 and then not Elaboration_Checks_Suppressed (Ent) 17090 and then not Suppress_Elaboration_Warnings (E_Scope) 17091 and then not Elaboration_Checks_Suppressed (E_Scope) 17092 then 17093 -- Instantiation case 17094 17095 if Inst_Case then 17096 if Comes_From_Source (Ent) and then SPARK_Elab_Errors then 17097 Error_Msg_NE 17098 ("instantiation of & during elaboration in SPARK", N, Ent); 17099 else 17100 Elab_Warning 17101 ("instantiation of & may raise Program_Error?l?", 17102 "info: instantiation of & during elaboration?$?", Ent); 17103 end if; 17104 17105 -- Indirect call case, info message only in static elaboration 17106 -- case, because the attribute reference itself cannot raise an 17107 -- exception. Note that SPARK does not permit indirect calls. 17108 17109 elsif Access_Case then 17110 Elab_Warning ("", "info: access to & during elaboration?$?", Ent); 17111 17112 -- Variable reference in SPARK mode 17113 17114 elsif Variable_Case then 17115 if Comes_From_Source (Ent) and then SPARK_Elab_Errors then 17116 Error_Msg_NE 17117 ("reference to & during elaboration in SPARK", N, Ent); 17118 end if; 17119 17120 -- Subprogram call case 17121 17122 else 17123 if Nkind (Name (N)) in N_Has_Entity 17124 and then Is_Init_Proc (Entity (Name (N))) 17125 and then Comes_From_Source (Ent) 17126 then 17127 Elab_Warning 17128 ("implicit call to & may raise Program_Error?l?", 17129 "info: implicit call to & during elaboration?$?", 17130 Ent); 17131 17132 elsif SPARK_Elab_Errors then 17133 17134 -- Emit a specialized error message when the elaboration of an 17135 -- object of a private type evaluates the expression of pragma 17136 -- Default_Initial_Condition. This prevents the internal name 17137 -- of the procedure from appearing in the error message. 17138 17139 if Is_DIC then 17140 Error_Msg_N 17141 ("call to Default_Initial_Condition during elaboration in " 17142 & "SPARK", N); 17143 else 17144 Error_Msg_NE 17145 ("call to & during elaboration in SPARK", N, Ent); 17146 end if; 17147 17148 else 17149 Elab_Warning 17150 ("call to & may raise Program_Error?l?", 17151 "info: call to & during elaboration?$?", 17152 Ent); 17153 end if; 17154 end if; 17155 17156 Error_Msg_Qual_Level := Nat'Last; 17157 17158 -- Case of Elaborate_All not present and required, for SPARK this 17159 -- is an error, so give an error message. 17160 17161 if SPARK_Elab_Errors then 17162 Error_Msg_NE -- CODEFIX 17163 ("\Elaborate_All pragma required for&", N, W_Scope); 17164 17165 -- Otherwise we generate an implicit pragma. For a subprogram 17166 -- instantiation, Elaborate is good enough, since no transitive 17167 -- call is possible at elaboration time in this case. 17168 17169 elsif Nkind (N) in N_Subprogram_Instantiation then 17170 Elab_Warning 17171 ("\missing pragma Elaborate for&?l?", 17172 "\implicit pragma Elaborate for& generated?$?", 17173 W_Scope); 17174 17175 -- For all other cases, we need an implicit Elaborate_All 17176 17177 else 17178 Elab_Warning 17179 ("\missing pragma Elaborate_All for&?l?", 17180 "\implicit pragma Elaborate_All for & generated?$?", 17181 W_Scope); 17182 end if; 17183 17184 Error_Msg_Qual_Level := 0; 17185 17186 -- Take into account the flags related to elaboration warning 17187 -- messages when enumerating the various calls involved. This 17188 -- ensures the proper pairing of the main warning and the 17189 -- clarification messages generated by Output_Calls. 17190 17191 Output_Calls (N, Check_Elab_Flag => True); 17192 17193 -- Set flag to prevent further warnings for same unit unless in 17194 -- All_Errors_Mode. 17195 17196 if not All_Errors_Mode and not Dynamic_Elaboration_Checks then 17197 Set_Suppress_Elaboration_Warnings (W_Scope); 17198 end if; 17199 end if; 17200 17201 -- Check for runtime elaboration check required 17202 17203 if Dynamic_Elaboration_Checks then 17204 if not Elaboration_Checks_Suppressed (Ent) 17205 and then not Elaboration_Checks_Suppressed (W_Scope) 17206 and then not Elaboration_Checks_Suppressed (E_Scope) 17207 and then not Cunit_SC 17208 then 17209 -- Runtime elaboration check required. Generate check of the 17210 -- elaboration Boolean for the unit containing the entity. 17211 17212 -- Note that for this case, we do check the real unit (the one 17213 -- from following renamings, since that is the issue). 17214 17215 -- Could this possibly miss a useless but required PE??? 17216 17217 Insert_Elab_Check (N, 17218 Make_Attribute_Reference (Loc, 17219 Attribute_Name => Name_Elaborated, 17220 Prefix => 17221 New_Occurrence_Of (Spec_Entity (E_Scope), Loc))); 17222 17223 -- Prevent duplicate elaboration checks on the same call, which 17224 -- can happen if the body enclosing the call appears itself in a 17225 -- call whose elaboration check is delayed. 17226 17227 if Nkind (N) in N_Subprogram_Call then 17228 Set_No_Elaboration_Check (N); 17229 end if; 17230 end if; 17231 17232 -- Case of static elaboration model 17233 17234 else 17235 -- Do not do anything if elaboration checks suppressed. Note that 17236 -- we check Ent here, not E, since we want the real entity for the 17237 -- body to see if checks are suppressed for it, not the dummy 17238 -- entry for renamings or derivations. 17239 17240 if Elaboration_Checks_Suppressed (Ent) 17241 or else Elaboration_Checks_Suppressed (E_Scope) 17242 or else Elaboration_Checks_Suppressed (W_Scope) 17243 then 17244 null; 17245 17246 -- Do not generate an Elaborate_All for finalization routines 17247 -- that perform partial clean up as part of initialization. 17248 17249 elsif In_Init_Proc and then Is_Finalization_Procedure (Ent) then 17250 null; 17251 17252 -- Here we need to generate an implicit elaborate all 17253 17254 else 17255 -- Generate Elaborate_All warning unless suppressed 17256 17257 if (Elab_Info_Messages and Generate_Warnings and not Inst_Case) 17258 and then not Suppress_Elaboration_Warnings (Ent) 17259 and then not Suppress_Elaboration_Warnings (E_Scope) 17260 and then not Suppress_Elaboration_Warnings (W_Scope) 17261 then 17262 Error_Msg_Node_2 := W_Scope; 17263 Error_Msg_NE 17264 ("info: call to& in elaboration code requires pragma " 17265 & "Elaborate_All on&?$?", N, E); 17266 end if; 17267 17268 -- Set indication for binder to generate Elaborate_All 17269 17270 Set_Elaboration_Constraint (N, E, W_Scope); 17271 end if; 17272 end if; 17273 end Check_A_Call; 17274 17275 ----------------------------- 17276 -- Check_Bad_Instantiation -- 17277 ----------------------------- 17278 17279 procedure Check_Bad_Instantiation (N : Node_Id) is 17280 Ent : Entity_Id; 17281 17282 begin 17283 -- Nothing to do if we do not have an instantiation (happens in some 17284 -- error cases, and also in the formal package declaration case) 17285 17286 if Nkind (N) not in N_Generic_Instantiation then 17287 return; 17288 17289 -- Nothing to do if serious errors detected (avoid cascaded errors) 17290 17291 elsif Serious_Errors_Detected /= 0 then 17292 return; 17293 17294 -- Nothing to do if not in full analysis mode 17295 17296 elsif not Full_Analysis then 17297 return; 17298 17299 -- Nothing to do if inside a generic template 17300 17301 elsif Inside_A_Generic then 17302 return; 17303 17304 -- Nothing to do if a library level instantiation 17305 17306 elsif Nkind (Parent (N)) = N_Compilation_Unit then 17307 return; 17308 17309 -- Nothing to do if we are compiling a proper body for semantic 17310 -- purposes only. The generic body may be in another proper body. 17311 17312 elsif 17313 Nkind (Parent (Unit_Declaration_Node (Main_Unit_Entity))) = N_Subunit 17314 then 17315 return; 17316 end if; 17317 17318 Ent := Get_Generic_Entity (N); 17319 17320 -- The case we are interested in is when the generic spec is in the 17321 -- current declarative part 17322 17323 if not Same_Elaboration_Scope (Current_Scope, Scope (Ent)) 17324 or else not In_Same_Extended_Unit (N, Ent) 17325 then 17326 return; 17327 end if; 17328 17329 -- If the generic entity is within a deeper instance than we are, then 17330 -- either the instantiation to which we refer itself caused an ABE, in 17331 -- which case that will be handled separately. Otherwise, we know that 17332 -- the body we need appears as needed at the point of the instantiation. 17333 -- If they are both at the same level but not within the same instance 17334 -- then the body of the generic will be in the earlier instance. 17335 17336 declare 17337 D1 : constant Nat := Instantiation_Depth (Sloc (Ent)); 17338 D2 : constant Nat := Instantiation_Depth (Sloc (N)); 17339 17340 begin 17341 if D1 > D2 then 17342 return; 17343 17344 elsif D1 = D2 17345 and then Is_Generic_Instance (Scope (Ent)) 17346 and then not In_Open_Scopes (Scope (Ent)) 17347 then 17348 return; 17349 end if; 17350 end; 17351 17352 -- Now we can proceed, if the entity being called has a completion, 17353 -- then we are definitely OK, since we have already seen the body. 17354 17355 if Has_Completion (Ent) then 17356 return; 17357 end if; 17358 17359 -- If there is no body, then nothing to do 17360 17361 if not Has_Generic_Body (N) then 17362 return; 17363 end if; 17364 17365 -- Here we definitely have a bad instantiation 17366 17367 Error_Msg_Warn := SPARK_Mode /= On; 17368 Error_Msg_NE ("cannot instantiate& before body seen<<", N, Ent); 17369 Error_Msg_N ("\Program_Error [<<", N); 17370 17371 Insert_Elab_Check (N); 17372 Set_Is_Known_Guaranteed_ABE (N); 17373 end Check_Bad_Instantiation; 17374 17375 --------------------- 17376 -- Check_Elab_Call -- 17377 --------------------- 17378 17379 procedure Check_Elab_Call 17380 (N : Node_Id; 17381 Outer_Scope : Entity_Id := Empty; 17382 In_Init_Proc : Boolean := False) 17383 is 17384 Ent : Entity_Id; 17385 P : Node_Id; 17386 17387 begin 17388 pragma Assert (Legacy_Elaboration_Checks); 17389 17390 -- If the reference is not in the main unit, there is nothing to check. 17391 -- Elaboration call from units in the context of the main unit will lead 17392 -- to semantic dependencies when those units are compiled. 17393 17394 if not In_Extended_Main_Code_Unit (N) then 17395 return; 17396 end if; 17397 17398 -- For an entry call, check relevant restriction 17399 17400 if Nkind (N) = N_Entry_Call_Statement 17401 and then not In_Subprogram_Or_Concurrent_Unit 17402 then 17403 Check_Restriction (No_Entry_Calls_In_Elaboration_Code, N); 17404 17405 -- Nothing to do if this is not an expected type of reference (happens 17406 -- in some error conditions, and in some cases where rewriting occurs). 17407 17408 elsif Nkind (N) not in N_Subprogram_Call 17409 and then Nkind (N) /= N_Attribute_Reference 17410 and then (SPARK_Mode /= On 17411 or else Nkind (N) not in N_Has_Entity 17412 or else No (Entity (N)) 17413 or else Ekind (Entity (N)) /= E_Variable) 17414 then 17415 return; 17416 17417 -- Nothing to do if this is a call already rewritten for elab checking. 17418 -- Such calls appear as the targets of If_Expressions. 17419 17420 -- This check MUST be wrong, it catches far too much 17421 17422 elsif Nkind (Parent (N)) = N_If_Expression then 17423 return; 17424 17425 -- Nothing to do if inside a generic template 17426 17427 elsif Inside_A_Generic 17428 and then No (Enclosing_Generic_Body (N)) 17429 then 17430 return; 17431 17432 -- Nothing to do if call is being preanalyzed, as when within a 17433 -- pre/postcondition, a predicate, or an invariant. 17434 17435 elsif In_Spec_Expression then 17436 return; 17437 end if; 17438 17439 -- Nothing to do if this is a call to a postcondition, which is always 17440 -- within a subprogram body, even though the current scope may be the 17441 -- enclosing scope of the subprogram. 17442 17443 if Nkind (N) = N_Procedure_Call_Statement 17444 and then Is_Entity_Name (Name (N)) 17445 and then Chars (Entity (Name (N))) = Name_uPostconditions 17446 then 17447 return; 17448 end if; 17449 17450 -- Here we have a reference at elaboration time that must be checked 17451 17452 if Debug_Flag_Underscore_LL then 17453 Write_Str (" Check_Elab_Ref: "); 17454 17455 if Nkind (N) = N_Attribute_Reference then 17456 if not Is_Entity_Name (Prefix (N)) then 17457 Write_Str ("<<not entity name>>"); 17458 else 17459 Write_Name (Chars (Entity (Prefix (N)))); 17460 end if; 17461 17462 Write_Str ("'Access"); 17463 17464 elsif No (Name (N)) or else not Is_Entity_Name (Name (N)) then 17465 Write_Str ("<<not entity name>> "); 17466 17467 else 17468 Write_Name (Chars (Entity (Name (N)))); 17469 end if; 17470 17471 Write_Str (" reference at "); 17472 Write_Location (Sloc (N)); 17473 Write_Eol; 17474 end if; 17475 17476 -- Climb up the tree to make sure we are not inside default expression 17477 -- of a parameter specification or a record component, since in both 17478 -- these cases, we will be doing the actual reference later, not now, 17479 -- and it is at the time of the actual reference (statically speaking) 17480 -- that we must do our static check, not at the time of its initial 17481 -- analysis). 17482 17483 -- However, we have to check references within component definitions 17484 -- (e.g. a function call that determines an array component bound), 17485 -- so we terminate the loop in that case. 17486 17487 P := Parent (N); 17488 while Present (P) loop 17489 if Nkind_In (P, N_Parameter_Specification, 17490 N_Component_Declaration) 17491 then 17492 return; 17493 17494 -- The reference occurs within the constraint of a component, 17495 -- so it must be checked. 17496 17497 elsif Nkind (P) = N_Component_Definition then 17498 exit; 17499 17500 else 17501 P := Parent (P); 17502 end if; 17503 end loop; 17504 17505 -- Stuff that happens only at the outer level 17506 17507 if No (Outer_Scope) then 17508 Elab_Visited.Set_Last (0); 17509 17510 -- Nothing to do if current scope is Standard (this is a bit odd, but 17511 -- it happens in the case of generic instantiations). 17512 17513 C_Scope := Current_Scope; 17514 17515 if C_Scope = Standard_Standard then 17516 return; 17517 end if; 17518 17519 -- First case, we are in elaboration code 17520 17521 From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit; 17522 17523 if From_Elab_Code then 17524 17525 -- Complain if ref that comes from source in preelaborated unit 17526 -- and we are not inside a subprogram (i.e. we are in elab code). 17527 17528 if Comes_From_Source (N) 17529 and then In_Preelaborated_Unit 17530 and then not In_Inlined_Body 17531 and then Nkind (N) /= N_Attribute_Reference 17532 then 17533 -- This is a warning in GNAT mode allowing such calls to be 17534 -- used in the predefined library with appropriate care. 17535 17536 Error_Msg_Warn := GNAT_Mode; 17537 Error_Msg_N 17538 ("<<non-static call not allowed in preelaborated unit", N); 17539 return; 17540 end if; 17541 17542 -- Second case, we are inside a subprogram or concurrent unit, which 17543 -- means we are not in elaboration code. 17544 17545 else 17546 -- In this case, the issue is whether we are inside the 17547 -- declarative part of the unit in which we live, or inside its 17548 -- statements. In the latter case, there is no issue of ABE calls 17549 -- at this level (a call from outside to the unit in which we live 17550 -- might cause an ABE, but that will be detected when we analyze 17551 -- that outer level call, as it recurses into the called unit). 17552 17553 -- Climb up the tree, doing this test, and also testing for being 17554 -- inside a default expression, which, as discussed above, is not 17555 -- checked at this stage. 17556 17557 declare 17558 P : Node_Id; 17559 L : List_Id; 17560 17561 begin 17562 P := N; 17563 loop 17564 -- If we find a parentless subtree, it seems safe to assume 17565 -- that we are not in a declarative part and that no 17566 -- checking is required. 17567 17568 if No (P) then 17569 return; 17570 end if; 17571 17572 if Is_List_Member (P) then 17573 L := List_Containing (P); 17574 P := Parent (L); 17575 else 17576 L := No_List; 17577 P := Parent (P); 17578 end if; 17579 17580 exit when Nkind (P) = N_Subunit; 17581 17582 -- Filter out case of default expressions, where we do not 17583 -- do the check at this stage. 17584 17585 if Nkind_In (P, N_Parameter_Specification, 17586 N_Component_Declaration) 17587 then 17588 return; 17589 end if; 17590 17591 -- A protected body has no elaboration code and contains 17592 -- only other bodies. 17593 17594 if Nkind (P) = N_Protected_Body then 17595 return; 17596 17597 elsif Nkind_In (P, N_Subprogram_Body, 17598 N_Task_Body, 17599 N_Block_Statement, 17600 N_Entry_Body) 17601 then 17602 if L = Declarations (P) then 17603 exit; 17604 17605 -- We are not in elaboration code, but we are doing 17606 -- dynamic elaboration checks, in this case, we still 17607 -- need to do the reference, since the subprogram we are 17608 -- in could be called from another unit, also in dynamic 17609 -- elaboration check mode, at elaboration time. 17610 17611 elsif Dynamic_Elaboration_Checks then 17612 17613 -- We provide a debug flag to disable this check. That 17614 -- way we have an easy work around for regressions 17615 -- that are caused by this new check. This debug flag 17616 -- can be removed later. 17617 17618 if Debug_Flag_DD then 17619 return; 17620 end if; 17621 17622 -- Do the check in this case 17623 17624 exit; 17625 17626 elsif Nkind (P) = N_Task_Body then 17627 17628 -- The check is deferred until Check_Task_Activation 17629 -- but we need to capture local suppress pragmas 17630 -- that may inhibit checks on this call. 17631 17632 Ent := Get_Referenced_Ent (N); 17633 17634 if No (Ent) then 17635 return; 17636 17637 elsif Elaboration_Checks_Suppressed (Current_Scope) 17638 or else Elaboration_Checks_Suppressed (Ent) 17639 or else Elaboration_Checks_Suppressed (Scope (Ent)) 17640 then 17641 if Nkind (N) in N_Subprogram_Call then 17642 Set_No_Elaboration_Check (N); 17643 end if; 17644 end if; 17645 17646 return; 17647 17648 -- Static model, call is not in elaboration code, we 17649 -- never need to worry, because in the static model the 17650 -- top-level caller always takes care of things. 17651 17652 else 17653 return; 17654 end if; 17655 end if; 17656 end loop; 17657 end; 17658 end if; 17659 end if; 17660 17661 Ent := Get_Referenced_Ent (N); 17662 17663 if No (Ent) then 17664 return; 17665 end if; 17666 17667 -- Determine whether a prior call to the same subprogram was already 17668 -- examined within the same context. If this is the case, then there is 17669 -- no need to proceed with the various warnings and checks because the 17670 -- work was already done for the previous call. 17671 17672 declare 17673 Self : constant Visited_Element := 17674 (Subp_Id => Ent, Context => Parent (N)); 17675 17676 begin 17677 for Index in 1 .. Elab_Visited.Last loop 17678 if Self = Elab_Visited.Table (Index) then 17679 return; 17680 end if; 17681 end loop; 17682 end; 17683 17684 -- See if we need to analyze this reference. We analyze it if either of 17685 -- the following conditions is met: 17686 17687 -- It is an inner level call (since in this case it was triggered 17688 -- by an outer level call from elaboration code), but only if the 17689 -- call is within the scope of the original outer level call. 17690 17691 -- It is an outer level reference from elaboration code, or a call to 17692 -- an entity is in the same elaboration scope. 17693 17694 -- And in these cases, we will check both inter-unit calls and 17695 -- intra-unit (within a single unit) calls. 17696 17697 C_Scope := Current_Scope; 17698 17699 -- If not outer level reference, then we follow it if it is within the 17700 -- original scope of the outer reference. 17701 17702 if Present (Outer_Scope) 17703 and then Within (Scope (Ent), Outer_Scope) 17704 then 17705 Set_C_Scope; 17706 Check_A_Call 17707 (N => N, 17708 E => Ent, 17709 Outer_Scope => Outer_Scope, 17710 Inter_Unit_Only => False, 17711 In_Init_Proc => In_Init_Proc); 17712 17713 -- Nothing to do if elaboration checks suppressed for this scope. 17714 -- However, an interesting exception, the fact that elaboration checks 17715 -- are suppressed within an instance (because we can trace the body when 17716 -- we process the template) does not extend to calls to generic formal 17717 -- subprograms. 17718 17719 elsif Elaboration_Checks_Suppressed (Current_Scope) 17720 and then not Is_Call_Of_Generic_Formal (N) 17721 then 17722 null; 17723 17724 elsif From_Elab_Code then 17725 Set_C_Scope; 17726 Check_A_Call (N, Ent, Standard_Standard, Inter_Unit_Only => False); 17727 17728 elsif Same_Elaboration_Scope (C_Scope, Scope (Ent)) then 17729 Set_C_Scope; 17730 Check_A_Call (N, Ent, Scope (Ent), Inter_Unit_Only => False); 17731 17732 -- If none of those cases holds, but Dynamic_Elaboration_Checks mode 17733 -- is set, then we will do the check, but only in the inter-unit case 17734 -- (this is to accommodate unguarded elaboration calls from other units 17735 -- in which this same mode is set). We don't want warnings in this case, 17736 -- it would generate warnings having nothing to do with elaboration. 17737 17738 elsif Dynamic_Elaboration_Checks then 17739 Set_C_Scope; 17740 Check_A_Call 17741 (N, 17742 Ent, 17743 Standard_Standard, 17744 Inter_Unit_Only => True, 17745 Generate_Warnings => False); 17746 17747 -- Otherwise nothing to do 17748 17749 else 17750 return; 17751 end if; 17752 17753 -- A call to an Init_Proc in elaboration code may bring additional 17754 -- dependencies, if some of the record components thereof have 17755 -- initializations that are function calls that come from source. We 17756 -- treat the current node as a call to each of these functions, to check 17757 -- their elaboration impact. 17758 17759 if Is_Init_Proc (Ent) and then From_Elab_Code then 17760 Process_Init_Proc : declare 17761 Unit_Decl : constant Node_Id := Unit_Declaration_Node (Ent); 17762 17763 function Check_Init_Call (Nod : Node_Id) return Traverse_Result; 17764 -- Find subprogram calls within body of Init_Proc for Traverse 17765 -- instantiation below. 17766 17767 procedure Traverse_Body is new Traverse_Proc (Check_Init_Call); 17768 -- Traversal procedure to find all calls with body of Init_Proc 17769 17770 --------------------- 17771 -- Check_Init_Call -- 17772 --------------------- 17773 17774 function Check_Init_Call (Nod : Node_Id) return Traverse_Result is 17775 Func : Entity_Id; 17776 17777 begin 17778 if Nkind (Nod) in N_Subprogram_Call 17779 and then Is_Entity_Name (Name (Nod)) 17780 then 17781 Func := Entity (Name (Nod)); 17782 17783 if Comes_From_Source (Func) then 17784 Check_A_Call 17785 (N, Func, Standard_Standard, Inter_Unit_Only => True); 17786 end if; 17787 17788 return OK; 17789 17790 else 17791 return OK; 17792 end if; 17793 end Check_Init_Call; 17794 17795 -- Start of processing for Process_Init_Proc 17796 17797 begin 17798 if Nkind (Unit_Decl) = N_Subprogram_Body then 17799 Traverse_Body (Handled_Statement_Sequence (Unit_Decl)); 17800 end if; 17801 end Process_Init_Proc; 17802 end if; 17803 end Check_Elab_Call; 17804 17805 ----------------------- 17806 -- Check_Elab_Assign -- 17807 ----------------------- 17808 17809 procedure Check_Elab_Assign (N : Node_Id) is 17810 Ent : Entity_Id; 17811 Scop : Entity_Id; 17812 17813 Pkg_Spec : Entity_Id; 17814 Pkg_Body : Entity_Id; 17815 17816 begin 17817 pragma Assert (Legacy_Elaboration_Checks); 17818 17819 -- For record or array component, check prefix. If it is an access type, 17820 -- then there is nothing to do (we do not know what is being assigned), 17821 -- but otherwise this is an assignment to the prefix. 17822 17823 if Nkind_In (N, N_Indexed_Component, 17824 N_Selected_Component, 17825 N_Slice) 17826 then 17827 if not Is_Access_Type (Etype (Prefix (N))) then 17828 Check_Elab_Assign (Prefix (N)); 17829 end if; 17830 17831 return; 17832 end if; 17833 17834 -- For type conversion, check expression 17835 17836 if Nkind (N) = N_Type_Conversion then 17837 Check_Elab_Assign (Expression (N)); 17838 return; 17839 end if; 17840 17841 -- Nothing to do if this is not an entity reference otherwise get entity 17842 17843 if Is_Entity_Name (N) then 17844 Ent := Entity (N); 17845 else 17846 return; 17847 end if; 17848 17849 -- What we are looking for is a reference in the body of a package that 17850 -- modifies a variable declared in the visible part of the package spec. 17851 17852 if Present (Ent) 17853 and then Comes_From_Source (N) 17854 and then not Suppress_Elaboration_Warnings (Ent) 17855 and then Ekind (Ent) = E_Variable 17856 and then not In_Private_Part (Ent) 17857 and then Is_Library_Level_Entity (Ent) 17858 then 17859 Scop := Current_Scope; 17860 loop 17861 if No (Scop) or else Scop = Standard_Standard then 17862 return; 17863 elsif Ekind (Scop) = E_Package 17864 and then Is_Compilation_Unit (Scop) 17865 then 17866 exit; 17867 else 17868 Scop := Scope (Scop); 17869 end if; 17870 end loop; 17871 17872 -- Here Scop points to the containing library package 17873 17874 Pkg_Spec := Scop; 17875 Pkg_Body := Body_Entity (Pkg_Spec); 17876 17877 -- All OK if the package has an Elaborate_Body pragma 17878 17879 if Has_Pragma_Elaborate_Body (Scop) then 17880 return; 17881 end if; 17882 17883 -- OK if entity being modified is not in containing package spec 17884 17885 if not In_Same_Source_Unit (Scop, Ent) then 17886 return; 17887 end if; 17888 17889 -- All OK if entity appears in generic package or generic instance. 17890 -- We just get too messed up trying to give proper warnings in the 17891 -- presence of generics. Better no message than a junk one. 17892 17893 Scop := Scope (Ent); 17894 while Present (Scop) and then Scop /= Pkg_Spec loop 17895 if Ekind (Scop) = E_Generic_Package then 17896 return; 17897 elsif Ekind (Scop) = E_Package 17898 and then Is_Generic_Instance (Scop) 17899 then 17900 return; 17901 end if; 17902 17903 Scop := Scope (Scop); 17904 end loop; 17905 17906 -- All OK if in task, don't issue warnings there 17907 17908 if In_Task_Activation then 17909 return; 17910 end if; 17911 17912 -- OK if no package body 17913 17914 if No (Pkg_Body) then 17915 return; 17916 end if; 17917 17918 -- OK if reference is not in package body 17919 17920 if not In_Same_Source_Unit (Pkg_Body, N) then 17921 return; 17922 end if; 17923 17924 -- OK if package body has no handled statement sequence 17925 17926 declare 17927 HSS : constant Node_Id := 17928 Handled_Statement_Sequence (Declaration_Node (Pkg_Body)); 17929 begin 17930 if No (HSS) or else not Comes_From_Source (HSS) then 17931 return; 17932 end if; 17933 end; 17934 17935 -- We definitely have a case of a modification of an entity in 17936 -- the package spec from the elaboration code of the package body. 17937 -- We may not give the warning (because there are some additional 17938 -- checks to avoid too many false positives), but it would be a good 17939 -- idea for the binder to try to keep the body elaboration close to 17940 -- the spec elaboration. 17941 17942 Set_Elaborate_Body_Desirable (Pkg_Spec); 17943 17944 -- All OK in gnat mode (we know what we are doing) 17945 17946 if GNAT_Mode then 17947 return; 17948 end if; 17949 17950 -- All OK if all warnings suppressed 17951 17952 if Warning_Mode = Suppress then 17953 return; 17954 end if; 17955 17956 -- All OK if elaboration checks suppressed for entity 17957 17958 if Checks_May_Be_Suppressed (Ent) 17959 and then Is_Check_Suppressed (Ent, Elaboration_Check) 17960 then 17961 return; 17962 end if; 17963 17964 -- OK if the entity is initialized. Note that the No_Initialization 17965 -- flag usually means that the initialization has been rewritten into 17966 -- assignments, but that still counts for us. 17967 17968 declare 17969 Decl : constant Node_Id := Declaration_Node (Ent); 17970 begin 17971 if Nkind (Decl) = N_Object_Declaration 17972 and then (Present (Expression (Decl)) 17973 or else No_Initialization (Decl)) 17974 then 17975 return; 17976 end if; 17977 end; 17978 17979 -- Here is where we give the warning 17980 17981 -- All OK if warnings suppressed on the entity 17982 17983 if not Has_Warnings_Off (Ent) then 17984 Error_Msg_Sloc := Sloc (Ent); 17985 17986 Error_Msg_NE 17987 ("??& can be accessed by clients before this initialization", 17988 N, Ent); 17989 Error_Msg_NE 17990 ("\??add Elaborate_Body to spec to ensure & is initialized", 17991 N, Ent); 17992 end if; 17993 17994 if not All_Errors_Mode then 17995 Set_Suppress_Elaboration_Warnings (Ent); 17996 end if; 17997 end if; 17998 end Check_Elab_Assign; 17999 18000 ---------------------- 18001 -- Check_Elab_Calls -- 18002 ---------------------- 18003 18004 -- WARNING: This routine manages SPARK regions 18005 18006 procedure Check_Elab_Calls is 18007 Saved_SM : SPARK_Mode_Type; 18008 Saved_SMP : Node_Id; 18009 18010 begin 18011 pragma Assert (Legacy_Elaboration_Checks); 18012 18013 -- If expansion is disabled, do not generate any checks, unless we 18014 -- are in GNATprove mode, so that errors are issued in GNATprove for 18015 -- violations of static elaboration rules in SPARK code. Also skip 18016 -- checks if any subunits are missing because in either case we lack the 18017 -- full information that we need, and no object file will be created in 18018 -- any case. 18019 18020 if (not Expander_Active and not GNATprove_Mode) 18021 or else Is_Generic_Unit (Cunit_Entity (Main_Unit)) 18022 or else Subunits_Missing 18023 then 18024 return; 18025 end if; 18026 18027 -- Skip delayed calls if we had any errors 18028 18029 if Serious_Errors_Detected = 0 then 18030 Delaying_Elab_Checks := False; 18031 Expander_Mode_Save_And_Set (True); 18032 18033 for J in Delay_Check.First .. Delay_Check.Last loop 18034 Push_Scope (Delay_Check.Table (J).Curscop); 18035 From_Elab_Code := Delay_Check.Table (J).From_Elab_Code; 18036 In_Task_Activation := Delay_Check.Table (J).In_Task_Activation; 18037 18038 Saved_SM := SPARK_Mode; 18039 Saved_SMP := SPARK_Mode_Pragma; 18040 18041 -- Set appropriate value of SPARK_Mode 18042 18043 if Delay_Check.Table (J).From_SPARK_Code then 18044 SPARK_Mode := On; 18045 end if; 18046 18047 Check_Internal_Call_Continue 18048 (N => Delay_Check.Table (J).N, 18049 E => Delay_Check.Table (J).E, 18050 Outer_Scope => Delay_Check.Table (J).Outer_Scope, 18051 Orig_Ent => Delay_Check.Table (J).Orig_Ent); 18052 18053 Restore_SPARK_Mode (Saved_SM, Saved_SMP); 18054 Pop_Scope; 18055 end loop; 18056 18057 -- Set Delaying_Elab_Checks back on for next main compilation 18058 18059 Expander_Mode_Restore; 18060 Delaying_Elab_Checks := True; 18061 end if; 18062 end Check_Elab_Calls; 18063 18064 ------------------------------ 18065 -- Check_Elab_Instantiation -- 18066 ------------------------------ 18067 18068 procedure Check_Elab_Instantiation 18069 (N : Node_Id; 18070 Outer_Scope : Entity_Id := Empty) 18071 is 18072 Ent : Entity_Id; 18073 18074 begin 18075 pragma Assert (Legacy_Elaboration_Checks); 18076 18077 -- Check for and deal with bad instantiation case. There is some 18078 -- duplicated code here, but we will worry about this later ??? 18079 18080 Check_Bad_Instantiation (N); 18081 18082 if Is_Known_Guaranteed_ABE (N) then 18083 return; 18084 end if; 18085 18086 -- Nothing to do if we do not have an instantiation (happens in some 18087 -- error cases, and also in the formal package declaration case) 18088 18089 if Nkind (N) not in N_Generic_Instantiation then 18090 return; 18091 end if; 18092 18093 -- Nothing to do if inside a generic template 18094 18095 if Inside_A_Generic then 18096 return; 18097 end if; 18098 18099 -- Nothing to do if the instantiation is not in the main unit 18100 18101 if not In_Extended_Main_Code_Unit (N) then 18102 return; 18103 end if; 18104 18105 Ent := Get_Generic_Entity (N); 18106 From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit; 18107 18108 -- See if we need to analyze this instantiation. We analyze it if 18109 -- either of the following conditions is met: 18110 18111 -- It is an inner level instantiation (since in this case it was 18112 -- triggered by an outer level call from elaboration code), but 18113 -- only if the instantiation is within the scope of the original 18114 -- outer level call. 18115 18116 -- It is an outer level instantiation from elaboration code, or the 18117 -- instantiated entity is in the same elaboration scope. 18118 18119 -- And in these cases, we will check both the inter-unit case and 18120 -- the intra-unit (within a single unit) case. 18121 18122 C_Scope := Current_Scope; 18123 18124 if Present (Outer_Scope) and then Within (Scope (Ent), Outer_Scope) then 18125 Set_C_Scope; 18126 Check_A_Call (N, Ent, Outer_Scope, Inter_Unit_Only => False); 18127 18128 elsif From_Elab_Code then 18129 Set_C_Scope; 18130 Check_A_Call (N, Ent, Standard_Standard, Inter_Unit_Only => False); 18131 18132 elsif Same_Elaboration_Scope (C_Scope, Scope (Ent)) then 18133 Set_C_Scope; 18134 Check_A_Call (N, Ent, Scope (Ent), Inter_Unit_Only => False); 18135 18136 -- If none of those cases holds, but Dynamic_Elaboration_Checks mode is 18137 -- set, then we will do the check, but only in the inter-unit case (this 18138 -- is to accommodate unguarded elaboration calls from other units in 18139 -- which this same mode is set). We inhibit warnings in this case, since 18140 -- this instantiation is not occurring in elaboration code. 18141 18142 elsif Dynamic_Elaboration_Checks then 18143 Set_C_Scope; 18144 Check_A_Call 18145 (N, 18146 Ent, 18147 Standard_Standard, 18148 Inter_Unit_Only => True, 18149 Generate_Warnings => False); 18150 18151 else 18152 return; 18153 end if; 18154 end Check_Elab_Instantiation; 18155 18156 ------------------------- 18157 -- Check_Internal_Call -- 18158 ------------------------- 18159 18160 procedure Check_Internal_Call 18161 (N : Node_Id; 18162 E : Entity_Id; 18163 Outer_Scope : Entity_Id; 18164 Orig_Ent : Entity_Id) 18165 is 18166 function Within_Initial_Condition (Call : Node_Id) return Boolean; 18167 -- Determine whether call Call occurs within pragma Initial_Condition or 18168 -- pragma Check with check_kind set to Initial_Condition. 18169 18170 ------------------------------ 18171 -- Within_Initial_Condition -- 18172 ------------------------------ 18173 18174 function Within_Initial_Condition (Call : Node_Id) return Boolean is 18175 Args : List_Id; 18176 Nam : Name_Id; 18177 Par : Node_Id; 18178 18179 begin 18180 -- Traverse the parent chain looking for an enclosing pragma 18181 18182 Par := Call; 18183 while Present (Par) loop 18184 if Nkind (Par) = N_Pragma then 18185 Nam := Pragma_Name (Par); 18186 18187 -- Pragma Initial_Condition appears in its alternative from as 18188 -- Check (Initial_Condition, ...). 18189 18190 if Nam = Name_Check then 18191 Args := Pragma_Argument_Associations (Par); 18192 18193 -- Pragma Check should have at least two arguments 18194 18195 pragma Assert (Present (Args)); 18196 18197 return 18198 Chars (Expression (First (Args))) = Name_Initial_Condition; 18199 18200 -- Direct match 18201 18202 elsif Nam = Name_Initial_Condition then 18203 return True; 18204 18205 -- Since pragmas are never nested within other pragmas, stop 18206 -- the traversal. 18207 18208 else 18209 return False; 18210 end if; 18211 18212 -- Prevent the search from going too far 18213 18214 elsif Is_Body_Or_Package_Declaration (Par) then 18215 exit; 18216 end if; 18217 18218 Par := Parent (Par); 18219 18220 -- If assertions are not enabled, the check pragma is rewritten 18221 -- as an if_statement in sem_prag, to generate various warnings 18222 -- on boolean expressions. Retrieve the original pragma. 18223 18224 if Nkind (Original_Node (Par)) = N_Pragma then 18225 Par := Original_Node (Par); 18226 end if; 18227 end loop; 18228 18229 return False; 18230 end Within_Initial_Condition; 18231 18232 -- Local variables 18233 18234 Inst_Case : constant Boolean := Nkind (N) in N_Generic_Instantiation; 18235 18236 -- Start of processing for Check_Internal_Call 18237 18238 begin 18239 -- For P'Access, we want to warn if the -gnatw.f switch is set, and the 18240 -- node comes from source. 18241 18242 if Nkind (N) = N_Attribute_Reference 18243 and then ((not Warn_On_Elab_Access and then not Debug_Flag_Dot_O) 18244 or else not Comes_From_Source (N)) 18245 then 18246 return; 18247 18248 -- If not function or procedure call, instantiation, or 'Access, then 18249 -- ignore call (this happens in some error cases and rewriting cases). 18250 18251 elsif not Nkind_In (N, N_Attribute_Reference, 18252 N_Function_Call, 18253 N_Procedure_Call_Statement) 18254 and then not Inst_Case 18255 then 18256 return; 18257 18258 -- Nothing to do if this is a call or instantiation that has already 18259 -- been found to be a sure ABE. 18260 18261 elsif Nkind (N) /= N_Attribute_Reference 18262 and then Is_Known_Guaranteed_ABE (N) 18263 then 18264 return; 18265 18266 -- Nothing to do if errors already detected (avoid cascaded errors) 18267 18268 elsif Serious_Errors_Detected /= 0 then 18269 return; 18270 18271 -- Nothing to do if not in full analysis mode 18272 18273 elsif not Full_Analysis then 18274 return; 18275 18276 -- Nothing to do if analyzing in special spec-expression mode, since the 18277 -- call is not actually being made at this time. 18278 18279 elsif In_Spec_Expression then 18280 return; 18281 18282 -- Nothing to do for call to intrinsic subprogram 18283 18284 elsif Is_Intrinsic_Subprogram (E) then 18285 return; 18286 18287 -- Nothing to do if call is within a generic unit 18288 18289 elsif Inside_A_Generic then 18290 return; 18291 18292 -- Nothing to do when the call appears within pragma Initial_Condition. 18293 -- The pragma is part of the elaboration statements of a package body 18294 -- and may only call external subprograms or subprograms whose body is 18295 -- already available. 18296 18297 elsif Within_Initial_Condition (N) then 18298 return; 18299 end if; 18300 18301 -- Delay this call if we are still delaying calls 18302 18303 if Delaying_Elab_Checks then 18304 Delay_Check.Append 18305 ((N => N, 18306 E => E, 18307 Orig_Ent => Orig_Ent, 18308 Curscop => Current_Scope, 18309 Outer_Scope => Outer_Scope, 18310 From_Elab_Code => From_Elab_Code, 18311 In_Task_Activation => In_Task_Activation, 18312 From_SPARK_Code => SPARK_Mode = On)); 18313 return; 18314 18315 -- Otherwise, call phase 2 continuation right now 18316 18317 else 18318 Check_Internal_Call_Continue (N, E, Outer_Scope, Orig_Ent); 18319 end if; 18320 end Check_Internal_Call; 18321 18322 ---------------------------------- 18323 -- Check_Internal_Call_Continue -- 18324 ---------------------------------- 18325 18326 procedure Check_Internal_Call_Continue 18327 (N : Node_Id; 18328 E : Entity_Id; 18329 Outer_Scope : Entity_Id; 18330 Orig_Ent : Entity_Id) 18331 is 18332 function Find_Elab_Reference (N : Node_Id) return Traverse_Result; 18333 -- Function applied to each node as we traverse the body. Checks for 18334 -- call or entity reference that needs checking, and if so checks it. 18335 -- Always returns OK, so entire tree is traversed, except that as 18336 -- described below subprogram bodies are skipped for now. 18337 18338 procedure Traverse is new Atree.Traverse_Proc (Find_Elab_Reference); 18339 -- Traverse procedure using above Find_Elab_Reference function 18340 18341 ------------------------- 18342 -- Find_Elab_Reference -- 18343 ------------------------- 18344 18345 function Find_Elab_Reference (N : Node_Id) return Traverse_Result is 18346 Actual : Node_Id; 18347 18348 begin 18349 -- If user has specified that there are no entry calls in elaboration 18350 -- code, do not trace past an accept statement, because the rendez- 18351 -- vous will happen after elaboration. 18352 18353 if Nkind_In (Original_Node (N), N_Accept_Statement, 18354 N_Selective_Accept) 18355 and then Restriction_Active (No_Entry_Calls_In_Elaboration_Code) 18356 then 18357 return Abandon; 18358 18359 -- If we have a function call, check it 18360 18361 elsif Nkind (N) = N_Function_Call then 18362 Check_Elab_Call (N, Outer_Scope); 18363 return OK; 18364 18365 -- If we have a procedure call, check the call, and also check 18366 -- arguments that are assignments (OUT or IN OUT mode formals). 18367 18368 elsif Nkind (N) = N_Procedure_Call_Statement then 18369 Check_Elab_Call (N, Outer_Scope, In_Init_Proc => Is_Init_Proc (E)); 18370 18371 Actual := First_Actual (N); 18372 while Present (Actual) loop 18373 if Known_To_Be_Assigned (Actual) then 18374 Check_Elab_Assign (Actual); 18375 end if; 18376 18377 Next_Actual (Actual); 18378 end loop; 18379 18380 return OK; 18381 18382 -- If we have an access attribute for a subprogram, check it. 18383 -- Suppress this behavior under debug flag. 18384 18385 elsif not Debug_Flag_Dot_UU 18386 and then Nkind (N) = N_Attribute_Reference 18387 and then Nam_In (Attribute_Name (N), Name_Access, 18388 Name_Unrestricted_Access) 18389 and then Is_Entity_Name (Prefix (N)) 18390 and then Is_Subprogram (Entity (Prefix (N))) 18391 then 18392 Check_Elab_Call (N, Outer_Scope); 18393 return OK; 18394 18395 -- In SPARK mode, if we have an entity reference to a variable, then 18396 -- check it. For now we consider any reference. 18397 18398 elsif SPARK_Mode = On 18399 and then Nkind (N) in N_Has_Entity 18400 and then Present (Entity (N)) 18401 and then Ekind (Entity (N)) = E_Variable 18402 then 18403 Check_Elab_Call (N, Outer_Scope); 18404 return OK; 18405 18406 -- If we have a generic instantiation, check it 18407 18408 elsif Nkind (N) in N_Generic_Instantiation then 18409 Check_Elab_Instantiation (N, Outer_Scope); 18410 return OK; 18411 18412 -- Skip subprogram bodies that come from source (wait for call to 18413 -- analyze these). The reason for the come from source test is to 18414 -- avoid catching task bodies. 18415 18416 -- For task bodies, we should really avoid these too, waiting for the 18417 -- task activation, but that's too much trouble to catch for now, so 18418 -- we go in unconditionally. This is not so terrible, it means the 18419 -- error backtrace is not quite complete, and we are too eager to 18420 -- scan bodies of tasks that are unused, but this is hardly very 18421 -- significant. 18422 18423 elsif Nkind (N) = N_Subprogram_Body 18424 and then Comes_From_Source (N) 18425 then 18426 return Skip; 18427 18428 elsif Nkind (N) = N_Assignment_Statement 18429 and then Comes_From_Source (N) 18430 then 18431 Check_Elab_Assign (Name (N)); 18432 return OK; 18433 18434 else 18435 return OK; 18436 end if; 18437 end Find_Elab_Reference; 18438 18439 Inst_Case : constant Boolean := Is_Generic_Unit (E); 18440 Loc : constant Source_Ptr := Sloc (N); 18441 18442 Ebody : Entity_Id; 18443 Sbody : Node_Id; 18444 18445 -- Start of processing for Check_Internal_Call_Continue 18446 18447 begin 18448 -- Save outer level call if at outer level 18449 18450 if Elab_Call.Last = 0 then 18451 Outer_Level_Sloc := Loc; 18452 end if; 18453 18454 -- If the call is to a function that renames a literal, no check needed 18455 18456 if Ekind (E) = E_Enumeration_Literal then 18457 return; 18458 end if; 18459 18460 -- Register the subprogram as examined within this particular context. 18461 -- This ensures that calls to the same subprogram but in different 18462 -- contexts receive warnings and checks of their own since the calls 18463 -- may be reached through different flow paths. 18464 18465 Elab_Visited.Append ((Subp_Id => E, Context => Parent (N))); 18466 18467 Sbody := Unit_Declaration_Node (E); 18468 18469 if not Nkind_In (Sbody, N_Subprogram_Body, N_Package_Body) then 18470 Ebody := Corresponding_Body (Sbody); 18471 18472 if No (Ebody) then 18473 return; 18474 else 18475 Sbody := Unit_Declaration_Node (Ebody); 18476 end if; 18477 end if; 18478 18479 -- If the body appears after the outer level call or instantiation then 18480 -- we have an error case handled below. 18481 18482 if Earlier_In_Extended_Unit (Outer_Level_Sloc, Sloc (Sbody)) 18483 and then not In_Task_Activation 18484 then 18485 null; 18486 18487 -- If we have the instantiation case we are done, since we now know that 18488 -- the body of the generic appeared earlier. 18489 18490 elsif Inst_Case then 18491 return; 18492 18493 -- Otherwise we have a call, so we trace through the called body to see 18494 -- if it has any problems. 18495 18496 else 18497 pragma Assert (Nkind (Sbody) = N_Subprogram_Body); 18498 18499 Elab_Call.Append ((Cloc => Loc, Ent => E)); 18500 18501 if Debug_Flag_Underscore_LL then 18502 Write_Str ("Elab_Call.Last = "); 18503 Write_Int (Int (Elab_Call.Last)); 18504 Write_Str (" Ent = "); 18505 Write_Name (Chars (E)); 18506 Write_Str (" at "); 18507 Write_Location (Sloc (N)); 18508 Write_Eol; 18509 end if; 18510 18511 -- Now traverse declarations and statements of subprogram body. Note 18512 -- that we cannot simply Traverse (Sbody), since traverse does not 18513 -- normally visit subprogram bodies. 18514 18515 declare 18516 Decl : Node_Id; 18517 begin 18518 Decl := First (Declarations (Sbody)); 18519 while Present (Decl) loop 18520 Traverse (Decl); 18521 Next (Decl); 18522 end loop; 18523 end; 18524 18525 Traverse (Handled_Statement_Sequence (Sbody)); 18526 18527 Elab_Call.Decrement_Last; 18528 return; 18529 end if; 18530 18531 -- Here is the case of calling a subprogram where the body has not yet 18532 -- been encountered. A warning message is needed, except if this is the 18533 -- case of appearing within an aspect specification that results in 18534 -- a check call, we do not really have such a situation, so no warning 18535 -- is needed (e.g. the case of a precondition, where the call appears 18536 -- textually before the body, but in actual fact is moved to the 18537 -- appropriate subprogram body and so does not need a check). 18538 18539 declare 18540 P : Node_Id; 18541 O : Node_Id; 18542 18543 begin 18544 P := Parent (N); 18545 loop 18546 -- Keep looking at parents if we are still in the subexpression 18547 18548 if Nkind (P) in N_Subexpr then 18549 P := Parent (P); 18550 18551 -- Here P is the parent of the expression, check for special case 18552 18553 else 18554 O := Original_Node (P); 18555 18556 -- Definitely not the special case if orig node is not a pragma 18557 18558 exit when Nkind (O) /= N_Pragma; 18559 18560 -- Check we have an If statement or a null statement (happens 18561 -- when the If has been expanded to be True). 18562 18563 exit when not Nkind_In (P, N_If_Statement, N_Null_Statement); 18564 18565 -- Our special case will be indicated either by the pragma 18566 -- coming from an aspect ... 18567 18568 if Present (Corresponding_Aspect (O)) then 18569 return; 18570 18571 -- Or, in the case of an initial condition, specifically by a 18572 -- Check pragma specifying an Initial_Condition check. 18573 18574 elsif Pragma_Name (O) = Name_Check 18575 and then 18576 Chars 18577 (Expression (First (Pragma_Argument_Associations (O)))) = 18578 Name_Initial_Condition 18579 then 18580 return; 18581 18582 -- For anything else, we have an error 18583 18584 else 18585 exit; 18586 end if; 18587 end if; 18588 end loop; 18589 end; 18590 18591 -- Not that special case, warning and dynamic check is required 18592 18593 -- If we have nothing in the call stack, then this is at the outer 18594 -- level, and the ABE is bound to occur, unless it's a 'Access, or 18595 -- it's a renaming. 18596 18597 if Elab_Call.Last = 0 then 18598 Error_Msg_Warn := SPARK_Mode /= On; 18599 18600 declare 18601 Insert_Check : Boolean := True; 18602 -- This flag is set to True if an elaboration check should be 18603 -- inserted. 18604 18605 begin 18606 if In_Task_Activation then 18607 Insert_Check := False; 18608 18609 elsif Inst_Case then 18610 Error_Msg_NE 18611 ("cannot instantiate& before body seen<<", N, Orig_Ent); 18612 18613 elsif Nkind (N) = N_Attribute_Reference then 18614 Error_Msg_NE 18615 ("Access attribute of & before body seen<<", N, Orig_Ent); 18616 Error_Msg_N ("\possible Program_Error on later references<", N); 18617 Insert_Check := False; 18618 18619 elsif Nkind (Unit_Declaration_Node (Orig_Ent)) /= 18620 N_Subprogram_Renaming_Declaration 18621 then 18622 Error_Msg_NE 18623 ("cannot call& before body seen<<", N, Orig_Ent); 18624 18625 elsif not Is_Generic_Actual_Subprogram (Orig_Ent) then 18626 Insert_Check := False; 18627 end if; 18628 18629 if Insert_Check then 18630 Error_Msg_N ("\Program_Error [<<", N); 18631 Insert_Elab_Check (N); 18632 end if; 18633 end; 18634 18635 -- Call is not at outer level 18636 18637 else 18638 -- Do not generate elaboration checks in GNATprove mode because the 18639 -- elaboration counter and the check are both forms of expansion. 18640 18641 if GNATprove_Mode then 18642 null; 18643 18644 -- Generate an elaboration check 18645 18646 elsif not Elaboration_Checks_Suppressed (E) then 18647 Set_Elaboration_Entity_Required (E); 18648 18649 -- Create a declaration of the elaboration entity, and insert it 18650 -- prior to the subprogram or the generic unit, within the same 18651 -- scope. Since the subprogram may be overloaded, create a unique 18652 -- entity. 18653 18654 if No (Elaboration_Entity (E)) then 18655 declare 18656 Loce : constant Source_Ptr := Sloc (E); 18657 Ent : constant Entity_Id := 18658 Make_Defining_Identifier (Loc, 18659 New_External_Name (Chars (E), 'E', -1)); 18660 18661 begin 18662 Set_Elaboration_Entity (E, Ent); 18663 Push_Scope (Scope (E)); 18664 18665 Insert_Action (Declaration_Node (E), 18666 Make_Object_Declaration (Loce, 18667 Defining_Identifier => Ent, 18668 Object_Definition => 18669 New_Occurrence_Of (Standard_Short_Integer, Loce), 18670 Expression => 18671 Make_Integer_Literal (Loc, Uint_0))); 18672 18673 -- Set elaboration flag at the point of the body 18674 18675 Set_Elaboration_Flag (Sbody, E); 18676 18677 -- Kill current value indication. This is necessary because 18678 -- the tests of this flag are inserted out of sequence and 18679 -- must not pick up bogus indications of the wrong constant 18680 -- value. Also, this is never a true constant, since one way 18681 -- or another, it gets reset. 18682 18683 Set_Current_Value (Ent, Empty); 18684 Set_Last_Assignment (Ent, Empty); 18685 Set_Is_True_Constant (Ent, False); 18686 Pop_Scope; 18687 end; 18688 end if; 18689 18690 -- Generate: 18691 -- if Enn = 0 then 18692 -- raise Program_Error with "access before elaboration"; 18693 -- end if; 18694 18695 Insert_Elab_Check (N, 18696 Make_Attribute_Reference (Loc, 18697 Attribute_Name => Name_Elaborated, 18698 Prefix => New_Occurrence_Of (E, Loc))); 18699 end if; 18700 18701 -- Generate the warning 18702 18703 if not Suppress_Elaboration_Warnings (E) 18704 and then not Elaboration_Checks_Suppressed (E) 18705 18706 -- Suppress this warning if we have a function call that occurred 18707 -- within an assertion expression, since we can get false warnings 18708 -- in this case, due to the out of order handling in this case. 18709 18710 and then 18711 (Nkind (Original_Node (N)) /= N_Function_Call 18712 or else not In_Assertion_Expression_Pragma (Original_Node (N))) 18713 then 18714 Error_Msg_Warn := SPARK_Mode /= On; 18715 18716 if Inst_Case then 18717 Error_Msg_NE 18718 ("instantiation of& may occur before body is seen<l<", 18719 N, Orig_Ent); 18720 else 18721 -- A rather specific check. For Finalize/Adjust/Initialize, if 18722 -- the type has Warnings_Off set, suppress the warning. 18723 18724 if Nam_In (Chars (E), Name_Adjust, 18725 Name_Finalize, 18726 Name_Initialize) 18727 and then Present (First_Formal (E)) 18728 then 18729 declare 18730 T : constant Entity_Id := Etype (First_Formal (E)); 18731 begin 18732 if Is_Controlled (T) then 18733 if Warnings_Off (T) 18734 or else (Ekind (T) = E_Private_Type 18735 and then Warnings_Off (Full_View (T))) 18736 then 18737 goto Output; 18738 end if; 18739 end if; 18740 end; 18741 end if; 18742 18743 -- Go ahead and give warning if not this special case 18744 18745 Error_Msg_NE 18746 ("call to& may occur before body is seen<l<", N, Orig_Ent); 18747 end if; 18748 18749 Error_Msg_N ("\Program_Error ]<l<", N); 18750 18751 -- There is no need to query the elaboration warning message flags 18752 -- because the main message is an error, not a warning, therefore 18753 -- all the clarification messages produces by Output_Calls must be 18754 -- emitted unconditionally. 18755 18756 <<Output>> 18757 18758 Output_Calls (N, Check_Elab_Flag => False); 18759 end if; 18760 end if; 18761 end Check_Internal_Call_Continue; 18762 18763 --------------------------- 18764 -- Check_Task_Activation -- 18765 --------------------------- 18766 18767 procedure Check_Task_Activation (N : Node_Id) is 18768 Loc : constant Source_Ptr := Sloc (N); 18769 Inter_Procs : constant Elist_Id := New_Elmt_List; 18770 Intra_Procs : constant Elist_Id := New_Elmt_List; 18771 Ent : Entity_Id; 18772 P : Entity_Id; 18773 Task_Scope : Entity_Id; 18774 Cunit_SC : Boolean := False; 18775 Decl : Node_Id; 18776 Elmt : Elmt_Id; 18777 Enclosing : Entity_Id; 18778 18779 procedure Add_Task_Proc (Typ : Entity_Id); 18780 -- Add to Task_Procs the task body procedure(s) of task types in Typ. 18781 -- For record types, this procedure recurses over component types. 18782 18783 procedure Collect_Tasks (Decls : List_Id); 18784 -- Collect the types of the tasks that are to be activated in the given 18785 -- list of declarations, in order to perform elaboration checks on the 18786 -- corresponding task procedures that are called implicitly here. 18787 18788 function Outer_Unit (E : Entity_Id) return Entity_Id; 18789 -- find enclosing compilation unit of Entity, ignoring subunits, or 18790 -- else enclosing subprogram. If E is not a package, there is no need 18791 -- for inter-unit elaboration checks. 18792 18793 ------------------- 18794 -- Add_Task_Proc -- 18795 ------------------- 18796 18797 procedure Add_Task_Proc (Typ : Entity_Id) is 18798 Comp : Entity_Id; 18799 Proc : Entity_Id := Empty; 18800 18801 begin 18802 if Is_Task_Type (Typ) then 18803 Proc := Get_Task_Body_Procedure (Typ); 18804 18805 elsif Is_Array_Type (Typ) 18806 and then Has_Task (Base_Type (Typ)) 18807 then 18808 Add_Task_Proc (Component_Type (Typ)); 18809 18810 elsif Is_Record_Type (Typ) 18811 and then Has_Task (Base_Type (Typ)) 18812 then 18813 Comp := First_Component (Typ); 18814 while Present (Comp) loop 18815 Add_Task_Proc (Etype (Comp)); 18816 Comp := Next_Component (Comp); 18817 end loop; 18818 end if; 18819 18820 -- If the task type is another unit, we will perform the usual 18821 -- elaboration check on its enclosing unit. If the type is in the 18822 -- same unit, we can trace the task body as for an internal call, 18823 -- but we only need to examine other external calls, because at 18824 -- the point the task is activated, internal subprogram bodies 18825 -- will have been elaborated already. We keep separate lists for 18826 -- each kind of task. 18827 18828 -- Skip this test if errors have occurred, since in this case 18829 -- we can get false indications. 18830 18831 if Serious_Errors_Detected /= 0 then 18832 return; 18833 end if; 18834 18835 if Present (Proc) then 18836 if Outer_Unit (Scope (Proc)) = Enclosing then 18837 18838 if No (Corresponding_Body (Unit_Declaration_Node (Proc))) 18839 and then 18840 (not Is_Generic_Instance (Scope (Proc)) 18841 or else Scope (Proc) = Scope (Defining_Identifier (Decl))) 18842 then 18843 Error_Msg_Warn := SPARK_Mode /= On; 18844 Error_Msg_N 18845 ("task will be activated before elaboration of its body<<", 18846 Decl); 18847 Error_Msg_N ("\Program_Error [<<", Decl); 18848 18849 elsif Present 18850 (Corresponding_Body (Unit_Declaration_Node (Proc))) 18851 then 18852 Append_Elmt (Proc, Intra_Procs); 18853 end if; 18854 18855 else 18856 -- No need for multiple entries of the same type 18857 18858 Elmt := First_Elmt (Inter_Procs); 18859 while Present (Elmt) loop 18860 if Node (Elmt) = Proc then 18861 return; 18862 end if; 18863 18864 Next_Elmt (Elmt); 18865 end loop; 18866 18867 Append_Elmt (Proc, Inter_Procs); 18868 end if; 18869 end if; 18870 end Add_Task_Proc; 18871 18872 ------------------- 18873 -- Collect_Tasks -- 18874 ------------------- 18875 18876 procedure Collect_Tasks (Decls : List_Id) is 18877 begin 18878 if Present (Decls) then 18879 Decl := First (Decls); 18880 while Present (Decl) loop 18881 if Nkind (Decl) = N_Object_Declaration 18882 and then Has_Task (Etype (Defining_Identifier (Decl))) 18883 then 18884 Add_Task_Proc (Etype (Defining_Identifier (Decl))); 18885 end if; 18886 18887 Next (Decl); 18888 end loop; 18889 end if; 18890 end Collect_Tasks; 18891 18892 ---------------- 18893 -- Outer_Unit -- 18894 ---------------- 18895 18896 function Outer_Unit (E : Entity_Id) return Entity_Id is 18897 Outer : Entity_Id; 18898 18899 begin 18900 Outer := E; 18901 while Present (Outer) loop 18902 if Elaboration_Checks_Suppressed (Outer) then 18903 Cunit_SC := True; 18904 end if; 18905 18906 exit when Is_Child_Unit (Outer) 18907 or else Scope (Outer) = Standard_Standard 18908 or else Ekind (Outer) /= E_Package; 18909 Outer := Scope (Outer); 18910 end loop; 18911 18912 return Outer; 18913 end Outer_Unit; 18914 18915 -- Start of processing for Check_Task_Activation 18916 18917 begin 18918 pragma Assert (Legacy_Elaboration_Checks); 18919 18920 Enclosing := Outer_Unit (Current_Scope); 18921 18922 -- Find all tasks declared in the current unit 18923 18924 if Nkind (N) = N_Package_Body then 18925 P := Unit_Declaration_Node (Corresponding_Spec (N)); 18926 18927 Collect_Tasks (Declarations (N)); 18928 Collect_Tasks (Visible_Declarations (Specification (P))); 18929 Collect_Tasks (Private_Declarations (Specification (P))); 18930 18931 elsif Nkind (N) = N_Package_Declaration then 18932 Collect_Tasks (Visible_Declarations (Specification (N))); 18933 Collect_Tasks (Private_Declarations (Specification (N))); 18934 18935 else 18936 Collect_Tasks (Declarations (N)); 18937 end if; 18938 18939 -- We only perform detailed checks in all tasks that are library level 18940 -- entities. If the master is a subprogram or task, activation will 18941 -- depend on the activation of the master itself. 18942 18943 -- Should dynamic checks be added in the more general case??? 18944 18945 if Ekind (Enclosing) /= E_Package then 18946 return; 18947 end if; 18948 18949 -- For task types defined in other units, we want the unit containing 18950 -- the task body to be elaborated before the current one. 18951 18952 Elmt := First_Elmt (Inter_Procs); 18953 while Present (Elmt) loop 18954 Ent := Node (Elmt); 18955 Task_Scope := Outer_Unit (Scope (Ent)); 18956 18957 if not Is_Compilation_Unit (Task_Scope) then 18958 null; 18959 18960 elsif Suppress_Elaboration_Warnings (Task_Scope) 18961 or else Elaboration_Checks_Suppressed (Task_Scope) 18962 then 18963 null; 18964 18965 elsif Dynamic_Elaboration_Checks then 18966 if not Elaboration_Checks_Suppressed (Ent) 18967 and then not Cunit_SC 18968 and then not Restriction_Active 18969 (No_Entry_Calls_In_Elaboration_Code) 18970 then 18971 -- Runtime elaboration check required. Generate check of the 18972 -- elaboration counter for the unit containing the entity. 18973 18974 Insert_Elab_Check (N, 18975 Make_Attribute_Reference (Loc, 18976 Prefix => 18977 New_Occurrence_Of (Spec_Entity (Task_Scope), Loc), 18978 Attribute_Name => Name_Elaborated)); 18979 end if; 18980 18981 else 18982 -- Force the binder to elaborate other unit first 18983 18984 if Elab_Info_Messages 18985 and then not Suppress_Elaboration_Warnings (Ent) 18986 and then not Elaboration_Checks_Suppressed (Ent) 18987 and then not Suppress_Elaboration_Warnings (Task_Scope) 18988 and then not Elaboration_Checks_Suppressed (Task_Scope) 18989 then 18990 Error_Msg_Node_2 := Task_Scope; 18991 Error_Msg_NE 18992 ("info: activation of an instance of task type & requires " 18993 & "pragma Elaborate_All on &?$?", N, Ent); 18994 end if; 18995 18996 Activate_Elaborate_All_Desirable (N, Task_Scope); 18997 Set_Suppress_Elaboration_Warnings (Task_Scope); 18998 end if; 18999 19000 Next_Elmt (Elmt); 19001 end loop; 19002 19003 -- For tasks declared in the current unit, trace other calls within the 19004 -- task procedure bodies, which are available. 19005 19006 if not Debug_Flag_Dot_Y then 19007 In_Task_Activation := True; 19008 19009 Elmt := First_Elmt (Intra_Procs); 19010 while Present (Elmt) loop 19011 Ent := Node (Elmt); 19012 Check_Internal_Call_Continue (N, Ent, Enclosing, Ent); 19013 Next_Elmt (Elmt); 19014 end loop; 19015 19016 In_Task_Activation := False; 19017 end if; 19018 end Check_Task_Activation; 19019 19020 ------------------------ 19021 -- Get_Referenced_Ent -- 19022 ------------------------ 19023 19024 function Get_Referenced_Ent (N : Node_Id) return Entity_Id is 19025 Nam : Node_Id; 19026 19027 begin 19028 if Nkind (N) in N_Has_Entity 19029 and then Present (Entity (N)) 19030 and then Ekind (Entity (N)) = E_Variable 19031 then 19032 return Entity (N); 19033 end if; 19034 19035 if Nkind (N) = N_Attribute_Reference then 19036 Nam := Prefix (N); 19037 else 19038 Nam := Name (N); 19039 end if; 19040 19041 if No (Nam) then 19042 return Empty; 19043 elsif Nkind (Nam) = N_Selected_Component then 19044 return Entity (Selector_Name (Nam)); 19045 elsif not Is_Entity_Name (Nam) then 19046 return Empty; 19047 else 19048 return Entity (Nam); 19049 end if; 19050 end Get_Referenced_Ent; 19051 19052 ---------------------- 19053 -- Has_Generic_Body -- 19054 ---------------------- 19055 19056 function Has_Generic_Body (N : Node_Id) return Boolean is 19057 Ent : constant Entity_Id := Get_Generic_Entity (N); 19058 Decl : constant Node_Id := Unit_Declaration_Node (Ent); 19059 Scop : Entity_Id; 19060 19061 function Find_Body_In (E : Entity_Id; N : Node_Id) return Node_Id; 19062 -- Determine if the list of nodes headed by N and linked by Next 19063 -- contains a package body for the package spec entity E, and if so 19064 -- return the package body. If not, then returns Empty. 19065 19066 function Load_Package_Body (Nam : Unit_Name_Type) return Node_Id; 19067 -- This procedure is called load the unit whose name is given by Nam. 19068 -- This unit is being loaded to see whether it contains an optional 19069 -- generic body. The returned value is the loaded unit, which is always 19070 -- a package body (only package bodies can contain other entities in the 19071 -- sense in which Has_Generic_Body is interested). We only attempt to 19072 -- load bodies if we are generating code. If we are in semantics check 19073 -- only mode, then it would be wrong to load bodies that are not 19074 -- required from a semantic point of view, so in this case we return 19075 -- Empty. The result is that the caller may incorrectly decide that a 19076 -- generic spec does not have a body when in fact it does, but the only 19077 -- harm in this is that some warnings on elaboration problems may be 19078 -- lost in semantic checks only mode, which is not big loss. We also 19079 -- return Empty if we go for a body and it is not there. 19080 19081 function Locate_Corresponding_Body (PE : Entity_Id) return Node_Id; 19082 -- PE is the entity for a package spec. This function locates the 19083 -- corresponding package body, returning Empty if none is found. The 19084 -- package body returned is fully parsed but may not yet be analyzed, 19085 -- so only syntactic fields should be referenced. 19086 19087 ------------------ 19088 -- Find_Body_In -- 19089 ------------------ 19090 19091 function Find_Body_In (E : Entity_Id; N : Node_Id) return Node_Id is 19092 Nod : Node_Id; 19093 19094 begin 19095 Nod := N; 19096 while Present (Nod) loop 19097 19098 -- If we found the package body we are looking for, return it 19099 19100 if Nkind (Nod) = N_Package_Body 19101 and then Chars (Defining_Unit_Name (Nod)) = Chars (E) 19102 then 19103 return Nod; 19104 19105 -- If we found the stub for the body, go after the subunit, 19106 -- loading it if necessary. 19107 19108 elsif Nkind (Nod) = N_Package_Body_Stub 19109 and then Chars (Defining_Identifier (Nod)) = Chars (E) 19110 then 19111 if Present (Library_Unit (Nod)) then 19112 return Unit (Library_Unit (Nod)); 19113 19114 else 19115 return Load_Package_Body (Get_Unit_Name (Nod)); 19116 end if; 19117 19118 -- If neither package body nor stub, keep looking on chain 19119 19120 else 19121 Next (Nod); 19122 end if; 19123 end loop; 19124 19125 return Empty; 19126 end Find_Body_In; 19127 19128 ----------------------- 19129 -- Load_Package_Body -- 19130 ----------------------- 19131 19132 function Load_Package_Body (Nam : Unit_Name_Type) return Node_Id is 19133 U : Unit_Number_Type; 19134 19135 begin 19136 if Operating_Mode /= Generate_Code then 19137 return Empty; 19138 else 19139 U := 19140 Load_Unit 19141 (Load_Name => Nam, 19142 Required => False, 19143 Subunit => False, 19144 Error_Node => N); 19145 19146 if U = No_Unit then 19147 return Empty; 19148 else 19149 return Unit (Cunit (U)); 19150 end if; 19151 end if; 19152 end Load_Package_Body; 19153 19154 ------------------------------- 19155 -- Locate_Corresponding_Body -- 19156 ------------------------------- 19157 19158 function Locate_Corresponding_Body (PE : Entity_Id) return Node_Id is 19159 Spec : constant Node_Id := Declaration_Node (PE); 19160 Decl : constant Node_Id := Parent (Spec); 19161 Scop : constant Entity_Id := Scope (PE); 19162 PBody : Node_Id; 19163 19164 begin 19165 if Is_Library_Level_Entity (PE) then 19166 19167 -- If package is a library unit that requires a body, we have no 19168 -- choice but to go after that body because it might contain an 19169 -- optional body for the original generic package. 19170 19171 if Unit_Requires_Body (PE) then 19172 19173 -- Load the body. Note that we are a little careful here to use 19174 -- Spec to get the unit number, rather than PE or Decl, since 19175 -- in the case where the package is itself a library level 19176 -- instantiation, Spec will properly reference the generic 19177 -- template, which is what we really want. 19178 19179 return 19180 Load_Package_Body 19181 (Get_Body_Name (Unit_Name (Get_Source_Unit (Spec)))); 19182 19183 -- But if the package is a library unit that does NOT require 19184 -- a body, then no body is permitted, so we are sure that there 19185 -- is no body for the original generic package. 19186 19187 else 19188 return Empty; 19189 end if; 19190 19191 -- Otherwise look and see if we are embedded in a further package 19192 19193 elsif Is_Package_Or_Generic_Package (Scop) then 19194 19195 -- If so, get the body of the enclosing package, and look in 19196 -- its package body for the package body we are looking for. 19197 19198 PBody := Locate_Corresponding_Body (Scop); 19199 19200 if No (PBody) then 19201 return Empty; 19202 else 19203 return Find_Body_In (PE, First (Declarations (PBody))); 19204 end if; 19205 19206 -- If we are not embedded in a further package, then the body 19207 -- must be in the same declarative part as we are. 19208 19209 else 19210 return Find_Body_In (PE, Next (Decl)); 19211 end if; 19212 end Locate_Corresponding_Body; 19213 19214 -- Start of processing for Has_Generic_Body 19215 19216 begin 19217 if Present (Corresponding_Body (Decl)) then 19218 return True; 19219 19220 elsif Unit_Requires_Body (Ent) then 19221 return True; 19222 19223 -- Compilation units cannot have optional bodies 19224 19225 elsif Is_Compilation_Unit (Ent) then 19226 return False; 19227 19228 -- Otherwise look at what scope we are in 19229 19230 else 19231 Scop := Scope (Ent); 19232 19233 -- Case of entity is in other than a package spec, in this case 19234 -- the body, if present, must be in the same declarative part. 19235 19236 if not Is_Package_Or_Generic_Package (Scop) then 19237 declare 19238 P : Node_Id; 19239 19240 begin 19241 -- Declaration node may get us a spec, so if so, go to 19242 -- the parent declaration. 19243 19244 P := Declaration_Node (Ent); 19245 while not Is_List_Member (P) loop 19246 P := Parent (P); 19247 end loop; 19248 19249 return Present (Find_Body_In (Ent, Next (P))); 19250 end; 19251 19252 -- If the entity is in a package spec, then we have to locate 19253 -- the corresponding package body, and look there. 19254 19255 else 19256 declare 19257 PBody : constant Node_Id := Locate_Corresponding_Body (Scop); 19258 19259 begin 19260 if No (PBody) then 19261 return False; 19262 else 19263 return 19264 Present 19265 (Find_Body_In (Ent, (First (Declarations (PBody))))); 19266 end if; 19267 end; 19268 end if; 19269 end if; 19270 end Has_Generic_Body; 19271 19272 ----------------------- 19273 -- Insert_Elab_Check -- 19274 ----------------------- 19275 19276 procedure Insert_Elab_Check (N : Node_Id; C : Node_Id := Empty) is 19277 Nod : Node_Id; 19278 Loc : constant Source_Ptr := Sloc (N); 19279 19280 Chk : Node_Id; 19281 -- The check (N_Raise_Program_Error) node to be inserted 19282 19283 begin 19284 -- If expansion is disabled, do not generate any checks. Also 19285 -- skip checks if any subunits are missing because in either 19286 -- case we lack the full information that we need, and no object 19287 -- file will be created in any case. 19288 19289 if not Expander_Active or else Subunits_Missing then 19290 return; 19291 end if; 19292 19293 -- If we have a generic instantiation, where Instance_Spec is set, 19294 -- then this field points to a generic instance spec that has 19295 -- been inserted before the instantiation node itself, so that 19296 -- is where we want to insert a check. 19297 19298 if Nkind (N) in N_Generic_Instantiation 19299 and then Present (Instance_Spec (N)) 19300 then 19301 Nod := Instance_Spec (N); 19302 else 19303 Nod := N; 19304 end if; 19305 19306 -- Build check node, possibly with condition 19307 19308 Chk := 19309 Make_Raise_Program_Error (Loc, Reason => PE_Access_Before_Elaboration); 19310 19311 if Present (C) then 19312 Set_Condition (Chk, Make_Op_Not (Loc, Right_Opnd => C)); 19313 end if; 19314 19315 -- If we are inserting at the top level, insert in Aux_Decls 19316 19317 if Nkind (Parent (Nod)) = N_Compilation_Unit then 19318 declare 19319 ADN : constant Node_Id := Aux_Decls_Node (Parent (Nod)); 19320 19321 begin 19322 if No (Declarations (ADN)) then 19323 Set_Declarations (ADN, New_List (Chk)); 19324 else 19325 Append_To (Declarations (ADN), Chk); 19326 end if; 19327 19328 Analyze (Chk); 19329 end; 19330 19331 -- Otherwise just insert as an action on the node in question 19332 19333 else 19334 Insert_Action (Nod, Chk); 19335 end if; 19336 end Insert_Elab_Check; 19337 19338 ------------------------------- 19339 -- Is_Call_Of_Generic_Formal -- 19340 ------------------------------- 19341 19342 function Is_Call_Of_Generic_Formal (N : Node_Id) return Boolean is 19343 begin 19344 return Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement) 19345 19346 -- Always return False if debug flag -gnatd.G is set 19347 19348 and then not Debug_Flag_Dot_GG 19349 19350 -- For now, we detect this by looking for the strange identifier 19351 -- node, whose Chars reflect the name of the generic formal, but 19352 -- the Chars of the Entity references the generic actual. 19353 19354 and then Nkind (Name (N)) = N_Identifier 19355 and then Chars (Name (N)) /= Chars (Entity (Name (N))); 19356 end Is_Call_Of_Generic_Formal; 19357 19358 ------------------------------- 19359 -- Is_Finalization_Procedure -- 19360 ------------------------------- 19361 19362 function Is_Finalization_Procedure (Id : Entity_Id) return Boolean is 19363 begin 19364 -- Check whether Id is a procedure with at least one parameter 19365 19366 if Ekind (Id) = E_Procedure and then Present (First_Formal (Id)) then 19367 declare 19368 Typ : constant Entity_Id := Etype (First_Formal (Id)); 19369 Deep_Fin : Entity_Id := Empty; 19370 Fin : Entity_Id := Empty; 19371 19372 begin 19373 -- If the type of the first formal does not require finalization 19374 -- actions, then this is definitely not [Deep_]Finalize. 19375 19376 if not Needs_Finalization (Typ) then 19377 return False; 19378 end if; 19379 19380 -- At this point we have the following scenario: 19381 19382 -- procedure Name (Param1 : [in] [out] Ctrl[; Param2 : ...]); 19383 19384 -- Recover the two possible versions of [Deep_]Finalize using the 19385 -- type of the first parameter and compare with the input. 19386 19387 Deep_Fin := TSS (Typ, TSS_Deep_Finalize); 19388 19389 if Is_Controlled (Typ) then 19390 Fin := Find_Prim_Op (Typ, Name_Finalize); 19391 end if; 19392 19393 return (Present (Deep_Fin) and then Id = Deep_Fin) 19394 or else (Present (Fin) and then Id = Fin); 19395 end; 19396 end if; 19397 19398 return False; 19399 end Is_Finalization_Procedure; 19400 19401 ------------------ 19402 -- Output_Calls -- 19403 ------------------ 19404 19405 procedure Output_Calls 19406 (N : Node_Id; 19407 Check_Elab_Flag : Boolean) 19408 is 19409 function Emit (Flag : Boolean) return Boolean; 19410 -- Determine whether to emit an error message based on the combination 19411 -- of flags Check_Elab_Flag and Flag. 19412 19413 function Is_Printable_Error_Name return Boolean; 19414 -- An internal function, used to determine if a name, stored in the 19415 -- Name_Buffer, is either a non-internal name, or is an internal name 19416 -- that is printable by the error message circuits (i.e. it has a single 19417 -- upper case letter at the end). 19418 19419 ---------- 19420 -- Emit -- 19421 ---------- 19422 19423 function Emit (Flag : Boolean) return Boolean is 19424 begin 19425 if Check_Elab_Flag then 19426 return Flag; 19427 else 19428 return True; 19429 end if; 19430 end Emit; 19431 19432 ----------------------------- 19433 -- Is_Printable_Error_Name -- 19434 ----------------------------- 19435 19436 function Is_Printable_Error_Name return Boolean is 19437 begin 19438 if not Is_Internal_Name then 19439 return True; 19440 19441 elsif Name_Len = 1 then 19442 return False; 19443 19444 else 19445 Name_Len := Name_Len - 1; 19446 return not Is_Internal_Name; 19447 end if; 19448 end Is_Printable_Error_Name; 19449 19450 -- Local variables 19451 19452 Ent : Entity_Id; 19453 19454 -- Start of processing for Output_Calls 19455 19456 begin 19457 for J in reverse 1 .. Elab_Call.Last loop 19458 Error_Msg_Sloc := Elab_Call.Table (J).Cloc; 19459 19460 Ent := Elab_Call.Table (J).Ent; 19461 Get_Name_String (Chars (Ent)); 19462 19463 -- Dynamic elaboration model, warnings controlled by -gnatwl 19464 19465 if Dynamic_Elaboration_Checks then 19466 if Emit (Elab_Warnings) then 19467 if Is_Generic_Unit (Ent) then 19468 Error_Msg_NE ("\\?l?& instantiated #", N, Ent); 19469 elsif Is_Init_Proc (Ent) then 19470 Error_Msg_N ("\\?l?initialization procedure called #", N); 19471 elsif Is_Printable_Error_Name then 19472 Error_Msg_NE ("\\?l?& called #", N, Ent); 19473 else 19474 Error_Msg_N ("\\?l?called #", N); 19475 end if; 19476 end if; 19477 19478 -- Static elaboration model, info messages controlled by -gnatel 19479 19480 else 19481 if Emit (Elab_Info_Messages) then 19482 if Is_Generic_Unit (Ent) then 19483 Error_Msg_NE ("\\?$?& instantiated #", N, Ent); 19484 elsif Is_Init_Proc (Ent) then 19485 Error_Msg_N ("\\?$?initialization procedure called #", N); 19486 elsif Is_Printable_Error_Name then 19487 Error_Msg_NE ("\\?$?& called #", N, Ent); 19488 else 19489 Error_Msg_N ("\\?$?called #", N); 19490 end if; 19491 end if; 19492 end if; 19493 end loop; 19494 end Output_Calls; 19495 19496 ---------------------------- 19497 -- Same_Elaboration_Scope -- 19498 ---------------------------- 19499 19500 function Same_Elaboration_Scope (Scop1, Scop2 : Entity_Id) return Boolean is 19501 S1 : Entity_Id; 19502 S2 : Entity_Id; 19503 19504 begin 19505 -- Find elaboration scope for Scop1 19506 -- This is either a subprogram or a compilation unit. 19507 19508 S1 := Scop1; 19509 while S1 /= Standard_Standard 19510 and then not Is_Compilation_Unit (S1) 19511 and then Ekind_In (S1, E_Package, E_Protected_Type, E_Block) 19512 loop 19513 S1 := Scope (S1); 19514 end loop; 19515 19516 -- Find elaboration scope for Scop2 19517 19518 S2 := Scop2; 19519 while S2 /= Standard_Standard 19520 and then not Is_Compilation_Unit (S2) 19521 and then Ekind_In (S2, E_Package, E_Protected_Type, E_Block) 19522 loop 19523 S2 := Scope (S2); 19524 end loop; 19525 19526 return S1 = S2; 19527 end Same_Elaboration_Scope; 19528 19529 ----------------- 19530 -- Set_C_Scope -- 19531 ----------------- 19532 19533 procedure Set_C_Scope is 19534 begin 19535 while not Is_Compilation_Unit (C_Scope) loop 19536 C_Scope := Scope (C_Scope); 19537 end loop; 19538 end Set_C_Scope; 19539 19540 -------------------------------- 19541 -- Set_Elaboration_Constraint -- 19542 -------------------------------- 19543 19544 procedure Set_Elaboration_Constraint 19545 (Call : Node_Id; 19546 Subp : Entity_Id; 19547 Scop : Entity_Id) 19548 is 19549 Elab_Unit : Entity_Id; 19550 19551 -- Check whether this is a call to an Initialize subprogram for a 19552 -- controlled type. Note that Call can also be a 'Access attribute 19553 -- reference, which now generates an elaboration check. 19554 19555 Init_Call : constant Boolean := 19556 Nkind (Call) = N_Procedure_Call_Statement 19557 and then Chars (Subp) = Name_Initialize 19558 and then Comes_From_Source (Subp) 19559 and then Present (Parameter_Associations (Call)) 19560 and then Is_Controlled (Etype (First_Actual (Call))); 19561 19562 begin 19563 -- If the unit is mentioned in a with_clause of the current unit, it is 19564 -- visible, and we can set the elaboration flag. 19565 19566 if Is_Immediately_Visible (Scop) 19567 or else (Is_Child_Unit (Scop) and then Is_Visible_Lib_Unit (Scop)) 19568 then 19569 Activate_Elaborate_All_Desirable (Call, Scop); 19570 Set_Suppress_Elaboration_Warnings (Scop); 19571 return; 19572 end if; 19573 19574 -- If this is not an initialization call or a call using object notation 19575 -- we know that the unit of the called entity is in the context, and we 19576 -- can set the flag as well. The unit need not be visible if the call 19577 -- occurs within an instantiation. 19578 19579 if Is_Init_Proc (Subp) 19580 or else Init_Call 19581 or else Nkind (Original_Node (Call)) = N_Selected_Component 19582 then 19583 null; -- detailed processing follows. 19584 19585 else 19586 Activate_Elaborate_All_Desirable (Call, Scop); 19587 Set_Suppress_Elaboration_Warnings (Scop); 19588 return; 19589 end if; 19590 19591 -- If the unit is not in the context, there must be an intermediate unit 19592 -- that is, on which we need to place to elaboration flag. This happens 19593 -- with init proc calls. 19594 19595 if Is_Init_Proc (Subp) or else Init_Call then 19596 19597 -- The initialization call is on an object whose type is not declared 19598 -- in the same scope as the subprogram. The type of the object must 19599 -- be a subtype of the type of operation. This object is the first 19600 -- actual in the call. 19601 19602 declare 19603 Typ : constant Entity_Id := 19604 Etype (First (Parameter_Associations (Call))); 19605 begin 19606 Elab_Unit := Scope (Typ); 19607 while (Present (Elab_Unit)) 19608 and then not Is_Compilation_Unit (Elab_Unit) 19609 loop 19610 Elab_Unit := Scope (Elab_Unit); 19611 end loop; 19612 end; 19613 19614 -- If original node uses selected component notation, the prefix is 19615 -- visible and determines the scope that must be elaborated. After 19616 -- rewriting, the prefix is the first actual in the call. 19617 19618 elsif Nkind (Original_Node (Call)) = N_Selected_Component then 19619 Elab_Unit := Scope (Etype (First (Parameter_Associations (Call)))); 19620 19621 -- Not one of special cases above 19622 19623 else 19624 -- Using previously computed scope. If the elaboration check is 19625 -- done after analysis, the scope is not visible any longer, but 19626 -- must still be in the context. 19627 19628 Elab_Unit := Scop; 19629 end if; 19630 19631 Activate_Elaborate_All_Desirable (Call, Elab_Unit); 19632 Set_Suppress_Elaboration_Warnings (Elab_Unit); 19633 end Set_Elaboration_Constraint; 19634 19635 ----------------- 19636 -- Spec_Entity -- 19637 ----------------- 19638 19639 function Spec_Entity (E : Entity_Id) return Entity_Id is 19640 Decl : Node_Id; 19641 19642 begin 19643 -- Check for case of body entity 19644 -- Why is the check for E_Void needed??? 19645 19646 if Ekind_In (E, E_Void, E_Subprogram_Body, E_Package_Body) then 19647 Decl := E; 19648 19649 loop 19650 Decl := Parent (Decl); 19651 exit when Nkind (Decl) in N_Proper_Body; 19652 end loop; 19653 19654 return Corresponding_Spec (Decl); 19655 19656 else 19657 return E; 19658 end if; 19659 end Spec_Entity; 19660 19661 ------------ 19662 -- Within -- 19663 ------------ 19664 19665 function Within (E1, E2 : Entity_Id) return Boolean is 19666 Scop : Entity_Id; 19667 begin 19668 Scop := E1; 19669 loop 19670 if Scop = E2 then 19671 return True; 19672 elsif Scop = Standard_Standard then 19673 return False; 19674 else 19675 Scop := Scope (Scop); 19676 end if; 19677 end loop; 19678 end Within; 19679 19680 -------------------------- 19681 -- Within_Elaborate_All -- 19682 -------------------------- 19683 19684 function Within_Elaborate_All 19685 (Unit : Unit_Number_Type; 19686 E : Entity_Id) return Boolean 19687 is 19688 type Unit_Number_Set is array (Main_Unit .. Last_Unit) of Boolean; 19689 pragma Pack (Unit_Number_Set); 19690 19691 Seen : Unit_Number_Set := (others => False); 19692 -- Seen (X) is True after we have seen unit X in the walk. This is used 19693 -- to prevent processing the same unit more than once. 19694 19695 Result : Boolean := False; 19696 19697 procedure Helper (Unit : Unit_Number_Type); 19698 -- This helper procedure does all the work for Within_Elaborate_All. It 19699 -- walks the dependency graph, and sets Result to True if it finds an 19700 -- appropriate Elaborate_All. 19701 19702 ------------ 19703 -- Helper -- 19704 ------------ 19705 19706 procedure Helper (Unit : Unit_Number_Type) is 19707 CU : constant Node_Id := Cunit (Unit); 19708 19709 Item : Node_Id; 19710 Item2 : Node_Id; 19711 Elab_Id : Entity_Id; 19712 Par : Node_Id; 19713 19714 begin 19715 if Seen (Unit) then 19716 return; 19717 else 19718 Seen (Unit) := True; 19719 end if; 19720 19721 -- First, check for Elaborate_Alls on this unit 19722 19723 Item := First (Context_Items (CU)); 19724 while Present (Item) loop 19725 if Nkind (Item) = N_Pragma 19726 and then Pragma_Name (Item) = Name_Elaborate_All 19727 then 19728 -- Return if some previous error on the pragma itself. The 19729 -- pragma may be unanalyzed, because of a previous error, or 19730 -- if it is the context of a subunit, inherited by its parent. 19731 19732 if Error_Posted (Item) or else not Analyzed (Item) then 19733 return; 19734 end if; 19735 19736 Elab_Id := 19737 Entity 19738 (Expression (First (Pragma_Argument_Associations (Item)))); 19739 19740 if E = Elab_Id then 19741 Result := True; 19742 return; 19743 end if; 19744 19745 Par := Parent (Unit_Declaration_Node (Elab_Id)); 19746 19747 Item2 := First (Context_Items (Par)); 19748 while Present (Item2) loop 19749 if Nkind (Item2) = N_With_Clause 19750 and then Entity (Name (Item2)) = E 19751 and then not Limited_Present (Item2) 19752 then 19753 Result := True; 19754 return; 19755 end if; 19756 19757 Next (Item2); 19758 end loop; 19759 end if; 19760 19761 Next (Item); 19762 end loop; 19763 19764 -- Second, recurse on with's. We could do this as part of the above 19765 -- loop, but it's probably more efficient to have two loops, because 19766 -- the relevant Elaborate_All is likely to be on the initial unit. In 19767 -- other words, we're walking the with's breadth-first. This part is 19768 -- only necessary in the dynamic elaboration model. 19769 19770 if Dynamic_Elaboration_Checks then 19771 Item := First (Context_Items (CU)); 19772 while Present (Item) loop 19773 if Nkind (Item) = N_With_Clause 19774 and then not Limited_Present (Item) 19775 then 19776 -- Note: the following call to Get_Cunit_Unit_Number does a 19777 -- linear search, which could be slow, but it's OK because 19778 -- we're about to give a warning anyway. Also, there might 19779 -- be hundreds of units, but not millions. If it turns out 19780 -- to be a problem, we could store the Get_Cunit_Unit_Number 19781 -- in each N_Compilation_Unit node, but that would involve 19782 -- rearranging N_Compilation_Unit_Aux to make room. 19783 19784 Helper (Get_Cunit_Unit_Number (Library_Unit (Item))); 19785 19786 if Result then 19787 return; 19788 end if; 19789 end if; 19790 19791 Next (Item); 19792 end loop; 19793 end if; 19794 end Helper; 19795 19796 -- Start of processing for Within_Elaborate_All 19797 19798 begin 19799 Helper (Unit); 19800 return Result; 19801 end Within_Elaborate_All; 19802 19803end Sem_Elab; 19804