OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [sem_elab.adb] - Blame information for rev 706

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 706 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT COMPILER COMPONENTS                         --
4
--                                                                          --
5
--                             S E M _ E L A B                              --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 1997-2011, Free Software Foundation, Inc.         --
10
--                                                                          --
11
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
12
-- terms of the  GNU General Public License as published  by the Free Soft- --
13
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
14
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
15
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
16
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
17
-- for  more details.  You should have  received  a copy of the GNU General --
18
-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
19
-- http://www.gnu.org/licenses for a complete copy of the license.          --
20
--                                                                          --
21
-- GNAT was originally developed  by the GNAT team at  New York University. --
22
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
23
--                                                                          --
24
------------------------------------------------------------------------------
25
 
26
with Atree;    use Atree;
27
with Checks;   use Checks;
28
with Debug;    use Debug;
29
with Einfo;    use Einfo;
30
with Elists;   use Elists;
31
with Errout;   use Errout;
32
with Exp_Tss;  use Exp_Tss;
33
with Exp_Util; use Exp_Util;
34
with Expander; use Expander;
35
with Fname;    use Fname;
36
with Lib;      use Lib;
37
with Lib.Load; use Lib.Load;
38
with Namet;    use Namet;
39
with Nlists;   use Nlists;
40
with Nmake;    use Nmake;
41
with Opt;      use Opt;
42
with Output;   use Output;
43
with Restrict; use Restrict;
44
with Rident;   use Rident;
45
with Sem;      use Sem;
46
with Sem_Aux;  use Sem_Aux;
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_Type; use Sem_Type;
52
with Sem_Util; use Sem_Util;
53
with Sinfo;    use Sinfo;
54
with Sinput;   use Sinput;
55
with Snames;   use Snames;
56
with Stand;    use Stand;
57
with Table;
58
with Tbuild;   use Tbuild;
59
with Uintp;    use Uintp;
60
with Uname;    use Uname;
61
 
62
package body Sem_Elab is
63
 
64
   --  The following table records the recursive call chain for output in the
65
   --  Output routine. Each entry records the call node and the entity of the
66
   --  called routine. The number of entries in the table (i.e. the value of
67
   --  Elab_Call.Last) indicates the current depth of recursion and is used to
68
   --  identify the outer level.
69
 
70
   type Elab_Call_Entry is record
71
      Cloc : Source_Ptr;
72
      Ent  : Entity_Id;
73
   end record;
74
 
75
   package Elab_Call is new Table.Table (
76
     Table_Component_Type => Elab_Call_Entry,
77
     Table_Index_Type     => Int,
78
     Table_Low_Bound      => 1,
79
     Table_Initial        => 50,
80
     Table_Increment      => 100,
81
     Table_Name           => "Elab_Call");
82
 
83
   --  This table is initialized at the start of each outer level call. It
84
   --  holds the entities for all subprograms that have been examined for this
85
   --  particular outer level call, and is used to prevent both infinite
86
   --  recursion, and useless reanalysis of bodies already seen
87
 
88
   package Elab_Visited is new Table.Table (
89
     Table_Component_Type => Entity_Id,
90
     Table_Index_Type     => Int,
91
     Table_Low_Bound      => 1,
92
     Table_Initial        => 200,
93
     Table_Increment      => 100,
94
     Table_Name           => "Elab_Visited");
95
 
96
   --  This table stores calls to Check_Internal_Call that are delayed
97
   --  until all generics are instantiated, and in particular that all
98
   --  generic bodies have been inserted. We need to delay, because we
99
   --  need to be able to look through the inserted bodies.
100
 
101
   type Delay_Element is record
102
      N : Node_Id;
103
      --  The parameter N from the call to Check_Internal_Call. Note that
104
      --  this node may get rewritten over the delay period by expansion
105
      --  in the call case (but not in the instantiation case).
106
 
107
      E : Entity_Id;
108
      --  The parameter E from the call to Check_Internal_Call
109
 
110
      Orig_Ent : Entity_Id;
111
      --  The parameter Orig_Ent from the call to Check_Internal_Call
112
 
113
      Curscop : Entity_Id;
114
      --  The current scope of the call. This is restored when we complete
115
      --  the delayed call, so that we do this in the right scope.
116
 
117
      From_Elab_Code : Boolean;
118
      --  Save indication of whether this call is from elaboration code
119
 
120
      Outer_Scope : Entity_Id;
121
      --  Save scope of outer level call
122
   end record;
123
 
124
   package Delay_Check is new Table.Table (
125
     Table_Component_Type => Delay_Element,
126
     Table_Index_Type     => Int,
127
     Table_Low_Bound      => 1,
128
     Table_Initial        => 1000,
129
     Table_Increment      => 100,
130
     Table_Name           => "Delay_Check");
131
 
132
   C_Scope : Entity_Id;
133
   --  Top level scope of current scope. Compute this only once at the outer
134
   --  level, i.e. for a call to Check_Elab_Call from 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 called,
155
   --  the delay table is used to make the delayed calls and this flag is reset
156
   --  to False, so that the calls are processed
157
 
158
   -----------------------
159
   -- Local Subprograms --
160
   -----------------------
161
 
162
   --  Note: Outer_Scope in all following specs 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 Activate_Elaborate_All_Desirable (N : Node_Id; U : Entity_Id);
170
   --  Analysis of construct N shows that we should set Elaborate_All_Desirable
171
   --  for the WITH clause for unit U (which will always be present). A special
172
   --  case is when N is a function or procedure instantiation, in which case
173
   --  it is sufficient to set Elaborate_Desirable, since in this case there is
174
   --  no possibility of transitive elaboration issues.
175
 
176
   procedure Check_A_Call
177
     (N                 : Node_Id;
178
      E                 : Entity_Id;
179
      Outer_Scope       : Entity_Id;
180
      Inter_Unit_Only   : Boolean;
181
      Generate_Warnings : Boolean := True;
182
      In_Init_Proc      : Boolean := False);
183
   --  This is the internal recursive routine that is called to check for a
184
   --  possible elaboration error. The argument N is a subprogram call or
185
   --  generic instantiation to be checked, and E is the entity of the called
186
   --  subprogram, or instantiated generic unit. The flag Outer_Scope is the
187
   --  outer level scope for the original call. Inter_Unit_Only is set if the
188
   --  call is only to be checked in the case where it is to another unit (and
189
   --  skipped if within a unit). Generate_Warnings is set to False to suppress
190
   --  warning messages about missing pragma Elaborate_All's. These messages
191
   --  are not wanted for inner calls in the dynamic model. Flag In_Init_Proc
192
   --  should be set whenever the current context is a type init proc.
193
 
194
   procedure Check_Bad_Instantiation (N : Node_Id);
195
   --  N is a node for an instantiation (if called with any other node kind,
196
   --  Check_Bad_Instantiation ignores the call). This subprogram checks for
197
   --  the special case of a generic instantiation of a generic spec in the
198
   --  same declarative part as the instantiation where a body is present and
199
   --  has not yet been seen. This is an obvious error, but needs to be checked
200
   --  specially at the time of the instantiation, since it is a case where we
201
   --  cannot insert the body anywhere. If this case is detected, warnings are
202
   --  generated, and a raise of Program_Error is inserted. In addition any
203
   --  subprograms in the generic spec are stubbed, and the Bad_Instantiation
204
   --  flag is set on the instantiation node. The caller in Sem_Ch12 uses this
205
   --  flag as an indication that no attempt should be made to insert an
206
   --  instance body.
207
 
208
   procedure Check_Internal_Call
209
     (N           : Node_Id;
210
      E           : Entity_Id;
211
      Outer_Scope : Entity_Id;
212
      Orig_Ent    : Entity_Id);
213
   --  N is a function call or procedure statement call node and E is the
214
   --  entity of the called function, which is within the current compilation
215
   --  unit (where subunits count as part of the parent). This call checks if
216
   --  this call, or any call within any accessed body could cause an ABE, and
217
   --  if so, outputs a warning. Orig_Ent differs from E only in the case of
218
   --  renamings, and points to the original name of the entity. This is used
219
   --  for error messages. Outer_Scope is the outer level scope for the
220
   --  original call.
221
 
222
   procedure Check_Internal_Call_Continue
223
     (N           : Node_Id;
224
      E           : Entity_Id;
225
      Outer_Scope : Entity_Id;
226
      Orig_Ent    : Entity_Id);
227
   --  The processing for Check_Internal_Call is divided up into two phases,
228
   --  and this represents the second phase. The second phase is delayed if
229
   --  Delaying_Elab_Calls is set to True. In this delayed case, the first
230
   --  phase makes an entry in the Delay_Check table, which is processed when
231
   --  Check_Elab_Calls is called. N, E and Orig_Ent are as for the call to
232
   --  Check_Internal_Call. Outer_Scope is the outer level scope for the
233
   --  original call.
234
 
235
   function Has_Generic_Body (N : Node_Id) return Boolean;
236
   --  N is a generic package instantiation node, and this routine determines
237
   --  if this package spec does in fact have a generic body. If so, then
238
   --  True is returned, otherwise False. Note that this is not at all the
239
   --  same as checking if the unit requires a body, since it deals with
240
   --  the case of optional bodies accurately (i.e. if a body is optional,
241
   --  then it looks to see if a body is actually present). Note: this
242
   --  function can only do a fully correct job if in generating code mode
243
   --  where all bodies have to be present. If we are operating in semantics
244
   --  check only mode, then in some cases of optional bodies, a result of
245
   --  False may incorrectly be given. In practice this simply means that
246
   --  some cases of warnings for incorrect order of elaboration will only
247
   --  be given when generating code, which is not a big problem (and is
248
   --  inevitable, given the optional body semantics of Ada).
249
 
250
   procedure Insert_Elab_Check (N : Node_Id; C : Node_Id := Empty);
251
   --  Given code for an elaboration check (or unconditional raise if the check
252
   --  is not needed), inserts the code in the appropriate place. N is the call
253
   --  or instantiation node for which the check code is required. C is the
254
   --  test whose failure triggers the raise.
255
 
256
   function Is_Finalization_Procedure (Id : Entity_Id) return Boolean;
257
   --  Determine whether entity Id denotes a [Deep_]Finalize procedure
258
 
259
   procedure Output_Calls (N : Node_Id);
260
   --  Outputs chain of calls stored in the Elab_Call table. The caller has
261
   --  already generated the main warning message, so the warnings generated
262
   --  are all continuation messages. The argument is the call node at which
263
   --  the messages are to be placed.
264
 
265
   function Same_Elaboration_Scope (Scop1, Scop2 : Entity_Id) return Boolean;
266
   --  Given two scopes, determine whether they are the same scope from an
267
   --  elaboration point of view, i.e. packages and blocks are ignored.
268
 
269
   procedure Set_C_Scope;
270
   --  On entry C_Scope is set to some scope. On return, C_Scope is reset
271
   --  to be the enclosing compilation unit of this scope.
272
 
273
   procedure Set_Elaboration_Constraint
274
    (Call : Node_Id;
275
     Subp : Entity_Id;
276
     Scop : Entity_Id);
277
   --  The current unit U may depend semantically on some unit P which is not
278
   --  in the current context. If there is an elaboration call that reaches P,
279
   --  we need to indicate that P requires an Elaborate_All, but this is not
280
   --  effective in U's ali file, if there is no with_clause for P. In this
281
   --  case we add the Elaborate_All on the unit Q that directly or indirectly
282
   --  makes P available. This can happen in two cases:
283
   --
284
   --    a) Q declares a subtype of a type declared in P, and the call is an
285
   --    initialization call for an object of that subtype.
286
   --
287
   --    b) Q declares an object of some tagged type whose root type is
288
   --    declared in P, and the initialization call uses object notation on
289
   --    that object to reach a primitive operation or a classwide operation
290
   --    declared in P.
291
   --
292
   --  If P appears in the context of U, the current processing is correct.
293
   --  Otherwise we must identify these two cases to retrieve Q and place the
294
   --  Elaborate_All_Desirable on it.
295
 
296
   function Spec_Entity (E : Entity_Id) return Entity_Id;
297
   --  Given a compilation unit entity, if it is a spec entity, it is returned
298
   --  unchanged. If it is a body entity, then the spec for the corresponding
299
   --  spec is returned
300
 
301
   procedure Supply_Bodies (N : Node_Id);
302
   --  Given a node, N, that is either a subprogram declaration or a package
303
   --  declaration, this procedure supplies dummy bodies for the subprogram
304
   --  or for all subprograms in the package. If the given node is not one
305
   --  of these two possibilities, then Supply_Bodies does nothing. The
306
   --  dummy body contains a single Raise statement.
307
 
308
   procedure Supply_Bodies (L : List_Id);
309
   --  Calls Supply_Bodies for all elements of the given list L
310
 
311
   function Within (E1, E2 : Entity_Id) return Boolean;
312
   --  Given two scopes E1 and E2, returns True if E1 is equal to E2, or is one
313
   --  of its contained scopes, False otherwise.
314
 
315
   function Within_Elaborate_All (E : Entity_Id) return Boolean;
316
   --  Before emitting a warning on a scope E for a missing elaborate_all,
317
   --  check whether E may be in the context of a directly visible unit U to
318
   --  which the pragma applies. This prevents spurious warnings when the
319
   --  called entity is renamed within U.
320
 
321
   --------------------------------------
322
   -- Activate_Elaborate_All_Desirable --
323
   --------------------------------------
324
 
325
   procedure Activate_Elaborate_All_Desirable (N : Node_Id; U : Entity_Id) is
326
      UN  : constant Unit_Number_Type := Get_Code_Unit (N);
327
      CU  : constant Node_Id          := Cunit (UN);
328
      UE  : constant Entity_Id        := Cunit_Entity (UN);
329
      Unm : constant Unit_Name_Type   := Unit_Name (UN);
330
      CI  : constant List_Id          := Context_Items (CU);
331
      Itm : Node_Id;
332
      Ent : Entity_Id;
333
 
334
      procedure Add_To_Context_And_Mark (Itm : Node_Id);
335
      --  This procedure is called when the elaborate indication must be
336
      --  applied to a unit not in the context of the referencing unit. The
337
      --  unit gets added to the context as an implicit with.
338
 
339
      function In_Withs_Of (UEs : Entity_Id) return Boolean;
340
      --  UEs is the spec entity of a unit. If the unit to be marked is
341
      --  in the context item list of this unit spec, then the call returns
342
      --  True and Itm is left set to point to the relevant N_With_Clause node.
343
 
344
      procedure Set_Elab_Flag (Itm : Node_Id);
345
      --  Sets Elaborate_[All_]Desirable as appropriate on Itm
346
 
347
      -----------------------------
348
      -- Add_To_Context_And_Mark --
349
      -----------------------------
350
 
351
      procedure Add_To_Context_And_Mark (Itm : Node_Id) is
352
         CW : constant Node_Id :=
353
                Make_With_Clause (Sloc (Itm),
354
                  Name => Name (Itm));
355
 
356
      begin
357
         Set_Library_Unit  (CW, Library_Unit (Itm));
358
         Set_Implicit_With (CW, True);
359
 
360
         --  Set elaborate all desirable on copy and then append the copy to
361
         --  the list of body with's and we are done.
