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