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-2012, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Atree; use Atree; 27with Checks; use Checks; 28with Debug; use Debug; 29with Einfo; use Einfo; 30with Elists; use Elists; 31with Errout; use Errout; 32with Exp_Tss; use Exp_Tss; 33with Exp_Util; use Exp_Util; 34with Expander; use Expander; 35with Fname; use Fname; 36with Lib; use Lib; 37with Lib.Load; use Lib.Load; 38with Namet; use Namet; 39with Nlists; use Nlists; 40with Nmake; use Nmake; 41with Opt; use Opt; 42with Output; use Output; 43with Restrict; use Restrict; 44with Rident; use Rident; 45with Sem; use Sem; 46with Sem_Aux; use Sem_Aux; 47with Sem_Cat; use Sem_Cat; 48with Sem_Ch7; use Sem_Ch7; 49with Sem_Ch8; use Sem_Ch8; 50with Sem_Res; use Sem_Res; 51with Sem_Type; use Sem_Type; 52with Sem_Util; use Sem_Util; 53with Sinfo; use Sinfo; 54with Sinput; use Sinput; 55with Snames; use Snames; 56with Stand; use Stand; 57with Table; 58with Tbuild; use Tbuild; 59with Uintp; use Uintp; 60with Uname; use Uname; 61 62package body Sem_Elab is 63 64 -- The following table records the recursive call chain for output in the 65 -- Output routine. Each entry records the call node and the entity of the 66 -- called routine. The number of entries in the table (i.e. the value of 67 -- Elab_Call.Last) indicates the current depth of recursion and is used to 68 -- identify the outer level. 69 70 type Elab_Call_Entry is record 71 Cloc : Source_Ptr; 72 Ent : Entity_Id; 73 end record; 74 75 package Elab_Call is new Table.Table ( 76 Table_Component_Type => Elab_Call_Entry, 77 Table_Index_Type => Int, 78 Table_Low_Bound => 1, 79 Table_Initial => 50, 80 Table_Increment => 100, 81 Table_Name => "Elab_Call"); 82 83 -- This table is initialized at the start of each outer level call. It 84 -- holds the entities for all subprograms that have been examined for this 85 -- particular outer level call, and is used to prevent both infinite 86 -- recursion, and useless reanalysis of bodies already seen 87 88 package Elab_Visited is new Table.Table ( 89 Table_Component_Type => Entity_Id, 90 Table_Index_Type => Int, 91 Table_Low_Bound => 1, 92 Table_Initial => 200, 93 Table_Increment => 100, 94 Table_Name => "Elab_Visited"); 95 96 -- This table stores calls to Check_Internal_Call that are delayed 97 -- until all generics are instantiated, and in particular that all 98 -- generic bodies have been inserted. We need to delay, because we 99 -- need to be able to look through the inserted bodies. 100 101 type Delay_Element is record 102 N : Node_Id; 103 -- The parameter N from the call to Check_Internal_Call. Note that 104 -- this node may get rewritten over the delay period by expansion 105 -- in the call case (but not in the instantiation case). 106 107 E : Entity_Id; 108 -- The parameter E from the call to Check_Internal_Call 109 110 Orig_Ent : Entity_Id; 111 -- The parameter Orig_Ent from the call to Check_Internal_Call 112 113 Curscop : Entity_Id; 114 -- The current scope of the call. This is restored when we complete 115 -- the delayed call, so that we do this in the right scope. 116 117 From_Elab_Code : Boolean; 118 -- Save indication of whether this call is from elaboration code 119 120 Outer_Scope : Entity_Id; 121 -- Save scope of outer level call 122 end record; 123 124 package Delay_Check is new Table.Table ( 125 Table_Component_Type => Delay_Element, 126 Table_Index_Type => Int, 127 Table_Low_Bound => 1, 128 Table_Initial => 1000, 129 Table_Increment => 100, 130 Table_Name => "Delay_Check"); 131 132 C_Scope : Entity_Id; 133 -- Top level scope of current scope. Compute this only once at the outer 134 -- level, i.e. for a call to Check_Elab_Call from outside this unit. 135 136 Outer_Level_Sloc : Source_Ptr; 137 -- Save Sloc value for outer level call node for comparisons of source 138 -- locations. A body is too late if it appears after the *outer* level 139 -- call, not the particular call that is being analyzed. 140 141 From_Elab_Code : Boolean; 142 -- This flag shows whether the outer level call currently being examined 143 -- is or is not in elaboration code. We are only interested in calls to 144 -- routines in other units if this flag is True. 145 146 In_Task_Activation : Boolean := False; 147 -- This flag indicates whether we are performing elaboration checks on 148 -- task procedures, at the point of activation. If true, we do not trace 149 -- internal calls in these procedures, because all local bodies are known 150 -- to be elaborated. 151 152 Delaying_Elab_Checks : Boolean := True; 153 -- This is set True till the compilation is complete, including the 154 -- insertion of all instance bodies. Then when Check_Elab_Calls is called, 155 -- the delay table is used to make the delayed calls and this flag is reset 156 -- to False, so that the calls are processed. 157 158 ----------------------- 159 -- Local Subprograms -- 160 ----------------------- 161 162 -- Note: Outer_Scope in all following specs represents the scope of 163 -- interest of the outer level call. If it is set to Standard_Standard, 164 -- then it means the outer level call was at elaboration level, and that 165 -- thus all calls are of interest. If it was set to some other scope, 166 -- then the original call was an inner call, and we are not interested 167 -- in calls that go outside this scope. 168 169 procedure Activate_Elaborate_All_Desirable (N : Node_Id; U : Entity_Id); 170 -- Analysis of construct N shows that we should set Elaborate_All_Desirable 171 -- for the WITH clause for unit U (which will always be present). A special 172 -- case is when N is a function or procedure instantiation, in which case 173 -- it is sufficient to set Elaborate_Desirable, since in this case there is 174 -- no possibility of transitive elaboration issues. 175 176 procedure Check_A_Call 177 (N : Node_Id; 178 E : Entity_Id; 179 Outer_Scope : Entity_Id; 180 Inter_Unit_Only : Boolean; 181 Generate_Warnings : Boolean := True; 182 In_Init_Proc : Boolean := False); 183 -- This is the internal recursive routine that is called to check for 184 -- possible elaboration error. The argument N is a subprogram call or 185 -- generic instantiation, or 'Access attribute reference to be checked, and 186 -- E is the entity of the called subprogram, or instantiated generic unit, 187 -- or subprogram referenced by 'Access. 188 -- 189 -- The flag Outer_Scope is the outer level scope for the original call. 190 -- Inter_Unit_Only is set if the call is only to be checked in the 191 -- case where it is to another unit (and skipped if within a unit). 192 -- Generate_Warnings is set to False to suppress warning messages about 193 -- missing pragma Elaborate_All's. These messages are not wanted for 194 -- inner calls in the dynamic model. Note that an instance of the Access 195 -- attribute applied to a subprogram also generates a call to this 196 -- procedure (since the referenced subprogram may be called later 197 -- indirectly). Flag In_Init_Proc should be set whenever the current 198 -- context is a type init proc. 199 200 procedure Check_Bad_Instantiation (N : Node_Id); 201 -- N is a node for an instantiation (if called with any other node kind, 202 -- Check_Bad_Instantiation ignores the call). This subprogram checks for 203 -- the special case of a generic instantiation of a generic spec in the 204 -- same declarative part as the instantiation where a body is present and 205 -- has not yet been seen. This is an obvious error, but needs to be checked 206 -- specially at the time of the instantiation, since it is a case where we 207 -- cannot insert the body anywhere. If this case is detected, warnings are 208 -- generated, and a raise of Program_Error is inserted. In addition any 209 -- subprograms in the generic spec are stubbed, and the Bad_Instantiation 210 -- flag is set on the instantiation node. The caller in Sem_Ch12 uses this 211 -- flag as an indication that no attempt should be made to insert an 212 -- instance body. 213 214 procedure Check_Internal_Call 215 (N : Node_Id; 216 E : Entity_Id; 217 Outer_Scope : Entity_Id; 218 Orig_Ent : Entity_Id); 219 -- N is a function call or procedure statement call node and E is the 220 -- entity of the called function, which is within the current compilation 221 -- unit (where subunits count as part of the parent). This call checks if 222 -- this call, or any call within any accessed body could cause an ABE, and 223 -- if so, outputs a warning. Orig_Ent differs from E only in the case of 224 -- renamings, and points to the original name of the entity. This is used 225 -- for error messages. Outer_Scope is the outer level scope for the 226 -- original call. 227 228 procedure Check_Internal_Call_Continue 229 (N : Node_Id; 230 E : Entity_Id; 231 Outer_Scope : Entity_Id; 232 Orig_Ent : Entity_Id); 233 -- The processing for Check_Internal_Call is divided up into two phases, 234 -- and this represents the second phase. The second phase is delayed if 235 -- Delaying_Elab_Calls is set to True. In this delayed case, the first 236 -- phase makes an entry in the Delay_Check table, which is processed when 237 -- Check_Elab_Calls is called. N, E and Orig_Ent are as for the call to 238 -- Check_Internal_Call. Outer_Scope is the outer level scope for the 239 -- original call. 240 241 function Has_Generic_Body (N : Node_Id) return Boolean; 242 -- N is a generic package instantiation node, and this routine determines 243 -- if this package spec does in fact have a generic body. If so, then 244 -- True is returned, otherwise False. Note that this is not at all the 245 -- same as checking if the unit requires a body, since it deals with 246 -- the case of optional bodies accurately (i.e. if a body is optional, 247 -- then it looks to see if a body is actually present). Note: this 248 -- function can only do a fully correct job if in generating code mode 249 -- where all bodies have to be present. If we are operating in semantics 250 -- check only mode, then in some cases of optional bodies, a result of 251 -- False may incorrectly be given. In practice this simply means that 252 -- some cases of warnings for incorrect order of elaboration will only 253 -- be given when generating code, which is not a big problem (and is 254 -- inevitable, given the optional body semantics of Ada). 255 256 procedure Insert_Elab_Check (N : Node_Id; C : Node_Id := Empty); 257 -- Given code for an elaboration check (or unconditional raise if the check 258 -- is not needed), inserts the code in the appropriate place. N is the call 259 -- or instantiation node for which the check code is required. C is the 260 -- test whose failure triggers the raise. 261 262 function Is_Finalization_Procedure (Id : Entity_Id) return Boolean; 263 -- Determine whether entity Id denotes a [Deep_]Finalize procedure 264 265 procedure Output_Calls (N : Node_Id); 266 -- Outputs chain of calls stored in the Elab_Call table. The caller has 267 -- already generated the main warning message, so the warnings generated 268 -- are all continuation messages. The argument is the call node at which 269 -- the messages are to be placed. 270 271 function Same_Elaboration_Scope (Scop1, Scop2 : Entity_Id) return Boolean; 272 -- Given two scopes, determine whether they are the same scope from an 273 -- elaboration point of view, i.e. packages and blocks are ignored. 274 275 procedure Set_C_Scope; 276 -- On entry C_Scope is set to some scope. On return, C_Scope is reset 277 -- to be the enclosing compilation unit of this scope. 278 279 function Get_Referenced_Ent (N : Node_Id) return Entity_Id; 280 -- N is either a function or procedure call or an access attribute that 281 -- references a subprogram. This call retrieves the relevant entity. If 282 -- this is a call to a protected subprogram, the entity is a selected 283 -- component. The callable entity may be absent, in which case Empty is 284 -- returned. This happens with non-analyzed calls in nested generics. 285 286 procedure Set_Elaboration_Constraint 287 (Call : Node_Id; 288 Subp : Entity_Id; 289 Scop : Entity_Id); 290 -- The current unit U may depend semantically on some unit P which is not 291 -- in the current context. If there is an elaboration call that reaches P, 292 -- we need to indicate that P requires an Elaborate_All, but this is not 293 -- effective in U's ali file, if there is no with_clause for P. In this 294 -- case we add the Elaborate_All on the unit Q that directly or indirectly 295 -- makes P available. This can happen in two cases: 296 -- 297 -- a) Q declares a subtype of a type declared in P, and the call is an 298 -- initialization call for an object of that subtype. 299 -- 300 -- b) Q declares an object of some tagged type whose root type is 301 -- declared in P, and the initialization call uses object notation on 302 -- that object to reach a primitive operation or a classwide operation 303 -- declared in P. 304 -- 305 -- If P appears in the context of U, the current processing is correct. 306 -- Otherwise we must identify these two cases to retrieve Q and place the 307 -- Elaborate_All_Desirable on it. 308 309 function Spec_Entity (E : Entity_Id) return Entity_Id; 310 -- Given a compilation unit entity, if it is a spec entity, it is returned 311 -- unchanged. If it is a body entity, then the spec for the corresponding 312 -- spec is returned 313 314 procedure Supply_Bodies (N : Node_Id); 315 -- Given a node, N, that is either a subprogram declaration or a package 316 -- declaration, this procedure supplies dummy bodies for the subprogram 317 -- or for all subprograms in the package. If the given node is not one 318 -- of these two possibilities, then Supply_Bodies does nothing. The 319 -- dummy body contains a single Raise statement. 320 321 procedure Supply_Bodies (L : List_Id); 322 -- Calls Supply_Bodies for all elements of the given list L 323 324 function Within (E1, E2 : Entity_Id) return Boolean; 325 -- Given two scopes E1 and E2, returns True if E1 is equal to E2, or is one 326 -- of its contained scopes, False otherwise. 327 328 function Within_Elaborate_All 329 (Unit : Unit_Number_Type; 330 E : Entity_Id) return Boolean; 331 -- Return True if we are within the scope of an Elaborate_All for E, or if 332 -- we are within the scope of an Elaborate_All for some other unit U, and U 333 -- with's E. This prevents spurious warnings when the called entity is 334 -- renamed within U, or in case of generic instances. 335 336 -------------------------------------- 337 -- Activate_Elaborate_All_Desirable -- 338 -------------------------------------- 339 340 procedure Activate_Elaborate_All_Desirable (N : Node_Id; U : Entity_Id) is 341 UN : constant Unit_Number_Type := Get_Code_Unit (N); 342 CU : constant Node_Id := Cunit (UN); 343 UE : constant Entity_Id := Cunit_Entity (UN); 344 Unm : constant Unit_Name_Type := Unit_Name (UN); 345 CI : constant List_Id := Context_Items (CU); 346 Itm : Node_Id; 347 Ent : Entity_Id; 348 349 procedure Add_To_Context_And_Mark (Itm : Node_Id); 350 -- This procedure is called when the elaborate indication must be 351 -- applied to a unit not in the context of the referencing unit. The 352 -- unit gets added to the context as an implicit with. 353 354 function In_Withs_Of (UEs : Entity_Id) return Boolean; 355 -- UEs is the spec entity of a unit. If the unit to be marked is 356 -- in the context item list of this unit spec, then the call returns 357 -- True and Itm is left set to point to the relevant N_With_Clause node. 358 359 procedure Set_Elab_Flag (Itm : Node_Id); 360 -- Sets Elaborate_[All_]Desirable as appropriate on Itm 361 362 ----------------------------- 363 -- Add_To_Context_And_Mark -- 364 ----------------------------- 365 366 procedure Add_To_Context_And_Mark (Itm : Node_Id) is 367 CW : constant Node_Id := 368 Make_With_Clause (Sloc (Itm), 369 Name => Name (Itm)); 370 371 begin 372 Set_Library_Unit (CW, Library_Unit (Itm)); 373 Set_Implicit_With (CW, True); 374 375 -- Set elaborate all desirable on copy and then append the copy to 376 -- the list of body with's and we are done. 377 378 Set_Elab_Flag (CW); 379 Append_To (CI, CW); 380 end Add_To_Context_And_Mark; 381 382 ----------------- 383 -- In_Withs_Of -- 384 ----------------- 385 386 function In_Withs_Of (UEs : Entity_Id) return Boolean is 387 UNs : constant Unit_Number_Type := Get_Source_Unit (UEs); 388 CUs : constant Node_Id := Cunit (UNs); 389 CIs : constant List_Id := Context_Items (CUs); 390 391 begin 392 Itm := First (CIs); 393 while Present (Itm) loop 394 if Nkind (Itm) = N_With_Clause then 395 Ent := 396 Cunit_Entity (Get_Cunit_Unit_Number (Library_Unit (Itm))); 397 398 if U = Ent then 399 return True; 400 end if; 401 end if; 402 403 Next (Itm); 404 end loop; 405 406 return False; 407 end In_Withs_Of; 408 409 ------------------- 410 -- Set_Elab_Flag -- 411 ------------------- 412 413 procedure Set_Elab_Flag (Itm : Node_Id) is 414 begin 415 if Nkind (N) in N_Subprogram_Instantiation then 416 Set_Elaborate_Desirable (Itm); 417 else 418 Set_Elaborate_All_Desirable (Itm); 419 end if; 420 end Set_Elab_Flag; 421 422 -- Start of processing for Activate_Elaborate_All_Desirable 423 424 begin 425 -- Do not set binder indication if expansion is disabled, as when 426 -- compiling a generic unit. 427 428 if not Expander_Active then 429 return; 430 end if; 431 432 Itm := First (CI); 433 while Present (Itm) loop 434 if Nkind (Itm) = N_With_Clause then 435 Ent := Cunit_Entity (Get_Cunit_Unit_Number (Library_Unit (Itm))); 436 437 -- If we find it, then mark elaborate all desirable and return 438 439 if U = Ent then 440 Set_Elab_Flag (Itm); 441 return; 442 end if; 443 end if; 444 445 Next (Itm); 446 end loop; 447 448 -- If we fall through then the with clause is not present in the 449 -- current unit. One legitimate possibility is that the with clause 450 -- is present in the spec when we are a body. 451 452 if Is_Body_Name (Unm) 453 and then In_Withs_Of (Spec_Entity (UE)) 454 then 455 Add_To_Context_And_Mark (Itm); 456 return; 457 end if; 458 459 -- Similarly, we may be in the spec or body of a child unit, where 460 -- the unit in question is with'ed by some ancestor of the child unit. 461 462 if Is_Child_Name (Unm) then 463 declare 464 Pkg : Entity_Id; 465 466 begin 467 Pkg := UE; 468 loop 469 Pkg := Scope (Pkg); 470 exit when Pkg = Standard_Standard; 471 472 if In_Withs_Of (Pkg) then 473 Add_To_Context_And_Mark (Itm); 474 return; 475 end if; 476 end loop; 477 end; 478 end if; 479 480 -- Here if we do not find with clause on spec or body. We just ignore 481 -- this case, it means that the elaboration involves some other unit 482 -- than the unit being compiled, and will be caught elsewhere. 483 484 null; 485 end Activate_Elaborate_All_Desirable; 486 487 ------------------ 488 -- Check_A_Call -- 489 ------------------ 490 491 procedure Check_A_Call 492 (N : Node_Id; 493 E : Entity_Id; 494 Outer_Scope : Entity_Id; 495 Inter_Unit_Only : Boolean; 496 Generate_Warnings : Boolean := True; 497 In_Init_Proc : Boolean := False) 498 is 499 Loc : constant Source_Ptr := Sloc (N); 500 Ent : Entity_Id; 501 Decl : Node_Id; 502 503 E_Scope : Entity_Id; 504 -- Top level scope of entity for called subprogram. This value includes 505 -- following renamings and derivations, so this scope can be in a 506 -- non-visible unit. This is the scope that is to be investigated to 507 -- see whether an elaboration check is required. 508 509 W_Scope : Entity_Id; 510 -- Top level scope of directly called entity for subprogram. This 511 -- differs from E_Scope in the case where renamings or derivations 512 -- are involved, since it does not follow these links. W_Scope is 513 -- generally in a visible unit, and it is this scope that may require 514 -- an Elaborate_All. However, there are some cases (initialization 515 -- calls and calls involving object notation) where W_Scope might not 516 -- be in the context of the current unit, and there is an intermediate 517 -- package that is, in which case the Elaborate_All has to be placed 518 -- on this intermediate package. These special cases are handled in 519 -- Set_Elaboration_Constraint. 520 521 Body_Acts_As_Spec : Boolean; 522 -- Set to true if call is to body acting as spec (no separate spec) 523 524 Inst_Case : constant Boolean := Nkind (N) in N_Generic_Instantiation; 525 -- Indicates if we have instantiation case 526 527 Access_Case : constant Boolean := Nkind (N) = N_Attribute_Reference; 528 -- Indicates if we have Access attribute case 529 530 Caller_Unit_Internal : Boolean; 531 Callee_Unit_Internal : Boolean; 532 533 Inst_Caller : Source_Ptr; 534 Inst_Callee : Source_Ptr; 535 536 Unit_Caller : Unit_Number_Type; 537 Unit_Callee : Unit_Number_Type; 538 539 Cunit_SC : Boolean := False; 540 -- Set to suppress dynamic elaboration checks where one of the 541 -- enclosing scopes has Elaboration_Checks_Suppressed set, or else 542 -- if a pragma Elaborate (_All) applies to that scope, in which case 543 -- warnings on the scope are also suppressed. For the internal case, 544 -- we ignore this flag. 545 546 begin 547 -- If the call is known to be within a local Suppress Elaboration 548 -- pragma, nothing to check. This can happen in task bodies. 549 550 if Nkind (N) in N_Subprogram_Call 551 and then No_Elaboration_Check (N) 552 then 553 return; 554 end if; 555 556 -- Go to parent for derived subprogram, or to original subprogram in the 557 -- case of a renaming (Alias covers both these cases). 558 559 Ent := E; 560 loop 561 if (Suppress_Elaboration_Warnings (Ent) 562 or else Elaboration_Checks_Suppressed (Ent)) 563 and then (Inst_Case or else No (Alias (Ent))) 564 then 565 return; 566 end if; 567 568 -- Nothing to do for imported entities 569 570 if Is_Imported (Ent) then 571 return; 572 end if; 573 574 exit when Inst_Case or else No (Alias (Ent)); 575 Ent := Alias (Ent); 576 end loop; 577 578 Decl := Unit_Declaration_Node (Ent); 579 580 if Nkind (Decl) = N_Subprogram_Body then 581 Body_Acts_As_Spec := True; 582 583 elsif Nkind (Decl) = N_Subprogram_Declaration 584 or else Nkind (Decl) = N_Subprogram_Body_Stub 585 or else Inst_Case 586 then 587 Body_Acts_As_Spec := False; 588 589 -- If we have none of an instantiation, subprogram body or 590 -- subprogram declaration, then it is not a case that we want 591 -- to check. (One case is a call to a generic formal subprogram, 592 -- where we do not want the check in the template). 593 594 else 595 return; 596 end if; 597 598 E_Scope := Ent; 599 loop 600 if Elaboration_Checks_Suppressed (E_Scope) 601 or else Suppress_Elaboration_Warnings (E_Scope) 602 then 603 Cunit_SC := True; 604 end if; 605 606 -- Exit when we get to compilation unit, not counting subunits 607 608 exit when Is_Compilation_Unit (E_Scope) 609 and then (Is_Child_Unit (E_Scope) 610 or else Scope (E_Scope) = Standard_Standard); 611 612 -- If we did not find a compilation unit, other than standard, 613 -- then nothing to check (happens in some instantiation cases) 614 615 if E_Scope = Standard_Standard then 616 return; 617 618 -- Otherwise move up a scope looking for compilation unit 619 620 else 621 E_Scope := Scope (E_Scope); 622 end if; 623 end loop; 624 625 -- No checks needed for pure or preelaborated compilation units 626 627 if Is_Pure (E_Scope) or else Is_Preelaborated (E_Scope) then 628 return; 629 end if; 630 631 -- If the generic entity is within a deeper instance than we are, then 632 -- either the instantiation to which we refer itself caused an ABE, in 633 -- which case that will be handled separately, or else we know that the 634 -- body we need appears as needed at the point of the instantiation. 635 -- However, this assumption is only valid if we are in static mode. 636 637 if not Dynamic_Elaboration_Checks 638 and then Instantiation_Depth (Sloc (Ent)) > 639 Instantiation_Depth (Sloc (N)) 640 then 641 return; 642 end if; 643 644 -- Do not give a warning for a package with no body 645 646 if Ekind (Ent) = E_Generic_Package 647 and then not Has_Generic_Body (N) 648 then 649 return; 650 end if; 651 652 -- Case of entity is not in current unit (i.e. with'ed unit case) 653 654 if E_Scope /= C_Scope then 655 656 -- We are only interested in such calls if the outer call was from 657 -- elaboration code, or if we are in Dynamic_Elaboration_Checks mode. 658 659 if not From_Elab_Code and then not Dynamic_Elaboration_Checks then 660 return; 661 end if; 662 663 -- Nothing to do if some scope said that no checks were required 664 665 if Cunit_SC then 666 return; 667 end if; 668 669 -- Nothing to do for a generic instance, because in this case the 670 -- checking was at the point of instantiation of the generic However, 671 -- this shortcut is only applicable in static mode. 672 673 if Is_Generic_Instance (Ent) and not Dynamic_Elaboration_Checks then 674 return; 675 end if; 676 677 -- Nothing to do if subprogram with no separate spec. However, a 678 -- call to Deep_Initialize may result in a call to a user-defined 679 -- Initialize procedure, which imposes a body dependency. This 680 -- happens only if the type is controlled and the Initialize 681 -- procedure is not inherited. 682 683 if Body_Acts_As_Spec then 684 if Is_TSS (Ent, TSS_Deep_Initialize) then 685 declare 686 Typ : constant Entity_Id := Etype (First_Formal (Ent)); 687 Init : Entity_Id; 688 689 begin 690 if not Is_Controlled (Typ) then 691 return; 692 else 693 Init := Find_Prim_Op (Typ, Name_Initialize); 694 695 if Comes_From_Source (Init) then 696 Ent := Init; 697 else 698 return; 699 end if; 700 end if; 701 end; 702 703 else 704 return; 705 end if; 706 end if; 707 708 -- Check cases of internal units 709 710 Callee_Unit_Internal := 711 Is_Internal_File_Name 712 (Unit_File_Name (Get_Source_Unit (E_Scope))); 713 714 -- Do not give a warning if the with'ed unit is internal and this is 715 -- the generic instantiation case (this saves a lot of hassle dealing 716 -- with the Text_IO special child units) 717 718 if Callee_Unit_Internal and Inst_Case then 719 return; 720 end if; 721 722 if C_Scope = Standard_Standard then 723 Caller_Unit_Internal := False; 724 else 725 Caller_Unit_Internal := 726 Is_Internal_File_Name 727 (Unit_File_Name (Get_Source_Unit (C_Scope))); 728 end if; 729 730 -- Do not give a warning if the with'ed unit is internal and the 731 -- caller is not internal (since the binder always elaborates 732 -- internal units first). 733 734 if Callee_Unit_Internal and (not Caller_Unit_Internal) then 735 return; 736 end if; 737 738 -- For now, if debug flag -gnatdE is not set, do no checking for 739 -- one internal unit withing another. This fixes the problem with 740 -- the sgi build and storage errors. To be resolved later ??? 741 742 if (Callee_Unit_Internal and Caller_Unit_Internal) 743 and then not Debug_Flag_EE 744 then 745 return; 746 end if; 747 748 if Is_TSS (E, TSS_Deep_Initialize) then 749 Ent := E; 750 end if; 751 752 -- If the call is in an instance, and the called entity is not 753 -- defined in the same instance, then the elaboration issue focuses 754 -- around the unit containing the template, it is this unit which 755 -- requires an Elaborate_All. 756 757 -- However, if we are doing dynamic elaboration, we need to chase the 758 -- call in the usual manner. 759 760 -- We do not handle the case of calling a generic formal correctly in 761 -- the static case.??? 762 763 Inst_Caller := Instantiation (Get_Source_File_Index (Sloc (N))); 764 Inst_Callee := Instantiation (Get_Source_File_Index (Sloc (Ent))); 765 766 if Inst_Caller = No_Location then 767 Unit_Caller := No_Unit; 768 else 769 Unit_Caller := Get_Source_Unit (N); 770 end if; 771 772 if Inst_Callee = No_Location then 773 Unit_Callee := No_Unit; 774 else 775 Unit_Callee := Get_Source_Unit (Ent); 776 end if; 777 778 if Unit_Caller /= No_Unit 779 and then Unit_Callee /= Unit_Caller 780 and then not Dynamic_Elaboration_Checks 781 then 782 E_Scope := Spec_Entity (Cunit_Entity (Unit_Caller)); 783 784 -- If we don't get a spec entity, just ignore call. Not quite 785 -- clear why this check is necessary. ??? 786 787 if No (E_Scope) then 788 return; 789 end if; 790 791 -- Otherwise step to enclosing compilation unit 792 793 while not Is_Compilation_Unit (E_Scope) loop 794 E_Scope := Scope (E_Scope); 795 end loop; 796 797 -- For the case N is not an instance, or a call within instance, we 798 -- recompute E_Scope for the error message, since we do NOT want to 799 -- go to the unit which has the ultimate declaration in the case of 800 -- renaming and derivation and we also want to go to the generic unit 801 -- in the case of an instance, and no further. 802 803 else 804 -- Loop to carefully follow renamings and derivations one step 805 -- outside the current unit, but not further. 806 807 if not Inst_Case 808 and then Present (Alias (Ent)) 809 then 810 E_Scope := Alias (Ent); 811 else 812 E_Scope := Ent; 813 end if; 814 815 loop 816 while not Is_Compilation_Unit (E_Scope) loop 817 E_Scope := Scope (E_Scope); 818 end loop; 819 820 -- If E_Scope is the same as C_Scope, it means that there 821 -- definitely was a local renaming or derivation, and we 822 -- are not yet out of the current unit. 823 824 exit when E_Scope /= C_Scope; 825 Ent := Alias (Ent); 826 E_Scope := Ent; 827 828 -- If no alias, there is a previous error 829 830 if No (Ent) then 831 Check_Error_Detected; 832 return; 833 end if; 834 end loop; 835 end if; 836 837 if Within_Elaborate_All (Current_Sem_Unit, E_Scope) then 838 return; 839 end if; 840 841 -- Find top level scope for called entity (not following renamings 842 -- or derivations). This is where the Elaborate_All will go if it 843 -- is needed. We start with the called entity, except in the case 844 -- of an initialization procedure outside the current package, where 845 -- the init proc is in the root package, and we start from the entity 846 -- of the name in the call. 847 848 declare 849 Ent : constant Entity_Id := Get_Referenced_Ent (N); 850 begin 851 if Is_Init_Proc (Ent) 852 and then not In_Same_Extended_Unit (N, Ent) 853 then 854 W_Scope := Scope (Ent); 855 else 856 W_Scope := E; 857 end if; 858 end; 859 860 -- Now loop through scopes to get to the enclosing compilation unit 861 862 while not Is_Compilation_Unit (W_Scope) loop 863 W_Scope := Scope (W_Scope); 864 end loop; 865 866 -- Now check if an elaborate_all (or dynamic check) is needed 867 868 if not Suppress_Elaboration_Warnings (Ent) 869 and then not Elaboration_Checks_Suppressed (Ent) 870 and then not Suppress_Elaboration_Warnings (E_Scope) 871 and then not Elaboration_Checks_Suppressed (E_Scope) 872 and then Elab_Warnings 873 and then Generate_Warnings 874 then 875 Generate_Elab_Warnings : declare 876 procedure Elab_Warning 877 (Msg_D : String; 878 Msg_S : String; 879 Ent : Node_Or_Entity_Id); 880 -- Generate a call to Error_Msg_NE with parameters Msg_D or 881 -- Msg_S (for dynamic or static elaboration model), N and Ent. 882 -- Msg_D is suppressed for the attribute reference case, since 883 -- we never raise Program_Error for an attribute reference. 884 885 ------------------ 886 -- Elab_Warning -- 887 ------------------ 888 889 procedure Elab_Warning 890 (Msg_D : String; 891 Msg_S : String; 892 Ent : Node_Or_Entity_Id) 893 is 894 begin 895 if Dynamic_Elaboration_Checks then 896 if not Access_Case then 897 Error_Msg_NE (Msg_D, N, Ent); 898 end if; 899 else 900 Error_Msg_NE (Msg_S, N, Ent); 901 end if; 902 end Elab_Warning; 903 904 -- Start of processing for Generate_Elab_Warnings 905 906 begin 907 -- Instantiation case 908 909 if Inst_Case then 910 Elab_Warning 911 ("instantiation of& may raise Program_Error?l?", 912 "info: instantiation of& during elaboration?l?", Ent); 913 914 -- Indirect call case, warning only in static elaboration 915 -- case, because the attribute reference itself cannot raise 916 -- an exception. 917 918 elsif Access_Case then 919 Elab_Warning 920 ("", "info: access to& during elaboration?l?", Ent); 921 922 -- Subprogram call case 923 924 else 925 if Nkind (Name (N)) in N_Has_Entity 926 and then Is_Init_Proc (Entity (Name (N))) 927 and then Comes_From_Source (Ent) 928 then 929 Elab_Warning 930 ("implicit call to & may raise Program_Error?l?", 931 "info: implicit call to & during elaboration?l?", 932 Ent); 933 934 else 935 Elab_Warning 936 ("call to & may raise Program_Error?l?", 937 "info: call to & during elaboration?l?", 938 Ent); 939 end if; 940 end if; 941 942 Error_Msg_Qual_Level := Nat'Last; 943 944 if Nkind (N) in N_Subprogram_Instantiation then 945 Elab_Warning 946 ("\missing pragma Elaborate for&?l?", 947 "\info: implicit pragma Elaborate for& generated?l?", 948 W_Scope); 949 950 else 951 Elab_Warning 952 ("\missing pragma Elaborate_All for&?l?", 953 "\info: implicit pragma Elaborate_All for & generated?l?", 954 W_Scope); 955 end if; 956 end Generate_Elab_Warnings; 957 958 Error_Msg_Qual_Level := 0; 959 Output_Calls (N); 960 961 -- Set flag to prevent further warnings for same unit unless in 962 -- All_Errors_Mode. 963 964 if not All_Errors_Mode and not Dynamic_Elaboration_Checks then 965 Set_Suppress_Elaboration_Warnings (W_Scope, True); 966 end if; 967 end if; 968 969 -- Check for runtime elaboration check required 970 971 if Dynamic_Elaboration_Checks then 972 if not Elaboration_Checks_Suppressed (Ent) 973 and then not Elaboration_Checks_Suppressed (W_Scope) 974 and then not Elaboration_Checks_Suppressed (E_Scope) 975 and then not Cunit_SC 976 then 977 -- Runtime elaboration check required. Generate check of the 978 -- elaboration Boolean for the unit containing the entity. 979 980 -- Note that for this case, we do check the real unit (the one 981 -- from following renamings, since that is the issue!) 982 983 -- Could this possibly miss a useless but required PE??? 984 985 Insert_Elab_Check (N, 986 Make_Attribute_Reference (Loc, 987 Attribute_Name => Name_Elaborated, 988 Prefix => 989 New_Occurrence_Of (Spec_Entity (E_Scope), Loc))); 990 991 -- Prevent duplicate elaboration checks on the same call, 992 -- which can happen if the body enclosing the call appears 993 -- itself in a call whose elaboration check is delayed. 994 995 if Nkind (N) in N_Subprogram_Call then 996 Set_No_Elaboration_Check (N); 997 end if; 998 end if; 999 1000 -- Case of static elaboration model 1001 1002 else 1003 -- Do not do anything if elaboration checks suppressed. Note that 1004 -- we check Ent here, not E, since we want the real entity for the 1005 -- body to see if checks are suppressed for it, not the dummy 1006 -- entry for renamings or derivations. 1007 1008 if Elaboration_Checks_Suppressed (Ent) 1009 or else Elaboration_Checks_Suppressed (E_Scope) 1010 or else Elaboration_Checks_Suppressed (W_Scope) 1011 then 1012 null; 1013 1014 -- Do not generate an Elaborate_All for finalization routines 1015 -- which perform partial clean up as part of initialization. 1016 1017 elsif In_Init_Proc and then Is_Finalization_Procedure (Ent) then 1018 null; 1019 1020 -- Here we need to generate an implicit elaborate all 1021 1022 else 1023 -- Generate elaborate_all warning unless suppressed 1024 1025 if (Elab_Warnings and Generate_Warnings and not Inst_Case) 1026 and then not Suppress_Elaboration_Warnings (Ent) 1027 and then not Suppress_Elaboration_Warnings (E_Scope) 1028 and then not Suppress_Elaboration_Warnings (W_Scope) 1029 then 1030 Error_Msg_Node_2 := W_Scope; 1031 Error_Msg_NE 1032 ("call to& in elaboration code " & 1033 "requires pragma Elaborate_All on&?l?", N, E); 1034 end if; 1035 1036 -- Set indication for binder to generate Elaborate_All 1037 1038 Set_Elaboration_Constraint (N, E, W_Scope); 1039 end if; 1040 end if; 1041 1042 -- Case of entity is in same unit as call or instantiation 1043 1044 elsif not Inter_Unit_Only then 1045 Check_Internal_Call (N, Ent, Outer_Scope, E); 1046 end if; 1047 end Check_A_Call; 1048 1049 ----------------------------- 1050 -- Check_Bad_Instantiation -- 1051 ----------------------------- 1052 1053 procedure Check_Bad_Instantiation (N : Node_Id) is 1054 Ent : Entity_Id; 1055 1056 begin 1057 -- Nothing to do if we do not have an instantiation (happens in some 1058 -- error cases, and also in the formal package declaration case) 1059 1060 if Nkind (N) not in N_Generic_Instantiation then 1061 return; 1062 1063 -- Nothing to do if serious errors detected (avoid cascaded errors) 1064 1065 elsif Serious_Errors_Detected /= 0 then 1066 return; 1067 1068 -- Nothing to do if not in full analysis mode 1069 1070 elsif not Full_Analysis then 1071 return; 1072 1073 -- Nothing to do if inside a generic template 1074 1075 elsif Inside_A_Generic then 1076 return; 1077 1078 -- Nothing to do if a library level instantiation 1079 1080 elsif Nkind (Parent (N)) = N_Compilation_Unit then 1081 return; 1082 1083 -- Nothing to do if we are compiling a proper body for semantic 1084 -- purposes only. The generic body may be in another proper body. 1085 1086 elsif 1087 Nkind (Parent (Unit_Declaration_Node (Main_Unit_Entity))) = N_Subunit 1088 then 1089 return; 1090 end if; 1091 1092 Ent := Get_Generic_Entity (N); 1093 1094 -- The case we are interested in is when the generic spec is in the 1095 -- current declarative part 1096 1097 if not Same_Elaboration_Scope (Current_Scope, Scope (Ent)) 1098 or else not In_Same_Extended_Unit (N, Ent) 1099 then 1100 return; 1101 end if; 1102 1103 -- If the generic entity is within a deeper instance than we are, then 1104 -- either the instantiation to which we refer itself caused an ABE, in 1105 -- which case that will be handled separately. Otherwise, we know that 1106 -- the body we need appears as needed at the point of the instantiation. 1107 -- If they are both at the same level but not within the same instance 1108 -- then the body of the generic will be in the earlier instance. 1109 1110 declare 1111 D1 : constant Int := Instantiation_Depth (Sloc (Ent)); 1112 D2 : constant Int := Instantiation_Depth (Sloc (N)); 1113 1114 begin 1115 if D1 > D2 then 1116 return; 1117 1118 elsif D1 = D2 1119 and then Is_Generic_Instance (Scope (Ent)) 1120 and then not In_Open_Scopes (Scope (Ent)) 1121 then 1122 return; 1123 end if; 1124 end; 1125 1126 -- Now we can proceed, if the entity being called has a completion, 1127 -- then we are definitely OK, since we have already seen the body. 1128 1129 if Has_Completion (Ent) then 1130 return; 1131 end if; 1132 1133 -- If there is no body, then nothing to do 1134 1135 if not Has_Generic_Body (N) then 1136 return; 1137 end if; 1138 1139 -- Here we definitely have a bad instantiation 1140 1141 Error_Msg_NE ("??cannot instantiate& before body seen", N, Ent); 1142 1143 if Present (Instance_Spec (N)) then 1144 Supply_Bodies (Instance_Spec (N)); 1145 end if; 1146 1147 Error_Msg_N ("\??Program_Error will be raised at run time", N); 1148 Insert_Elab_Check (N); 1149 Set_ABE_Is_Certain (N); 1150 end Check_Bad_Instantiation; 1151 1152 --------------------- 1153 -- Check_Elab_Call -- 1154 --------------------- 1155 1156 procedure Check_Elab_Call 1157 (N : Node_Id; 1158 Outer_Scope : Entity_Id := Empty; 1159 In_Init_Proc : Boolean := False) 1160 is 1161 Ent : Entity_Id; 1162 P : Node_Id; 1163 1164 begin 1165 -- If the call does not come from the main unit, there is nothing to 1166 -- check. Elaboration call from units in the context of the main unit 1167 -- will lead to semantic dependencies when those units are compiled. 1168 1169 if not In_Extended_Main_Code_Unit (N) then 1170 return; 1171 end if; 1172 1173 -- For an entry call, check relevant restriction 1174 1175 if Nkind (N) = N_Entry_Call_Statement 1176 and then not In_Subprogram_Or_Concurrent_Unit 1177 then 1178 Check_Restriction (No_Entry_Calls_In_Elaboration_Code, N); 1179 1180 -- Nothing to do if this is not a call or attribute reference (happens 1181 -- in some error conditions, and in some cases where rewriting occurs). 1182 1183 elsif Nkind (N) not in N_Subprogram_Call 1184 and then Nkind (N) /= N_Attribute_Reference 1185 then 1186 return; 1187 1188 -- Nothing to do if this is a call already rewritten for elab checking 1189 1190 elsif Nkind (Parent (N)) = N_If_Expression then 1191 return; 1192 1193 -- Nothing to do if inside a generic template 1194 1195 elsif Inside_A_Generic 1196 and then No (Enclosing_Generic_Body (N)) 1197 then 1198 return; 1199 end if; 1200 1201 -- Here we have a call at elaboration time which must be checked 1202 1203 if Debug_Flag_LL then 1204 Write_Str (" Check_Elab_Call: "); 1205 1206 if Nkind (N) = N_Attribute_Reference then 1207 if not Is_Entity_Name (Prefix (N)) then 1208 Write_Str ("<<not entity name>>"); 1209 else 1210 Write_Name (Chars (Entity (Prefix (N)))); 1211 end if; 1212 Write_Str ("'Access"); 1213 1214 elsif No (Name (N)) or else not Is_Entity_Name (Name (N)) then 1215 Write_Str ("<<not entity name>> "); 1216 1217 else 1218 Write_Name (Chars (Entity (Name (N)))); 1219 end if; 1220 1221 Write_Str (" call at "); 1222 Write_Location (Sloc (N)); 1223 Write_Eol; 1224 end if; 1225 1226 -- Climb up the tree to make sure we are not inside default expression 1227 -- of a parameter specification or a record component, since in both 1228 -- these cases, we will be doing the actual call later, not now, and it 1229 -- is at the time of the actual call (statically speaking) that we must 1230 -- do our static check, not at the time of its initial analysis). 1231 1232 -- However, we have to check calls within component definitions (e.g. 1233 -- a function call that determines an array component bound), so we 1234 -- terminate the loop in that case. 1235 1236 P := Parent (N); 1237 while Present (P) loop 1238 if Nkind_In (P, N_Parameter_Specification, 1239 N_Component_Declaration) 1240 then 1241 return; 1242 1243 -- The call occurs within the constraint of a component, 1244 -- so it must be checked. 1245 1246 elsif Nkind (P) = N_Component_Definition then 1247 exit; 1248 1249 else 1250 P := Parent (P); 1251 end if; 1252 end loop; 1253 1254 -- Stuff that happens only at the outer level 1255 1256 if No (Outer_Scope) then 1257 Elab_Visited.Set_Last (0); 1258 1259 -- Nothing to do if current scope is Standard (this is a bit odd, but 1260 -- it happens in the case of generic instantiations). 1261 1262 C_Scope := Current_Scope; 1263 1264 if C_Scope = Standard_Standard then 1265 return; 1266 end if; 1267 1268 -- First case, we are in elaboration code 1269 1270 From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit; 1271 if From_Elab_Code then 1272 1273 -- Complain if call that comes from source in preelaborated unit 1274 -- and we are not inside a subprogram (i.e. we are in elab code). 1275 1276 if Comes_From_Source (N) 1277 and then In_Preelaborated_Unit 1278 and then not In_Inlined_Body 1279 and then Nkind (N) /= N_Attribute_Reference 1280 then 1281 -- This is a warning in GNAT mode allowing such calls to be 1282 -- used in the predefined library with appropriate care. 1283 1284 Error_Msg_Warn := GNAT_Mode; 1285 Error_Msg_N 1286 ("<non-static call not allowed in preelaborated unit", N); 1287 return; 1288 end if; 1289 1290 -- Second case, we are inside a subprogram or concurrent unit, which 1291 -- means we are not in elaboration code. 1292 1293 else 1294 -- In this case, the issue is whether we are inside the 1295 -- declarative part of the unit in which we live, or inside its 1296 -- statements. In the latter case, there is no issue of ABE calls 1297 -- at this level (a call from outside to the unit in which we live 1298 -- might cause an ABE, but that will be detected when we analyze 1299 -- that outer level call, as it recurses into the called unit). 1300 1301 -- Climb up the tree, doing this test, and also testing for being 1302 -- inside a default expression, which, as discussed above, is not 1303 -- checked at this stage. 1304 1305 declare 1306 P : Node_Id; 1307 L : List_Id; 1308 1309 begin 1310 P := N; 1311 loop 1312 -- If we find a parentless subtree, it seems safe to assume 1313 -- that we are not in a declarative part and that no 1314 -- checking is required. 1315 1316 if No (P) then 1317 return; 1318 end if; 1319 1320 if Is_List_Member (P) then 1321 L := List_Containing (P); 1322 P := Parent (L); 1323 else 1324 L := No_List; 1325 P := Parent (P); 1326 end if; 1327 1328 exit when Nkind (P) = N_Subunit; 1329 1330 -- Filter out case of default expressions, where we do not 1331 -- do the check at this stage. 1332 1333 if Nkind (P) = N_Parameter_Specification 1334 or else 1335 Nkind (P) = N_Component_Declaration 1336 then 1337 return; 1338 end if; 1339 1340 -- A protected body has no elaboration code and contains 1341 -- only other bodies. 1342 1343 if Nkind (P) = N_Protected_Body then 1344 return; 1345 1346 elsif Nkind (P) = N_Subprogram_Body 1347 or else 1348 Nkind (P) = N_Task_Body 1349 or else 1350 Nkind (P) = N_Block_Statement 1351 or else 1352 Nkind (P) = N_Entry_Body 1353 then 1354 if L = Declarations (P) then 1355 exit; 1356 1357 -- We are not in elaboration code, but we are doing 1358 -- dynamic elaboration checks, in this case, we still 1359 -- need to do the call, since the subprogram we are in 1360 -- could be called from another unit, also in dynamic 1361 -- elaboration check mode, at elaboration time. 1362 1363 elsif Dynamic_Elaboration_Checks then 1364 1365 -- We provide a debug flag to disable this check. That 1366 -- way we have an easy work around for regressions 1367 -- that are caused by this new check. This debug flag 1368 -- can be removed later. 1369 1370 if Debug_Flag_DD then 1371 return; 1372 end if; 1373 1374 -- Do the check in this case 1375 1376 exit; 1377 1378 elsif Nkind (P) = N_Task_Body then 1379 1380 -- The check is deferred until Check_Task_Activation 1381 -- but we need to capture local suppress pragmas 1382 -- that may inhibit checks on this call. 1383 1384 Ent := Get_Referenced_Ent (N); 1385 1386 if No (Ent) then 1387 return; 1388 1389 elsif Elaboration_Checks_Suppressed (Current_Scope) 1390 or else Elaboration_Checks_Suppressed (Ent) 1391 or else Elaboration_Checks_Suppressed (Scope (Ent)) 1392 then 1393 Set_No_Elaboration_Check (N); 1394 end if; 1395 1396 return; 1397 1398 -- Static model, call is not in elaboration code, we 1399 -- never need to worry, because in the static model the 1400 -- top level caller always takes care of things. 1401 1402 else 1403 return; 1404 end if; 1405 end if; 1406 end loop; 1407 end; 1408 end if; 1409 end if; 1410 1411 Ent := Get_Referenced_Ent (N); 1412 1413 if No (Ent) then 1414 return; 1415 end if; 1416 1417 -- Nothing to do if this is a recursive call (i.e. a call to 1418 -- an entity that is already in the Elab_Call stack) 1419 1420 for J in 1 .. Elab_Visited.Last loop 1421 if Ent = Elab_Visited.Table (J) then 1422 return; 1423 end if; 1424 end loop; 1425 1426 -- See if we need to analyze this call. We analyze it if either of 1427 -- the following conditions is met: 1428 1429 -- It is an inner level call (since in this case it was triggered 1430 -- by an outer level call from elaboration code), but only if the 1431 -- call is within the scope of the original outer level call. 1432 1433 -- It is an outer level call from elaboration code, or the called 1434 -- entity is in the same elaboration scope. 1435 1436 -- And in these cases, we will check both inter-unit calls and 1437 -- intra-unit (within a single unit) calls. 1438 1439 C_Scope := Current_Scope; 1440 1441 -- If not outer level call, then we follow it if it is within the 1442 -- original scope of the outer call. 1443 1444 if Present (Outer_Scope) 1445 and then Within (Scope (Ent), Outer_Scope) 1446 then 1447 Set_C_Scope; 1448 Check_A_Call 1449 (N => N, 1450 E => Ent, 1451 Outer_Scope => Outer_Scope, 1452 Inter_Unit_Only => False, 1453 In_Init_Proc => In_Init_Proc); 1454 1455 elsif Elaboration_Checks_Suppressed (Current_Scope) then 1456 null; 1457 1458 elsif From_Elab_Code then 1459 Set_C_Scope; 1460 Check_A_Call (N, Ent, Standard_Standard, Inter_Unit_Only => False); 1461 1462 elsif Same_Elaboration_Scope (C_Scope, Scope (Ent)) then 1463 Set_C_Scope; 1464 Check_A_Call (N, Ent, Scope (Ent), Inter_Unit_Only => False); 1465 1466 -- If none of those cases holds, but Dynamic_Elaboration_Checks mode 1467 -- is set, then we will do the check, but only in the inter-unit case 1468 -- (this is to accommodate unguarded elaboration calls from other units 1469 -- in which this same mode is set). We don't want warnings in this case, 1470 -- it would generate warnings having nothing to do with elaboration. 1471 1472 elsif Dynamic_Elaboration_Checks then 1473 Set_C_Scope; 1474 Check_A_Call 1475 (N, 1476 Ent, 1477 Standard_Standard, 1478 Inter_Unit_Only => True, 1479 Generate_Warnings => False); 1480 1481 -- Otherwise nothing to do 1482 1483 else 1484 return; 1485 end if; 1486 1487 -- A call to an Init_Proc in elaboration code may bring additional 1488 -- dependencies, if some of the record components thereof have 1489 -- initializations that are function calls that come from source. We 1490 -- treat the current node as a call to each of these functions, to check 1491 -- their elaboration impact. 1492 1493 if Is_Init_Proc (Ent) 1494 and then From_Elab_Code 1495 then 1496 Process_Init_Proc : declare 1497 Unit_Decl : constant Node_Id := Unit_Declaration_Node (Ent); 1498 1499 function Check_Init_Call (Nod : Node_Id) return Traverse_Result; 1500 -- Find subprogram calls within body of Init_Proc for Traverse 1501 -- instantiation below. 1502 1503 procedure Traverse_Body is new Traverse_Proc (Check_Init_Call); 1504 -- Traversal procedure to find all calls with body of Init_Proc 1505 1506 --------------------- 1507 -- Check_Init_Call -- 1508 --------------------- 1509 1510 function Check_Init_Call (Nod : Node_Id) return Traverse_Result is 1511 Func : Entity_Id; 1512 1513 begin 1514 if Nkind (Nod) in N_Subprogram_Call 1515 and then Is_Entity_Name (Name (Nod)) 1516 then 1517 Func := Entity (Name (Nod)); 1518 1519 if Comes_From_Source (Func) then 1520 Check_A_Call 1521 (N, Func, Standard_Standard, Inter_Unit_Only => True); 1522 end if; 1523 1524 return OK; 1525 1526 else 1527 return OK; 1528 end if; 1529 end Check_Init_Call; 1530 1531 -- Start of processing for Process_Init_Proc 1532 1533 begin 1534 if Nkind (Unit_Decl) = N_Subprogram_Body then 1535 Traverse_Body (Handled_Statement_Sequence (Unit_Decl)); 1536 end if; 1537 end Process_Init_Proc; 1538 end if; 1539 end Check_Elab_Call; 1540 1541 ----------------------- 1542 -- Check_Elab_Assign -- 1543 ----------------------- 1544 1545 procedure Check_Elab_Assign (N : Node_Id) is 1546 Ent : Entity_Id; 1547 Scop : Entity_Id; 1548 1549 Pkg_Spec : Entity_Id; 1550 Pkg_Body : Entity_Id; 1551 1552 begin 1553 -- For record or array component, check prefix. If it is an access type, 1554 -- then there is nothing to do (we do not know what is being assigned), 1555 -- but otherwise this is an assignment to the prefix. 1556 1557 if Nkind (N) = N_Indexed_Component 1558 or else 1559 Nkind (N) = N_Selected_Component 1560 or else 1561 Nkind (N) = N_Slice 1562 then 1563 if not Is_Access_Type (Etype (Prefix (N))) then 1564 Check_Elab_Assign (Prefix (N)); 1565 end if; 1566 1567 return; 1568 end if; 1569 1570 -- For type conversion, check expression 1571 1572 if Nkind (N) = N_Type_Conversion then 1573 Check_Elab_Assign (Expression (N)); 1574 return; 1575 end if; 1576 1577 -- Nothing to do if this is not an entity reference otherwise get entity 1578 1579 if Is_Entity_Name (N) then 1580 Ent := Entity (N); 1581 else 1582 return; 1583 end if; 1584 1585 -- What we are looking for is a reference in the body of a package that 1586 -- modifies a variable declared in the visible part of the package spec. 1587 1588 if Present (Ent) 1589 and then Comes_From_Source (N) 1590 and then not Suppress_Elaboration_Warnings (Ent) 1591 and then Ekind (Ent) = E_Variable 1592 and then not In_Private_Part (Ent) 1593 and then Is_Library_Level_Entity (Ent) 1594 then 1595 Scop := Current_Scope; 1596 loop 1597 if No (Scop) or else Scop = Standard_Standard then 1598 return; 1599 elsif Ekind (Scop) = E_Package 1600 and then Is_Compilation_Unit (Scop) 1601 then 1602 exit; 1603 else 1604 Scop := Scope (Scop); 1605 end if; 1606 end loop; 1607 1608 -- Here Scop points to the containing library package 1609 1610 Pkg_Spec := Scop; 1611 Pkg_Body := Body_Entity (Pkg_Spec); 1612 1613 -- All OK if the package has an Elaborate_Body pragma 1614 1615 if Has_Pragma_Elaborate_Body (Scop) then 1616 return; 1617 end if; 1618 1619 -- OK if entity being modified is not in containing package spec 1620 1621 if not In_Same_Source_Unit (Scop, Ent) then 1622 return; 1623 end if; 1624 1625 -- All OK if entity appears in generic package or generic instance. 1626 -- We just get too messed up trying to give proper warnings in the 1627 -- presence of generics. Better no message than a junk one. 1628 1629 Scop := Scope (Ent); 1630 while Present (Scop) and then Scop /= Pkg_Spec loop 1631 if Ekind (Scop) = E_Generic_Package then 1632 return; 1633 elsif Ekind (Scop) = E_Package 1634 and then Is_Generic_Instance (Scop) 1635 then 1636 return; 1637 end if; 1638 1639 Scop := Scope (Scop); 1640 end loop; 1641 1642 -- All OK if in task, don't issue warnings there 1643 1644 if In_Task_Activation then 1645 return; 1646 end if; 1647 1648 -- OK if no package body 1649 1650 if No (Pkg_Body) then 1651 return; 1652 end if; 1653 1654 -- OK if reference is not in package body 1655 1656 if not In_Same_Source_Unit (Pkg_Body, N) then 1657 return; 1658 end if; 1659 1660 -- OK if package body has no handled statement sequence 1661 1662 declare 1663 HSS : constant Node_Id := 1664 Handled_Statement_Sequence (Declaration_Node (Pkg_Body)); 1665 begin 1666 if No (HSS) or else not Comes_From_Source (HSS) then 1667 return; 1668 end if; 1669 end; 1670 1671 -- We definitely have a case of a modification of an entity in 1672 -- the package spec from the elaboration code of the package body. 1673 -- We may not give the warning (because there are some additional 1674 -- checks to avoid too many false positives), but it would be a good 1675 -- idea for the binder to try to keep the body elaboration close to 1676 -- the spec elaboration. 1677 1678 Set_Elaborate_Body_Desirable (Pkg_Spec); 1679 1680 -- All OK in gnat mode (we know what we are doing) 1681 1682 if GNAT_Mode then 1683 return; 1684 end if; 1685 1686 -- All OK if all warnings suppressed 1687 1688 if Warning_Mode = Suppress then 1689 return; 1690 end if; 1691 1692 -- All OK if elaboration checks suppressed for entity 1693 1694 if Checks_May_Be_Suppressed (Ent) 1695 and then Is_Check_Suppressed (Ent, Elaboration_Check) 1696 then 1697 return; 1698 end if; 1699 1700 -- OK if the entity is initialized. Note that the No_Initialization 1701 -- flag usually means that the initialization has been rewritten into 1702 -- assignments, but that still counts for us. 1703 1704 declare 1705 Decl : constant Node_Id := Declaration_Node (Ent); 1706 begin 1707 if Nkind (Decl) = N_Object_Declaration 1708 and then (Present (Expression (Decl)) 1709 or else No_Initialization (Decl)) 1710 then 1711 return; 1712 end if; 1713 end; 1714 1715 -- Here is where we give the warning 1716 1717 -- All OK if warnings suppressed on the entity 1718 1719 if not Has_Warnings_Off (Ent) then 1720 Error_Msg_Sloc := Sloc (Ent); 1721 1722 Error_Msg_NE 1723 ("??elaboration code may access& before it is initialized", 1724 N, Ent); 1725 Error_Msg_NE 1726 ("\??suggest adding pragma Elaborate_Body to spec of &", 1727 N, Scop); 1728 Error_Msg_N 1729 ("\??or an explicit initialization could be added #", N); 1730 end if; 1731 1732 if not All_Errors_Mode then 1733 Set_Suppress_Elaboration_Warnings (Ent); 1734 end if; 1735 end if; 1736 end Check_Elab_Assign; 1737 1738 ---------------------- 1739 -- Check_Elab_Calls -- 1740 ---------------------- 1741 1742 procedure Check_Elab_Calls is 1743 begin 1744 -- If expansion is disabled, do not generate any checks. Also skip 1745 -- checks if any subunits are missing because in either case we lack the 1746 -- full information that we need, and no object file will be created in 1747 -- any case. 1748 1749 if not Expander_Active 1750 or else Is_Generic_Unit (Cunit_Entity (Main_Unit)) 1751 or else Subunits_Missing 1752 then 1753 return; 1754 end if; 1755 1756 -- Skip delayed calls if we had any errors 1757 1758 if Serious_Errors_Detected = 0 then 1759 Delaying_Elab_Checks := False; 1760 Expander_Mode_Save_And_Set (True); 1761 1762 for J in Delay_Check.First .. Delay_Check.Last loop 1763 Push_Scope (Delay_Check.Table (J).Curscop); 1764 From_Elab_Code := Delay_Check.Table (J).From_Elab_Code; 1765 1766 Check_Internal_Call_Continue ( 1767 N => Delay_Check.Table (J).N, 1768 E => Delay_Check.Table (J).E, 1769 Outer_Scope => Delay_Check.Table (J).Outer_Scope, 1770 Orig_Ent => Delay_Check.Table (J).Orig_Ent); 1771 1772 Pop_Scope; 1773 end loop; 1774 1775 -- Set Delaying_Elab_Checks back on for next main compilation 1776 1777 Expander_Mode_Restore; 1778 Delaying_Elab_Checks := True; 1779 end if; 1780 end Check_Elab_Calls; 1781 1782 ------------------------------ 1783 -- Check_Elab_Instantiation -- 1784 ------------------------------ 1785 1786 procedure Check_Elab_Instantiation 1787 (N : Node_Id; 1788 Outer_Scope : Entity_Id := Empty) 1789 is 1790 Ent : Entity_Id; 1791 1792 begin 1793 -- Check for and deal with bad instantiation case. There is some 1794 -- duplicated code here, but we will worry about this later ??? 1795 1796 Check_Bad_Instantiation (N); 1797 1798 if ABE_Is_Certain (N) then 1799 return; 1800 end if; 1801 1802 -- Nothing to do if we do not have an instantiation (happens in some 1803 -- error cases, and also in the formal package declaration case) 1804 1805 if Nkind (N) not in N_Generic_Instantiation then 1806 return; 1807 end if; 1808 1809 -- Nothing to do if inside a generic template 1810 1811 if Inside_A_Generic then 1812 return; 1813 end if; 1814 1815 -- Nothing to do if the instantiation is not in the main unit 1816 1817 if not In_Extended_Main_Code_Unit (N) then 1818 return; 1819 end if; 1820 1821 Ent := Get_Generic_Entity (N); 1822 From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit; 1823 1824 -- See if we need to analyze this instantiation. We analyze it if 1825 -- either of the following conditions is met: 1826 1827 -- It is an inner level instantiation (since in this case it was 1828 -- triggered by an outer level call from elaboration code), but 1829 -- only if the instantiation is within the scope of the original 1830 -- outer level call. 1831 1832 -- It is an outer level instantiation from elaboration code, or the 1833 -- instantiated entity is in the same elaboration scope. 1834 1835 -- And in these cases, we will check both the inter-unit case and 1836 -- the intra-unit (within a single unit) case. 1837 1838 C_Scope := Current_Scope; 1839 1840 if Present (Outer_Scope) 1841 and then Within (Scope (Ent), Outer_Scope) 1842 then 1843 Set_C_Scope; 1844 Check_A_Call (N, Ent, Outer_Scope, Inter_Unit_Only => False); 1845 1846 elsif From_Elab_Code then 1847 Set_C_Scope; 1848 Check_A_Call (N, Ent, Standard_Standard, Inter_Unit_Only => False); 1849 1850 elsif Same_Elaboration_Scope (C_Scope, Scope (Ent)) then 1851 Set_C_Scope; 1852 Check_A_Call (N, Ent, Scope (Ent), Inter_Unit_Only => False); 1853 1854 -- If none of those cases holds, but Dynamic_Elaboration_Checks mode is 1855 -- set, then we will do the check, but only in the inter-unit case (this 1856 -- is to accommodate unguarded elaboration calls from other units in 1857 -- which this same mode is set). We inhibit warnings in this case, since 1858 -- this instantiation is not occurring in elaboration code. 1859 1860 elsif Dynamic_Elaboration_Checks then 1861 Set_C_Scope; 1862 Check_A_Call 1863 (N, 1864 Ent, 1865 Standard_Standard, 1866 Inter_Unit_Only => True, 1867 Generate_Warnings => False); 1868 1869 else 1870 return; 1871 end if; 1872 end Check_Elab_Instantiation; 1873 1874 ------------------------- 1875 -- Check_Internal_Call -- 1876 ------------------------- 1877 1878 procedure Check_Internal_Call 1879 (N : Node_Id; 1880 E : Entity_Id; 1881 Outer_Scope : Entity_Id; 1882 Orig_Ent : Entity_Id) 1883 is 1884 Inst_Case : constant Boolean := Nkind (N) in N_Generic_Instantiation; 1885 1886 begin 1887 -- If not function or procedure call or instantiation, then ignore 1888 -- call (this happens in some error cases and rewriting cases). 1889 1890 if not Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement) 1891 and then not Inst_Case 1892 then 1893 return; 1894 1895 -- Nothing to do if this is a call or instantiation that has already 1896 -- been found to be a sure ABE. 1897 1898 elsif ABE_Is_Certain (N) then 1899 return; 1900 1901 -- Nothing to do if errors already detected (avoid cascaded errors) 1902 1903 elsif Serious_Errors_Detected /= 0 then 1904 return; 1905 1906 -- Nothing to do if not in full analysis mode 1907 1908 elsif not Full_Analysis then 1909 return; 1910 1911 -- Nothing to do if analyzing in special spec-expression mode, since the 1912 -- call is not actually being made at this time. 1913 1914 elsif In_Spec_Expression then 1915 return; 1916 1917 -- Nothing to do for call to intrinsic subprogram 1918 1919 elsif Is_Intrinsic_Subprogram (E) then 1920 return; 1921 1922 -- No need to trace local calls if checking task activation, because 1923 -- other local bodies are elaborated already. 1924 1925 elsif In_Task_Activation then 1926 return; 1927 1928 -- Nothing to do if call is within a generic unit 1929 1930 elsif Inside_A_Generic then 1931 return; 1932 end if; 1933 1934 -- Delay this call if we are still delaying calls 1935 1936 if Delaying_Elab_Checks then 1937 Delay_Check.Append ( 1938 (N => N, 1939 E => E, 1940 Orig_Ent => Orig_Ent, 1941 Curscop => Current_Scope, 1942 Outer_Scope => Outer_Scope, 1943 From_Elab_Code => From_Elab_Code)); 1944 return; 1945 1946 -- Otherwise, call phase 2 continuation right now 1947 1948 else 1949 Check_Internal_Call_Continue (N, E, Outer_Scope, Orig_Ent); 1950 end if; 1951 end Check_Internal_Call; 1952 1953 ---------------------------------- 1954 -- Check_Internal_Call_Continue -- 1955 ---------------------------------- 1956 1957 procedure Check_Internal_Call_Continue 1958 (N : Node_Id; 1959 E : Entity_Id; 1960 Outer_Scope : Entity_Id; 1961 Orig_Ent : Entity_Id) 1962 is 1963 Loc : constant Source_Ptr := Sloc (N); 1964 Inst_Case : constant Boolean := Is_Generic_Unit (E); 1965 1966 Sbody : Node_Id; 1967 Ebody : Entity_Id; 1968 1969 function Find_Elab_Reference (N : Node_Id) return Traverse_Result; 1970 -- Function applied to each node as we traverse the body. Checks for 1971 -- call or entity reference that needs checking, and if so checks it. 1972 -- Always returns OK, so entire tree is traversed, except that as 1973 -- described below subprogram bodies are skipped for now. 1974 1975 procedure Traverse is new Atree.Traverse_Proc (Find_Elab_Reference); 1976 -- Traverse procedure using above Find_Elab_Reference function 1977 1978 ------------------------- 1979 -- Find_Elab_Reference -- 1980 ------------------------- 1981 1982 function Find_Elab_Reference (N : Node_Id) return Traverse_Result is 1983 Actual : Node_Id; 1984 1985 begin 1986 -- If user has specified that there are no entry calls in elaboration 1987 -- code, do not trace past an accept statement, because the rendez- 1988 -- vous will happen after elaboration. 1989 1990 if (Nkind (Original_Node (N)) = N_Accept_Statement 1991 or else Nkind (Original_Node (N)) = N_Selective_Accept) 1992 and then Restriction_Active (No_Entry_Calls_In_Elaboration_Code) 1993 then 1994 return Abandon; 1995 1996 -- If we have a function call, check it 1997 1998 elsif Nkind (N) = N_Function_Call then 1999 Check_Elab_Call (N, Outer_Scope); 2000 return OK; 2001 2002 -- If we have a procedure call, check the call, and also check 2003 -- arguments that are assignments (OUT or IN OUT mode formals). 2004 2005 elsif Nkind (N) = N_Procedure_Call_Statement then 2006 Check_Elab_Call (N, Outer_Scope, In_Init_Proc => Is_Init_Proc (E)); 2007 2008 Actual := First_Actual (N); 2009 while Present (Actual) loop 2010 if Known_To_Be_Assigned (Actual) then 2011 Check_Elab_Assign (Actual); 2012 end if; 2013 2014 Next_Actual (Actual); 2015 end loop; 2016 2017 return OK; 2018 2019 -- If we have an access attribute for a subprogram, check 2020 -- it. Suppress this behavior under debug flag. 2021 2022 elsif not Debug_Flag_Dot_UU 2023 and then Nkind (N) = N_Attribute_Reference 2024 and then (Attribute_Name (N) = Name_Access 2025 or else 2026 Attribute_Name (N) = Name_Unrestricted_Access) 2027 and then Is_Entity_Name (Prefix (N)) 2028 and then Is_Subprogram (Entity (Prefix (N))) 2029 then 2030 Check_Elab_Call (N, Outer_Scope); 2031 return OK; 2032 2033 -- If we have a generic instantiation, check it 2034 2035 elsif Nkind (N) in N_Generic_Instantiation then 2036 Check_Elab_Instantiation (N, Outer_Scope); 2037 return OK; 2038 2039 -- Skip subprogram bodies that come from source (wait for call to 2040 -- analyze these). The reason for the come from source test is to 2041 -- avoid catching task bodies. 2042 2043 -- For task bodies, we should really avoid these too, waiting for the 2044 -- task activation, but that's too much trouble to catch for now, so 2045 -- we go in unconditionally. This is not so terrible, it means the 2046 -- error backtrace is not quite complete, and we are too eager to 2047 -- scan bodies of tasks that are unused, but this is hardly very 2048 -- significant! 2049 2050 elsif Nkind (N) = N_Subprogram_Body 2051 and then Comes_From_Source (N) 2052 then 2053 return Skip; 2054 2055 elsif Nkind (N) = N_Assignment_Statement 2056 and then Comes_From_Source (N) 2057 then 2058 Check_Elab_Assign (Name (N)); 2059 return OK; 2060 2061 else 2062 return OK; 2063 end if; 2064 end Find_Elab_Reference; 2065 2066 -- Start of processing for Check_Internal_Call_Continue 2067 2068 begin 2069 -- Save outer level call if at outer level 2070 2071 if Elab_Call.Last = 0 then 2072 Outer_Level_Sloc := Loc; 2073 end if; 2074 2075 Elab_Visited.Append (E); 2076 2077 -- If the call is to a function that renames a literal, no check needed 2078 2079 if Ekind (E) = E_Enumeration_Literal then 2080 return; 2081 end if; 2082 2083 Sbody := Unit_Declaration_Node (E); 2084 2085 if Nkind (Sbody) /= N_Subprogram_Body 2086 and then 2087 Nkind (Sbody) /= N_Package_Body 2088 then 2089 Ebody := Corresponding_Body (Sbody); 2090 2091 if No (Ebody) then 2092 return; 2093 else 2094 Sbody := Unit_Declaration_Node (Ebody); 2095 end if; 2096 end if; 2097 2098 -- If the body appears after the outer level call or instantiation then 2099 -- we have an error case handled below. 2100 2101 if Earlier_In_Extended_Unit (Outer_Level_Sloc, Sloc (Sbody)) 2102 and then not In_Task_Activation 2103 then 2104 null; 2105 2106 -- If we have the instantiation case we are done, since we now 2107 -- know that the body of the generic appeared earlier. 2108 2109 elsif Inst_Case then 2110 return; 2111 2112 -- Otherwise we have a call, so we trace through the called body to see 2113 -- if it has any problems. 2114 2115 else 2116 pragma Assert (Nkind (Sbody) = N_Subprogram_Body); 2117 2118 Elab_Call.Append ((Cloc => Loc, Ent => E)); 2119 2120 if Debug_Flag_LL then 2121 Write_Str ("Elab_Call.Last = "); 2122 Write_Int (Int (Elab_Call.Last)); 2123 Write_Str (" Ent = "); 2124 Write_Name (Chars (E)); 2125 Write_Str (" at "); 2126 Write_Location (Sloc (N)); 2127 Write_Eol; 2128 end if; 2129 2130 -- Now traverse declarations and statements of subprogram body. Note 2131 -- that we cannot simply Traverse (Sbody), since traverse does not 2132 -- normally visit subprogram bodies. 2133 2134 declare 2135 Decl : Node_Id; 2136 begin 2137 Decl := First (Declarations (Sbody)); 2138 while Present (Decl) loop 2139 Traverse (Decl); 2140 Next (Decl); 2141 end loop; 2142 end; 2143 2144 Traverse (Handled_Statement_Sequence (Sbody)); 2145 2146 Elab_Call.Decrement_Last; 2147 return; 2148 end if; 2149 2150 -- Here is the case of calling a subprogram where the body has not yet 2151 -- been encountered. A warning message is needed, except if this is the 2152 -- case of appearing within an aspect specification that results in 2153 -- a check call, we do not really have such a situation, so no warning 2154 -- is needed (e.g. the case of a precondition, where the call appears 2155 -- textually before the body, but in actual fact is moved to the 2156 -- appropriate subprogram body and so does not need a check). 2157 2158 declare 2159 P : Node_Id; 2160 begin 2161 P := Parent (N); 2162 loop 2163 if Nkind (P) in N_Subexpr then 2164 P := Parent (P); 2165 elsif Nkind (P) = N_If_Statement 2166 and then Nkind (Original_Node (P)) = N_Pragma 2167 and then Present (Corresponding_Aspect (Original_Node (P))) 2168 then 2169 return; 2170 else 2171 exit; 2172 end if; 2173 end loop; 2174 end; 2175 2176 -- Not that special case, warning and dynamic check is required 2177 2178 -- If we have nothing in the call stack, then this is at the outer 2179 -- level, and the ABE is bound to occur. 2180 2181 if Elab_Call.Last = 0 then 2182 if Inst_Case then 2183 Error_Msg_NE 2184 ("??cannot instantiate& before body seen", N, Orig_Ent); 2185 else 2186 Error_Msg_NE ("??cannot call& before body seen", N, Orig_Ent); 2187 end if; 2188 2189 Error_Msg_N ("\??Program_Error will be raised at run time", N); 2190 Insert_Elab_Check (N); 2191 2192 -- Call is not at outer level 2193 2194 else 2195 -- Deal with dynamic elaboration check 2196 2197 if not Elaboration_Checks_Suppressed (E) then 2198 Set_Elaboration_Entity_Required (E); 2199 2200 -- Case of no elaboration entity allocated yet 2201 2202 if No (Elaboration_Entity (E)) then 2203 2204 -- Create object declaration for elaboration entity, and put it 2205 -- just in front of the spec of the subprogram or generic unit, 2206 -- in the same scope as this unit. 2207 2208 declare 2209 Loce : constant Source_Ptr := Sloc (E); 2210 Ent : constant Entity_Id := 2211 Make_Defining_Identifier (Loc, 2212 Chars => New_External_Name (Chars (E), 'E')); 2213 2214 begin 2215 Set_Elaboration_Entity (E, Ent); 2216 Push_Scope (Scope (E)); 2217 2218 Insert_Action (Declaration_Node (E), 2219 Make_Object_Declaration (Loce, 2220 Defining_Identifier => Ent, 2221 Object_Definition => 2222 New_Occurrence_Of (Standard_Short_Integer, Loce), 2223 Expression => 2224 Make_Integer_Literal (Loc, Uint_0))); 2225 2226 -- Set elaboration flag at the point of the body 2227 2228 Set_Elaboration_Flag (Sbody, E); 2229 2230 -- Kill current value indication. This is necessary because 2231 -- the tests of this flag are inserted out of sequence and 2232 -- must not pick up bogus indications of the wrong constant 2233 -- value. Also, this is never a true constant, since one way 2234 -- or another, it gets reset. 2235 2236 Set_Current_Value (Ent, Empty); 2237 Set_Last_Assignment (Ent, Empty); 2238 Set_Is_True_Constant (Ent, False); 2239 Pop_Scope; 2240 end; 2241 end if; 2242 2243 -- Generate check of the elaboration counter 2244 2245 Insert_Elab_Check (N, 2246 Make_Attribute_Reference (Loc, 2247 Attribute_Name => Name_Elaborated, 2248 Prefix => New_Occurrence_Of (E, Loc))); 2249 end if; 2250 2251 -- Generate the warning 2252 2253 if not Suppress_Elaboration_Warnings (E) 2254 and then not Elaboration_Checks_Suppressed (E) 2255 2256 -- Suppress this warning if we have a function call that occurred 2257 -- within an assertion expression, since we can get false warnings 2258 -- in this case, due to the out of order handling in this case. 2259 2260 and then (Nkind (Original_Node (N)) /= N_Function_Call 2261 or else not In_Assertion (Original_Node (N))) 2262 then 2263 if Inst_Case then 2264 Error_Msg_NE 2265 ("instantiation of& may occur before body is seen??", 2266 N, Orig_Ent); 2267 else 2268 Error_Msg_NE 2269 ("call to& may occur before body is seen??", N, Orig_Ent); 2270 end if; 2271 2272 Error_Msg_N 2273 ("\Program_Error may be raised at run time??", N); 2274 2275 Output_Calls (N); 2276 end if; 2277 end if; 2278 2279 -- Set flag to suppress further warnings on same subprogram 2280 -- unless in all errors mode 2281 2282 if not All_Errors_Mode then 2283 Set_Suppress_Elaboration_Warnings (E); 2284 end if; 2285 end Check_Internal_Call_Continue; 2286 2287 --------------------------- 2288 -- Check_Task_Activation -- 2289 --------------------------- 2290 2291 procedure Check_Task_Activation (N : Node_Id) is 2292 Loc : constant Source_Ptr := Sloc (N); 2293 Inter_Procs : constant Elist_Id := New_Elmt_List; 2294 Intra_Procs : constant Elist_Id := New_Elmt_List; 2295 Ent : Entity_Id; 2296 P : Entity_Id; 2297 Task_Scope : Entity_Id; 2298 Cunit_SC : Boolean := False; 2299 Decl : Node_Id; 2300 Elmt : Elmt_Id; 2301 Enclosing : Entity_Id; 2302 2303 procedure Add_Task_Proc (Typ : Entity_Id); 2304 -- Add to Task_Procs the task body procedure(s) of task types in Typ. 2305 -- For record types, this procedure recurses over component types. 2306 2307 procedure Collect_Tasks (Decls : List_Id); 2308 -- Collect the types of the tasks that are to be activated in the given 2309 -- list of declarations, in order to perform elaboration checks on the 2310 -- corresponding task procedures which are called implicitly here. 2311 2312 function Outer_Unit (E : Entity_Id) return Entity_Id; 2313 -- find enclosing compilation unit of Entity, ignoring subunits, or 2314 -- else enclosing subprogram. If E is not a package, there is no need 2315 -- for inter-unit elaboration checks. 2316 2317 ------------------- 2318 -- Add_Task_Proc -- 2319 ------------------- 2320 2321 procedure Add_Task_Proc (Typ : Entity_Id) is 2322 Comp : Entity_Id; 2323 Proc : Entity_Id := Empty; 2324 2325 begin 2326 if Is_Task_Type (Typ) then 2327 Proc := Get_Task_Body_Procedure (Typ); 2328 2329 elsif Is_Array_Type (Typ) 2330 and then Has_Task (Base_Type (Typ)) 2331 then 2332 Add_Task_Proc (Component_Type (Typ)); 2333 2334 elsif Is_Record_Type (Typ) 2335 and then Has_Task (Base_Type (Typ)) 2336 then 2337 Comp := First_Component (Typ); 2338 while Present (Comp) loop 2339 Add_Task_Proc (Etype (Comp)); 2340 Comp := Next_Component (Comp); 2341 end loop; 2342 end if; 2343 2344 -- If the task type is another unit, we will perform the usual 2345 -- elaboration check on its enclosing unit. If the type is in the 2346 -- same unit, we can trace the task body as for an internal call, 2347 -- but we only need to examine other external calls, because at 2348 -- the point the task is activated, internal subprogram bodies 2349 -- will have been elaborated already. We keep separate lists for 2350 -- each kind of task. 2351 2352 -- Skip this test if errors have occurred, since in this case 2353 -- we can get false indications. 2354 2355 if Serious_Errors_Detected /= 0 then 2356 return; 2357 end if; 2358 2359 if Present (Proc) then 2360 if Outer_Unit (Scope (Proc)) = Enclosing then 2361 2362 if No (Corresponding_Body (Unit_Declaration_Node (Proc))) 2363 and then 2364 (not Is_Generic_Instance (Scope (Proc)) 2365 or else 2366 Scope (Proc) = Scope (Defining_Identifier (Decl))) 2367 then 2368 Error_Msg_N 2369 ("task will be activated before elaboration of its body??", 2370 Decl); 2371 Error_Msg_N 2372 ("\Program_Error will be raised at run time??", Decl); 2373 2374 elsif 2375 Present (Corresponding_Body (Unit_Declaration_Node (Proc))) 2376 then 2377 Append_Elmt (Proc, Intra_Procs); 2378 end if; 2379 2380 else 2381 -- No need for multiple entries of the same type 2382 2383 Elmt := First_Elmt (Inter_Procs); 2384 while Present (Elmt) loop 2385 if Node (Elmt) = Proc then 2386 return; 2387 end if; 2388 2389 Next_Elmt (Elmt); 2390 end loop; 2391 2392 Append_Elmt (Proc, Inter_Procs); 2393 end if; 2394 end if; 2395 end Add_Task_Proc; 2396 2397 ------------------- 2398 -- Collect_Tasks -- 2399 ------------------- 2400 2401 procedure Collect_Tasks (Decls : List_Id) is 2402 begin 2403 if Present (Decls) then 2404 Decl := First (Decls); 2405 while Present (Decl) loop 2406 if Nkind (Decl) = N_Object_Declaration 2407 and then Has_Task (Etype (Defining_Identifier (Decl))) 2408 then 2409 Add_Task_Proc (Etype (Defining_Identifier (Decl))); 2410 end if; 2411 2412 Next (Decl); 2413 end loop; 2414 end if; 2415 end Collect_Tasks; 2416 2417 ---------------- 2418 -- Outer_Unit -- 2419 ---------------- 2420 2421 function Outer_Unit (E : Entity_Id) return Entity_Id is 2422 Outer : Entity_Id; 2423 2424 begin 2425 Outer := E; 2426 while Present (Outer) loop 2427 if Elaboration_Checks_Suppressed (Outer) then 2428 Cunit_SC := True; 2429 end if; 2430 2431 exit when Is_Child_Unit (Outer) 2432 or else Scope (Outer) = Standard_Standard 2433 or else Ekind (Outer) /= E_Package; 2434 Outer := Scope (Outer); 2435 end loop; 2436 2437 return Outer; 2438 end Outer_Unit; 2439 2440 -- Start of processing for Check_Task_Activation 2441 2442 begin 2443 Enclosing := Outer_Unit (Current_Scope); 2444 2445 -- Find all tasks declared in the current unit 2446 2447 if Nkind (N) = N_Package_Body then 2448 P := Unit_Declaration_Node (Corresponding_Spec (N)); 2449 2450 Collect_Tasks (Declarations (N)); 2451 Collect_Tasks (Visible_Declarations (Specification (P))); 2452 Collect_Tasks (Private_Declarations (Specification (P))); 2453 2454 elsif Nkind (N) = N_Package_Declaration then 2455 Collect_Tasks (Visible_Declarations (Specification (N))); 2456 Collect_Tasks (Private_Declarations (Specification (N))); 2457 2458 else 2459 Collect_Tasks (Declarations (N)); 2460 end if; 2461 2462 -- We only perform detailed checks in all tasks are library level 2463 -- entities. If the master is a subprogram or task, activation will 2464 -- depend on the activation of the master itself. 2465 2466 -- Should dynamic checks be added in the more general case??? 2467 2468 if Ekind (Enclosing) /= E_Package then 2469 return; 2470 end if; 2471 2472 -- For task types defined in other units, we want the unit containing 2473 -- the task body to be elaborated before the current one. 2474 2475 Elmt := First_Elmt (Inter_Procs); 2476 while Present (Elmt) loop 2477 Ent := Node (Elmt); 2478 Task_Scope := Outer_Unit (Scope (Ent)); 2479 2480 if not Is_Compilation_Unit (Task_Scope) then 2481 null; 2482 2483 elsif Suppress_Elaboration_Warnings (Task_Scope) 2484 or else Elaboration_Checks_Suppressed (Task_Scope) 2485 then 2486 null; 2487 2488 elsif Dynamic_Elaboration_Checks then 2489 if not Elaboration_Checks_Suppressed (Ent) 2490 and then not Cunit_SC 2491 and then 2492 not Restriction_Active (No_Entry_Calls_In_Elaboration_Code) 2493 then 2494 -- Runtime elaboration check required. Generate check of the 2495 -- elaboration counter for the unit containing the entity. 2496 2497 Insert_Elab_Check (N, 2498 Make_Attribute_Reference (Loc, 2499 Attribute_Name => Name_Elaborated, 2500 Prefix => 2501 New_Occurrence_Of (Spec_Entity (Task_Scope), Loc))); 2502 end if; 2503 2504 else 2505 -- Force the binder to elaborate other unit first 2506 2507 if not Suppress_Elaboration_Warnings (Ent) 2508 and then not Elaboration_Checks_Suppressed (Ent) 2509 and then Elab_Warnings 2510 and then not Suppress_Elaboration_Warnings (Task_Scope) 2511 and then not Elaboration_Checks_Suppressed (Task_Scope) 2512 then 2513 Error_Msg_Node_2 := Task_Scope; 2514 Error_Msg_NE 2515 ("activation of an instance of task type&" & 2516 " requires pragma Elaborate_All on &?l?", N, Ent); 2517 end if; 2518 2519 Activate_Elaborate_All_Desirable (N, Task_Scope); 2520 Set_Suppress_Elaboration_Warnings (Task_Scope); 2521 end if; 2522 2523 Next_Elmt (Elmt); 2524 end loop; 2525 2526 -- For tasks declared in the current unit, trace other calls within 2527 -- the task procedure bodies, which are available. 2528 2529 In_Task_Activation := True; 2530 2531 Elmt := First_Elmt (Intra_Procs); 2532 while Present (Elmt) loop 2533 Ent := Node (Elmt); 2534 Check_Internal_Call_Continue (N, Ent, Enclosing, Ent); 2535 Next_Elmt (Elmt); 2536 end loop; 2537 2538 In_Task_Activation := False; 2539 end Check_Task_Activation; 2540 2541 -------------------------------- 2542 -- Set_Elaboration_Constraint -- 2543 -------------------------------- 2544 2545 procedure Set_Elaboration_Constraint 2546 (Call : Node_Id; 2547 Subp : Entity_Id; 2548 Scop : Entity_Id) 2549 is 2550 Elab_Unit : Entity_Id; 2551 2552 -- Check whether this is a call to an Initialize subprogram for a 2553 -- controlled type. Note that Call can also be a 'Access attribute 2554 -- reference, which now generates an elaboration check. 2555 2556 Init_Call : constant Boolean := 2557 Nkind (Call) = N_Procedure_Call_Statement 2558 and then Chars (Subp) = Name_Initialize 2559 and then Comes_From_Source (Subp) 2560 and then Present (Parameter_Associations (Call)) 2561 and then Is_Controlled (Etype (First_Actual (Call))); 2562 begin 2563 -- If the unit is mentioned in a with_clause of the current unit, it is 2564 -- visible, and we can set the elaboration flag. 2565 2566 if Is_Immediately_Visible (Scop) 2567 or else (Is_Child_Unit (Scop) and then Is_Visible_Lib_Unit (Scop)) 2568 then 2569 Activate_Elaborate_All_Desirable (Call, Scop); 2570 Set_Suppress_Elaboration_Warnings (Scop, True); 2571 return; 2572 end if; 2573 2574 -- If this is not an initialization call or a call using object notation 2575 -- we know that the unit of the called entity is in the context, and 2576 -- we can set the flag as well. The unit need not be visible if the call 2577 -- occurs within an instantiation. 2578 2579 if Is_Init_Proc (Subp) 2580 or else Init_Call 2581 or else Nkind (Original_Node (Call)) = N_Selected_Component 2582 then 2583 null; -- detailed processing follows. 2584 2585 else 2586 Activate_Elaborate_All_Desirable (Call, Scop); 2587 Set_Suppress_Elaboration_Warnings (Scop, True); 2588 return; 2589 end if; 2590 2591 -- If the unit is not in the context, there must be an intermediate unit 2592 -- that is, on which we need to place to elaboration flag. This happens 2593 -- with init proc calls. 2594 2595 if Is_Init_Proc (Subp) 2596 or else Init_Call 2597 then 2598 -- The initialization call is on an object whose type is not declared 2599 -- in the same scope as the subprogram. The type of the object must 2600 -- be a subtype of the type of operation. This object is the first 2601 -- actual in the call. 2602 2603 declare 2604 Typ : constant Entity_Id := 2605 Etype (First (Parameter_Associations (Call))); 2606 begin 2607 Elab_Unit := Scope (Typ); 2608 while (Present (Elab_Unit)) 2609 and then not Is_Compilation_Unit (Elab_Unit) 2610 loop 2611 Elab_Unit := Scope (Elab_Unit); 2612 end loop; 2613 end; 2614 2615 -- If original node uses selected component notation, the prefix is 2616 -- visible and determines the scope that must be elaborated. After 2617 -- rewriting, the prefix is the first actual in the call. 2618 2619 elsif Nkind (Original_Node (Call)) = N_Selected_Component then 2620 Elab_Unit := Scope (Etype (First (Parameter_Associations (Call)))); 2621 2622 -- Not one of special cases above 2623 2624 else 2625 -- Using previously computed scope. If the elaboration check is 2626 -- done after analysis, the scope is not visible any longer, but 2627 -- must still be in the context. 2628 2629 Elab_Unit := Scop; 2630 end if; 2631 2632 Activate_Elaborate_All_Desirable (Call, Elab_Unit); 2633 Set_Suppress_Elaboration_Warnings (Elab_Unit, True); 2634 end Set_Elaboration_Constraint; 2635 2636 ------------------------ 2637 -- Get_Referenced_Ent -- 2638 ------------------------ 2639 2640 function Get_Referenced_Ent (N : Node_Id) return Entity_Id is 2641 Nam : Node_Id; 2642 2643 begin 2644 if Nkind (N) = N_Attribute_Reference then 2645 Nam := Prefix (N); 2646 else 2647 Nam := Name (N); 2648 end if; 2649 2650 if No (Nam) then 2651 return Empty; 2652 elsif Nkind (Nam) = N_Selected_Component then 2653 return Entity (Selector_Name (Nam)); 2654 elsif not Is_Entity_Name (Nam) then 2655 return Empty; 2656 else 2657 return Entity (Nam); 2658 end if; 2659 end Get_Referenced_Ent; 2660 2661 ---------------------- 2662 -- Has_Generic_Body -- 2663 ---------------------- 2664 2665 function Has_Generic_Body (N : Node_Id) return Boolean is 2666 Ent : constant Entity_Id := Get_Generic_Entity (N); 2667 Decl : constant Node_Id := Unit_Declaration_Node (Ent); 2668 Scop : Entity_Id; 2669 2670 function Find_Body_In (E : Entity_Id; N : Node_Id) return Node_Id; 2671 -- Determine if the list of nodes headed by N and linked by Next 2672 -- contains a package body for the package spec entity E, and if so 2673 -- return the package body. If not, then returns Empty. 2674 2675 function Load_Package_Body (Nam : Unit_Name_Type) return Node_Id; 2676 -- This procedure is called load the unit whose name is given by Nam. 2677 -- This unit is being loaded to see whether it contains an optional 2678 -- generic body. The returned value is the loaded unit, which is always 2679 -- a package body (only package bodies can contain other entities in the 2680 -- sense in which Has_Generic_Body is interested). We only attempt to 2681 -- load bodies if we are generating code. If we are in semantics check 2682 -- only mode, then it would be wrong to load bodies that are not 2683 -- required from a semantic point of view, so in this case we return 2684 -- Empty. The result is that the caller may incorrectly decide that a 2685 -- generic spec does not have a body when in fact it does, but the only 2686 -- harm in this is that some warnings on elaboration problems may be 2687 -- lost in semantic checks only mode, which is not big loss. We also 2688 -- return Empty if we go for a body and it is not there. 2689 2690 function Locate_Corresponding_Body (PE : Entity_Id) return Node_Id; 2691 -- PE is the entity for a package spec. This function locates the 2692 -- corresponding package body, returning Empty if none is found. The 2693 -- package body returned is fully parsed but may not yet be analyzed, 2694 -- so only syntactic fields should be referenced. 2695 2696 ------------------ 2697 -- Find_Body_In -- 2698 ------------------ 2699 2700 function Find_Body_In (E : Entity_Id; N : Node_Id) return Node_Id is 2701 Nod : Node_Id; 2702 2703 begin 2704 Nod := N; 2705 while Present (Nod) loop 2706 2707 -- If we found the package body we are looking for, return it 2708 2709 if Nkind (Nod) = N_Package_Body 2710 and then Chars (Defining_Unit_Name (Nod)) = Chars (E) 2711 then 2712 return Nod; 2713 2714 -- If we found the stub for the body, go after the subunit, 2715 -- loading it if necessary. 2716 2717 elsif Nkind (Nod) = N_Package_Body_Stub 2718 and then Chars (Defining_Identifier (Nod)) = Chars (E) 2719 then 2720 if Present (Library_Unit (Nod)) then 2721 return Unit (Library_Unit (Nod)); 2722 2723 else 2724 return Load_Package_Body (Get_Unit_Name (Nod)); 2725 end if; 2726 2727 -- If neither package body nor stub, keep looking on chain 2728 2729 else 2730 Next (Nod); 2731 end if; 2732 end loop; 2733 2734 return Empty; 2735 end Find_Body_In; 2736 2737 ----------------------- 2738 -- Load_Package_Body -- 2739 ----------------------- 2740 2741 function Load_Package_Body (Nam : Unit_Name_Type) return Node_Id is 2742 U : Unit_Number_Type; 2743 2744 begin 2745 if Operating_Mode /= Generate_Code then 2746 return Empty; 2747 else 2748 U := 2749 Load_Unit 2750 (Load_Name => Nam, 2751 Required => False, 2752 Subunit => False, 2753 Error_Node => N); 2754 2755 if U = No_Unit then 2756 return Empty; 2757 else 2758 return Unit (Cunit (U)); 2759 end if; 2760 end if; 2761 end Load_Package_Body; 2762 2763 ------------------------------- 2764 -- Locate_Corresponding_Body -- 2765 ------------------------------- 2766 2767 function Locate_Corresponding_Body (PE : Entity_Id) return Node_Id is 2768 Spec : constant Node_Id := Declaration_Node (PE); 2769 Decl : constant Node_Id := Parent (Spec); 2770 Scop : constant Entity_Id := Scope (PE); 2771 PBody : Node_Id; 2772 2773 begin 2774 if Is_Library_Level_Entity (PE) then 2775 2776 -- If package is a library unit that requires a body, we have no 2777 -- choice but to go after that body because it might contain an 2778 -- optional body for the original generic package. 2779 2780 if Unit_Requires_Body (PE) then 2781 2782 -- Load the body. Note that we are a little careful here to use 2783 -- Spec to get the unit number, rather than PE or Decl, since 2784 -- in the case where the package is itself a library level 2785 -- instantiation, Spec will properly reference the generic 2786 -- template, which is what we really want. 2787 2788 return 2789 Load_Package_Body 2790 (Get_Body_Name (Unit_Name (Get_Source_Unit (Spec)))); 2791 2792 -- But if the package is a library unit that does NOT require 2793 -- a body, then no body is permitted, so we are sure that there 2794 -- is no body for the original generic package. 2795 2796 else 2797 return Empty; 2798 end if; 2799 2800 -- Otherwise look and see if we are embedded in a further package 2801 2802 elsif Is_Package_Or_Generic_Package (Scop) then 2803 2804 -- If so, get the body of the enclosing package, and look in 2805 -- its package body for the package body we are looking for. 2806 2807 PBody := Locate_Corresponding_Body (Scop); 2808 2809 if No (PBody) then 2810 return Empty; 2811 else 2812 return Find_Body_In (PE, First (Declarations (PBody))); 2813 end if; 2814 2815 -- If we are not embedded in a further package, then the body 2816 -- must be in the same declarative part as we are. 2817 2818 else 2819 return Find_Body_In (PE, Next (Decl)); 2820 end if; 2821 end Locate_Corresponding_Body; 2822 2823 -- Start of processing for Has_Generic_Body 2824 2825 begin 2826 if Present (Corresponding_Body (Decl)) then 2827 return True; 2828 2829 elsif Unit_Requires_Body (Ent) then 2830 return True; 2831 2832 -- Compilation units cannot have optional bodies 2833 2834 elsif Is_Compilation_Unit (Ent) then 2835 return False; 2836 2837 -- Otherwise look at what scope we are in 2838 2839 else 2840 Scop := Scope (Ent); 2841 2842 -- Case of entity is in other than a package spec, in this case 2843 -- the body, if present, must be in the same declarative part. 2844 2845 if not Is_Package_Or_Generic_Package (Scop) then 2846 declare 2847 P : Node_Id; 2848 2849 begin 2850 -- Declaration node may get us a spec, so if so, go to 2851 -- the parent declaration. 2852 2853 P := Declaration_Node (Ent); 2854 while not Is_List_Member (P) loop 2855 P := Parent (P); 2856 end loop; 2857 2858 return Present (Find_Body_In (Ent, Next (P))); 2859 end; 2860 2861 -- If the entity is in a package spec, then we have to locate 2862 -- the corresponding package body, and look there. 2863 2864 else 2865 declare 2866 PBody : constant Node_Id := Locate_Corresponding_Body (Scop); 2867 2868 begin 2869 if No (PBody) then 2870 return False; 2871 else 2872 return 2873 Present 2874 (Find_Body_In (Ent, (First (Declarations (PBody))))); 2875 end if; 2876 end; 2877 end if; 2878 end if; 2879 end Has_Generic_Body; 2880 2881 ----------------------- 2882 -- Insert_Elab_Check -- 2883 ----------------------- 2884 2885 procedure Insert_Elab_Check (N : Node_Id; C : Node_Id := Empty) is 2886 Nod : Node_Id; 2887 Loc : constant Source_Ptr := Sloc (N); 2888 2889 begin 2890 -- If expansion is disabled, do not generate any checks. Also 2891 -- skip checks if any subunits are missing because in either 2892 -- case we lack the full information that we need, and no object 2893 -- file will be created in any case. 2894 2895 if not Expander_Active or else Subunits_Missing then 2896 return; 2897 end if; 2898 2899 -- If we have a generic instantiation, where Instance_Spec is set, 2900 -- then this field points to a generic instance spec that has 2901 -- been inserted before the instantiation node itself, so that 2902 -- is where we want to insert a check. 2903 2904 if Nkind (N) in N_Generic_Instantiation 2905 and then Present (Instance_Spec (N)) 2906 then 2907 Nod := Instance_Spec (N); 2908 else 2909 Nod := N; 2910 end if; 2911 2912 -- If we are inserting at the top level, insert in Aux_Decls 2913 2914 if Nkind (Parent (Nod)) = N_Compilation_Unit then 2915 declare 2916 ADN : constant Node_Id := Aux_Decls_Node (Parent (Nod)); 2917 R : Node_Id; 2918 2919 begin 2920 if No (C) then 2921 R := 2922 Make_Raise_Program_Error (Loc, 2923 Reason => PE_Access_Before_Elaboration); 2924 else 2925 R := 2926 Make_Raise_Program_Error (Loc, 2927 Condition => Make_Op_Not (Loc, C), 2928 Reason => PE_Access_Before_Elaboration); 2929 end if; 2930 2931 if No (Declarations (ADN)) then 2932 Set_Declarations (ADN, New_List (R)); 2933 else 2934 Append_To (Declarations (ADN), R); 2935 end if; 2936 2937 Analyze (R); 2938 end; 2939 2940 -- Otherwise just insert before the node in question. However, if 2941 -- the context of the call has already been analyzed, an insertion 2942 -- will not work if it depends on subsequent expansion (e.g. a call in 2943 -- a branch of a short-circuit). In that case we replace the call with 2944 -- an if expression, or with a Raise if it is unconditional. 2945 2946 -- Unfortunately this does not work if the call has a dynamic size, 2947 -- because gigi regards it as a dynamic-sized temporary. If such a call 2948 -- appears in a short-circuit expression, the elaboration check will be 2949 -- missed (rare enough ???). Otherwise, the code below inserts the check 2950 -- at the appropriate place before the call. Same applies in the even 2951 -- rarer case the return type has a known size but is unconstrained. 2952 2953 else 2954 if Nkind (N) = N_Function_Call 2955 and then Analyzed (Parent (N)) 2956 and then Size_Known_At_Compile_Time (Etype (N)) 2957 and then 2958 (not Has_Discriminants (Etype (N)) 2959 or else Is_Constrained (Etype (N))) 2960 2961 then 2962 declare 2963 Typ : constant Entity_Id := Etype (N); 2964 Chk : constant Boolean := Do_Range_Check (N); 2965 2966 R : constant Node_Id := 2967 Make_Raise_Program_Error (Loc, 2968 Reason => PE_Access_Before_Elaboration); 2969 2970 Reloc_N : Node_Id; 2971 2972 begin 2973 Set_Etype (R, Typ); 2974 2975 if No (C) then 2976 Rewrite (N, R); 2977 2978 else 2979 Reloc_N := Relocate_Node (N); 2980 Save_Interps (N, Reloc_N); 2981 Rewrite (N, 2982 Make_If_Expression (Loc, 2983 Expressions => New_List (C, Reloc_N, R))); 2984 end if; 2985 2986 Analyze_And_Resolve (N, Typ); 2987 2988 -- If the original call requires a range check, so does the 2989 -- if expression. 2990 2991 if Chk then 2992 Enable_Range_Check (N); 2993 else 2994 Set_Do_Range_Check (N, False); 2995 end if; 2996 end; 2997 2998 else 2999 if No (C) then 3000 Insert_Action (Nod, 3001 Make_Raise_Program_Error (Loc, 3002 Reason => PE_Access_Before_Elaboration)); 3003 else 3004 Insert_Action (Nod, 3005 Make_Raise_Program_Error (Loc, 3006 Condition => 3007 Make_Op_Not (Loc, 3008 Right_Opnd => C), 3009 Reason => PE_Access_Before_Elaboration)); 3010 end if; 3011 end if; 3012 end if; 3013 end Insert_Elab_Check; 3014 3015 ------------------------------- 3016 -- Is_Finalization_Procedure -- 3017 ------------------------------- 3018 3019 function Is_Finalization_Procedure (Id : Entity_Id) return Boolean is 3020 begin 3021 -- Check whether Id is a procedure with at least one parameter 3022 3023 if Ekind (Id) = E_Procedure 3024 and then Present (First_Formal (Id)) 3025 then 3026 declare 3027 Typ : constant Entity_Id := Etype (First_Formal (Id)); 3028 Deep_Fin : Entity_Id := Empty; 3029 Fin : Entity_Id := Empty; 3030 3031 begin 3032 -- If the type of the first formal does not require finalization 3033 -- actions, then this is definitely not [Deep_]Finalize. 3034 3035 if not Needs_Finalization (Typ) then 3036 return False; 3037 end if; 3038 3039 -- At this point we have the following scenario: 3040 3041 -- procedure Name (Param1 : [in] [out] Ctrl[; Param2 : ...]); 3042 3043 -- Recover the two possible versions of [Deep_]Finalize using the 3044 -- type of the first parameter and compare with the input. 3045 3046 Deep_Fin := TSS (Typ, TSS_Deep_Finalize); 3047 3048 if Is_Controlled (Typ) then 3049 Fin := Find_Prim_Op (Typ, Name_Finalize); 3050 end if; 3051 3052 return 3053 (Present (Deep_Fin) and then Id = Deep_Fin) 3054 or else 3055 (Present (Fin) and then Id = Fin); 3056 end; 3057 end if; 3058 3059 return False; 3060 end Is_Finalization_Procedure; 3061 3062 ------------------ 3063 -- Output_Calls -- 3064 ------------------ 3065 3066 procedure Output_Calls (N : Node_Id) is 3067 Ent : Entity_Id; 3068 3069 function Is_Printable_Error_Name (Nm : Name_Id) return Boolean; 3070 -- An internal function, used to determine if a name, Nm, is either 3071 -- a non-internal name, or is an internal name that is printable 3072 -- by the error message circuits (i.e. it has a single upper 3073 -- case letter at the end). 3074 3075 function Is_Printable_Error_Name (Nm : Name_Id) return Boolean is 3076 begin 3077 if not Is_Internal_Name (Nm) then 3078 return True; 3079 3080 elsif Name_Len = 1 then 3081 return False; 3082 3083 else 3084 Name_Len := Name_Len - 1; 3085 return not Is_Internal_Name; 3086 end if; 3087 end Is_Printable_Error_Name; 3088 3089 -- Start of processing for Output_Calls 3090 3091 begin 3092 for J in reverse 1 .. Elab_Call.Last loop 3093 Error_Msg_Sloc := Elab_Call.Table (J).Cloc; 3094 3095 Ent := Elab_Call.Table (J).Ent; 3096 3097 if Is_Generic_Unit (Ent) then 3098 Error_Msg_NE ("\??& instantiated #", N, Ent); 3099 3100 elsif Is_Init_Proc (Ent) then 3101 Error_Msg_N ("\??initialization procedure called #", N); 3102 3103 elsif Is_Printable_Error_Name (Chars (Ent)) then 3104 Error_Msg_NE ("\??& called #", N, Ent); 3105 3106 else 3107 Error_Msg_N ("\?? called #", N); 3108 end if; 3109 end loop; 3110 end Output_Calls; 3111 3112 ---------------------------- 3113 -- Same_Elaboration_Scope -- 3114 ---------------------------- 3115 3116 function Same_Elaboration_Scope (Scop1, Scop2 : Entity_Id) return Boolean is 3117 S1 : Entity_Id; 3118 S2 : Entity_Id; 3119 3120 begin 3121 -- Find elaboration scope for Scop1 3122 -- This is either a subprogram or a compilation unit. 3123 3124 S1 := Scop1; 3125 while S1 /= Standard_Standard 3126 and then not Is_Compilation_Unit (S1) 3127 and then (Ekind (S1) = E_Package 3128 or else 3129 Ekind (S1) = E_Protected_Type 3130 or else 3131 Ekind (S1) = E_Block) 3132 loop 3133 S1 := Scope (S1); 3134 end loop; 3135 3136 -- Find elaboration scope for Scop2 3137 3138 S2 := Scop2; 3139 while S2 /= Standard_Standard 3140 and then not Is_Compilation_Unit (S2) 3141 and then (Ekind (S2) = E_Package 3142 or else 3143 Ekind (S2) = E_Protected_Type 3144 or else 3145 Ekind (S2) = E_Block) 3146 loop 3147 S2 := Scope (S2); 3148 end loop; 3149 3150 return S1 = S2; 3151 end Same_Elaboration_Scope; 3152 3153 ----------------- 3154 -- Set_C_Scope -- 3155 ----------------- 3156 3157 procedure Set_C_Scope is 3158 begin 3159 while not Is_Compilation_Unit (C_Scope) loop 3160 C_Scope := Scope (C_Scope); 3161 end loop; 3162 end Set_C_Scope; 3163 3164 ----------------- 3165 -- Spec_Entity -- 3166 ----------------- 3167 3168 function Spec_Entity (E : Entity_Id) return Entity_Id is 3169 Decl : Node_Id; 3170 3171 begin 3172 -- Check for case of body entity 3173 -- Why is the check for E_Void needed??? 3174 3175 if Ekind_In (E, E_Void, E_Subprogram_Body, E_Package_Body) then 3176 Decl := E; 3177 3178 loop 3179 Decl := Parent (Decl); 3180 exit when Nkind (Decl) in N_Proper_Body; 3181 end loop; 3182 3183 return Corresponding_Spec (Decl); 3184 3185 else 3186 return E; 3187 end if; 3188 end Spec_Entity; 3189 3190 ------------------- 3191 -- Supply_Bodies -- 3192 ------------------- 3193 3194 procedure Supply_Bodies (N : Node_Id) is 3195 begin 3196 if Nkind (N) = N_Subprogram_Declaration then 3197 declare 3198 Ent : constant Entity_Id := Defining_Unit_Name (Specification (N)); 3199 begin 3200 3201 -- Internal subprograms will already have a generated body, so 3202 -- there is no need to provide a stub for them. 3203 3204 if No (Corresponding_Body (N)) then 3205 declare 3206 Loc : constant Source_Ptr := Sloc (N); 3207 B : Node_Id; 3208 Formals : constant List_Id := Copy_Parameter_List (Ent); 3209 Nam : constant Entity_Id := 3210 Make_Defining_Identifier (Loc, Chars (Ent)); 3211 Spec : Node_Id; 3212 Stats : constant List_Id := 3213 New_List 3214 (Make_Raise_Program_Error (Loc, 3215 Reason => PE_Access_Before_Elaboration)); 3216 3217 begin 3218 if Ekind (Ent) = E_Function then 3219 Spec := 3220 Make_Function_Specification (Loc, 3221 Defining_Unit_Name => Nam, 3222 Parameter_Specifications => Formals, 3223 Result_Definition => 3224 New_Copy_Tree 3225 (Result_Definition (Specification (N)))); 3226 3227 -- We cannot reliably make a return statement for this 3228 -- body, but none is needed because the call raises 3229 -- program error. 3230 3231 Set_Return_Present (Ent); 3232 3233 else 3234 Spec := 3235 Make_Procedure_Specification (Loc, 3236 Defining_Unit_Name => Nam, 3237 Parameter_Specifications => Formals); 3238 end if; 3239 3240 B := Make_Subprogram_Body (Loc, 3241 Specification => Spec, 3242 Declarations => New_List, 3243 Handled_Statement_Sequence => 3244 Make_Handled_Sequence_Of_Statements (Loc, Stats)); 3245 Insert_After (N, B); 3246 Analyze (B); 3247 end; 3248 end if; 3249 end; 3250 3251 elsif Nkind (N) = N_Package_Declaration then 3252 declare 3253 Spec : constant Node_Id := Specification (N); 3254 begin 3255 Push_Scope (Defining_Unit_Name (Spec)); 3256 Supply_Bodies (Visible_Declarations (Spec)); 3257 Supply_Bodies (Private_Declarations (Spec)); 3258 Pop_Scope; 3259 end; 3260 end if; 3261 end Supply_Bodies; 3262 3263 procedure Supply_Bodies (L : List_Id) is 3264 Elmt : Node_Id; 3265 begin 3266 if Present (L) then 3267 Elmt := First (L); 3268 while Present (Elmt) loop 3269 Supply_Bodies (Elmt); 3270 Next (Elmt); 3271 end loop; 3272 end if; 3273 end Supply_Bodies; 3274 3275 ------------ 3276 -- Within -- 3277 ------------ 3278 3279 function Within (E1, E2 : Entity_Id) return Boolean is 3280 Scop : Entity_Id; 3281 begin 3282 Scop := E1; 3283 loop 3284 if Scop = E2 then 3285 return True; 3286 elsif Scop = Standard_Standard then 3287 return False; 3288 else 3289 Scop := Scope (Scop); 3290 end if; 3291 end loop; 3292 end Within; 3293 3294 -------------------------- 3295 -- Within_Elaborate_All -- 3296 -------------------------- 3297 3298 function Within_Elaborate_All 3299 (Unit : Unit_Number_Type; 3300 E : Entity_Id) return Boolean 3301 is 3302 type Unit_Number_Set is array (Main_Unit .. Last_Unit) of Boolean; 3303 pragma Pack (Unit_Number_Set); 3304 3305 Seen : Unit_Number_Set := (others => False); 3306 -- Seen (X) is True after we have seen unit X in the walk. This is used 3307 -- to prevent processing the same unit more than once. 3308 3309 Result : Boolean := False; 3310 3311 procedure Helper (Unit : Unit_Number_Type); 3312 -- This helper procedure does all the work for Within_Elaborate_All. It 3313 -- walks the dependency graph, and sets Result to True if it finds an 3314 -- appropriate Elaborate_All. 3315 3316 ------------ 3317 -- Helper -- 3318 ------------ 3319 3320 procedure Helper (Unit : Unit_Number_Type) is 3321 CU : constant Node_Id := Cunit (Unit); 3322 3323 Item : Node_Id; 3324 Item2 : Node_Id; 3325 Elab_Id : Entity_Id; 3326 Par : Node_Id; 3327 3328 begin 3329 if Seen (Unit) then 3330 return; 3331 else 3332 Seen (Unit) := True; 3333 end if; 3334 3335 -- First, check for Elaborate_Alls on this unit 3336 3337 Item := First (Context_Items (CU)); 3338 while Present (Item) loop 3339 if Nkind (Item) = N_Pragma 3340 and then Pragma_Name (Item) = Name_Elaborate_All 3341 then 3342 -- Return if some previous error on the pragma itself 3343 3344 if Error_Posted (Item) then 3345 return; 3346 end if; 3347 3348 Elab_Id := 3349 Entity 3350 (Expression (First (Pragma_Argument_Associations (Item)))); 3351 3352 if E = Elab_Id then 3353 Result := True; 3354 return; 3355 end if; 3356 3357 Par := Parent (Unit_Declaration_Node (Elab_Id)); 3358 3359 Item2 := First (Context_Items (Par)); 3360 while Present (Item2) loop 3361 if Nkind (Item2) = N_With_Clause 3362 and then Entity (Name (Item2)) = E 3363 and then not Limited_Present (Item2) 3364 then 3365 Result := True; 3366 return; 3367 end if; 3368 3369 Next (Item2); 3370 end loop; 3371 end if; 3372 3373 Next (Item); 3374 end loop; 3375 3376 -- Second, recurse on with's. We could do this as part of the above 3377 -- loop, but it's probably more efficient to have two loops, because 3378 -- the relevant Elaborate_All is likely to be on the initial unit. In 3379 -- other words, we're walking the with's breadth-first. This part is 3380 -- only necessary in the dynamic elaboration model. 3381 3382 if Dynamic_Elaboration_Checks then 3383 Item := First (Context_Items (CU)); 3384 while Present (Item) loop 3385 if Nkind (Item) = N_With_Clause 3386 and then not Limited_Present (Item) 3387 then 3388 -- Note: the following call to Get_Cunit_Unit_Number does a 3389 -- linear search, which could be slow, but it's OK because 3390 -- we're about to give a warning anyway. Also, there might 3391 -- be hundreds of units, but not millions. If it turns out 3392 -- to be a problem, we could store the Get_Cunit_Unit_Number 3393 -- in each N_Compilation_Unit node, but that would involve 3394 -- rearranging N_Compilation_Unit_Aux to make room. 3395 3396 Helper (Get_Cunit_Unit_Number (Library_Unit (Item))); 3397 3398 if Result then 3399 return; 3400 end if; 3401 end if; 3402 3403 Next (Item); 3404 end loop; 3405 end if; 3406 end Helper; 3407 3408 -- Start of processing for Within_Elaborate_All 3409 3410 begin 3411 Helper (Unit); 3412 return Result; 3413 end Within_Elaborate_All; 3414 3415end Sem_Elab; 3416