362
 
363
         Set_Elab_Flag (CW);
364
         Append_To (CI, CW);
365
      end Add_To_Context_And_Mark;
366
 
367
      -----------------
368
      -- In_Withs_Of --
369
      -----------------
370
 
371
      function In_Withs_Of (UEs : Entity_Id) return Boolean is
372
         UNs : constant Unit_Number_Type := Get_Source_Unit (UEs);
373
         CUs : constant Node_Id          := Cunit (UNs);
374
         CIs : constant List_Id          := Context_Items (CUs);
375
 
376
      begin
377
         Itm := First (CIs);
378
         while Present (Itm) loop
379
            if Nkind (Itm) = N_With_Clause then
380
               Ent :=
381
                 Cunit_Entity (Get_Cunit_Unit_Number (Library_Unit (Itm)));
382
 
383
               if U = Ent then
384
                  return True;
385
               end if;
386
            end if;
387
 
388
            Next (Itm);
389
         end loop;
390
 
391
         return False;
392
      end In_Withs_Of;
393
 
394
      -------------------
395
      -- Set_Elab_Flag --
396
      -------------------
397
 
398
      procedure Set_Elab_Flag (Itm : Node_Id) is
399
      begin
400
         if Nkind (N) in N_Subprogram_Instantiation then
401
            Set_Elaborate_Desirable (Itm);
402
         else
403
            Set_Elaborate_All_Desirable (Itm);
404
         end if;
405
      end Set_Elab_Flag;
406
 
407
   --  Start of processing for Activate_Elaborate_All_Desirable
408
 
409
   begin
410
      --  Do not set binder indication if expansion is disabled, as when
411
      --  compiling a generic unit.
412
 
413
      if not Expander_Active then
414
         return;
415
      end if;
416
 
417
      Itm := First (CI);
418
      while Present (Itm) loop
419
         if Nkind (Itm) = N_With_Clause then
420
            Ent := Cunit_Entity (Get_Cunit_Unit_Number (Library_Unit (Itm)));
421
 
422
            --  If we find it, then mark elaborate all desirable and return
423
 
424
            if U = Ent then
425
               Set_Elab_Flag (Itm);
426
               return;
427
            end if;
428
         end if;
429
 
430
         Next (Itm);
431
      end loop;
432
 
433
      --  If we fall through then the with clause is not present in the
434
      --  current unit. One legitimate possibility is that the with clause
435
      --  is present in the spec when we are a body.
436
 
437
      if Is_Body_Name (Unm)
438
        and then In_Withs_Of (Spec_Entity (UE))
439
      then
440
         Add_To_Context_And_Mark (Itm);
441
         return;
442
      end if;
443
 
444
      --  Similarly, we may be in the spec or body of a child unit, where
445
      --  the unit in question is with'ed by some ancestor of the child unit.
446
 
447
      if Is_Child_Name (Unm) then
448
         declare
449
            Pkg : Entity_Id;
450
 
451
         begin
452
            Pkg := UE;
453
            loop
454
               Pkg := Scope (Pkg);
455
               exit when Pkg = Standard_Standard;
456
 
457
               if In_Withs_Of (Pkg) then
458
                  Add_To_Context_And_Mark (Itm);
459
                  return;
460
               end if;
461
            end loop;
462
         end;
463
      end if;
464
 
465
      --  Here if we do not find with clause on spec or body. We just ignore
466
      --  this case, it means that the elaboration involves some other unit
467
      --  than the unit being compiled, and will be caught elsewhere.
468
 
469
      null;
470
   end Activate_Elaborate_All_Desirable;
471
 
472
   ------------------
473
   -- Check_A_Call --
474
   ------------------
475
 
476
   procedure Check_A_Call
477
     (N                 : Node_Id;
478
      E                 : Entity_Id;
479
      Outer_Scope       : Entity_Id;
480
      Inter_Unit_Only   : Boolean;
481
      Generate_Warnings : Boolean := True;
482
      In_Init_Proc      : Boolean := False)
483
   is
484
      Loc  : constant Source_Ptr := Sloc (N);
485
      Ent  : Entity_Id;
486
      Decl : Node_Id;
487
 
488
      E_Scope : Entity_Id;
489
      --  Top level scope of entity for called subprogram. This value includes
490
      --  following renamings and derivations, so this scope can be in a
491
      --  non-visible unit. This is the scope that is to be investigated to
492
      --  see whether an elaboration check is required.
493
 
494
      W_Scope : Entity_Id;
495
      --  Top level scope of directly called entity for subprogram. This
496
      --  differs from E_Scope in the case where renamings or derivations
497
      --  are involved, since it does not follow these links. W_Scope is
498
      --  generally in a visible unit, and it is this scope that may require
499
      --  an Elaborate_All. However, there are some cases (initialization
500
      --  calls and calls involving object notation) where W_Scope might not
501
      --  be in the context of the current unit, and there is an intermediate
502
      --  package that is, in which case the Elaborate_All has to be placed
503
      --  on this intermediate package. These special cases are handled in
504
      --  Set_Elaboration_Constraint.
505
 
506
      Body_Acts_As_Spec : Boolean;
507
      --  Set to true if call is to body acting as spec (no separate spec)
508
 
509
      Inst_Case : constant Boolean := Nkind (N) in N_Generic_Instantiation;
510
      --  Indicates if we have instantiation case
511
 
512
      Caller_Unit_Internal : Boolean;
513
      Callee_Unit_Internal : Boolean;
514
 
515
      Inst_Caller : Source_Ptr;
516
      Inst_Callee : Source_Ptr;
517
 
518
      Unit_Caller : Unit_Number_Type;
519
      Unit_Callee : Unit_Number_Type;
520
 
521
      Cunit_SC : Boolean := False;
522
      --  Set to suppress dynamic elaboration checks where one of the
523
      --  enclosing scopes has Elaboration_Checks_Suppressed set, or else
524
      --  if a pragma Elaborate (_All) applies to that scope, in which case
525
      --  warnings on the scope are also suppressed. For the internal case,
526
      --  we ignore this flag.
527
 
528
   begin
529
      --  If the call is known to be within a local Suppress Elaboration
530
      --  pragma, nothing to check. This can happen in task bodies.
531
 
532
      if (Nkind (N) = N_Function_Call
533
           or else Nkind (N) = N_Procedure_Call_Statement)
534
        and then No_Elaboration_Check (N)
535
      then
536
         return;
537
      end if;
538
 
539
      --  Go to parent for derived subprogram, or to original subprogram in the
540
      --  case of a renaming (Alias covers both these cases).
541
 
542
      Ent := E;
543
      loop
544
         if (Suppress_Elaboration_Warnings (Ent)
545
              or else Elaboration_Checks_Suppressed (Ent))
546
           and then (Inst_Case or else No (Alias (Ent)))
547
         then
548
            return;
549
         end if;
550
 
551
         --  Nothing to do for imported entities
552
 
553
         if Is_Imported (Ent) then
554
            return;
555
         end if;
556
 
557
         exit when Inst_Case or else No (Alias (Ent));
558
         Ent := Alias (Ent);
559
      end loop;
560
 
561
      Decl := Unit_Declaration_Node (Ent);
562
 
563
      if Nkind (Decl) = N_Subprogram_Body then
564
         Body_Acts_As_Spec := True;
565
 
566
      elsif Nkind (Decl) = N_Subprogram_Declaration
567
        or else Nkind (Decl) = N_Subprogram_Body_Stub
568
        or else Inst_Case
569
      then
570
         Body_Acts_As_Spec := False;
571
 
572
      --  If we have none of an instantiation, subprogram body or
573
      --  subprogram declaration, then it is not a case that we want
574
      --  to check. (One case is a call to a generic formal subprogram,
575
      --  where we do not want the check in the template).
576
 
577
      else
578
         return;
579
      end if;
580
 
581
      E_Scope := Ent;
582
      loop
583
         if Elaboration_Checks_Suppressed (E_Scope)
584
           or else Suppress_Elaboration_Warnings (E_Scope)
585
         then
586
            Cunit_SC := True;
587
         end if;
588
 
589
         --  Exit when we get to compilation unit, not counting subunits
590
 
591
         exit when Is_Compilation_Unit (E_Scope)
592
           and then (Is_Child_Unit (E_Scope)
593
                       or else Scope (E_Scope) = Standard_Standard);
594
 
595
         --  If we did not find a compilation unit, other than standard,
596
         --  then nothing to check (happens in some instantiation cases)
597
 
598
         if E_Scope = Standard_Standard then
599
            return;
600
 
601
         --  Otherwise move up a scope looking for compilation unit
602
 
603
         else
604
            E_Scope := Scope (E_Scope);
605
         end if;
606
      end loop;
607
 
608
      --  No checks needed for pure or preelaborated compilation units
609
 
610
      if Is_Pure (E_Scope) or else Is_Preelaborated (E_Scope) then
611
         return;
612
      end if;
613
 
614
      --  If the generic entity is within a deeper instance than we are, then
615
      --  either the instantiation to which we refer itself caused an ABE, in
616
      --  which case that will be handled separately, or else we know that the
617
      --  body we need appears as needed at the point of the instantiation.
618
      --  However, this assumption is only valid if we are in static mode.
619
 
620
      if not Dynamic_Elaboration_Checks
621
        and then Instantiation_Depth (Sloc (Ent)) >
622
                 Instantiation_Depth (Sloc (N))
623
      then
624
         return;
625
      end if;
626
 
627
      --  Do not give a warning for a package with no body
628
 
629
      if Ekind (Ent) = E_Generic_Package
630
        and then not Has_Generic_Body (N)
631
      then
632
         return;
633
      end if;
634
 
