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-2004 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 2, 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 COPYING. If not, write -- 19-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- 20-- MA 02111-1307, USA. -- 21-- -- 22-- GNAT was originally developed by the GNAT team at New York University. -- 23-- Extensive contributions were provided by Ada Core Technologies Inc. -- 24-- -- 25------------------------------------------------------------------------------ 26 27with Atree; use Atree; 28with Checks; use Checks; 29with Debug; use Debug; 30with Einfo; use Einfo; 31with Elists; use Elists; 32with Errout; use Errout; 33with Exp_Tss; use Exp_Tss; 34with Exp_Util; use Exp_Util; 35with Expander; use Expander; 36with Fname; use Fname; 37with Lib; use Lib; 38with Lib.Load; use Lib.Load; 39with Namet; use Namet; 40with Nlists; use Nlists; 41with Nmake; use Nmake; 42with Opt; use Opt; 43with Output; use Output; 44with Restrict; use Restrict; 45with Sem; use Sem; 46with Sem_Cat; use Sem_Cat; 47with Sem_Ch7; use Sem_Ch7; 48with Sem_Ch8; use Sem_Ch8; 49with Sem_Res; use Sem_Res; 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 Uname; use Uname; 58 59package body Sem_Elab is 60 61 -- The following table records the recursive call chain for output 62 -- in the Output routine. Each entry records the call node and the 63 -- entity of the called routine. The number of entries in the table 64 -- (i.e. the value of Elab_Call.Last) indicates the current depth 65 -- of recursion and is used to identify the outer level. 66 67 type Elab_Call_Entry is record 68 Cloc : Source_Ptr; 69 Ent : Entity_Id; 70 end record; 71 72 package Elab_Call is new Table.Table ( 73 Table_Component_Type => Elab_Call_Entry, 74 Table_Index_Type => Int, 75 Table_Low_Bound => 1, 76 Table_Initial => 50, 77 Table_Increment => 100, 78 Table_Name => "Elab_Call"); 79 80 -- This table is initialized at the start of each outer level call. 81 -- It holds the entities for all subprograms that have been examined 82 -- for this particular outer level call, and is used to prevent both 83 -- infinite recursion, and useless reanalysis of bodies already seen 84 85 package Elab_Visited is new Table.Table ( 86 Table_Component_Type => Entity_Id, 87 Table_Index_Type => Int, 88 Table_Low_Bound => 1, 89 Table_Initial => 200, 90 Table_Increment => 100, 91 Table_Name => "Elab_Visited"); 92 93 -- This table stores calls to Check_Internal_Call that are delayed 94 -- until all generics are instantiated, and in particular that all 95 -- generic bodies have been inserted. We need to delay, because we 96 -- need to be able to look through the inserted bodies. 97 98 type Delay_Element is record 99 N : Node_Id; 100 -- The parameter N from the call to Check_Internal_Call. Note that 101 -- this node may get rewritten over the delay period by expansion 102 -- in the call case (but not in the instantiation case). 103 104 E : Entity_Id; 105 -- The parameter E from the call to Check_Internal_Call 106 107 Orig_Ent : Entity_Id; 108 -- The parameter Orig_Ent from the call to Check_Internal_Call 109 110 Curscop : Entity_Id; 111 -- The current scope of the call. This is restored when we complete 112 -- the delayed call, so that we do this in the right scope. 113 114 From_Elab_Code : Boolean; 115 -- Save indication of whether this call is from elaboration code 116 117 Outer_Scope : Entity_Id; 118 -- Save scope of outer level call 119 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. We need to compute this only 132 -- once at the outer level, i.e. for a call to Check_Elab_Call from 133 -- outside this unit. 134 135 Outer_Level_Sloc : Source_Ptr; 136 -- Save Sloc value for outer level call node for comparisons of source 137 -- locations. A body is too late if it appears after the *outer* level 138 -- call, not the particular call that is being analyzed. 139 140 From_Elab_Code : Boolean; 141 -- This flag shows whether the outer level call currently being examined 142 -- is or is not in elaboration code. We are only interested in calls to 143 -- routines in other units if this flag is True. 144 145 In_Task_Activation : Boolean := False; 146 -- This flag indicates whether we are performing elaboration checks on 147 -- task procedures, at the point of activation. If true, we do not trace 148 -- internal calls in these procedures, because all local bodies are known 149 -- to be elaborated. 150 151 Delaying_Elab_Checks : Boolean := True; 152 -- This is set True till the compilation is complete, including the 153 -- insertion of all instance bodies. Then when Check_Elab_Calls is 154 -- called, the delay table is used to make the delayed calls and 155 -- this flag is reset to False, so that the calls are processed 156 157 ----------------------- 158 -- Local Subprograms -- 159 ----------------------- 160 161 -- Note: Outer_Scope in all these calls represents the scope of 162 -- interest of the outer level call. If it is set to Standard_Standard, 163 -- then it means the outer level call was at elaboration level, and that 164 -- thus all calls are of interest. If it was set to some other scope, 165 -- then the original call was an inner call, and we are not interested 166 -- in calls that go outside this scope. 167 168 procedure Check_A_Call 169 (N : Node_Id; 170 E : Entity_Id; 171 Outer_Scope : Entity_Id; 172 Inter_Unit_Only : Boolean; 173 Generate_Warnings : Boolean := True); 174 -- This is the internal recursive routine that is called to check for 175 -- a possible elaboration error. The argument N is a subprogram call 176 -- or generic instantiation to be checked, and E is the entity of 177 -- the called subprogram, or instantiated generic unit. The flag 178 -- Outer_Scope is the outer level scope for the original call. 179 -- Inter_Unit_Only is set if the call is only to be checked in the 180 -- case where it is to another unit (and skipped if within a unit). 181 -- Generate_Warnings is set to False to suppress warning messages 182 -- about missing pragma Elaborate_All's. These messages are not 183 -- wanted for inner calls in the dynamic model. 184 185 procedure Check_Bad_Instantiation (N : Node_Id); 186 -- N is a node for an instantiation (if called with any other node kind, 187 -- Check_Bad_Instantiation ignores the call). This subprogram checks for 188 -- the special case of a generic instantiation of a generic spec in the 189 -- same declarative part as the instantiation where a body is present and 190 -- has not yet been seen. This is an obvious error, but needs to be checked 191 -- specially at the time of the instantiation, since it is a case where we 192 -- cannot insert the body anywhere. If this case is detected, warnings are 193 -- generated, and a raise of Program_Error is inserted. In addition any 194 -- subprograms in the generic spec are stubbed, and the Bad_Instantiation 195 -- flag is set on the instantiation node. The caller in Sem_Ch12 uses this 196 -- flag as an indication that no attempt should be made to insert an 197 -- instance body. 198 199 procedure Check_Internal_Call 200 (N : Node_Id; 201 E : Entity_Id; 202 Outer_Scope : Entity_Id; 203 Orig_Ent : Entity_Id); 204 -- N is a function call or procedure statement call node and E is 205 -- the entity of the called function, which is within the current 206 -- compilation unit (where subunits count as part of the parent). 207 -- This call checks if this call, or any call within any accessed 208 -- body could cause an ABE, and if so, outputs a warning. Orig_Ent 209 -- differs from E only in the case of renamings, and points to the 210 -- original name of the entity. This is used for error messages. 211 -- Outer_Scope is the outer level scope for the original call. 212 213 procedure Check_Internal_Call_Continue 214 (N : Node_Id; 215 E : Entity_Id; 216 Outer_Scope : Entity_Id; 217 Orig_Ent : Entity_Id); 218 -- The processing for Check_Internal_Call is divided up into two phases, 219 -- and this represents the second phase. The second phase is delayed if 220 -- Delaying_Elab_Calls is set to True. In this delayed case, the first 221 -- phase makes an entry in the Delay_Check table, which is processed 222 -- when Check_Elab_Calls is called. N, E and Orig_Ent are as for the call 223 -- to Check_Internal_Call. Outer_Scope is the outer level scope for 224 -- the original call. 225 226 function Has_Generic_Body (N : Node_Id) return Boolean; 227 -- N is a generic package instantiation node, and this routine determines 228 -- if this package spec does in fact have a generic body. If so, then 229 -- True is returned, otherwise False. Note that this is not at all the 230 -- same as checking if the unit requires a body, since it deals with 231 -- the case of optional bodies accurately (i.e. if a body is optional, 232 -- then it looks to see if a body is actually present). Note: this 233 -- function can only do a fully correct job if in generating code mode 234 -- where all bodies have to be present. If we are operating in semantics 235 -- check only mode, then in some cases of optional bodies, a result of 236 -- False may incorrectly be given. In practice this simply means that 237 -- some cases of warnings for incorrect order of elaboration will only 238 -- be given when generating code, which is not a big problem (and is 239 -- inevitable, given the optional body semantics of Ada). 240 241 procedure Insert_Elab_Check (N : Node_Id; C : Node_Id := Empty); 242 -- Given code for an elaboration check (or unconditional raise if 243 -- the check is not needed), inserts the code in the appropriate 244 -- place. N is the call or instantiation node for which the check 245 -- code is required. C is the test whose failure triggers the raise. 246 247 procedure Output_Calls (N : Node_Id); 248 -- Outputs chain of calls stored in the Elab_Call table. The caller 249 -- has already generated the main warning message, so the warnings 250 -- generated are all continuation messages. The argument is the 251 -- call node at which the messages are to be placed. 252 253 function Same_Elaboration_Scope (Scop1, Scop2 : Entity_Id) return Boolean; 254 -- Given two scopes, determine whether they are the same scope from an 255 -- elaboration point of view, i.e. packages and blocks are ignored. 256 257 procedure Set_C_Scope; 258 -- On entry C_Scope is set to some scope. On return, C_Scope is reset 259 -- to be the enclosing compilation unit of this scope. 260 261 function Spec_Entity (E : Entity_Id) return Entity_Id; 262 -- Given a compilation unit entity, if it is a spec entity, it is 263 -- returned unchanged. If it is a body entity, then the spec for 264 -- the corresponding spec is returned 265 266 procedure Supply_Bodies (N : Node_Id); 267 -- Given a node, N, that is either a subprogram declaration or a package 268 -- declaration, this procedure supplies dummy bodies for the subprogram 269 -- or for all subprograms in the package. If the given node is not one 270 -- of these two possibilities, then Supply_Bodies does nothing. The 271 -- dummy body is supplied by setting the subprogram to be Imported with 272 -- convention Stubbed. 273 274 procedure Supply_Bodies (L : List_Id); 275 -- Calls Supply_Bodies for all elements of the given list L. 276 277 function Within (E1, E2 : Entity_Id) return Boolean; 278 -- Given two scopes E1 and E2, returns True if E1 is equal to E2, or 279 -- is one of its contained scopes, False otherwise. 280 281 function Within_Elaborate_All (E : Entity_Id) return Boolean; 282 -- Before emitting a warning on a scope E for a missing elaborate_all, 283 -- check whether E may be in the context of a directly visible unit 284 -- U to which the pragma applies. This prevents spurious warnings when 285 -- the called entity is renamed within U. 286 287 ------------------ 288 -- Check_A_Call -- 289 ------------------ 290 291 procedure Check_A_Call 292 (N : Node_Id; 293 E : Entity_Id; 294 Outer_Scope : Entity_Id; 295 Inter_Unit_Only : Boolean; 296 Generate_Warnings : Boolean := True) 297 is 298 Loc : constant Source_Ptr := Sloc (N); 299 Ent : Entity_Id; 300 Decl : Node_Id; 301 302 E_Scope : Entity_Id; 303 -- Top level scope of entity for called subprogram. This 304 -- value includes following renamings and derivations, so 305 -- this scope can be in a non-visible unit. This is the 306 -- scope that is to be investigated to see whether an 307 -- elaboration check is required. 308 309 W_Scope : Entity_Id; 310 -- Top level scope of directly called entity for subprogram. 311 -- This differs from E_Scope in the case where renamings or 312 -- derivations are involved, since it does not follow these 313 -- links, thus W_Scope is always in a visible unit. This is 314 -- the scope for the Elaborate_All if one is needed. 315 316 Body_Acts_As_Spec : Boolean; 317 -- Set to true if call is to body acting as spec (no separate spec) 318 319 Inst_Case : constant Boolean := Nkind (N) in N_Generic_Instantiation; 320 -- Indicates if we have instantiation case 321 322 Caller_Unit_Internal : Boolean; 323 Callee_Unit_Internal : Boolean; 324 325 Inst_Caller : Source_Ptr; 326 Inst_Callee : Source_Ptr; 327 328 Unit_Caller : Unit_Number_Type; 329 Unit_Callee : Unit_Number_Type; 330 331 Cunit_SC : Boolean := False; 332 -- Set to suppress dynamic elaboration checks where one of the 333 -- enclosing scopes has Elaboration_Checks_Suppressed set, or else 334 -- if a pragma Elaborate (_All) applies to that scope, in which case 335 -- warnings on the scope are also suppressed. For the internal case, 336 -- we ignore this flag. 337 338 begin 339 -- If the call is known to be within a local Suppress Elaboration 340 -- pragma, nothing to check. This can happen in task bodies. 341 342 if (Nkind (N) = N_Function_Call 343 or else Nkind (N) = N_Procedure_Call_Statement) 344 and then No_Elaboration_Check (N) 345 then 346 return; 347 end if; 348 349 -- Go to parent for derived subprogram, or to original subprogram 350 -- in the case of a renaming (Alias covers both these cases) 351 352 Ent := E; 353 loop 354 if (Suppress_Elaboration_Warnings (Ent) 355 or else Elaboration_Checks_Suppressed (Ent)) 356 and then (Inst_Case or else No (Alias (Ent))) 357 then 358 return; 359 end if; 360 361 -- Nothing to do for imported entities, 362 363 if Is_Imported (Ent) then 364 return; 365 end if; 366 367 exit when Inst_Case or else No (Alias (Ent)); 368 Ent := Alias (Ent); 369 end loop; 370 371 Decl := Unit_Declaration_Node (Ent); 372 373 if Nkind (Decl) = N_Subprogram_Body then 374 Body_Acts_As_Spec := True; 375 376 elsif Nkind (Decl) = N_Subprogram_Declaration 377 or else Nkind (Decl) = N_Subprogram_Body_Stub 378 or else Inst_Case 379 then 380 Body_Acts_As_Spec := False; 381 382 -- If we have none of an instantiation, subprogram body or 383 -- subprogram declaration, then it is not a case that we want 384 -- to check. (One case is a call to a generic formal subprogram, 385 -- where we do not want the check in the template). 386 387 else 388 return; 389 end if; 390 391 E_Scope := Ent; 392 loop 393 if Elaboration_Checks_Suppressed (E_Scope) 394 or else Suppress_Elaboration_Warnings (E_Scope) 395 then 396 Cunit_SC := True; 397 end if; 398 399 -- Exit when we get to compilation unit, not counting subunits 400 401 exit when Is_Compilation_Unit (E_Scope) 402 and then (Is_Child_Unit (E_Scope) 403 or else Scope (E_Scope) = Standard_Standard); 404 405 -- If we did not find a compilation unit, other than standard, 406 -- then nothing to check (happens in some instantiation cases) 407 408 if E_Scope = Standard_Standard then 409 return; 410 411 -- Otherwise move up a scope looking for compilation unit 412 413 else 414 E_Scope := Scope (E_Scope); 415 end if; 416 end loop; 417 418 -- No checks needed for pure or preelaborated compilation units 419 420 if Is_Pure (E_Scope) 421 or else Is_Preelaborated (E_Scope) 422 then 423 return; 424 end if; 425 426 -- If the generic entity is within a deeper instance than we are, then 427 -- either the instantiation to which we refer itself caused an ABE, in 428 -- which case that will be handled separately. Otherwise, we know that 429 -- the body we need appears as needed at the point of the instantiation. 430 -- However, this assumption is only valid if we are in static mode. 431 432 if not Dynamic_Elaboration_Checks 433 and then Instantiation_Depth (Sloc (Ent)) > 434 Instantiation_Depth (Sloc (N)) 435 then 436 return; 437 end if; 438 439 -- Do not give a warning for a package with no body 440 441 if Ekind (Ent) = E_Generic_Package 442 and then not Has_Generic_Body (N) 443 then 444 return; 445 end if; 446 447 -- Case of entity is not in current unit (i.e. with'ed unit case) 448 449 if E_Scope /= C_Scope then 450 451 -- We are only interested in such calls if the outer call was from 452 -- elaboration code, or if we are in Dynamic_Elaboration_Checks mode. 453 454 if not From_Elab_Code and then not Dynamic_Elaboration_Checks then 455 return; 456 end if; 457 458 -- Nothing to do if some scope said that no checks were required 459 460 if Cunit_SC then 461 return; 462 end if; 463 464 -- Nothing to do for a generic instance, because in this case 465 -- the checking was at the point of instantiation of the generic 466 -- However, this shortcut is only applicable in static mode. 467 468 if Is_Generic_Instance (Ent) and not Dynamic_Elaboration_Checks then 469 return; 470 end if; 471 472 -- Nothing to do if subprogram with no separate spec. However, 473 -- a call to Deep_Initialize may result in a call to a user-defined 474 -- Initialize procedure, which imposes a body dependency. This 475 -- happens only if the type is controlled and the Initialize 476 -- procedure is not inherited. 477 478 if Body_Acts_As_Spec then 479 if Is_TSS (Ent, TSS_Deep_Initialize) then 480 declare 481 Typ : Entity_Id; 482 Init : Entity_Id; 483 begin 484 Typ := Etype (Next_Formal (First_Formal (Ent))); 485 486 if not Is_Controlled (Typ) then 487 return; 488 else 489 Init := Find_Prim_Op (Typ, Name_Initialize); 490 491 if Comes_From_Source (Init) then 492 Ent := Init; 493 else 494 return; 495 end if; 496 end if; 497 end; 498 499 else 500 return; 501 end if; 502 end if; 503 504 -- Check cases of internal units 505 506 Callee_Unit_Internal := 507 Is_Internal_File_Name 508 (Unit_File_Name (Get_Source_Unit (E_Scope))); 509 510 -- Do not give a warning if the with'ed unit is internal 511 -- and this is the generic instantiation case (this saves a 512 -- lot of hassle dealing with the Text_IO special child units) 513 514 if Callee_Unit_Internal and Inst_Case then 515 return; 516 end if; 517 518 if C_Scope = Standard_Standard then 519 Caller_Unit_Internal := False; 520 else 521 Caller_Unit_Internal := 522 Is_Internal_File_Name 523 (Unit_File_Name (Get_Source_Unit (C_Scope))); 524 end if; 525 526 -- Do not give a warning if the with'ed unit is internal 527 -- and the caller is not internal (since the binder always 528 -- elaborates internal units first). 529 530 if Callee_Unit_Internal and (not Caller_Unit_Internal) then 531 return; 532 end if; 533 534 -- For now, if debug flag -gnatdE is not set, do no checking for 535 -- one internal unit withing another. This fixes the problem with 536 -- the sgi build and storage errors. To be resolved later ??? 537 538 if (Callee_Unit_Internal and Caller_Unit_Internal) 539 and then not Debug_Flag_EE 540 then 541 return; 542 end if; 543 544 if Is_TSS (E, TSS_Deep_Initialize) then 545 Ent := E; 546 end if; 547 548 -- If the call is in an instance, and the called entity is not 549 -- defined in the same instance, then the elaboration issue 550 -- focuses around the unit containing the template, it is 551 -- this unit which requires an Elaborate_All. 552 553 -- However, if we are doing dynamic elaboration, we need to 554 -- chase the call in the usual manner. 555 556 -- We do not handle the case of calling a generic formal correctly 557 -- in the static case. See test 4703-004 to explore this gap ??? 558 559 Inst_Caller := Instantiation (Get_Source_File_Index (Sloc (N))); 560 Inst_Callee := Instantiation (Get_Source_File_Index (Sloc (Ent))); 561 562 if Inst_Caller = No_Location then 563 Unit_Caller := No_Unit; 564 else 565 Unit_Caller := Get_Source_Unit (N); 566 end if; 567 568 if Inst_Callee = No_Location then 569 Unit_Callee := No_Unit; 570 else 571 Unit_Callee := Get_Source_Unit (Ent); 572 end if; 573 574 if Unit_Caller /= No_Unit 575 and then Unit_Callee /= Unit_Caller 576 and then not Dynamic_Elaboration_Checks 577 then 578 E_Scope := Spec_Entity (Cunit_Entity (Unit_Caller)); 579 580 -- If we don't get a spec entity, just ignore call. Not 581 -- quite clear why this check is necessary. 582 583 if No (E_Scope) then 584 return; 585 end if; 586 587 -- Otherwise step to enclosing compilation unit 588 589 while not Is_Compilation_Unit (E_Scope) loop 590 E_Scope := Scope (E_Scope); 591 end loop; 592 593 -- For the case N is not an instance, or a call within instance 594 -- We recompute E_Scope for the error message, since we 595 -- do NOT want to go to the unit which has the ultimate 596 -- declaration in the case of renaming and derivation and 597 -- we also want to go to the generic unit in the case of 598 -- an instance, and no further. 599 600 else 601 -- Loop to carefully follow renamings and derivations 602 -- one step outside the current unit, but not further. 603 604 if not Inst_Case 605 and then Present (Alias (Ent)) 606 then 607 E_Scope := Alias (Ent); 608 else 609 E_Scope := Ent; 610 end if; 611 612 loop 613 while not Is_Compilation_Unit (E_Scope) loop 614 E_Scope := Scope (E_Scope); 615 end loop; 616 617 -- If E_Scope is the same as C_Scope, it means that there 618 -- definitely was a local renaming or derivation, and we 619 -- are not yet out of the current unit. 620 621 exit when E_Scope /= C_Scope; 622 Ent := Alias (Ent); 623 E_Scope := Ent; 624 625 -- If no alias, there is a previous error 626 627 if No (Ent) then 628 return; 629 end if; 630 end loop; 631 end if; 632 633 if Within_Elaborate_All (E_Scope) then 634 return; 635 end if; 636 637 -- Find top level scope for called entity (not following renamings 638 -- or derivations). This is where the Elaborate_All will go if it 639 -- is needed. We start with the called entity, except in the case 640 -- of initialization procedures, where the init proc is in the root 641 -- package, where we start fromn the entity of the name in the call. 642 643 if Is_Entity_Name (Name (N)) 644 and then Is_Init_Proc (Entity (Name (N))) 645 then 646 W_Scope := Scope (Entity (Name (N))); 647 else 648 W_Scope := E; 649 end if; 650 651 while not Is_Compilation_Unit (W_Scope) loop 652 W_Scope := Scope (W_Scope); 653 end loop; 654 655 -- Now check if an elaborate_all (or dynamic check) is needed 656 657 if not Suppress_Elaboration_Warnings (Ent) 658 and then not Elaboration_Checks_Suppressed (Ent) 659 and then not Suppress_Elaboration_Warnings (E_Scope) 660 and then not Elaboration_Checks_Suppressed (E_Scope) 661 and then Elab_Warnings 662 and then Generate_Warnings 663 then 664 if Inst_Case then 665 Error_Msg_NE 666 ("instantiation of& may raise Program_Error?", N, Ent); 667 668 else 669 if Is_Init_Proc (Entity (Name (N))) 670 and then Comes_From_Source (Ent) 671 then 672 Error_Msg_NE 673 ("implicit call to & may raise Program_Error?", N, Ent); 674 675 else 676 Error_Msg_NE 677 ("call to & may raise Program_Error?", N, Ent); 678 end if; 679 end if; 680 681 Error_Msg_Qual_Level := Nat'Last; 682 Error_Msg_NE 683 ("\missing pragma Elaborate_All for&?", N, W_Scope); 684 Error_Msg_Qual_Level := 0; 685 Output_Calls (N); 686 687 -- Set flag to prevent further warnings for same unit 688 -- unless in All_Errors_Mode. 689 690 if not All_Errors_Mode and not Dynamic_Elaboration_Checks then 691 Set_Suppress_Elaboration_Warnings (W_Scope, True); 692 end if; 693 end if; 694 695 -- Check for runtime elaboration check required 696 697 if Dynamic_Elaboration_Checks then 698 if not Elaboration_Checks_Suppressed (Ent) 699 and then not Elaboration_Checks_Suppressed (W_Scope) 700 and then not Elaboration_Checks_Suppressed (E_Scope) 701 and then not Cunit_SC 702 then 703 -- Runtime elaboration check required. Generate check of the 704 -- elaboration Boolean for the unit containing the entity. 705 706 -- Note that for this case, we do check the real unit (the 707 -- one from following renamings, since that is the issue!) 708 709 -- Could this possibly miss a useless but required PE??? 710 711 Insert_Elab_Check (N, 712 Make_Attribute_Reference (Loc, 713 Attribute_Name => Name_Elaborated, 714 Prefix => 715 New_Occurrence_Of 716 (Spec_Entity (E_Scope), Loc))); 717 end if; 718 719 -- Case of static elaboration model 720 721 else 722 -- Do not do anything if elaboration checks suppressed. Note 723 -- that we check Ent here, not E, since we want the real entity 724 -- for the body to see if checks are suppressed for it, not the 725 -- dummy entry for renamings or derivations. 726 727 if Elaboration_Checks_Suppressed (Ent) 728 or else Elaboration_Checks_Suppressed (E_Scope) 729 or else Elaboration_Checks_Suppressed (W_Scope) 730 then 731 null; 732 733 -- Here we need to generate an implicit elaborate all 734 735 else 736 -- Generate elaborate_all warning unless suppressed 737 738 if (Elab_Warnings and Generate_Warnings and not Inst_Case) 739 and then not Suppress_Elaboration_Warnings (Ent) 740 and then not Suppress_Elaboration_Warnings (E_Scope) 741 and then not Suppress_Elaboration_Warnings (W_Scope) 742 then 743 Error_Msg_Node_2 := W_Scope; 744 Error_Msg_NE 745 ("call to& in elaboration code " & 746 "requires pragma Elaborate_All on&?", N, E); 747 end if; 748 749 -- Set indication for binder to generate Elaborate_All 750 751 Set_Elaborate_All_Desirable (W_Scope); 752 Set_Suppress_Elaboration_Warnings (W_Scope, True); 753 end if; 754 end if; 755 756 -- Case of entity is in same unit as call or instantiation 757 758 elsif not Inter_Unit_Only then 759 Check_Internal_Call (N, Ent, Outer_Scope, E); 760 end if; 761 end Check_A_Call; 762 763 ----------------------------- 764 -- Check_Bad_Instantiation -- 765 ----------------------------- 766 767 procedure Check_Bad_Instantiation (N : Node_Id) is 768 Ent : Entity_Id; 769 770 begin 771 -- Nothing to do if we do not have an instantiation (happens in some 772 -- error cases, and also in the formal package declaration case) 773 774 if Nkind (N) not in N_Generic_Instantiation then 775 return; 776 777 -- Nothing to do if serious errors detected (avoid cascaded errors) 778 779 elsif Serious_Errors_Detected /= 0 then 780 return; 781 782 -- Nothing to do if not in full analysis mode 783 784 elsif not Full_Analysis then 785 return; 786 787 -- Nothing to do if inside a generic template 788 789 elsif Inside_A_Generic then 790 return; 791 792 -- Nothing to do if a library level instantiation 793 794 elsif Nkind (Parent (N)) = N_Compilation_Unit then 795 return; 796 797 -- Nothing to do if we are compiling a proper body for semantic 798 -- purposes only. The generic body may be in another proper body. 799 800 elsif 801 Nkind (Parent (Unit_Declaration_Node (Main_Unit_Entity))) = N_Subunit 802 then 803 return; 804 end if; 805 806 Ent := Get_Generic_Entity (N); 807 808 -- The case we are interested in is when the generic spec is in the 809 -- current declarative part 810 811 if not Same_Elaboration_Scope (Current_Scope, Scope (Ent)) 812 or else not In_Same_Extended_Unit (Sloc (N), Sloc (Ent)) 813 then 814 return; 815 end if; 816 817 -- If the generic entity is within a deeper instance than we are, then 818 -- either the instantiation to which we refer itself caused an ABE, in 819 -- which case that will be handled separately. Otherwise, we know that 820 -- the body we need appears as needed at the point of the instantiation. 821 -- If they are both at the same level but not within the same instance 822 -- then the body of the generic will be in the earlier instance. 823 824 declare 825 D1 : constant Int := Instantiation_Depth (Sloc (Ent)); 826 D2 : constant Int := Instantiation_Depth (Sloc (N)); 827 828 begin 829 if D1 > D2 then 830 return; 831 832 elsif D1 = D2 833 and then Is_Generic_Instance (Scope (Ent)) 834 and then not In_Open_Scopes (Scope (Ent)) 835 then 836 return; 837 end if; 838 end; 839 840 -- Now we can proceed, if the entity being called has a completion, 841 -- then we are definitely OK, since we have already seen the body. 842 843 if Has_Completion (Ent) then 844 return; 845 end if; 846 847 -- If there is no body, then nothing to do 848 849 if not Has_Generic_Body (N) then 850 return; 851 end if; 852 853 -- Here we definitely have a bad instantiation 854 855 Error_Msg_NE 856 ("?cannot instantiate& before body seen", N, Ent); 857 858 if Present (Instance_Spec (N)) then 859 Supply_Bodies (Instance_Spec (N)); 860 end if; 861 862 Error_Msg_N 863 ("\?Program_Error will be raised at run time", N); 864 Insert_Elab_Check (N); 865 Set_ABE_Is_Certain (N); 866 867 end Check_Bad_Instantiation; 868 869 --------------------- 870 -- Check_Elab_Call -- 871 --------------------- 872 873 procedure Check_Elab_Call 874 (N : Node_Id; 875 Outer_Scope : Entity_Id := Empty) 876 is 877 Ent : Entity_Id; 878 P : Node_Id; 879 880 function Get_Called_Ent return Entity_Id; 881 -- Retrieve called entity. If this is a call to a protected subprogram, 882 -- entity is a selected component. The callable entity may be absent, 883 -- in which case there is no check to perform. This happens with 884 -- non-analyzed calls in nested generics. 885 886 -------------------- 887 -- Get_Called_Ent -- 888 -------------------- 889 890 function Get_Called_Ent return Entity_Id is 891 Nam : Node_Id; 892 893 begin 894 Nam := Name (N); 895 896 if No (Nam) then 897 return Empty; 898 899 elsif Nkind (Nam) = N_Selected_Component then 900 return Entity (Selector_Name (Nam)); 901 902 elsif not Is_Entity_Name (Nam) then 903 return Empty; 904 905 else 906 return Entity (Nam); 907 end if; 908 end Get_Called_Ent; 909 910 -- Start of processing for Check_Elab_Call 911 912 begin 913 -- For an entry call, check relevant restriction 914 915 if Nkind (N) = N_Entry_Call_Statement 916 and then not In_Subprogram_Or_Concurrent_Unit 917 then 918 Check_Restriction (No_Entry_Calls_In_Elaboration_Code, N); 919 920 -- Nothing to do if this is not a call (happens in some error 921 -- conditions, and in some cases where rewriting occurs). 922 923 elsif Nkind (N) /= N_Function_Call 924 and then Nkind (N) /= N_Procedure_Call_Statement 925 then 926 return; 927 928 -- Nothing to do if this is a call already rewritten for elab checking. 929 930 elsif Nkind (Parent (N)) = N_Conditional_Expression then 931 return; 932 933 -- Nothing to do if inside a generic template 934 935 elsif Inside_A_Generic 936 and then not Present (Enclosing_Generic_Body (N)) 937 then 938 return; 939 end if; 940 941 -- Here we have a call at elaboration time which must be checked 942 943 if Debug_Flag_LL then 944 Write_Str (" Check_Elab_Call: "); 945 946 if No (Name (N)) 947 or else not Is_Entity_Name (Name (N)) 948 then 949 Write_Str ("<<not entity name>> "); 950 else 951 Write_Name (Chars (Entity (Name (N)))); 952 end if; 953 954 Write_Str (" call at "); 955 Write_Location (Sloc (N)); 956 Write_Eol; 957 end if; 958 959 -- Climb up the tree to make sure we are not inside a 960 -- default expression of a parameter specification or 961 -- a record component, since in both these cases, we 962 -- will be doing the actual call later, not now, and it 963 -- is at the time of the actual call (statically speaking) 964 -- that we must do our static check, not at the time of 965 -- its initial analysis). 966 967 P := Parent (N); 968 while Present (P) loop 969 if Nkind (P) = N_Parameter_Specification 970 or else 971 Nkind (P) = N_Component_Declaration 972 then 973 return; 974 else 975 P := Parent (P); 976 end if; 977 end loop; 978 979 -- Stuff that happens only at the outer level 980 981 if No (Outer_Scope) then 982 Elab_Visited.Set_Last (0); 983 984 -- Nothing to do if current scope is Standard (this is a bit 985 -- odd, but it happens in the case of generic instantiations). 986 987 C_Scope := Current_Scope; 988 989 if C_Scope = Standard_Standard then 990 return; 991 end if; 992 993 -- First case, we are in elaboration code 994 995 From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit; 996 if From_Elab_Code then 997 998 -- Complain if call that comes from source in preelaborated 999 -- unit and we are not inside a subprogram (i.e. we are in 1000 -- elab code) 1001 1002 if Comes_From_Source (N) 1003 and then In_Preelaborated_Unit 1004 and then not In_Inlined_Body 1005 then 1006 Error_Msg_N 1007 ("non-static call not allowed in preelaborated unit", N); 1008 return; 1009 end if; 1010 1011 -- Second case, we are inside a subprogram or concurrent unit 1012 -- i.e, we are not in elaboration code. 1013 1014 else 1015 -- In this case, the issue is whether we are inside the 1016 -- declarative part of the unit in which we live, or inside 1017 -- its statements. In the latter case, there is no issue of 1018 -- ABE calls at this level (a call from outside to the unit 1019 -- in which we live might cause an ABE, but that will be 1020 -- detected when we analyze that outer level call, as it 1021 -- recurses into the called unit). 1022 1023 -- Climb up the tree, doing this test, and also testing 1024 -- for being inside a default expression, which, as 1025 -- discussed above, is not checked at this stage. 1026 1027 declare 1028 P : Node_Id; 1029 L : List_Id; 1030 1031 begin 1032 P := N; 1033 loop 1034 -- If we find a parentless subtree, it seems safe to 1035 -- assume that we are not in a declarative part and 1036 -- that no checking is required. 1037 1038 if No (P) then 1039 return; 1040 end if; 1041 1042 if Is_List_Member (P) then 1043 L := List_Containing (P); 1044 P := Parent (L); 1045 else 1046 L := No_List; 1047 P := Parent (P); 1048 end if; 1049 1050 exit when Nkind (P) = N_Subunit; 1051 1052 -- Filter out case of default expressions, where 1053 -- we do not do the check at this stage. 1054 1055 if Nkind (P) = N_Parameter_Specification 1056 or else 1057 Nkind (P) = N_Component_Declaration 1058 then 1059 return; 1060 end if; 1061 1062 if Nkind (P) = N_Subprogram_Body 1063 or else 1064 Nkind (P) = N_Protected_Body 1065 or else 1066 Nkind (P) = N_Task_Body 1067 or else 1068 Nkind (P) = N_Block_Statement 1069 then 1070 if L = Declarations (P) then 1071 exit; 1072 1073 -- We are not in elaboration code, but we are doing 1074 -- dynamic elaboration checks, in this case, we still 1075 -- need to do the call, since the subprogram we are in 1076 -- could be called from another unit, also in dynamic 1077 -- elaboration check mode, at elaboration time. 1078 1079 elsif Dynamic_Elaboration_Checks then 1080 1081 -- This is a rather new check, going into version 1082 -- 3.14a1 for the first time (V1.80 of this unit), 1083 -- so we provide a debug flag to enable it. That 1084 -- way we have an easy work around for regressions 1085 -- that are caused by this new check. This debug 1086 -- flag can be removed later. 1087 1088 if Debug_Flag_DD then 1089 return; 1090 end if; 1091 1092 -- Do the check in this case 1093 1094 exit; 1095 1096 elsif Nkind (P) = N_Task_Body then 1097 1098 -- The check is deferred until Check_Task_Activation 1099 -- but we need to capture local suppress pragmas 1100 -- that may inhibit checks on this call. 1101 1102 Ent := Get_Called_Ent; 1103 1104 if No (Ent) then 1105 return; 1106 1107 elsif Elaboration_Checks_Suppressed (Current_Scope) 1108 or else Elaboration_Checks_Suppressed (Ent) 1109 or else Elaboration_Checks_Suppressed (Scope (Ent)) 1110 then 1111 Set_No_Elaboration_Check (N); 1112 end if; 1113 1114 return; 1115 1116 -- Static model, call is not in elaboration code, we 1117 -- never need to worry, because in the static model 1118 -- the top level caller always takes care of things. 1119 1120 else 1121 return; 1122 end if; 1123 end if; 1124 end loop; 1125 end; 1126 end if; 1127 end if; 1128 1129 Ent := Get_Called_Ent; 1130 1131 if No (Ent) then 1132 return; 1133 end if; 1134 1135 -- Nothing to do if this is a recursive call (i.e. a call to 1136 -- an entity that is already in the Elab_Call stack) 1137 1138 for J in 1 .. Elab_Visited.Last loop 1139 if Ent = Elab_Visited.Table (J) then 1140 return; 1141 end if; 1142 end loop; 1143 1144 -- See if we need to analyze this call. We analyze it if either of 1145 -- the following conditions is met: 1146 1147 -- It is an inner level call (since in this case it was triggered 1148 -- by an outer level call from elaboration code), but only if the 1149 -- call is within the scope of the original outer level call. 1150 1151 -- It is an outer level call from elaboration code, or the called 1152 -- entity is in the same elaboration scope. 1153 1154 -- And in these cases, we will check both inter-unit calls and 1155 -- intra-unit (within a single unit) calls. 1156 1157 C_Scope := Current_Scope; 1158 1159 -- If not outer level call, then we follow it if it is within 1160 -- the original scope of the outer call. 1161 1162 if Present (Outer_Scope) 1163 and then Within (Scope (Ent), Outer_Scope) 1164 then 1165 Set_C_Scope; 1166 Check_A_Call (N, Ent, Outer_Scope, Inter_Unit_Only => False); 1167 1168 elsif Elaboration_Checks_Suppressed (Current_Scope) then 1169 null; 1170 1171 elsif From_Elab_Code then 1172 Set_C_Scope; 1173 Check_A_Call (N, Ent, Standard_Standard, Inter_Unit_Only => False); 1174 1175 elsif Same_Elaboration_Scope (C_Scope, Scope (Ent)) then 1176 Set_C_Scope; 1177 Check_A_Call (N, Ent, Scope (Ent), Inter_Unit_Only => False); 1178 1179 -- If none of those cases holds, but Dynamic_Elaboration_Checks mode 1180 -- is set, then we will do the check, but only in the inter-unit case 1181 -- (this is to accommodate unguarded elaboration calls from other units 1182 -- in which this same mode is set). We don't want warnings in this case, 1183 -- it would generate warnings having nothing to do with elaboration. 1184 1185 elsif Dynamic_Elaboration_Checks then 1186 Set_C_Scope; 1187 Check_A_Call 1188 (N, 1189 Ent, 1190 Standard_Standard, 1191 Inter_Unit_Only => True, 1192 Generate_Warnings => False); 1193 1194 -- Otherwise nothing to do 1195 1196 else 1197 return; 1198 end if; 1199 1200 -- A call to an Init_Proc in elaboration code may bring additional 1201 -- dependencies, if some of the record components thereof have 1202 -- initializations that are function calls that come from source. 1203 -- We treat the current node as a call to each of these functions, 1204 -- to check their elaboration impact. 1205 1206 if Is_Init_Proc (Ent) 1207 and then From_Elab_Code 1208 then 1209 Process_Init_Proc : declare 1210 Unit_Decl : constant Node_Id := Unit_Declaration_Node (Ent); 1211 1212 function Process (Nod : Node_Id) return Traverse_Result; 1213 -- Find subprogram calls within body of init_proc for 1214 -- Traverse instantiation below. 1215 1216 function Process (Nod : Node_Id) return Traverse_Result is 1217 Func : Entity_Id; 1218 1219 begin 1220 if (Nkind (Nod) = N_Function_Call 1221 or else Nkind (Nod) = N_Procedure_Call_Statement) 1222 and then Is_Entity_Name (Name (Nod)) 1223 then 1224 Func := Entity (Name (Nod)); 1225 1226 if Comes_From_Source (Func) then 1227 Check_A_Call 1228 (N, Func, Standard_Standard, Inter_Unit_Only => True); 1229 end if; 1230 1231 return OK; 1232 1233 else 1234 return OK; 1235 end if; 1236 end Process; 1237 1238 procedure Traverse_Body is new Traverse_Proc (Process); 1239 1240 -- Start of processing for Process_Init_Proc 1241 1242 begin 1243 if Nkind (Unit_Decl) = N_Subprogram_Body then 1244 Traverse_Body (Handled_Statement_Sequence (Unit_Decl)); 1245 end if; 1246 end Process_Init_Proc; 1247 end if; 1248 end Check_Elab_Call; 1249 1250 ---------------------- 1251 -- Check_Elab_Calls -- 1252 ---------------------- 1253 1254 procedure Check_Elab_Calls is 1255 begin 1256 -- If expansion is disabled, do not generate any checks. Also 1257 -- skip checks if any subunits are missing because in either 1258 -- case we lack the full information that we need, and no object 1259 -- file will be created in any case. 1260 1261 if not Expander_Active 1262 or else Is_Generic_Unit (Cunit_Entity (Main_Unit)) 1263 or else Subunits_Missing 1264 then 1265 return; 1266 end if; 1267 1268 -- Skip delayed calls if we had any errors 1269 1270 if Serious_Errors_Detected = 0 then 1271 Delaying_Elab_Checks := False; 1272 Expander_Mode_Save_And_Set (True); 1273 1274 for J in Delay_Check.First .. Delay_Check.Last loop 1275 New_Scope (Delay_Check.Table (J).Curscop); 1276 From_Elab_Code := Delay_Check.Table (J).From_Elab_Code; 1277 1278 Check_Internal_Call_Continue ( 1279 N => Delay_Check.Table (J).N, 1280 E => Delay_Check.Table (J).E, 1281 Outer_Scope => Delay_Check.Table (J).Outer_Scope, 1282 Orig_Ent => Delay_Check.Table (J).Orig_Ent); 1283 1284 Pop_Scope; 1285 end loop; 1286 1287 -- Set Delaying_Elab_Checks back on for next main compilation 1288 1289 Expander_Mode_Restore; 1290 Delaying_Elab_Checks := True; 1291 end if; 1292 end Check_Elab_Calls; 1293 1294 ------------------------------ 1295 -- Check_Elab_Instantiation -- 1296 ------------------------------ 1297 1298 procedure Check_Elab_Instantiation 1299 (N : Node_Id; 1300 Outer_Scope : Entity_Id := Empty) 1301 is 1302 Ent : Entity_Id; 1303 1304 begin 1305 -- Check for and deal with bad instantiation case. There is some 1306 -- duplicated code here, but we will worry about this later ??? 1307 1308 Check_Bad_Instantiation (N); 1309 1310 if ABE_Is_Certain (N) then 1311 return; 1312 end if; 1313 1314 -- Nothing to do if we do not have an instantiation (happens in some 1315 -- error cases, and also in the formal package declaration case) 1316 1317 if Nkind (N) not in N_Generic_Instantiation then 1318 return; 1319 end if; 1320 1321 -- Nothing to do if inside a generic template 1322 1323 if Inside_A_Generic then 1324 return; 1325 end if; 1326 1327 Ent := Get_Generic_Entity (N); 1328 From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit; 1329 1330 -- See if we need to analyze this instantiation. We analyze it if 1331 -- either of the following conditions is met: 1332 1333 -- It is an inner level instantiation (since in this case it was 1334 -- triggered by an outer level call from elaboration code), but 1335 -- only if the instantiation is within the scope of the original 1336 -- outer level call. 1337 1338 -- It is an outer level instantiation from elaboration code, or the 1339 -- instantiated entity is in the same elaboratoin scope. 1340 1341 -- And in these cases, we will check both the inter-unit case and 1342 -- the intra-unit (within a single unit) case. 1343 1344 C_Scope := Current_Scope; 1345 1346 if Present (Outer_Scope) 1347 and then Within (Scope (Ent), Outer_Scope) 1348 then 1349 Set_C_Scope; 1350 Check_A_Call (N, Ent, Outer_Scope, Inter_Unit_Only => False); 1351 1352 elsif From_Elab_Code then 1353 Set_C_Scope; 1354 Check_A_Call (N, Ent, Standard_Standard, Inter_Unit_Only => False); 1355 1356 elsif Same_Elaboration_Scope (C_Scope, Scope (Ent)) then 1357 Set_C_Scope; 1358 Check_A_Call (N, Ent, Scope (Ent), Inter_Unit_Only => False); 1359 1360 -- If none of those cases holds, but Dynamic_Elaboration_Checks mode 1361 -- is set, then we will do the check, but only in the inter-unit case 1362 -- (this is to accommodate unguarded elaboration calls from other units 1363 -- in which this same mode is set). We inhibit warnings in this case, 1364 -- since this instantiation is not occurring in elaboration code. 1365 1366 elsif Dynamic_Elaboration_Checks then 1367 Set_C_Scope; 1368 Check_A_Call 1369 (N, 1370 Ent, 1371 Standard_Standard, 1372 Inter_Unit_Only => True, 1373 Generate_Warnings => False); 1374 1375 else 1376 return; 1377 end if; 1378 end Check_Elab_Instantiation; 1379 1380 ------------------------- 1381 -- Check_Internal_Call -- 1382 ------------------------- 1383 1384 procedure Check_Internal_Call 1385 (N : Node_Id; 1386 E : Entity_Id; 1387 Outer_Scope : Entity_Id; 1388 Orig_Ent : Entity_Id) 1389 is 1390 Inst_Case : constant Boolean := Nkind (N) in N_Generic_Instantiation; 1391 1392 begin 1393 -- If not function or procedure call or instantiation, then ignore 1394 -- call (this happens in some error case and rewriting cases) 1395 1396 if Nkind (N) /= N_Function_Call 1397 and then 1398 Nkind (N) /= N_Procedure_Call_Statement 1399 and then 1400 not Inst_Case 1401 then 1402 return; 1403 1404 -- Nothing to do if this is a call or instantiation that has 1405 -- already been found to be a sure ABE 1406 1407 elsif ABE_Is_Certain (N) then 1408 return; 1409 1410 -- Nothing to do if errors already detected (avoid cascaded errors) 1411 1412 elsif Serious_Errors_Detected /= 0 then 1413 return; 1414 1415 -- Nothing to do if not in full analysis mode 1416 1417 elsif not Full_Analysis then 1418 return; 1419 1420 -- Nothing to do if within a default expression, since the call 1421 -- is not actualy being made at this time. 1422 1423 elsif In_Default_Expression then 1424 return; 1425 1426 -- Nothing to do for call to intrinsic subprogram 1427 1428 elsif Is_Intrinsic_Subprogram (E) then 1429 return; 1430 1431 -- No need to trace local calls if checking task activation, because 1432 -- other local bodies are elaborated already. 1433 1434 elsif In_Task_Activation then 1435 return; 1436 end if; 1437 1438 -- Delay this call if we are still delaying calls 1439 1440 if Delaying_Elab_Checks then 1441 Delay_Check.Increment_Last; 1442 Delay_Check.Table (Delay_Check.Last) := 1443 (N => N, 1444 E => E, 1445 Orig_Ent => Orig_Ent, 1446 Curscop => Current_Scope, 1447 Outer_Scope => Outer_Scope, 1448 From_Elab_Code => From_Elab_Code); 1449 return; 1450 1451 -- Otherwise, call phase 2 continuation right now 1452 1453 else 1454 Check_Internal_Call_Continue (N, E, Outer_Scope, Orig_Ent); 1455 end if; 1456 1457 end Check_Internal_Call; 1458 1459 ---------------------------------- 1460 -- Check_Internal_Call_Continue -- 1461 ---------------------------------- 1462 1463 procedure Check_Internal_Call_Continue 1464 (N : Node_Id; 1465 E : Entity_Id; 1466 Outer_Scope : Entity_Id; 1467 Orig_Ent : Entity_Id) 1468 is 1469 Loc : constant Source_Ptr := Sloc (N); 1470 Inst_Case : constant Boolean := Is_Generic_Unit (E); 1471 1472 Sbody : Node_Id; 1473 Ebody : Entity_Id; 1474 1475 function Process (N : Node_Id) return Traverse_Result; 1476 -- Function applied to each node as we traverse the body. 1477 -- Checks for call that needs checking, and if so checks 1478 -- it. Always returns OK, so entire tree is traversed. 1479 1480 ------------- 1481 -- Process -- 1482 ------------- 1483 1484 function Process (N : Node_Id) return Traverse_Result is 1485 begin 1486 -- If user has specified that there are no entry calls in elaboration 1487 -- code, do not trace past an accept statement, because the rendez- 1488 -- vous will happen after elaboration. 1489 1490 if (Nkind (Original_Node (N)) = N_Accept_Statement 1491 or else Nkind (Original_Node (N)) = N_Selective_Accept) 1492 and then Restrictions (No_Entry_Calls_In_Elaboration_Code) 1493 then 1494 return Abandon; 1495 1496 -- If we have a subprogram call, check it 1497 1498 elsif Nkind (N) = N_Function_Call 1499 or else Nkind (N) = N_Procedure_Call_Statement 1500 then 1501 Check_Elab_Call (N, Outer_Scope); 1502 return OK; 1503 1504 -- If we have a generic instantiation, check it 1505 1506 elsif Nkind (N) in N_Generic_Instantiation then 1507 Check_Elab_Instantiation (N, Outer_Scope); 1508 return OK; 1509 1510 -- Skip subprogram bodies that come from source (wait for 1511 -- call to analyze these). The reason for the come from 1512 -- source test is to avoid catching task bodies. 1513 1514 -- For task bodies, we should really avoid these too, waiting 1515 -- for the task activation, but that's too much trouble to 1516 -- catch for now, so we go in unconditionally. This is not 1517 -- so terrible, it means the error backtrace is not quite 1518 -- complete, and we are too eager to scan bodies of tasks 1519 -- that are unused, but this is hardly very significant! 1520 1521 elsif Nkind (N) = N_Subprogram_Body 1522 and then Comes_From_Source (N) 1523 then 1524 return Skip; 1525 1526 else 1527 return OK; 1528 end if; 1529 end Process; 1530 1531 procedure Traverse is new Atree.Traverse_Proc; 1532 -- Traverse procedure using above Process function 1533 1534 -- Start of processing for Check_Internal_Call_Continue 1535 1536 begin 1537 -- Save outer level call if at outer level 1538 1539 if Elab_Call.Last = 0 then 1540 Outer_Level_Sloc := Loc; 1541 end if; 1542 1543 Elab_Visited.Increment_Last; 1544 Elab_Visited.Table (Elab_Visited.Last) := E; 1545 1546 -- If the call is to a function that renames a literal, no check 1547 -- is needed. 1548 1549 if Ekind (E) = E_Enumeration_Literal then 1550 return; 1551 end if; 1552 1553 Sbody := Unit_Declaration_Node (E); 1554 1555 if Nkind (Sbody) /= N_Subprogram_Body 1556 and then 1557 Nkind (Sbody) /= N_Package_Body 1558 then 1559 Ebody := Corresponding_Body (Sbody); 1560 1561 if No (Ebody) then 1562 return; 1563 else 1564 Sbody := Unit_Declaration_Node (Ebody); 1565 end if; 1566 end if; 1567 1568 -- If the body appears after the outer level call or 1569 -- instantiation then we have an error case handled below. 1570 1571 if Earlier_In_Extended_Unit (Outer_Level_Sloc, Sloc (Sbody)) 1572 and then not In_Task_Activation 1573 then 1574 null; 1575 1576 -- If we have the instantiation case we are done, since we now 1577 -- know that the body of the generic appeared earlier. 1578 1579 elsif Inst_Case then 1580 return; 1581 1582 -- Otherwise we have a call, so we trace through the called 1583 -- body to see if it has any problems .. 1584 1585 else 1586 pragma Assert (Nkind (Sbody) = N_Subprogram_Body); 1587 1588 Elab_Call.Increment_Last; 1589 Elab_Call.Table (Elab_Call.Last).Cloc := Loc; 1590 Elab_Call.Table (Elab_Call.Last).Ent := E; 1591 1592 if Debug_Flag_LL then 1593 Write_Str ("Elab_Call.Last = "); 1594 Write_Int (Int (Elab_Call.Last)); 1595 Write_Str (" Ent = "); 1596 Write_Name (Chars (E)); 1597 Write_Str (" at "); 1598 Write_Location (Sloc (N)); 1599 Write_Eol; 1600 end if; 1601 1602 -- Now traverse declarations and statements of subprogram body. 1603 -- Note that we cannot simply Traverse (Sbody), since traverse 1604 -- does not normally visit subprogram bodies. 1605 1606 declare 1607 Decl : Node_Id := First (Declarations (Sbody)); 1608 1609 begin 1610 while Present (Decl) loop 1611 Traverse (Decl); 1612 Next (Decl); 1613 end loop; 1614 end; 1615 1616 Traverse (Handled_Statement_Sequence (Sbody)); 1617 1618 Elab_Call.Decrement_Last; 1619 return; 1620 end if; 1621 1622 -- Here is the case of calling a subprogram where the body has 1623 -- not yet been encountered, a warning message is needed. 1624 1625 -- If we have nothing in the call stack, then this is at the 1626 -- outer level, and the ABE is bound to occur. 1627 1628 if Elab_Call.Last = 0 then 1629 if Inst_Case then 1630 Error_Msg_NE 1631 ("?cannot instantiate& before body seen", N, Orig_Ent); 1632 else 1633 Error_Msg_NE 1634 ("?cannot call& before body seen", N, Orig_Ent); 1635 end if; 1636 1637 Error_Msg_N 1638 ("\?Program_Error will be raised at run time", N); 1639 Insert_Elab_Check (N); 1640 1641 -- Call is not at outer level 1642 1643 else 1644 -- Deal with dynamic elaboration check 1645 1646 if not Elaboration_Checks_Suppressed (E) then 1647 Set_Elaboration_Entity_Required (E); 1648 1649 -- Case of no elaboration entity allocated yet 1650 1651 if No (Elaboration_Entity (E)) then 1652 1653 -- Create object declaration for elaboration entity, and put it 1654 -- just in front of the spec of the subprogram or generic unit, 1655 -- in the same scope as this unit. 1656 1657 declare 1658 Loce : constant Source_Ptr := Sloc (E); 1659 Ent : constant Entity_Id := 1660 Make_Defining_Identifier (Loc, 1661 Chars => New_External_Name (Chars (E), 'E')); 1662 1663 begin 1664 Set_Elaboration_Entity (E, Ent); 1665 New_Scope (Scope (E)); 1666 1667 Insert_Action (Declaration_Node (E), 1668 Make_Object_Declaration (Loce, 1669 Defining_Identifier => Ent, 1670 Object_Definition => 1671 New_Occurrence_Of (Standard_Boolean, Loce), 1672 Expression => New_Occurrence_Of (Standard_False, Loce))); 1673 1674 -- Set elaboration flag at the point of the body 1675 1676 Set_Elaboration_Flag (Sbody, E); 1677 1678 -- Kill current value indication. This is necessary 1679 -- because the tests of this flag are inserted out of 1680 -- sequence and must not pick up bogus indications of 1681 -- the wrong constant value. Also, this is never a true 1682 -- constant, since one way or another, it gets reset. 1683 1684 Set_Current_Value (Ent, Empty); 1685 Set_Is_True_Constant (Ent, False); 1686 Pop_Scope; 1687 end; 1688 end if; 1689 1690 -- Generate check of the elaboration Boolean 1691 1692 Insert_Elab_Check (N, 1693 New_Occurrence_Of (Elaboration_Entity (E), Loc)); 1694 end if; 1695 1696 -- Generate the warning 1697 1698 if not Suppress_Elaboration_Warnings (E) 1699 and then not Elaboration_Checks_Suppressed (E) 1700 then 1701 if Inst_Case then 1702 Error_Msg_NE 1703 ("instantiation of& may occur before body is seen?", 1704 N, Orig_Ent); 1705 else 1706 Error_Msg_NE 1707 ("call to& may occur before body is seen?", N, Orig_Ent); 1708 end if; 1709 1710 Error_Msg_N 1711 ("\Program_Error may be raised at run time?", N); 1712 1713 Output_Calls (N); 1714 end if; 1715 end if; 1716 1717 -- Set flag to suppress further warnings on same subprogram 1718 -- unless in all errors mode 1719 1720 if not All_Errors_Mode then 1721 Set_Suppress_Elaboration_Warnings (E); 1722 end if; 1723 end Check_Internal_Call_Continue; 1724 1725 --------------------------- 1726 -- Check_Task_Activation -- 1727 --------------------------- 1728 1729 procedure Check_Task_Activation (N : Node_Id) is 1730 Loc : constant Source_Ptr := Sloc (N); 1731 Inter_Procs : constant Elist_Id := New_Elmt_List; 1732 Intra_Procs : constant Elist_Id := New_Elmt_List; 1733 Ent : Entity_Id; 1734 P : Entity_Id; 1735 Task_Scope : Entity_Id; 1736 Cunit_SC : Boolean := False; 1737 Decl : Node_Id; 1738 Elmt : Elmt_Id; 1739 Enclosing : Entity_Id; 1740 1741 procedure Add_Task_Proc (Typ : Entity_Id); 1742 -- Add to Task_Procs the task body procedure(s) of task types in Typ. 1743 -- For record types, this procedure recurses over component types. 1744 1745 procedure Collect_Tasks (Decls : List_Id); 1746 -- Collect the types of the tasks that are to be activated in the given 1747 -- list of declarations, in order to perform elaboration checks on the 1748 -- corresponding task procedures which are called implicitly here. 1749 1750 function Outer_Unit (E : Entity_Id) return Entity_Id; 1751 -- find enclosing compilation unit of Entity, ignoring subunits, or 1752 -- else enclosing subprogram. If E is not a package, there is no need 1753 -- for inter-unit elaboration checks. 1754 1755 ------------------- 1756 -- Add_Task_Proc -- 1757 ------------------- 1758 1759 procedure Add_Task_Proc (Typ : Entity_Id) is 1760 Comp : Entity_Id; 1761 Proc : Entity_Id := Empty; 1762 1763 begin 1764 if Is_Task_Type (Typ) then 1765 Proc := Get_Task_Body_Procedure (Typ); 1766 1767 elsif Is_Array_Type (Typ) 1768 and then Has_Task (Base_Type (Typ)) 1769 then 1770 Add_Task_Proc (Component_Type (Typ)); 1771 1772 elsif Is_Record_Type (Typ) 1773 and then Has_Task (Base_Type (Typ)) 1774 then 1775 Comp := First_Component (Typ); 1776 1777 while Present (Comp) loop 1778 Add_Task_Proc (Etype (Comp)); 1779 Comp := Next_Component (Comp); 1780 end loop; 1781 end if; 1782 1783 -- If the task type is another unit, we will perform the usual 1784 -- elaboration check on its enclosing unit. If the type is in the 1785 -- same unit, we can trace the task body as for an internal call, 1786 -- but we only need to examine other external calls, because at 1787 -- the point the task is activated, internal subprogram bodies 1788 -- will have been elaborated already. We keep separate lists for 1789 -- each kind of task. 1790 1791 -- Skip this test if errors have occurred, since in this case 1792 -- we can get false indications. 1793 1794 if Serious_Errors_Detected /= 0 then 1795 return; 1796 end if; 1797 1798 if Present (Proc) then 1799 if Outer_Unit (Scope (Proc)) = Enclosing then 1800 1801 if No (Corresponding_Body (Unit_Declaration_Node (Proc))) 1802 and then 1803 (not Is_Generic_Instance (Scope (Proc)) 1804 or else 1805 Scope (Proc) = Scope (Defining_Identifier (Decl))) 1806 then 1807 Error_Msg_N 1808 ("task will be activated before elaboration of its body?", 1809 Decl); 1810 Error_Msg_N 1811 ("Program_Error will be raised at run-time?", Decl); 1812 1813 elsif 1814 Present (Corresponding_Body (Unit_Declaration_Node (Proc))) 1815 then 1816 Append_Elmt (Proc, Intra_Procs); 1817 end if; 1818 1819 else 1820 Elmt := First_Elmt (Inter_Procs); 1821 1822 -- No need for multiple entries of the same type. 1823 1824 while Present (Elmt) loop 1825 if Node (Elmt) = Proc then 1826 return; 1827 end if; 1828 1829 Next_Elmt (Elmt); 1830 end loop; 1831 1832 Append_Elmt (Proc, Inter_Procs); 1833 end if; 1834 end if; 1835 end Add_Task_Proc; 1836 1837 ------------------- 1838 -- Collect_Tasks -- 1839 ------------------- 1840 1841 procedure Collect_Tasks (Decls : List_Id) is 1842 begin 1843 if Present (Decls) then 1844 Decl := First (Decls); 1845 1846 while Present (Decl) loop 1847 1848 if Nkind (Decl) = N_Object_Declaration 1849 and then Has_Task (Etype (Defining_Identifier (Decl))) 1850 then 1851 Add_Task_Proc (Etype (Defining_Identifier (Decl))); 1852 end if; 1853 1854 Next (Decl); 1855 end loop; 1856 end if; 1857 end Collect_Tasks; 1858 1859 ---------------- 1860 -- Outer_Unit -- 1861 ---------------- 1862 1863 function Outer_Unit (E : Entity_Id) return Entity_Id is 1864 Outer : Entity_Id := E; 1865 1866 begin 1867 while Present (Outer) loop 1868 if Elaboration_Checks_Suppressed (Outer) then 1869 Cunit_SC := True; 1870 end if; 1871 1872 exit when Is_Child_Unit (Outer) 1873 or else Scope (Outer) = Standard_Standard 1874 or else Ekind (Outer) /= E_Package; 1875 Outer := Scope (Outer); 1876 end loop; 1877 1878 return Outer; 1879 end Outer_Unit; 1880 1881 -- Start of processing for Check_Task_Activation 1882 1883 begin 1884 Enclosing := Outer_Unit (Current_Scope); 1885 1886 -- Find all tasks declared in the current unit. 1887 1888 if Nkind (N) = N_Package_Body then 1889 P := Unit_Declaration_Node (Corresponding_Spec (N)); 1890 1891 Collect_Tasks (Declarations (N)); 1892 Collect_Tasks (Visible_Declarations (Specification (P))); 1893 Collect_Tasks (Private_Declarations (Specification (P))); 1894 1895 elsif Nkind (N) = N_Package_Declaration then 1896 Collect_Tasks (Visible_Declarations (Specification (N))); 1897 Collect_Tasks (Private_Declarations (Specification (N))); 1898 1899 else 1900 Collect_Tasks (Declarations (N)); 1901 end if; 1902 1903 -- We only perform detailed checks in all tasks are library level 1904 -- entities. If the master is a subprogram or task, activation will 1905 -- depend on the activation of the master itself. 1906 -- Should dynamic checks be added in the more general case??? 1907 1908 if Ekind (Enclosing) /= E_Package then 1909 return; 1910 end if; 1911 1912 -- For task types defined in other units, we want the unit containing 1913 -- the task body to be elaborated before the current one. 1914 1915 Elmt := First_Elmt (Inter_Procs); 1916 1917 while Present (Elmt) loop 1918 Ent := Node (Elmt); 1919 Task_Scope := Outer_Unit (Scope (Ent)); 1920 1921 if not Is_Compilation_Unit (Task_Scope) then 1922 null; 1923 1924 elsif Suppress_Elaboration_Warnings (Task_Scope) 1925 or else Elaboration_Checks_Suppressed (Task_Scope) 1926 then 1927 null; 1928 1929 elsif Dynamic_Elaboration_Checks then 1930 if not Elaboration_Checks_Suppressed (Ent) 1931 and then not Cunit_SC 1932 and then not Restrictions (No_Entry_Calls_In_Elaboration_Code) 1933 then 1934 -- Runtime elaboration check required. generate check of the 1935 -- elaboration Boolean for the unit containing the entity. 1936 1937 Insert_Elab_Check (N, 1938 Make_Attribute_Reference (Loc, 1939 Attribute_Name => Name_Elaborated, 1940 Prefix => 1941 New_Occurrence_Of 1942 (Spec_Entity (Task_Scope), Loc))); 1943 end if; 1944 1945 else 1946 -- Force the binder to elaborate other unit first 1947 1948 if not Suppress_Elaboration_Warnings (Ent) 1949 and then not Elaboration_Checks_Suppressed (Ent) 1950 and then Elab_Warnings 1951 and then not Suppress_Elaboration_Warnings (Task_Scope) 1952 and then not Elaboration_Checks_Suppressed (Task_Scope) 1953 then 1954 Error_Msg_Node_2 := Task_Scope; 1955 Error_Msg_NE ("activation of an instance of task type&" & 1956 " requires pragma Elaborate_All on &?", N, Ent); 1957 end if; 1958 1959 Set_Elaborate_All_Desirable (Task_Scope); 1960 Set_Suppress_Elaboration_Warnings (Task_Scope); 1961 end if; 1962 1963 Next_Elmt (Elmt); 1964 end loop; 1965 1966 -- For tasks declared in the current unit, trace other calls within 1967 -- the task procedure bodies, which are available. 1968 1969 In_Task_Activation := True; 1970 Elmt := First_Elmt (Intra_Procs); 1971 1972 while Present (Elmt) loop 1973 Ent := Node (Elmt); 1974 Check_Internal_Call_Continue (N, Ent, Enclosing, Ent); 1975 Next_Elmt (Elmt); 1976 end loop; 1977 1978 In_Task_Activation := False; 1979 end Check_Task_Activation; 1980 1981 ---------------------- 1982 -- Has_Generic_Body -- 1983 ---------------------- 1984 1985 function Has_Generic_Body (N : Node_Id) return Boolean is 1986 Ent : constant Entity_Id := Get_Generic_Entity (N); 1987 Decl : constant Node_Id := Unit_Declaration_Node (Ent); 1988 Scop : Entity_Id; 1989 1990 function Find_Body_In (E : Entity_Id; N : Node_Id) return Node_Id; 1991 -- Determine if the list of nodes headed by N and linked by Next 1992 -- contains a package body for the package spec entity E, and if 1993 -- so return the package body. If not, then returns Empty. 1994 1995 function Load_Package_Body (Nam : Unit_Name_Type) return Node_Id; 1996 -- This procedure is called load the unit whose name is given by Nam. 1997 -- This unit is being loaded to see whether it contains an optional 1998 -- generic body. The returned value is the loaded unit, which is 1999 -- always a package body (only package bodies can contain other 2000 -- entities in the sense in which Has_Generic_Body is interested). 2001 -- We only attempt to load bodies if we are generating code. If we 2002 -- are in semantics check only mode, then it would be wrong to load 2003 -- bodies that are not required from a semantic point of view, so 2004 -- in this case we return Empty. The result is that the caller may 2005 -- incorrectly decide that a generic spec does not have a body when 2006 -- in fact it does, but the only harm in this is that some warnings 2007 -- on elaboration problems may be lost in semantic checks only mode, 2008 -- which is not big loss. We also return Empty if we go for a body 2009 -- and it is not there. 2010 2011 function Locate_Corresponding_Body (PE : Entity_Id) return Node_Id; 2012 -- PE is the entity for a package spec. This function locates the 2013 -- corresponding package body, returning Empty if none is found. 2014 -- The package body returned is fully parsed but may not yet be 2015 -- analyzed, so only syntactic fields should be referenced. 2016 2017 ------------------ 2018 -- Find_Body_In -- 2019 ------------------ 2020 2021 function Find_Body_In (E : Entity_Id; N : Node_Id) return Node_Id is 2022 Nod : Node_Id; 2023 2024 begin 2025 Nod := N; 2026 while Present (Nod) loop 2027 2028 -- If we found the package body we are looking for, return it 2029 2030 if Nkind (Nod) = N_Package_Body 2031 and then Chars (Defining_Unit_Name (Nod)) = Chars (E) 2032 then 2033 return Nod; 2034 2035 -- If we found the stub for the body, go after the subunit, 2036 -- loading it if necessary. 2037 2038 elsif Nkind (Nod) = N_Package_Body_Stub 2039 and then Chars (Defining_Identifier (Nod)) = Chars (E) 2040 then 2041 if Present (Library_Unit (Nod)) then 2042 return Unit (Library_Unit (Nod)); 2043 2044 else 2045 return Load_Package_Body (Get_Unit_Name (Nod)); 2046 end if; 2047 2048 -- If neither package body nor stub, keep looking on chain 2049 2050 else 2051 Next (Nod); 2052 end if; 2053 end loop; 2054 2055 return Empty; 2056 end Find_Body_In; 2057 2058 ----------------------- 2059 -- Load_Package_Body -- 2060 ----------------------- 2061 2062 function Load_Package_Body (Nam : Unit_Name_Type) return Node_Id is 2063 U : Unit_Number_Type; 2064 2065 begin 2066 if Operating_Mode /= Generate_Code then 2067 return Empty; 2068 else 2069 U := 2070 Load_Unit 2071 (Load_Name => Nam, 2072 Required => False, 2073 Subunit => False, 2074 Error_Node => N); 2075 2076 if U = No_Unit then 2077 return Empty; 2078 else 2079 return Unit (Cunit (U)); 2080 end if; 2081 end if; 2082 end Load_Package_Body; 2083 2084 ------------------------------- 2085 -- Locate_Corresponding_Body -- 2086 ------------------------------- 2087 2088 function Locate_Corresponding_Body (PE : Entity_Id) return Node_Id is 2089 Spec : constant Node_Id := Declaration_Node (PE); 2090 Decl : constant Node_Id := Parent (Spec); 2091 Scop : constant Entity_Id := Scope (PE); 2092 PBody : Node_Id; 2093 2094 begin 2095 if Is_Library_Level_Entity (PE) then 2096 2097 -- If package is a library unit that requires a body, we have 2098 -- no choice but to go after that body because it might contain 2099 -- an optional body for the original generic package. 2100 2101 if Unit_Requires_Body (PE) then 2102 2103 -- Load the body. Note that we are a little careful here to 2104 -- use Spec to get the unit number, rather than PE or Decl, 2105 -- since in the case where the package is itself a library 2106 -- level instantiation, Spec will properly reference the 2107 -- generic template, which is what we really want. 2108 2109 return 2110 Load_Package_Body 2111 (Get_Body_Name (Unit_Name (Get_Source_Unit (Spec)))); 2112 2113 -- But if the package is a library unit that does NOT require 2114 -- a body, then no body is permitted, so we are sure that there 2115 -- is no body for the original generic package. 2116 2117 else 2118 return Empty; 2119 end if; 2120 2121 -- Otherwise look and see if we are embedded in a further package 2122 2123 elsif Is_Package (Scop) then 2124 2125 -- If so, get the body of the enclosing package, and look in 2126 -- its package body for the package body we are looking for. 2127 2128 PBody := Locate_Corresponding_Body (Scop); 2129 2130 if No (PBody) then 2131 return Empty; 2132 else 2133 return Find_Body_In (PE, First (Declarations (PBody))); 2134 end if; 2135 2136 -- If we are not embedded in a further package, then the body 2137 -- must be in the same declarative part as we are. 2138 2139 else 2140 return Find_Body_In (PE, Next (Decl)); 2141 end if; 2142 end Locate_Corresponding_Body; 2143 2144 -- Start of processing for Has_Generic_Body 2145 2146 begin 2147 if Present (Corresponding_Body (Decl)) then 2148 return True; 2149 2150 elsif Unit_Requires_Body (Ent) then 2151 return True; 2152 2153 -- Compilation units cannot have optional bodies 2154 2155 elsif Is_Compilation_Unit (Ent) then 2156 return False; 2157 2158 -- Otherwise look at what scope we are in 2159 2160 else 2161 Scop := Scope (Ent); 2162 2163 -- Case of entity is in other than a package spec, in this case 2164 -- the body, if present, must be in the same declarative part. 2165 2166 if not Is_Package (Scop) then 2167 declare 2168 P : Node_Id; 2169 2170 begin 2171 P := Declaration_Node (Ent); 2172 2173 -- Declaration node may get us a spec, so if so, go to 2174 -- the parent declaration. 2175 2176 while not Is_List_Member (P) loop 2177 P := Parent (P); 2178 end loop; 2179 2180 return Present (Find_Body_In (Ent, Next (P))); 2181 end; 2182 2183 -- If the entity is in a package spec, then we have to locate 2184 -- the corresponding package body, and look there. 2185 2186 else 2187 declare 2188 PBody : constant Node_Id := Locate_Corresponding_Body (Scop); 2189 2190 begin 2191 if No (PBody) then 2192 return False; 2193 else 2194 return 2195 Present 2196 (Find_Body_In (Ent, (First (Declarations (PBody))))); 2197 end if; 2198 end; 2199 end if; 2200 end if; 2201 end Has_Generic_Body; 2202 2203 ----------------------- 2204 -- Insert_Elab_Check -- 2205 ----------------------- 2206 2207 procedure Insert_Elab_Check (N : Node_Id; C : Node_Id := Empty) is 2208 Nod : Node_Id; 2209 Loc : constant Source_Ptr := Sloc (N); 2210 2211 begin 2212 -- If expansion is disabled, do not generate any checks. Also 2213 -- skip checks if any subunits are missing because in either 2214 -- case we lack the full information that we need, and no object 2215 -- file will be created in any case. 2216 2217 if not Expander_Active or else Subunits_Missing then 2218 return; 2219 end if; 2220 2221 -- If we have a generic instantiation, where Instance_Spec is set, 2222 -- then this field points to a generic instance spec that has 2223 -- been inserted before the instantiation node itself, so that 2224 -- is where we want to insert a check. 2225 2226 if Nkind (N) in N_Generic_Instantiation 2227 and then Present (Instance_Spec (N)) 2228 then 2229 Nod := Instance_Spec (N); 2230 else 2231 Nod := N; 2232 end if; 2233 2234 -- If we are inserting at the top level, insert in Aux_Decls 2235 2236 if Nkind (Parent (Nod)) = N_Compilation_Unit then 2237 declare 2238 ADN : constant Node_Id := Aux_Decls_Node (Parent (Nod)); 2239 R : Node_Id; 2240 2241 begin 2242 if No (C) then 2243 R := 2244 Make_Raise_Program_Error (Loc, 2245 Reason => PE_Access_Before_Elaboration); 2246 else 2247 R := 2248 Make_Raise_Program_Error (Loc, 2249 Condition => Make_Op_Not (Loc, C), 2250 Reason => PE_Access_Before_Elaboration); 2251 end if; 2252 2253 if No (Declarations (ADN)) then 2254 Set_Declarations (ADN, New_List (R)); 2255 else 2256 Append_To (Declarations (ADN), R); 2257 end if; 2258 2259 Analyze (R); 2260 end; 2261 2262 -- Otherwise just insert before the node in question. However, if 2263 -- the context of the call has already been analyzed, an insertion 2264 -- will not work if it depends on subsequent expansion (e.g. a call in 2265 -- a branch of a short-circuit). In that case we replace the call with 2266 -- a conditional expression, or with a Raise if it is unconditional. 2267 -- Unfortunately this does not work if the call has a dynamic size, 2268 -- because gigi regards it as a dynamic-sized temporary. If such a call 2269 -- appears in a short-circuit expression, the elaboration check will be 2270 -- missed (rare enough ???). Otherwise, the code below inserts the check 2271 -- at the appropriate place before the call. Same applies in the even 2272 -- rarer case the return type has a known size but is unconstrained. 2273 2274 else 2275 if Nkind (N) = N_Function_Call 2276 and then Analyzed (Parent (N)) 2277 and then Size_Known_At_Compile_Time (Etype (N)) 2278 and then 2279 (not Has_Discriminants (Etype (N)) 2280 or else Is_Constrained (Etype (N))) 2281 2282 then 2283 declare 2284 Typ : constant Entity_Id := Etype (N); 2285 Chk : constant Boolean := Do_Range_Check (N); 2286 2287 R : constant Node_Id := 2288 Make_Raise_Program_Error (Loc, 2289 Reason => PE_Access_Before_Elaboration); 2290 2291 begin 2292 Set_Etype (R, Typ); 2293 2294 if No (C) then 2295 Rewrite (N, R); 2296 2297 else 2298 Rewrite (N, 2299 Make_Conditional_Expression (Loc, 2300 Expressions => New_List (C, Relocate_Node (N), R))); 2301 end if; 2302 2303 Analyze_And_Resolve (N, Typ); 2304 2305 -- If the original call requires a range check, so does the 2306 -- conditional expression. 2307 2308 if Chk then 2309 Enable_Range_Check (N); 2310 else 2311 Set_Do_Range_Check (N, False); 2312 end if; 2313 end; 2314 2315 else 2316 if No (C) then 2317 Insert_Action (Nod, 2318 Make_Raise_Program_Error (Loc, 2319 Reason => PE_Access_Before_Elaboration)); 2320 else 2321 Insert_Action (Nod, 2322 Make_Raise_Program_Error (Loc, 2323 Condition => 2324 Make_Op_Not (Loc, 2325 Right_Opnd => C), 2326 Reason => PE_Access_Before_Elaboration)); 2327 end if; 2328 end if; 2329 end if; 2330 end Insert_Elab_Check; 2331 2332 ------------------ 2333 -- Output_Calls -- 2334 ------------------ 2335 2336 procedure Output_Calls (N : Node_Id) is 2337 Ent : Entity_Id; 2338 2339 function Is_Printable_Error_Name (Nm : Name_Id) return Boolean; 2340 -- An internal function, used to determine if a name, Nm, is either 2341 -- a non-internal name, or is an internal name that is printable 2342 -- by the error message circuits (i.e. it has a single upper 2343 -- case letter at the end). 2344 2345 function Is_Printable_Error_Name (Nm : Name_Id) return Boolean is 2346 begin 2347 if not Is_Internal_Name (Nm) then 2348 return True; 2349 2350 elsif Name_Len = 1 then 2351 return False; 2352 2353 else 2354 Name_Len := Name_Len - 1; 2355 return not Is_Internal_Name; 2356 end if; 2357 end Is_Printable_Error_Name; 2358 2359 -- Start of processing for Output_Calls 2360 2361 begin 2362 for J in reverse 1 .. Elab_Call.Last loop 2363 Error_Msg_Sloc := Elab_Call.Table (J).Cloc; 2364 2365 Ent := Elab_Call.Table (J).Ent; 2366 2367 if Is_Generic_Unit (Ent) then 2368 Error_Msg_NE ("\?& instantiated #", N, Ent); 2369 2370 elsif Is_Init_Proc (Ent) then 2371 Error_Msg_N ("\?initialization procedure called #", N); 2372 2373 elsif Is_Printable_Error_Name (Chars (Ent)) then 2374 Error_Msg_NE ("\?& called #", N, Ent); 2375 2376 else 2377 Error_Msg_N ("\? called #", N); 2378 end if; 2379 end loop; 2380 end Output_Calls; 2381 2382 ---------------------------- 2383 -- Same_Elaboration_Scope -- 2384 ---------------------------- 2385 2386 function Same_Elaboration_Scope (Scop1, Scop2 : Entity_Id) return Boolean is 2387 S1 : Entity_Id := Scop1; 2388 S2 : Entity_Id := Scop2; 2389 2390 begin 2391 while S1 /= Standard_Standard 2392 and then (Ekind (S1) = E_Package 2393 or else 2394 Ekind (S1) = E_Block) 2395 loop 2396 S1 := Scope (S1); 2397 end loop; 2398 2399 while S2 /= Standard_Standard 2400 and then (Ekind (S2) = E_Package 2401 or else 2402 Ekind (S2) = E_Protected_Type 2403 or else 2404 Ekind (S2) = E_Block) 2405 loop 2406 S2 := Scope (S2); 2407 end loop; 2408 2409 return S1 = S2; 2410 end Same_Elaboration_Scope; 2411 2412 ----------------- 2413 -- Set_C_Scope -- 2414 ----------------- 2415 2416 procedure Set_C_Scope is 2417 begin 2418 while not Is_Compilation_Unit (C_Scope) loop 2419 C_Scope := Scope (C_Scope); 2420 end loop; 2421 end Set_C_Scope; 2422 2423 ----------------- 2424 -- Spec_Entity -- 2425 ----------------- 2426 2427 function Spec_Entity (E : Entity_Id) return Entity_Id is 2428 Decl : Node_Id; 2429 2430 begin 2431 -- Check for case of body entity 2432 -- Why is the check for E_Void needed??? 2433 2434 if Ekind (E) = E_Void 2435 or else Ekind (E) = E_Subprogram_Body 2436 or else Ekind (E) = E_Package_Body 2437 then 2438 Decl := E; 2439 2440 loop 2441 Decl := Parent (Decl); 2442 exit when Nkind (Decl) in N_Proper_Body; 2443 end loop; 2444 2445 return Corresponding_Spec (Decl); 2446 2447 else 2448 return E; 2449 end if; 2450 end Spec_Entity; 2451 2452 ------------------- 2453 -- Supply_Bodies -- 2454 ------------------- 2455 2456 procedure Supply_Bodies (N : Node_Id) is 2457 begin 2458 if Nkind (N) = N_Subprogram_Declaration then 2459 declare 2460 Ent : constant Entity_Id := Defining_Unit_Name (Specification (N)); 2461 2462 begin 2463 Set_Is_Imported (Ent); 2464 Set_Convention (Ent, Convention_Stubbed); 2465 end; 2466 2467 elsif Nkind (N) = N_Package_Declaration then 2468 declare 2469 Spec : constant Node_Id := Specification (N); 2470 2471 begin 2472 New_Scope (Defining_Unit_Name (Spec)); 2473 Supply_Bodies (Visible_Declarations (Spec)); 2474 Supply_Bodies (Private_Declarations (Spec)); 2475 Pop_Scope; 2476 end; 2477 end if; 2478 end Supply_Bodies; 2479 2480 procedure Supply_Bodies (L : List_Id) is 2481 Elmt : Node_Id; 2482 2483 begin 2484 if Present (L) then 2485 Elmt := First (L); 2486 while Present (Elmt) loop 2487 Supply_Bodies (Elmt); 2488 Next (Elmt); 2489 end loop; 2490 end if; 2491 end Supply_Bodies; 2492 2493 ------------ 2494 -- Within -- 2495 ------------ 2496 2497 function Within (E1, E2 : Entity_Id) return Boolean is 2498 Scop : Entity_Id; 2499 2500 begin 2501 Scop := E1; 2502 2503 loop 2504 if Scop = E2 then 2505 return True; 2506 2507 elsif Scop = Standard_Standard then 2508 return False; 2509 2510 else 2511 Scop := Scope (Scop); 2512 end if; 2513 end loop; 2514 2515 raise Program_Error; 2516 end Within; 2517 2518 -------------------------- 2519 -- Within_Elaborate_All -- 2520 -------------------------- 2521 2522 function Within_Elaborate_All (E : Entity_Id) return Boolean is 2523 Item : Node_Id; 2524 Item2 : Node_Id; 2525 Elab_Id : Entity_Id; 2526 Par : Node_Id; 2527 2528 begin 2529 Item := First (Context_Items (Cunit (Current_Sem_Unit))); 2530 2531 while Present (Item) loop 2532 if Nkind (Item) = N_Pragma 2533 and then Get_Pragma_Id (Chars (Item)) = Pragma_Elaborate_All 2534 then 2535 if Error_Posted (Item) then 2536 2537 -- Some previous error on the pragma itself 2538 2539 return False; 2540 end if; 2541 2542 Elab_Id := 2543 Entity ( 2544 Expression (First (Pragma_Argument_Associations (Item)))); 2545 2546 Par := Parent (Unit_Declaration_Node (Elab_Id)); 2547 Item2 := First (Context_Items (Par)); 2548 2549 while Present (Item2) loop 2550 if Nkind (Item2) = N_With_Clause 2551 and then Entity (Name (Item2)) = E 2552 then 2553 return True; 2554 end if; 2555 2556 Next (Item2); 2557 end loop; 2558 end if; 2559 2560 Next (Item); 2561 end loop; 2562 2563 return False; 2564 end Within_Elaborate_All; 2565 2566end Sem_Elab; 2567