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