635
      --  Case of entity is not in current unit (i.e. with'ed unit case)
636
 
637
      if E_Scope /= C_Scope then
638
 
639
         --  We are only interested in such calls if the outer call was from
640
         --  elaboration code, or if we are in Dynamic_Elaboration_Checks mode.
641
 
642
         if not From_Elab_Code and then not Dynamic_Elaboration_Checks then
643
            return;
644
         end if;
645
 
646
         --  Nothing to do if some scope said that no checks were required
647
 
648
         if Cunit_SC then
649
            return;
650
         end if;
651
 
652
         --  Nothing to do for a generic instance, because in this case the
653
         --  checking was at the point of instantiation of the generic However,
654
         --  this shortcut is only applicable in static mode.
655
 
656
         if Is_Generic_Instance (Ent) and not Dynamic_Elaboration_Checks then
657
            return;
658
         end if;
659
 
660
         --  Nothing to do if subprogram with no separate spec. However, a
661
         --  call to Deep_Initialize may result in a call to a user-defined
662
         --  Initialize procedure, which imposes a body dependency. This
663
         --  happens only if the type is controlled and the Initialize
664
         --  procedure is not inherited.
665
 
666
         if Body_Acts_As_Spec then
667
            if Is_TSS (Ent, TSS_Deep_Initialize) then
668
               declare
669
                  Typ  : constant Entity_Id := Etype (First_Formal (Ent));
670
                  Init : Entity_Id;
671
 
672
               begin
673
                  if not Is_Controlled (Typ) then
674
                     return;
675
                  else
676
                     Init := Find_Prim_Op (Typ, Name_Initialize);
677
 
678
                     if Comes_From_Source (Init) then
679
                        Ent := Init;
680
                     else
681
                        return;
682
                     end if;
683
                  end if;
684
               end;
685
 
686
            else
687
               return;
688
            end if;
689
         end if;
690
 
691
         --  Check cases of internal units
692
 
693
         Callee_Unit_Internal :=
694
           Is_Internal_File_Name
695
             (Unit_File_Name (Get_Source_Unit (E_Scope)));
696
 
697
         --  Do not give a warning if the with'ed unit is internal
698
         --  and this is the generic instantiation case (this saves a
699
         --  lot of hassle dealing with the Text_IO special child units)
700
 
701
         if Callee_Unit_Internal and Inst_Case then
702
            return;
703
         end if;
704
 
705
         if C_Scope = Standard_Standard then
706
            Caller_Unit_Internal := False;
707
         else
708
            Caller_Unit_Internal :=
709
              Is_Internal_File_Name
710
                (Unit_File_Name (Get_Source_Unit (C_Scope)));
711
         end if;
712
 
713
         --  Do not give a warning if the with'ed unit is internal
714
         --  and the caller is not internal (since the binder always
715
         --  elaborates internal units first).
716
 
717
         if Callee_Unit_Internal and (not Caller_Unit_Internal) then
718
            return;
719
         end if;
720
 
721
         --  For now, if debug flag -gnatdE is not set, do no checking for
722
         --  one internal unit withing another. This fixes the problem with
723
         --  the sgi build and storage errors. To be resolved later ???
724
 
725
         if (Callee_Unit_Internal and Caller_Unit_Internal)
726
            and then not Debug_Flag_EE
727
         then
728
            return;
729
         end if;
730
 
731
         if Is_TSS (E, TSS_Deep_Initialize) then
732
            Ent := E;
733
         end if;
734
 
735
         --  If the call is in an instance, and the called entity is not
736
         --  defined in the same instance, then the elaboration issue
737
         --  focuses around the unit containing the template, it is
738
         --  this unit which requires an Elaborate_All.
739
 
740
         --  However, if we are doing dynamic elaboration, we need to
741
         --  chase the call in the usual manner.
742
 
743
         --  We do not handle the case of calling a generic formal correctly
744
         --  in the static case. See test 4703-004 to explore this gap ???
745
 
746
         Inst_Caller := Instantiation (Get_Source_File_Index (Sloc (N)));
747
         Inst_Callee := Instantiation (Get_Source_File_Index (Sloc (Ent)));
748
 
749
         if Inst_Caller = No_Location then
750
            Unit_Caller := No_Unit;
751
         else
752
            Unit_Caller := Get_Source_Unit (N);
753
         end if;
754
 
755
         if Inst_Callee = No_Location then
756
            Unit_Callee := No_Unit;
757
         else
758
            Unit_Callee := Get_Source_Unit (Ent);
759
         end if;
760
 
761
         if Unit_Caller /= No_Unit
762
           and then Unit_Callee /= Unit_Caller
763
           and then not Dynamic_Elaboration_Checks
764
         then
765
            E_Scope := Spec_Entity (Cunit_Entity (Unit_Caller));
766
 
767
            --  If we don't get a spec entity, just ignore call. Not quite
768
            --  clear why this check is necessary. ???
769
 
770
            if No (E_Scope) then
771
               return;
772
            end if;
773
 
774
            --  Otherwise step to enclosing compilation unit
775
 
776
            while not Is_Compilation_Unit (E_Scope) loop
777
               E_Scope := Scope (E_Scope);
778
            end loop;
779
 
780
         --  For the case N is not an instance, or a call within instance, we
781
         --  recompute E_Scope for the error message, since we do NOT want to
782
         --  go to the unit which has the ultimate declaration in the case of
783
         --  renaming and derivation and we also want to go to the generic unit
784
         --  in the case of an instance, and no further.
785
 
786
         else
787
            --  Loop to carefully follow renamings and derivations one step
788
            --  outside the current unit, but not further.
789
 
790
            if not Inst_Case
791
              and then Present (Alias (Ent))
792
            then
793
               E_Scope := Alias (Ent);
794
            else
795
               E_Scope := Ent;
796
            end if;
797
 
798
            loop
799
               while not Is_Compilation_Unit (E_Scope) loop
800
                  E_Scope := Scope (E_Scope);
801
               end loop;
802
 
803
               --  If E_Scope is the same as C_Scope, it means that there
804
               --  definitely was a local renaming or derivation, and we
805
               --  are not yet out of the current unit.
806
 
807
               exit when E_Scope /= C_Scope;
808
               Ent := Alias (Ent);
809
               E_Scope := Ent;
810
 
811
               --  If no alias, there is a previous error
812
 
813
               if No (Ent) then
814
                  return;
815
               end if;
816
            end loop;
817
         end if;
818
 
819
         if Within_Elaborate_All (E_Scope) then
820
            return;
821
         end if;
822
 
823
         --  Find top level scope for called entity (not following renamings
824
         --  or derivations). This is where the Elaborate_All will go if it
825
         --  is needed. We start with the called entity, except in the case
826
         --  of an initialization procedure outside the current package, where
827
         --  the init proc is in the root package, and we start from the entity
828
         --  of the name in the call.
829
 
830
         if Is_Entity_Name (Name (N))
831
           and then Is_Init_Proc (Entity (Name (N)))
832
           and then not In_Same_Extended_Unit (N, Entity (Name (N)))
833
         then
834
            W_Scope := Scope (Entity (Name (N)));
835
         else
836
            W_Scope := E;
837
         end if;
838
 
839
         while not Is_Compilation_Unit (W_Scope) loop
840
            W_Scope := Scope (W_Scope);
841
         end loop;
842
 
843
         --  Now check if an elaborate_all (or dynamic check) is needed
844
 
845
         if not Suppress_Elaboration_Warnings (Ent)
846
           and then not Elaboration_Checks_Suppressed (Ent)
847
           and then not Suppress_Elaboration_Warnings (E_Scope)
848
           and then not Elaboration_Checks_Suppressed (E_Scope)
849
           and then Elab_Warnings
850
           and then Generate_Warnings
851
         then
852
            Generate_Elab_Warnings : declare
853
               procedure Elab_Warning
854
                 (Msg_D : String;
855
                  Msg_S : String;
856
                  Ent   : Node_Or_Entity_Id);
857
               --  Generate a call to Error_Msg_NE with parameters Msg_D or
858
               --  Msg_S (for dynamic or static elaboration model), N and Ent.
859
 
860
               ------------------
861
               -- Elab_Warning --
862
               ------------------
863
 
864
               procedure Elab_Warning
865
                 (Msg_D : String;
866
                  Msg_S : String;
867
                  Ent   : Node_Or_Entity_Id)
868
               is
869
               begin
870
                  if Dynamic_Elaboration_Checks then
871
                     Error_Msg_NE (Msg_D, N, Ent);
872
                  else
873
                     Error_Msg_NE (Msg_S, N, Ent);
874
                  end if;
875
               end Elab_Warning;
876
 
877
            --  Start of processing for Generate_Elab_Warnings
878
 
879
            begin
880
               if Inst_Case then
881
                  Elab_Warning
882
                    ("instantiation of& may raise Program_Error?",
883
                     "info: instantiation of& during elaboration?", Ent);
884
 
885
               else
886
                  if Nkind (Name (N)) in N_Has_Entity
887
                    and then Is_Init_Proc (Entity (Name (N)))
888
                    and then Comes_From_Source (Ent)
889
                  then
890
                     Elab_Warning
891
                       ("implicit call to & may raise Program_Error?",
892
                        "info: implicit call to & during elaboration?",
893
                        Ent);
894
 
895
                  else
896
                     Elab_Warning
897
                       ("call to & may raise Program_Error?",
898
                        "info: call to & during elaboration?",
899
                        Ent);
900
                  end if;
901
               end if;
902
 
903
               Error_Msg_Qual_Level := Nat'Last;
904
 
905
               if Nkind (N) in N_Subprogram_Instantiation then
906
                  Elab_Warning
907
                    ("\missing pragma Elaborate for&?",
908
                     "\info: implicit pragma Elaborate for& generated?",
909
                     W_Scope);
910
               else
911
                  Elab_Warning
912
                    ("\missing pragma Elaborate_All for&?",
913
                     "\info: implicit pragma Elaborate_All for & generated?",
914
                     W_Scope);
915
               end if;
916
            end Generate_Elab_Warnings;
917
 
918
            Error_Msg_Qual_Level := 0;
919
            Output_Calls (N);
920
 
921
            --  Set flag to prevent further warnings for same unit unless in
922
            --  All_Errors_Mode.
923
 
924
            if not All_Errors_Mode and not Dynamic_Elaboration_Checks then
925
               Set_Suppress_Elaboration_Warnings (W_Scope, True);
926
            end if;
927
         end if;
928
 
929
         --  Check for runtime elaboration check required
930
 
931
         if Dynamic_Elaboration_Checks then
932
            if not Elaboration_Checks_Suppressed (Ent)
933
              and then not Elaboration_Checks_Suppressed (W_Scope)
934
              and then not Elaboration_Checks_Suppressed (E_Scope)
935
              and then not Cunit_SC
936
            then
937
               --  Runtime elaboration check required. Generate check of the
938
               --  elaboration Boolean for the unit containing the entity.
939
 
940
               --  Note that for this case, we do check the real unit (the one
941
               --  from following renamings, since that is the issue!)
942
 
943
               --  Could this possibly miss a useless but required PE???
944
 
945
               Insert_Elab_Check (N,
946
                 Make_Attribute_Reference (Loc,
947
                   Attribute_Name => Name_Elaborated,
948
                   Prefix => New_Occurrence_Of (Spec_Entity (E_Scope), Loc)));
949
 
950
               --  Prevent duplicate elaboration checks on the same call,
951
               --  which can happen if the body enclosing the call appears
952
               --  itself in a call whose elaboration check is delayed.
953
 
954
               if Nkind_In (N, N_Function_Call,
955
                               N_Procedure_Call_Statement)
956
               then
957
                  Set_No_Elaboration_Check (N);
958
               end if;
959
            end if;
960
 
961
         --  Case of static elaboration model
962
 
963
         else
964
            --  Do not do anything if elaboration checks suppressed. Note that
965
            --  we check Ent here, not E, since we want the real entity for the
966
            --  body to see if checks are suppressed for it, not the dummy
967
            --  entry for renamings or derivations.
968
 
969
            if Elaboration_Checks_Suppressed (Ent)
970
              or else Elaboration_Checks_Suppressed (E_Scope)
971
              or else Elaboration_Checks_Suppressed (W_Scope)
972
            then
973
               null;
974
 
975
            --  Do not generate an Elaborate_All for finalization routines
976
            --  which perform partial clean up as part of initialization.
977
 
978
            elsif In_Init_Proc
979
              and then Is_Finalization_Procedure (Ent)
980
            then
981
               null;
982
 
983
            --  Here we need to generate an implicit elaborate all
984
 
985
            else
986
               --  Generate elaborate_all warning unless suppressed
987
 
988
               if (Elab_Warnings and Generate_Warnings and not Inst_Case)
989
                 and then not Suppress_Elaboration_Warnings (Ent)
990
                 and then not Suppress_Elaboration_Warnings (E_Scope)
991
                 and then not Suppress_Elaboration_Warnings (W_Scope)
992
               then
993
                  Error_Msg_Node_2 := W_Scope;
994
                  Error_Msg_NE
995
                    ("call to& in elaboration code " &
996
                     "requires pragma Elaborate_All on&?", N, E);
997
               end if;
998
 
999
               --  Set indication for binder to generate Elaborate_All
1000
 
1001
               Set_Elaboration_Constraint (N, E, W_Scope);
1002
            end if;
1003
         end if;
1004
 
1005
      --  Case of entity is in same unit as call or instantiation
1006
 
1007
      elsif not Inter_Unit_Only then
1008
         Check_Internal_Call (N, Ent, Outer_Scope, E);
1009
      end if;
1010
   end Check_A_Call;
1011
 
1012
   -----------------------------
1013
   -- Check_Bad_Instantiation --
1014
   -----------------------------
1015
 
1016
   procedure Check_Bad_Instantiation (N : Node_Id) is
1017
      Ent : Entity_Id;
1018
 
1019
   begin
1020
      --  Nothing to do if we do not have an instantiation (happens in some
1021
      --  error cases, and also in the formal package declaration case)
1022
 
1023
      if Nkind (N) not in N_Generic_Instantiation then
1024
         return;
1025
 
1026
      --  Nothing to do if serious errors detected (avoid cascaded errors)
1027
 
1028
      elsif Serious_Errors_Detected /= 0 then
1029
         return;
1030
 
1031
      --  Nothing to do if not in full analysis mode
1032
 
1033
      elsif not Full_Analysis then
1034
         return;
1035
 
1036
      --  Nothing to do if inside a generic template
1037
 
1038
      elsif Inside_A_Generic then
1039
         return;
1040
 
1041
      --  Nothing to do if a library level instantiation
1042
 
1043
      elsif Nkind (Parent (N)) = N_Compilation_Unit then
1044
         return;
1045
 
1046
      --  Nothing to do if we are compiling a proper body for semantic
1047
      --  purposes only. The generic body may be in another proper body.
1048
 
1049
      elsif
1050
        Nkind (Parent (Unit_Declaration_Node (Main_Unit_Entity))) = N_Subunit
1051
      then
1052
         return;
1053
      end if;
1054
 
1055
      Ent := Get_Generic_Entity (N);
1056
 
1057
      --  The case we are interested in is when the generic spec is in the
1058
      --  current declarative part
1059
 
1060
      if not Same_Elaboration_Scope (Current_Scope, Scope (Ent))
1061
        or else not In_Same_Extended_Unit (N, Ent)
1062
      then
1063
         return;
1064
      end if;
1065
 
1066
      --  If the generic entity is within a deeper instance than we are, then
1067
      --  either the instantiation to which we refer itself caused an ABE, in
1068
      --  which case that will be handled separately. Otherwise, we know that
1069
      --  the body we need appears as needed at the point of the instantiation.
1070
      --  If they are both at the same level but not within the same instance
1071
      --  then the body of the generic will be in the earlier instance.
1072
 
1073
      declare
1074
         D1 : constant Int := Instantiation_Depth (Sloc (Ent));
1075
         D2 : constant Int := Instantiation_Depth (Sloc (N));
1076
 
1077
      begin
1078
         if D1 > D2 then
1079
            return;
1080
 
1081
         elsif D1 = D2
1082
           and then Is_Generic_Instance (Scope (Ent))
1083
           and then not In_Open_Scopes (Scope (Ent))
1084
         then
1085
            return;
1086
         end if;
1087
      end;
1088
 
1089
      --  Now we can proceed, if the entity being called has a completion,
1090
      --  then we are definitely OK, since we have already seen the body.
1091
 
1092
      if Has_Completion (Ent) then
1093
         return;
1094
      end if;
1095
 
1096
      --  If there is no body, then nothing to do
1097
 
1098
      if not Has_Generic_Body (N) then
1099
         return;
1100
      end if;
1101
 
1102
      --  Here we definitely have a bad instantiation
1103
 
1104
      Error_Msg_NE
1105
        ("?cannot instantiate& before body seen", N, Ent);
1106
 
1107
      if Present (Instance_Spec (N)) then
1108
         Supply_Bodies (Instance_Spec (N));
1109
      end if;
1110
 
1111
      Error_Msg_N
1112
        ("\?Program_Error will be raised at run time", N);
1113
      Insert_Elab_Check (N);
1114
      Set_ABE_Is_Certain (N);
1115
   end Check_Bad_Instantiation;
1116
 
1117
   ---------------------
1118
   -- Check_Elab_Call --
1119
   ---------------------
1120
 
1121
   procedure Check_Elab_Call
1122
     (N            : Node_Id;
1123
      Outer_Scope  : Entity_Id := Empty;
1124
      In_Init_Proc : Boolean   := False)
1125
   is
1126
      Ent : Entity_Id;
1127
      P   : Node_Id;
1128
 
1129
      function Get_Called_Ent return Entity_Id;
1130
      --  Retrieve called entity. If this is a call to a protected subprogram,
1131
      --  entity is a selected component. The callable entity may be absent,
1132
      --  in which case there is no check to perform. This happens with
1133
      --  non-analyzed calls in nested generics.
1134
 
1135
      --------------------
1136
      -- Get_Called_Ent --
1137
      --------------------
1138
 
1139
      function Get_Called_Ent return Entity_Id is
1140
         Nam : Node_Id;
1141
 
1142
      begin
1143
         Nam := Name (N);
1144
 
1145
         if No (Nam) then
1146
            return Empty;
1147
 
1148
         elsif Nkind (Nam) = N_Selected_Component then
1149
            return Entity (Selector_Name (Nam));
1150
 
1151
         elsif not Is_Entity_Name (Nam) then
1152
            return Empty;
1153
 
1154
         else
1155
            return Entity (Nam);
1156
         end if;
1157
      end Get_Called_Ent;
1158
 
1159
   --  Start of processing for Check_Elab_Call
1160
 
1161
   begin
1162
      --  If the call does not come from the main unit, there is nothing to
1163
      --  check. Elaboration call from units in the context of the main unit
1164
      --  will lead to semantic dependencies when those units are compiled.
1165
 
1166
      if not In_Extended_Main_Code_Unit (N) then
1167
         return;
1168
      end if;
1169
 
1170
      --  For an entry call, check relevant restriction
1171
 
1172
      if Nkind (N) = N_Entry_Call_Statement
1173
         and then not In_Subprogram_Or_Concurrent_Unit
1174
      then
1175
         Check_Restriction (No_Entry_Calls_In_Elaboration_Code, N);
1176
 
1177
      --  Nothing to do if this is not a call (happens in some error
1178
      --  conditions, and in some cases where rewriting occurs).
1179
 
1180
      elsif Nkind (N) /= N_Function_Call
1181
        and then Nkind (N) /= N_Procedure_Call_Statement
1182
      then
1183
         return;
1184
 
1185
      --  Nothing to do if this is a call already rewritten for elab checking
1186
 
1187
      elsif Nkind (Parent (N)) = N_Conditional_Expression then
1188
         return;
1189
 
1190
      --  Nothing to do if inside a generic template
1191
 
1192
      elsif Inside_A_Generic
1193
        and then No (Enclosing_Generic_Body (N))
1194
      then
1195
         return;
1196
      end if;
1197
 
1198
      --  Here we have a call at elaboration time which must be checked
1199
 
1200
      if Debug_Flag_LL then
1201
         Write_Str ("  Check_Elab_Call: ");
1202
 
1203
         if No (Name (N))
1204
           or else not Is_Entity_Name (Name (N))
1205
         then
1206
            Write_Str ("<<not entity name>> ");
1207
         else
1208
            Write_Name (Chars (Entity (Name (N))));
1209
         end if;
1210
 
1211
         Write_Str ("  call at ");
1212
         Write_Location (Sloc (N));
1213
         Write_Eol;
1214
      end if;
1215
 
1216
      --  Climb up the tree to make sure we are not inside default expression
1217
      --  of a parameter specification or a record component, since in both
1218
      --  these cases, we will be doing the actual call later, not now, and it
1219
      --  is at the time of the actual call (statically speaking) that we must
1220
      --  do our static check, not at the time of its initial analysis).
