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, or else we know that the
 430       --  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 an initialization procedure outside the current package, where
 642          --  the init proc is in the root package, and we start from the entity
 643          --  of the name in the call.
 644
 645          if Is_Entity_Name (Name (N))
 646            and then Is_Init_Proc (Entity (Name (N)))
 647            and then not In_Same_Extended_Unit (N, Entity (Name (N)))
 648          then
 649             W_Scope := Scope (Entity (Name (N)));
 650          else
 651             W_Scope := E;
 652          end if;
 653
 654          while not Is_Compilation_Unit (W_Scope) loop
 655             W_Scope := Scope (W_Scope);
 656          end loop;
 657
 658          --  Now check if an elaborate_all (or dynamic check) is needed
 659
 660          if not Suppress_Elaboration_Warnings (Ent)
 661            and then not Elaboration_Checks_Suppressed (Ent)
 662            and then not Suppress_Elaboration_Warnings (E_Scope)
 663            and then not Elaboration_Checks_Suppressed (E_Scope)
 664            and then Elab_Warnings
 665            and then Generate_Warnings
 666          then
 667             if Inst_Case then
 668                Error_Msg_NE
 669                  ("instantiation of& may raise Program_Error?", N, Ent);
 670
 671             else
 672                if Is_Init_Proc (Entity (Name (N)))
 673                  and then Comes_From_Source (Ent)
 674                then
 675                   Error_Msg_NE
 676                     ("implicit call to & may raise Program_Error?", N, Ent);
 677
 678                else
 679                   Error_Msg_NE
 680                     ("call to & may raise Program_Error?", N, Ent);
 681                end if;
 682             end if;
 683
 684             Error_Msg_Qual_Level := Nat'Last;
 685             Error_Msg_NE
 686               ("\missing pragma Elaborate_All for&?", N, W_Scope);
 687             Error_Msg_Qual_Level := 0;
 688             Output_Calls (N);
 689
 690             --  Set flag to prevent further warnings for same unit
 691             --  unless in All_Errors_Mode.
 692
 693             if not All_Errors_Mode and not Dynamic_Elaboration_Checks then
 694                Set_Suppress_Elaboration_Warnings (W_Scope, True);
 695             end if;
 696          end if;
 697
 698          --  Check for runtime elaboration check required
 699
 700          if Dynamic_Elaboration_Checks then
 701             if not Elaboration_Checks_Suppressed (Ent)
 702               and then not Elaboration_Checks_Suppressed (W_Scope)
 703               and then not Elaboration_Checks_Suppressed (E_Scope)
 704               and then not Cunit_SC
 705             then
 706                --  Runtime elaboration check required. Generate check of the
 707                --  elaboration Boolean for the unit containing the entity.
 708
 709                --  Note that for this case, we do check the real unit (the
 710                --  one from following renamings, since that is the issue!)
 711
 712                --  Could this possibly miss a useless but required PE???
 713
 714                Insert_Elab_Check (N,
 715                  Make_Attribute_Reference (Loc,
 716                    Attribute_Name => Name_Elaborated,
 717                    Prefix =>
 718                      New_Occurrence_Of
 719                        (Spec_Entity (E_Scope), Loc)));
 720             end if;
 721
 722          --  Case of static elaboration model
 723
 724          else
 725             --  Do not do anything if elaboration checks suppressed. Note
 726             --  that we check Ent here, not E, since we want the real entity
 727             --  for the body to see if checks are suppressed for it, not the
 728             --  dummy entry for renamings or derivations.
 729
 730             if Elaboration_Checks_Suppressed (Ent)
 731               or else Elaboration_Checks_Suppressed (E_Scope)
 732               or else Elaboration_Checks_Suppressed (W_Scope)
 733             then
 734                null;
 735
 736             --  Here we need to generate an implicit elaborate all
 737
 738             else
 739                --  Generate elaborate_all warning unless suppressed
 740
 741                if (Elab_Warnings and Generate_Warnings and not Inst_Case)
 742                  and then not Suppress_Elaboration_Warnings (Ent)
 743                  and then not Suppress_Elaboration_Warnings (E_Scope)
 744                  and then not Suppress_Elaboration_Warnings (W_Scope)
 745                then
 746                   Error_Msg_Node_2 := W_Scope;
 747                   Error_Msg_NE
 748                     ("call to& in elaboration code " &
 749                      "requires pragma Elaborate_All on&?", N, E);
 750                end if;
 751
 752                --  Set indication for binder to generate Elaborate_All
 753
 754                Set_Elaborate_All_Desirable (W_Scope);
 755                Set_Suppress_Elaboration_Warnings (W_Scope, True);
 756             end if;
 757          end if;
 758
 759       --  Case of entity is in same unit as call or instantiation
 760
 761       elsif not Inter_Unit_Only then
 762          Check_Internal_Call (N, Ent, Outer_Scope, E);
 763       end if;
 764    end Check_A_Call;
 765
 766    -----------------------------
 767    -- Check_Bad_Instantiation --
 768    -----------------------------
 769
 770    procedure Check_Bad_Instantiation (N : Node_Id) is
 771       Ent : Entity_Id;
 772
 773    begin
 774       --  Nothing to do if we do not have an instantiation (happens in some
 775       --  error cases, and also in the formal package declaration case)
 776
 777       if Nkind (N) not in N_Generic_Instantiation then
 778          return;
 779
 780       --  Nothing to do if serious errors detected (avoid cascaded errors)
 781
 782       elsif Serious_Errors_Detected /= 0 then
 783          return;
 784
 785       --  Nothing to do if not in full analysis mode
 786
 787       elsif not Full_Analysis then
 788          return;
 789
 790       --  Nothing to do if inside a generic template
 791
 792       elsif Inside_A_Generic then
 793          return;
 794
 795       --  Nothing to do if a library level instantiation
 796
 797       elsif Nkind (Parent (N)) = N_Compilation_Unit then
 798          return;
 799
 800       --  Nothing to do if we are compiling a proper body for semantic
 801       --  purposes only. The generic body may be in another proper body.
 802
 803       elsif
 804         Nkind (Parent (Unit_Declaration_Node (Main_Unit_Entity))) = N_Subunit
 805       then
 806          return;
 807       end if;
 808
 809       Ent := Get_Generic_Entity (N);
 810
 811       --  The case we are interested in is when the generic spec is in the
 812       --  current declarative part
 813
 814       if not Same_Elaboration_Scope (Current_Scope, Scope (Ent))
 815         or else not In_Same_Extended_Unit (N, Ent)
 816       then
 817          return;
 818       end if;
 819
 820       --  If the generic entity is within a deeper instance than we are, then
 821       --  either the instantiation to which we refer itself caused an ABE, in
 822       --  which case that will be handled separately. Otherwise, we know that
 823       --  the body we need appears as needed at the point of the instantiation.
 824       --  If they are both at the same level but not within the same instance
 825       --  then the body of the generic will be in the earlier instance.
 826
 827       declare
 828          D1 : constant Int := Instantiation_Depth (Sloc (Ent));
 829          D2 : constant Int := Instantiation_Depth (Sloc (N));
 830
 831       begin
 832          if D1 > D2 then
 833             return;
 834
 835          elsif D1 = D2
 836            and then Is_Generic_Instance (Scope (Ent))
 837            and then not In_Open_Scopes (Scope (Ent))
 838          then
 839             return;
 840          end if;
 841       end;
 842
 843       --  Now we can proceed, if the entity being called has a completion,
 844       --  then we are definitely OK, since we have already seen the body.
 845
 846       if Has_Completion (Ent) then
 847          return;
 848       end if;
 849
 850       --  If there is no body, then nothing to do
 851
 852       if not Has_Generic_Body (N) then
 853          return;
 854       end if;
 855
 856       --  Here we definitely have a bad instantiation
 857
 858       Error_Msg_NE
 859         ("?cannot instantiate& before body seen", N, Ent);
 860
 861       if Present (Instance_Spec (N)) then
 862          Supply_Bodies (Instance_Spec (N));
 863       end if;
 864
 865       Error_Msg_N
 866         ("\?Program_Error will be raised at run time", N);
 867       Insert_Elab_Check (N);
 868       Set_ABE_Is_Certain (N);
 869
 870    end Check_Bad_Instantiation;
 871
 872    ---------------------
 873    -- Check_Elab_Call --
 874    ---------------------
 875
 876    procedure Check_Elab_Call
 877      (N           : Node_Id;
 878       Outer_Scope : Entity_Id := Empty)
 879    is
 880       Ent : Entity_Id;
 881       P   : Node_Id;
 882
 883       function Get_Called_Ent return Entity_Id;
 884       --  Retrieve called entity. If this is a call to a protected subprogram,
 885       --  entity is a selected component. The callable entity may be absent,
 886       --  in which case there is no check to perform.  This happens with
 887       --  non-analyzed calls in nested generics.
 888
 889       --------------------
 890       -- Get_Called_Ent --
 891       --------------------
 892
 893       function Get_Called_Ent return Entity_Id is
 894          Nam : Node_Id;
 895
 896       begin
 897          Nam := Name (N);
 898
 899          if No (Nam) then
 900             return Empty;
 901
 902          elsif Nkind (Nam) = N_Selected_Component then
 903             return Entity (Selector_Name (Nam));
 904
 905          elsif not Is_Entity_Name (Nam) then
 906             return Empty;
 907
 908          else
 909             return Entity (Nam);
 910          end if;
 911       end Get_Called_Ent;
 912
 913    --  Start of processing for Check_Elab_Call
 914
 915    begin
 916       --  If the call does not come from the main unit, there is nothing to
 917       --  check. Elaboration call from units in the context of the main unit
 918       --  will lead to semantic dependencies when those units are compiled.
 919
 920       if not In_Extended_Main_Code_Unit (N) then
 921          return;
 922       end if;
 923
 924       --  For an entry call, check relevant restriction
 925
 926       if Nkind (N) = N_Entry_Call_Statement
 927          and then not In_Subprogram_Or_Concurrent_Unit
 928       then
 929          Check_Restriction (No_Entry_Calls_In_Elaboration_Code, N);
 930
 931       --  Nothing to do if this is not a call (happens in some error
 932       --  conditions, and in some cases where rewriting occurs).
 933
 934       elsif Nkind (N) /= N_Function_Call
 935         and then Nkind (N) /= N_Procedure_Call_Statement
 936       then
 937          return;
 938
 939       --  Nothing to do if this is a call already rewritten for elab checking.
 940
 941       elsif Nkind (Parent (N)) = N_Conditional_Expression then
 942          return;
 943
 944       --  Nothing to do if inside a generic template
 945
 946       elsif Inside_A_Generic
 947         and then not Present (Enclosing_Generic_Body (N))
 948       then
 949          return;
 950       end if;
 951
 952       --  Here we have a call at elaboration time which must be checked
 953
 954       if Debug_Flag_LL then
 955          Write_Str ("  Check_Elab_Call: ");
 956
 957          if No (Name (N))
 958            or else not Is_Entity_Name (Name (N))
 959          then
 960             Write_Str ("<<not entity name>> ");
 961          else
 962             Write_Name (Chars (Entity (Name (N))));
 963          end if;
 964
 965          Write_Str ("  call at ");
 966          Write_Location (Sloc (N));
 967          Write_Eol;
 968       end if;
 969
 970       --  Climb up the tree to make sure we are not inside a
 971       --  default expression of a parameter specification or
 972       --  a record component, since in both these cases, we
 973       --  will be doing the actual call later, not now, and it
 974       --  is at the time of the actual call (statically speaking)
 975       --  that we must do our static check, not at the time of
 976       --  its initial analysis). However, we have to check calls
 977       --  within component definitions (e.g., a function call
 978       --  that determines an array component bound), so we
 979       --  terminate the loop in that case.
 980
 981       P := Parent (N);
 982       while Present (P) loop
 983          if Nkind (P) = N_Parameter_Specification
 984               or else
 985             Nkind (P) = N_Component_Declaration
 986          then
 987             return;
 988
 989          --  The call occurs within the constraint of a component,
 990          --  so it must be checked.
 991
 992          elsif Nkind (P) = N_Component_Definition then
 993             exit;
 994
 995          else
 996             P := Parent (P);
 997          end if;
 998       end loop;
 999
