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