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