1221
 
1222
      --  However, we have to check calls within component definitions (e.g.
1223
      --  a function call that determines an array component bound), so we
1224
      --  terminate the loop in that case.
1225
 
1226
      P := Parent (N);
1227
      while Present (P) loop
1228
         if Nkind (P) = N_Parameter_Specification
1229
              or else
1230
            Nkind (P) = N_Component_Declaration
1231
         then
1232
            return;
1233
 
1234
         --  The call occurs within the constraint of a component,
1235
         --  so it must be checked.
1236
 
1237
         elsif Nkind (P) = N_Component_Definition then
1238
            exit;
1239
 
1240
         else
1241
            P := Parent (P);
1242
         end if;
1243
      end loop;
1244
 
1245
      --  Stuff that happens only at the outer level
1246
 
1247
      if No (Outer_Scope) then
1248
         Elab_Visited.Set_Last (0);
1249
 
1250
         --  Nothing to do if current scope is Standard (this is a bit odd, but
1251
         --  it happens in the case of generic instantiations).
1252
 
1253
         C_Scope := Current_Scope;
1254
 
1255
         if C_Scope = Standard_Standard then
1256
            return;
1257
         end if;
1258
 
1259
         --  First case, we are in elaboration code
1260
 
1261
         From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit;
1262
         if From_Elab_Code then
1263
 
1264
            --  Complain if call that comes from source in preelaborated unit
1265
            --  and we are not inside a subprogram (i.e. we are in elab code).
1266
 
1267
            if Comes_From_Source (N)
1268
              and then In_Preelaborated_Unit
1269
              and then not In_Inlined_Body
1270
            then
1271
               --  This is a warning in GNAT mode allowing such calls to be
1272
               --  used in the predefined library with appropriate care.
1273
 
1274
               Error_Msg_Warn := GNAT_Mode;
1275
               Error_Msg_N
1276
                 ("<non-static call not allowed in preelaborated unit", N);
1277
               return;
1278
            end if;
1279
 
1280
         --  Second case, we are inside a subprogram or concurrent unit, which
1281
         --  means we are not in elaboration code.
1282
 
1283
         else
1284
            --  In this case, the issue is whether we are inside the
1285
            --  declarative part of the unit in which we live, or inside its
1286
            --  statements. In the latter case, there is no issue of ABE calls
1287
            --  at this level (a call from outside to the unit in which we live
1288
            --  might cause an ABE, but that will be detected when we analyze
1289
            --  that outer level call, as it recurses into the called unit).
1290
 
1291
            --  Climb up the tree, doing this test, and also testing for being
1292
            --  inside a default expression, which, as discussed above, is not
1293
            --  checked at this stage.
1294
 
1295
            declare
1296
               P : Node_Id;
1297
               L : List_Id;
1298
 
1299
            begin
1300
               P := N;
1301
               loop
1302
                  --  If we find a parentless subtree, it seems safe to assume
1303
                  --  that we are not in a declarative part and that no
1304
                  --  checking is required.
1305
 
1306
                  if No (P) then
1307
                     return;
1308
                  end if;
1309
 
1310
                  if Is_List_Member (P) then
1311
                     L := List_Containing (P);
1312
                     P := Parent (L);
1313
                  else
1314
                     L := No_List;
1315
                     P := Parent (P);
1316
                  end if;
1317
 
1318
                  exit when Nkind (P) = N_Subunit;
1319
 
1320
                  --  Filter out case of default expressions, where we do not
1321
                  --  do the check at this stage.
1322
 
1323
                  if Nkind (P) = N_Parameter_Specification
1324
                       or else
1325
                     Nkind (P) = N_Component_Declaration
1326
                  then
1327
                     return;
1328
                  end if;
1329
 
1330
                  --  A protected body has no elaboration code and contains
1331
                  --  only other bodies.
1332
 
1333
                  if Nkind (P) = N_Protected_Body then
1334
                     return;
1335
 
1336
                  elsif Nkind (P) = N_Subprogram_Body
1337
                       or else
1338
                     Nkind (P) = N_Task_Body
1339
                       or else
1340
                     Nkind (P) = N_Block_Statement
1341
                       or else
1342
                     Nkind (P) = N_Entry_Body
1343
                  then
1344
                     if L = Declarations (P) then
1345
                        exit;
1346
 
1347
                     --  We are not in elaboration code, but we are doing
1348
                     --  dynamic elaboration checks, in this case, we still
1349
                     --  need to do the call, since the subprogram we are in
1350
                     --  could be called from another unit, also in dynamic
1351
                     --  elaboration check mode, at elaboration time.
1352
 
1353
                     elsif Dynamic_Elaboration_Checks then
1354
 
1355
                        --  This is a rather new check, going into version
1356
                        --  3.14a1 for the first time (V1.80 of this unit), so
1357
                        --  we provide a debug flag to enable it. That way we
1358
                        --  have an easy work around for regressions that are
1359
                        --  caused by this new check. This debug flag can be
1360
                        --  removed later.
1361
 
1362
                        if Debug_Flag_DD then
1363
                           return;
1364
                        end if;
1365
 
1366
                        --  Do the check in this case
1367
 
1368
                        exit;
1369
 
1370
                     elsif Nkind (P) = N_Task_Body then
1371
 
1372
                        --  The check is deferred until Check_Task_Activation
1373
                        --  but we need to capture local suppress pragmas
1374
                        --  that may inhibit checks on this call.
1375
 
1376
                        Ent := Get_Called_Ent;
1377
 
1378
                        if No (Ent) then
1379
                           return;
1380
 
1381
                        elsif Elaboration_Checks_Suppressed (Current_Scope)
1382
                          or else Elaboration_Checks_Suppressed (Ent)
1383
                          or else Elaboration_Checks_Suppressed (Scope (Ent))
1384
                        then
1385
                           Set_No_Elaboration_Check (N);
1386
                        end if;
1387
 
1388
                        return;
1389
 
1390
                     --  Static model, call is not in elaboration code, we
1391
                     --  never need to worry, because in the static model the
1392
                     --  top level caller always takes care of things.
1393
 
1394
                     else
1395
                        return;
1396
                     end if;
1397
                  end if;
1398
               end loop;
1399
            end;
1400
         end if;
1401
      end if;
1402
 
1403
      Ent := Get_Called_Ent;
1404
 
1405
      if No (Ent) then
1406
         return;
1407
      end if;
1408
 
1409
      --  Nothing to do if this is a recursive call (i.e. a call to
1410
      --  an entity that is already in the Elab_Call stack)
1411
 
1412
      for J in 1 .. Elab_Visited.Last loop
1413
         if Ent = Elab_Visited.Table (J) then
1414
            return;
1415
         end if;
1416
      end loop;
1417
 
1418
      --  See if we need to analyze this call. We analyze it if either of
1419
      --  the following conditions is met:
1420
 
1421
      --    It is an inner level call (since in this case it was triggered
1422
      --    by an outer level call from elaboration code), but only if the
1423
      --    call is within the scope of the original outer level call.
1424
 
1425
      --    It is an outer level call from elaboration code, or the called
1426
      --    entity is in the same elaboration scope.
1427
 
1428
      --  And in these cases, we will check both inter-unit calls and
1429
      --  intra-unit (within a single unit) calls.
1430
 
1431
      C_Scope := Current_Scope;
1432
 
1433
      --  If not outer level call, then we follow it if it is within the
1434
      --  original scope of the outer call.
1435
 
1436
      if Present (Outer_Scope)
1437
        and then Within (Scope (Ent), Outer_Scope)
1438
      then
1439
         Set_C_Scope;
1440
         Check_A_Call
1441
           (N               => N,
1442
            E               => Ent,
1443
            Outer_Scope     => Outer_Scope,
1444
            Inter_Unit_Only => False,
1445
            In_Init_Proc    => In_Init_Proc);
1446
 
1447
      elsif Elaboration_Checks_Suppressed (Current_Scope) then
1448
         null;
1449
 
1450
      elsif From_Elab_Code then
1451
         Set_C_Scope;
1452
         Check_A_Call (N, Ent, Standard_Standard, Inter_Unit_Only => False);
1453
 
1454
      elsif Same_Elaboration_Scope (C_Scope, Scope (Ent)) then
1455
         Set_C_Scope;
1456
         Check_A_Call (N, Ent, Scope (Ent), Inter_Unit_Only => False);
1457
 
1458
      --  If none of those cases holds, but Dynamic_Elaboration_Checks mode
1459
      --  is set, then we will do the check, but only in the inter-unit case
1460
      --  (this is to accommodate unguarded elaboration calls from other units
1461
      --  in which this same mode is set). We don't want warnings in this case,
1462
      --  it would generate warnings having nothing to do with elaboration.
1463
 
1464
      elsif Dynamic_Elaboration_Checks then
1465
         Set_C_Scope;
1466
         Check_A_Call
1467
           (N,
1468
            Ent,
1469
            Standard_Standard,
1470
            Inter_Unit_Only   => True,
1471
            Generate_Warnings => False);
1472
 
1473
      --  Otherwise nothing to do
1474
 
1475
      else
1476
         return;
1477
      end if;
1478
 
1479
      --  A call to an Init_Proc in elaboration code may bring additional
1480
      --  dependencies, if some of the record components thereof have
1481
      --  initializations that are function calls that come from source. We
1482
      --  treat the current node as a call to each of these functions, to check
1483
      --  their elaboration impact.
1484
 
1485
      if Is_Init_Proc (Ent)
1486
        and then From_Elab_Code
1487
      then
1488
         Process_Init_Proc : declare
1489
            Unit_Decl : constant Node_Id := Unit_Declaration_Node (Ent);
1490
 
1491
            function Check_Init_Call (Nod : Node_Id) return Traverse_Result;
1492
            --  Find subprogram calls within body of Init_Proc for Traverse
1493
            --  instantiation below.
1494
 
1495
            procedure Traverse_Body is new Traverse_Proc (Check_Init_Call);
1496
            --  Traversal procedure to find all calls with body of Init_Proc
1497
 
1498
            ---------------------
1499
            -- Check_Init_Call --
1500
            ---------------------
1501
 
1502
            function Check_Init_Call (Nod : Node_Id) return Traverse_Result is
1503
               Func : Entity_Id;
1504
 
1505
            begin
1506
               if (Nkind (Nod) = N_Function_Call
1507
                    or else Nkind (Nod) = N_Procedure_Call_Statement)
1508
                 and then Is_Entity_Name (Name (Nod))
1509
               then
1510
                  Func := Entity (Name (Nod));
1511
 
1512
                  if Comes_From_Source (Func) then
1513
                     Check_A_Call
1514
                       (N, Func, Standard_Standard, Inter_Unit_Only => True);
1515
                  end if;
1516
 
1517
                  return OK;
1518
 
1519
               else
1520
                  return OK;
1521
               end if;
1522
            end Check_Init_Call;
1523
 
1524
         --  Start of processing for Process_Init_Proc
1525
 
1526
         begin
1527
            if Nkind (Unit_Decl) = N_Subprogram_Body then
1528
               Traverse_Body (Handled_Statement_Sequence (Unit_Decl));
1529
            end if;
1530
         end Process_Init_Proc;
1531
      end if;
1532
   end Check_Elab_Call;
1533
 
1534
   -----------------------
1535
   -- Check_Elab_Assign --
1536
   -----------------------
1537
 
1538
   procedure Check_Elab_Assign (N : Node_Id) is
1539
      Ent  : Entity_Id;
1540
      Scop : Entity_Id;
1541
 
1542
      Pkg_Spec : Entity_Id;
1543
      Pkg_Body : Entity_Id;
1544
 
1545
   begin
1546
      --  For record or array component, check prefix. If it is an access type,
1547
      --  then there is nothing to do (we do not know what is being assigned),
1548
      --  but otherwise this is an assignment to the prefix.
1549
 
1550
      if Nkind (N) = N_Indexed_Component
1551
           or else
1552
         Nkind (N) = N_Selected_Component
1553
           or else
1554
         Nkind (N) = N_Slice
1555
      then
1556
         if not Is_Access_Type (Etype (Prefix (N))) then
1557
            Check_Elab_Assign (Prefix (N));
1558
         end if;
1559
 
1560
         return;
1561
      end if;
1562
 
1563
      --  For type conversion, check expression
1564
 
1565
      if Nkind (N) = N_Type_Conversion then
1566
         Check_Elab_Assign (Expression (N));
1567
         return;
1568
      end if;
1569
 
1570
      --  Nothing to do if this is not an entity reference otherwise get entity
1571
 
1572
      if Is_Entity_Name (N) then
1573
         Ent := Entity (N);
1574
      else
1575
         return;
1576
      end if;
1577
 
1578
      --  What we are looking for is a reference in the body of a package that
1579
      --  modifies a variable declared in the visible part of the package spec.
1580
 
1581
      if Present (Ent)
1582
        and then Comes_From_Source (N)
1583
        and then not Suppress_Elaboration_Warnings (Ent)
1584
        and then Ekind (Ent) = E_Variable
1585
        and then not In_Private_Part (Ent)
1586
        and then Is_Library_Level_Entity (Ent)
1587
      then
1588
         Scop := Current_Scope;
1589
         loop
1590
            if No (Scop) or else Scop = Standard_Standard then
1591
               return;
1592
            elsif Ekind (Scop) = E_Package
1593
              and then Is_Compilation_Unit (Scop)
1594
            then
1595
               exit;
1596
            else
1597
               Scop := Scope (Scop);
1598
            end if;
1599
         end loop;
1600
 
1601
         --  Here Scop points to the containing library package
1602
 
1603
         Pkg_Spec := Scop;
1604
         Pkg_Body := Body_Entity (Pkg_Spec);
1605
 
1606
         --  All OK if the package has an Elaborate_Body pragma
1607
 
1608
         if Has_Pragma_Elaborate_Body (Scop) then
1609
            return;
1610
         end if;
1611
 
1612
         --  OK if entity being modified is not in containing package spec
1613
 
1614
         if not In_Same_Source_Unit (Scop, Ent) then
1615
            return;
1616
         end if;
1617
 
1618
         --  All OK if entity appears in generic package or generic instance.
1619
         --  We just get too messed up trying to give proper warnings in the
1620
         --  presence of generics. Better no message than a junk one.
1621
 
1622
         Scop := Scope (Ent);
1623
         while Present (Scop) and then Scop /= Pkg_Spec loop
1624
            if Ekind (Scop) = E_Generic_Package then
1625
               return;
1626
            elsif Ekind (Scop) = E_Package
1627
              and then Is_Generic_Instance (Scop)
1628
            then
1629
               return;
1630
            end if;
1631
 
1632
            Scop := Scope (Scop);
1633
         end loop;
1634
 
1635
         --  All OK if in task, don't issue warnings there
1636
 
1637
         if In_Task_Activation then
1638
            return;
1639
         end if;
1640
 
1641
         --  OK if no package body
1642
 
1643
         if No (Pkg_Body) then
1644
            return;
1645
         end if;
1646
 