1000       --  Stuff that happens only at the outer level
1001
1002       if No (Outer_Scope) then
1003          Elab_Visited.Set_Last (0);
1004
1005          --  Nothing to do if current scope is Standard (this is a bit
1006          --  odd, but it happens in the case of generic instantiations).
1007
1008          C_Scope := Current_Scope;
1009
1010          if C_Scope = Standard_Standard then
1011             return;
1012          end if;
1013
1014          --  First case, we are in elaboration code
1015
1016          From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit;
1017          if From_Elab_Code then
1018
1019             --  Complain if call that comes from source in preelaborated
1020             --  unit and we are not inside a subprogram (i.e. we are in
1021             --  elab code)
1022
1023             if Comes_From_Source (N)
1024               and then In_Preelaborated_Unit
1025               and then not In_Inlined_Body
1026             then
1027                Error_Msg_N
1028                  ("non-static call not allowed in preelaborated unit", N);
1029                return;
1030             end if;
1031
1032          --  Second case, we are inside a subprogram or concurrent unit
1033          --  i.e, we are not in elaboration code.
1034
1035          else
1036             --  In this case, the issue is whether we are inside the
1037             --  declarative part of the unit in which we live, or inside
1038             --  its statements. In the latter case, there is no issue of
1039             --  ABE calls at this level (a call from outside to the unit
1040             --  in which we live might cause an ABE, but that will be
1041             --  detected when we analyze that outer level call, as it
1042             --  recurses into the called unit).
1043
1044             --  Climb up the tree, doing this test, and also testing
1045             --  for being inside a default expression, which, as
1046             --  discussed above, is not checked at this stage.
1047
1048             declare
1049                P : Node_Id;
1050                L : List_Id;
1051
1052             begin
1053                P := N;
1054                loop
1055                   --  If we find a parentless subtree, it seems safe to
1056                   --  assume that we are not in a declarative part and
1057                   --  that no checking is required.
1058
1059                   if No (P) then
1060                      return;
1061                   end if;
1062
1063                   if Is_List_Member (P) then
1064                      L := List_Containing (P);
1065                      P := Parent (L);
1066                   else
1067                      L := No_List;
1068                      P := Parent (P);
1069                   end if;
1070
1071                   exit when Nkind (P) = N_Subunit;
1072
1073                   --  Filter out case of default expressions, where
1074                   --  we do not do the check at this stage.
1075
1076                   if Nkind (P) = N_Parameter_Specification
1077                        or else
1078                      Nkind (P) = N_Component_Declaration
1079                   then
1080                      return;
1081                   end if;
1082
1083                   if Nkind (P) = N_Subprogram_Body
1084                        or else
1085                      Nkind (P) = N_Protected_Body
1086                        or else
1087                      Nkind (P) = N_Task_Body
1088                        or else
1089                      Nkind (P) = N_Block_Statement
1090                   then
1091                      if L = Declarations (P) then
1092                         exit;
1093
1094                      --  We are not in elaboration code, but we are doing
1095                      --  dynamic elaboration checks, in this case, we still
1096                      --  need to do the call, since the subprogram we are in
1097                      --  could be called from another unit, also in dynamic
1098                      --  elaboration check mode, at elaboration time.
1099
1100                      elsif Dynamic_Elaboration_Checks then
1101
1102                         --  This is a rather new check, going into version
1103                         --  3.14a1 for the first time (V1.80 of this unit),
1104                         --  so we provide a debug flag to enable it. That
1105                         --  way we have an easy work around for regressions
1106                         --  that are caused by this new check. This debug
1107                         --  flag can be removed later.
1108
1109                         if Debug_Flag_DD then
1110                            return;
1111                         end if;
1112
1113                         --  Do the check in this case
1114
1115                         exit;
1116
1117                      elsif Nkind (P) = N_Task_Body then
1118
1119                         --  The check is deferred until Check_Task_Activation
1120                         --  but we need to capture local suppress pragmas
1121                         --  that may inhibit checks on this call.
1122
1123                         Ent := Get_Called_Ent;
1124
1125                         if No (Ent) then
1126                            return;
1127
1128                         elsif Elaboration_Checks_Suppressed (Current_Scope)
1129                           or else Elaboration_Checks_Suppressed (Ent)
1130                           or else Elaboration_Checks_Suppressed (Scope (Ent))
1131                         then
1132                            Set_No_Elaboration_Check (N);
1133                         end if;
1134
1135                         return;
1136
1137                      --  Static model, call is not in elaboration code, we
1138                      --  never need to worry, because in the static model
1139                      --  the top level caller always takes care of things.
1140
1141                      else
1142                         return;
1143                      end if;
1144                   end if;
1145                end loop;
1146             end;
1147          end if;
1148       end if;
1149
1150       Ent := Get_Called_Ent;
1151
1152       if No (Ent) then
1153          return;
1154       end if;
1155
1156       --  Nothing to do if this is a recursive call (i.e. a call to
1157       --  an entity that is already in the Elab_Call stack)
1158
1159       for J in 1 .. Elab_Visited.Last loop
1160          if Ent = Elab_Visited.Table (J) then
1161             return;
1162          end if;
1163       end loop;
1164
1165       --  See if we need to analyze this call. We analyze it if either of
1166       --  the following conditions is met:
1167
1168       --    It is an inner level call (since in this case it was triggered
1169       --    by an outer level call from elaboration code), but only if the
1170       --    call is within the scope of the original outer level call.
1171
1172       --    It is an outer level call from elaboration code, or the called
1173       --    entity is in the same elaboration scope.
1174
1175       --  And in these cases, we will check both inter-unit calls and
1176       --  intra-unit (within a single unit) calls.
1177
1178       C_Scope := Current_Scope;
1179
1180       --  If not outer level call, then we follow it if it is within
1181       --  the original scope of the outer call.
1182
1183       if Present (Outer_Scope)
1184         and then Within (Scope (Ent), Outer_Scope)
1185       then
1186          Set_C_Scope;
1187          Check_A_Call (N, Ent, Outer_Scope, Inter_Unit_Only => False);
1188
1189       elsif Elaboration_Checks_Suppressed (Current_Scope) then
1190          null;
1191
1192       elsif From_Elab_Code then
1193          Set_C_Scope;
1194          Check_A_Call (N, Ent, Standard_Standard, Inter_Unit_Only => False);
1195
1196       elsif Same_Elaboration_Scope (C_Scope, Scope (Ent)) then
1197          Set_C_Scope;
1198          Check_A_Call (N, Ent, Scope (Ent), Inter_Unit_Only => False);
1199
1200       --  If none of those cases holds, but Dynamic_Elaboration_Checks mode
1201       --  is set, then we will do the check, but only in the inter-unit case
1202       --  (this is to accommodate unguarded elaboration calls from other units
1203       --  in which this same mode is set). We don't want warnings in this case,
1204       --  it would generate warnings having nothing to do with elaboration.
1205
1206       elsif Dynamic_Elaboration_Checks then
1207          Set_C_Scope;
1208          Check_A_Call
1209            (N,
1210             Ent,
1211             Standard_Standard,
1212             Inter_Unit_Only => True,
1213             Generate_Warnings => False);
1214
1215       --  Otherwise nothing to do
1216
1217       else
1218          return;
1219       end if;
1220
1221       --  A call to an Init_Proc in elaboration code may bring additional
1222       --  dependencies, if some of the record components thereof have
1223       --  initializations that are function calls that come from source.
1224       --  We treat the current node as a call to each of these functions,
1225       --  to check their elaboration impact.
1226
1227       if Is_Init_Proc (Ent)
1228         and then From_Elab_Code
1229       then
1230          Process_Init_Proc : declare
1231             Unit_Decl : constant Node_Id := Unit_Declaration_Node (Ent);
1232
1233             function Process (Nod : Node_Id) return Traverse_Result;
1234             --  Find subprogram calls within body of init_proc for
1235             --  Traverse instantiation below.
1236
1237             function Process (Nod : Node_Id) return Traverse_Result is
1238                Func : Entity_Id;
1239
1240             begin
1241                if (Nkind (Nod) = N_Function_Call
1242                     or else Nkind (Nod) = N_Procedure_Call_Statement)
1243                  and then Is_Entity_Name (Name (Nod))
1244                then
1245                   Func := Entity (Name (Nod));
1246
1247                   if Comes_From_Source (Func) then
1248                      Check_A_Call
1249                        (N, Func, Standard_Standard, Inter_Unit_Only => True);
1250                   end if;
1251
1252                   return OK;
1253
1254                else
1255                   return OK;
1256                end if;
1257             end Process;
1258
1259             procedure Traverse_Body is new Traverse_Proc (Process);
1260
1261          --  Start of processing for Process_Init_Proc
1262
1263          begin
1264             if Nkind (Unit_Decl) = N_Subprogram_Body then
1265                Traverse_Body (Handled_Statement_Sequence (Unit_Decl));
1266             end if;
1267          end Process_Init_Proc;
1268       end if;
1269    end Check_Elab_Call;
1270
1271    ----------------------
1272    -- Check_Elab_Calls --
1273    ----------------------
1274
1275    procedure Check_Elab_Calls is
1276    begin
1277       --  If expansion is disabled, do not generate any checks. Also
1278       --  skip checks if any subunits are missing because in either
1279       --  case we lack the full information that we need, and no object
1280       --  file will be created in any case.
1281
1282       if not Expander_Active
1283         or else Is_Generic_Unit (Cunit_Entity (Main_Unit))
1284         or else Subunits_Missing
1285       then
1286          return;
1287       end if;
1288
1289       --  Skip delayed calls if we had any errors
1290
1291       if Serious_Errors_Detected = 0 then
1292          Delaying_Elab_Checks := False;
1293          Expander_Mode_Save_And_Set (True);
1294
1295          for J in Delay_Check.First .. Delay_Check.Last loop
1296             New_Scope (Delay_Check.Table (J).Curscop);
1297             From_Elab_Code := Delay_Check.Table (J).From_Elab_Code;
1298
1299             Check_Internal_Call_Continue (
1300               N           => Delay_Check.Table (J).N,
1301               E           => Delay_Check.Table (J).E,
1302               Outer_Scope => Delay_Check.Table (J).Outer_Scope,
1303               Orig_Ent    => Delay_Check.Table (J).Orig_Ent);
1304
1305             Pop_Scope;
1306          end loop;
1307
1308          --  Set Delaying_Elab_Checks back on for next main compilation
1309
1310          Expander_Mode_Restore;
1311          Delaying_Elab_Checks := True;
1312       end if;
1313    end Check_Elab_Calls;
1314
1315    ------------------------------
1316    -- Check_Elab_Instantiation --
1317    ------------------------------
1318
1319    procedure Check_Elab_Instantiation
1320      (N           : Node_Id;
1321       Outer_Scope : Entity_Id := Empty)
1322    is
1323       Ent : Entity_Id;
1324
1325    begin
1326       --  Check for and deal with bad instantiation case. There is some
1327       --  duplicated code here, but we will worry about this later ???
1328
1329       Check_Bad_Instantiation (N);
1330
1331       if ABE_Is_Certain (N) then
1332          return;
1333       end if;
1334
1335       --  Nothing to do if we do not have an instantiation (happens in some
1336       --  error cases, and also in the formal package declaration case)
1337
1338       if Nkind (N) not in N_Generic_Instantiation then
1339          return;
1340       end if;
1341
1342       --  Nothing to do if inside a generic template
1343
1344       if Inside_A_Generic then
1345          return;
1346       end if;
1347
1348       Ent := Get_Generic_Entity (N);
1349       From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit;
1350
1351       --  See if we need to analyze this instantiation. We analyze it if
1352       --  either of the following conditions is met:
1353
1354       --    It is an inner level instantiation (since in this case it was
1355       --    triggered by an outer level call from elaboration code), but
1356       --    only if the instantiation is within the scope of the original
1357       --    outer level call.
1358
1359       --    It is an outer level instantiation from elaboration code, or the
1360       --    instantiated entity is in the same elaboratoin scope.
1361
1362       --  And in these cases, we will check both the inter-unit case and
1363       --  the intra-unit (within a single unit) case.
1364
1365       C_Scope := Current_Scope;
1366
1367       if Present (Outer_Scope)
1368         and then Within (Scope (Ent), Outer_Scope)
1369       then
1370          Set_C_Scope;
1371          Check_A_Call (N, Ent, Outer_Scope, Inter_Unit_Only => False);
1372
1373       elsif From_Elab_Code then
1374          Set_C_Scope;
1375          Check_A_Call (N, Ent, Standard_Standard, Inter_Unit_Only => False);
1376
1377       elsif Same_Elaboration_Scope (C_Scope, Scope (Ent)) then
1378          Set_C_Scope;
1379          Check_A_Call (N, Ent, Scope (Ent), Inter_Unit_Only => False);
1380
1381       --  If none of those cases holds, but Dynamic_Elaboration_Checks mode
1382       --  is set, then we will do the check, but only in the inter-unit case
1383       --  (this is to accommodate unguarded elaboration calls from other units
1384       --  in which this same mode is set). We inhibit warnings in this case,
1385       --  since this instantiation is not occurring in elaboration code.
1386
1387       elsif Dynamic_Elaboration_Checks then
1388          Set_C_Scope;
1389          Check_A_Call
1390            (N,
1391             Ent,
1392             Standard_Standard,
1393             Inter_Unit_Only => True,
1394             Generate_Warnings => False);
1395
1396       else
1397          return;
1398       end if;
1399    end Check_Elab_Instantiation;
1400
1401    -------------------------
1402    -- Check_Internal_Call --
1403    -------------------------
1404
1405    procedure Check_Internal_Call
1406      (N           : Node_Id;
1407       E           : Entity_Id;
1408       Outer_Scope : Entity_Id;
1409       Orig_Ent    : Entity_Id)
1410    is
1411       Inst_Case : constant Boolean := Nkind (N) in N_Generic_Instantiation;
1412
1413    begin
1414       --  If not function or procedure call or instantiation, then ignore
1415       --  call (this happens in some error case and rewriting cases)
1416
1417       if Nkind (N) /= N_Function_Call
1418            and then
1419          Nkind (N) /= N_Procedure_Call_Statement
1420            and then
1421          not Inst_Case
1422       then
1423          return;
1424
1425       --  Nothing to do if this is a call or instantiation that has
1426       --  already been found to be a sure ABE
1427
1428       elsif ABE_Is_Certain (N) then
1429          return;
1430
1431       --  Nothing to do if errors already detected (avoid cascaded errors)
1432
1433       elsif Serious_Errors_Detected /= 0 then
1434          return;
1435
1436       --  Nothing to do if not in full analysis mode
1437
1438       elsif not Full_Analysis then
1439          return;
1440
1441       --  Nothing to do if within a default expression, since the call
1442       --  is not actualy being made at this time.
1443
1444       elsif In_Default_Expression then
1445          return;
1446
1447       --  Nothing to do for call to intrinsic subprogram
1448
1449       elsif Is_Intrinsic_Subprogram (E) then
1450          return;
1451
1452       --  No need to trace local calls if checking task activation, because
1453       --  other local bodies are elaborated already.
1454
1455       elsif In_Task_Activation then
1456          return;
1457       end if;
1458
1459       --  Delay this call if we are still delaying calls
1460
1461       if Delaying_Elab_Checks then
1462          Delay_Check.Increment_Last;
1463          Delay_Check.Table (Delay_Check.Last) :=
1464            (N              => N,
1465             E              => E,
1466             Orig_Ent       => Orig_Ent,
1467             Curscop        => Current_Scope,
1468             Outer_Scope    => Outer_Scope,
1469             From_Elab_Code => From_Elab_Code);
1470          return;
1471
1472       --  Otherwise, call phase 2 continuation right now
1473
1474       else
1475          Check_Internal_Call_Continue (N, E, Outer_Scope, Orig_Ent);
1476       end if;
1477
1478    end Check_Internal_Call;
1479
1480    ----------------------------------
1481    -- Check_Internal_Call_Continue --
1482    ----------------------------------
1483
1484    procedure Check_Internal_Call_Continue
1485      (N           : Node_Id;
1486       E           : Entity_Id;
1487       Outer_Scope : Entity_Id;
1488       Orig_Ent    : Entity_Id)
1489    is
1490       Loc       : constant Source_Ptr := Sloc (N);
1491       Inst_Case : constant Boolean := Is_Generic_Unit (E);
1492
1493       Sbody : Node_Id;
1494       Ebody : Entity_Id;
1495
1496       function Process (N : Node_Id) return Traverse_Result;
1497       --  Function applied to each node as we traverse the body.
1498       --  Checks for call that needs checking, and if so checks
1499       --  it. Always returns OK, so entire tree is traversed.
1500
1501       -------------
1502       -- Process --
1503       -------------
1504
1505       function Process (N : Node_Id) return Traverse_Result is
1506       begin
1507          --  If user has specified that there are no entry calls in elaboration
1508          --  code, do not trace past an accept statement, because the rendez-
1509          --  vous will happen after elaboration.
1510
1511          if (Nkind (Original_Node (N)) = N_Accept_Statement
1512               or else Nkind (Original_Node (N)) = N_Selective_Accept)
1513            and then Restriction_Active (No_Entry_Calls_In_Elaboration_Code)
1514          then
1515             return Abandon;
1516
1517          --  If we have a subprogram call, check it
1518
1519          elsif Nkind (N) = N_Function_Call
1520            or else Nkind (N) = N_Procedure_Call_Statement
1521          then
1522             Check_Elab_Call (N, Outer_Scope);
1523             return OK;
1524
1525          --  If we have a generic instantiation, check it
1526
1527          elsif Nkind (N) in N_Generic_Instantiation then
1528             Check_Elab_Instantiation (N, Outer_Scope);
1529             return OK;
1530
1531          --  Skip subprogram bodies that come from source (wait for
1532          --  call to analyze these). The reason for the come from
1533          --  source test is to avoid catching task bodies.
1534
1535          --  For task bodies, we should really avoid these too, waiting
1536          --  for the task activation, but that's too much trouble to
1537          --  catch for now, so we go in unconditionally. This is not
1538          --  so terrible, it means the error backtrace is not quite
1539          --  complete, and we are too eager to scan bodies of tasks
1540          --  that are unused, but this is hardly very significant!
1541
1542          elsif Nkind (N) = N_Subprogram_Body
1543            and then Comes_From_Source (N)
1544          then
1545             return Skip;
1546
1547          else
1548             return OK;
1549          end if;
1550       end Process;
1551
1552       procedure Traverse is new Atree.Traverse_Proc;
1553       --  Traverse procedure using above Process function
1554
1555    --  Start of processing for Check_Internal_Call_Continue
1556
1557    begin
1558       --  Save outer level call if at outer level
1559
1560       if Elab_Call.Last = 0 then
1561          Outer_Level_Sloc := Loc;
1562       end if;
1563
1564       Elab_Visited.Increment_Last;
1565       Elab_Visited.Table (Elab_Visited.Last) := E;
1566
1567       --  If the call is to a function that renames a literal, no check
1568       --  is needed.
1569
1570       if Ekind (E) = E_Enumeration_Literal then
1571          return;
1572       end if;
1573
1574       Sbody := Unit_Declaration_Node (E);
1575
1576       if Nkind (Sbody) /= N_Subprogram_Body
1577            and then
1578          Nkind (Sbody) /= N_Package_Body
1579       then
1580          Ebody := Corresponding_Body (Sbody);
1581
1582          if No (Ebody) then
1583             return;
1584          else
1585             Sbody := Unit_Declaration_Node (Ebody);
1586          end if;
1587       end if;
1588
1589       --  If the body appears after the outer level call or
1590       --  instantiation then we have an error case handled below.
1591
1592       if Earlier_In_Extended_Unit (Outer_Level_Sloc, Sloc (Sbody))
1593         and then not In_Task_Activation
1594       then
1595          null;
1596
1597       --  If we have the instantiation case we are done, since we now
1598       --  know that the body of the generic appeared earlier.
1599
1600       elsif Inst_Case then
1601          return;
1602
1603       --  Otherwise we have a call, so we trace through the called
1604       --  body to see if it has any problems ..
1605
1606       else
1607          pragma Assert (Nkind (Sbody) = N_Subprogram_Body);
1608
1609          Elab_Call.Increment_Last;
1610          Elab_Call.Table (Elab_Call.Last).Cloc := Loc;
1611          Elab_Call.Table (Elab_Call.Last).Ent  := E;
1612
1613          if Debug_Flag_LL then
1614             Write_Str ("Elab_Call.Last = ");
1615             Write_Int (Int (Elab_Call.Last));
1616             Write_Str ("   Ent = ");
1617             Write_Name (Chars (E));
1618             Write_Str ("   at ");
1619             Write_Location (Sloc (N));
1620             Write_Eol;
1621          end if;
1622
1623          --  Now traverse declarations and statements of subprogram body.
1624          --  Note that we cannot simply Traverse (Sbody), since traverse
1625          --  does not normally visit subprogram bodies.
1626
1627          declare
1628             Decl : Node_Id := First (Declarations (Sbody));
1629
1630          begin
1631             while Present (Decl) loop
1632                Traverse (Decl);
1633                Next (Decl);
1634             end loop;
1635          end;
1636
1637          Traverse (Handled_Statement_Sequence (Sbody));
1638
1639          Elab_Call.Decrement_Last;
1640          return;
1641       end if;
1642
1643       --  Here is the case of calling a subprogram where the body has
1644       --  not yet been encountered, a warning message is needed.
1645
1646       --  If we have nothing in the call stack, then this is at the
1647       --  outer level, and the ABE is bound to occur.
1648
1649       if Elab_Call.Last = 0 then
1650          if Inst_Case then
1651             Error_Msg_NE
1652               ("?cannot instantiate& before body seen", N, Orig_Ent);
1653          else
1654             Error_Msg_NE
1655               ("?cannot call& before body seen", N, Orig_Ent);
1656          end if;
1657
1658          Error_Msg_N
1659            ("\?Program_Error will be raised at run time", N);
1660          Insert_Elab_Check (N);
1661
1662       --  Call is not at outer level
1663
1664       else
1665          --  Deal with dynamic elaboration check
1666
1667          if not Elaboration_Checks_Suppressed (E) then
1668             Set_Elaboration_Entity_Required (E);
1669
1670             --  Case of no elaboration entity allocated yet
1671
1672             if No (Elaboration_Entity (E)) then
1673
1674                --  Create object declaration for elaboration entity, and put it
1675                --  just in front of the spec of the subprogram or generic unit,
1676                --  in the same scope as this unit.
1677
1678                declare
1679                   Loce : constant Source_Ptr := Sloc (E);
1680                   Ent  : constant Entity_Id  :=
1681                            Make_Defining_Identifier (Loc,
1682                              Chars => New_External_Name (Chars (E), 'E'));
1683
1684                begin
1685                   Set_Elaboration_Entity (E, Ent);
1686                   New_Scope (Scope (E));
1687
1688                   Insert_Action (Declaration_Node (E),
1689                     Make_Object_Declaration (Loce,
1690                       Defining_Identifier => Ent,
1691                       Object_Definition =>
1692                         New_Occurrence_Of (Standard_Boolean, Loce),
1693                       Expression => New_Occurrence_Of (Standard_False, Loce)));
1694
1695                   --  Set elaboration flag at the point of the body
1696
1697                   Set_Elaboration_Flag (Sbody, E);
1698
1699                   --  Kill current value indication. This is necessary
1700                   --  because the tests of this flag are inserted out of
1701                   --  sequence and must not pick up bogus indications of
1702                   --  the wrong constant value. Also, this is never a true
1703                   --  constant, since one way or another, it gets reset.
1704
1705                   Set_Current_Value    (Ent, Empty);
1706                   Set_Is_True_Constant (Ent, False);
1707                   Pop_Scope;
1708                end;
1709             end if;
1710
1711             --  Generate check of the elaboration Boolean
1712
1713             Insert_Elab_Check (N,
1714               New_Occurrence_Of (Elaboration_Entity (E), Loc));
1715          end if;
1716
1717          --  Generate the warning
1718
1719          if not Suppress_Elaboration_Warnings (E)
1720            and then not Elaboration_Checks_Suppressed (E)
1721          then
1722             if Inst_Case then
1723                Error_Msg_NE
1724                  ("instantiation of& may occur before body is seen?",
1725                   N, Orig_Ent);
1726             else
1727                Error_Msg_NE
1728                  ("call to& may occur before body is seen?", N, Orig_Ent);
1729             end if;
1730
1731             Error_Msg_N
1732               ("\Program_Error may be raised at run time?", N);
1733
1734             Output_Calls (N);
1735          end if;
1736       end if;
1737
1738       --  Set flag to suppress further warnings on same subprogram
1739       --  unless in all errors mode
1740
1741       if not All_Errors_Mode then
1742          Set_Suppress_Elaboration_Warnings (E);
1743       end if;
1744    end Check_Internal_Call_Continue;
1745
1746    ---------------------------
1747    -- Check_Task_Activation --
1748    ---------------------------
1749
1750    procedure Check_Task_Activation (N : Node_Id) is
1751       Loc         : constant Source_Ptr := Sloc (N);
1752       Inter_Procs : constant Elist_Id   := New_Elmt_List;
1753       Intra_Procs : constant Elist_Id   := New_Elmt_List;
1754       Ent         : Entity_Id;
1755       P           : Entity_Id;
1756       Task_Scope  : Entity_Id;
1757       Cunit_SC    : Boolean := False;
1758       Decl        : Node_Id;
1759       Elmt        : Elmt_Id;
1760       Enclosing   : Entity_Id;
1761
1762       procedure Add_Task_Proc (Typ : Entity_Id);
1763       --  Add to Task_Procs the task body procedure(s) of task types in Typ.
1764       --  For record types, this procedure recurses over component types.
1765
1766       procedure Collect_Tasks (Decls : List_Id);
1767       --  Collect the types of the tasks that are to be activated in the given
1768       --  list of declarations, in order to perform elaboration checks on the
1769       --  corresponding task procedures which are called implicitly here.
1770
1771       function Outer_Unit (E : Entity_Id) return Entity_Id;
1772       --  find enclosing compilation unit of Entity, ignoring subunits, or
1773       --  else enclosing subprogram. If E is not a package, there is no need
1774       --  for inter-unit elaboration checks.
1775
1776       -------------------
1777       -- Add_Task_Proc --
1778       -------------------
1779
1780       procedure Add_Task_Proc (Typ : Entity_Id) is
1781          Comp : Entity_Id;
1782          Proc : Entity_Id := Empty;
1783
1784       begin
1785          if Is_Task_Type (Typ) then
1786             Proc := Get_Task_Body_Procedure (Typ);
1787
1788          elsif Is_Array_Type (Typ)
1789            and then Has_Task (Base_Type (Typ))
1790          then
1791             Add_Task_Proc (Component_Type (Typ));
1792
1793          elsif Is_Record_Type (Typ)
1794            and then Has_Task (Base_Type (Typ))
1795          then
1796             Comp := First_Component (Typ);
1797
1798             while Present (Comp) loop
1799                Add_Task_Proc (Etype (Comp));
1800                Comp := Next_Component (Comp);
1801             end loop;
1802          end if;
1803
1804          --  If the task type is another unit, we will perform the usual
1805          --  elaboration check on its enclosing unit. If the type is in the
1806          --  same unit, we can trace the task body as for an internal call,
1807          --  but we only need to examine other external calls, because at
1808          --  the point the task is activated, internal subprogram bodies
1809          --  will have been elaborated already. We keep separate lists for
1810          --  each kind of task.
1811
1812          --  Skip this test if errors have occurred, since in this case
1813          --  we can get false indications.
1814
1815          if Serious_Errors_Detected /= 0 then
1816             return;
1817          end if;
1818
1819          if Present (Proc) then
1820             if Outer_Unit (Scope (Proc)) = Enclosing then
1821
1822                if No (Corresponding_Body (Unit_Declaration_Node (Proc)))
1823                  and then
1824                    (not Is_Generic_Instance (Scope (Proc))
1825                       or else
1826                     Scope (Proc) = Scope (Defining_Identifier (Decl)))
1827                then
1828                   Error_Msg_N
1829                     ("task will be activated before elaboration of its body?",
1830                       Decl);
1831                   Error_Msg_N
1832                     ("Program_Error will be raised at run-time?", Decl);
1833
1834                elsif
1835                  Present (Corresponding_Body (Unit_Declaration_Node (Proc)))
1836                then
1837                   Append_Elmt (Proc, Intra_Procs);
1838                end if;
1839
1840             else
1841                Elmt := First_Elmt (Inter_Procs);
1842
1843                --  No need for multiple entries of the same type.
1844
1845                while Present (Elmt) loop
1846                   if Node (Elmt) = Proc then
1847                      return;
1848                   end if;
1849
1850                   Next_Elmt (Elmt);
1851                end loop;
1852
1853                Append_Elmt (Proc, Inter_Procs);
1854             end if;
1855          end if;
1856       end Add_Task_Proc;
1857
1858       -------------------
1859       -- Collect_Tasks --
1860       -------------------
1861
1862       procedure Collect_Tasks (Decls : List_Id) is
1863       begin
1864          if Present (Decls) then
1865             Decl := First (Decls);
1866
1867             while Present (Decl) loop
1868
1869                if Nkind (Decl) = N_Object_Declaration
1870                  and then Has_Task (Etype (Defining_Identifier (Decl)))
1871                then
1872                   Add_Task_Proc (Etype (Defining_Identifier (Decl)));
1873                end if;
1874
1875                Next (Decl);
1876             end loop;
1877          end if;
1878       end Collect_Tasks;
1879
1880       ----------------
1881       -- Outer_Unit --
1882       ----------------
1883
1884       function Outer_Unit (E : Entity_Id) return Entity_Id is
1885          Outer : Entity_Id := E;
1886
1887       begin
1888          while Present (Outer) loop
1889             if Elaboration_Checks_Suppressed (Outer) then
1890                Cunit_SC := True;
1891             end if;
1892
1893             exit when Is_Child_Unit (Outer)
1894               or else Scope (Outer) = Standard_Standard
1895               or else Ekind (Outer) /= E_Package;
1896             Outer := Scope (Outer);
1897          end loop;
1898
1899          return Outer;
1900       end Outer_Unit;
1901
1902    --  Start of processing for Check_Task_Activation
1903
1904    begin
1905       Enclosing := Outer_Unit (Current_Scope);
1906
1907       --  Find all tasks declared in the current unit.
1908
1909       if Nkind (N) = N_Package_Body then
1910          P := Unit_Declaration_Node (Corresponding_Spec (N));
1911
1912          Collect_Tasks (Declarations (N));
1913          Collect_Tasks (Visible_Declarations (Specification (P)));
1914          Collect_Tasks (Private_Declarations (Specification (P)));
1915
1916       elsif Nkind (N) = N_Package_Declaration then
1917          Collect_Tasks (Visible_Declarations (Specification (N)));
1918          Collect_Tasks (Private_Declarations (Specification (N)));
1919
1920       else
1921          Collect_Tasks (Declarations (N));
1922       end if;
1923
1924       --  We only perform detailed checks in all tasks are library level
1925       --  entities. If the master is a subprogram or task, activation will
1926       --  depend on the activation of the master itself.
1927       --  Should dynamic checks be added in the more general case???
1928
1929       if Ekind (Enclosing) /= E_Package then
1930          return;
1931       end if;
1932
1933       --  For task types defined in other units, we want the unit containing
1934       --  the task body to be elaborated before the current one.
1935
1936       Elmt := First_Elmt (Inter_Procs);
1937
1938       while Present (Elmt) loop
1939          Ent := Node (Elmt);
1940          Task_Scope := Outer_Unit (Scope (Ent));
1941
1942          if not Is_Compilation_Unit (Task_Scope) then
1943             null;
1944
1945          elsif Suppress_Elaboration_Warnings (Task_Scope)
1946            or else Elaboration_Checks_Suppressed (Task_Scope)
1947          then
1948             null;
1949
1950          elsif Dynamic_Elaboration_Checks then
1951             if not Elaboration_Checks_Suppressed (Ent)
1952               and then not Cunit_SC
1953               and then
1954                 not Restriction_Active (No_Entry_Calls_In_Elaboration_Code)
1955             then
1956                --  Runtime elaboration check required. generate check of the
1957                --  elaboration Boolean for the unit containing the entity.
1958
1959                Insert_Elab_Check (N,
1960                  Make_Attribute_Reference (Loc,
1961                    Attribute_Name => Name_Elaborated,
1962                    Prefix =>
1963                      New_Occurrence_Of
1964                        (Spec_Entity (Task_Scope), Loc)));
1965             end if;
1966
1967          else
1968             --  Force the binder to elaborate other unit first
1969
1970             if not Suppress_Elaboration_Warnings (Ent)
1971               and then not Elaboration_Checks_Suppressed (Ent)
1972               and then Elab_Warnings
1973               and then not Suppress_Elaboration_Warnings (Task_Scope)
1974               and then not Elaboration_Checks_Suppressed (Task_Scope)
1975             then
1976                Error_Msg_Node_2 := Task_Scope;
1977                Error_Msg_NE ("activation of an instance of task type&" &
1978                   " requires pragma Elaborate_All on &?", N, Ent);
1979             end if;
1980
1981             Set_Elaborate_All_Desirable (Task_Scope);
1982             Set_Suppress_Elaboration_Warnings (Task_Scope);
1983          end if;
1984
1985          Next_Elmt (Elmt);
1986       end loop;
1987
1988       --  For tasks declared in the current unit, trace other calls within
1989       --  the task procedure bodies, which are available.
1990
1991       In_Task_Activation := True;
1992       Elmt := First_Elmt (Intra_Procs);
1993
1994       while Present (Elmt) loop
1995          Ent := Node (Elmt);
1996          Check_Internal_Call_Continue (N, Ent, Enclosing, Ent);
1997          Next_Elmt (Elmt);
1998       end loop;
1999
2000       In_Task_Activation := False;
2001    end Check_Task_Activation;
2002
2003    ----------------------
2004    -- Has_Generic_Body --
2005    ----------------------
2006
2007    function Has_Generic_Body (N : Node_Id) return Boolean is
2008       Ent  : constant Entity_Id := Get_Generic_Entity (N);
2009       Decl : constant Node_Id   := Unit_Declaration_Node (Ent);
2010       Scop : Entity_Id;
2011
2012       function Find_Body_In (E : Entity_Id; N : Node_Id) return Node_Id;
2013       --  Determine if the list of nodes headed by N and linked by Next
2014       --  contains a package body for the package spec entity E, and if
2015       --  so return the package body. If not, then returns Empty.
2016
2017       function Load_Package_Body (Nam : Unit_Name_Type) return Node_Id;
2018       --  This procedure is called load the unit whose name is given by Nam.
2019       --  This unit is being loaded to see whether it contains an optional
2020       --  generic body. The returned value is the loaded unit, which is
2021       --  always a package body (only package bodies can contain other
2022       --  entities in the sense in which Has_Generic_Body is interested).
2023       --  We only attempt to load bodies if we are generating code. If we
2024       --  are in semantics check only mode, then it would be wrong to load
2025       --  bodies that are not required from a semantic point of view, so
2026       --  in this case we return Empty. The result is that the caller may
2027       --  incorrectly decide that a generic spec does not have a body when
2028       --  in fact it does, but the only harm in this is that some warnings
2029       --  on elaboration problems may be lost in semantic checks only mode,
2030       --  which is not big loss. We also return Empty if we go for a body
2031       --  and it is not there.
2032
2033       function Locate_Corresponding_Body (PE : Entity_Id) return Node_Id;
2034       --  PE is the entity for a package spec. This function locates the
2035       --  corresponding package body, returning Empty if none is found.
2036       --  The package body returned is fully parsed but may not yet be
2037       --  analyzed, so only syntactic fields should be referenced.
2038
2039       ------------------
2040       -- Find_Body_In --
2041       ------------------
2042
2043       function Find_Body_In (E : Entity_Id; N : Node_Id) return Node_Id is
2044          Nod : Node_Id;
2045
2046       begin
2047          Nod := N;
2048          while Present (Nod) loop
2049
2050             --  If we found the package body we are looking for, return it
2051
2052             if Nkind (Nod) = N_Package_Body
2053               and then Chars (Defining_Unit_Name (Nod)) = Chars (E)
2054             then
2055                return Nod;
2056
2057             --  If we found the stub for the body, go after the subunit,
2058             --  loading it if necessary.
2059
2060             elsif Nkind (Nod) = N_Package_Body_Stub
2061               and then Chars (Defining_Identifier (Nod)) = Chars (E)
2062             then
2063                if Present (Library_Unit (Nod)) then
2064                   return Unit (Library_Unit (Nod));
2065
2066                else
2067                   return Load_Package_Body (Get_Unit_Name (Nod));
2068                end if;
2069
2070             --  If neither package body nor stub, keep looking on chain
2071
2072             else
2073                Next (Nod);
2074             end if;
2075          end loop;
2076
2077          return Empty;
2078       end Find_Body_In;
2079
2080       -----------------------
2081       -- Load_Package_Body --
2082       -----------------------
2083
2084       function Load_Package_Body (Nam : Unit_Name_Type) return Node_Id is
2085          U : Unit_Number_Type;
2086
2087       begin
2088          if Operating_Mode /= Generate_Code then
2089             return Empty;
2090          else
2091             U :=
2092               Load_Unit
2093                 (Load_Name  => Nam,
2094                  Required   => False,
2095                  Subunit    => False,
2096                  Error_Node => N);
2097
2098             if U = No_Unit then
2099                return Empty;
2100             else
2101                return Unit (Cunit (U));
2102             end if;
2103          end if;
2104       end Load_Package_Body;
2105
2106       -------------------------------
2107       -- Locate_Corresponding_Body --
2108       -------------------------------
2109
2110       function Locate_Corresponding_Body (PE : Entity_Id) return Node_Id is
2111          Spec  : constant Node_Id   := Declaration_Node (PE);
2112          Decl  : constant Node_Id   := Parent (Spec);
2113          Scop  : constant Entity_Id := Scope (PE);
2114          PBody : Node_Id;
2115
2116       begin
2117          if Is_Library_Level_Entity (PE) then
2118
2119             --  If package is a library unit that requires a body, we have
2120             --  no choice but to go after that body because it might contain
2121             --  an optional body for the original generic package.
2122
2123             if Unit_Requires_Body (PE) then
2124
2125                --  Load the body. Note that we are a little careful here to
2126                --  use Spec to get the unit number, rather than PE or Decl,
2127                --  since in the case where the package is itself a library
2128                --  level instantiation, Spec will properly reference the
2129                --  generic template, which is what we really want.
2130
2131                return
2132                  Load_Package_Body
2133                    (Get_Body_Name (Unit_Name (Get_Source_Unit (Spec))));
2134
2135             --  But if the package is a library unit that does NOT require
2136             --  a body, then no body is permitted, so we are sure that there
2137             --  is no body for the original generic package.
2138
2139             else
2140                return Empty;
2141             end if;
2142
2143          --  Otherwise look and see if we are embedded in a further package
2144
2145          elsif Is_Package (Scop) then
2146
2147             --  If so, get the body of the enclosing package, and look in
2148             --  its package body for the package body we are looking for.
2149
2150             PBody := Locate_Corresponding_Body (Scop);
2151
2152             if No (PBody) then
2153                return Empty;
2154             else
2155                return Find_Body_In (PE, First (Declarations (PBody)));
2156             end if;
2157
2158          --  If we are not embedded in a further package, then the body
2159          --  must be in the same declarative part as we are.
2160
2161          else
2162             return Find_Body_In (PE, Next (Decl));
2163          end if;
2164       end Locate_Corresponding_Body;
2165
2166    --  Start of processing for Has_Generic_Body
2167
2168    begin
2169       if Present (Corresponding_Body (Decl)) then
2170          return True;
2171
2172       elsif Unit_Requires_Body (Ent) then
2173          return True;
2174
2175       --  Compilation units cannot have optional bodies
2176
2177       elsif Is_Compilation_Unit (Ent) then
2178          return False;
2179
2180       --  Otherwise look at what scope we are in
2181
2182       else
2183          Scop := Scope (Ent);
2184
2185          --  Case of entity is in other than a package spec, in this case
2186          --  the body, if present, must be in the same declarative part.
2187
2188          if not Is_Package (Scop) then
2189             declare
2190                P : Node_Id;
2191
2192             begin
2193                P := Declaration_Node (Ent);
2194
2195                --  Declaration node may get us a spec, so if so, go to
2196                --  the parent declaration.
2197
2198                while not Is_List_Member (P) loop
2199                   P := Parent (P);
2200                end loop;
2201
2202                return Present (Find_Body_In (Ent, Next (P)));
2203             end;
2204
2205          --  If the entity is in a package spec, then we have to locate
2206          --  the corresponding package body, and look there.
2207
2208          else
2209             declare
2210                PBody : constant Node_Id := Locate_Corresponding_Body (Scop);
2211
2212             begin
2213                if No (PBody) then
2214                   return False;
2215                else
2216                   return
2217                     Present
2218                       (Find_Body_In (Ent, (First (Declarations (PBody)))));
2219                end if;
2220             end;
2221          end if;
2222       end if;
2223    end Has_Generic_Body;
2224
2225    -----------------------
2226    -- Insert_Elab_Check --
2227    -----------------------
2228
2229    procedure Insert_Elab_Check (N : Node_Id; C : Node_Id := Empty) is
2230       Nod : Node_Id;
2231       Loc : constant Source_Ptr := Sloc (N);
2232
2233    begin
2234       --  If expansion is disabled, do not generate any checks. Also
2235       --  skip checks if any subunits are missing because in either
2236       --  case we lack the full information that we need, and no object
2237       --  file will be created in any case.
2238
2239       if not Expander_Active or else Subunits_Missing then
2240          return;
2241       end if;
2242
2243       --  If we have a generic instantiation, where Instance_Spec is set,
2244       --  then this field points to a generic instance spec that has
2245       --  been inserted before the instantiation node itself, so that
2246       --  is where we want to insert a check.
2247
2248       if Nkind (N) in N_Generic_Instantiation
2249         and then Present (Instance_Spec (N))
2250       then
2251          Nod := Instance_Spec (N);
2252       else
2253          Nod := N;
2254       end if;
2255
2256       --  If we are inserting at the top level, insert in Aux_Decls
2257
2258       if Nkind (Parent (Nod)) = N_Compilation_Unit then
2259          declare
2260             ADN : constant Node_Id := Aux_Decls_Node (Parent (Nod));
2261             R   : Node_Id;
2262
2263          begin
2264             if No (C) then
2265                R :=
2266                  Make_Raise_Program_Error (Loc,
2267                    Reason => PE_Access_Before_Elaboration);
2268             else
2269                R :=
2270                  Make_Raise_Program_Error (Loc,
2271                    Condition => Make_Op_Not (Loc, C),
2272                    Reason    => PE_Access_Before_Elaboration);
2273             end if;
2274
2275             if No (Declarations (ADN)) then
2276                Set_Declarations (ADN, New_List (R));
2277             else
2278                Append_To (Declarations (ADN), R);
2279             end if;
2280
2281             Analyze (R);
2282          end;
2283
2284       --  Otherwise just insert before the node in question. However, if
2285       --  the context of the call has already been analyzed, an insertion
2286       --  will not work if it depends on subsequent expansion (e.g. a call in
2287       --  a branch of a short-circuit). In that case we replace the call with
2288       --  a conditional expression, or with a Raise if it is unconditional.
2289       --  Unfortunately this does not work if the call has a dynamic size,
2290       --  because gigi regards it as a dynamic-sized temporary. If such a call
2291       --  appears in a short-circuit expression, the elaboration check will be
2292       --  missed (rare enough ???). Otherwise, the code below inserts the check
2293       --  at the appropriate place before the call. Same applies in the even
2294       --  rarer case the return type has a known size but is unconstrained.
2295
2296       else
2297          if Nkind (N) = N_Function_Call
2298            and then Analyzed (Parent (N))
2299            and then Size_Known_At_Compile_Time (Etype (N))
2300            and then
2301             (not Has_Discriminants (Etype (N))
2302               or else Is_Constrained (Etype (N)))
2303
2304          then
2305             declare
2306                Typ : constant Entity_Id := Etype (N);
2307                Chk : constant Boolean   := Do_Range_Check (N);
2308
2309                R   : constant Node_Id :=
2310                        Make_Raise_Program_Error (Loc,
2311                          Reason => PE_Access_Before_Elaboration);
2312
2313             begin
2314                Set_Etype (R, Typ);
2315
2316                if No (C) then
2317                   Rewrite (N, R);
2318
2319                else
2320                   Rewrite (N,
2321                     Make_Conditional_Expression (Loc,
2322                       Expressions => New_List (C, Relocate_Node (N), R)));
2323                end if;
2324
2325                Analyze_And_Resolve (N, Typ);
2326
2327                --  If the original call requires a range check, so does the
2328                --  conditional expression.
2329
2330                if Chk then
2331                   Enable_Range_Check (N);
2332                else
2333                   Set_Do_Range_Check (N, False);
2334                end if;
2335             end;
2336
2337          else
2338             if No (C) then
2339                Insert_Action (Nod,
2340                   Make_Raise_Program_Error (Loc,
2341                     Reason => PE_Access_Before_Elaboration));
2342             else
2343                Insert_Action (Nod,
2344                   Make_Raise_Program_Error (Loc,
2345                     Condition =>
2346                       Make_Op_Not (Loc,
2347                         Right_Opnd => C),
2348                     Reason => PE_Access_Before_Elaboration));
2349             end if;
2350          end if;
2351       end if;
2352    end Insert_Elab_Check;
2353
2354    ------------------
2355    -- Output_Calls --
2356    ------------------
2357
2358    procedure Output_Calls (N : Node_Id) is
2359       Ent : Entity_Id;
2360
2361       function Is_Printable_Error_Name (Nm : Name_Id) return Boolean;
2362       --  An internal function, used to determine if a name, Nm, is either
2363       --  a non-internal name, or is an internal name that is printable
2364       --  by the error message circuits (i.e. it has a single upper
2365       --  case letter at the end).
2366
2367       function Is_Printable_Error_Name (Nm : Name_Id) return Boolean is
2368       begin
2369          if not Is_Internal_Name (Nm) then
2370             return True;
2371
2372          elsif Name_Len = 1 then
2373             return False;
2374
2375          else
2376             Name_Len := Name_Len - 1;
2377             return not Is_Internal_Name;
2378          end if;
2379       end Is_Printable_Error_Name;
2380
2381    --  Start of processing for Output_Calls
2382
2383    begin
2384       for J in reverse 1 .. Elab_Call.Last loop
2385          Error_Msg_Sloc := Elab_Call.Table (J).Cloc;
2386
2387          Ent := Elab_Call.Table (J).Ent;
2388
2389          if Is_Generic_Unit (Ent) then
2390             Error_Msg_NE ("\?& instantiated #", N, Ent);
2391
2392          elsif Is_Init_Proc (Ent) then
2393             Error_Msg_N ("\?initialization procedure called #", N);
2394
2395          elsif Is_Printable_Error_Name (Chars (Ent)) then
2396             Error_Msg_NE ("\?& called #", N, Ent);
2397
2398          else
2399             Error_Msg_N ("\? called #", N);
2400          end if;
2401       end loop;
2402    end Output_Calls;
2403
2404    ----------------------------
2405    -- Same_Elaboration_Scope --
2406    ----------------------------
2407
2408    function Same_Elaboration_Scope (Scop1, Scop2 : Entity_Id) return Boolean is
2409       S1 : Entity_Id := Scop1;
2410       S2 : Entity_Id := Scop2;
2411
2412    begin
2413       while S1 /= Standard_Standard
2414         and then (Ekind (S1) = E_Package
2415                     or else
2416                   Ekind (S1) = E_Block)
2417       loop
2418          S1 := Scope (S1);
2419       end loop;
2420
2421       while S2 /= Standard_Standard
2422         and then (Ekind (S2) = E_Package
2423                     or else
2424                   Ekind (S2) = E_Protected_Type
2425                     or else
2426                   Ekind (S2) = E_Block)
2427       loop
2428          S2 := Scope (S2);
2429       end loop;
2430
2431       return S1 = S2;
2432    end Same_Elaboration_Scope;
2433
2434    -----------------
2435    -- Set_C_Scope --
2436    -----------------
2437
2438    procedure Set_C_Scope is
2439    begin
2440       while not Is_Compilation_Unit (C_Scope) loop
2441          C_Scope := Scope (C_Scope);
2442       end loop;
2443    end Set_C_Scope;
2444
2445    -----------------
2446    -- Spec_Entity --
2447    -----------------
2448
2449    function Spec_Entity (E : Entity_Id) return Entity_Id is
2450       Decl : Node_Id;
2451
2452    begin
2453       --  Check for case of body entity
2454       --  Why is the check for E_Void needed???
2455
2456       if Ekind (E) = E_Void
2457         or else Ekind (E) = E_Subprogram_Body
2458         or else Ekind (E) = E_Package_Body
2459       then
2460          Decl := E;
2461
2462          loop
2463             Decl := Parent (Decl);
2464             exit when Nkind (Decl) in N_Proper_Body;
2465          end loop;
2466
2467          return Corresponding_Spec (Decl);
2468
2469       else
2470          return E;
2471       end if;
2472    end Spec_Entity;
2473
2474    -------------------
2475    -- Supply_Bodies --
2476    -------------------
2477
2478    procedure Supply_Bodies (N : Node_Id) is
2479    begin
2480       if Nkind (N) = N_Subprogram_Declaration then
2481          declare
2482             Ent : constant Entity_Id := Defining_Unit_Name (Specification (N));
2483
2484          begin
2485             Set_Is_Imported (Ent);
2486             Set_Convention  (Ent, Convention_Stubbed);
2487          end;
2488
2489       elsif Nkind (N) = N_Package_Declaration then
2490          declare
2491             Spec : constant Node_Id := Specification (N);
2492
2493          begin
2494             New_Scope (Defining_Unit_Name (Spec));
2495             Supply_Bodies (Visible_Declarations (Spec));
2496             Supply_Bodies (Private_Declarations (Spec));
2497             Pop_Scope;
2498          end;
2499       end if;
2500    end Supply_Bodies;
2501
2502    procedure Supply_Bodies (L : List_Id) is
2503       Elmt : Node_Id;
2504
2505    begin
2506       if Present (L) then
2507          Elmt := First (L);
2508          while Present (Elmt) loop
2509             Supply_Bodies (Elmt);
2510             Next (Elmt);
2511          end loop;
2512       end if;
2513    end Supply_Bodies;
2514
2515    ------------
2516    -- Within --
2517    ------------
2518
2519    function Within (E1, E2 : Entity_Id) return Boolean is
2520       Scop : Entity_Id;
2521
2522    begin
2523       Scop := E1;
2524
2525       loop
2526          if Scop = E2 then
2527             return True;
2528
2529          elsif Scop = Standard_Standard then
2530             return False;
2531
2532          else
2533             Scop := Scope (Scop);
2534          end if;
2535       end loop;
2536
2537       raise Program_Error;
2538    end Within;
2539
2540    --------------------------
2541    -- Within_Elaborate_All --
2542    --------------------------
2543
2544    function Within_Elaborate_All (E : Entity_Id) return Boolean is
2545       Item    : Node_Id;
2546       Item2   : Node_Id;
2547       Elab_Id : Entity_Id;
2548       Par     : Node_Id;
2549
2550    begin
2551       Item := First (Context_Items (Cunit (Current_Sem_Unit)));
2552
2553       while Present (Item) loop
2554          if Nkind (Item) = N_Pragma
2555            and then Get_Pragma_Id (Chars (Item)) = Pragma_Elaborate_All
2556          then
2557             if Error_Posted (Item) then
2558
2559                --  Some previous error on the pragma itself
2560
2561                return False;
2562             end if;
2563
2564             Elab_Id :=
2565               Entity (
2566                 Expression (First (Pragma_Argument_Associations (Item))));
2567
2568             Par   := Parent (Unit_Declaration_Node (Elab_Id));
2569             Item2 := First (Context_Items (Par));
2570
2571             while Present (Item2) loop
2572                if Nkind (Item2) = N_With_Clause
2573                  and then Entity (Name (Item2)) = E
2574                then
2575                   return True;
2576                end if;
2577
2578                Next (Item2);
2579             end loop;
2580          end if;
2581
2582          Next (Item);
2583       end loop;
2584
2585       return False;
2586    end Within_Elaborate_All;
2587
2588 end Sem_Elab;