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