1647
         --  OK if reference is not in package body
1648
 
1649
         if not In_Same_Source_Unit (Pkg_Body, N) then
1650
            return;
1651
         end if;
1652
 
1653
         --  OK if package body has no handled statement sequence
1654
 
1655
         declare
1656
            HSS : constant Node_Id :=
1657
                    Handled_Statement_Sequence (Declaration_Node (Pkg_Body));
1658
         begin
1659
            if No (HSS) or else not Comes_From_Source (HSS) then
1660
               return;
1661
            end if;
1662
         end;
1663
 
1664
         --  We definitely have a case of a modification of an entity in
1665
         --  the package spec from the elaboration code of the package body.
1666
         --  We may not give the warning (because there are some additional
1667
         --  checks to avoid too many false positives), but it would be a good
1668
         --  idea for the binder to try to keep the body elaboration close to
1669
         --  the spec elaboration.
1670
 
1671
         Set_Elaborate_Body_Desirable (Pkg_Spec);
1672
 
1673
         --  All OK in gnat mode (we know what we are doing)
1674
 
1675
         if GNAT_Mode then
1676
            return;
1677
         end if;
1678
 
1679
         --  All OK if all warnings suppressed
1680
 
1681
         if Warning_Mode = Suppress then
1682
            return;
1683
         end if;
1684
 
1685
         --  All OK if elaboration checks suppressed for entity
1686
 
1687
         if Checks_May_Be_Suppressed (Ent)
1688
           and then Is_Check_Suppressed (Ent, Elaboration_Check)
1689
         then
1690
            return;
1691
         end if;
1692
 
1693
         --  OK if the entity is initialized. Note that the No_Initialization
1694
         --  flag usually means that the initialization has been rewritten into
1695
         --  assignments, but that still counts for us.
1696
 
1697
         declare
1698
            Decl : constant Node_Id := Declaration_Node (Ent);
1699
         begin
1700
            if Nkind (Decl) = N_Object_Declaration
1701
              and then (Present (Expression (Decl))
1702
                          or else No_Initialization (Decl))
1703
            then
1704
               return;
1705
            end if;
1706
         end;
1707
 
1708
         --  Here is where we give the warning
1709
 
1710
         --  All OK if warnings suppressed on the entity
1711
 
1712
         if not Has_Warnings_Off (Ent) then
1713
            Error_Msg_Sloc := Sloc (Ent);
1714
 
1715
            Error_Msg_NE
1716
              ("?elaboration code may access& before it is initialized",
1717
               N, Ent);
1718
            Error_Msg_NE
1719
              ("\?suggest adding pragma Elaborate_Body to spec of &",
1720
               N, Scop);
1721
            Error_Msg_N
1722
              ("\?or an explicit initialization could be added #", N);
1723
         end if;
1724
 
1725
         if not All_Errors_Mode then
1726
            Set_Suppress_Elaboration_Warnings (Ent);
1727
         end if;
1728
      end if;
1729
   end Check_Elab_Assign;
1730
 
1731
   ----------------------
1732
   -- Check_Elab_Calls --
1733
   ----------------------
1734
 
1735
   procedure Check_Elab_Calls is
1736
   begin
1737
      --  If expansion is disabled, do not generate any checks. Also skip
1738
      --  checks if any subunits are missing because in either case we lack the
1739
      --  full information that we need, and no object file will be created in
1740
      --  any case.
1741
 
1742
      if not Expander_Active
1743
        or else Is_Generic_Unit (Cunit_Entity (Main_Unit))
1744
        or else Subunits_Missing
1745
      then
1746
         return;
1747
      end if;
1748
 
1749
      --  Skip delayed calls if we had any errors
1750
 
1751
      if Serious_Errors_Detected = 0 then
1752
         Delaying_Elab_Checks := False;
1753
         Expander_Mode_Save_And_Set (True);
1754
 
1755
         for J in Delay_Check.First .. Delay_Check.Last loop
1756
            Push_Scope (Delay_Check.Table (J).Curscop);
1757
            From_Elab_Code := Delay_Check.Table (J).From_Elab_Code;
1758
 
1759
            Check_Internal_Call_Continue (
1760
              N           => Delay_Check.Table (J).N,
1761
              E           => Delay_Check.Table (J).E,
1762
              Outer_Scope => Delay_Check.Table (J).Outer_Scope,
1763
              Orig_Ent    => Delay_Check.Table (J).Orig_Ent);
1764
 
1765
            Pop_Scope;
1766
         end loop;
1767
 
1768
         --  Set Delaying_Elab_Checks back on for next main compilation
1769
 
1770
         Expander_Mode_Restore;
1771
         Delaying_Elab_Checks := True;
1772
      end if;
1773
   end Check_Elab_Calls;
1774
 
1775
   ------------------------------
1776
   -- Check_Elab_Instantiation --
1777
   ------------------------------
1778
 
1779
   procedure Check_Elab_Instantiation
1780
     (N           : Node_Id;
1781
      Outer_Scope : Entity_Id := Empty)
1782
   is
1783
      Ent : Entity_Id;
1784
 
1785
   begin
1786
      --  Check for and deal with bad instantiation case. There is some
1787
      --  duplicated code here, but we will worry about this later ???
1788
 
1789
      Check_Bad_Instantiation (N);
1790
 
1791
      if ABE_Is_Certain (N) then
1792
         return;
1793
      end if;
1794
 
1795
      --  Nothing to do if we do not have an instantiation (happens in some
1796
      --  error cases, and also in the formal package declaration case)
1797
 
1798
      if Nkind (N) not in N_Generic_Instantiation then
1799
         return;
1800
      end if;
1801
 
1802
      --  Nothing to do if inside a generic template
1803
 
1804
      if Inside_A_Generic then
1805
         return;
1806
      end if;
1807
 
1808
      --  Nothing to do if the instantiation is not in the main unit
1809
 
1810
      if not In_Extended_Main_Code_Unit (N) then
1811
         return;
1812
      end if;
1813
 
1814
      Ent := Get_Generic_Entity (N);
1815
      From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit;
1816
 
1817
      --  See if we need to analyze this instantiation. We analyze it if
1818
      --  either of the following conditions is met:
1819
 
1820
      --    It is an inner level instantiation (since in this case it was
1821
      --    triggered by an outer level call from elaboration code), but
1822
      --    only if the instantiation is within the scope of the original
1823
      --    outer level call.
1824
 
1825
      --    It is an outer level instantiation from elaboration code, or the
1826
      --    instantiated entity is in the same elaboration scope.
1827
 
1828
      --  And in these cases, we will check both the inter-unit case and
1829
      --  the intra-unit (within a single unit) case.
1830
 
1831
      C_Scope := Current_Scope;
1832
 
1833
      if Present (Outer_Scope)
1834
        and then Within (Scope (Ent), Outer_Scope)
1835
      then
1836
         Set_C_Scope;
1837
         Check_A_Call (N, Ent, Outer_Scope, Inter_Unit_Only => False);
1838
 
1839
      elsif From_Elab_Code then
1840
         Set_C_Scope;
1841
         Check_A_Call (N, Ent, Standard_Standard, Inter_Unit_Only => False);
1842
 
1843
      elsif Same_Elaboration_Scope (C_Scope, Scope (Ent)) then
1844
         Set_C_Scope;
1845
         Check_A_Call (N, Ent, Scope (Ent), Inter_Unit_Only => False);
1846
 
1847
      --  If none of those cases holds, but Dynamic_Elaboration_Checks mode is
1848
      --  set, then we will do the check, but only in the inter-unit case (this
1849
      --  is to accommodate unguarded elaboration calls from other units in
1850
      --  which this same mode is set). We inhibit warnings in this case, since
1851
      --  this instantiation is not occurring in elaboration code.
1852
 
1853
      elsif Dynamic_Elaboration_Checks then
1854
         Set_C_Scope;
1855
         Check_A_Call
1856
           (N,
1857
            Ent,
1858
            Standard_Standard,
1859
            Inter_Unit_Only => True,
1860
            Generate_Warnings => False);
1861
 
1862
      else
1863
         return;
1864
      end if;
1865
   end Check_Elab_Instantiation;
1866
 
1867
   -------------------------
1868
   -- Check_Internal_Call --
1869
   -------------------------
1870
 
1871
   procedure Check_Internal_Call
1872
     (N           : Node_Id;
1873
      E           : Entity_Id;
1874
      Outer_Scope : Entity_Id;
1875
      Orig_Ent    : Entity_Id)
1876
   is
1877
      Inst_Case : constant Boolean := Nkind (N) in N_Generic_Instantiation;
1878
 
1879
   begin
1880
      --  If not function or procedure call or instantiation, then ignore
1881
      --  call (this happens in some error case and rewriting cases)
1882
 
1883
      if Nkind (N) /= N_Function_Call
1884
           and then
1885
         Nkind (N) /= N_Procedure_Call_Statement
1886
           and then
1887
         not Inst_Case
1888
      then
1889
         return;
1890
 
1891
      --  Nothing to do if this is a call or instantiation that has
1892
      --  already been found to be a sure ABE
1893
 
1894
      elsif ABE_Is_Certain (N) then
1895
         return;
1896
 
1897
      --  Nothing to do if errors already detected (avoid cascaded errors)
1898
 
1899
      elsif Serious_Errors_Detected /= 0 then
1900
         return;
1901
 
1902
      --  Nothing to do if not in full analysis mode
1903
 
1904
      elsif not Full_Analysis then
1905
         return;
1906
 
1907
      --  Nothing to do if analyzing in special spec-expression mode, since the
1908
      --  call is not actually being made at this time.
1909
 
1910
      elsif In_Spec_Expression then
1911
         return;
1912
 
1913
      --  Nothing to do for call to intrinsic subprogram
1914
 
1915
      elsif Is_Intrinsic_Subprogram (E) then
1916
         return;
1917
 
1918
      --  No need to trace local calls if checking task activation, because
1919
      --  other local bodies are elaborated already.
1920
 
1921
      elsif In_Task_Activation then
1922
         return;
1923
 
1924
      --  Nothing to do if call is within a generic unit
1925
 
1926
      elsif Inside_A_Generic then
1927
         return;
1928
      end if;
1929
 
1930
      --  Delay this call if we are still delaying calls
1931
 
1932
      if Delaying_Elab_Checks then
1933
         Delay_Check.Append (
1934
           (N              => N,
1935
            E              => E,
1936
            Orig_Ent       => Orig_Ent,
1937
            Curscop        => Current_Scope,
1938
            Outer_Scope    => Outer_Scope,
1939
            From_Elab_Code => From_Elab_Code));
1940
         return;
1941
 
1942
      --  Otherwise, call phase 2 continuation right now
1943
 
1944
      else
1945
         Check_Internal_Call_Continue (N, E, Outer_Scope, Orig_Ent);
1946
      end if;
1947
   end Check_Internal_Call;
1948
 
1949
   ----------------------------------
1950
   -- Check_Internal_Call_Continue --
1951
   ----------------------------------
1952
 
1953
   procedure Check_Internal_Call_Continue
1954
     (N           : Node_Id;
1955
      E           : Entity_Id;
1956
      Outer_Scope : Entity_Id;
1957
      Orig_Ent    : Entity_Id)
1958
   is
1959
      Loc       : constant Source_Ptr := Sloc (N);
1960
      Inst_Case : constant Boolean := Is_Generic_Unit (E);
1961
 
1962
      Sbody : Node_Id;
1963
      Ebody : Entity_Id;
1964
 
1965
      function Find_Elab_Reference (N : Node_Id) return Traverse_Result;
1966
      --  Function applied to each node as we traverse the body. Checks for
1967
      --  call or entity reference that needs checking, and if so checks it.
1968
      --  Always returns OK, so entire tree is traversed, except that as
1969
      --  described below subprogram bodies are skipped for now.
1970
 
1971
      procedure Traverse is new Atree.Traverse_Proc (Find_Elab_Reference);
1972
      --  Traverse procedure using above Find_Elab_Reference function
1973
 
1974
      -------------------------
1975
      -- Find_Elab_Reference --
1976
      -------------------------
1977
 
1978
      function Find_Elab_Reference (N : Node_Id) return Traverse_Result is
1979
         Actual : Node_Id;
1980
 
1981
      begin
1982
         --  If user has specified that there are no entry calls in elaboration
1983
         --  code, do not trace past an accept statement, because the rendez-
1984
         --  vous will happen after elaboration.
1985
 
1986
         if (Nkind (Original_Node (N)) = N_Accept_Statement
1987
              or else Nkind (Original_Node (N)) = N_Selective_Accept)
1988
           and then Restriction_Active (No_Entry_Calls_In_Elaboration_Code)
1989
         then
1990
            return Abandon;
1991
 
1992
            --  If we have a function call, check it
1993
 
1994
         elsif Nkind (N) = N_Function_Call then
1995
            Check_Elab_Call (N, Outer_Scope);
1996
            return OK;
1997
 
1998
         --  If we have a procedure call, check the call, and also check
1999
         --  arguments that are assignments (OUT or IN OUT mode formals).
2000
 
2001
         elsif Nkind (N) = N_Procedure_Call_Statement then
2002
            Check_Elab_Call (N, Outer_Scope, In_Init_Proc => Is_Init_Proc (E));
2003
 
2004
            Actual := First_Actual (N);
2005
            while Present (Actual) loop
2006
               if Known_To_Be_Assigned (Actual) then
2007
                  Check_Elab_Assign (Actual);
2008
               end if;
2009
 
2010
               Next_Actual (Actual);
2011
            end loop;
2012
 
2013
            return OK;
2014
 
2015
         --  If we have a generic instantiation, check it
2016
 
2017
         elsif Nkind (N) in N_Generic_Instantiation then
2018
            Check_Elab_Instantiation (N, Outer_Scope);
2019
            return OK;
2020
 
2021
         --  Skip subprogram bodies that come from source (wait for call to
2022
         --  analyze these). The reason for the come from source test is to
2023
         --  avoid catching task bodies.
2024
 
2025
         --  For task bodies, we should really avoid these too, waiting for the
2026
         --  task activation, but that's too much trouble to catch for now, so
2027
         --  we go in unconditionally. This is not so terrible, it means the
2028
         --  error backtrace is not quite complete, and we are too eager to
2029
         --  scan bodies of tasks that are unused, but this is hardly very
2030
         --  significant!
2031
 
2032
         elsif Nkind (N) = N_Subprogram_Body
2033
           and then Comes_From_Source (N)
2034
         then
2035
            return Skip;
2036
 
2037
         elsif Nkind (N) = N_Assignment_Statement
2038
           and then Comes_From_Source (N)
2039
         then
2040
            Check_Elab_Assign (Name (N));
2041
            return OK;
2042
 
2043
         else
2044
            return OK;
2045
         end if;
2046
      end Find_Elab_Reference;
2047
 
2048
   --  Start of processing for Check_Internal_Call_Continue
2049
 
2050
   begin
2051
      --  Save outer level call if at outer level
2052
 
2053
      if Elab_Call.Last = 0 then
2054
         Outer_Level_Sloc := Loc;
2055
      end if;
2056
 
2057
      Elab_Visited.Append (E);
2058
 
2059
      --  If the call is to a function that renames a literal, no check
