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