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