gcc/ada/sem_elab.adb

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