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
1181         or else Is_Generic_Unit (Cunit_Entity (Main_Unit))
1182         or else Subunits_Missing
1183       then
1184          return;
1185       end if;
1186
1187       --  Skip delayed calls if we had any errors
1188
1189       if Serious_Errors_Detected = 0 then
1190          Delaying_Elab_Checks := False;
1191          Expander_Mode_Save_And_Set (True);
1192
1193          for J in Delay_Check.First .. Delay_Check.Last loop
1194             New_Scope (Delay_Check.Table (J).Curscop);
1195             From_Elab_Code := Delay_Check.Table (J).From_Elab_Code;
1196
1197             Check_Internal_Call_Continue (
1198               N           => Delay_Check.Table (J).N,
1199               E           => Delay_Check.Table (J).E,
1200               Outer_Scope => Delay_Check.Table (J).Outer_Scope,
1201               Orig_Ent    => Delay_Check.Table (J).Orig_Ent);
1202
1203             Pop_Scope;
1204          end loop;
1205
1206          --  Set Delaying_Elab_Checks back on for next main compilation
1207
1208          Expander_Mode_Restore;
1209          Delaying_Elab_Checks := True;
1210       end if;
1211    end Check_Elab_Calls;
1212
1213    ------------------------------
1214    -- Check_Elab_Instantiation --
1215    ------------------------------
1216
1217    procedure Check_Elab_Instantiation
1218      (N           : Node_Id;
1219       Outer_Scope : Entity_Id := Empty)
1220    is
1221       Ent : Entity_Id;
1222
1223    begin
1224       --  Check for and deal with bad instantiation case. There is some
1225       --  duplicated code here, but we will worry about this later ???
1226
1227       Check_Bad_Instantiation (N);
1228
1229       if ABE_Is_Certain (N) then
1230          return;
1231       end if;
1232
1233       --  Nothing to do if we do not have an instantiation (happens in some
1234       --  error cases, and also in the formal package declaration case)
1235
1236       if Nkind (N) not in N_Generic_Instantiation then
1237          return;
1238       end if;
1239
1240       --  Nothing to do if inside a generic template
1241
1242       if Inside_A_Generic then
1243          return;
1244       end if;
1245
1246       Ent := Get_Generic_Entity (N);
1247       From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit;
1248
1249       --  See if we need to analyze this instantiation. We analyze it if
1250       --  either of the following conditions is met:
1251
1252       --    It is an inner level instantiation (since in this case it was
1253       --    triggered by an outer level call from elaboration code), but
1254       --    only if the instantiation is within the scope of the original
1255       --    outer level call.
1256
1257       --    It is an outer level instantiation from elaboration code, or the
1258       --    instantiated entity is in the same elaboratoin scope.
1259
1260       --  And in these cases, we will check both the inter-unit case and
1261       --  the intra-unit (within a single unit) case.
1262
1263       C_Scope := Current_Scope;
1264
1265       if Present (Outer_Scope)
1266         and then Within (Scope (Ent), Outer_Scope)
1267       then
1268          Set_C_Scope;
1269          Check_A_Call (N, Ent, Outer_Scope, Inter_Unit_Only => False);
1270
1271       elsif From_Elab_Code then
1272          Set_C_Scope;
1273          Check_A_Call (N, Ent, Standard_Standard, Inter_Unit_Only => False);
1274
1275       elsif Same_Elaboration_Scope (C_Scope, Scope (Ent)) then
1276          Set_C_Scope;
1277          Check_A_Call (N, Ent, Scope (Ent), Inter_Unit_Only => False);
1278
1279       --  If none of those cases holds, but Dynamic_Elaboration_Checks mode
1280       --  is set, then we will do the check, but only in the inter-unit case
1281       --  (this is to accommodate unguarded elaboration calls from other units
1282       --  in which this same mode is set). We inhibit warnings in this case,
1283       --  since this instantiation is not occurring in elaboration code.
1284
1285       elsif Dynamic_Elaboration_Checks then
1286          Set_C_Scope;
1287          Check_A_Call
1288            (N,
1289             Ent,
1290             Standard_Standard,
1291             Inter_Unit_Only => True,
1292             Generate_Warnings => False);
1293
1294       else
1295          return;
1296       end if;
1297    end Check_Elab_Instantiation;
1298
1299    -------------------------
1300    -- Check_Internal_Call --
1301    -------------------------
1302
1303    procedure Check_Internal_Call
1304      (N           : Node_Id;
1305       E           : Entity_Id;
1306       Outer_Scope : Entity_Id;
1307       Orig_Ent    : Entity_Id)
1308    is
1309       Inst_Case : constant Boolean := Nkind (N) in N_Generic_Instantiation;
1310
1311    begin
1312       --  If not function or procedure call or instantiation, then ignore
1313       --  call (this happens in some error case and rewriting cases)
1314
1315       if Nkind (N) /= N_Function_Call
1316            and then
1317          Nkind (N) /= N_Procedure_Call_Statement
1318            and then
1319          not Inst_Case
1320       then
1321          return;
1322
1323       --  Nothing to do if this is a call or instantiation that has
1324       --  already been found to be a sure ABE
1325
1326       elsif ABE_Is_Certain (N) then
1327          return;
1328
1329       --  Nothing to do if errors already detected (avoid cascaded errors)
1330
1331       elsif Serious_Errors_Detected /= 0 then
1332          return;
1333
1334       --  Nothing to do if not in full analysis mode
1335
1336       elsif not Full_Analysis then
1337          return;
1338
1339       --  Nothing to do if within a default expression, since the call
1340       --  is not actualy being made at this time.
1341
1342       elsif In_Default_Expression then
1343          return;
1344
1345       --  Nothing to do for call to intrinsic subprogram
1346
1347       elsif Is_Intrinsic_Subprogram (E) then
1348          return;
1349
1350       --  No need to trace local calls if checking task activation, because
1351       --  other local bodies are elaborated already.
1352
1353       elsif In_Task_Activation then
1354          return;
1355       end if;
1356
1357       --  Delay this call if we are still delaying calls
1358
1359       if Delaying_Elab_Checks then
1360          Delay_Check.Increment_Last;
1361          Delay_Check.Table (Delay_Check.Last) :=
1362            (N              => N,
1363             E              => E,
1364             Orig_Ent       => Orig_Ent,
1365             Curscop        => Current_Scope,
1366             Outer_Scope    => Outer_Scope,
1367             From_Elab_Code => From_Elab_Code);
1368          return;
1369
1370       --  Otherwise, call phase 2 continuation right now
1371
1372       else
1373          Check_Internal_Call_Continue (N, E, Outer_Scope, Orig_Ent);
1374       end if;
1375
1376    end Check_Internal_Call;
1377
1378    ----------------------------------
1379    -- Check_Internal_Call_Continue --
1380    ----------------------------------
1381
1382    procedure Check_Internal_Call_Continue
1383      (N           : Node_Id;
1384       E           : Entity_Id;
1385       Outer_Scope : Entity_Id;
1386       Orig_Ent    : Entity_Id)
1387    is
1388       Loc       : constant Source_Ptr := Sloc (N);
1389       Inst_Case : constant Boolean := Is_Generic_Unit (E);
1390
1391       Sbody : Node_Id;
1392       Ebody : Entity_Id;
1393
1394       function Process (N : Node_Id) return Traverse_Result;
1395       --  Function applied to each node as we traverse the body.
1396       --  Checks for call that needs checking, and if so checks
1397       --  it. Always returns OK, so entire tree is traversed.
1398
1399       -------------
1400       -- Process --
1401       -------------
1402
1403       function Process (N : Node_Id) return Traverse_Result is
1404       begin
1405          --  If user has specified that there are no entry calls in elaboration
1406          --  code, do not trace past an accept statement, because the rendez-
1407          --  vous will happen after elaboration.
1408
1409          if (Nkind (Original_Node (N)) = N_Accept_Statement
1410               or else Nkind (Original_Node (N)) = N_Selective_Accept)
1411            and then Restrictions (No_Entry_Calls_In_Elaboration_Code)
1412          then
1413             return Abandon;
1414
1415          --  If we have a subprogram call, check it
1416
1417          elsif Nkind (N) = N_Function_Call
1418            or else Nkind (N) = N_Procedure_Call_Statement
1419          then
1420             Check_Elab_Call (N, Outer_Scope);
1421             return OK;
1422
1423          --  If we have a generic instantiation, check it
1424
1425          elsif Nkind (N) in N_Generic_Instantiation then
1426             Check_Elab_Instantiation (N, Outer_Scope);
1427             return OK;
1428
1429          --  Skip subprogram bodies that come from source (wait for
1430          --  call to analyze these). The reason for the come from
1431          --  source test is to avoid catching task bodies.
1432
1433          --  For task bodies, we should really avoid these too, waiting
1434          --  for the task activation, but that's too much trouble to
1435          --  catch for now, so we go in unconditionally. This is not
1436          --  so terrible, it means the error backtrace is not quite
1437          --  complete, and we are too eager to scan bodies of tasks
1438          --  that are unused, but this is hardly very significant!
1439
1440          elsif Nkind (N) = N_Subprogram_Body
1441            and then Comes_From_Source (N)
1442          then
1443             return Skip;
1444
1445          else
1446             return OK;
1447          end if;
1448       end Process;
1449
1450       procedure Traverse is new Atree.Traverse_Proc;
1451       --  Traverse procedure using above Process function
1452
1453    --  Start of processing for Check_Internal_Call_Continue
1454
1455    begin
1456       --  Save outer level call if at outer level
1457
1458       if Elab_Call.Last = 0 then
1459          Outer_Level_Sloc := Loc;
1460       end if;
1461
1462       Elab_Visited.Increment_Last;
1463       Elab_Visited.Table (Elab_Visited.Last) := E;
1464
1465       --  If the call is to a function that renames a literal, no check
1466       --  is needed.
1467
1468       if Ekind (E) = E_Enumeration_Literal then
1469          return;
1470       end if;
1471
1472       Sbody := Unit_Declaration_Node (E);
1473
1474       if Nkind (Sbody) /= N_Subprogram_Body
1475            and then
1476          Nkind (Sbody) /= N_Package_Body
1477       then
1478          Ebody := Corresponding_Body (Sbody);
1479
1480          if No (Ebody) then
1481             return;
1482          else
1483             Sbody := Unit_Declaration_Node (Ebody);
1484          end if;
1485       end if;
1486
1487       --  If the body appears after the outer level call or
1488       --  instantiation then we have an error case handled below.
1489
1490       if Earlier_In_Extended_Unit (Outer_Level_Sloc, Sloc (Sbody))
1491         and then not In_Task_Activation
1492       then
1493          null;
1494
1495       --  If we have the instantiation case we are done, since we now
1496       --  know that the body of the generic appeared earlier.
1497
1498       elsif Inst_Case then
1499          return;
1500
1501       --  Otherwise we have a call, so we trace through the called
1502       --  body to see if it has any problems ..
1503
1504       else
1505          pragma Assert (Nkind (Sbody) = N_Subprogram_Body);
1506
1507          Elab_Call.Increment_Last;
1508          Elab_Call.Table (Elab_Call.Last).Cloc := Loc;
1509          Elab_Call.Table (Elab_Call.Last).Ent  := E;
1510
1511          if Debug_Flag_LL then
1512             Write_Str ("Elab_Call.Last = ");
1513             Write_Int (Int (Elab_Call.Last));
1514             Write_Str ("   Ent = ");
1515             Write_Name (Chars (E));
1516             Write_Str ("   at ");
1517             Write_Location (Sloc (N));
1518             Write_Eol;
1519          end if;
1520
1521          --  Now traverse declarations and statements of subprogram body.
1522          --  Note that we cannot simply Traverse (Sbody), since traverse
1523          --  does not normally visit subprogram bodies.
1524
1525          declare
1526             Decl : Node_Id := First (Declarations (Sbody));
1527
1528          begin
1529             while Present (Decl) loop
1530                Traverse (Decl);
1531                Next (Decl);
1532             end loop;
1533          end;
1534
1535          Traverse (Handled_Statement_Sequence (Sbody));
1536
1537          Elab_Call.Decrement_Last;
1538          return;
1539       end if;
1540
1541       --  Here is the case of calling a subprogram where the body has
1542       --  not yet been encountered, a warning message is needed.
1543
1544       --  If we have nothing in the call stack, then this is at the
1545       --  outer level, and the ABE is bound to occur.
1546
1547       if Elab_Call.Last = 0 then
1548          if Inst_Case then
1549             Error_Msg_NE
1550               ("?cannot instantiate& before body seen", N, Orig_Ent);
1551          else
1552             Error_Msg_NE
1553               ("?cannot call& before body seen", N, Orig_Ent);
1554          end if;
1555
1556          Error_Msg_N
1557            ("\?Program_Error will be raised at run time", N);
1558          Insert_Elab_Check (N);
1559
1560       --  Call is not at outer level
1561
1562       else
1563          --  Deal with dynamic elaboration check
1564
1565          if not Elaboration_Checks_Suppressed (E) then
1566             Set_Elaboration_Entity_Required (E);
1567
1568             --  Case of no elaboration entity allocated yet
1569
1570             if No (Elaboration_Entity (E)) then
1571
1572                --  Create object declaration for elaboration entity, and put it
1573                --  just in front of the spec of the subprogram or generic unit,
1574                --  in the same scope as this unit.
1575
1576                declare
1577                   Loce : constant Source_Ptr := Sloc (E);
1578                   Ent  : constant Entity_Id  :=
1579                            Make_Defining_Identifier (Loc,
1580                              Chars => New_External_Name (Chars (E), 'E'));
1581
1582                begin
1583                   Set_Elaboration_Entity (E, Ent);
1584                   New_Scope (Scope (E));
1585
1586                   Insert_Action (Declaration_Node (E),
1587                     Make_Object_Declaration (Loce,
1588                       Defining_Identifier => Ent,
1589                       Object_Definition =>
1590                         New_Occurrence_Of (Standard_Boolean, Loce),
1591                       Expression => New_Occurrence_Of (Standard_False, Loce)));
1592
1593                   --  Set elaboration flag at the point of the body
1594
1595                   Set_Elaboration_Flag (Sbody, E);
1596
1597                   --  Kill current value indication. This is necessary
1598                   --  because the tests of this flag are inserted out of
1599                   --  sequence and must not pick up bogus indications of
1600                   --  the wrong constant value. Also, this is never a true
1601                   --  constant, since one way or another, it gets reset.
1602
1603                   Set_Current_Value    (Ent, Empty);
1604                   Set_Is_True_Constant (Ent, False);
1605                   Pop_Scope;
1606                end;
1607             end if;
1608
1609             --  Generate check of the elaboration Boolean
1610
1611             Insert_Elab_Check (N,
1612               New_Occurrence_Of (Elaboration_Entity (E), Loc));
1613          end if;
1614
1615          --  Generate the warning
1616
1617          if not Suppress_Elaboration_Warnings (E)
1618            and then not Elaboration_Checks_Suppressed (E)
1619          then
1620             if Inst_Case then
1621                Error_Msg_NE
1622                  ("instantiation of& may occur before body is seen?",
1623                   N, Orig_Ent);
1624             else
1625                Error_Msg_NE
1626                  ("call to& may occur before body is seen?", N, Orig_Ent);
1627             end if;
1628
1629             Error_Msg_N
1630               ("\Program_Error may be raised at run time?", N);
1631
1632             Output_Calls (N);
1633          end if;
1634       end if;
1635
1636       --  Set flag to suppress further warnings on same subprogram
1637       --  unless in all errors mode
1638
1639       if not All_Errors_Mode then
1640          Set_Suppress_Elaboration_Warnings (E);
1641       end if;
1642    end Check_Internal_Call_Continue;
1643
1644    ---------------------------
1645    -- Check_Task_Activation --
1646    ---------------------------
1647
1648    procedure Check_Task_Activation (N : Node_Id) is
1649       Loc         : constant Source_Ptr := Sloc (N);
1650       Inter_Procs : constant Elist_Id   := New_Elmt_List;
1651       Intra_Procs : constant Elist_Id   := New_Elmt_List;
1652       Ent         : Entity_Id;
1653       P           : Entity_Id;
1654       Task_Scope  : Entity_Id;
1655       Cunit_SC    : Boolean := False;
1656       Decl        : Node_Id;
1657       Elmt        : Elmt_Id;
1658       Enclosing   : Entity_Id;
1659
1660       procedure Add_Task_Proc (Typ : Entity_Id);
1661       --  Add to Task_Procs the task body procedure(s) of task types in Typ.
1662       --  For record types, this procedure recurses over component types.
1663
1664       procedure Collect_Tasks (Decls : List_Id);
1665       --  Collect the types of the tasks that are to be activated in the given
1666       --  list of declarations, in order to perform elaboration checks on the
1667       --  corresponding task procedures which are called implicitly here.
1668
1669       function Outer_Unit (E : Entity_Id) return Entity_Id;
1670       --  find enclosing compilation unit of Entity, ignoring subunits, or
1671       --  else enclosing subprogram. If E is not a package, there is no need
1672       --  for inter-unit elaboration checks.
1673
1674       -------------------
1675       -- Add_Task_Proc --
1676       -------------------
1677
1678       procedure Add_Task_Proc (Typ : Entity_Id) is
1679          Comp : Entity_Id;
1680          Proc : Entity_Id := Empty;
1681
1682       begin
1683          if Is_Task_Type (Typ) then
1684             Proc := Get_Task_Body_Procedure (Typ);
1685
1686          elsif Is_Array_Type (Typ)
1687            and then Has_Task (Base_Type (Typ))
1688          then
1689             Add_Task_Proc (Component_Type (Typ));
1690
1691          elsif Is_Record_Type (Typ)
1692            and then Has_Task (Base_Type (Typ))
1693          then
1694             Comp := First_Component (Typ);
1695
1696             while Present (Comp) loop
1697                Add_Task_Proc (Etype (Comp));
1698                Comp := Next_Component (Comp);
1699             end loop;
1700          end if;
1701
1702          --  If the task type is another unit, we will perform the usual
1703          --  elaboration check on its enclosing unit. If the type is in the
1704          --  same unit, we can trace the task body as for an internal call,
1705          --  but we only need to examine other external calls, because at
1706          --  the point the task is activated, internal subprogram bodies
1707          --  will have been elaborated already. We keep separate lists for
1708          --  each kind of task.
1709
1710          --  Skip this test if errors have occurred, since in this case
1711          --  we can get false indications.
1712
1713          if Serious_Errors_Detected /= 0 then
1714             return;
1715          end if;
1716
1717          if Present (Proc) then
1718             if Outer_Unit (Scope (Proc)) = Enclosing then
1719
1720                if No (Corresponding_Body (Unit_Declaration_Node (Proc)))
1721                  and then
1722                    (not Is_Generic_Instance (Scope (Proc))
1723                       or else
1724                     Scope (Proc) = Scope (Defining_Identifier (Decl)))
1725                then
1726                   Error_Msg_N
1727                     ("task will be activated before elaboration of its body?",
1728                       Decl);
1729                   Error_Msg_N
1730                     ("Program_Error will be raised at run-time?", Decl);
1731
1732                elsif
1733                  Present (Corresponding_Body (Unit_Declaration_Node (Proc)))
1734                then
1735                   Append_Elmt (Proc, Intra_Procs);
1736                end if;
1737
1738             else
1739                Elmt := First_Elmt (Inter_Procs);
1740
1741                --  No need for multiple entries of the same type.
1742
1743                while Present (Elmt) loop
1744                   if Node (Elmt) = Proc then
1745                      return;
1746                   end if;
1747
1748                   Next_Elmt (Elmt);
1749                end loop;
1750
1751                Append_Elmt (Proc, Inter_Procs);
1752             end if;
1753          end if;
1754       end Add_Task_Proc;
1755
1756       -------------------
1757       -- Collect_Tasks --
1758       -------------------
1759
1760       procedure Collect_Tasks (Decls : List_Id) is
1761       begin
1762          if Present (Decls) then
1763             Decl := First (Decls);
1764
1765             while Present (Decl) loop
1766
1767                if Nkind (Decl) = N_Object_Declaration
1768                  and then Has_Task (Etype (Defining_Identifier (Decl)))
1769                then
1770                   Add_Task_Proc (Etype (Defining_Identifier (Decl)));
1771                end if;
1772
1773                Next (Decl);
1774             end loop;
1775          end if;
1776       end Collect_Tasks;
1777
1778       ----------------
1779       -- Outer_Unit --
1780       ----------------
1781
1782       function Outer_Unit (E : Entity_Id) return Entity_Id is
1783          Outer : Entity_Id := E;
1784
1785       begin
1786          while Present (Outer) loop
1787             if Elaboration_Checks_Suppressed (Outer) then
1788                Cunit_SC := True;
1789             end if;
1790
1791             exit when Is_Child_Unit (Outer)
1792               or else Scope (Outer) = Standard_Standard
1793               or else Ekind (Outer) /= E_Package;
1794             Outer := Scope (Outer);
1795          end loop;
1796
1797          return Outer;
1798       end Outer_Unit;
1799
1800    --  Start of processing for Check_Task_Activation
1801
1802    begin
1803       Enclosing := Outer_Unit (Current_Scope);
1804
1805       --  Find all tasks declared in the current unit.
1806
1807       if Nkind (N) = N_Package_Body then
1808          P := Unit_Declaration_Node (Corresponding_Spec (N));
1809
1810          Collect_Tasks (Declarations (N));
1811          Collect_Tasks (Visible_Declarations (Specification (P)));
1812          Collect_Tasks (Private_Declarations (Specification (P)));
1813
1814       elsif Nkind (N) = N_Package_Declaration then
1815          Collect_Tasks (Visible_Declarations (Specification (N)));
1816          Collect_Tasks (Private_Declarations (Specification (N)));
1817
1818       else
1819          Collect_Tasks (Declarations (N));
1820       end if;
1821
1822       --  We only perform detailed checks in all tasks are library level
1823       --  entities. If the master is a subprogram or task, activation will
1824       --  depend on the activation of the master itself.
1825       --  Should dynamic checks be added in the more general case???
1826
1827       if Ekind (Enclosing) /= E_Package then
1828          return;
1829       end if;
1830
1831       --  For task types defined in other units, we want the unit containing
1832       --  the task body to be elaborated before the current one.
1833
1834       Elmt := First_Elmt (Inter_Procs);
1835
1836       while Present (Elmt) loop
1837          Ent := Node (Elmt);
1838          Task_Scope := Outer_Unit (Scope (Ent));
1839
1840          if not Is_Compilation_Unit (Task_Scope) then
1841             null;
1842
1843          elsif Suppress_Elaboration_Warnings (Task_Scope)
1844            or else Elaboration_Checks_Suppressed (Task_Scope)
1845          then
1846             null;
1847
1848          elsif Dynamic_Elaboration_Checks then
1849             if not Elaboration_Checks_Suppressed (Ent)
1850               and then not Cunit_SC
1851               and then not Restrictions (No_Entry_Calls_In_Elaboration_Code)
1852             then
1853                --  Runtime elaboration check required. generate check of the
1854                --  elaboration Boolean for the unit containing the entity.
1855
1856                Insert_Elab_Check (N,
1857                  Make_Attribute_Reference (Loc,
1858                    Attribute_Name => Name_Elaborated,
1859                    Prefix =>
1860                      New_Occurrence_Of
1861                        (Spec_Entity (Task_Scope), Loc)));
1862             end if;
1863
1864          else
1865             --  Force the binder to elaborate other unit first
1866
1867             if not Suppress_Elaboration_Warnings (Ent)
1868               and then not Elaboration_Checks_Suppressed (Ent)
1869               and then Elab_Warnings
1870               and then not Suppress_Elaboration_Warnings (Task_Scope)
1871               and then not Elaboration_Checks_Suppressed (Task_Scope)
1872             then
1873                Error_Msg_Node_2 := Task_Scope;
1874                Error_Msg_NE ("activation of an instance of task type&" &
1875                   " requires pragma Elaborate_All on &?", N, Ent);
1876             end if;
1877
1878             Set_Elaborate_All_Desirable (Task_Scope);
1879             Set_Suppress_Elaboration_Warnings (Task_Scope);
1880          end if;
1881
1882          Next_Elmt (Elmt);
1883       end loop;
1884
1885       --  For tasks declared in the current unit, trace other calls within
1886       --  the task procedure bodies, which are available.
1887
1888       In_Task_Activation := True;
1889       Elmt := First_Elmt (Intra_Procs);
1890
1891       while Present (Elmt) loop
1892          Ent := Node (Elmt);
1893          Check_Internal_Call_Continue (N, Ent, Enclosing, Ent);
1894          Next_Elmt (Elmt);
1895       end loop;
1896
1897       In_Task_Activation := False;
1898    end Check_Task_Activation;
1899
1900    ----------------------
1901    -- Has_Generic_Body --
1902    ----------------------
1903
1904    function Has_Generic_Body (N : Node_Id) return Boolean is
1905       Ent  : constant Entity_Id := Get_Generic_Entity (N);
1906       Decl : constant Node_Id   := Unit_Declaration_Node (Ent);
1907       Scop : Entity_Id;
1908
1909       function Find_Body_In (E : Entity_Id; N : Node_Id) return Node_Id;
1910       --  Determine if the list of nodes headed by N and linked by Next
1911       --  contains a package body for the package spec entity E, and if
1912       --  so return the package body. If not, then returns Empty.
1913
1914       function Load_Package_Body (Nam : Unit_Name_Type) return Node_Id;
1915       --  This procedure is called load the unit whose name is given by Nam.
1916       --  This unit is being loaded to see whether it contains an optional
1917       --  generic body. The returned value is the loaded unit, which is
1918       --  always a package body (only package bodies can contain other
1919       --  entities in the sense in which Has_Generic_Body is interested).
1920       --  We only attempt to load bodies if we are generating code. If we
1921       --  are in semantics check only mode, then it would be wrong to load
1922       --  bodies that are not required from a semantic point of view, so
1923       --  in this case we return Empty. The result is that the caller may
1924       --  incorrectly decide that a generic spec does not have a body when
1925       --  in fact it does, but the only harm in this is that some warnings
1926       --  on elaboration problems may be lost in semantic checks only mode,
1927       --  which is not big loss. We also return Empty if we go for a body
1928       --  and it is not there.
1929
1930       function Locate_Corresponding_Body (PE : Entity_Id) return Node_Id;
1931       --  PE is the entity for a package spec. This function locates the
1932       --  corresponding package body, returning Empty if none is found.
1933       --  The package body returned is fully parsed but may not yet be
1934       --  analyzed, so only syntactic fields should be referenced.
1935
1936       ------------------
1937       -- Find_Body_In --
1938       ------------------
1939
1940       function Find_Body_In (E : Entity_Id; N : Node_Id) return Node_Id is
1941          Nod : Node_Id;
1942
1943       begin
1944          Nod := N;
1945          while Present (Nod) loop
1946
1947             --  If we found the package body we are looking for, return it
1948
1949             if Nkind (Nod) = N_Package_Body
1950               and then Chars (Defining_Unit_Name (Nod)) = Chars (E)
1951             then
1952                return Nod;
1953
1954             --  If we found the stub for the body, go after the subunit,
1955             --  loading it if necessary.
1956
1957             elsif Nkind (Nod) = N_Package_Body_Stub
1958               and then Chars (Defining_Identifier (Nod)) = Chars (E)
1959             then
1960                if Present (Library_Unit (Nod)) then
1961                   return Unit (Library_Unit (Nod));
1962
1963                else
1964                   return Load_Package_Body (Get_Unit_Name (Nod));
1965                end if;
1966
1967             --  If neither package body nor stub, keep looking on chain
1968
1969             else
1970                Next (Nod);
1971             end if;
1972          end loop;
1973
1974          return Empty;
1975       end Find_Body_In;
1976
1977       -----------------------
1978       -- Load_Package_Body --
1979       -----------------------
1980
1981       function Load_Package_Body (Nam : Unit_Name_Type) return Node_Id is
1982          U : Unit_Number_Type;
1983
1984       begin
1985          if Operating_Mode /= Generate_Code then
1986             return Empty;
1987          else
1988             U :=
1989               Load_Unit
1990                 (Load_Name  => Nam,
1991                  Required   => False,
1992                  Subunit    => False,
1993                  Error_Node => N);
1994
1995             if U = No_Unit then
1996                return Empty;
1997             else
1998                return Unit (Cunit (U));
1999             end if;
2000          end if;
2001       end Load_Package_Body;
2002
2003       -------------------------------
2004       -- Locate_Corresponding_Body --
2005       -------------------------------
2006
2007       function Locate_Corresponding_Body (PE : Entity_Id) return Node_Id is
2008          Spec  : constant Node_Id   := Declaration_Node (PE);
2009          Decl  : constant Node_Id   := Parent (Spec);
2010          Scop  : constant Entity_Id := Scope (PE);
2011          PBody : Node_Id;
2012
2013       begin
2014          if Is_Library_Level_Entity (PE) then
2015
2016             --  If package is a library unit that requires a body, we have
2017             --  no choice but to go after that body because it might contain
2018             --  an optional body for the original generic package.
2019
2020             if Unit_Requires_Body (PE) then
2021
2022                --  Load the body. Note that we are a little careful here to
2023                --  use Spec to get the unit number, rather than PE or Decl,
2024                --  since in the case where the package is itself a library
2025                --  level instantiation, Spec will properly reference the
2026                --  generic template, which is what we really want.
2027
2028                return
2029                  Load_Package_Body
2030                    (Get_Body_Name (Unit_Name (Get_Source_Unit (Spec))));
2031
2032             --  But if the package is a library unit that does NOT require
2033             --  a body, then no body is permitted, so we are sure that there
2034             --  is no body for the original generic package.
2035
2036             else
2037                return Empty;
2038             end if;
2039
2040          --  Otherwise look and see if we are embedded in a further package
2041
2042          elsif Is_Package (Scop) then
2043
2044             --  If so, get the body of the enclosing package, and look in
2045             --  its package body for the package body we are looking for.
2046
2047             PBody := Locate_Corresponding_Body (Scop);
2048
2049             if No (PBody) then
2050                return Empty;
2051             else
2052                return Find_Body_In (PE, First (Declarations (PBody)));
2053             end if;
2054
2055          --  If we are not embedded in a further package, then the body
2056          --  must be in the same declarative part as we are.
2057
2058          else
2059             return Find_Body_In (PE, Next (Decl));
2060          end if;
2061       end Locate_Corresponding_Body;
2062
2063    --  Start of processing for Has_Generic_Body
2064
2065    begin
2066       if Present (Corresponding_Body (Decl)) then
2067          return True;
2068
2069       elsif Unit_Requires_Body (Ent) then
2070          return True;
2071
2072       --  Compilation units cannot have optional bodies
2073
2074       elsif Is_Compilation_Unit (Ent) then
2075          return False;
2076
2077       --  Otherwise look at what scope we are in
2078
2079       else
2080          Scop := Scope (Ent);
2081
2082          --  Case of entity is in other than a package spec, in this case
2083          --  the body, if present, must be in the same declarative part.
2084
2085          if not Is_Package (Scop) then
2086             declare
2087                P : Node_Id;
2088
2089             begin
2090                P := Declaration_Node (Ent);
2091
2092                --  Declaration node may get us a spec, so if so, go to
2093                --  the parent declaration.
2094
2095                while not Is_List_Member (P) loop
2096                   P := Parent (P);
2097                end loop;
2098
2099                return Present (Find_Body_In (Ent, Next (P)));
2100             end;
2101
2102          --  If the entity is in a package spec, then we have to locate
2103          --  the corresponding package body, and look there.
2104
2105          else
2106             declare
2107                PBody : constant Node_Id := Locate_Corresponding_Body (Scop);
2108
2109             begin
2110                if No (PBody) then
2111                   return False;
2112                else
2113                   return
2114                     Present
2115                       (Find_Body_In (Ent, (First (Declarations (PBody)))));
2116                end if;
2117             end;
2118          end if;
2119       end if;
2120    end Has_Generic_Body;
2121
2122    -----------------------
2123    -- Insert_Elab_Check --
2124    -----------------------
2125
2126    procedure Insert_Elab_Check (N : Node_Id; C : Node_Id := Empty) is
2127       Nod : Node_Id;
2128       Loc : constant Source_Ptr := Sloc (N);
2129
2130    begin
2131       --  If expansion is disabled, do not generate any checks. Also
2132       --  skip checks if any subunits are missing because in either
2133       --  case we lack the full information that we need, and no object
2134       --  file will be created in any case.
2135
2136       if not Expander_Active or else Subunits_Missing then
2137          return;
2138       end if;
2139
2140       --  If we have a generic instantiation, where Instance_Spec is set,
2141       --  then this field points to a generic instance spec that has
2142       --  been inserted before the instantiation node itself, so that
2143       --  is where we want to insert a check.
2144
2145       if Nkind (N) in N_Generic_Instantiation
2146         and then Present (Instance_Spec (N))
2147       then
2148          Nod := Instance_Spec (N);
2149       else
2150          Nod := N;
2151       end if;
2152
2153       --  If we are inserting at the top level, insert in Aux_Decls
2154
2155       if Nkind (Parent (Nod)) = N_Compilation_Unit then
2156          declare
2157             ADN : constant Node_Id := Aux_Decls_Node (Parent (Nod));
2158             R   : Node_Id;
2159
2160          begin
2161             if No (C) then
2162                R :=
2163                  Make_Raise_Program_Error (Loc,
2164                    Reason => PE_Access_Before_Elaboration);
2165             else
2166                R :=
2167                  Make_Raise_Program_Error (Loc,
2168                    Condition => Make_Op_Not (Loc, C),
2169                    Reason    => PE_Access_Before_Elaboration);
2170             end if;
2171
2172             if No (Declarations (ADN)) then
2173                Set_Declarations (ADN, New_List (R));
2174             else
2175                Append_To (Declarations (ADN), R);
2176             end if;
2177
2178             Analyze (R);
2179          end;
2180
2181       --  Otherwise just insert before the node in question. However, if
2182       --  the context of the call has already been analyzed, an insertion
2183       --  will not work if it depends on subsequent expansion (e.g. a call in
2184       --  a branch of a short-circuit). In that case we replace the call with
2185       --  a conditional expression, or with a Raise if it is unconditional.
2186       --  Unfortunately this does not work if the call has a dynamic size,
2187       --  because gigi regards it as a dynamic-sized temporary. If such a call
2188       --  appears in a short-circuit expression, the elaboration check will be
2189       --  missed (rare enough ???). Otherwise, the code below inserts the check
2190       --  at the appropriate place before the call. Same applies in the even
2191       --  rarer case the return type has a known size but is unconstrained.
2192
2193       else
2194          if Nkind (N) = N_Function_Call
2195            and then Analyzed (Parent (N))
2196            and then Size_Known_At_Compile_Time (Etype (N))
2197            and then
2198             (not Has_Discriminants (Etype (N))
2199               or else Is_Constrained (Etype (N)))
2200
2201          then
2202             declare
2203                Typ : constant Entity_Id := Etype (N);
2204                Chk : constant Boolean   := Do_Range_Check (N);
2205
2206                R   : constant Node_Id :=
2207                        Make_Raise_Program_Error (Loc,
2208                          Reason => PE_Access_Before_Elaboration);
2209
2210             begin
2211                Set_Etype (R, Typ);
2212
2213                if No (C) then
2214                   Rewrite (N, R);
2215
2216                else
2217                   Rewrite (N,
2218                     Make_Conditional_Expression (Loc,
2219                       Expressions => New_List (C, Relocate_Node (N), R)));
2220                end if;
2221
2222                Analyze_And_Resolve (N, Typ);
2223
2224                --  If the original call requires a range check, so does the
2225                --  conditional expression.
2226
2227                if Chk then
2228                   Enable_Range_Check (N);
2229                else
2230                   Set_Do_Range_Check (N, False);
2231                end if;
2232             end;
2233
2234          else
2235             if No (C) then
2236                Insert_Action (Nod,
2237                   Make_Raise_Program_Error (Loc,
2238                     Reason => PE_Access_Before_Elaboration));
2239             else
2240                Insert_Action (Nod,
2241                   Make_Raise_Program_Error (Loc,
2242                     Condition =>
2243                       Make_Op_Not (Loc,
2244                         Right_Opnd => C),
2245                     Reason => PE_Access_Before_Elaboration));
2246             end if;
2247          end if;
2248       end if;
2249    end Insert_Elab_Check;
2250
2251    ------------------
2252    -- Output_Calls --
2253    ------------------
2254
2255    procedure Output_Calls (N : Node_Id) is
2256       Ent : Entity_Id;
2257
2258       function Is_Printable_Error_Name (Nm : Name_Id) return Boolean;
2259       --  An internal function, used to determine if a name, Nm, is either
2260       --  a non-internal name, or is an internal name that is printable
2261       --  by the error message circuits (i.e. it has a single upper
2262       --  case letter at the end).
2263
2264       function Is_Printable_Error_Name (Nm : Name_Id) return Boolean is
2265       begin
2266          if not Is_Internal_Name (Nm) then
2267             return True;
2268
2269          elsif Name_Len = 1 then
2270             return False;
2271
2272          else
2273             Name_Len := Name_Len - 1;
2274             return not Is_Internal_Name;
2275          end if;
2276       end Is_Printable_Error_Name;
2277
2278    --  Start of processing for Output_Calls
2279
2280    begin
2281       for J in reverse 1 .. Elab_Call.Last loop
2282          Error_Msg_Sloc := Elab_Call.Table (J).Cloc;
2283
2284          Ent := Elab_Call.Table (J).Ent;
2285
2286          if Is_Generic_Unit (Ent) then
2287             Error_Msg_NE ("\?& instantiated #", N, Ent);
2288
2289          elsif Is_Init_Proc (Ent) then
2290             Error_Msg_N ("\?initialization procedure called #", N);
2291
2292          elsif Is_Printable_Error_Name (Chars (Ent)) then
2293             Error_Msg_NE ("\?& called #", N, Ent);
2294
2295          else
2296             Error_Msg_N ("\? called #", N);
2297          end if;
2298       end loop;
2299    end Output_Calls;
2300
2301    ----------------------------
2302    -- Same_Elaboration_Scope --
2303    ----------------------------
2304
2305    function Same_Elaboration_Scope (Scop1, Scop2 : Entity_Id) return Boolean is
2306       S1 : Entity_Id := Scop1;
2307       S2 : Entity_Id := Scop2;
2308
2309    begin
2310       while S1 /= Standard_Standard
2311         and then (Ekind (S1) = E_Package
2312                     or else
2313                   Ekind (S1) = E_Block)
2314       loop
2315          S1 := Scope (S1);
2316       end loop;
2317
2318       while S2 /= Standard_Standard
2319         and then (Ekind (S2) = E_Package
2320                     or else
2321                   Ekind (S2) = E_Protected_Type
2322                     or else
2323                   Ekind (S2) = E_Block)
2324       loop
2325          S2 := Scope (S2);
2326       end loop;
2327
2328       return S1 = S2;
2329    end Same_Elaboration_Scope;
2330
2331    -----------------
2332    -- Set_C_Scope --
2333    -----------------
2334
2335    procedure Set_C_Scope is
2336    begin
2337       while not Is_Compilation_Unit (C_Scope) loop
2338          C_Scope := Scope (C_Scope);
2339       end loop;
2340    end Set_C_Scope;
2341
2342    -----------------
2343    -- Spec_Entity --
2344    -----------------
2345
2346    function Spec_Entity (E : Entity_Id) return Entity_Id is
2347       Decl : Node_Id;
2348
2349    begin
2350       --  Check for case of body entity
2351       --  Why is the check for E_Void needed???
2352
2353       if Ekind (E) = E_Void
2354         or else Ekind (E) = E_Subprogram_Body
2355         or else Ekind (E) = E_Package_Body
2356       then
2357          Decl := E;
2358
2359          loop
2360             Decl := Parent (Decl);
2361             exit when Nkind (Decl) in N_Proper_Body;
2362          end loop;
2363
2364          return Corresponding_Spec (Decl);
2365
2366       else
2367          return E;
2368       end if;
2369    end Spec_Entity;
2370
2371    -------------------
2372    -- Supply_Bodies --
2373    -------------------
2374
2375    procedure Supply_Bodies (N : Node_Id) is
2376    begin
2377       if Nkind (N) = N_Subprogram_Declaration then
2378          declare
2379             Ent : constant Entity_Id := Defining_Unit_Name (Specification (N));
2380
2381          begin
2382             Set_Is_Imported (Ent);
2383             Set_Convention  (Ent, Convention_Stubbed);
2384          end;
2385
2386       elsif Nkind (N) = N_Package_Declaration then
2387          declare
2388             Spec : constant Node_Id := Specification (N);
2389
2390          begin
2391             New_Scope (Defining_Unit_Name (Spec));
2392             Supply_Bodies (Visible_Declarations (Spec));
2393             Supply_Bodies (Private_Declarations (Spec));
2394             Pop_Scope;
2395          end;
2396       end if;
2397    end Supply_Bodies;
2398
2399    procedure Supply_Bodies (L : List_Id) is
2400       Elmt : Node_Id;
2401
2402    begin
2403       if Present (L) then
2404          Elmt := First (L);
2405          while Present (Elmt) loop
2406             Supply_Bodies (Elmt);
2407             Next (Elmt);
2408          end loop;
2409       end if;
2410    end Supply_Bodies;
2411
2412    ------------
2413    -- Within --
2414    ------------
2415
2416    function Within (E1, E2 : Entity_Id) return Boolean is
2417       Scop : Entity_Id;
2418
2419    begin
2420       Scop := E1;
2421
2422       loop
2423          if Scop = E2 then
2424             return True;
2425
2426          elsif Scop = Standard_Standard then
2427             return False;
2428
2429          else
2430             Scop := Scope (Scop);
2431          end if;
2432       end loop;
2433
2434       raise Program_Error;
2435    end Within;
2436
2437    --------------------------
2438    -- Within_Elaborate_All --
2439    --------------------------
2440
2441    function Within_Elaborate_All (E : Entity_Id) return Boolean is
2442       Item    : Node_Id;
2443       Item2   : Node_Id;
2444       Elab_Id : Entity_Id;
2445       Par     : Node_Id;
2446
2447    begin
2448       Item := First (Context_Items (Cunit (Current_Sem_Unit)));
2449
2450       while Present (Item) loop
2451          if Nkind (Item) = N_Pragma
2452            and then Get_Pragma_Id (Chars (Item)) = Pragma_Elaborate_All
2453          then
2454             if Error_Posted (Item) then
2455
2456                --  Some previous error on the pragma itself
2457
2458                return False;
2459             end if;
2460
2461             Elab_Id :=
2462               Entity (
2463                 Expression (First (Pragma_Argument_Associations (Item))));
2464
2465             Par   := Parent (Unit_Declaration_Node (Elab_Id));
2466             Item2 := First (Context_Items (Par));
2467
2468             while Present (Item2) loop
2469                if Nkind (Item2) = N_With_Clause
2470                  and then Entity (Name (Item2)) = E
2471                then
2472                   return True;
2473                end if;
2474
2475                Next (Item2);
2476             end loop;
2477          end if;
2478
2479          Next (Item);
2480       end loop;
2481
2482       return False;
2483    end Within_Elaborate_All;
2484
2485 end Sem_Elab;