2060
      --  is needed.
2061
 
2062
      if Ekind (E) = E_Enumeration_Literal then
2063
         return;
2064
      end if;
2065
 
2066
      Sbody := Unit_Declaration_Node (E);
2067
 
2068
      if Nkind (Sbody) /= N_Subprogram_Body
2069
           and then
2070
         Nkind (Sbody) /= N_Package_Body
2071
      then
2072
         Ebody := Corresponding_Body (Sbody);
2073
 
2074
         if No (Ebody) then
2075
            return;
2076
         else
2077
            Sbody := Unit_Declaration_Node (Ebody);
2078
         end if;
2079
      end if;
2080
 
2081
      --  If the body appears after the outer level call or instantiation then
2082
      --  we have an error case handled below.
2083
 
2084
      if Earlier_In_Extended_Unit (Outer_Level_Sloc, Sloc (Sbody))
2085
        and then not In_Task_Activation
2086
      then
2087
         null;
2088
 
2089
      --  If we have the instantiation case we are done, since we now
2090
      --  know that the body of the generic appeared earlier.
2091
 
2092
      elsif Inst_Case then
2093
         return;
2094
 
2095
      --  Otherwise we have a call, so we trace through the called body to see
2096
      --  if it has any problems.
2097
 
2098
      else
2099
         pragma Assert (Nkind (Sbody) = N_Subprogram_Body);
2100
 
2101
         Elab_Call.Append ((Cloc => Loc, Ent => E));
2102
 
2103
         if Debug_Flag_LL then
2104
            Write_Str ("Elab_Call.Last = ");
2105
            Write_Int (Int (Elab_Call.Last));
2106
            Write_Str ("   Ent = ");
2107
            Write_Name (Chars (E));
2108
            Write_Str ("   at ");
2109
            Write_Location (Sloc (N));
2110
            Write_Eol;
2111
         end if;
2112
 
2113
         --  Now traverse declarations and statements of subprogram body. Note
2114
         --  that we cannot simply Traverse (Sbody), since traverse does not
2115
         --  normally visit subprogram bodies.
2116
 
2117
         declare
2118
            Decl : Node_Id;
2119
         begin
2120
            Decl := First (Declarations (Sbody));
2121
            while Present (Decl) loop
2122
               Traverse (Decl);
2123
               Next (Decl);
2124
            end loop;
2125
         end;
2126
 
2127
         Traverse (Handled_Statement_Sequence (Sbody));
2128
 
2129
         Elab_Call.Decrement_Last;
2130
         return;
2131
      end if;
2132
 
2133
      --  Here is the case of calling a subprogram where the body has not yet
2134
      --  been encountered. A warning message is needed, except if this is the
2135
      --  case of appearing within an aspect specification that results in
2136
      --  a check call, we do not really have such a situation, so no warning
2137
      --  is needed (e.g. the case of a precondition, where the call appears
2138
      --  textually before the body, but in actual fact is moved to the
2139
      --  appropriate subprogram body and so does not need a check).
2140
 
2141
      declare
2142
         P : Node_Id;
2143
      begin
2144
         P := Parent (N);
2145
         loop
2146
            if Nkind (P) in N_Subexpr then
2147
               P := Parent (P);
2148
            elsif Nkind (P) = N_If_Statement
2149
              and then Nkind (Original_Node (P)) = N_Pragma
2150
              and then Present (Corresponding_Aspect (Original_Node (P)))
2151
            then
2152
               return;
2153
            else
2154
               exit;
2155
            end if;
2156
         end loop;
2157
      end;
2158
 
2159
      --  Not that special case, warning and dynamic check is required
2160
 
2161
      --  If we have nothing in the call stack, then this is at the outer
2162
      --  level, and the ABE is bound to occur.
2163
 
2164
      if Elab_Call.Last = 0 then
2165
         if Inst_Case then
2166
            Error_Msg_NE
2167
              ("?cannot instantiate& before body seen", N, Orig_Ent);
2168
         else
2169
            Error_Msg_NE
2170
              ("?cannot call& before body seen", N, Orig_Ent);
2171
         end if;
2172
 
2173
         Error_Msg_N
2174
           ("\?Program_Error will be raised at run time", N);
2175
         Insert_Elab_Check (N);
2176
 
2177
      --  Call is not at outer level
2178
 
2179
      else
2180
         --  Deal with dynamic elaboration check
2181
 
2182
         if not Elaboration_Checks_Suppressed (E) then
2183
            Set_Elaboration_Entity_Required (E);
2184
 
2185
            --  Case of no elaboration entity allocated yet
2186
 
2187
            if No (Elaboration_Entity (E)) then
2188
 
2189
               --  Create object declaration for elaboration entity, and put it
2190
               --  just in front of the spec of the subprogram or generic unit,
2191
               --  in the same scope as this unit.
2192
 
2193
               declare
2194
                  Loce : constant Source_Ptr := Sloc (E);
2195
                  Ent  : constant Entity_Id  :=
2196
                           Make_Defining_Identifier (Loc,
2197
                             Chars => New_External_Name (Chars (E), 'E'));
2198
 
2199
               begin
2200
                  Set_Elaboration_Entity (E, Ent);
2201
                  Push_Scope (Scope (E));
2202
 
2203
                  Insert_Action (Declaration_Node (E),
2204
                    Make_Object_Declaration (Loce,
2205
                      Defining_Identifier => Ent,
2206
                      Object_Definition   =>
2207
                        New_Occurrence_Of (Standard_Short_Integer, Loce),
2208
                      Expression          =>
2209
                        Make_Integer_Literal (Loc, Uint_0)));
2210
 
2211
                  --  Set elaboration flag at the point of the body
2212
 
2213
                  Set_Elaboration_Flag (Sbody, E);
2214
 
2215
                  --  Kill current value indication. This is necessary because
2216
                  --  the tests of this flag are inserted out of sequence and
2217
                  --  must not pick up bogus indications of the wrong constant
2218
                  --  value. Also, this is never a true constant, since one way
2219
                  --  or another, it gets reset.
2220
 
2221
                  Set_Current_Value    (Ent, Empty);
2222
                  Set_Last_Assignment  (Ent, Empty);
2223
                  Set_Is_True_Constant (Ent, False);
2224
                  Pop_Scope;
2225
               end;
2226
            end if;
2227
 
2228
            --  Generate check of the elaboration counter
2229
 
2230
            Insert_Elab_Check (N,
2231
               Make_Attribute_Reference (Loc,
2232
                 Attribute_Name => Name_Elaborated,
2233
                 Prefix         => New_Occurrence_Of (E, Loc)));
2234
         end if;
2235
 
2236
         --  Generate the warning
2237
 
2238
         if not Suppress_Elaboration_Warnings (E)
2239
           and then not Elaboration_Checks_Suppressed (E)
2240
         then
2241
            if Inst_Case then
2242
               Error_Msg_NE
2243
                 ("instantiation of& may occur before body is seen?",
2244
                  N, Orig_Ent);
2245
            else
2246
               Error_Msg_NE
2247
                 ("call to& may occur before body is seen?", N, Orig_Ent);
2248
            end if;
2249
 
2250
            Error_Msg_N
2251
              ("\Program_Error may be raised at run time?", N);
2252
 
2253
            Output_Calls (N);
2254
         end if;
2255
      end if;
2256
 
2257
      --  Set flag to suppress further warnings on same subprogram
2258
      --  unless in all errors mode
2259
 
2260
      if not All_Errors_Mode then
2261
         Set_Suppress_Elaboration_Warnings (E);
2262
      end if;
2263
   end Check_Internal_Call_Continue;
2264
 
2265
   ---------------------------
2266
   -- Check_Task_Activation --
2267
   ---------------------------
2268
 
2269
   procedure Check_Task_Activation (N : Node_Id) is
2270
      Loc         : constant Source_Ptr := Sloc (N);
2271
      Inter_Procs : constant Elist_Id   := New_Elmt_List;
2272
      Intra_Procs : constant Elist_Id   := New_Elmt_List;
2273
      Ent         : Entity_Id;
2274
      P           : Entity_Id;
2275
      Task_Scope  : Entity_Id;
2276
      Cunit_SC    : Boolean := False;
2277
      Decl        : Node_Id;
2278
      Elmt        : Elmt_Id;
2279
      Enclosing   : Entity_Id;
2280
 
2281
      procedure Add_Task_Proc (Typ : Entity_Id);
2282
      --  Add to Task_Procs the task body procedure(s) of task types in Typ.
2283
      --  For record types, this procedure recurses over component types.
2284
 
2285
      procedure Collect_Tasks (Decls : List_Id);
2286
      --  Collect the types of the tasks that are to be activated in the given
2287
      --  list of declarations, in order to perform elaboration checks on the
2288
      --  corresponding task procedures which are called implicitly here.
2289
 
2290
      function Outer_Unit (E : Entity_Id) return Entity_Id;
2291
      --  find enclosing compilation unit of Entity, ignoring subunits, or
2292
      --  else enclosing subprogram. If E is not a package, there is no need
2293
      --  for inter-unit elaboration checks.
2294
 
2295
      -------------------
2296
      -- Add_Task_Proc --
2297
      -------------------
2298
 
2299
      procedure Add_Task_Proc (Typ : Entity_Id) is
2300
         Comp : Entity_Id;
2301
         Proc : Entity_Id := Empty;
2302
 
2303
      begin
2304
         if Is_Task_Type (Typ) then
2305
            Proc := Get_Task_Body_Procedure (Typ);
2306
 
2307
         elsif Is_Array_Type (Typ)
2308
           and then Has_Task (Base_Type (Typ))
2309
         then
2310
            Add_Task_Proc (Component_Type (Typ));
2311
 
2312
         elsif Is_Record_Type (Typ)
2313
           and then Has_Task (Base_Type (Typ))
2314
         then
2315
            Comp := First_Component (Typ);
2316
            while Present (Comp) loop
2317
               Add_Task_Proc (Etype (Comp));
2318
               Comp := Next_Component (Comp);
2319
            end loop;
2320
         end if;
2321
 
2322
         --  If the task type is another unit, we will perform the usual
2323
         --  elaboration check on its enclosing unit. If the type is in the
2324
         --  same unit, we can trace the task body as for an internal call,
2325
         --  but we only need to examine other external calls, because at
2326
         --  the point the task is activated, internal subprogram bodies
2327
         --  will have been elaborated already. We keep separate lists for
2328
         --  each kind of task.
2329
 
2330
         --  Skip this test if errors have occurred, since in this case
2331
         --  we can get false indications.
2332
 
2333
         if Serious_Errors_Detected /= 0 then
2334
            return;
2335
         end if;
2336
 
2337
         if Present (Proc) then
2338
            if Outer_Unit (Scope (Proc)) = Enclosing then
2339
 
2340
               if No (Corresponding_Body (Unit_Declaration_Node (Proc)))
2341
                 and then
2342
                   (not Is_Generic_Instance (Scope (Proc))
2343
                      or else
2344
                    Scope (Proc) = Scope (Defining_Identifier (Decl)))
2345
               then
2346
                  Error_Msg_N
2347
                    ("task will be activated before elaboration of its body?",
2348
                      Decl);
2349
                  Error_Msg_N
2350
                    ("\Program_Error will be raised at run time?", Decl);
2351
 
2352
               elsif
2353
                 Present (Corresponding_Body (Unit_Declaration_Node (Proc)))
2354
               then
2355
                  Append_Elmt (Proc, Intra_Procs);
2356
               end if;
2357
 
2358
            else
2359
               --  No need for multiple entries of the same type
2360
 
2361
               Elmt := First_Elmt (Inter_Procs);
2362
               while Present (Elmt) loop
2363
                  if Node (Elmt) = Proc then
2364
                     return;
2365
                  end if;
2366
 
2367
                  Next_Elmt (Elmt);
2368
               end loop;
2369
 
2370
               Append_Elmt (Proc, Inter_Procs);
2371
            end if;
2372
         end if;
2373
      end Add_Task_Proc;
2374
 
2375
      -------------------
2376
      -- Collect_Tasks --
2377
      -------------------
2378
 
2379
      procedure Collect_Tasks (Decls : List_Id) is
2380
      begin
2381
         if Present (Decls) then
2382
            Decl := First (Decls);
2383
            while Present (Decl) loop
2384
               if Nkind (Decl) = N_Object_Declaration
2385
                 and then Has_Task (Etype (Defining_Identifier (Decl)))
2386
               then
2387
                  Add_Task_Proc (Etype (Defining_Identifier (Decl)));
2388
               end if;
2389
 
2390
               Next (Decl);
2391
            end loop;
2392
         end if;
2393
      end Collect_Tasks;
2394
 
2395
      ----------------
2396
      -- Outer_Unit --
2397
      ----------------
2398
 
2399
      function Outer_Unit (E : Entity_Id) return Entity_Id is
2400
         Outer : Entity_Id;
2401
 
2402
      begin
2403
         Outer := E;
2404
         while Present (Outer) loop
2405
            if Elaboration_Checks_Suppressed (Outer) then
2406
               Cunit_SC := True;
2407
            end if;
2408
 
2409
            exit when Is_Child_Unit (Outer)
2410
              or else Scope (Outer) = Standard_Standard
2411
              or else Ekind (Outer) /= E_Package;
2412
            Outer := Scope (Outer);
2413
         end loop;
2414
 
2415
         return Outer;
2416
      end Outer_Unit;
2417
 
2418
   --  Start of processing for Check_Task_Activation
2419
 
2420
   begin
2421
      Enclosing := Outer_Unit (Current_Scope);
2422
 
2423
      --  Find all tasks declared in the current unit
2424
 
2425
      if Nkind (N) = N_Package_Body then
2426
         P := Unit_Declaration_Node (Corresponding_Spec (N));
2427
 
2428
         Collect_Tasks (Declarations (N));
2429
         Collect_Tasks (Visible_Declarations (Specification (P)));
2430
         Collect_Tasks (Private_Declarations (Specification (P)));
2431
 
2432
      elsif Nkind (N) = N_Package_Declaration then
2433
         Collect_Tasks (Visible_Declarations (Specification (N)));
2434
         Collect_Tasks (Private_Declarations (Specification (N)));
2435
 
2436
      else
2437
         Collect_Tasks (Declarations (N));
2438
      end if;
2439
 
2440
      --  We only perform detailed checks in all tasks are library level
2441
      --  entities. If the master is a subprogram or task, activation will
2442
      --  depend on the activation of the master itself.
2443
 
2444
      --  Should dynamic checks be added in the more general case???
2445
 
2446
      if Ekind (Enclosing) /= E_Package then
2447
         return;
2448
      end if;
2449
 
2450
      --  For task types defined in other units, we want the unit containing
2451
      --  the task body to be elaborated before the current one.
2452
 
2453
      Elmt := First_Elmt (Inter_Procs);
2454
      while Present (Elmt) loop
2455
         Ent := Node (Elmt);
2456
         Task_Scope := Outer_Unit (Scope (Ent));
2457
 
2458
         if not Is_Compilation_Unit (Task_Scope) then
2459
            null;
2460
 
2461
         elsif Suppress_Elaboration_Warnings (Task_Scope)
2462
           or else Elaboration_Checks_Suppressed (Task_Scope)
2463
         then
2464
            null;
2465
 
2466
         elsif Dynamic_Elaboration_Checks then
2467
            if not Elaboration_Checks_Suppressed (Ent)
2468
              and then not Cunit_SC
2469
              and then
2470
                not Restriction_Active (No_Entry_Calls_In_Elaboration_Code)
2471
            then
2472
               --  Runtime elaboration check required. Generate check of the
2473
               --  elaboration counter for the unit containing the entity.
2474
 
2475
               Insert_Elab_Check (N,
2476
                 Make_Attribute_Reference (Loc,
2477
                   Attribute_Name => Name_Elaborated,
2478
                   Prefix =>
2479
                     New_Occurrence_Of (Spec_Entity (Task_Scope), Loc)));
2480
            end if;
2481
 
2482
         else
2483
            --  Force the binder to elaborate other unit first
2484
 
2485
            if not Suppress_Elaboration_Warnings (Ent)
2486
              and then not Elaboration_Checks_Suppressed (Ent)
2487
              and then Elab_Warnings
2488
              and then not Suppress_Elaboration_Warnings (Task_Scope)
2489
              and then not Elaboration_Checks_Suppressed (Task_Scope)
2490
            then
2491
               Error_Msg_Node_2 := Task_Scope;
2492
               Error_Msg_NE
2493
                 ("activation of an instance of task type&" &
2494
                  " requires pragma Elaborate_All on &?", N, Ent);
2495
            end if;
2496
 
2497
            Activate_Elaborate_All_Desirable (N, Task_Scope);
2498
            Set_Suppress_Elaboration_Warnings (Task_Scope);
2499
         end if;
2500
 
2501
         Next_Elmt (Elmt);
2502
      end loop;
2503
 
2504
      --  For tasks declared in the current unit, trace other calls within
2505
      --  the task procedure bodies, which are available.
2506
 
2507
      In_Task_Activation := True;
2508
 
2509
      Elmt := First_Elmt (Intra_Procs);
2510
      while Present (Elmt) loop
2511
         Ent := Node (Elmt);
2512
         Check_Internal_Call_Continue (N, Ent, Enclosing, Ent);
2513
         Next_Elmt (Elmt);
2514
      end loop;
2515
 
2516
      In_Task_Activation := False;
2517
   end Check_Task_Activation;
2518
 
2519
   --------------------------------
2520
   -- Set_Elaboration_Constraint --
2521
   --------------------------------
2522
 
2523
   procedure Set_Elaboration_Constraint
2524
    (Call : Node_Id;
2525
     Subp : Entity_Id;
2526
     Scop : Entity_Id)
2527
   is
2528
      Elab_Unit  : Entity_Id;
2529
      Init_Call  : constant Boolean :=
2530
                     Chars (Subp) = Name_Initialize
2531
                       and then Comes_From_Source (Subp)
2532
                       and then Present (Parameter_Associations (Call))
2533
                       and then Is_Controlled (Etype (First_Actual (Call)));
2534
   begin
2535
      --  If the unit is mentioned in a with_clause of the current unit, it is
2536
      --  visible, and we can set the elaboration flag.
2537
 
2538
      if Is_Immediately_Visible (Scop)
2539
        or else (Is_Child_Unit (Scop) and then Is_Visible_Child_Unit (Scop))
2540
      then
2541
         Activate_Elaborate_All_Desirable (Call, Scop);
2542
         Set_Suppress_Elaboration_Warnings (Scop, True);
2543
         return;
2544
      end if;
2545
 
2546
      --  If this is not an initialization call or a call using object notation
2547
      --  we know that the unit of the called entity is in the context, and
2548
      --  we can set the flag as well. The unit need not be visible if the call
2549
      --  occurs within an instantiation.
2550
 
2551
      if Is_Init_Proc (Subp)
2552
        or else Init_Call
2553
        or else Nkind (Original_Node (Call)) = N_Selected_Component
2554
      then
2555
         null;  --  detailed processing follows.
2556
 
2557
      else
2558
         Activate_Elaborate_All_Desirable (Call, Scop);
2559
         Set_Suppress_Elaboration_Warnings (Scop, True);
2560
         return;
2561
      end if;
2562
 
2563
      --  If the unit is not in the context, there must be an intermediate unit
2564
      --  that is, on which we need to place to elaboration flag. This happens
2565
      --  with init proc calls.
2566
 
2567
      if Is_Init_Proc (Subp)
2568
        or else Init_Call
2569
      then
2570
         --  The initialization call is on an object whose type is not declared
2571
         --  in the same scope as the subprogram. The type of the object must
2572
         --  be a subtype of the type of operation. This object is the first
2573
         --  actual in the call.
2574
 
2575
         declare
2576
            Typ : constant Entity_Id :=
2577
                    Etype (First (Parameter_Associations (Call)));
2578
         begin
2579
            Elab_Unit := Scope (Typ);
2580
            while (Present (Elab_Unit))
2581
              and then not Is_Compilation_Unit (Elab_Unit)
2582
            loop
2583
               Elab_Unit := Scope (Elab_Unit);
2584
            end loop;
2585
         end;
2586
 
2587
      --  If original node uses selected component notation, the prefix is
2588
      --  visible and determines the scope that must be elaborated. After
2589
      --  rewriting, the prefix is the first actual in the call.
2590
 
2591
      elsif Nkind (Original_Node (Call)) = N_Selected_Component then
2592
         Elab_Unit := Scope (Etype (First (Parameter_Associations (Call))));
2593
 
2594
      --  Not one of special cases above
2595
 
2596
      else
2597
         --  Using previously computed scope. If the elaboration check is
2598
         --  done after analysis, the scope is not visible any longer, but
2599
         --  must still be in the context.
2600
 
2601
         Elab_Unit := Scop;
2602
      end if;
2603
 
2604
      Activate_Elaborate_All_Desirable (Call, Elab_Unit);
2605
      Set_Suppress_Elaboration_Warnings (Elab_Unit, True);
2606
   end Set_Elaboration_Constraint;
2607
 
2608
   ----------------------
2609
   -- Has_Generic_Body --
2610
   ----------------------
2611
 
2612
   function Has_Generic_Body (N : Node_Id) return Boolean is
2613
      Ent  : constant Entity_Id := Get_Generic_Entity (N);
2614
      Decl : constant Node_Id   := Unit_Declaration_Node (Ent);
2615
      Scop : Entity_Id;
2616
 
2617
      function Find_Body_In (E : Entity_Id; N : Node_Id) return Node_Id;
2618
      --  Determine if the list of nodes headed by N and linked by Next
2619
      --  contains a package body for the package spec entity E, and if so
2620
      --  return the package body. If not, then returns Empty.
2621
 
2622
      function Load_Package_Body (Nam : Unit_Name_Type) return Node_Id;
2623
      --  This procedure is called load the unit whose name is given by Nam.
2624
      --  This unit is being loaded to see whether it contains an optional
2625
      --  generic body. The returned value is the loaded unit, which is always
2626
      --  a package body (only package bodies can contain other entities in the
2627
      --  sense in which Has_Generic_Body is interested). We only attempt to
2628
      --  load bodies if we are generating code. If we are in semantics check
2629
      --  only mode, then it would be wrong to load bodies that are not
2630
      --  required from a semantic point of view, so in this case we return
2631
      --  Empty. The result is that the caller may incorrectly decide that a
2632
      --  generic spec does not have a body when in fact it does, but the only
2633
      --  harm in this is that some warnings on elaboration problems may be
2634
      --  lost in semantic checks only mode, which is not big loss. We also
2635
      --  return Empty if we go for a body and it is not there.
2636
 
2637
      function Locate_Corresponding_Body (PE : Entity_Id) return Node_Id;
2638
      --  PE is the entity for a package spec. This function locates the
2639
      --  corresponding package body, returning Empty if none is found. The
2640
      --  package body returned is fully parsed but may not yet be analyzed,
2641
      --  so only syntactic fields should be referenced.
2642
 
2643
      ------------------
2644
      -- Find_Body_In --
2645
      ------------------
2646
 
2647
      function Find_Body_In (E : Entity_Id; N : Node_Id) return Node_Id is
2648
         Nod : Node_Id;
2649
 
2650
      begin
2651
         Nod := N;
2652
         while Present (Nod) loop
2653
 
2654
            --  If we found the package body we are looking for, return it
2655
 
2656
            if Nkind (Nod) = N_Package_Body
2657
              and then Chars (Defining_Unit_Name (Nod)) = Chars (E)
2658
            then
2659
               return Nod;
2660
 
2661
            --  If we found the stub for the body, go after the subunit,
2662
            --  loading it if necessary.
2663
 
2664
            elsif Nkind (Nod) = N_Package_Body_Stub
2665
              and then Chars (Defining_Identifier (Nod)) = Chars (E)
2666
            then
2667
               if Present (Library_Unit (Nod)) then
2668
                  return Unit (Library_Unit (Nod));
2669
 
2670
               else
2671
                  return Load_Package_Body (Get_Unit_Name (Nod));
2672
               end if;
2673
 
2674
            --  If neither package body nor stub, keep looking on chain
2675
 
2676
            else
2677
               Next (Nod);
2678
            end if;
2679
         end loop;
2680
 
2681
         return Empty;
2682
      end Find_Body_In;
2683
 
2684
      -----------------------
2685
      -- Load_Package_Body --
2686
      -----------------------
2687
 
2688
      function Load_Package_Body (Nam : Unit_Name_Type) return Node_Id is
2689
         U : Unit_Number_Type;
2690
 
2691
      begin
2692
         if Operating_Mode /= Generate_Code then
2693
            return Empty;
2694
         else
2695
            U :=
2696
              Load_Unit
2697
                (Load_Name  => Nam,
2698
                 Required   => False,
2699
                 Subunit    => False,
2700
                 Error_Node => N);
2701
 
2702
            if U = No_Unit then
2703
               return Empty;
2704
            else
2705
               return Unit (Cunit (U));
2706
            end if;
2707
         end if;
2708
      end Load_Package_Body;
2709
 
2710
      -------------------------------
2711
      -- Locate_Corresponding_Body --
2712
      -------------------------------
2713
 
2714
      function Locate_Corresponding_Body (PE : Entity_Id) return Node_Id is
2715
         Spec  : constant Node_Id   := Declaration_Node (PE);
2716
         Decl  : constant Node_Id   := Parent (Spec);
2717
         Scop  : constant Entity_Id := Scope (PE);
2718
         PBody : Node_Id;
2719
 
2720
      begin
2721
         if Is_Library_Level_Entity (PE) then
2722
 
2723
            --  If package is a library unit that requires a body, we have no
2724
            --  choice but to go after that body because it might contain an
2725
            --  optional body for the original generic package.
2726
 
2727
            if Unit_Requires_Body (PE) then
2728
 
2729
               --  Load the body. Note that we are a little careful here to use
2730
               --  Spec to get the unit number, rather than PE or Decl, since
2731
               --  in the case where the package is itself a library level
2732
               --  instantiation, Spec will properly reference the generic
2733
               --  template, which is what we really want.
2734
 
2735
               return
2736
                 Load_Package_Body
2737
                   (Get_Body_Name (Unit_Name (Get_Source_Unit (Spec))));
2738
 
2739
            --  But if the package is a library unit that does NOT require
2740
            --  a body, then no body is permitted, so we are sure that there
2741
            --  is no body for the original generic package.
2742
 
2743
            else
2744
               return Empty;
2745
            end if;
2746
 
2747
         --  Otherwise look and see if we are embedded in a further package
2748
 
2749
         elsif Is_Package_Or_Generic_Package (Scop) then
2750
 
2751
            --  If so, get the body of the enclosing package, and look in
2752
            --  its package body for the package body we are looking for.
2753
 
2754
            PBody := Locate_Corresponding_Body (Scop);
2755
 
2756
            if No (PBody) then
2757
               return Empty;
2758
            else
2759
               return Find_Body_In (PE, First (Declarations (PBody)));
2760
            end if;
2761
 
2762
         --  If we are not embedded in a further package, then the body
2763
         --  must be in the same declarative part as we are.
2764
 
2765
         else
2766
            return Find_Body_In (PE, Next (Decl));
2767
         end if;
2768
      end Locate_Corresponding_Body;
2769
 
2770
   --  Start of processing for Has_Generic_Body
2771
 
2772
   begin
2773
      if Present (Corresponding_Body (Decl)) then
2774
         return True;
2775
 
2776
      elsif Unit_Requires_Body (Ent) then
2777
         return True;
2778
 
2779
      --  Compilation units cannot have optional bodies
2780
 
2781
      elsif Is_Compilation_Unit (Ent) then
2782
         return False;
2783
 
2784
      --  Otherwise look at what scope we are in
2785
 
2786
      else
2787
         Scop := Scope (Ent);
2788
 
2789
         --  Case of entity is in other than a package spec, in this case
2790
         --  the body, if present, must be in the same declarative part.
2791
 
2792
         if not Is_Package_Or_Generic_Package (Scop) then
2793
            declare
2794
               P : Node_Id;
2795
 
2796
            begin
2797
               --  Declaration node may get us a spec, so if so, go to
2798
               --  the parent declaration.
2799
 
2800
               P := Declaration_Node (Ent);
2801
               while not Is_List_Member (P) loop
2802
                  P := Parent (P);
2803
               end loop;
2804
 
2805
               return Present (Find_Body_In (Ent, Next (P)));
2806
            end;
2807
 
2808
         --  If the entity is in a package spec, then we have to locate
2809
         --  the corresponding package body, and look there.
2810
 
2811
         else
2812
            declare
2813
               PBody : constant Node_Id := Locate_Corresponding_Body (Scop);
2814
 
2815
            begin
2816
               if No (PBody) then
2817
                  return False;
2818
               else
2819
                  return
2820
                    Present
2821
                      (Find_Body_In (Ent, (First (Declarations (PBody)))));
2822
               end if;
2823
            end;
2824
         end if;
2825
      end if;
2826
   end Has_Generic_Body;
2827
 
2828
   -----------------------
2829
   -- Insert_Elab_Check --
2830
   -----------------------
2831
 
2832
   procedure Insert_Elab_Check (N : Node_Id; C : Node_Id := Empty) is
2833
      Nod : Node_Id;
2834
      Loc : constant Source_Ptr := Sloc (N);
2835
 
2836
   begin
2837
      --  If expansion is disabled, do not generate any checks. Also
2838
      --  skip checks if any subunits are missing because in either
2839
      --  case we lack the full information that we need, and no object
2840
      --  file will be created in any case.
2841
 
2842
      if not Expander_Active or else Subunits_Missing then
2843
         return;
2844
      end if;
2845
 
2846
      --  If we have a generic instantiation, where Instance_Spec is set,
2847
      --  then this field points to a generic instance spec that has
2848
      --  been inserted before the instantiation node itself, so that
2849
      --  is where we want to insert a check.
2850
 
2851
      if Nkind (N) in N_Generic_Instantiation
2852
        and then Present (Instance_Spec (N))
2853
      then
2854
         Nod := Instance_Spec (N);
2855
      else
2856
         Nod := N;
2857
      end if;
2858
 
2859
      --  If we are inserting at the top level, insert in Aux_Decls
2860
 
2861
      if Nkind (Parent (Nod)) = N_Compilation_Unit then
2862
         declare
2863
            ADN : constant Node_Id := Aux_Decls_Node (Parent (Nod));
2864
            R   : Node_Id;
2865
 
2866
         begin
2867
            if No (C) then
2868
               R :=
2869
                 Make_Raise_Program_Error (Loc,
2870
                   Reason => PE_Access_Before_Elaboration);
2871
            else
2872
               R :=
2873
                 Make_Raise_Program_Error (Loc,
2874
                   Condition => Make_Op_Not (Loc, C),
2875
                   Reason    => PE_Access_Before_Elaboration);
2876
            end if;
2877
 
2878
            if No (Declarations (ADN)) then
2879
               Set_Declarations (ADN, New_List (R));
2880
            else
2881
               Append_To (Declarations (ADN), R);
2882
            end if;
2883
 
2884
            Analyze (R);
2885
         end;
2886
 
2887
      --  Otherwise just insert before the node in question. However, if
2888
      --  the context of the call has already been analyzed, an insertion
2889
      --  will not work if it depends on subsequent expansion (e.g. a call in
2890
      --  a branch of a short-circuit). In that case we replace the call with
2891
      --  a conditional expression, or with a Raise if it is unconditional.
2892
      --  Unfortunately this does not work if the call has a dynamic size,
2893
      --  because gigi regards it as a dynamic-sized temporary. If such a call
2894
      --  appears in a short-circuit expression, the elaboration check will be
2895
      --  missed (rare enough ???). Otherwise, the code below inserts the check
2896
      --  at the appropriate place before the call. Same applies in the even
2897
      --  rarer case the return type has a known size but is unconstrained.
2898
 
2899
      else
2900
         if Nkind (N) = N_Function_Call
2901
           and then Analyzed (Parent (N))
2902
           and then Size_Known_At_Compile_Time (Etype (N))
2903
           and then
2904
            (not Has_Discriminants (Etype (N))
2905
              or else Is_Constrained (Etype (N)))
2906
 
2907
         then
2908
            declare
2909
               Typ : constant Entity_Id := Etype (N);
2910
               Chk : constant Boolean   := Do_Range_Check (N);
2911
 
2912
               R  : constant Node_Id :=
2913
                      Make_Raise_Program_Error (Loc,
2914
                         Reason => PE_Access_Before_Elaboration);
2915
 
2916
               Reloc_N : Node_Id;
2917
 
2918
            begin
2919
               Set_Etype (R, Typ);
2920
 
2921
               if No (C) then
2922
                  Rewrite (N, R);
2923
 
2924
               else
2925
                  Reloc_N := Relocate_Node (N);
2926
                  Save_Interps (N, Reloc_N);
2927
                  Rewrite (N,
2928
                    Make_Conditional_Expression (Loc,
2929
                      Expressions => New_List (C, Reloc_N, R)));
2930
               end if;
2931
 
2932
               Analyze_And_Resolve (N, Typ);
2933
 
2934
               --  If the original call requires a range check, so does the
2935
               --  conditional expression.
2936
 
2937
               if Chk then
2938
                  Enable_Range_Check (N);
2939
               else
2940
                  Set_Do_Range_Check (N, False);
2941
               end if;
2942
            end;
2943
 
2944
         else
2945
            if No (C) then
2946
               Insert_Action (Nod,
2947
                  Make_Raise_Program_Error (Loc,
2948
                    Reason => PE_Access_Before_Elaboration));
2949
            else
2950
               Insert_Action (Nod,
2951
                  Make_Raise_Program_Error (Loc,
2952
                    Condition =>
2953
                      Make_Op_Not (Loc,
2954
                        Right_Opnd => C),
2955
                    Reason => PE_Access_Before_Elaboration));
2956
            end if;
2957
         end if;
2958
      end if;
2959
   end Insert_Elab_Check;
2960
 
2961
   -------------------------------
2962
   -- Is_Finalization_Procedure --
2963
   -------------------------------
2964
 
2965
   function Is_Finalization_Procedure (Id : Entity_Id) return Boolean is
2966
   begin
2967
      --  Check whether Id is a procedure with at least one parameter
2968
 
2969
      if Ekind (Id) = E_Procedure
2970
        and then Present (First_Formal (Id))
2971
      then
2972
         declare
2973
            Typ      : constant Entity_Id := Etype (First_Formal (Id));
2974
            Deep_Fin : Entity_Id := Empty;
2975
            Fin      : Entity_Id := Empty;
2976
 
2977
         begin
2978
            --  If the type of the first formal does not require finalization
2979
            --  actions, then this is definitely not [Deep_]Finalize.
2980
 
2981
            if not Needs_Finalization (Typ) then
2982
               return False;
2983
            end if;
2984
 
2985
            --  At this point we have the following scenario:
2986
 
2987
            --    procedure Name (Param1 : [in] [out] Ctrl[; Param2 : ...]);
2988
 
2989
            --  Recover the two possible versions of [Deep_]Finalize using the
2990
            --  type of the first parameter and compare with the input.
2991
 
2992
            Deep_Fin := TSS (Typ, TSS_Deep_Finalize);
2993
 
2994
            if Is_Controlled (Typ) then
2995
               Fin := Find_Prim_Op (Typ, Name_Finalize);
2996
            end if;
2997
 
2998
            return
2999
                (Present (Deep_Fin) and then Id = Deep_Fin)
3000
              or else
3001
                (Present (Fin) and then Id = Fin);
3002
         end;
3003
      end if;
3004
 
3005
      return False;
3006
   end Is_Finalization_Procedure;
3007
 
3008
   ------------------
3009
   -- Output_Calls --
3010
   ------------------
3011
 
3012
   procedure Output_Calls (N : Node_Id) is
3013
      Ent : Entity_Id;
3014
 
3015
      function Is_Printable_Error_Name (Nm : Name_Id) return Boolean;
3016
      --  An internal function, used to determine if a name, Nm, is either
3017
      --  a non-internal name, or is an internal name that is printable
3018
      --  by the error message circuits (i.e. it has a single upper
3019
      --  case letter at the end).
3020
 
3021
      function Is_Printable_Error_Name (Nm : Name_Id) return Boolean is
3022
      begin
3023
         if not Is_Internal_Name (Nm) then
3024
            return True;
3025
 
3026
         elsif Name_Len = 1 then
3027
            return False;
3028
 
3029
         else
3030
            Name_Len := Name_Len - 1;
3031
            return not Is_Internal_Name;
3032
         end if;
3033
      end Is_Printable_Error_Name;
3034
 
3035
   --  Start of processing for Output_Calls
3036
 
3037
   begin
3038
      for J in reverse 1 .. Elab_Call.Last loop
3039
         Error_Msg_Sloc := Elab_Call.Table (J).Cloc;
3040
 
3041
         Ent := Elab_Call.Table (J).Ent;
3042
 
3043
         if Is_Generic_Unit (Ent) then
3044
            Error_Msg_NE ("\?& instantiated #", N, Ent);
3045
 
3046
         elsif Is_Init_Proc (Ent) then
3047
            Error_Msg_N ("\?initialization procedure called #", N);
3048
 
3049
         elsif Is_Printable_Error_Name (Chars (Ent)) then
3050
            Error_Msg_NE ("\?& called #", N, Ent);
3051
 
3052
         else
3053
            Error_Msg_N ("\? called #", N);
3054
         end if;
3055
      end loop;
3056
   end Output_Calls;
3057
 
3058
   ----------------------------
3059
   -- Same_Elaboration_Scope --
3060
   ----------------------------
3061
 
3062
   function Same_Elaboration_Scope (Scop1, Scop2 : Entity_Id) return Boolean is
3063
      S1 : Entity_Id;
3064
      S2 : Entity_Id;
3065
 
3066
   begin
3067
      --  Find elaboration scope for Scop1
3068
      --  This is either a subprogram or a compilation unit.
3069
 
3070
      S1 := Scop1;
3071
      while S1 /= Standard_Standard
3072
        and then not Is_Compilation_Unit (S1)
3073
        and then (Ekind (S1) = E_Package
3074
                    or else
3075
                  Ekind (S1) = E_Protected_Type
3076
                    or else
3077
                  Ekind (S1) = E_Block)
3078
      loop
3079
         S1 := Scope (S1);
3080
      end loop;
3081
 
3082
      --  Find elaboration scope for Scop2
3083
 
3084
      S2 := Scop2;
3085
      while S2 /= Standard_Standard
3086
        and then not Is_Compilation_Unit (S2)
3087
        and then (Ekind (S2) = E_Package
3088
                    or else
3089
                  Ekind (S2) = E_Protected_Type
3090
                    or else
3091
                  Ekind (S2) = E_Block)
3092
      loop
3093
         S2 := Scope (S2);
3094
      end loop;
3095
 
3096
      return S1 = S2;
3097
   end Same_Elaboration_Scope;
3098
 
3099
   -----------------
3100
   -- Set_C_Scope --
3101
   -----------------
3102
 
3103
   procedure Set_C_Scope is
3104
   begin
3105
      while not Is_Compilation_Unit (C_Scope) loop
3106
         C_Scope := Scope (C_Scope);
3107
      end loop;
3108
   end Set_C_Scope;
3109
 
3110
   -----------------
3111
   -- Spec_Entity --
3112
   -----------------
3113
 
3114
   function Spec_Entity (E : Entity_Id) return Entity_Id is
3115
      Decl : Node_Id;
3116
 
3117
   begin
3118
      --  Check for case of body entity
3119
      --  Why is the check for E_Void needed???
3120
 
3121
      if Ekind_In (E, E_Void, E_Subprogram_Body, E_Package_Body) then
3122
         Decl := E;
3123
 
3124
         loop
3125
            Decl := Parent (Decl);
3126
            exit when Nkind (Decl) in N_Proper_Body;
3127
         end loop;
3128
 
3129
         return Corresponding_Spec (Decl);
3130
 
3131
      else
3132
         return E;
3133
      end if;
3134
   end Spec_Entity;
3135
 
3136
   -------------------
3137
   -- Supply_Bodies --
3138
   -------------------
3139
 
3140
   procedure Supply_Bodies (N : Node_Id) is
3141
   begin
3142
      if Nkind (N) = N_Subprogram_Declaration then
3143
         declare
3144
            Ent : constant Entity_Id := Defining_Unit_Name (Specification (N));
3145
         begin
3146
 
3147
            --  Internal subprograms will already have a generated body, so
3148
            --  there is no need to provide a stub for them.
3149
 
3150
            if No (Corresponding_Body (N)) then
3151
               declare
3152
                  Loc     : constant Source_Ptr := Sloc (N);
3153
                  B       : Node_Id;
3154
                  Formals : constant List_Id := Copy_Parameter_List (Ent);
3155
                  Nam     : constant Entity_Id :=
3156
                              Make_Defining_Identifier (Loc, Chars (Ent));
3157
                  Spec    : Node_Id;
3158
                  Stats   : constant List_Id :=
3159
                              New_List
3160
                               (Make_Raise_Program_Error (Loc,
3161
                                  Reason => PE_Access_Before_Elaboration));
3162
 
3163
               begin
3164
                  if Ekind (Ent) = E_Function then
3165
                     Spec :=
3166
                        Make_Function_Specification (Loc,
3167
                          Defining_Unit_Name => Nam,
3168
                          Parameter_Specifications => Formals,
3169
                          Result_Definition =>
3170
                            New_Copy_Tree
3171
                              (Result_Definition (Specification (N))));
3172
 
3173
                     --  We cannot reliably make a return statement for this
3174
                     --  body, but none is needed because the call raises
3175
                     --  program error.
3176
 
3177
                     Set_Return_Present (Ent);
3178
 
3179
                  else
3180
                     Spec :=
3181
                        Make_Procedure_Specification (Loc,
3182
                          Defining_Unit_Name => Nam,
3183
                          Parameter_Specifications => Formals);
3184
                  end if;
3185
 
3186
                  B := Make_Subprogram_Body (Loc,
3187
                          Specification => Spec,
3188
                          Declarations => New_List,
3189
                          Handled_Statement_Sequence =>
3190
                            Make_Handled_Sequence_Of_Statements (Loc,  Stats));
3191
                  Insert_After (N, B);
3192
                  Analyze (B);
3193
               end;
3194
            end if;
3195
         end;
3196
 
3197
      elsif Nkind (N) = N_Package_Declaration then
3198
         declare
3199
            Spec : constant Node_Id := Specification (N);
3200
         begin
3201
            Push_Scope (Defining_Unit_Name (Spec));
3202
            Supply_Bodies (Visible_Declarations (Spec));
3203
            Supply_Bodies (Private_Declarations (Spec));
3204
            Pop_Scope;
3205
         end;
3206
      end if;
3207
   end Supply_Bodies;
3208
 
3209
   procedure Supply_Bodies (L : List_Id) is
3210
      Elmt : Node_Id;
3211
   begin
3212
      if Present (L) then
3213
         Elmt := First (L);
3214
         while Present (Elmt) loop
3215
            Supply_Bodies (Elmt);
3216
            Next (Elmt);
3217
         end loop;
3218
      end if;
3219
   end Supply_Bodies;
3220
 
3221
   ------------
3222
   -- Within --
3223
   ------------
3224
 
3225
   function Within (E1, E2 : Entity_Id) return Boolean is
3226
      Scop : Entity_Id;
3227
   begin
3228
      Scop := E1;
3229
      loop
3230
         if Scop = E2 then
3231
            return True;
3232
         elsif Scop = Standard_Standard then
3233
            return False;
3234
         else
3235
            Scop := Scope (Scop);
3236
         end if;
3237
      end loop;
3238
   end Within;
3239
 
3240
   --------------------------
3241
   -- Within_Elaborate_All --
3242
   --------------------------
3243
 
3244
   function Within_Elaborate_All (E : Entity_Id) return Boolean is
3245
      Item    : Node_Id;
3246
      Item2   : Node_Id;
3247
      Elab_Id : Entity_Id;
3248
      Par     : Node_Id;
3249
 
3250
   begin
3251
      Item := First (Context_Items (Cunit (Current_Sem_Unit)));
3252
      while Present (Item) loop
3253
         if Nkind (Item) = N_Pragma
3254
           and then Pragma_Name (Item) = Name_Elaborate_All
3255
         then
3256
            --  Return if some previous error on the pragma itself
3257
 
3258
            if Error_Posted (Item) then
3259
               return False;
3260
            end if;
3261
 
3262
            Elab_Id :=
3263
              Entity
3264
                (Expression (First (Pragma_Argument_Associations (Item))));
3265
 
3266
            Par := Parent (Unit_Declaration_Node (Elab_Id));
3267
 
3268
            Item2 := First (Context_Items (Par));
3269
            while Present (Item2) loop
3270
               if Nkind (Item2) = N_With_Clause
3271
                 and then Entity (Name (Item2)) = E
3272
               then
3273
                  return True;
3274
               end if;
3275
 
3276
               Next (Item2);
3277
            end loop;
3278
         end if;
3279
 
3280
         Next (Item);
3281
      end loop;
3282
 
3283
      return False;
3284
   end Within_Elaborate_All;
3285
 
3286
end Sem_Elab;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.