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

Subversion Repositories openrisc

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

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 706 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT COMPILER COMPONENTS                         --
4
--                                                                          --
5
--                             S E M _ C H 1 2                              --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 1992-2012, 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 Aspects;  use Aspects;
27
with Atree;    use Atree;
28
with Einfo;    use Einfo;
29
with Elists;   use Elists;
30
with Errout;   use Errout;
31
with Expander; use Expander;
32
with Exp_Disp; use Exp_Disp;
33
with Fname;    use Fname;
34
with Fname.UF; use Fname.UF;
35
with Freeze;   use Freeze;
36
with Hostparm;
37
with Itypes;   use Itypes;
38
with Lib;      use Lib;
39
with Lib.Load; use Lib.Load;
40
with Lib.Xref; use Lib.Xref;
41
with Nlists;   use Nlists;
42
with Namet;    use Namet;
43
with Nmake;    use Nmake;
44
with Opt;      use Opt;
45
with Rident;   use Rident;
46
with Restrict; use Restrict;
47
with Rtsfind;  use Rtsfind;
48
with Sem;      use Sem;
49
with Sem_Aux;  use Sem_Aux;
50
with Sem_Cat;  use Sem_Cat;
51
with Sem_Ch3;  use Sem_Ch3;
52
with Sem_Ch6;  use Sem_Ch6;
53
with Sem_Ch7;  use Sem_Ch7;
54
with Sem_Ch8;  use Sem_Ch8;
55
with Sem_Ch10; use Sem_Ch10;
56
with Sem_Ch13; use Sem_Ch13;
57
with Sem_Dim;  use Sem_Dim;
58
with Sem_Disp; use Sem_Disp;
59
with Sem_Elab; use Sem_Elab;
60
with Sem_Elim; use Sem_Elim;
61
with Sem_Eval; use Sem_Eval;
62
with Sem_Prag; use Sem_Prag;
63
with Sem_Res;  use Sem_Res;
64
with Sem_Type; use Sem_Type;
65
with Sem_Util; use Sem_Util;
66
with Sem_Warn; use Sem_Warn;
67
with Stand;    use Stand;
68
with Sinfo;    use Sinfo;
69
with Sinfo.CN; use Sinfo.CN;
70
with Sinput;   use Sinput;
71
with Sinput.L; use Sinput.L;
72
with Snames;   use Snames;
73
with Stringt;  use Stringt;
74
with Uname;    use Uname;
75
with Table;
76
with Tbuild;   use Tbuild;
77
with Uintp;    use Uintp;
78
with Urealp;   use Urealp;
79
 
80
with GNAT.HTable;
81
 
82
package body Sem_Ch12 is
83
 
84
   ----------------------------------------------------------
85
   -- Implementation of Generic Analysis and Instantiation --
86
   ----------------------------------------------------------
87
 
88
   --  GNAT implements generics by macro expansion. No attempt is made to share
89
   --  generic instantiations (for now). Analysis of a generic definition does
90
   --  not perform any expansion action, but the expander must be called on the
91
   --  tree for each instantiation, because the expansion may of course depend
92
   --  on the generic actuals. All of this is best achieved as follows:
93
   --
94
   --  a) Semantic analysis of a generic unit is performed on a copy of the
95
   --  tree for the generic unit. All tree modifications that follow analysis
96
   --  do not affect the original tree. Links are kept between the original
97
   --  tree and the copy, in order to recognize non-local references within
98
   --  the generic, and propagate them to each instance (recall that name
99
   --  resolution is done on the generic declaration: generics are not really
100
   --  macros!). This is summarized in the following diagram:
101
 
102
   --              .-----------.               .----------.
103
   --              |  semantic |<--------------|  generic |
104
   --              |    copy   |               |    unit  |
105
   --              |           |==============>|          |
106
   --              |___________|    global     |__________|
107
   --                             references     |   |  |
108
   --                                            |   |  |
109
   --                                          .-----|--|.
110
   --                                          |  .-----|---.
111
   --                                          |  |  .----------.
112
   --                                          |  |  |  generic |
113
   --                                          |__|  |          |
114
   --                                             |__| instance |
115
   --                                                |__________|
116
 
117
   --  b) Each instantiation copies the original tree, and inserts into it a
118
   --  series of declarations that describe the mapping between generic formals
119
   --  and actuals. For example, a generic In OUT parameter is an object
120
   --  renaming of the corresponding actual, etc. Generic IN parameters are
121
   --  constant declarations.
122
 
123
   --  c) In order to give the right visibility for these renamings, we use
124
   --  a different scheme for package and subprogram instantiations. For
125
   --  packages, the list of renamings is inserted into the package
126
   --  specification, before the visible declarations of the package. The
127
   --  renamings are analyzed before any of the text of the instance, and are
128
   --  thus visible at the right place. Furthermore, outside of the instance,
129
   --  the generic parameters are visible and denote their corresponding
130
   --  actuals.
131
 
132
   --  For subprograms, we create a container package to hold the renamings
133
   --  and the subprogram instance itself. Analysis of the package makes the
134
   --  renaming declarations visible to the subprogram. After analyzing the
135
   --  package, the defining entity for the subprogram is touched-up so that
136
   --  it appears declared in the current scope, and not inside the container
137
   --  package.
138
 
139
   --  If the instantiation is a compilation unit, the container package is
140
   --  given the same name as the subprogram instance. This ensures that
141
   --  the elaboration procedure called by the binder, using the compilation
142
   --  unit name, calls in fact the elaboration procedure for the package.
143
 
144
   --  Not surprisingly, private types complicate this approach. By saving in
145
   --  the original generic object the non-local references, we guarantee that
146
   --  the proper entities are referenced at the point of instantiation.
147
   --  However, for private types, this by itself does not insure that the
148
   --  proper VIEW of the entity is used (the full type may be visible at the
149
   --  point of generic definition, but not at instantiation, or vice-versa).
150
   --  In  order to reference the proper view, we special-case any reference
151
   --  to private types in the generic object, by saving both views, one in
152
   --  the generic and one in the semantic copy. At time of instantiation, we
153
   --  check whether the two views are consistent, and exchange declarations if
154
   --  necessary, in order to restore the correct visibility. Similarly, if
155
   --  the instance view is private when the generic view was not, we perform
156
   --  the exchange. After completing the instantiation, we restore the
157
   --  current visibility. The flag Has_Private_View marks identifiers in the
158
   --  the generic unit that require checking.
159
 
160
   --  Visibility within nested generic units requires special handling.
161
   --  Consider the following scheme:
162
 
163
   --  type Global is ...         --  outside of generic unit.
164
   --  generic ...
165
   --  package Outer is
166
   --     ...
167
   --     type Semi_Global is ... --  global to inner.
168
 
169
   --     generic ...                                         -- 1
170
   --     procedure inner (X1 : Global;  X2 : Semi_Global);
171
 
172
   --     procedure in2 is new inner (...);                   -- 4
173
   --  end Outer;
174
 
175
   --  package New_Outer is new Outer (...);                  -- 2
176
   --  procedure New_Inner is new New_Outer.Inner (...);      -- 3
177
 
178
   --  The semantic analysis of Outer captures all occurrences of Global.
179
   --  The semantic analysis of Inner (at 1) captures both occurrences of
180
   --  Global and Semi_Global.
181
 
182
   --  At point 2 (instantiation of Outer), we also produce a generic copy
183
   --  of Inner, even though Inner is, at that point, not being instantiated.
184
   --  (This is just part of the semantic analysis of New_Outer).
185
 
186
   --  Critically, references to Global within Inner must be preserved, while
187
   --  references to Semi_Global should not preserved, because they must now
188
   --  resolve to an entity within New_Outer. To distinguish between these, we
189
   --  use a global variable, Current_Instantiated_Parent, which is set when
190
   --  performing a generic copy during instantiation (at 2). This variable is
191
   --  used when performing a generic copy that is not an instantiation, but
192
   --  that is nested within one, as the occurrence of 1 within 2. The analysis
193
   --  of a nested generic only preserves references that are global to the
194
   --  enclosing Current_Instantiated_Parent. We use the Scope_Depth value to
195
   --  determine whether a reference is external to the given parent.
196
 
197
   --  The instantiation at point 3 requires no special treatment. The method
198
   --  works as well for further nestings of generic units, but of course the
199
   --  variable Current_Instantiated_Parent must be stacked because nested
200
   --  instantiations can occur, e.g. the occurrence of 4 within 2.
201
 
202
   --  The instantiation of package and subprogram bodies is handled in a
203
   --  similar manner, except that it is delayed until after semantic
204
   --  analysis is complete. In this fashion complex cross-dependencies
205
   --  between several package declarations and bodies containing generics
206
   --  can be compiled which otherwise would diagnose spurious circularities.
207
 
208
   --  For example, it is possible to compile two packages A and B that
209
   --  have the following structure:
210
 
211
   --    package A is                         package B is
212
   --       generic ...                          generic ...
213
   --       package G_A is                       package G_B is
214
 
215
   --    with B;                              with A;
216
   --    package body A is                    package body B is
217
   --       package N_B is new G_B (..)          package N_A is new G_A (..)
218
 
219
   --  The table Pending_Instantiations in package Inline is used to keep
220
   --  track of body instantiations that are delayed in this manner. Inline
221
   --  handles the actual calls to do the body instantiations. This activity
222
   --  is part of Inline, since the processing occurs at the same point, and
223
   --  for essentially the same reason, as the handling of inlined routines.
224
 
225
   ----------------------------------------------
226
   -- Detection of Instantiation Circularities --
227
   ----------------------------------------------
228
 
229
   --  If we have a chain of instantiations that is circular, this is static
230
   --  error which must be detected at compile time. The detection of these
231
   --  circularities is carried out at the point that we insert a generic
232
   --  instance spec or body. If there is a circularity, then the analysis of
233
   --  the offending spec or body will eventually result in trying to load the
234
   --  same unit again, and we detect this problem as we analyze the package
235
   --  instantiation for the second time.
236
 
237
   --  At least in some cases after we have detected the circularity, we get
238
   --  into trouble if we try to keep going. The following flag is set if a
239
   --  circularity is detected, and used to abandon compilation after the
240
   --  messages have been posted.
241
 
242
   Circularity_Detected : Boolean := False;
243
   --  This should really be reset on encountering a new main unit, but in
244
   --  practice we are not using multiple main units so it is not critical.
245
 
246
   -------------------------------------------------
247
   -- Formal packages and partial parametrization --
248
   -------------------------------------------------
249
 
250
   --  When compiling a generic, a formal package is a local instantiation. If
251
   --  declared with a box, its generic formals are visible in the enclosing
252
   --  generic. If declared with a partial list of actuals, those actuals that
253
   --  are defaulted (covered by an Others clause, or given an explicit box
254
   --  initialization) are also visible in the enclosing generic, while those
255
   --  that have a corresponding actual are not.
256
 
257
   --  In our source model of instantiation, the same visibility must be
258
   --  present in the spec and body of an instance: the names of the formals
259
   --  that are defaulted must be made visible within the instance, and made
260
   --  invisible (hidden) after the instantiation is complete, so that they
261
   --  are not accessible outside of the instance.
262
 
263
   --  In a generic, a formal package is treated like a special instantiation.
264
   --  Our Ada 95 compiler handled formals with and without box in different
265
   --  ways. With partial parametrization, we use a single model for both.
266
   --  We create a package declaration that consists of the specification of
267
   --  the generic package, and a set of declarations that map the actuals
268
   --  into local renamings, just as we do for bona fide instantiations. For
269
   --  defaulted parameters and formals with a box, we copy directly the
270
   --  declarations of the formal into this local package. The result is a
271
   --  a package whose visible declarations may include generic formals. This
272
   --  package is only used for type checking and visibility analysis, and
273
   --  never reaches the back-end, so it can freely violate the placement
274
   --  rules for generic formal declarations.
275
 
276
   --  The list of declarations (renamings and copies of formals) is built
277
   --  by Analyze_Associations, just as for regular instantiations.
278
 
279
   --  At the point of instantiation, conformance checking must be applied only
280
   --  to those parameters that were specified in the formal. We perform this
281
   --  checking by creating another internal instantiation, this one including
282
   --  only the renamings and the formals (the rest of the package spec is not
283
   --  relevant to conformance checking). We can then traverse two lists: the
284
   --  list of actuals in the instance that corresponds to the formal package,
285
   --  and the list of actuals produced for this bogus instantiation. We apply
286
   --  the conformance rules to those actuals that are not defaulted (i.e.
287
   --  which still appear as generic formals.
288
 
289
   --  When we compile an instance body we must make the right parameters
290
   --  visible again. The predicate Is_Generic_Formal indicates which of the
291
   --  formals should have its Is_Hidden flag reset.
292
 
293
   -----------------------
294
   -- Local subprograms --
295
   -----------------------
296
 
297
   procedure Abandon_Instantiation (N : Node_Id);
298
   pragma No_Return (Abandon_Instantiation);
299
   --  Posts an error message "instantiation abandoned" at the indicated node
300
   --  and then raises the exception Instantiation_Error to do it.
301
 
302
   procedure Analyze_Formal_Array_Type
303
     (T   : in out Entity_Id;
304
      Def : Node_Id);
305
   --  A formal array type is treated like an array type declaration, and
306
   --  invokes Array_Type_Declaration (sem_ch3) whose first parameter is
307
   --  in-out, because in the case of an anonymous type the entity is
308
   --  actually created in the procedure.
309
 
310
   --  The following procedures treat other kinds of formal parameters
311
 
312
   procedure Analyze_Formal_Derived_Interface_Type
313
     (N   : Node_Id;
314
      T   : Entity_Id;
315
      Def : Node_Id);
316
 
317
   procedure Analyze_Formal_Derived_Type
318
     (N   : Node_Id;
319
      T   : Entity_Id;
320
      Def : Node_Id);
321
 
322
   procedure Analyze_Formal_Interface_Type
323
     (N   : Node_Id;
324
      T   : Entity_Id;
325
      Def : Node_Id);
326
 
327
   --  The following subprograms create abbreviated declarations for formal
328
   --  scalar types. We introduce an anonymous base of the proper class for
329
   --  each of them, and define the formals as constrained first subtypes of
330
   --  their bases. The bounds are expressions that are non-static in the
331
   --  generic.
332
 
333
   procedure Analyze_Formal_Decimal_Fixed_Point_Type
334
                                                (T : Entity_Id; Def : Node_Id);
335
   procedure Analyze_Formal_Discrete_Type       (T : Entity_Id; Def : Node_Id);
336
   procedure Analyze_Formal_Floating_Type       (T : Entity_Id; Def : Node_Id);
337
   procedure Analyze_Formal_Signed_Integer_Type (T : Entity_Id; Def : Node_Id);
338
   procedure Analyze_Formal_Modular_Type        (T : Entity_Id; Def : Node_Id);
339
   procedure Analyze_Formal_Ordinary_Fixed_Point_Type
340
                                                (T : Entity_Id; Def : Node_Id);
341
 
342
   procedure Analyze_Formal_Private_Type
343
     (N   : Node_Id;
344
      T   : Entity_Id;
345
      Def : Node_Id);
346
   --  Creates a new private type, which does not require completion
347
 
348
   procedure Analyze_Formal_Incomplete_Type (T : Entity_Id; Def : Node_Id);
349
   --  Ada 2012: Creates a new incomplete type whose actual does not freeze
350
 
351
   procedure Analyze_Generic_Formal_Part (N : Node_Id);
352
   --  Analyze generic formal part
353
 
354
   procedure Analyze_Generic_Access_Type (T : Entity_Id; Def : Node_Id);
355
   --  Create a new access type with the given designated type
356
 
357
   function Analyze_Associations
358
     (I_Node  : Node_Id;
359
      Formals : List_Id;
360
      F_Copy  : List_Id) return List_Id;
361
   --  At instantiation time, build the list of associations between formals
362
   --  and actuals. Each association becomes a renaming declaration for the
363
   --  formal entity. F_Copy is the analyzed list of formals in the generic
364
   --  copy. It is used to apply legality checks to the actuals. I_Node is the
365
   --  instantiation node itself.
366
 
367
   procedure Analyze_Subprogram_Instantiation
368
     (N : Node_Id;
369
      K : Entity_Kind);
370
 
371
   procedure Build_Instance_Compilation_Unit_Nodes
372
     (N        : Node_Id;
373
      Act_Body : Node_Id;
374
      Act_Decl : Node_Id);
375
   --  This procedure is used in the case where the generic instance of a
376
   --  subprogram body or package body is a library unit. In this case, the
377
   --  original library unit node for the generic instantiation must be
378
   --  replaced by the resulting generic body, and a link made to a new
379
   --  compilation unit node for the generic declaration. The argument N is
380
   --  the original generic instantiation. Act_Body and Act_Decl are the body
381
   --  and declaration of the instance (either package body and declaration
382
   --  nodes or subprogram body and declaration nodes depending on the case).
383
   --  On return, the node N has been rewritten with the actual body.
384
 
385
   procedure Check_Access_Definition (N : Node_Id);
386
   --  Subsidiary routine to null exclusion processing. Perform an assertion
387
   --  check on Ada version and the presence of an access definition in N.
388
 
389
   procedure Check_Formal_Packages (P_Id : Entity_Id);
390
   --  Apply the following to all formal packages in generic associations
391
 
392
   procedure Check_Formal_Package_Instance
393
     (Formal_Pack : Entity_Id;
394
      Actual_Pack : Entity_Id);
395
   --  Verify that the actuals of the actual instance match the actuals of
396
   --  the template for a formal package that is not declared with a box.
397
 
398
   procedure Check_Forward_Instantiation (Decl : Node_Id);
399
   --  If the generic is a local entity and the corresponding body has not
400
   --  been seen yet, flag enclosing packages to indicate that it will be
401
   --  elaborated after the generic body. Subprograms declared in the same
402
   --  package cannot be inlined by the front-end because front-end inlining
403
   --  requires a strict linear order of elaboration.
404
 
405
   function Check_Hidden_Primitives (Assoc_List : List_Id) return Elist_Id;
406
   --  Check if some association between formals and actuals requires to make
407
   --  visible primitives of a tagged type, and make those primitives visible.
408
   --  Return the list of primitives whose visibility is modified (to restore
409
   --  their visibility later through Restore_Hidden_Primitives). If no
410
   --  candidate is found then return No_Elist.
411
 
412
   procedure Check_Hidden_Child_Unit
413
     (N           : Node_Id;
414
      Gen_Unit    : Entity_Id;
415
      Act_Decl_Id : Entity_Id);
416
   --  If the generic unit is an implicit child instance within a parent
417
   --  instance, we need to make an explicit test that it is not hidden by
418
   --  a child instance of the same name and parent.
419
 
420
   procedure Check_Generic_Actuals
421
     (Instance      : Entity_Id;
422
      Is_Formal_Box : Boolean);
423
   --  Similar to previous one. Check the actuals in the instantiation,
424
   --  whose views can change between the point of instantiation and the point
425
   --  of instantiation of the body. In addition, mark the generic renamings
426
   --  as generic actuals, so that they are not compatible with other actuals.
427
   --  Recurse on an actual that is a formal package whose declaration has
428
   --  a box.
429
 
430
   function Contains_Instance_Of
431
     (Inner : Entity_Id;
432
      Outer : Entity_Id;
433
      N     : Node_Id) return Boolean;
434
   --  Inner is instantiated within the generic Outer. Check whether Inner
435
   --  directly or indirectly contains an instance of Outer or of one of its
436
   --  parents, in the case of a subunit. Each generic unit holds a list of
437
   --  the entities instantiated within (at any depth). This procedure
438
   --  determines whether the set of such lists contains a cycle, i.e. an
439
   --  illegal circular instantiation.
440
 
441
   function Denotes_Formal_Package
442
     (Pack     : Entity_Id;
443
      On_Exit  : Boolean := False;
444
      Instance : Entity_Id := Empty) return Boolean;
445
   --  Returns True if E is a formal package of an enclosing generic, or
446
   --  the actual for such a formal in an enclosing instantiation. If such
447
   --  a package is used as a formal in an nested generic, or as an actual
448
   --  in a nested instantiation, the visibility of ITS formals should not
449
   --  be modified. When called from within Restore_Private_Views, the flag
450
   --  On_Exit is true, to indicate that the search for a possible enclosing
451
   --  instance should ignore the current one. In that case Instance denotes
452
   --  the declaration for which this is an actual. This declaration may be
453
   --  an instantiation in the source, or the internal instantiation that
454
   --  corresponds to the actual for a formal package.
455
 
456
   function Earlier (N1, N2 : Node_Id) return Boolean;
457
   --  Yields True if N1 and N2 appear in the same compilation unit,
458
   --  ignoring subunits, and if N1 is to the left of N2 in a left-to-right
459
   --  traversal of the tree for the unit. Used to determine the placement
460
   --  of freeze nodes for instance bodies that may depend on other instances.
461
 
462
   function Find_Actual_Type
463
     (Typ       : Entity_Id;
464
      Gen_Type  : Entity_Id) return Entity_Id;
465
   --  When validating the actual types of a child instance, check whether
466
   --  the formal is a formal type of the parent unit, and retrieve the current
467
   --  actual for it. Typ is the entity in the analyzed formal type declaration
468
   --  (component or index type of an array type, or designated type of an
469
   --  access formal) and Gen_Type is the enclosing analyzed formal array
470
   --  or access type. The desired actual may be a formal of a parent, or may
471
   --  be declared in a formal package of a parent. In both cases it is a
472
   --  generic actual type because it appears within a visible instance.
473
   --  Finally, it may be declared in a parent unit without being a formal
474
   --  of that unit, in which case it must be retrieved by visibility.
475
   --  Ambiguities may still arise if two homonyms are declared in two formal
476
   --  packages, and the prefix of the formal type may be needed to resolve
477
   --  the ambiguity in the instance ???
478
 
479
   function In_Same_Declarative_Part
480
     (F_Node : Node_Id;
481
      Inst   : Node_Id) return Boolean;
482
   --  True if the instantiation Inst and the given freeze_node F_Node appear
483
   --  within the same declarative part, ignoring subunits, but with no inter-
484
   --  vening subprograms or concurrent units. Used to find the proper plave
485
   --  for the freeze node of an instance, when the generic is declared in a
486
   --  previous instance. If predicate is true, the freeze node of the instance
487
   --  can be placed after the freeze node of the previous instance, Otherwise
488
   --  it has to be placed at the end of the current declarative part.
489
 
490
   function In_Main_Context (E : Entity_Id) return Boolean;
491
   --  Check whether an instantiation is in the context of the main unit.
492
   --  Used to determine whether its body should be elaborated to allow
493
   --  front-end inlining.
494
 
495
   procedure Set_Instance_Env
496
     (Gen_Unit : Entity_Id;
497
      Act_Unit : Entity_Id);
498
   --  Save current instance on saved environment, to be used to determine
499
   --  the global status of entities in nested instances. Part of Save_Env.
500
   --  called after verifying that the generic unit is legal for the instance,
501
   --  The procedure also examines whether the generic unit is a predefined
502
   --  unit, in order to set configuration switches accordingly. As a result
503
   --  the procedure must be called after analyzing and freezing the actuals.
504
 
505
   procedure Set_Instance_Of (A : Entity_Id; B : Entity_Id);
506
   --  Associate analyzed generic parameter with corresponding
507
   --  instance. Used for semantic checks at instantiation time.
508
 
509
   function Has_Been_Exchanged (E : Entity_Id) return Boolean;
510
   --  Traverse the Exchanged_Views list to see if a type was private
511
   --  and has already been flipped during this phase of instantiation.
512
 
513
   procedure Hide_Current_Scope;
514
   --  When instantiating a generic child unit, the parent context must be
515
   --  present, but the instance and all entities that may be generated
516
   --  must be inserted in the current scope. We leave the current scope
517
   --  on the stack, but make its entities invisible to avoid visibility
518
   --  problems. This is reversed at the end of the instantiation. This is
519
   --  not done for the instantiation of the bodies, which only require the
520
   --  instances of the generic parents to be in scope.
521
 
522
   procedure Install_Body
523
     (Act_Body : Node_Id;
524
      N        : Node_Id;
525
      Gen_Body : Node_Id;
526
      Gen_Decl : Node_Id);
527
   --  If the instantiation happens textually before the body of the generic,
528
   --  the instantiation of the body must be analyzed after the generic body,
529
   --  and not at the point of instantiation. Such early instantiations can
530
   --  happen if the generic and the instance appear in  a package declaration
531
   --  because the generic body can only appear in the corresponding package
532
   --  body. Early instantiations can also appear if generic, instance and
533
   --  body are all in the declarative part of a subprogram or entry. Entities
534
   --  of packages that are early instantiations are delayed, and their freeze
535
   --  node appears after the generic body.
536
 
537
   procedure Insert_Freeze_Node_For_Instance
538
     (N      : Node_Id;
539
      F_Node : Node_Id);
540
   --  N denotes a package or a subprogram instantiation and F_Node is the
541
   --  associated freeze node. Insert the freeze node before the first source
542
   --  body which follows immediately after N. If no such body is found, the
543
   --  freeze node is inserted at the end of the declarative region which
544
   --  contains N.
545
 
546
   procedure Freeze_Subprogram_Body
547
     (Inst_Node : Node_Id;
548
      Gen_Body  : Node_Id;
549
      Pack_Id   : Entity_Id);
550
   --  The generic body may appear textually after the instance, including
551
   --  in the proper body of a stub, or within a different package instance.
552
   --  Given that the instance can only be elaborated after the generic, we
553
   --  place freeze_nodes for the instance and/or for packages that may enclose
554
   --  the instance and the generic, so that the back-end can establish the
555
   --  proper order of elaboration.
556
 
557
   procedure Init_Env;
558
   --  Establish environment for subsequent instantiation. Separated from
559
   --  Save_Env because data-structures for visibility handling must be
560
   --  initialized before call to Check_Generic_Child_Unit.
561
 
562
   procedure Install_Formal_Packages (Par : Entity_Id);
563
   --  Install the visible part of any formal of the parent that is a formal
564
   --  package. Note that for the case of a formal package with a box, this
565
   --  includes the formal part of the formal package (12.7(10/2)).
566
 
567
   procedure Install_Parent (P : Entity_Id; In_Body : Boolean := False);
568
   --  When compiling an instance of a child unit the parent (which is
569
   --  itself an instance) is an enclosing scope that must be made
570
   --  immediately visible. This procedure is also used to install the non-
571
   --  generic parent of a generic child unit when compiling its body, so
572
   --  that full views of types in the parent are made visible.
573
 
574
   procedure Remove_Parent (In_Body : Boolean := False);
575
   --  Reverse effect after instantiation of child is complete
576
 
577
   procedure Install_Hidden_Primitives
578
     (Prims_List : in out Elist_Id;
579
      Gen_T      : Entity_Id;
580
      Act_T      : Entity_Id);
581
   --  Remove suffix 'P' from hidden primitives of Act_T to match the
582
   --  visibility of primitives of Gen_T. The list of primitives to which
583
   --  the suffix is removed is added to Prims_List to restore them later.
584
 
585
   procedure Restore_Hidden_Primitives (Prims_List : in out Elist_Id);
586
   --  Restore suffix 'P' to primitives of Prims_List and leave Prims_List
587
   --  set to No_Elist.
588
 
589
   procedure Inline_Instance_Body
590
     (N        : Node_Id;
591
      Gen_Unit : Entity_Id;
592
      Act_Decl : Node_Id);
593
   --  If front-end inlining is requested, instantiate the package body,
594
   --  and preserve the visibility of its compilation unit, to insure
595
   --  that successive instantiations succeed.
596
 
597
   --  The functions Instantiate_XXX perform various legality checks and build
598
   --  the declarations for instantiated generic parameters. In all of these
599
   --  Formal is the entity in the generic unit, Actual is the entity of
600
   --  expression in the generic associations, and Analyzed_Formal is the
601
   --  formal in the generic copy, which contains the semantic information to
602
   --  be used to validate the actual.
603
 
604
   function Instantiate_Object
605
     (Formal          : Node_Id;
606
      Actual          : Node_Id;
607
      Analyzed_Formal : Node_Id) return List_Id;
608
 
609
   function Instantiate_Type
610
     (Formal          : Node_Id;
611
      Actual          : Node_Id;
612
      Analyzed_Formal : Node_Id;
613
      Actual_Decls    : List_Id) return List_Id;
614
 
615
   function Instantiate_Formal_Subprogram
616
     (Formal          : Node_Id;
617
      Actual          : Node_Id;
618
      Analyzed_Formal : Node_Id) return Node_Id;
619
 
620
   function Instantiate_Formal_Package
621
     (Formal          : Node_Id;
622
      Actual          : Node_Id;
623
      Analyzed_Formal : Node_Id) return List_Id;
624
   --  If the formal package is declared with a box, special visibility rules
625
   --  apply to its formals: they are in the visible part of the package. This
626
   --  is true in the declarative region of the formal package, that is to say
627
   --  in the enclosing generic or instantiation. For an instantiation, the
628
   --  parameters of the formal package are made visible in an explicit step.
629
   --  Furthermore, if the actual has a visible USE clause, these formals must
630
   --  be made potentially use-visible as well. On exit from the enclosing
631
   --  instantiation, the reverse must be done.
632
 
633
   --  For a formal package declared without a box, there are conformance rules
634
   --  that apply to the actuals in the generic declaration and the actuals of
635
   --  the actual package in the enclosing instantiation. The simplest way to
636
   --  apply these rules is to repeat the instantiation of the formal package
637
   --  in the context of the enclosing instance, and compare the generic
638
   --  associations of this instantiation with those of the actual package.
639
   --  This internal instantiation only needs to contain the renamings of the
640
   --  formals: the visible and private declarations themselves need not be
641
   --  created.
642
 
643
   --  In Ada 2005, the formal package may be only partially parameterized.
644
   --  In that case the visibility step must make visible those actuals whose
645
   --  corresponding formals were given with a box. A final complication
646
   --  involves inherited operations from formal derived types, which must
647
   --  be visible if the type is.
648
 
649
   function Is_In_Main_Unit (N : Node_Id) return Boolean;
650
   --  Test if given node is in the main unit
651
 
652
   procedure Load_Parent_Of_Generic
653
     (N             : Node_Id;
654
      Spec          : Node_Id;
655
      Body_Optional : Boolean := False);
656
   --  If the generic appears in a separate non-generic library unit, load the
657
   --  corresponding body to retrieve the body of the generic. N is the node
658
   --  for the generic instantiation, Spec is the generic package declaration.
659
   --
660
   --  Body_Optional is a flag that indicates that the body is being loaded to
661
   --  ensure that temporaries are generated consistently when there are other
662
   --  instances in the current declarative part that precede the one being
663
   --  loaded. In that case a missing body is acceptable.
664
 
665
   procedure Inherit_Context (Gen_Decl : Node_Id; Inst : Node_Id);
666
   --  Add the context clause of the unit containing a generic unit to a
667
   --  compilation unit that is, or contains, an instantiation.
668
 
669
   function Get_Associated_Node (N : Node_Id) return Node_Id;
670
   --  In order to propagate semantic information back from the analyzed copy
671
   --  to the original generic, we maintain links between selected nodes in the
672
   --  generic and their corresponding copies. At the end of generic analysis,
673
   --  the routine Save_Global_References traverses the generic tree, examines
674
   --  the semantic information, and preserves the links to those nodes that
675
   --  contain global information. At instantiation, the information from the
676
   --  associated node is placed on the new copy, so that name resolution is
677
   --  not repeated.
678
   --
679
   --  Three kinds of source nodes have associated nodes:
680
   --
681
   --    a) those that can reference (denote) entities, that is identifiers,
682
   --       character literals, expanded_names, operator symbols, operators,
683
   --       and attribute reference nodes. These nodes have an Entity field
684
   --       and are the set of nodes that are in N_Has_Entity.
685
   --
686
   --    b) aggregates (N_Aggregate and N_Extension_Aggregate)
687
   --
688
   --    c) selected components (N_Selected_Component)
689
   --
690
   --  For the first class, the associated node preserves the entity if it is
691
   --  global. If the generic contains nested instantiations, the associated
692
   --  node itself has been recopied, and a chain of them must be followed.
693
   --
694
   --  For aggregates, the associated node allows retrieval of the type, which
695
   --  may otherwise not appear in the generic. The view of this type may be
696
   --  different between generic and instantiation, and the full view can be
697
   --  installed before the instantiation is analyzed. For aggregates of type
698
   --  extensions, the same view exchange may have to be performed for some of
699
   --  the ancestor types, if their view is private at the point of
700
   --  instantiation.
701
   --
702
   --  Nodes that are selected components in the parse tree may be rewritten
703
   --  as expanded names after resolution, and must be treated as potential
704
   --  entity holders, which is why they also have an Associated_Node.
705
   --
706
   --  Nodes that do not come from source, such as freeze nodes, do not appear
707
   --  in the generic tree, and need not have an associated node.
708
   --
709
   --  The associated node is stored in the Associated_Node field. Note that
710
   --  this field overlaps Entity, which is fine, because the whole point is
711
   --  that we don't need or want the normal Entity field in this situation.
712
 
713
   procedure Map_Formal_Package_Entities (Form : Entity_Id; Act : Entity_Id);
714
   --  Within the generic part, entities in the formal package are
715
   --  visible. To validate subsequent type declarations, indicate
716
   --  the correspondence between the entities in the analyzed formal,
717
   --  and the entities in  the actual package. There are three packages
718
   --  involved in the instantiation of a formal package: the parent
719
   --  generic P1 which appears in the generic declaration, the fake
720
   --  instantiation P2 which appears in the analyzed generic, and whose
721
   --  visible entities may be used in subsequent formals, and the actual
722
   --  P3 in the instance. To validate subsequent formals, me indicate
723
   --  that the entities in P2 are mapped into those of P3. The mapping of
724
   --  entities has to be done recursively for nested packages.
725
 
726
   procedure Move_Freeze_Nodes
727
     (Out_Of : Entity_Id;
728
      After  : Node_Id;
729
      L      : List_Id);
730
   --  Freeze nodes can be generated in the analysis of a generic unit, but
731
   --  will not be seen by the back-end. It is necessary to move those nodes
732
   --  to the enclosing scope if they freeze an outer entity. We place them
733
   --  at the end of the enclosing generic package, which is semantically
734
   --  neutral.
735
 
736
   procedure Preanalyze_Actuals (N : Node_Id);
737
   --  Analyze actuals to perform name resolution. Full resolution is done
738
   --  later, when the expected types are known, but names have to be captured
739
   --  before installing parents of generics, that are not visible for the
740
   --  actuals themselves.
741
 
742
   function True_Parent (N : Node_Id) return Node_Id;
743
   --  For a subunit, return parent of corresponding stub, else return
744
   --  parent of node.
745
 
746
   procedure Valid_Default_Attribute (Nam : Entity_Id; Def : Node_Id);
747
   --  Verify that an attribute that appears as the default for a formal
748
   --  subprogram is a function or procedure with the correct profile.
749
 
750
   -------------------------------------------
751
   -- Data Structures for Generic Renamings --
752
   -------------------------------------------
753
 
754
   --  The map Generic_Renamings associates generic entities with their
755
   --  corresponding actuals. Currently used to validate type instances. It
756
   --  will eventually be used for all generic parameters to eliminate the
757
   --  need for overload resolution in the instance.
758
 
759
   type Assoc_Ptr is new Int;
760
 
761
   Assoc_Null : constant Assoc_Ptr := -1;
762
 
763
   type Assoc is record
764
      Gen_Id         : Entity_Id;
765
      Act_Id         : Entity_Id;
766
      Next_In_HTable : Assoc_Ptr;
767
   end record;
768
 
769
   package Generic_Renamings is new Table.Table
770
     (Table_Component_Type => Assoc,
771
      Table_Index_Type     => Assoc_Ptr,
772
      Table_Low_Bound      => 0,
773
      Table_Initial        => 10,
774
      Table_Increment      => 100,
775
      Table_Name           => "Generic_Renamings");
776
 
777
   --  Variable to hold enclosing instantiation. When the environment is
778
   --  saved for a subprogram inlining, the corresponding Act_Id is empty.
779
 
780
   Current_Instantiated_Parent : Assoc := (Empty, Empty, Assoc_Null);
781
 
782
   --  Hash table for associations
783
 
784
   HTable_Size : constant := 37;
785
   type HTable_Range is range 0 .. HTable_Size - 1;
786
 
787
   procedure Set_Next_Assoc (E : Assoc_Ptr; Next : Assoc_Ptr);
788
   function  Next_Assoc     (E : Assoc_Ptr) return Assoc_Ptr;
789
   function Get_Gen_Id      (E : Assoc_Ptr) return Entity_Id;
790
   function Hash            (F : Entity_Id) return HTable_Range;
791
 
792
   package Generic_Renamings_HTable is new GNAT.HTable.Static_HTable (
793
      Header_Num => HTable_Range,
794
      Element    => Assoc,
795
      Elmt_Ptr   => Assoc_Ptr,
796
      Null_Ptr   => Assoc_Null,
797
      Set_Next   => Set_Next_Assoc,
798
      Next       => Next_Assoc,
799
      Key        => Entity_Id,
800
      Get_Key    => Get_Gen_Id,
801
      Hash       => Hash,
802
      Equal      => "=");
803
 
804
   Exchanged_Views : Elist_Id;
805
   --  This list holds the private views that have been exchanged during
806
   --  instantiation to restore the visibility of the generic declaration.
807
   --  (see comments above). After instantiation, the current visibility is
808
   --  reestablished by means of a traversal of this list.
809
 
810
   Hidden_Entities : Elist_Id;
811
   --  This list holds the entities of the current scope that are removed
812
   --  from immediate visibility when instantiating a child unit. Their
813
   --  visibility is restored in Remove_Parent.
814
 
815
   --  Because instantiations can be recursive, the following must be saved
816
   --  on entry and restored on exit from an instantiation (spec or body).
817
   --  This is done by the two procedures Save_Env and Restore_Env. For
818
   --  package and subprogram instantiations (but not for the body instances)
819
   --  the action of Save_Env is done in two steps: Init_Env is called before
820
   --  Check_Generic_Child_Unit, because setting the parent instances requires
821
   --  that the visibility data structures be properly initialized. Once the
822
   --  generic is unit is validated, Set_Instance_Env completes Save_Env.
823
 
824
   Parent_Unit_Visible : Boolean := False;
825
   --  Parent_Unit_Visible is used when the generic is a child unit, and
826
   --  indicates whether the ultimate parent of the generic is visible in the
827
   --  instantiation environment. It is used to reset the visibility of the
828
   --  parent at the end of the instantiation (see Remove_Parent).
829
 
830
   Instance_Parent_Unit : Entity_Id := Empty;
831
   --  This records the ultimate parent unit of an instance of a generic
832
   --  child unit and is used in conjunction with Parent_Unit_Visible to
833
   --  indicate the unit to which the Parent_Unit_Visible flag corresponds.
834
 
835
   type Instance_Env is record
836
      Instantiated_Parent  : Assoc;
837
      Exchanged_Views      : Elist_Id;
838
      Hidden_Entities      : Elist_Id;
839
      Current_Sem_Unit     : Unit_Number_Type;
840
      Parent_Unit_Visible  : Boolean   := False;
841
      Instance_Parent_Unit : Entity_Id := Empty;
842
      Switches             : Config_Switches_Type;
843
   end record;
844
 
845
   package Instance_Envs is new Table.Table (
846
     Table_Component_Type => Instance_Env,
847
     Table_Index_Type     => Int,
848
     Table_Low_Bound      => 0,
849
     Table_Initial        => 32,
850
     Table_Increment      => 100,
851
     Table_Name           => "Instance_Envs");
852
 
853
   procedure Restore_Private_Views
854
     (Pack_Id    : Entity_Id;
855
      Is_Package : Boolean := True);
856
   --  Restore the private views of external types, and unmark the generic
857
   --  renamings of actuals, so that they become compatible subtypes again.
858
   --  For subprograms, Pack_Id is the package constructed to hold the
859
   --  renamings.
860
 
861
   procedure Switch_View (T : Entity_Id);
862
   --  Switch the partial and full views of a type and its private
863
   --  dependents (i.e. its subtypes and derived types).
864
 
865
   ------------------------------------
866
   -- Structures for Error Reporting --
867
   ------------------------------------
868
 
869
   Instantiation_Node : Node_Id;
870
   --  Used by subprograms that validate instantiation of formal parameters
871
   --  where there might be no actual on which to place the error message.
872
   --  Also used to locate the instantiation node for generic subunits.
873
 
874
   Instantiation_Error : exception;
875
   --  When there is a semantic error in the generic parameter matching,
876
   --  there is no point in continuing the instantiation, because the
877
   --  number of cascaded errors is unpredictable. This exception aborts
878
   --  the instantiation process altogether.
879
 
880
   S_Adjustment : Sloc_Adjustment;
881
   --  Offset created for each node in an instantiation, in order to keep
882
   --  track of the source position of the instantiation in each of its nodes.
883
   --  A subsequent semantic error or warning on a construct of the instance
884
   --  points to both places: the original generic node, and the point of
885
   --  instantiation. See Sinput and Sinput.L for additional details.
886
 
887
   ------------------------------------------------------------
888
   -- Data structure for keeping track when inside a Generic --
889
   ------------------------------------------------------------
890
 
891
   --  The following table is used to save values of the Inside_A_Generic
892
   --  flag (see spec of Sem) when they are saved by Start_Generic.
893
 
894
   package Generic_Flags is new Table.Table (
895
     Table_Component_Type => Boolean,
896
     Table_Index_Type     => Int,
897
     Table_Low_Bound      => 0,
898
     Table_Initial        => 32,
899
     Table_Increment      => 200,
900
     Table_Name           => "Generic_Flags");
901
 
902
   ---------------------------
903
   -- Abandon_Instantiation --
904
   ---------------------------
905
 
906
   procedure Abandon_Instantiation (N : Node_Id) is
907
   begin
908
      Error_Msg_N ("\instantiation abandoned!", N);
909
      raise Instantiation_Error;
910
   end Abandon_Instantiation;
911
 
912
   --------------------------
913
   -- Analyze_Associations --
914
   --------------------------
915
 
916
   function Analyze_Associations
917
     (I_Node  : Node_Id;
918
      Formals : List_Id;
919
      F_Copy  : List_Id) return List_Id
920
   is
921
      Actuals_To_Freeze : constant Elist_Id  := New_Elmt_List;
922
      Assoc             : constant List_Id   := New_List;
923
      Default_Actuals   : constant Elist_Id  := New_Elmt_List;
924
      Gen_Unit          : constant Entity_Id :=
925
                            Defining_Entity (Parent (F_Copy));
926
 
927
      Actuals         : List_Id;
928
      Actual          : Node_Id;
929
      Analyzed_Formal : Node_Id;
930
      First_Named     : Node_Id := Empty;
931
      Formal          : Node_Id;
932
      Match           : Node_Id;
933
      Named           : Node_Id;
934
      Saved_Formal    : Node_Id;
935
 
936
      Default_Formals : constant List_Id := New_List;
937
      --  If an Others_Choice is present, some of the formals may be defaulted.
938
      --  To simplify the treatment of visibility in an instance, we introduce
939
      --  individual defaults for each such formal. These defaults are
940
      --  appended to the list of associations and replace the Others_Choice.
941
 
942
      Found_Assoc : Node_Id;
943
      --  Association for the current formal being match. Empty if there are
944
      --  no remaining actuals, or if there is no named association with the
945
      --  name of the formal.
946
 
947
      Is_Named_Assoc : Boolean;
948
      Num_Matched    : Int := 0;
949
      Num_Actuals    : Int := 0;
950
 
951
      Others_Present : Boolean := False;
952
      Others_Choice  : Node_Id := Empty;
953
      --  In Ada 2005, indicates partial parametrization of a formal
954
      --  package. As usual an other association must be last in the list.
955
 
956
      procedure Check_Overloaded_Formal_Subprogram (Formal : Entity_Id);
957
      --  Apply RM 12.3 (9): if a formal subprogram is overloaded, the instance
958
      --  cannot have a named association for it. AI05-0025 extends this rule
959
      --  to formals of formal packages by AI05-0025, and it also applies to
960
      --  box-initialized formals.
961
 
962
      function Has_Fully_Defined_Profile (Subp : Entity_Id) return Boolean;
963
      --  Determine whether the parameter types and the return type of Subp
964
      --  are fully defined at the point of instantiation.
965
 
966
      function Matching_Actual
967
        (F   : Entity_Id;
968
         A_F : Entity_Id) return Node_Id;
969
      --  Find actual that corresponds to a given a formal parameter. If the
970
      --  actuals are positional, return the next one, if any. If the actuals
971
      --  are named, scan the parameter associations to find the right one.
972
      --  A_F is the corresponding entity in the analyzed generic,which is
973
      --  placed on the selector name for ASIS use.
974
      --
975
      --  In Ada 2005, a named association may be given with a box, in which
976
      --  case Matching_Actual sets Found_Assoc to the generic association,
977
      --  but return Empty for the actual itself. In this case the code below
978
      --  creates a corresponding declaration for the formal.
979
 
980
      function Partial_Parametrization return Boolean;
981
      --  Ada 2005: if no match is found for a given formal, check if the
982
      --  association for it includes a box, or whether the associations
983
      --  include an Others clause.
984
 
985
      procedure Process_Default (F : Entity_Id);
986
      --  Add a copy of the declaration of generic formal  F to the list of
987
      --  associations, and add an explicit box association for F  if there
988
      --  is none yet, and the default comes from an Others_Choice.
989
 
990
      function Renames_Standard_Subprogram (Subp : Entity_Id) return Boolean;
991
      --  Determine whether Subp renames one of the subprograms defined in the
992
      --  generated package Standard.
993
 
994
      procedure Set_Analyzed_Formal;
995
      --  Find the node in the generic copy that corresponds to a given formal.
996
      --  The semantic information on this node is used to perform legality
997
      --  checks on the actuals. Because semantic analysis can introduce some
998
      --  anonymous entities or modify the declaration node itself, the
999
      --  correspondence between the two lists is not one-one. In addition to
1000
      --  anonymous types, the presence a formal equality will introduce an
1001
      --  implicit declaration for the corresponding inequality.
1002
 
1003
      ----------------------------------------
1004
      -- Check_Overloaded_Formal_Subprogram --
1005
      ----------------------------------------
1006
 
1007
      procedure Check_Overloaded_Formal_Subprogram (Formal : Entity_Id) is
1008
         Temp_Formal : Entity_Id;
1009
 
1010
      begin
1011
         Temp_Formal := First (Formals);
1012
         while Present (Temp_Formal) loop
1013
            if Nkind (Temp_Formal) in N_Formal_Subprogram_Declaration
1014
              and then Temp_Formal /= Formal
1015
              and then
1016
                Chars (Defining_Unit_Name (Specification (Formal))) =
1017
                Chars (Defining_Unit_Name (Specification (Temp_Formal)))
1018
            then
1019
               if Present (Found_Assoc) then
1020
                  Error_Msg_N
1021
                    ("named association not allowed for overloaded formal",
1022
                     Found_Assoc);
1023
 
1024
               else
1025
                  Error_Msg_N
1026
                    ("named association not allowed for overloaded formal",
1027
                     Others_Choice);
1028
               end if;
1029
 
1030
               Abandon_Instantiation (Instantiation_Node);
1031
            end if;
1032
 
1033
            Next (Temp_Formal);
1034
         end loop;
1035
      end Check_Overloaded_Formal_Subprogram;
1036
 
1037
      -------------------------------
1038
      -- Has_Fully_Defined_Profile --
1039
      -------------------------------
1040
 
1041
      function Has_Fully_Defined_Profile (Subp : Entity_Id) return Boolean is
1042
         function Is_Fully_Defined_Type (Typ : Entity_Id) return Boolean;
1043
         --  Determine whethet type Typ is fully defined
1044
 
1045
         ---------------------------
1046
         -- Is_Fully_Defined_Type --
1047
         ---------------------------
1048
 
1049
         function Is_Fully_Defined_Type (Typ : Entity_Id) return Boolean is
1050
         begin
1051
            --  A private type without a full view is not fully defined
1052
 
1053
            if Is_Private_Type (Typ)
1054
              and then No (Full_View (Typ))
1055
            then
1056
               return False;
1057
 
1058
            --  An incomplete type is never fully defined
1059
 
1060
            elsif Is_Incomplete_Type (Typ) then
1061
               return False;
1062
 
1063
            --  All other types are fully defined
1064
 
1065
            else
1066
               return True;
1067
            end if;
1068
         end Is_Fully_Defined_Type;
1069
 
1070
         --  Local declarations
1071
 
1072
         Param : Entity_Id;
1073
 
1074
      --  Start of processing for Has_Fully_Defined_Profile
1075
 
1076
      begin
1077
         --  Check the parameters
1078
 
1079
         Param := First_Formal (Subp);
1080
         while Present (Param) loop
1081
            if not Is_Fully_Defined_Type (Etype (Param)) then
1082
               return False;
1083
            end if;
1084
 
1085
            Next_Formal (Param);
1086
         end loop;
1087
 
1088
         --  Check the return type
1089
 
1090
         return Is_Fully_Defined_Type (Etype (Subp));
1091
      end Has_Fully_Defined_Profile;
1092
 
1093
      ---------------------
1094
      -- Matching_Actual --
1095
      ---------------------
1096
 
1097
      function Matching_Actual
1098
        (F   : Entity_Id;
1099
         A_F : Entity_Id) return Node_Id
1100
      is
1101
         Prev  : Node_Id;
1102
         Act   : Node_Id;
1103
 
1104
      begin
1105
         Is_Named_Assoc := False;
1106
 
1107
         --  End of list of purely positional parameters
1108
 
1109
         if No (Actual) or else Nkind (Actual) = N_Others_Choice then
1110
            Found_Assoc := Empty;
1111
            Act         := Empty;
1112
 
1113
         --  Case of positional parameter corresponding to current formal
1114
 
1115
         elsif No (Selector_Name (Actual)) then
1116
            Found_Assoc := Actual;
1117
            Act :=  Explicit_Generic_Actual_Parameter (Actual);
1118
            Num_Matched := Num_Matched + 1;
1119
            Next (Actual);
1120
 
1121
         --  Otherwise scan list of named actuals to find the one with the
1122
         --  desired name. All remaining actuals have explicit names.
1123
 
1124
         else
1125
            Is_Named_Assoc := True;
1126
            Found_Assoc := Empty;
1127
            Act         := Empty;
1128
            Prev        := Empty;
1129
 
1130
            while Present (Actual) loop
1131
               if Chars (Selector_Name (Actual)) = Chars (F) then
1132
                  Set_Entity (Selector_Name (Actual), A_F);
1133
                  Set_Etype  (Selector_Name (Actual), Etype (A_F));
1134
                  Generate_Reference (A_F, Selector_Name (Actual));
1135
                  Found_Assoc := Actual;
1136
                  Act :=  Explicit_Generic_Actual_Parameter (Actual);
1137
                  Num_Matched := Num_Matched + 1;
1138
                  exit;
1139
               end if;
1140
 
1141
               Prev := Actual;
1142
               Next (Actual);
1143
            end loop;
1144
 
1145
            --  Reset for subsequent searches. In most cases the named
1146
            --  associations are in order. If they are not, we reorder them
1147
            --  to avoid scanning twice the same actual. This is not just a
1148
            --  question of efficiency: there may be multiple defaults with
1149
            --  boxes that have the same name. In a nested instantiation we
1150
            --  insert actuals for those defaults, and cannot rely on their
1151
            --  names to disambiguate them.
1152
 
1153
            if Actual = First_Named  then
1154
               Next (First_Named);
1155
 
1156
            elsif Present (Actual) then
1157
               Insert_Before (First_Named, Remove_Next (Prev));
1158
            end if;
1159
 
1160
            Actual := First_Named;
1161
         end if;
1162
 
1163
         if Is_Entity_Name (Act) and then Present (Entity (Act)) then
1164
            Set_Used_As_Generic_Actual (Entity (Act));
1165
         end if;
1166
 
1167
         return Act;
1168
      end Matching_Actual;
1169
 
1170
      -----------------------------
1171
      -- Partial_Parametrization --
1172
      -----------------------------
1173
 
1174
      function Partial_Parametrization return Boolean is
1175
      begin
1176
         return Others_Present
1177
          or else (Present (Found_Assoc) and then Box_Present (Found_Assoc));
1178
      end Partial_Parametrization;
1179
 
1180
      ---------------------
1181
      -- Process_Default --
1182
      ---------------------
1183
 
1184
      procedure Process_Default (F : Entity_Id)  is
1185
         Loc     : constant Source_Ptr := Sloc (I_Node);
1186
         F_Id    : constant Entity_Id  := Defining_Entity (F);
1187
         Decl    : Node_Id;
1188
         Default : Node_Id;
1189
         Id      : Entity_Id;
1190
 
1191
      begin
1192
         --  Append copy of formal declaration to associations, and create new
1193
         --  defining identifier for it.
1194
 
1195
         Decl := New_Copy_Tree (F);
1196
         Id := Make_Defining_Identifier (Sloc (F_Id), Chars (F_Id));
1197
 
1198
         if Nkind (F) in N_Formal_Subprogram_Declaration then
1199
            Set_Defining_Unit_Name (Specification (Decl), Id);
1200
 
1201
         else
1202
            Set_Defining_Identifier (Decl, Id);
1203
         end if;
1204
 
1205
         Append (Decl, Assoc);
1206
 
1207
         if No (Found_Assoc) then
1208
            Default :=
1209
               Make_Generic_Association (Loc,
1210
                 Selector_Name => New_Occurrence_Of (Id, Loc),
1211
                 Explicit_Generic_Actual_Parameter => Empty);
1212
            Set_Box_Present (Default);
1213
            Append (Default, Default_Formals);
1214
         end if;
1215
      end Process_Default;
1216
 
1217
      ---------------------------------
1218
      -- Renames_Standard_Subprogram --
1219
      ---------------------------------
1220
 
1221
      function Renames_Standard_Subprogram (Subp : Entity_Id) return Boolean is
1222
         Id : Entity_Id;
1223
 
1224
      begin
1225
         Id := Alias (Subp);
1226
         while Present (Id) loop
1227
            if Scope (Id) = Standard_Standard then
1228
               return True;
1229
            end if;
1230
 
1231
            Id := Alias (Id);
1232
         end loop;
1233
 
1234
         return False;
1235
      end Renames_Standard_Subprogram;
1236
 
1237
      -------------------------
1238
      -- Set_Analyzed_Formal --
1239
      -------------------------
1240
 
1241
      procedure Set_Analyzed_Formal is
1242
         Kind : Node_Kind;
1243
 
1244
      begin
1245
         while Present (Analyzed_Formal) loop
1246
            Kind := Nkind (Analyzed_Formal);
1247
 
1248
            case Nkind (Formal) is
1249
 
1250
               when N_Formal_Subprogram_Declaration =>
1251
                  exit when Kind in N_Formal_Subprogram_Declaration
1252
                    and then
1253
                      Chars
1254
                        (Defining_Unit_Name (Specification (Formal))) =
1255
                      Chars
1256
                        (Defining_Unit_Name (Specification (Analyzed_Formal)));
1257
 
1258
               when N_Formal_Package_Declaration =>
1259
                  exit when Nkind_In (Kind, N_Formal_Package_Declaration,
1260
                                            N_Generic_Package_Declaration,
1261
                                            N_Package_Declaration);
1262
 
1263
               when N_Use_Package_Clause | N_Use_Type_Clause => exit;
1264
 
1265
               when others =>
1266
 
1267
                  --  Skip freeze nodes, and nodes inserted to replace
1268
                  --  unrecognized pragmas.
1269
 
1270
                  exit when
1271
                    Kind not in N_Formal_Subprogram_Declaration
1272
                      and then not Nkind_In (Kind, N_Subprogram_Declaration,
1273
                                                   N_Freeze_Entity,
1274
                                                   N_Null_Statement,
1275
                                                   N_Itype_Reference)
1276
                      and then Chars (Defining_Identifier (Formal)) =
1277
                               Chars (Defining_Identifier (Analyzed_Formal));
1278
            end case;
1279
 
1280
            Next (Analyzed_Formal);
1281
         end loop;
1282
      end Set_Analyzed_Formal;
1283
 
1284
   --  Start of processing for Analyze_Associations
1285
 
1286
   begin
1287
      Actuals := Generic_Associations (I_Node);
1288
 
1289
      if Present (Actuals) then
1290
 
1291
         --  Check for an Others choice, indicating a partial parametrization
1292
         --  for a formal package.
1293
 
1294
         Actual := First (Actuals);
1295
         while Present (Actual) loop
1296
            if Nkind (Actual) = N_Others_Choice then
1297
               Others_Present := True;
1298
               Others_Choice  := Actual;
1299
 
1300
               if Present (Next (Actual)) then
1301
                  Error_Msg_N ("others must be last association", Actual);
1302
               end if;
1303
 
1304
               --  This subprogram is used both for formal packages and for
1305
               --  instantiations. For the latter, associations must all be
1306
               --  explicit.
1307
 
1308
               if Nkind (I_Node) /= N_Formal_Package_Declaration
1309
                 and then Comes_From_Source (I_Node)
1310
               then
1311
                  Error_Msg_N
1312
                    ("others association not allowed in an instance",
1313
                      Actual);
1314
               end if;
1315
 
1316
               --  In any case, nothing to do after the others association
1317
 
1318
               exit;
1319
 
1320
            elsif Box_Present (Actual)
1321
              and then Comes_From_Source (I_Node)
1322
              and then Nkind (I_Node) /= N_Formal_Package_Declaration
1323
            then
1324
               Error_Msg_N
1325
                 ("box association not allowed in an instance", Actual);
1326
            end if;
1327
 
1328
            Next (Actual);
1329
         end loop;
1330
 
1331
         --  If named associations are present, save first named association
1332
         --  (it may of course be Empty) to facilitate subsequent name search.
1333
 
1334
         First_Named := First (Actuals);
1335
         while Present (First_Named)
1336
           and then Nkind (First_Named) /= N_Others_Choice
1337
           and then No (Selector_Name (First_Named))
1338
         loop
1339
            Num_Actuals := Num_Actuals + 1;
1340
            Next (First_Named);
1341
         end loop;
1342
      end if;
1343
 
1344
      Named := First_Named;
1345
      while Present (Named) loop
1346
         if Nkind (Named) /= N_Others_Choice
1347
           and then No (Selector_Name (Named))
1348
         then
1349
            Error_Msg_N ("invalid positional actual after named one", Named);
1350
            Abandon_Instantiation (Named);
1351
         end if;
1352
 
1353
         --  A named association may lack an actual parameter, if it was
1354
         --  introduced for a default subprogram that turns out to be local
1355
         --  to the outer instantiation.
1356
 
1357
         if Nkind (Named) /= N_Others_Choice
1358
           and then Present (Explicit_Generic_Actual_Parameter (Named))
1359
         then
1360
            Num_Actuals := Num_Actuals + 1;
1361
         end if;
1362
 
1363
         Next (Named);
1364
      end loop;
1365
 
1366
      if Present (Formals) then
1367
         Formal := First_Non_Pragma (Formals);
1368
         Analyzed_Formal := First_Non_Pragma (F_Copy);
1369
 
1370
         if Present (Actuals) then
1371
            Actual := First (Actuals);
1372
 
1373
         --  All formals should have default values
1374
 
1375
         else
1376
            Actual := Empty;
1377
         end if;
1378
 
1379
         while Present (Formal) loop
1380
            Set_Analyzed_Formal;
1381
            Saved_Formal := Next_Non_Pragma (Formal);
1382
 
1383
            case Nkind (Formal) is
1384
               when N_Formal_Object_Declaration =>
1385
                  Match :=
1386
                    Matching_Actual (
1387
                      Defining_Identifier (Formal),
1388
                      Defining_Identifier (Analyzed_Formal));
1389
 
1390
                  if No (Match) and then Partial_Parametrization then
1391
                     Process_Default (Formal);
1392
                  else
1393
                     Append_List
1394
                       (Instantiate_Object (Formal, Match, Analyzed_Formal),
1395
                        Assoc);
1396
                  end if;
1397
 
1398
               when N_Formal_Type_Declaration =>
1399
                  Match :=
1400
                    Matching_Actual (
1401
                      Defining_Identifier (Formal),
1402
                      Defining_Identifier (Analyzed_Formal));
1403
 
1404
                  if No (Match) then
1405
                     if Partial_Parametrization then
1406
                        Process_Default (Formal);
1407
 
1408
                     else
1409
                        Error_Msg_Sloc := Sloc (Gen_Unit);
1410
                        Error_Msg_NE
1411
                          ("missing actual&",
1412
                            Instantiation_Node,
1413
                              Defining_Identifier (Formal));
1414
                        Error_Msg_NE ("\in instantiation of & declared#",
1415
                            Instantiation_Node, Gen_Unit);
1416
                        Abandon_Instantiation (Instantiation_Node);
1417
                     end if;
1418
 
1419
                  else
1420
                     Analyze (Match);
1421
                     Append_List
1422
                       (Instantiate_Type
1423
                          (Formal, Match, Analyzed_Formal, Assoc),
1424
                        Assoc);
1425
 
1426
                     --  An instantiation is a freeze point for the actuals,
1427
                     --  unless this is a rewritten formal package, or the
1428
                     --  formal is an Ada 2012 formal incomplete type.
1429
 
1430
                     if Nkind (I_Node) = N_Formal_Package_Declaration
1431
                       or else
1432
                         (Ada_Version >= Ada_2012
1433
                           and then
1434
                             Ekind (Defining_Identifier (Analyzed_Formal)) =
1435
                                                            E_Incomplete_Type)
1436
                     then
1437
                        null;
1438
 
1439
                     else
1440
                        Append_Elmt (Entity (Match), Actuals_To_Freeze);
1441
                     end if;
1442
                  end if;
1443
 
1444
                  --  A remote access-to-class-wide type is not a legal actual
1445
                  --  for a generic formal of an access type (E.2.2(17/2)).
1446
                  --  In GNAT an exception to this rule is introduced when
1447
                  --  the formal is marked as remote using implementation
1448
                  --  defined aspect/pragma Remote_Access_Type. In that case
1449
                  --  the actual must be remote as well.
1450
 
1451
                  if Nkind (Analyzed_Formal) = N_Formal_Type_Declaration
1452
                    and then
1453
                      Nkind (Formal_Type_Definition (Analyzed_Formal)) =
1454
                                            N_Access_To_Object_Definition
1455
                  then
1456
                     declare
1457
                        Formal_Ent : constant Entity_Id :=
1458
                                        Defining_Identifier (Analyzed_Formal);
1459
                     begin
1460
                        if Is_Remote_Access_To_Class_Wide_Type (Entity (Match))
1461
                             = Is_Remote_Types (Formal_Ent)
1462
                        then
1463
                           --  Remoteness of formal and actual match
1464
 
1465
                           null;
1466
 
1467
                        elsif Is_Remote_Types (Formal_Ent) then
1468
 
1469
                           --  Remote formal, non-remote actual
1470
 
1471
                           Error_Msg_NE
1472
                             ("actual for& must be remote", Match, Formal_Ent);
1473
 
1474
                        else
1475
                           --  Non-remote formal, remote actual
1476
 
1477
                           Error_Msg_NE
1478
                             ("actual for& may not be remote",
1479
                              Match, Formal_Ent);
1480
                        end if;
1481
                     end;
1482
                  end if;
1483
 
1484
               when N_Formal_Subprogram_Declaration =>
1485
                  Match :=
1486
                    Matching_Actual
1487
                      (Defining_Unit_Name (Specification (Formal)),
1488
                       Defining_Unit_Name (Specification (Analyzed_Formal)));
1489
 
1490
                  --  If the formal subprogram has the same name as another
1491
                  --  formal subprogram of the generic, then a named
1492
                  --  association is illegal (12.3(9)). Exclude named
1493
                  --  associations that are generated for a nested instance.
1494
 
1495
                  if Present (Match)
1496
                    and then Is_Named_Assoc
1497
                    and then Comes_From_Source (Found_Assoc)
1498
                  then
1499
                     Check_Overloaded_Formal_Subprogram (Formal);
1500
                  end if;
1501
 
1502
                  --  If there is no corresponding actual, this may be case of
1503
                  --  partial parametrization, or else the formal has a default
1504
                  --  or a box.
1505
 
1506
                  if No (Match) and then Partial_Parametrization then
1507
                     Process_Default (Formal);
1508
 
1509
                     if Nkind (I_Node) = N_Formal_Package_Declaration then
1510
                        Check_Overloaded_Formal_Subprogram (Formal);
1511
                     end if;
1512
 
1513
                  else
1514
                     Append_To (Assoc,
1515
                       Instantiate_Formal_Subprogram
1516
                         (Formal, Match, Analyzed_Formal));
1517
 
1518
                     --  An instantiation is a freeze point for the actuals,
1519
                     --  unless this is a rewritten formal package.
1520
 
1521
                     if Nkind (I_Node) /= N_Formal_Package_Declaration
1522
                       and then Nkind (Match) = N_Identifier
1523
                       and then Is_Subprogram (Entity (Match))
1524
 
1525
                       --  The actual subprogram may rename a routine defined
1526
                       --  in Standard. Avoid freezing such renamings because
1527
                       --  subprograms coming from Standard cannot be frozen.
1528
 
1529
                       and then
1530
                         not Renames_Standard_Subprogram (Entity (Match))
1531
 
1532
                       --  If the actual subprogram comes from a different
1533
                       --  unit, it is already frozen, either by a body in
1534
                       --  that unit or by the end of the declarative part
1535
                       --  of the unit. This check avoids the freezing of
1536
                       --  subprograms defined in Standard which are used
1537
                       --  as generic actuals.
1538
 
1539
                       and then In_Same_Code_Unit (Entity (Match), I_Node)
1540
                       and then Has_Fully_Defined_Profile (Entity (Match))
1541
                     then
1542
                        --  Mark the subprogram as having a delayed freeze
1543
                        --  since this may be an out-of-order action.
1544
 
1545
                        Set_Has_Delayed_Freeze (Entity (Match));
1546
                        Append_Elmt (Entity (Match), Actuals_To_Freeze);
1547
                     end if;
1548
                  end if;
1549
 
1550
                  --  If this is a nested generic, preserve default for later
1551
                  --  instantiations.
1552
 
1553
                  if No (Match)
1554
                    and then Box_Present (Formal)
1555
                  then
1556
                     Append_Elmt
1557
                       (Defining_Unit_Name (Specification (Last (Assoc))),
1558
                        Default_Actuals);
1559
                  end if;
1560
 
1561
               when N_Formal_Package_Declaration =>
1562
                  Match :=
1563
                    Matching_Actual (
1564
                      Defining_Identifier (Formal),
1565
                      Defining_Identifier (Original_Node (Analyzed_Formal)));
1566
 
1567
                  if No (Match) then
1568
                     if Partial_Parametrization then
1569
                        Process_Default (Formal);
1570
 
1571
                     else
1572
                        Error_Msg_Sloc := Sloc (Gen_Unit);
1573
                        Error_Msg_NE
1574
                          ("missing actual&",
1575
                            Instantiation_Node, Defining_Identifier (Formal));
1576
                        Error_Msg_NE ("\in instantiation of & declared#",
1577
                            Instantiation_Node, Gen_Unit);
1578
 
1579
                        Abandon_Instantiation (Instantiation_Node);
1580
                     end if;
1581
 
1582
                  else
1583
                     Analyze (Match);
1584
                     Append_List
1585
                       (Instantiate_Formal_Package
1586
                         (Formal, Match, Analyzed_Formal),
1587
                        Assoc);
1588
                  end if;
1589
 
1590
               --  For use type and use package appearing in the generic part,
1591
               --  we have already copied them, so we can just move them where
1592
               --  they belong (we mustn't recopy them since this would mess up
1593
               --  the Sloc values).
1594
 
1595
               when N_Use_Package_Clause |
1596
                    N_Use_Type_Clause    =>
1597
                  if Nkind (Original_Node (I_Node)) =
1598
                                     N_Formal_Package_Declaration
1599
                  then
1600
                     Append (New_Copy_Tree (Formal), Assoc);
1601
                  else
1602
                     Remove (Formal);
1603
                     Append (Formal, Assoc);
1604
                  end if;
1605
 
1606
               when others =>
1607
                  raise Program_Error;
1608
 
1609
            end case;
1610
 
1611
            Formal := Saved_Formal;
1612
            Next_Non_Pragma (Analyzed_Formal);
1613
         end loop;
1614
 
1615
         if Num_Actuals > Num_Matched then
1616
            Error_Msg_Sloc := Sloc (Gen_Unit);
1617
 
1618
            if Present (Selector_Name (Actual)) then
1619
               Error_Msg_NE
1620
                 ("unmatched actual&",
1621
                    Actual, Selector_Name (Actual));
1622
               Error_Msg_NE ("\in instantiation of& declared#",
1623
                    Actual, Gen_Unit);
1624
            else
1625
               Error_Msg_NE
1626
                 ("unmatched actual in instantiation of& declared#",
1627
                   Actual, Gen_Unit);
1628
            end if;
1629
         end if;
1630
 
1631
      elsif Present (Actuals) then
1632
         Error_Msg_N
1633
           ("too many actuals in generic instantiation", Instantiation_Node);
1634
      end if;
1635
 
1636
      --  An instantiation freezes all generic actuals. The only exceptions
1637
      --  to this are incomplete types and subprograms which are not fully
1638
      --  defined at the point of instantiation.
1639
 
1640
      declare
1641
         Elmt : Elmt_Id := First_Elmt (Actuals_To_Freeze);
1642
      begin
1643
         while Present (Elmt) loop
1644
            Freeze_Before (I_Node, Node (Elmt));
1645
            Next_Elmt (Elmt);
1646
         end loop;
1647
      end;
1648
 
1649
      --  If there are default subprograms, normalize the tree by adding
1650
      --  explicit associations for them. This is required if the instance
1651
      --  appears within a generic.
1652
 
1653
      declare
1654
         Elmt  : Elmt_Id;
1655
         Subp  : Entity_Id;
1656
         New_D : Node_Id;
1657
 
1658
      begin
1659
         Elmt := First_Elmt (Default_Actuals);
1660
         while Present (Elmt) loop
1661
            if No (Actuals) then
1662
               Actuals := New_List;
1663
               Set_Generic_Associations (I_Node, Actuals);
1664
            end if;
1665
 
1666
            Subp := Node (Elmt);
1667
            New_D :=
1668
              Make_Generic_Association (Sloc (Subp),
1669
                Selector_Name => New_Occurrence_Of (Subp, Sloc (Subp)),
1670
                  Explicit_Generic_Actual_Parameter =>
1671
                    New_Occurrence_Of (Subp, Sloc (Subp)));
1672
            Mark_Rewrite_Insertion (New_D);
1673
            Append_To (Actuals, New_D);
1674
            Next_Elmt (Elmt);
1675
         end loop;
1676
      end;
1677
 
1678
      --  If this is a formal package, normalize the parameter list by adding
1679
      --  explicit box associations for the formals that are covered by an
1680
      --  Others_Choice.
1681
 
1682
      if not Is_Empty_List (Default_Formals) then
1683
         Append_List (Default_Formals, Formals);
1684
      end if;
1685
 
1686
      return Assoc;
1687
   end Analyze_Associations;
1688
 
1689
   -------------------------------
1690
   -- Analyze_Formal_Array_Type --
1691
   -------------------------------
1692
 
1693
   procedure Analyze_Formal_Array_Type
1694
     (T   : in out Entity_Id;
1695
      Def : Node_Id)
1696
   is
1697
      DSS : Node_Id;
1698
 
1699
   begin
1700
      --  Treated like a non-generic array declaration, with additional
1701
      --  semantic checks.
1702
 
1703
      Enter_Name (T);
1704
 
1705
      if Nkind (Def) = N_Constrained_Array_Definition then
1706
         DSS := First (Discrete_Subtype_Definitions (Def));
1707
         while Present (DSS) loop
1708
            if Nkind_In (DSS, N_Subtype_Indication,
1709
                              N_Range,
1710
                              N_Attribute_Reference)
1711
            then
1712
               Error_Msg_N ("only a subtype mark is allowed in a formal", DSS);
1713
            end if;
1714
 
1715
            Next (DSS);
1716
         end loop;
1717
      end if;
1718
 
1719
      Array_Type_Declaration (T, Def);
1720
      Set_Is_Generic_Type (Base_Type (T));
1721
 
1722
      if Ekind (Component_Type (T)) = E_Incomplete_Type
1723
        and then No (Full_View (Component_Type (T)))
1724
      then
1725
         Error_Msg_N ("premature usage of incomplete type", Def);
1726
 
1727
      --  Check that range constraint is not allowed on the component type
1728
      --  of a generic formal array type (AARM 12.5.3(3))
1729
 
1730
      elsif Is_Internal (Component_Type (T))
1731
        and then Present (Subtype_Indication (Component_Definition (Def)))
1732
        and then Nkind (Original_Node
1733
                         (Subtype_Indication (Component_Definition (Def)))) =
1734
                                                         N_Subtype_Indication
1735
      then
1736
         Error_Msg_N
1737
           ("in a formal, a subtype indication can only be "
1738
             & "a subtype mark (RM 12.5.3(3))",
1739
             Subtype_Indication (Component_Definition (Def)));
1740
      end if;
1741
 
1742
   end Analyze_Formal_Array_Type;
1743
 
1744
   ---------------------------------------------
1745
   -- Analyze_Formal_Decimal_Fixed_Point_Type --
1746
   ---------------------------------------------
1747
 
1748
   --  As for other generic types, we create a valid type representation with
1749
   --  legal but arbitrary attributes, whose values are never considered
1750
   --  static. For all scalar types we introduce an anonymous base type, with
1751
   --  the same attributes. We choose the corresponding integer type to be
1752
   --  Standard_Integer.
1753
   --  Here and in other similar routines, the Sloc of the generated internal
1754
   --  type must be the same as the sloc of the defining identifier of the
1755
   --  formal type declaration, to provide proper source navigation.
1756
 
1757
   procedure Analyze_Formal_Decimal_Fixed_Point_Type
1758
     (T   : Entity_Id;
1759
      Def : Node_Id)
1760
   is
1761
      Loc : constant Source_Ptr := Sloc (Def);
1762
 
1763
      Base : constant Entity_Id :=
1764
               New_Internal_Entity
1765
                 (E_Decimal_Fixed_Point_Type,
1766
                  Current_Scope,
1767
                  Sloc (Defining_Identifier (Parent (Def))), 'G');
1768
 
1769
      Int_Base  : constant Entity_Id := Standard_Integer;
1770
      Delta_Val : constant Ureal := Ureal_1;
1771
      Digs_Val  : constant Uint  := Uint_6;
1772
 
1773
   begin
1774
      Enter_Name (T);
1775
 
1776
      Set_Etype          (Base, Base);
1777
      Set_Size_Info      (Base, Int_Base);
1778
      Set_RM_Size        (Base, RM_Size (Int_Base));
1779
      Set_First_Rep_Item (Base, First_Rep_Item (Int_Base));
1780
      Set_Digits_Value   (Base, Digs_Val);
1781
      Set_Delta_Value    (Base, Delta_Val);
1782
      Set_Small_Value    (Base, Delta_Val);
1783
      Set_Scalar_Range   (Base,
1784
        Make_Range (Loc,
1785
          Low_Bound  => Make_Real_Literal (Loc, Ureal_1),
1786
          High_Bound => Make_Real_Literal (Loc, Ureal_1)));
1787
 
1788
      Set_Is_Generic_Type (Base);
1789
      Set_Parent          (Base, Parent (Def));
1790
 
1791
      Set_Ekind          (T, E_Decimal_Fixed_Point_Subtype);
1792
      Set_Etype          (T, Base);
1793
      Set_Size_Info      (T, Int_Base);
1794
      Set_RM_Size        (T, RM_Size (Int_Base));
1795
      Set_First_Rep_Item (T, First_Rep_Item (Int_Base));
1796
      Set_Digits_Value   (T, Digs_Val);
1797
      Set_Delta_Value    (T, Delta_Val);
1798
      Set_Small_Value    (T, Delta_Val);
1799
      Set_Scalar_Range   (T, Scalar_Range (Base));
1800
      Set_Is_Constrained (T);
1801
 
1802
      Check_Restriction (No_Fixed_Point, Def);
1803
   end Analyze_Formal_Decimal_Fixed_Point_Type;
1804
 
1805
   -------------------------------------------
1806
   -- Analyze_Formal_Derived_Interface_Type --
1807
   -------------------------------------------
1808
 
1809
   procedure Analyze_Formal_Derived_Interface_Type
1810
     (N   : Node_Id;
1811
      T   : Entity_Id;
1812
      Def : Node_Id)
1813
   is
1814
      Loc   : constant Source_Ptr := Sloc (Def);
1815
 
1816
   begin
1817
      --  Rewrite as a type declaration of a derived type. This ensures that
1818
      --  the interface list and primitive operations are properly captured.
1819
 
1820
      Rewrite (N,
1821
        Make_Full_Type_Declaration (Loc,
1822
          Defining_Identifier => T,
1823
          Type_Definition     => Def));
1824
      Analyze (N);
1825
      Set_Is_Generic_Type (T);
1826
   end Analyze_Formal_Derived_Interface_Type;
1827
 
1828
   ---------------------------------
1829
   -- Analyze_Formal_Derived_Type --
1830
   ---------------------------------
1831
 
1832
   procedure Analyze_Formal_Derived_Type
1833
     (N   : Node_Id;
1834
      T   : Entity_Id;
1835
      Def : Node_Id)
1836
   is
1837
      Loc      : constant Source_Ptr := Sloc (Def);
1838
      Unk_Disc : constant Boolean    := Unknown_Discriminants_Present (N);
1839
      New_N    : Node_Id;
1840
 
1841
   begin
1842
      Set_Is_Generic_Type (T);
1843
 
1844
      if Private_Present (Def) then
1845
         New_N :=
1846
           Make_Private_Extension_Declaration (Loc,
1847
             Defining_Identifier           => T,
1848
             Discriminant_Specifications   => Discriminant_Specifications (N),
1849
             Unknown_Discriminants_Present => Unk_Disc,
1850
             Subtype_Indication            => Subtype_Mark (Def),
1851
             Interface_List                => Interface_List (Def));
1852
 
1853
         Set_Abstract_Present     (New_N, Abstract_Present     (Def));
1854
         Set_Limited_Present      (New_N, Limited_Present      (Def));
1855
         Set_Synchronized_Present (New_N, Synchronized_Present (Def));
1856
 
1857
      else
1858
         New_N :=
1859
           Make_Full_Type_Declaration (Loc,
1860
             Defining_Identifier => T,
1861
             Discriminant_Specifications =>
1862
               Discriminant_Specifications (Parent (T)),
1863
             Type_Definition =>
1864
               Make_Derived_Type_Definition (Loc,
1865
                 Subtype_Indication => Subtype_Mark (Def)));
1866
 
1867
         Set_Abstract_Present
1868
           (Type_Definition (New_N), Abstract_Present (Def));
1869
         Set_Limited_Present
1870
           (Type_Definition (New_N), Limited_Present  (Def));
1871
      end if;
1872
 
1873
      Rewrite (N, New_N);
1874
      Analyze (N);
1875
 
1876
      if Unk_Disc then
1877
         if not Is_Composite_Type (T) then
1878
            Error_Msg_N
1879
              ("unknown discriminants not allowed for elementary types", N);
1880
         else
1881
            Set_Has_Unknown_Discriminants (T);
1882
            Set_Is_Constrained (T, False);
1883
         end if;
1884
      end if;
1885
 
1886
      --  If the parent type has a known size, so does the formal, which makes
1887
      --  legal representation clauses that involve the formal.
1888
 
1889
      Set_Size_Known_At_Compile_Time
1890
        (T, Size_Known_At_Compile_Time (Entity (Subtype_Mark (Def))));
1891
   end Analyze_Formal_Derived_Type;
1892
 
1893
   ----------------------------------
1894
   -- Analyze_Formal_Discrete_Type --
1895
   ----------------------------------
1896
 
1897
   --  The operations defined for a discrete types are those of an enumeration
1898
   --  type. The size is set to an arbitrary value, for use in analyzing the
1899
   --  generic unit.
1900
 
1901
   procedure Analyze_Formal_Discrete_Type (T : Entity_Id; Def : Node_Id) is
1902
      Loc : constant Source_Ptr := Sloc (Def);
1903
      Lo  : Node_Id;
1904
      Hi  : Node_Id;
1905
 
1906
      Base : constant Entity_Id :=
1907
               New_Internal_Entity
1908
                 (E_Floating_Point_Type, Current_Scope,
1909
                  Sloc (Defining_Identifier (Parent (Def))), 'G');
1910
 
1911
   begin
1912
      Enter_Name          (T);
1913
      Set_Ekind           (T, E_Enumeration_Subtype);
1914
      Set_Etype           (T, Base);
1915
      Init_Size           (T, 8);
1916
      Init_Alignment      (T);
1917
      Set_Is_Generic_Type (T);
1918
      Set_Is_Constrained  (T);
1919
 
1920
      --  For semantic analysis, the bounds of the type must be set to some
1921
      --  non-static value. The simplest is to create attribute nodes for those
1922
      --  bounds, that refer to the type itself. These bounds are never
1923
      --  analyzed but serve as place-holders.
1924
 
1925
      Lo :=
1926
        Make_Attribute_Reference (Loc,
1927
          Attribute_Name => Name_First,
1928
          Prefix         => New_Reference_To (T, Loc));
1929
      Set_Etype (Lo, T);
1930
 
1931
      Hi :=
1932
        Make_Attribute_Reference (Loc,
1933
          Attribute_Name => Name_Last,
1934
          Prefix         => New_Reference_To (T, Loc));
1935
      Set_Etype (Hi, T);
1936
 
1937
      Set_Scalar_Range (T,
1938
        Make_Range (Loc,
1939
          Low_Bound  => Lo,
1940
          High_Bound => Hi));
1941
 
1942
      Set_Ekind           (Base, E_Enumeration_Type);
1943
      Set_Etype           (Base, Base);
1944
      Init_Size           (Base, 8);
1945
      Init_Alignment      (Base);
1946
      Set_Is_Generic_Type (Base);
1947
      Set_Scalar_Range    (Base, Scalar_Range (T));
1948
      Set_Parent          (Base, Parent (Def));
1949
   end Analyze_Formal_Discrete_Type;
1950
 
1951
   ----------------------------------
1952
   -- Analyze_Formal_Floating_Type --
1953
   ---------------------------------
1954
 
1955
   procedure Analyze_Formal_Floating_Type (T : Entity_Id; Def : Node_Id) is
1956
      Base : constant Entity_Id :=
1957
               New_Internal_Entity
1958
                 (E_Floating_Point_Type, Current_Scope,
1959
                  Sloc (Defining_Identifier (Parent (Def))), 'G');
1960
 
1961
   begin
1962
      --  The various semantic attributes are taken from the predefined type
1963
      --  Float, just so that all of them are initialized. Their values are
1964
      --  never used because no constant folding or expansion takes place in
1965
      --  the generic itself.
1966
 
1967
      Enter_Name (T);
1968
      Set_Ekind          (T, E_Floating_Point_Subtype);
1969
      Set_Etype          (T, Base);
1970
      Set_Size_Info      (T,              (Standard_Float));
1971
      Set_RM_Size        (T, RM_Size      (Standard_Float));
1972
      Set_Digits_Value   (T, Digits_Value (Standard_Float));
1973
      Set_Scalar_Range   (T, Scalar_Range (Standard_Float));
1974
      Set_Is_Constrained (T);
1975
 
1976
      Set_Is_Generic_Type (Base);
1977
      Set_Etype           (Base, Base);
1978
      Set_Size_Info       (Base,              (Standard_Float));
1979
      Set_RM_Size         (Base, RM_Size      (Standard_Float));
1980
      Set_Digits_Value    (Base, Digits_Value (Standard_Float));
1981
      Set_Scalar_Range    (Base, Scalar_Range (Standard_Float));
1982
      Set_Parent          (Base, Parent (Def));
1983
 
1984
      Check_Restriction (No_Floating_Point, Def);
1985
   end Analyze_Formal_Floating_Type;
1986
 
1987
   -----------------------------------
1988
   -- Analyze_Formal_Interface_Type;--
1989
   -----------------------------------
1990
 
1991
   procedure Analyze_Formal_Interface_Type
1992
      (N   : Node_Id;
1993
       T   : Entity_Id;
1994
       Def : Node_Id)
1995
   is
1996
      Loc   : constant Source_Ptr := Sloc (N);
1997
      New_N : Node_Id;
1998
 
1999
   begin
2000
      New_N :=
2001
        Make_Full_Type_Declaration (Loc,
2002
          Defining_Identifier => T,
2003
          Type_Definition => Def);
2004
 
2005
      Rewrite (N, New_N);
2006
      Analyze (N);
2007
      Set_Is_Generic_Type (T);
2008
   end Analyze_Formal_Interface_Type;
2009
 
2010
   ---------------------------------
2011
   -- Analyze_Formal_Modular_Type --
2012
   ---------------------------------
2013
 
2014
   procedure Analyze_Formal_Modular_Type (T : Entity_Id; Def : Node_Id) is
2015
   begin
2016
      --  Apart from their entity kind, generic modular types are treated like
2017
      --  signed integer types, and have the same attributes.
2018
 
2019
      Analyze_Formal_Signed_Integer_Type (T, Def);
2020
      Set_Ekind (T, E_Modular_Integer_Subtype);
2021
      Set_Ekind (Etype (T), E_Modular_Integer_Type);
2022
 
2023
   end Analyze_Formal_Modular_Type;
2024
 
2025
   ---------------------------------------
2026
   -- Analyze_Formal_Object_Declaration --
2027
   ---------------------------------------
2028
 
2029
   procedure Analyze_Formal_Object_Declaration (N : Node_Id) is
2030
      E  : constant Node_Id := Default_Expression (N);
2031
      Id : constant Node_Id := Defining_Identifier (N);
2032
      K  : Entity_Kind;
2033
      T  : Node_Id;
2034
 
2035
   begin
2036
      Enter_Name (Id);
2037
 
2038
      --  Determine the mode of the formal object
2039
 
2040
      if Out_Present (N) then
2041
         K := E_Generic_In_Out_Parameter;
2042
 
2043
         if not In_Present (N) then
2044
            Error_Msg_N ("formal generic objects cannot have mode OUT", N);
2045
         end if;
2046
 
2047
      else
2048
         K := E_Generic_In_Parameter;
2049
      end if;
2050
 
2051
      if Present (Subtype_Mark (N)) then
2052
         Find_Type (Subtype_Mark (N));
2053
         T := Entity (Subtype_Mark (N));
2054
 
2055
         --  Verify that there is no redundant null exclusion
2056
 
2057
         if Null_Exclusion_Present (N) then
2058
            if not Is_Access_Type (T) then
2059
               Error_Msg_N
2060
                 ("null exclusion can only apply to an access type", N);
2061
 
2062
            elsif Can_Never_Be_Null (T) then
2063
               Error_Msg_NE
2064
                 ("`NOT NULL` not allowed (& already excludes null)",
2065
                    N, T);
2066
            end if;
2067
         end if;
2068
 
2069
      --  Ada 2005 (AI-423): Formal object with an access definition
2070
 
2071
      else
2072
         Check_Access_Definition (N);
2073
         T := Access_Definition
2074
                (Related_Nod => N,
2075
                 N           => Access_Definition (N));
2076
      end if;
2077
 
2078
      if Ekind (T) = E_Incomplete_Type then
2079
         declare
2080
            Error_Node : Node_Id;
2081
 
2082
         begin
2083
            if Present (Subtype_Mark (N)) then
2084
               Error_Node := Subtype_Mark (N);
2085
            else
2086
               Check_Access_Definition (N);
2087
               Error_Node := Access_Definition (N);
2088
            end if;
2089
 
2090
            Error_Msg_N ("premature usage of incomplete type", Error_Node);
2091
         end;
2092
      end if;
2093
 
2094
      if K = E_Generic_In_Parameter then
2095
 
2096
         --  Ada 2005 (AI-287): Limited aggregates allowed in generic formals
2097
 
2098
         if Ada_Version < Ada_2005 and then Is_Limited_Type (T) then
2099
            Error_Msg_N
2100
              ("generic formal of mode IN must not be of limited type", N);
2101
            Explain_Limited_Type (T, N);
2102
         end if;
2103
 
2104
         if Is_Abstract_Type (T) then
2105
            Error_Msg_N
2106
              ("generic formal of mode IN must not be of abstract type", N);
2107
         end if;
2108
 
2109
         if Present (E) then
2110
            Preanalyze_Spec_Expression (E, T);
2111
 
2112
            if Is_Limited_Type (T) and then not OK_For_Limited_Init (T, E) then
2113
               Error_Msg_N
2114
                 ("initialization not allowed for limited types", E);
2115
               Explain_Limited_Type (T, E);
2116
            end if;
2117
         end if;
2118
 
2119
         Set_Ekind (Id, K);
2120
         Set_Etype (Id, T);
2121
 
2122
      --  Case of generic IN OUT parameter
2123
 
2124
      else
2125
         --  If the formal has an unconstrained type, construct its actual
2126
         --  subtype, as is done for subprogram formals. In this fashion, all
2127
         --  its uses can refer to specific bounds.
2128
 
2129
         Set_Ekind (Id, K);
2130
         Set_Etype (Id, T);
2131
 
2132
         if (Is_Array_Type (T)
2133
              and then not Is_Constrained (T))
2134
           or else
2135
            (Ekind (T) = E_Record_Type
2136
              and then Has_Discriminants (T))
2137
         then
2138
            declare
2139
               Non_Freezing_Ref : constant Node_Id :=
2140
                                    New_Reference_To (Id, Sloc (Id));
2141
               Decl : Node_Id;
2142
 
2143
            begin
2144
               --  Make sure the actual subtype doesn't generate bogus freezing
2145
 
2146
               Set_Must_Not_Freeze (Non_Freezing_Ref);
2147
               Decl := Build_Actual_Subtype (T, Non_Freezing_Ref);
2148
               Insert_Before_And_Analyze (N, Decl);
2149
               Set_Actual_Subtype (Id, Defining_Identifier (Decl));
2150
            end;
2151
         else
2152
            Set_Actual_Subtype (Id, T);
2153
         end if;
2154
 
2155
         if Present (E) then
2156
            Error_Msg_N
2157
              ("initialization not allowed for `IN OUT` formals", N);
2158
         end if;
2159
      end if;
2160
 
2161
      if Has_Aspects (N) then
2162
         Analyze_Aspect_Specifications (N, Id);
2163
      end if;
2164
   end Analyze_Formal_Object_Declaration;
2165
 
2166
   ----------------------------------------------
2167
   -- Analyze_Formal_Ordinary_Fixed_Point_Type --
2168
   ----------------------------------------------
2169
 
2170
   procedure Analyze_Formal_Ordinary_Fixed_Point_Type
2171
     (T   : Entity_Id;
2172
      Def : Node_Id)
2173
   is
2174
      Loc  : constant Source_Ptr := Sloc (Def);
2175
      Base : constant Entity_Id :=
2176
               New_Internal_Entity
2177
                 (E_Ordinary_Fixed_Point_Type, Current_Scope,
2178
                  Sloc (Defining_Identifier (Parent (Def))), 'G');
2179
 
2180
   begin
2181
      --  The semantic attributes are set for completeness only, their values
2182
      --  will never be used, since all properties of the type are non-static.
2183
 
2184
      Enter_Name (T);
2185
      Set_Ekind            (T, E_Ordinary_Fixed_Point_Subtype);
2186
      Set_Etype            (T, Base);
2187
      Set_Size_Info        (T, Standard_Integer);
2188
      Set_RM_Size          (T, RM_Size (Standard_Integer));
2189
      Set_Small_Value      (T, Ureal_1);
2190
      Set_Delta_Value      (T, Ureal_1);
2191
      Set_Scalar_Range     (T,
2192
        Make_Range (Loc,
2193
          Low_Bound  => Make_Real_Literal (Loc, Ureal_1),
2194
          High_Bound => Make_Real_Literal (Loc, Ureal_1)));
2195
      Set_Is_Constrained   (T);
2196
 
2197
      Set_Is_Generic_Type (Base);
2198
      Set_Etype           (Base, Base);
2199
      Set_Size_Info       (Base, Standard_Integer);
2200
      Set_RM_Size         (Base, RM_Size (Standard_Integer));
2201
      Set_Small_Value     (Base, Ureal_1);
2202
      Set_Delta_Value     (Base, Ureal_1);
2203
      Set_Scalar_Range    (Base, Scalar_Range (T));
2204
      Set_Parent          (Base, Parent (Def));
2205
 
2206
      Check_Restriction (No_Fixed_Point, Def);
2207
   end Analyze_Formal_Ordinary_Fixed_Point_Type;
2208
 
2209
   ----------------------------------------
2210
   -- Analyze_Formal_Package_Declaration --
2211
   ----------------------------------------
2212
 
2213
   procedure Analyze_Formal_Package_Declaration (N : Node_Id) is
2214
      Loc              : constant Source_Ptr := Sloc (N);
2215
      Pack_Id          : constant Entity_Id  := Defining_Identifier (N);
2216
      Formal           : Entity_Id;
2217
      Gen_Id           : constant Node_Id    := Name (N);
2218
      Gen_Decl         : Node_Id;
2219
      Gen_Unit         : Entity_Id;
2220
      New_N            : Node_Id;
2221
      Parent_Installed : Boolean := False;
2222
      Renaming         : Node_Id;
2223
      Parent_Instance  : Entity_Id;
2224
      Renaming_In_Par  : Entity_Id;
2225
      Associations     : Boolean := True;
2226
 
2227
      Vis_Prims_List : Elist_Id := No_Elist;
2228
      --  List of primitives made temporarily visible in the instantiation
2229
      --  to match the visibility of the formal type
2230
 
2231
      function Build_Local_Package return Node_Id;
2232
      --  The formal package is rewritten so that its parameters are replaced
2233
      --  with corresponding declarations. For parameters with bona fide
2234
      --  associations these declarations are created by Analyze_Associations
2235
      --  as for a regular instantiation. For boxed parameters, we preserve
2236
      --  the formal declarations and analyze them, in order to introduce
2237
      --  entities of the right kind in the environment of the formal.
2238
 
2239
      -------------------------
2240
      -- Build_Local_Package --
2241
      -------------------------
2242
 
2243
      function Build_Local_Package return Node_Id is
2244
         Decls     : List_Id;
2245
         Pack_Decl : Node_Id;
2246
 
2247
      begin
2248
         --  Within the formal, the name of the generic package is a renaming
2249
         --  of the formal (as for a regular instantiation).
2250
 
2251
         Pack_Decl :=
2252
           Make_Package_Declaration (Loc,
2253
             Specification =>
2254
               Copy_Generic_Node
2255
                 (Specification (Original_Node (Gen_Decl)),
2256
                    Empty, Instantiating => True));
2257
 
2258
         Renaming := Make_Package_Renaming_Declaration (Loc,
2259
             Defining_Unit_Name =>
2260
               Make_Defining_Identifier (Loc, Chars (Gen_Unit)),
2261
             Name => New_Occurrence_Of (Formal, Loc));
2262
 
2263
         if Nkind (Gen_Id) = N_Identifier
2264
           and then Chars (Gen_Id) = Chars (Pack_Id)
2265
         then
2266
            Error_Msg_NE
2267
              ("& is hidden within declaration of instance", Gen_Id, Gen_Unit);
2268
         end if;
2269
 
2270
         --  If the formal is declared with a box, or with an others choice,
2271
         --  create corresponding declarations for all entities in the formal
2272
         --  part, so that names with the proper types are available in the
2273
         --  specification of the formal package.
2274
 
2275
         --  On the other hand, if there are no associations, then all the
2276
         --  formals must have defaults, and this will be checked by the
2277
         --  call to Analyze_Associations.
2278
 
2279
         if Box_Present (N)
2280
           or else Nkind (First (Generic_Associations (N))) = N_Others_Choice
2281
         then
2282
            declare
2283
               Formal_Decl : Node_Id;
2284
 
2285
            begin
2286
               --  TBA : for a formal package, need to recurse ???
2287
 
2288
               Decls := New_List;
2289
               Formal_Decl :=
2290
                 First
2291
                   (Generic_Formal_Declarations (Original_Node (Gen_Decl)));
2292
               while Present (Formal_Decl) loop
2293
                  Append_To
2294
                    (Decls, Copy_Generic_Node (Formal_Decl, Empty, True));
2295
                  Next (Formal_Decl);
2296
               end loop;
2297
            end;
2298
 
2299
         --  If generic associations are present, use Analyze_Associations to
2300
         --  create the proper renaming declarations.
2301
 
2302
         else
2303
            declare
2304
               Act_Tree : constant Node_Id :=
2305
                            Copy_Generic_Node
2306
                              (Original_Node (Gen_Decl), Empty,
2307
                               Instantiating => True);
2308
 
2309
            begin
2310
               Generic_Renamings.Set_Last (0);
2311
               Generic_Renamings_HTable.Reset;
2312
               Instantiation_Node := N;
2313
 
2314
               Decls :=
2315
                 Analyze_Associations
2316
                   (I_Node  => Original_Node (N),
2317
                    Formals => Generic_Formal_Declarations (Act_Tree),
2318
                    F_Copy  => Generic_Formal_Declarations (Gen_Decl));
2319
 
2320
               Vis_Prims_List := Check_Hidden_Primitives (Decls);
2321
            end;
2322
         end if;
2323
 
2324
         Append (Renaming, To => Decls);
2325
 
2326
         --  Add generated declarations ahead of local declarations in
2327
         --  the package.
2328
 
2329
         if No (Visible_Declarations (Specification (Pack_Decl))) then
2330
            Set_Visible_Declarations (Specification (Pack_Decl), Decls);
2331
         else
2332
            Insert_List_Before
2333
              (First (Visible_Declarations (Specification (Pack_Decl))),
2334
                 Decls);
2335
         end if;
2336
 
2337
         return Pack_Decl;
2338
      end Build_Local_Package;
2339
 
2340
   --  Start of processing for Analyze_Formal_Package_Declaration
2341
 
2342
   begin
2343
      Text_IO_Kludge (Gen_Id);
2344
 
2345
      Init_Env;
2346
      Check_Generic_Child_Unit (Gen_Id, Parent_Installed);
2347
      Gen_Unit := Entity (Gen_Id);
2348
 
2349
      --  Check for a formal package that is a package renaming
2350
 
2351
      if Present (Renamed_Object (Gen_Unit)) then
2352
 
2353
         --  Indicate that unit is used, before replacing it with renamed
2354
         --  entity for use below.
2355
 
2356
         if In_Extended_Main_Source_Unit (N) then
2357
            Set_Is_Instantiated (Gen_Unit);
2358
            Generate_Reference  (Gen_Unit, N);
2359
         end if;
2360
 
2361
         Gen_Unit := Renamed_Object (Gen_Unit);
2362
      end if;
2363
 
2364
      if Ekind (Gen_Unit) /= E_Generic_Package then
2365
         Error_Msg_N ("expect generic package name", Gen_Id);
2366
         Restore_Env;
2367
         goto Leave;
2368
 
2369
      elsif  Gen_Unit = Current_Scope then
2370
         Error_Msg_N
2371
           ("generic package cannot be used as a formal package of itself",
2372
             Gen_Id);
2373
         Restore_Env;
2374
         goto Leave;
2375
 
2376
      elsif In_Open_Scopes (Gen_Unit) then
2377
         if Is_Compilation_Unit (Gen_Unit)
2378
           and then Is_Child_Unit (Current_Scope)
2379
         then
2380
            --  Special-case the error when the formal is a parent, and
2381
            --  continue analysis to minimize cascaded errors.
2382
 
2383
            Error_Msg_N
2384
              ("generic parent cannot be used as formal package "
2385
                & "of a child unit",
2386
                Gen_Id);
2387
 
2388
         else
2389
            Error_Msg_N
2390
              ("generic package cannot be used as a formal package "
2391
                & "within itself",
2392
                Gen_Id);
2393
            Restore_Env;
2394
            goto Leave;
2395
         end if;
2396
      end if;
2397
 
2398
      --  Check that name of formal package does not hide name of generic,
2399
      --  or its leading prefix. This check must be done separately because
2400
      --  the name of the generic has already been analyzed.
2401
 
2402
      declare
2403
         Gen_Name : Entity_Id;
2404
 
2405
      begin
2406
         Gen_Name := Gen_Id;
2407
         while Nkind (Gen_Name) = N_Expanded_Name loop
2408
            Gen_Name := Prefix (Gen_Name);
2409
         end loop;
2410
 
2411
         if Chars (Gen_Name) = Chars (Pack_Id) then
2412
            Error_Msg_NE
2413
             ("& is hidden within declaration of formal package",
2414
               Gen_Id, Gen_Name);
2415
         end if;
2416
      end;
2417
 
2418
      if Box_Present (N)
2419
        or else No (Generic_Associations (N))
2420
        or else Nkind (First (Generic_Associations (N))) = N_Others_Choice
2421
      then
2422
         Associations := False;
2423
      end if;
2424
 
2425
      --  If there are no generic associations, the generic parameters appear
2426
      --  as local entities and are instantiated like them. We copy the generic
2427
      --  package declaration as if it were an instantiation, and analyze it
2428
      --  like a regular package, except that we treat the formals as
2429
      --  additional visible components.
2430
 
2431
      Gen_Decl := Unit_Declaration_Node (Gen_Unit);
2432
 
2433
      if In_Extended_Main_Source_Unit (N) then
2434
         Set_Is_Instantiated (Gen_Unit);
2435
         Generate_Reference  (Gen_Unit, N);
2436
      end if;
2437
 
2438
      Formal := New_Copy (Pack_Id);
2439
      Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment);
2440
 
2441
      begin
2442
         --  Make local generic without formals. The formals will be replaced
2443
         --  with internal declarations.
2444
 
2445
         New_N := Build_Local_Package;
2446
 
2447
         --  If there are errors in the parameter list, Analyze_Associations
2448
         --  raises Instantiation_Error. Patch the declaration to prevent
2449
         --  further exception propagation.
2450
 
2451
      exception
2452
         when Instantiation_Error =>
2453
 
2454
            Enter_Name (Formal);
2455
            Set_Ekind  (Formal, E_Variable);
2456
            Set_Etype  (Formal, Any_Type);
2457
            Restore_Hidden_Primitives (Vis_Prims_List);
2458
 
2459
            if Parent_Installed then
2460
               Remove_Parent;
2461
            end if;
2462
 
2463
            goto Leave;
2464
      end;
2465
 
2466
      Rewrite (N, New_N);
2467
      Set_Defining_Unit_Name (Specification (New_N), Formal);
2468
      Set_Generic_Parent (Specification (N), Gen_Unit);
2469
      Set_Instance_Env (Gen_Unit, Formal);
2470
      Set_Is_Generic_Instance (Formal);
2471
 
2472
      Enter_Name (Formal);
2473
      Set_Ekind  (Formal, E_Package);
2474
      Set_Etype  (Formal, Standard_Void_Type);
2475
      Set_Inner_Instances (Formal, New_Elmt_List);
2476
      Push_Scope  (Formal);
2477
 
2478
      if Is_Child_Unit (Gen_Unit)
2479
        and then Parent_Installed
2480
      then
2481
         --  Similarly, we have to make the name of the formal visible in the
2482
         --  parent instance, to resolve properly fully qualified names that
2483
         --  may appear in the generic unit. The parent instance has been
2484
         --  placed on the scope stack ahead of the current scope.
2485
 
2486
         Parent_Instance := Scope_Stack.Table (Scope_Stack.Last - 1).Entity;
2487
 
2488
         Renaming_In_Par :=
2489
           Make_Defining_Identifier (Loc, Chars (Gen_Unit));
2490
         Set_Ekind (Renaming_In_Par, E_Package);
2491
         Set_Etype (Renaming_In_Par, Standard_Void_Type);
2492
         Set_Scope (Renaming_In_Par, Parent_Instance);
2493
         Set_Parent (Renaming_In_Par, Parent (Formal));
2494
         Set_Renamed_Object (Renaming_In_Par, Formal);
2495
         Append_Entity (Renaming_In_Par, Parent_Instance);
2496
      end if;
2497
 
2498
      Analyze (Specification (N));
2499
 
2500
      --  The formals for which associations are provided are not visible
2501
      --  outside of the formal package. The others are still declared by a
2502
      --  formal parameter declaration.
2503
 
2504
      --  If there are no associations, the only local entity to hide is the
2505
      --  generated package renaming itself.
2506
 
2507
      declare
2508
         E : Entity_Id;
2509
 
2510
      begin
2511
         E := First_Entity (Formal);
2512
         while Present (E) loop
2513
            if Associations
2514
              and then not Is_Generic_Formal (E)
2515
            then
2516
               Set_Is_Hidden (E);
2517
            end if;
2518
 
2519
            if Ekind (E) = E_Package
2520
              and then Renamed_Entity (E) = Formal
2521
            then
2522
               Set_Is_Hidden (E);
2523
               exit;
2524
            end if;
2525
 
2526
            Next_Entity (E);
2527
         end loop;
2528
      end;
2529
 
2530
      End_Package_Scope (Formal);
2531
      Restore_Hidden_Primitives (Vis_Prims_List);
2532
 
2533
      if Parent_Installed then
2534
         Remove_Parent;
2535
      end if;
2536
 
2537
      Restore_Env;
2538
 
2539
      --  Inside the generic unit, the formal package is a regular package, but
2540
      --  no body is needed for it. Note that after instantiation, the defining
2541
      --  unit name we need is in the new tree and not in the original (see
2542
      --  Package_Instantiation). A generic formal package is an instance, and
2543
      --  can be used as an actual for an inner instance.
2544
 
2545
      Set_Has_Completion (Formal, True);
2546
 
2547
      --  Add semantic information to the original defining identifier.
2548
      --  for ASIS use.
2549
 
2550
      Set_Ekind (Pack_Id, E_Package);
2551
      Set_Etype (Pack_Id, Standard_Void_Type);
2552
      Set_Scope (Pack_Id, Scope (Formal));
2553
      Set_Has_Completion (Pack_Id, True);
2554
 
2555
   <<Leave>>
2556
      if Has_Aspects (N) then
2557
         Analyze_Aspect_Specifications (N, Pack_Id);
2558
      end if;
2559
   end Analyze_Formal_Package_Declaration;
2560
 
2561
   ---------------------------------
2562
   -- Analyze_Formal_Private_Type --
2563
   ---------------------------------
2564
 
2565
   procedure Analyze_Formal_Private_Type
2566
     (N   : Node_Id;
2567
      T   : Entity_Id;
2568
      Def : Node_Id)
2569
   is
2570
   begin
2571
      New_Private_Type (N, T, Def);
2572
 
2573
      --  Set the size to an arbitrary but legal value
2574
 
2575
      Set_Size_Info (T, Standard_Integer);
2576
      Set_RM_Size   (T, RM_Size (Standard_Integer));
2577
   end Analyze_Formal_Private_Type;
2578
 
2579
   ------------------------------------
2580
   -- Analyze_Formal_Incomplete_Type --
2581
   ------------------------------------
2582
 
2583
   procedure Analyze_Formal_Incomplete_Type
2584
     (T   : Entity_Id;
2585
      Def : Node_Id)
2586
   is
2587
   begin
2588
      Enter_Name (T);
2589
      Set_Ekind (T, E_Incomplete_Type);
2590
      Set_Etype (T, T);
2591
      Set_Private_Dependents (T, New_Elmt_List);
2592
 
2593
      if Tagged_Present (Def) then
2594
         Set_Is_Tagged_Type (T);
2595
         Make_Class_Wide_Type (T);
2596
         Set_Direct_Primitive_Operations (T, New_Elmt_List);
2597
      end if;
2598
   end Analyze_Formal_Incomplete_Type;
2599
 
2600
   ----------------------------------------
2601
   -- Analyze_Formal_Signed_Integer_Type --
2602
   ----------------------------------------
2603
 
2604
   procedure Analyze_Formal_Signed_Integer_Type
2605
     (T   : Entity_Id;
2606
      Def : Node_Id)
2607
   is
2608
      Base : constant Entity_Id :=
2609
               New_Internal_Entity
2610
                 (E_Signed_Integer_Type,
2611
                  Current_Scope,
2612
                  Sloc (Defining_Identifier (Parent (Def))), 'G');
2613
 
2614
   begin
2615
      Enter_Name (T);
2616
 
2617
      Set_Ekind          (T, E_Signed_Integer_Subtype);
2618
      Set_Etype          (T, Base);
2619
      Set_Size_Info      (T, Standard_Integer);
2620
      Set_RM_Size        (T, RM_Size (Standard_Integer));
2621
      Set_Scalar_Range   (T, Scalar_Range (Standard_Integer));
2622
      Set_Is_Constrained (T);
2623
 
2624
      Set_Is_Generic_Type (Base);
2625
      Set_Size_Info       (Base, Standard_Integer);
2626
      Set_RM_Size         (Base, RM_Size (Standard_Integer));
2627
      Set_Etype           (Base, Base);
2628
      Set_Scalar_Range    (Base, Scalar_Range (Standard_Integer));
2629
      Set_Parent          (Base, Parent (Def));
2630
   end Analyze_Formal_Signed_Integer_Type;
2631
 
2632
   -------------------------------------------
2633
   -- Analyze_Formal_Subprogram_Declaration --
2634
   -------------------------------------------
2635
 
2636
   procedure Analyze_Formal_Subprogram_Declaration (N : Node_Id) is
2637
      Spec : constant Node_Id   := Specification (N);
2638
      Def  : constant Node_Id   := Default_Name (N);
2639
      Nam  : constant Entity_Id := Defining_Unit_Name (Spec);
2640
      Subp : Entity_Id;
2641
 
2642
   begin
2643
      if Nam = Error then
2644
         return;
2645
      end if;
2646
 
2647
      if Nkind (Nam) = N_Defining_Program_Unit_Name then
2648
         Error_Msg_N ("name of formal subprogram must be a direct name", Nam);
2649
         goto Leave;
2650
      end if;
2651
 
2652
      Analyze_Subprogram_Declaration (N);
2653
      Set_Is_Formal_Subprogram (Nam);
2654
      Set_Has_Completion (Nam);
2655
 
2656
      if Nkind (N) = N_Formal_Abstract_Subprogram_Declaration then
2657
         Set_Is_Abstract_Subprogram (Nam);
2658
         Set_Is_Dispatching_Operation (Nam);
2659
 
2660
         declare
2661
            Ctrl_Type : constant Entity_Id := Find_Dispatching_Type (Nam);
2662
         begin
2663
            if No (Ctrl_Type) then
2664
               Error_Msg_N
2665
                 ("abstract formal subprogram must have a controlling type",
2666
                  N);
2667
            else
2668
               Check_Controlling_Formals (Ctrl_Type, Nam);
2669
            end if;
2670
         end;
2671
      end if;
2672
 
2673
      --  Default name is resolved at the point of instantiation
2674
 
2675
      if Box_Present (N) then
2676
         null;
2677
 
2678
      --  Else default is bound at the point of generic declaration
2679
 
2680
      elsif Present (Def) then
2681
         if Nkind (Def) = N_Operator_Symbol then
2682
            Find_Direct_Name (Def);
2683
 
2684
         elsif Nkind (Def) /= N_Attribute_Reference then
2685
            Analyze (Def);
2686
 
2687
         else
2688
            --  For an attribute reference, analyze the prefix and verify
2689
            --  that it has the proper profile for the subprogram.
2690
 
2691
            Analyze (Prefix (Def));
2692
            Valid_Default_Attribute (Nam, Def);
2693
            goto Leave;
2694
         end if;
2695
 
2696
         --  Default name may be overloaded, in which case the interpretation
2697
         --  with the correct profile must be  selected, as for a renaming.
2698
         --  If the definition is an indexed component, it must denote a
2699
         --  member of an entry family. If it is a selected component, it
2700
         --  can be a protected operation.
2701
 
2702
         if Etype (Def) = Any_Type then
2703
            goto Leave;
2704
 
2705
         elsif Nkind (Def) = N_Selected_Component then
2706
            if not Is_Overloadable (Entity (Selector_Name (Def))) then
2707
               Error_Msg_N ("expect valid subprogram name as default", Def);
2708
            end if;
2709
 
2710
         elsif Nkind (Def) = N_Indexed_Component then
2711
            if Is_Entity_Name (Prefix (Def)) then
2712
               if Ekind (Entity (Prefix (Def))) /= E_Entry_Family then
2713
                  Error_Msg_N ("expect valid subprogram name as default", Def);
2714
               end if;
2715
 
2716
            elsif Nkind (Prefix (Def)) = N_Selected_Component then
2717
               if Ekind (Entity (Selector_Name (Prefix (Def)))) /=
2718
                                                          E_Entry_Family
2719
               then
2720
                  Error_Msg_N ("expect valid subprogram name as default", Def);
2721
               end if;
2722
 
2723
            else
2724
               Error_Msg_N ("expect valid subprogram name as default", Def);
2725
               goto Leave;
2726
            end if;
2727
 
2728
         elsif Nkind (Def) = N_Character_Literal then
2729
 
2730
            --  Needs some type checks: subprogram should be parameterless???
2731
 
2732
            Resolve (Def, (Etype (Nam)));
2733
 
2734
         elsif not Is_Entity_Name (Def)
2735
           or else not Is_Overloadable (Entity (Def))
2736
         then
2737
            Error_Msg_N ("expect valid subprogram name as default", Def);
2738
            goto Leave;
2739
 
2740
         elsif not Is_Overloaded (Def) then
2741
            Subp := Entity (Def);
2742
 
2743
            if Subp = Nam then
2744
               Error_Msg_N ("premature usage of formal subprogram", Def);
2745
 
2746
            elsif not Entity_Matches_Spec (Subp, Nam) then
2747
               Error_Msg_N ("no visible entity matches specification", Def);
2748
            end if;
2749
 
2750
         --  More than one interpretation, so disambiguate as for a renaming
2751
 
2752
         else
2753
            declare
2754
               I   : Interp_Index;
2755
               I1  : Interp_Index := 0;
2756
               It  : Interp;
2757
               It1 : Interp;
2758
 
2759
            begin
2760
               Subp := Any_Id;
2761
               Get_First_Interp (Def, I, It);
2762
               while Present (It.Nam) loop
2763
                  if Entity_Matches_Spec (It.Nam, Nam) then
2764
                     if Subp /= Any_Id then
2765
                        It1 := Disambiguate (Def, I1, I, Etype (Subp));
2766
 
2767
                        if It1 = No_Interp then
2768
                           Error_Msg_N ("ambiguous default subprogram", Def);
2769
                        else
2770
                           Subp := It1.Nam;
2771
                        end if;
2772
 
2773
                        exit;
2774
 
2775
                     else
2776
                        I1  := I;
2777
                        Subp := It.Nam;
2778
                     end if;
2779
                  end if;
2780
 
2781
                  Get_Next_Interp (I, It);
2782
               end loop;
2783
            end;
2784
 
2785
            if Subp /= Any_Id then
2786
 
2787
               --  Subprogram found, generate reference to it
2788
 
2789
               Set_Entity (Def, Subp);
2790
               Generate_Reference (Subp, Def);
2791
 
2792
               if Subp = Nam then
2793
                  Error_Msg_N ("premature usage of formal subprogram", Def);
2794
 
2795
               elsif Ekind (Subp) /= E_Operator then
2796
                  Check_Mode_Conformant (Subp, Nam);
2797
               end if;
2798
 
2799
            else
2800
               Error_Msg_N ("no visible subprogram matches specification", N);
2801
            end if;
2802
         end if;
2803
      end if;
2804
 
2805
   <<Leave>>
2806
      if Has_Aspects (N) then
2807
         Analyze_Aspect_Specifications (N, Nam);
2808
      end if;
2809
 
2810
   end Analyze_Formal_Subprogram_Declaration;
2811
 
2812
   -------------------------------------
2813
   -- Analyze_Formal_Type_Declaration --
2814
   -------------------------------------
2815
 
2816
   procedure Analyze_Formal_Type_Declaration (N : Node_Id) is
2817
      Def : constant Node_Id := Formal_Type_Definition (N);
2818
      T   : Entity_Id;
2819
 
2820
   begin
2821
      T := Defining_Identifier (N);
2822
 
2823
      if Present (Discriminant_Specifications (N))
2824
        and then Nkind (Def) /= N_Formal_Private_Type_Definition
2825
      then
2826
         Error_Msg_N
2827
           ("discriminants not allowed for this formal type", T);
2828
      end if;
2829
 
2830
      --  Enter the new name, and branch to specific routine
2831
 
2832
      case Nkind (Def) is
2833
         when N_Formal_Private_Type_Definition         =>
2834
            Analyze_Formal_Private_Type (N, T, Def);
2835
 
2836
         when N_Formal_Derived_Type_Definition         =>
2837
            Analyze_Formal_Derived_Type (N, T, Def);
2838
 
2839
         when N_Formal_Incomplete_Type_Definition         =>
2840
            Analyze_Formal_Incomplete_Type (T, Def);
2841
 
2842
         when N_Formal_Discrete_Type_Definition        =>
2843
            Analyze_Formal_Discrete_Type (T, Def);
2844
 
2845
         when N_Formal_Signed_Integer_Type_Definition  =>
2846
            Analyze_Formal_Signed_Integer_Type (T, Def);
2847
 
2848
         when N_Formal_Modular_Type_Definition         =>
2849
            Analyze_Formal_Modular_Type (T, Def);
2850
 
2851
         when N_Formal_Floating_Point_Definition       =>
2852
            Analyze_Formal_Floating_Type (T, Def);
2853
 
2854
         when N_Formal_Ordinary_Fixed_Point_Definition =>
2855
            Analyze_Formal_Ordinary_Fixed_Point_Type (T, Def);
2856
 
2857
         when N_Formal_Decimal_Fixed_Point_Definition  =>
2858
            Analyze_Formal_Decimal_Fixed_Point_Type (T, Def);
2859
 
2860
         when N_Array_Type_Definition =>
2861
            Analyze_Formal_Array_Type (T, Def);
2862
 
2863
         when N_Access_To_Object_Definition            |
2864
              N_Access_Function_Definition             |
2865
              N_Access_Procedure_Definition            =>
2866
            Analyze_Generic_Access_Type (T, Def);
2867
 
2868
         --  Ada 2005: a interface declaration is encoded as an abstract
2869
         --  record declaration or a abstract type derivation.
2870
 
2871
         when N_Record_Definition                      =>
2872
            Analyze_Formal_Interface_Type (N, T, Def);
2873
 
2874
         when N_Derived_Type_Definition                =>
2875
            Analyze_Formal_Derived_Interface_Type (N, T, Def);
2876
 
2877
         when N_Error                                  =>
2878
            null;
2879
 
2880
         when others                                   =>
2881
            raise Program_Error;
2882
 
2883
      end case;
2884
 
2885
      Set_Is_Generic_Type (T);
2886
 
2887
      if Has_Aspects (N) then
2888
         Analyze_Aspect_Specifications (N, T);
2889
      end if;
2890
   end Analyze_Formal_Type_Declaration;
2891
 
2892
   ------------------------------------
2893
   -- Analyze_Function_Instantiation --
2894
   ------------------------------------
2895
 
2896
   procedure Analyze_Function_Instantiation (N : Node_Id) is
2897
   begin
2898
      Analyze_Subprogram_Instantiation (N, E_Function);
2899
   end Analyze_Function_Instantiation;
2900
 
2901
   ---------------------------------
2902
   -- Analyze_Generic_Access_Type --
2903
   ---------------------------------
2904
 
2905
   procedure Analyze_Generic_Access_Type (T : Entity_Id; Def : Node_Id) is
2906
   begin
2907
      Enter_Name (T);
2908
 
2909
      if Nkind (Def) = N_Access_To_Object_Definition then
2910
         Access_Type_Declaration (T, Def);
2911
 
2912
         if Is_Incomplete_Or_Private_Type (Designated_Type (T))
2913
           and then No (Full_View (Designated_Type (T)))
2914
           and then not Is_Generic_Type (Designated_Type (T))
2915
         then
2916
            Error_Msg_N ("premature usage of incomplete type", Def);
2917
 
2918
         elsif not Is_Entity_Name (Subtype_Indication (Def)) then
2919
            Error_Msg_N
2920
              ("only a subtype mark is allowed in a formal", Def);
2921
         end if;
2922
 
2923
      else
2924
         Access_Subprogram_Declaration (T, Def);
2925
      end if;
2926
   end Analyze_Generic_Access_Type;
2927
 
2928
   ---------------------------------
2929
   -- Analyze_Generic_Formal_Part --
2930
   ---------------------------------
2931
 
2932
   procedure Analyze_Generic_Formal_Part (N : Node_Id) is
2933
      Gen_Parm_Decl : Node_Id;
2934
 
2935
   begin
2936
      --  The generic formals are processed in the scope of the generic unit,
2937
      --  where they are immediately visible. The scope is installed by the
2938
      --  caller.
2939
 
2940
      Gen_Parm_Decl := First (Generic_Formal_Declarations (N));
2941
 
2942
      while Present (Gen_Parm_Decl) loop
2943
         Analyze (Gen_Parm_Decl);
2944
         Next (Gen_Parm_Decl);
2945
      end loop;
2946
 
2947
      Generate_Reference_To_Generic_Formals (Current_Scope);
2948
   end Analyze_Generic_Formal_Part;
2949
 
2950
   ------------------------------------------
2951
   -- Analyze_Generic_Package_Declaration  --
2952
   ------------------------------------------
2953
 
2954
   procedure Analyze_Generic_Package_Declaration (N : Node_Id) is
2955
      Loc         : constant Source_Ptr := Sloc (N);
2956
      Id          : Entity_Id;
2957
      New_N       : Node_Id;
2958
      Save_Parent : Node_Id;
2959
      Renaming    : Node_Id;
2960
      Decls       : constant List_Id :=
2961
                      Visible_Declarations (Specification (N));
2962
      Decl        : Node_Id;
2963
 
2964
   begin
2965
      Check_SPARK_Restriction ("generic is not allowed", N);
2966
 
2967
      --  We introduce a renaming of the enclosing package, to have a usable
2968
      --  entity as the prefix of an expanded name for a local entity of the
2969
      --  form Par.P.Q, where P is the generic package. This is because a local
2970
      --  entity named P may hide it, so that the usual visibility rules in
2971
      --  the instance will not resolve properly.
2972
 
2973
      Renaming :=
2974
        Make_Package_Renaming_Declaration (Loc,
2975
          Defining_Unit_Name =>
2976
            Make_Defining_Identifier (Loc,
2977
             Chars => New_External_Name (Chars (Defining_Entity (N)), "GH")),
2978
          Name => Make_Identifier (Loc, Chars (Defining_Entity (N))));
2979
 
2980
      if Present (Decls) then
2981
         Decl := First (Decls);
2982
         while Present (Decl)
2983
           and then Nkind (Decl) = N_Pragma
2984
         loop
2985
            Next (Decl);
2986
         end loop;
2987
 
2988
         if Present (Decl) then
2989
            Insert_Before (Decl, Renaming);
2990
         else
2991
            Append (Renaming, Visible_Declarations (Specification (N)));
2992
         end if;
2993
 
2994
      else
2995
         Set_Visible_Declarations (Specification (N), New_List (Renaming));
2996
      end if;
2997
 
2998
      --  Create copy of generic unit, and save for instantiation. If the unit
2999
      --  is a child unit, do not copy the specifications for the parent, which
3000
      --  are not part of the generic tree.
3001
 
3002
      Save_Parent := Parent_Spec (N);
3003
      Set_Parent_Spec (N, Empty);
3004
 
3005
      New_N := Copy_Generic_Node (N, Empty, Instantiating => False);
3006
      Set_Parent_Spec (New_N, Save_Parent);
3007
      Rewrite (N, New_N);
3008
      Id := Defining_Entity (N);
3009
      Generate_Definition (Id);
3010
 
3011
      --  Expansion is not applied to generic units
3012
 
3013
      Start_Generic;
3014
 
3015
      Enter_Name (Id);
3016
      Set_Ekind (Id, E_Generic_Package);
3017
      Set_Etype (Id, Standard_Void_Type);
3018
      Push_Scope (Id);
3019
      Enter_Generic_Scope (Id);
3020
      Set_Inner_Instances (Id, New_Elmt_List);
3021
 
3022
      Set_Categorization_From_Pragmas (N);
3023
      Set_Is_Pure (Id, Is_Pure (Current_Scope));
3024
 
3025
      --  Link the declaration of the generic homonym in the generic copy to
3026
      --  the package it renames, so that it is always resolved properly.
3027
 
3028
      Set_Generic_Homonym (Id, Defining_Unit_Name (Renaming));
3029
      Set_Entity (Associated_Node (Name (Renaming)), Id);
3030
 
3031
      --  For a library unit, we have reconstructed the entity for the unit,
3032
      --  and must reset it in the library tables.
3033
 
3034
      if Nkind (Parent (N)) = N_Compilation_Unit then
3035
         Set_Cunit_Entity (Current_Sem_Unit, Id);
3036
      end if;
3037
 
3038
      Analyze_Generic_Formal_Part (N);
3039
 
3040
      --  After processing the generic formals, analysis proceeds as for a
3041
      --  non-generic package.
3042
 
3043
      Analyze (Specification (N));
3044
 
3045
      Validate_Categorization_Dependency (N, Id);
3046
 
3047
      End_Generic;
3048
 
3049
      End_Package_Scope (Id);
3050
      Exit_Generic_Scope (Id);
3051
 
3052
      if Nkind (Parent (N)) /= N_Compilation_Unit then
3053
         Move_Freeze_Nodes (Id, N, Visible_Declarations (Specification (N)));
3054
         Move_Freeze_Nodes (Id, N, Private_Declarations (Specification (N)));
3055
         Move_Freeze_Nodes (Id, N, Generic_Formal_Declarations (N));
3056
 
3057
      else
3058
         Set_Body_Required (Parent (N), Unit_Requires_Body (Id));
3059
         Validate_RT_RAT_Component (N);
3060
 
3061
         --  If this is a spec without a body, check that generic parameters
3062
         --  are referenced.
3063
 
3064
         if not Body_Required (Parent (N)) then
3065
            Check_References (Id);
3066
         end if;
3067
      end if;
3068
 
3069
      if Has_Aspects (N) then
3070
         Analyze_Aspect_Specifications (N, Id);
3071
      end if;
3072
   end Analyze_Generic_Package_Declaration;
3073
 
3074
   --------------------------------------------
3075
   -- Analyze_Generic_Subprogram_Declaration --
3076
   --------------------------------------------
3077
 
3078
   procedure Analyze_Generic_Subprogram_Declaration (N : Node_Id) is
3079
      Spec        : Node_Id;
3080
      Id          : Entity_Id;
3081
      Formals     : List_Id;
3082
      New_N       : Node_Id;
3083
      Result_Type : Entity_Id;
3084
      Save_Parent : Node_Id;
3085
      Typ         : Entity_Id;
3086
 
3087
   begin
3088
      Check_SPARK_Restriction ("generic is not allowed", N);
3089
 
3090
      --  Create copy of generic unit, and save for instantiation. If the unit
3091
      --  is a child unit, do not copy the specifications for the parent, which
3092
      --  are not part of the generic tree.
3093
 
3094
      Save_Parent := Parent_Spec (N);
3095
      Set_Parent_Spec (N, Empty);
3096
 
3097
      New_N := Copy_Generic_Node (N, Empty, Instantiating => False);
3098
      Set_Parent_Spec (New_N, Save_Parent);
3099
      Rewrite (N, New_N);
3100
 
3101
      --  The aspect specifications are not attached to the tree, and must
3102
      --  be copied and attached to the generic copy explicitly.
3103
 
3104
      if Present (Aspect_Specifications (New_N)) then
3105
         declare
3106
            Aspects : constant List_Id := Aspect_Specifications (N);
3107
         begin
3108
            Set_Has_Aspects (N, False);
3109
            Move_Aspects (New_N, N);
3110
            Set_Has_Aspects (Original_Node (N), False);
3111
            Set_Aspect_Specifications (Original_Node (N), Aspects);
3112
         end;
3113
      end if;
3114
 
3115
      Spec := Specification (N);
3116
      Id := Defining_Entity (Spec);
3117
      Generate_Definition (Id);
3118
      Set_Contract (Id, Make_Contract (Sloc (Id)));
3119
 
3120
      if Nkind (Id) = N_Defining_Operator_Symbol then
3121
         Error_Msg_N
3122
           ("operator symbol not allowed for generic subprogram", Id);
3123
      end if;
3124
 
3125
      Start_Generic;
3126
 
3127
      Enter_Name (Id);
3128
 
3129
      Set_Scope_Depth_Value (Id, Scope_Depth (Current_Scope) + 1);
3130
      Push_Scope (Id);
3131
      Enter_Generic_Scope (Id);
3132
      Set_Inner_Instances (Id, New_Elmt_List);
3133
      Set_Is_Pure (Id, Is_Pure (Current_Scope));
3134
 
3135
      Analyze_Generic_Formal_Part (N);
3136
 
3137
      Formals := Parameter_Specifications (Spec);
3138
 
3139
      if Present (Formals) then
3140
         Process_Formals (Formals, Spec);
3141
      end if;
3142
 
3143
      if Nkind (Spec) = N_Function_Specification then
3144
         Set_Ekind (Id, E_Generic_Function);
3145
 
3146
         if Nkind (Result_Definition (Spec)) = N_Access_Definition then
3147
            Result_Type := Access_Definition (Spec, Result_Definition (Spec));
3148
            Set_Etype (Id, Result_Type);
3149
 
3150
            --  Check restriction imposed by AI05-073: a generic function
3151
            --  cannot return an abstract type or an access to such.
3152
 
3153
            --  This is a binding interpretation should it apply to earlier
3154
            --  versions of Ada as well as Ada 2012???
3155
 
3156
            if Is_Abstract_Type (Designated_Type (Result_Type))
3157
              and then Ada_Version >= Ada_2012
3158
            then
3159
               Error_Msg_N ("generic function cannot have an access result"
3160
                 & " that designates an abstract type", Spec);
3161
            end if;
3162
 
3163
         else
3164
            Find_Type (Result_Definition (Spec));
3165
            Typ := Entity (Result_Definition (Spec));
3166
 
3167
            if Is_Abstract_Type (Typ)
3168
              and then Ada_Version >= Ada_2012
3169
            then
3170
               Error_Msg_N
3171
                 ("generic function cannot have abstract result type", Spec);
3172
            end if;
3173
 
3174
            --  If a null exclusion is imposed on the result type, then create
3175
            --  a null-excluding itype (an access subtype) and use it as the
3176
            --  function's Etype.
3177
 
3178
            if Is_Access_Type (Typ)
3179
              and then Null_Exclusion_Present (Spec)
3180
            then
3181
               Set_Etype  (Id,
3182
                 Create_Null_Excluding_Itype
3183
                   (T           => Typ,
3184
                    Related_Nod => Spec,
3185
                    Scope_Id    => Defining_Unit_Name (Spec)));
3186
            else
3187
               Set_Etype (Id, Typ);
3188
            end if;
3189
         end if;
3190
 
3191
      else
3192
         Set_Ekind (Id, E_Generic_Procedure);
3193
         Set_Etype (Id, Standard_Void_Type);
3194
      end if;
3195
 
3196
      --  For a library unit, we have reconstructed the entity for the unit,
3197
      --  and must reset it in the library tables. We also make sure that
3198
      --  Body_Required is set properly in the original compilation unit node.
3199
 
3200
      if Nkind (Parent (N)) = N_Compilation_Unit then
3201
         Set_Cunit_Entity (Current_Sem_Unit, Id);
3202
         Set_Body_Required (Parent (N), Unit_Requires_Body (Id));
3203
      end if;
3204
 
3205
      Set_Categorization_From_Pragmas (N);
3206
      Validate_Categorization_Dependency (N, Id);
3207
 
3208
      Save_Global_References (Original_Node (N));
3209
 
3210
      --  For ASIS purposes, convert any postcondition, precondition pragmas
3211
      --  into aspects, if N is not a compilation unit by itself, in order to
3212
      --  enable the analysis of expressions inside the corresponding PPC
3213
      --  pragmas.
3214
 
3215
      if ASIS_Mode and then Is_List_Member (N) then
3216
         Make_Aspect_For_PPC_In_Gen_Sub_Decl (N);
3217
      end if;
3218
 
3219
      --  To capture global references, analyze the expressions of aspects,
3220
      --  and propagate information to original tree. Note that in this case
3221
      --  analysis of attributes is not delayed until the freeze point.
3222
 
3223
      --  It seems very hard to recreate the proper visibility of the generic
3224
      --  subprogram at a later point because the analysis of an aspect may
3225
      --  create pragmas after the generic copies have been made ???
3226
 
3227
      if Has_Aspects (N) then
3228
         declare
3229
            Aspect : Node_Id;
3230
 
3231
         begin
3232
            Aspect := First (Aspect_Specifications (N));
3233
            while Present (Aspect) loop
3234
               if Get_Aspect_Id (Chars (Identifier (Aspect)))
3235
                  /= Aspect_Warnings
3236
               then
3237
                  Analyze (Expression (Aspect));
3238
               end if;
3239
               Next (Aspect);
3240
            end loop;
3241
 
3242
            Aspect := First (Aspect_Specifications (Original_Node (N)));
3243
            while Present (Aspect) loop
3244
               Save_Global_References (Expression (Aspect));
3245
               Next (Aspect);
3246
            end loop;
3247
         end;
3248
      end if;
3249
 
3250
      End_Generic;
3251
      End_Scope;
3252
      Exit_Generic_Scope (Id);
3253
      Generate_Reference_To_Formals (Id);
3254
 
3255
      List_Inherited_Pre_Post_Aspects (Id);
3256
   end Analyze_Generic_Subprogram_Declaration;
3257
 
3258
   -----------------------------------
3259
   -- Analyze_Package_Instantiation --
3260
   -----------------------------------
3261
 
3262
   procedure Analyze_Package_Instantiation (N : Node_Id) is
3263
      Loc    : constant Source_Ptr := Sloc (N);
3264
      Gen_Id : constant Node_Id    := Name (N);
3265
 
3266
      Act_Decl      : Node_Id;
3267
      Act_Decl_Name : Node_Id;
3268
      Act_Decl_Id   : Entity_Id;
3269
      Act_Spec      : Node_Id;
3270
      Act_Tree      : Node_Id;
3271
 
3272
      Gen_Decl : Node_Id;
3273
      Gen_Unit : Entity_Id;
3274
 
3275
      Is_Actual_Pack : constant Boolean :=
3276
                         Is_Internal (Defining_Entity (N));
3277
 
3278
      Env_Installed    : Boolean := False;
3279
      Parent_Installed : Boolean := False;
3280
      Renaming_List    : List_Id;
3281
      Unit_Renaming    : Node_Id;
3282
      Needs_Body       : Boolean;
3283
      Inline_Now       : Boolean := False;
3284
 
3285
      Save_Style_Check : constant Boolean := Style_Check;
3286
      --  Save style check mode for restore on exit
3287
 
3288
      procedure Delay_Descriptors (E : Entity_Id);
3289
      --  Delay generation of subprogram descriptors for given entity
3290
 
3291
      function Might_Inline_Subp return Boolean;
3292
      --  If inlining is active and the generic contains inlined subprograms,
3293
      --  we instantiate the body. This may cause superfluous instantiations,
3294
      --  but it is simpler than detecting the need for the body at the point
3295
      --  of inlining, when the context of the instance is not available.
3296
 
3297
      -----------------------
3298
      -- Delay_Descriptors --
3299
      -----------------------
3300
 
3301
      procedure Delay_Descriptors (E : Entity_Id) is
3302
      begin
3303
         if not Delay_Subprogram_Descriptors (E) then
3304
            Set_Delay_Subprogram_Descriptors (E);
3305
            Pending_Descriptor.Append (E);
3306
         end if;
3307
      end Delay_Descriptors;
3308
 
3309
      -----------------------
3310
      -- Might_Inline_Subp --
3311
      -----------------------
3312
 
3313
      function Might_Inline_Subp return Boolean is
3314
         E : Entity_Id;
3315
 
3316
      begin
3317
         if not Inline_Processing_Required then
3318
            return False;
3319
 
3320
         else
3321
            E := First_Entity (Gen_Unit);
3322
            while Present (E) loop
3323
               if Is_Subprogram (E)
3324
                 and then Is_Inlined (E)
3325
               then
3326
                  return True;
3327
               end if;
3328
 
3329
               Next_Entity (E);
3330
            end loop;
3331
         end if;
3332
 
3333
         return False;
3334
      end Might_Inline_Subp;
3335
 
3336
      --  Local declarations
3337
 
3338
      Vis_Prims_List : Elist_Id := No_Elist;
3339
      --  List of primitives made temporarily visible in the instantiation
3340
      --  to match the visibility of the formal type
3341
 
3342
   --  Start of processing for Analyze_Package_Instantiation
3343
 
3344
   begin
3345
      Check_SPARK_Restriction ("generic is not allowed", N);
3346
 
3347
      --  Very first thing: apply the special kludge for Text_IO processing
3348
      --  in case we are instantiating one of the children of [Wide_]Text_IO.
3349
 
3350
      Text_IO_Kludge (Name (N));
3351
 
3352
      --  Make node global for error reporting
3353
 
3354
      Instantiation_Node := N;
3355
 
3356
      --  Turn off style checking in instances. If the check is enabled on the
3357
      --  generic unit, a warning in an instance would just be noise. If not
3358
      --  enabled on the generic, then a warning in an instance is just wrong.
3359
 
3360
      Style_Check := False;
3361
 
3362
      --  Case of instantiation of a generic package
3363
 
3364
      if Nkind (N) = N_Package_Instantiation then
3365
         Act_Decl_Id := New_Copy (Defining_Entity (N));
3366
         Set_Comes_From_Source (Act_Decl_Id, True);
3367
 
3368
         if Nkind (Defining_Unit_Name (N)) = N_Defining_Program_Unit_Name then
3369
            Act_Decl_Name :=
3370
              Make_Defining_Program_Unit_Name (Loc,
3371
                Name => New_Copy_Tree (Name (Defining_Unit_Name (N))),
3372
                Defining_Identifier => Act_Decl_Id);
3373
         else
3374
            Act_Decl_Name :=  Act_Decl_Id;
3375
         end if;
3376
 
3377
      --  Case of instantiation of a formal package
3378
 
3379
      else
3380
         Act_Decl_Id   := Defining_Identifier (N);
3381
         Act_Decl_Name := Act_Decl_Id;
3382
      end if;
3383
 
3384
      Generate_Definition (Act_Decl_Id);
3385
      Preanalyze_Actuals (N);
3386
 
3387
      Init_Env;
3388
      Env_Installed := True;
3389
 
3390
      --  Reset renaming map for formal types. The mapping is established
3391
      --  when analyzing the generic associations, but some mappings are
3392
      --  inherited from formal packages of parent units, and these are
3393
      --  constructed when the parents are installed.
3394
 
3395
      Generic_Renamings.Set_Last (0);
3396
      Generic_Renamings_HTable.Reset;
3397
 
3398
      Check_Generic_Child_Unit (Gen_Id, Parent_Installed);
3399
      Gen_Unit := Entity (Gen_Id);
3400
 
3401
      --  Verify that it is the name of a generic package
3402
 
3403
      --  A visibility glitch: if the instance is a child unit and the generic
3404
      --  is the generic unit of a parent instance (i.e. both the parent and
3405
      --  the child units are instances of the same package) the name now
3406
      --  denotes the renaming within the parent, not the intended generic
3407
      --  unit. See if there is a homonym that is the desired generic. The
3408
      --  renaming declaration must be visible inside the instance of the
3409
      --  child, but not when analyzing the name in the instantiation itself.
3410
 
3411
      if Ekind (Gen_Unit) = E_Package
3412
        and then Present (Renamed_Entity (Gen_Unit))
3413
        and then In_Open_Scopes (Renamed_Entity (Gen_Unit))
3414
        and then Is_Generic_Instance (Renamed_Entity (Gen_Unit))
3415
        and then Present (Homonym (Gen_Unit))
3416
      then
3417
         Gen_Unit := Homonym (Gen_Unit);
3418
      end if;
3419
 
3420
      if Etype (Gen_Unit) = Any_Type then
3421
         Restore_Env;
3422
         goto Leave;
3423
 
3424
      elsif Ekind (Gen_Unit) /= E_Generic_Package then
3425
 
3426
         --  Ada 2005 (AI-50217): Cannot use instance in limited with_clause
3427
 
3428
         if From_With_Type (Gen_Unit) then
3429
            Error_Msg_N
3430
              ("cannot instantiate a limited withed package", Gen_Id);
3431
         else
3432
            Error_Msg_N
3433
              ("expect name of generic package in instantiation", Gen_Id);
3434
         end if;
3435
 
3436
         Restore_Env;
3437
         goto Leave;
3438
      end if;
3439
 
3440
      if In_Extended_Main_Source_Unit (N) then
3441
         Set_Is_Instantiated (Gen_Unit);
3442
         Generate_Reference  (Gen_Unit, N);
3443
 
3444
         if Present (Renamed_Object (Gen_Unit)) then
3445
            Set_Is_Instantiated (Renamed_Object (Gen_Unit));
3446
            Generate_Reference  (Renamed_Object (Gen_Unit), N);
3447
         end if;
3448
      end if;
3449
 
3450
      if Nkind (Gen_Id) = N_Identifier
3451
        and then Chars (Gen_Unit) = Chars (Defining_Entity (N))
3452
      then
3453
         Error_Msg_NE
3454
           ("& is hidden within declaration of instance", Gen_Id, Gen_Unit);
3455
 
3456
      elsif Nkind (Gen_Id) = N_Expanded_Name
3457
        and then Is_Child_Unit (Gen_Unit)
3458
        and then Nkind (Prefix (Gen_Id)) = N_Identifier
3459
        and then Chars (Act_Decl_Id) = Chars (Prefix (Gen_Id))
3460
      then
3461
         Error_Msg_N
3462
           ("& is hidden within declaration of instance ", Prefix (Gen_Id));
3463
      end if;
3464
 
3465
      Set_Entity (Gen_Id, Gen_Unit);
3466
 
3467
      --  If generic is a renaming, get original generic unit
3468
 
3469
      if Present (Renamed_Object (Gen_Unit))
3470
        and then Ekind (Renamed_Object (Gen_Unit)) = E_Generic_Package
3471
      then
3472
         Gen_Unit := Renamed_Object (Gen_Unit);
3473
      end if;
3474
 
3475
      --  Verify that there are no circular instantiations
3476
 
3477
      if In_Open_Scopes (Gen_Unit) then
3478
         Error_Msg_NE ("instantiation of & within itself", N, Gen_Unit);
3479
         Restore_Env;
3480
         goto Leave;
3481
 
3482
      elsif Contains_Instance_Of (Gen_Unit, Current_Scope, Gen_Id) then
3483
         Error_Msg_Node_2 := Current_Scope;
3484
         Error_Msg_NE
3485
           ("circular Instantiation: & instantiated in &!", N, Gen_Unit);
3486
         Circularity_Detected := True;
3487
         Restore_Env;
3488
         goto Leave;
3489
 
3490
      else
3491
         Gen_Decl := Unit_Declaration_Node (Gen_Unit);
3492
 
3493
         --  Initialize renamings map, for error checking, and the list that
3494
         --  holds private entities whose views have changed between generic
3495
         --  definition and instantiation. If this is the instance created to
3496
         --  validate an actual package, the instantiation environment is that
3497
         --  of the enclosing instance.
3498
 
3499
         Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment);
3500
 
3501
         --  Copy original generic tree, to produce text for instantiation
3502
 
3503
         Act_Tree :=
3504
           Copy_Generic_Node
3505
             (Original_Node (Gen_Decl), Empty, Instantiating => True);
3506
 
3507
         Act_Spec := Specification (Act_Tree);
3508
 
3509
         --  If this is the instance created to validate an actual package,
3510
         --  only the formals matter, do not examine the package spec itself.
3511
 
3512
         if Is_Actual_Pack then
3513
            Set_Visible_Declarations (Act_Spec, New_List);
3514
            Set_Private_Declarations (Act_Spec, New_List);
3515
         end if;
3516
 
3517
         Renaming_List :=
3518
           Analyze_Associations
3519
             (I_Node  => N,
3520
              Formals => Generic_Formal_Declarations (Act_Tree),
3521
              F_Copy  => Generic_Formal_Declarations (Gen_Decl));
3522
 
3523
         Vis_Prims_List := Check_Hidden_Primitives (Renaming_List);
3524
 
3525
         Set_Instance_Env (Gen_Unit, Act_Decl_Id);
3526
         Set_Defining_Unit_Name (Act_Spec, Act_Decl_Name);
3527
         Set_Is_Generic_Instance (Act_Decl_Id);
3528
 
3529
         Set_Generic_Parent (Act_Spec, Gen_Unit);
3530
 
3531
         --  References to the generic in its own declaration or its body are
3532
         --  references to the instance. Add a renaming declaration for the
3533
         --  generic unit itself. This declaration, as well as the renaming
3534
         --  declarations for the generic formals, must remain private to the
3535
         --  unit: the formals, because this is the language semantics, and
3536
         --  the unit because its use is an artifact of the implementation.
3537
 
3538
         Unit_Renaming :=
3539
           Make_Package_Renaming_Declaration (Loc,
3540
             Defining_Unit_Name =>
3541
               Make_Defining_Identifier (Loc, Chars (Gen_Unit)),
3542
             Name => New_Reference_To (Act_Decl_Id, Loc));
3543
 
3544
         Append (Unit_Renaming, Renaming_List);
3545
 
3546
         --  The renaming declarations are the first local declarations of
3547
         --  the new unit.
3548
 
3549
         if Is_Non_Empty_List (Visible_Declarations (Act_Spec)) then
3550
            Insert_List_Before
3551
              (First (Visible_Declarations (Act_Spec)), Renaming_List);
3552
         else
3553
            Set_Visible_Declarations (Act_Spec, Renaming_List);
3554
         end if;
3555
 
3556
         Act_Decl :=
3557
           Make_Package_Declaration (Loc,
3558
             Specification => Act_Spec);
3559
 
3560
         --  Save the instantiation node, for subsequent instantiation of the
3561
         --  body, if there is one and we are generating code for the current
3562
         --  unit. Mark the unit as having a body, to avoid a premature error
3563
         --  message.
3564
 
3565
         --  We instantiate the body if we are generating code, if we are
3566
         --  generating cross-reference information, or if we are building
3567
         --  trees for ASIS use.
3568
 
3569
         declare
3570
            Enclosing_Body_Present : Boolean := False;
3571
            --  If the generic unit is not a compilation unit, then a body may
3572
            --  be present in its parent even if none is required. We create a
3573
            --  tentative pending instantiation for the body, which will be
3574
            --  discarded if none is actually present.
3575
 
3576
            Scop : Entity_Id;
3577
 
3578
         begin
3579
            if Scope (Gen_Unit) /= Standard_Standard
3580
              and then not Is_Child_Unit (Gen_Unit)
3581
            then
3582
               Scop := Scope (Gen_Unit);
3583
 
3584
               while Present (Scop)
3585
                 and then Scop /= Standard_Standard
3586
               loop
3587
                  if Unit_Requires_Body (Scop) then
3588
                     Enclosing_Body_Present := True;
3589
                     exit;
3590
 
3591
                  elsif In_Open_Scopes (Scop)
3592
                    and then In_Package_Body (Scop)
3593
                  then
3594
                     Enclosing_Body_Present := True;
3595
                     exit;
3596
                  end if;
3597
 
3598
                  exit when Is_Compilation_Unit (Scop);
3599
                  Scop := Scope (Scop);
3600
               end loop;
3601
            end if;
3602
 
3603
            --  If front-end inlining is enabled, and this is a unit for which
3604
            --  code will be generated, we instantiate the body at once.
3605
 
3606
            --  This is done if the instance is not the main unit, and if the
3607
            --  generic is not a child unit of another generic, to avoid scope
3608
            --  problems and the reinstallation of parent instances.
3609
 
3610
            if Expander_Active
3611
              and then (not Is_Child_Unit (Gen_Unit)
3612
                         or else not Is_Generic_Unit (Scope (Gen_Unit)))
3613
              and then Might_Inline_Subp
3614
              and then not Is_Actual_Pack
3615
            then
3616
               if Front_End_Inlining
3617
                 and then (Is_In_Main_Unit (N)
3618
                            or else In_Main_Context (Current_Scope))
3619
                 and then Nkind (Parent (N)) /= N_Compilation_Unit
3620
               then
3621
                  Inline_Now := True;
3622
 
3623
               --  In configurable_run_time mode we force the inlining of
3624
               --  predefined subprograms marked Inline_Always, to minimize
3625
               --  the use of the run-time library.
3626
 
3627
               elsif Is_Predefined_File_Name
3628
                       (Unit_File_Name (Get_Source_Unit (Gen_Decl)))
3629
                 and then Configurable_Run_Time_Mode
3630
                 and then Nkind (Parent (N)) /= N_Compilation_Unit
3631
               then
3632
                  Inline_Now := True;
3633
               end if;
3634
 
3635
               --  If the current scope is itself an instance within a child
3636
               --  unit, there will be duplications in the scope stack, and the
3637
               --  unstacking mechanism in Inline_Instance_Body will fail.
3638
               --  This loses some rare cases of optimization, and might be
3639
               --  improved some day, if we can find a proper abstraction for
3640
               --  "the complete compilation context" that can be saved and
3641
               --  restored. ???
3642
 
3643
               if Is_Generic_Instance (Current_Scope) then
3644
                  declare
3645
                     Curr_Unit : constant Entity_Id :=
3646
                                   Cunit_Entity (Current_Sem_Unit);
3647
                  begin
3648
                     if Curr_Unit /= Current_Scope
3649
                       and then Is_Child_Unit (Curr_Unit)
3650
                     then
3651
                        Inline_Now := False;
3652
                     end if;
3653
                  end;
3654
               end if;
3655
            end if;
3656
 
3657
            Needs_Body :=
3658
              (Unit_Requires_Body (Gen_Unit)
3659
                  or else Enclosing_Body_Present
3660
                  or else Present (Corresponding_Body (Gen_Decl)))
3661
                and then (Is_In_Main_Unit (N)
3662
                           or else Might_Inline_Subp)
3663
                and then not Is_Actual_Pack
3664
                and then not Inline_Now
3665
                and then not Alfa_Mode
3666
                and then (Operating_Mode = Generate_Code
3667
                           or else (Operating_Mode = Check_Semantics
3668
                                     and then ASIS_Mode));
3669
 
3670
            --  If front_end_inlining is enabled, do not instantiate body if
3671
            --  within a generic context.
3672
 
3673
            if (Front_End_Inlining
3674
                 and then not Expander_Active)
3675
              or else Is_Generic_Unit (Cunit_Entity (Main_Unit))
3676
            then
3677
               Needs_Body := False;
3678
            end if;
3679
 
3680
            --  If the current context is generic, and the package being
3681
            --  instantiated is declared within a formal package, there is no
3682
            --  body to instantiate until the enclosing generic is instantiated
3683
            --  and there is an actual for the formal package. If the formal
3684
            --  package has parameters, we build a regular package instance for
3685
            --  it, that precedes the original formal package declaration.
3686
 
3687
            if In_Open_Scopes (Scope (Scope (Gen_Unit))) then
3688
               declare
3689
                  Decl : constant Node_Id :=
3690
                           Original_Node
3691
                             (Unit_Declaration_Node (Scope (Gen_Unit)));
3692
               begin
3693
                  if Nkind (Decl) = N_Formal_Package_Declaration
3694
                    or else (Nkind (Decl) = N_Package_Declaration
3695
                              and then Is_List_Member (Decl)
3696
                              and then Present (Next (Decl))
3697
                              and then
3698
                                Nkind (Next (Decl)) =
3699
                                                N_Formal_Package_Declaration)
3700
                  then
3701
                     Needs_Body := False;
3702
                  end if;
3703
               end;
3704
            end if;
3705
         end;
3706
 
3707
         --  For RCI unit calling stubs, we omit the instance body if the
3708
         --  instance is the RCI library unit itself.
3709
 
3710
         --  However there is a special case for nested instances: in this case
3711
         --  we do generate the instance body, as it might be required, e.g.
3712
         --  because it provides stream attributes for some type used in the
3713
         --  profile of a remote subprogram. This is consistent with 12.3(12),
3714
         --  which indicates that the instance body occurs at the place of the
3715
         --  instantiation, and thus is part of the RCI declaration, which is
3716
         --  present on all client partitions (this is E.2.3(18)).
3717
 
3718
         --  Note that AI12-0002 may make it illegal at some point to have
3719
         --  stream attributes defined in an RCI unit, in which case this
3720
         --  special case will become unnecessary. In the meantime, there
3721
         --  is known application code in production that depends on this
3722
         --  being possible, so we definitely cannot eliminate the body in
3723
         --  the case of nested instances for the time being.
3724
 
3725
         --  When we generate a nested instance body, calling stubs for any
3726
         --  relevant subprogram will be be inserted immediately after the
3727
         --  subprogram declarations, and will take precedence over the
3728
         --  subsequent (original) body. (The stub and original body will be
3729
         --  complete homographs, but this is permitted in an instance).
3730
         --  (Could we do better and remove the original body???)
3731
 
3732
         if Distribution_Stub_Mode = Generate_Caller_Stub_Body
3733
           and then Comes_From_Source (N)
3734
           and then Nkind (Parent (N)) = N_Compilation_Unit
3735
         then
3736
            Needs_Body := False;
3737
         end if;
3738
 
3739
         if Needs_Body then
3740
 
3741
            --  Here is a defence against a ludicrous number of instantiations
3742
            --  caused by a circular set of instantiation attempts.
3743
 
3744
            if Pending_Instantiations.Last > Hostparm.Max_Instantiations then
3745
               Error_Msg_N ("too many instantiations", N);
3746
               raise Unrecoverable_Error;
3747
            end if;
3748
 
3749
            --  Indicate that the enclosing scopes contain an instantiation,
3750
            --  and that cleanup actions should be delayed until after the
3751
            --  instance body is expanded.
3752
 
3753
            Check_Forward_Instantiation (Gen_Decl);
3754
            if Nkind (N) = N_Package_Instantiation then
3755
               declare
3756
                  Enclosing_Master : Entity_Id;
3757
 
3758
               begin
3759
                  --  Loop to search enclosing masters
3760
 
3761
                  Enclosing_Master := Current_Scope;
3762
                  Scope_Loop : while Enclosing_Master /= Standard_Standard loop
3763
                     if Ekind (Enclosing_Master) = E_Package then
3764
                        if Is_Compilation_Unit (Enclosing_Master) then
3765
                           if In_Package_Body (Enclosing_Master) then
3766
                              Delay_Descriptors
3767
                                (Body_Entity (Enclosing_Master));
3768
                           else
3769
                              Delay_Descriptors
3770
                                (Enclosing_Master);
3771
                           end if;
3772
 
3773
                           exit Scope_Loop;
3774
 
3775
                        else
3776
                           Enclosing_Master := Scope (Enclosing_Master);
3777
                        end if;
3778
 
3779
                     elsif Is_Generic_Unit (Enclosing_Master)
3780
                       or else Ekind (Enclosing_Master) = E_Void
3781
                     then
3782
                        --  Cleanup actions will eventually be performed on the
3783
                        --  enclosing subprogram or package instance, if any.
3784
                        --  Enclosing scope is void in the formal part of a
3785
                        --  generic subprogram.
3786
 
3787
                        exit Scope_Loop;
3788
 
3789
                     else
3790
                        if Ekind (Enclosing_Master) = E_Entry
3791
                          and then
3792
                            Ekind (Scope (Enclosing_Master)) = E_Protected_Type
3793
                        then
3794
                           if not Expander_Active then
3795
                              exit Scope_Loop;
3796
                           else
3797
                              Enclosing_Master :=
3798
                                Protected_Body_Subprogram (Enclosing_Master);
3799
                           end if;
3800
                        end if;
3801
 
3802
                        Set_Delay_Cleanups (Enclosing_Master);
3803
 
3804
                        while Ekind (Enclosing_Master) = E_Block loop
3805
                           Enclosing_Master := Scope (Enclosing_Master);
3806
                        end loop;
3807
 
3808
                        if Is_Subprogram (Enclosing_Master) then
3809
                           Delay_Descriptors (Enclosing_Master);
3810
 
3811
                        elsif Is_Task_Type (Enclosing_Master) then
3812
                           declare
3813
                              TBP : constant Node_Id :=
3814
                                      Get_Task_Body_Procedure
3815
                                        (Enclosing_Master);
3816
                           begin
3817
                              if Present (TBP) then
3818
                                 Delay_Descriptors  (TBP);
3819
                                 Set_Delay_Cleanups (TBP);
3820
                              end if;
3821
                           end;
3822
                        end if;
3823
 
3824
                        exit Scope_Loop;
3825
                     end if;
3826
                  end loop Scope_Loop;
3827
               end;
3828
 
3829
               --  Make entry in table
3830
 
3831
               Pending_Instantiations.Append
3832
                 ((Inst_Node                => N,
3833
                   Act_Decl                 => Act_Decl,
3834
                   Expander_Status          => Expander_Active,
3835
                   Current_Sem_Unit         => Current_Sem_Unit,
3836
                   Scope_Suppress           => Scope_Suppress,
3837
                   Local_Suppress_Stack_Top => Local_Suppress_Stack_Top,
3838
                   Version                  => Ada_Version));
3839
            end if;
3840
         end if;
3841
 
3842
         Set_Categorization_From_Pragmas (Act_Decl);
3843
 
3844
         if Parent_Installed then
3845
            Hide_Current_Scope;
3846
         end if;
3847
 
3848
         Set_Instance_Spec (N, Act_Decl);
3849
 
3850
         --  If not a compilation unit, insert the package declaration before
3851
         --  the original instantiation node.
3852
 
3853
         if Nkind (Parent (N)) /= N_Compilation_Unit then
3854
            Mark_Rewrite_Insertion (Act_Decl);
3855
            Insert_Before (N, Act_Decl);
3856
            Analyze (Act_Decl);
3857
 
3858
         --  For an instantiation that is a compilation unit, place
3859
         --  declaration on current node so context is complete for analysis
3860
         --  (including nested instantiations). If this is the main unit,
3861
         --  the declaration eventually replaces the instantiation node.
3862
         --  If the instance body is created later, it replaces the
3863
         --  instance node, and the declaration is attached to it
3864
         --  (see Build_Instance_Compilation_Unit_Nodes).
3865
 
3866
         else
3867
            if Cunit_Entity (Current_Sem_Unit) = Defining_Entity (N) then
3868
 
3869
               --  The entity for the current unit is the newly created one,
3870
               --  and all semantic information is attached to it.
3871
 
3872
               Set_Cunit_Entity (Current_Sem_Unit, Act_Decl_Id);
3873
 
3874
               --  If this is the main unit, replace the main entity as well
3875
 
3876
               if Current_Sem_Unit = Main_Unit then
3877
                  Main_Unit_Entity := Act_Decl_Id;
3878
               end if;
3879
            end if;
3880
 
3881
            Set_Unit (Parent (N), Act_Decl);
3882
            Set_Parent_Spec (Act_Decl, Parent_Spec (N));
3883
            Set_Package_Instantiation (Act_Decl_Id, N);
3884
            Analyze (Act_Decl);
3885
            Set_Unit (Parent (N), N);
3886
            Set_Body_Required (Parent (N), False);
3887
 
3888
            --  We never need elaboration checks on instantiations, since by
3889
            --  definition, the body instantiation is elaborated at the same
3890
            --  time as the spec instantiation.
3891
 
3892
            Set_Suppress_Elaboration_Warnings (Act_Decl_Id);
3893
            Set_Kill_Elaboration_Checks       (Act_Decl_Id);
3894
         end if;
3895
 
3896
         Check_Elab_Instantiation (N);
3897
 
3898
         if ABE_Is_Certain (N) and then Needs_Body then
3899
            Pending_Instantiations.Decrement_Last;
3900
         end if;
3901
 
3902
         Check_Hidden_Child_Unit (N, Gen_Unit, Act_Decl_Id);
3903
 
3904
         Set_First_Private_Entity (Defining_Unit_Name (Unit_Renaming),
3905
           First_Private_Entity (Act_Decl_Id));
3906
 
3907
         --  If the instantiation will receive a body, the unit will be
3908
         --  transformed into a package body, and receive its own elaboration
3909
         --  entity. Otherwise, the nature of the unit is now a package
3910
         --  declaration.
3911
 
3912
         if Nkind (Parent (N)) = N_Compilation_Unit
3913
           and then not Needs_Body
3914
         then
3915
            Rewrite (N, Act_Decl);
3916
         end if;
3917
 
3918
         if Present (Corresponding_Body (Gen_Decl))
3919
           or else Unit_Requires_Body (Gen_Unit)
3920
         then
3921
            Set_Has_Completion (Act_Decl_Id);
3922
         end if;
3923
 
3924
         Check_Formal_Packages (Act_Decl_Id);
3925
 
3926
         Restore_Hidden_Primitives (Vis_Prims_List);
3927
         Restore_Private_Views (Act_Decl_Id);
3928
 
3929
         Inherit_Context (Gen_Decl, N);
3930
 
3931
         if Parent_Installed then
3932
            Remove_Parent;
3933
         end if;
3934
 
3935
         Restore_Env;
3936
         Env_Installed := False;
3937
      end if;
3938
 
3939
      Validate_Categorization_Dependency (N, Act_Decl_Id);
3940
 
3941
      --  There used to be a check here to prevent instantiations in local
3942
      --  contexts if the No_Local_Allocators restriction was active. This
3943
      --  check was removed by a binding interpretation in AI-95-00130/07,
3944
      --  but we retain the code for documentation purposes.
3945
 
3946
      --  if Ekind (Act_Decl_Id) /= E_Void
3947
      --    and then not Is_Library_Level_Entity (Act_Decl_Id)
3948
      --  then
3949
      --     Check_Restriction (No_Local_Allocators, N);
3950
      --  end if;
3951
 
3952
      if Inline_Now then
3953
         Inline_Instance_Body (N, Gen_Unit, Act_Decl);
3954
      end if;
3955
 
3956
      --  The following is a tree patch for ASIS: ASIS needs separate nodes to
3957
      --  be used as defining identifiers for a formal package and for the
3958
      --  corresponding expanded package.
3959
 
3960
      if Nkind (N) = N_Formal_Package_Declaration then
3961
         Act_Decl_Id := New_Copy (Defining_Entity (N));
3962
         Set_Comes_From_Source (Act_Decl_Id, True);
3963
         Set_Is_Generic_Instance (Act_Decl_Id, False);
3964
         Set_Defining_Identifier (N, Act_Decl_Id);
3965
      end if;
3966
 
3967
      Style_Check := Save_Style_Check;
3968
 
3969
      --  Check that if N is an instantiation of System.Dim_Float_IO or
3970
      --  System.Dim_Integer_IO, the formal type has a dimension system.
3971
 
3972
      if Nkind (N) = N_Package_Instantiation
3973
        and then Is_Dim_IO_Package_Instantiation (N)
3974
      then
3975
         declare
3976
            Assoc : constant Node_Id := First (Generic_Associations (N));
3977
         begin
3978
            if not Has_Dimension_System
3979
                     (Etype (Explicit_Generic_Actual_Parameter (Assoc)))
3980
            then
3981
               Error_Msg_N ("type with a dimension system expected", Assoc);
3982
            end if;
3983
         end;
3984
      end if;
3985
 
3986
   <<Leave>>
3987
      if Has_Aspects (N) then
3988
         Analyze_Aspect_Specifications (N, Act_Decl_Id);
3989
      end if;
3990
 
3991
   exception
3992
      when Instantiation_Error =>
3993
         if Parent_Installed then
3994
            Remove_Parent;
3995
         end if;
3996
 
3997
         if Env_Installed then
3998
            Restore_Env;
3999
         end if;
4000
 
4001
         Style_Check := Save_Style_Check;
4002
   end Analyze_Package_Instantiation;
4003
 
4004
   --------------------------
4005
   -- Inline_Instance_Body --
4006
   --------------------------
4007
 
4008
   procedure Inline_Instance_Body
4009
     (N        : Node_Id;
4010
      Gen_Unit : Entity_Id;
4011
      Act_Decl : Node_Id)
4012
   is
4013
      Vis          : Boolean;
4014
      Gen_Comp     : constant Entity_Id :=
4015
                      Cunit_Entity (Get_Source_Unit (Gen_Unit));
4016
      Curr_Comp    : constant Node_Id := Cunit (Current_Sem_Unit);
4017
      Curr_Scope   : Entity_Id := Empty;
4018
      Curr_Unit    : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
4019
      Removed      : Boolean := False;
4020
      Num_Scopes   : Int := 0;
4021
 
4022
      Scope_Stack_Depth : constant Int :=
4023
                            Scope_Stack.Last - Scope_Stack.First + 1;
4024
 
4025
      Use_Clauses  : array (1 .. Scope_Stack_Depth) of Node_Id;
4026
      Instances    : array (1 .. Scope_Stack_Depth) of Entity_Id;
4027
      Inner_Scopes : array (1 .. Scope_Stack_Depth) of Entity_Id;
4028
      Num_Inner    : Int := 0;
4029
      N_Instances  : Int := 0;
4030
      S            : Entity_Id;
4031
 
4032
   begin
4033
      --  Case of generic unit defined in another unit. We must remove the
4034
      --  complete context of the current unit to install that of the generic.
4035
 
4036
      if Gen_Comp /= Cunit_Entity (Current_Sem_Unit) then
4037
 
4038
         --  Add some comments for the following two loops ???
4039
 
4040
         S := Current_Scope;
4041
         while Present (S) and then S /= Standard_Standard loop
4042
            loop
4043
               Num_Scopes := Num_Scopes + 1;
4044
 
4045
               Use_Clauses (Num_Scopes) :=
4046
                 (Scope_Stack.Table
4047
                    (Scope_Stack.Last - Num_Scopes + 1).
4048
                       First_Use_Clause);
4049
               End_Use_Clauses (Use_Clauses (Num_Scopes));
4050
 
4051
               exit when Scope_Stack.Last - Num_Scopes + 1 = Scope_Stack.First
4052
                 or else Scope_Stack.Table
4053
                           (Scope_Stack.Last - Num_Scopes).Entity
4054
                             = Scope (S);
4055
            end loop;
4056
 
4057
            exit when Is_Generic_Instance (S)
4058
              and then (In_Package_Body (S)
4059
                          or else Ekind (S) = E_Procedure
4060
                          or else Ekind (S) = E_Function);
4061
            S := Scope (S);
4062
         end loop;
4063
 
4064
         Vis := Is_Immediately_Visible (Gen_Comp);
4065
 
4066
         --  Find and save all enclosing instances
4067
 
4068
         S := Current_Scope;
4069
 
4070
         while Present (S)
4071
           and then S /= Standard_Standard
4072
         loop
4073
            if Is_Generic_Instance (S) then
4074
               N_Instances := N_Instances + 1;
4075
               Instances (N_Instances) := S;
4076
 
4077
               exit when In_Package_Body (S);
4078
            end if;
4079
 
4080
            S := Scope (S);
4081
         end loop;
4082
 
4083
         --  Remove context of current compilation unit, unless we are within a
4084
         --  nested package instantiation, in which case the context has been
4085
         --  removed previously.
4086
 
4087
         --  If current scope is the body of a child unit, remove context of
4088
         --  spec as well. If an enclosing scope is an instance body, the
4089
         --  context has already been removed, but the entities in the body
4090
         --  must be made invisible as well.
4091
 
4092
         S := Current_Scope;
4093
 
4094
         while Present (S)
4095
           and then S /= Standard_Standard
4096
         loop
4097
            if Is_Generic_Instance (S)
4098
              and then (In_Package_Body (S)
4099
                          or else Ekind (S) = E_Procedure
4100
                            or else Ekind (S) = E_Function)
4101
            then
4102
               --  We still have to remove the entities of the enclosing
4103
               --  instance from direct visibility.
4104
 
4105
               declare
4106
                  E : Entity_Id;
4107
               begin
4108
                  E := First_Entity (S);
4109
                  while Present (E) loop
4110
                     Set_Is_Immediately_Visible (E, False);
4111
                     Next_Entity (E);
4112
                  end loop;
4113
               end;
4114
 
4115
               exit;
4116
            end if;
4117
 
4118
            if S = Curr_Unit
4119
              or else (Ekind (Curr_Unit) = E_Package_Body
4120
                        and then S = Spec_Entity (Curr_Unit))
4121
              or else (Ekind (Curr_Unit) = E_Subprogram_Body
4122
                        and then S =
4123
                          Corresponding_Spec
4124
                            (Unit_Declaration_Node (Curr_Unit)))
4125
            then
4126
               Removed := True;
4127
 
4128
               --  Remove entities in current scopes from visibility, so that
4129
               --  instance body is compiled in a clean environment.
4130
 
4131
               Save_Scope_Stack (Handle_Use => False);
4132
 
4133
               if Is_Child_Unit (S) then
4134
 
4135
                  --  Remove child unit from stack, as well as inner scopes.
4136
                  --  Removing the context of a child unit removes parent units
4137
                  --  as well.
4138
 
4139
                  while Current_Scope /= S loop
4140
                     Num_Inner := Num_Inner + 1;
4141
                     Inner_Scopes (Num_Inner) := Current_Scope;
4142
                     Pop_Scope;
4143
                  end loop;
4144
 
4145
                  Pop_Scope;
4146
                  Remove_Context (Curr_Comp);
4147
                  Curr_Scope := S;
4148
 
4149
               else
4150
                  Remove_Context (Curr_Comp);
4151
               end if;
4152
 
4153
               if Ekind (Curr_Unit) = E_Package_Body then
4154
                  Remove_Context (Library_Unit (Curr_Comp));
4155
               end if;
4156
            end if;
4157
 
4158
            S := Scope (S);
4159
         end loop;
4160
         pragma Assert (Num_Inner < Num_Scopes);
4161
 
4162
         Push_Scope (Standard_Standard);
4163
         Scope_Stack.Table (Scope_Stack.Last).Is_Active_Stack_Base := True;
4164
         Instantiate_Package_Body
4165
           (Body_Info =>
4166
             ((Inst_Node                => N,
4167
               Act_Decl                 => Act_Decl,
4168
               Expander_Status          => Expander_Active,
4169
               Current_Sem_Unit         => Current_Sem_Unit,
4170
               Scope_Suppress           => Scope_Suppress,
4171
               Local_Suppress_Stack_Top => Local_Suppress_Stack_Top,
4172
               Version                  => Ada_Version)),
4173
            Inlined_Body => True);
4174
 
4175
         Pop_Scope;
4176
 
4177
         --  Restore context
4178
 
4179
         Set_Is_Immediately_Visible (Gen_Comp, Vis);
4180
 
4181
         --  Reset Generic_Instance flag so that use clauses can be installed
4182
         --  in the proper order. (See Use_One_Package for effect of enclosing
4183
         --  instances on processing of use clauses).
4184
 
4185
         for J in 1 .. N_Instances loop
4186
            Set_Is_Generic_Instance (Instances (J), False);
4187
         end loop;
4188
 
4189
         if Removed then
4190
            Install_Context (Curr_Comp);
4191
 
4192
            if Present (Curr_Scope)
4193
              and then Is_Child_Unit (Curr_Scope)
4194
            then
4195
               Push_Scope (Curr_Scope);
4196
               Set_Is_Immediately_Visible (Curr_Scope);
4197
 
4198
               --  Finally, restore inner scopes as well
4199
 
4200
               for J in reverse 1 .. Num_Inner loop
4201
                  Push_Scope (Inner_Scopes (J));
4202
               end loop;
4203
            end if;
4204
 
4205
            Restore_Scope_Stack (Handle_Use => False);
4206
 
4207
            if Present (Curr_Scope)
4208
              and then
4209
                (In_Private_Part (Curr_Scope)
4210
                  or else In_Package_Body (Curr_Scope))
4211
            then
4212
               --  Install private declaration of ancestor units, which are
4213
               --  currently available. Restore_Scope_Stack and Install_Context
4214
               --  only install the visible part of parents.
4215
 
4216
               declare
4217
                  Par : Entity_Id;
4218
               begin
4219
                  Par := Scope (Curr_Scope);
4220
                  while (Present (Par))
4221
                    and then Par /= Standard_Standard
4222
                  loop
4223
                     Install_Private_Declarations (Par);
4224
                     Par := Scope (Par);
4225
                  end loop;
4226
               end;
4227
            end if;
4228
         end if;
4229
 
4230
         --  Restore use clauses. For a child unit, use clauses in the parents
4231
         --  are restored when installing the context, so only those in inner
4232
         --  scopes (and those local to the child unit itself) need to be
4233
         --  installed explicitly.
4234
 
4235
         if Is_Child_Unit (Curr_Unit)
4236
           and then Removed
4237
         then
4238
            for J in reverse 1 .. Num_Inner + 1 loop
4239
               Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause :=
4240
                 Use_Clauses (J);
4241
               Install_Use_Clauses (Use_Clauses (J));
4242
            end  loop;
4243
 
4244
         else
4245
            for J in reverse 1 .. Num_Scopes loop
4246
               Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause :=
4247
                 Use_Clauses (J);
4248
               Install_Use_Clauses (Use_Clauses (J));
4249
            end  loop;
4250
         end if;
4251
 
4252
         --  Restore status of instances. If one of them is a body, make
4253
         --  its local entities visible again.
4254
 
4255
         declare
4256
            E    : Entity_Id;
4257
            Inst : Entity_Id;
4258
 
4259
         begin
4260
            for J in 1 .. N_Instances loop
4261
               Inst := Instances (J);
4262
               Set_Is_Generic_Instance (Inst, True);
4263
 
4264
               if In_Package_Body (Inst)
4265
                 or else Ekind (S) = E_Procedure
4266
                 or else Ekind (S) = E_Function
4267
               then
4268
                  E := First_Entity (Instances (J));
4269
                  while Present (E) loop
4270
                     Set_Is_Immediately_Visible (E);
4271
                     Next_Entity (E);
4272
                  end loop;
4273
               end if;
4274
            end loop;
4275
         end;
4276
 
4277
      --  If generic unit is in current unit, current context is correct
4278
 
4279
      else
4280
         Instantiate_Package_Body
4281
           (Body_Info =>
4282
             ((Inst_Node                => N,
4283
               Act_Decl                 => Act_Decl,
4284
               Expander_Status          => Expander_Active,
4285
               Current_Sem_Unit         => Current_Sem_Unit,
4286
               Scope_Suppress           => Scope_Suppress,
4287
               Local_Suppress_Stack_Top => Local_Suppress_Stack_Top,
4288
               Version                  => Ada_Version)),
4289
            Inlined_Body => True);
4290
      end if;
4291
   end Inline_Instance_Body;
4292
 
4293
   -------------------------------------
4294
   -- Analyze_Procedure_Instantiation --
4295
   -------------------------------------
4296
 
4297
   procedure Analyze_Procedure_Instantiation (N : Node_Id) is
4298
   begin
4299
      Analyze_Subprogram_Instantiation (N, E_Procedure);
4300
   end Analyze_Procedure_Instantiation;
4301
 
4302
   -----------------------------------
4303
   -- Need_Subprogram_Instance_Body --
4304
   -----------------------------------
4305
 
4306
   function Need_Subprogram_Instance_Body
4307
     (N    : Node_Id;
4308
      Subp : Entity_Id) return Boolean
4309
   is
4310
   begin
4311
      if (Is_In_Main_Unit (N)
4312
           or else Is_Inlined (Subp)
4313
           or else Is_Inlined (Alias (Subp)))
4314
        and then (Operating_Mode = Generate_Code
4315
                   or else (Operating_Mode = Check_Semantics
4316
                             and then ASIS_Mode))
4317
        and then (Full_Expander_Active or else ASIS_Mode)
4318
        and then not ABE_Is_Certain (N)
4319
        and then not Is_Eliminated (Subp)
4320
      then
4321
         Pending_Instantiations.Append
4322
           ((Inst_Node                => N,
4323
             Act_Decl                 => Unit_Declaration_Node (Subp),
4324
             Expander_Status          => Expander_Active,
4325
             Current_Sem_Unit         => Current_Sem_Unit,
4326
             Scope_Suppress           => Scope_Suppress,
4327
             Local_Suppress_Stack_Top => Local_Suppress_Stack_Top,
4328
             Version                  => Ada_Version));
4329
         return True;
4330
 
4331
      else
4332
         return False;
4333
      end if;
4334
   end Need_Subprogram_Instance_Body;
4335
 
4336
   --------------------------------------
4337
   -- Analyze_Subprogram_Instantiation --
4338
   --------------------------------------
4339
 
4340
   procedure Analyze_Subprogram_Instantiation
4341
     (N : Node_Id;
4342
      K : Entity_Kind)
4343
   is
4344
      Loc    : constant Source_Ptr := Sloc (N);
4345
      Gen_Id : constant Node_Id    := Name (N);
4346
 
4347
      Anon_Id : constant Entity_Id :=
4348
                  Make_Defining_Identifier (Sloc (Defining_Entity (N)),
4349
                    Chars => New_External_Name
4350
                               (Chars (Defining_Entity (N)), 'R'));
4351
 
4352
      Act_Decl_Id : Entity_Id;
4353
      Act_Decl    : Node_Id;
4354
      Act_Spec    : Node_Id;
4355
      Act_Tree    : Node_Id;
4356
 
4357
      Env_Installed    : Boolean := False;
4358
      Gen_Unit         : Entity_Id;
4359
      Gen_Decl         : Node_Id;
4360
      Pack_Id          : Entity_Id;
4361
      Parent_Installed : Boolean := False;
4362
      Renaming_List    : List_Id;
4363
 
4364
      Save_Style_Check : constant Boolean := Style_Check;
4365
      --  Save style check mode for restore on exit
4366
 
4367
      procedure Analyze_Instance_And_Renamings;
4368
      --  The instance must be analyzed in a context that includes the mappings
4369
      --  of generic parameters into actuals. We create a package declaration
4370
      --  for this purpose, and a subprogram with an internal name within the
4371
      --  package. The subprogram instance is simply an alias for the internal
4372
      --  subprogram, declared in the current scope.
4373
 
4374
      ------------------------------------
4375
      -- Analyze_Instance_And_Renamings --
4376
      ------------------------------------
4377
 
4378
      procedure Analyze_Instance_And_Renamings is
4379
         Def_Ent   : constant Entity_Id := Defining_Entity (N);
4380
         Pack_Decl : Node_Id;
4381
 
4382
      begin
4383
         if Nkind (Parent (N)) = N_Compilation_Unit then
4384
 
4385
            --  For the case of a compilation unit, the container package has
4386
            --  the same name as the instantiation, to insure that the binder
4387
            --  calls the elaboration procedure with the right name. Copy the
4388
            --  entity of the instance, which may have compilation level flags
4389
            --  (e.g. Is_Child_Unit) set.
4390
 
4391
            Pack_Id := New_Copy (Def_Ent);
4392
 
4393
         else
4394
            --  Otherwise we use the name of the instantiation concatenated
4395
            --  with its source position to ensure uniqueness if there are
4396
            --  several instantiations with the same name.
4397
 
4398
            Pack_Id :=
4399
              Make_Defining_Identifier (Loc,
4400
                Chars => New_External_Name
4401
                           (Related_Id   => Chars (Def_Ent),
4402
                            Suffix       => "GP",
4403
                            Suffix_Index => Source_Offset (Sloc (Def_Ent))));
4404
         end if;
4405
 
4406
         Pack_Decl := Make_Package_Declaration (Loc,
4407
           Specification => Make_Package_Specification (Loc,
4408
             Defining_Unit_Name   => Pack_Id,
4409
             Visible_Declarations => Renaming_List,
4410
             End_Label            => Empty));
4411
 
4412
         Set_Instance_Spec (N, Pack_Decl);
4413
         Set_Is_Generic_Instance (Pack_Id);
4414
         Set_Debug_Info_Needed (Pack_Id);
4415
 
4416
         --  Case of not a compilation unit
4417
 
4418
         if Nkind (Parent (N)) /= N_Compilation_Unit then
4419
            Mark_Rewrite_Insertion (Pack_Decl);
4420
            Insert_Before (N, Pack_Decl);
4421
            Set_Has_Completion (Pack_Id);
4422
 
4423
         --  Case of an instantiation that is a compilation unit
4424
 
4425
         --  Place declaration on current node so context is complete for
4426
         --  analysis (including nested instantiations), and for use in a
4427
         --  context_clause (see Analyze_With_Clause).
4428
 
4429
         else
4430
            Set_Unit (Parent (N), Pack_Decl);
4431
            Set_Parent_Spec (Pack_Decl, Parent_Spec (N));
4432
         end if;
4433
 
4434
         Analyze (Pack_Decl);
4435
         Check_Formal_Packages (Pack_Id);
4436
         Set_Is_Generic_Instance (Pack_Id, False);
4437
 
4438
         --  Why do we clear Is_Generic_Instance??? We set it 20 lines
4439
         --  above???
4440
 
4441
         --  Body of the enclosing package is supplied when instantiating the
4442
         --  subprogram body, after semantic analysis is completed.
4443
 
4444
         if Nkind (Parent (N)) = N_Compilation_Unit then
4445
 
4446
            --  Remove package itself from visibility, so it does not
4447
            --  conflict with subprogram.
4448
 
4449
            Set_Name_Entity_Id (Chars (Pack_Id), Homonym (Pack_Id));
4450
 
4451
            --  Set name and scope of internal subprogram so that the proper
4452
            --  external name will be generated. The proper scope is the scope
4453
            --  of the wrapper package. We need to generate debugging info for
4454
            --  the internal subprogram, so set flag accordingly.
4455
 
4456
            Set_Chars (Anon_Id, Chars (Defining_Entity (N)));
4457
            Set_Scope (Anon_Id, Scope (Pack_Id));
4458
 
4459
            --  Mark wrapper package as referenced, to avoid spurious warnings
4460
            --  if the instantiation appears in various with_ clauses of
4461
            --  subunits of the main unit.
4462
 
4463
            Set_Referenced (Pack_Id);
4464
         end if;
4465
 
4466
         Set_Is_Generic_Instance (Anon_Id);
4467
         Set_Debug_Info_Needed   (Anon_Id);
4468
         Act_Decl_Id := New_Copy (Anon_Id);
4469
 
4470
         Set_Parent            (Act_Decl_Id, Parent (Anon_Id));
4471
         Set_Chars             (Act_Decl_Id, Chars (Defining_Entity (N)));
4472
         Set_Sloc              (Act_Decl_Id, Sloc (Defining_Entity (N)));
4473
         Set_Comes_From_Source (Act_Decl_Id, True);
4474
 
4475
         --  The signature may involve types that are not frozen yet, but the
4476
         --  subprogram will be frozen at the point the wrapper package is
4477
         --  frozen, so it does not need its own freeze node. In fact, if one
4478
         --  is created, it might conflict with the freezing actions from the
4479
         --  wrapper package.
4480
 
4481
         Set_Has_Delayed_Freeze (Anon_Id, False);
4482
 
4483
         --  If the instance is a child unit, mark the Id accordingly. Mark
4484
         --  the anonymous entity as well, which is the real subprogram and
4485
         --  which is used when the instance appears in a context clause.
4486
         --  Similarly, propagate the Is_Eliminated flag to handle properly
4487
         --  nested eliminated subprograms.
4488
 
4489
         Set_Is_Child_Unit (Act_Decl_Id, Is_Child_Unit (Defining_Entity (N)));
4490
         Set_Is_Child_Unit (Anon_Id, Is_Child_Unit (Defining_Entity (N)));
4491
         New_Overloaded_Entity (Act_Decl_Id);
4492
         Check_Eliminated  (Act_Decl_Id);
4493
         Set_Is_Eliminated (Anon_Id, Is_Eliminated (Act_Decl_Id));
4494
 
4495
         --  In compilation unit case, kill elaboration checks on the
4496
         --  instantiation, since they are never needed -- the body is
4497
         --  instantiated at the same point as the spec.
4498
 
4499
         if Nkind (Parent (N)) = N_Compilation_Unit then
4500
            Set_Suppress_Elaboration_Warnings (Act_Decl_Id);
4501
            Set_Kill_Elaboration_Checks       (Act_Decl_Id);
4502
            Set_Is_Compilation_Unit (Anon_Id);
4503
 
4504
            Set_Cunit_Entity (Current_Sem_Unit, Pack_Id);
4505
         end if;
4506
 
4507
         --  The instance is not a freezing point for the new subprogram
4508
 
4509
         Set_Is_Frozen (Act_Decl_Id, False);
4510
 
4511
         if Nkind (Defining_Entity (N)) = N_Defining_Operator_Symbol then
4512
            Valid_Operator_Definition (Act_Decl_Id);
4513
         end if;
4514
 
4515
         Set_Alias  (Act_Decl_Id, Anon_Id);
4516
         Set_Parent (Act_Decl_Id, Parent (Anon_Id));
4517
         Set_Has_Completion (Act_Decl_Id);
4518
         Set_Related_Instance (Pack_Id, Act_Decl_Id);
4519
 
4520
         if Nkind (Parent (N)) = N_Compilation_Unit then
4521
            Set_Body_Required (Parent (N), False);
4522
         end if;
4523
      end Analyze_Instance_And_Renamings;
4524
 
4525
      --  Local variables
4526
 
4527
      Vis_Prims_List : Elist_Id := No_Elist;
4528
      --  List of primitives made temporarily visible in the instantiation
4529
      --  to match the visibility of the formal type
4530
 
4531
   --  Start of processing for Analyze_Subprogram_Instantiation
4532
 
4533
   begin
4534
      Check_SPARK_Restriction ("generic is not allowed", N);
4535
 
4536
      --  Very first thing: apply the special kludge for Text_IO processing
4537
      --  in case we are instantiating one of the children of [Wide_]Text_IO.
4538
      --  Of course such an instantiation is bogus (these are packages, not
4539
      --  subprograms), but we get a better error message if we do this.
4540
 
4541
      Text_IO_Kludge (Gen_Id);
4542
 
4543
      --  Make node global for error reporting
4544
 
4545
      Instantiation_Node := N;
4546
 
4547
      --  Turn off style checking in instances. If the check is enabled on the
4548
      --  generic unit, a warning in an instance would just be noise. If not
4549
      --  enabled on the generic, then a warning in an instance is just wrong.
4550
 
4551
      Style_Check := False;
4552
 
4553
      Preanalyze_Actuals (N);
4554
 
4555
      Init_Env;
4556
      Env_Installed := True;
4557
      Check_Generic_Child_Unit (Gen_Id, Parent_Installed);
4558
      Gen_Unit := Entity (Gen_Id);
4559
 
4560
      Generate_Reference (Gen_Unit, Gen_Id);
4561
 
4562
      if Nkind (Gen_Id) = N_Identifier
4563
        and then Chars (Gen_Unit) = Chars (Defining_Entity (N))
4564
      then
4565
         Error_Msg_NE
4566
           ("& is hidden within declaration of instance", Gen_Id, Gen_Unit);
4567
      end if;
4568
 
4569
      if Etype (Gen_Unit) = Any_Type then
4570
         Restore_Env;
4571
         return;
4572
      end if;
4573
 
4574
      --  Verify that it is a generic subprogram of the right kind, and that
4575
      --  it does not lead to a circular instantiation.
4576
 
4577
      if not Ekind_In (Gen_Unit, E_Generic_Procedure, E_Generic_Function) then
4578
         Error_Msg_N ("expect generic subprogram in instantiation", Gen_Id);
4579
 
4580
      elsif In_Open_Scopes (Gen_Unit) then
4581
         Error_Msg_NE ("instantiation of & within itself", N, Gen_Unit);
4582
 
4583
      elsif K = E_Procedure
4584
        and then Ekind (Gen_Unit) /= E_Generic_Procedure
4585
      then
4586
         if Ekind (Gen_Unit) = E_Generic_Function then
4587
            Error_Msg_N
4588
              ("cannot instantiate generic function as procedure", Gen_Id);
4589
         else
4590
            Error_Msg_N
4591
              ("expect name of generic procedure in instantiation", Gen_Id);
4592
         end if;
4593
 
4594
      elsif K = E_Function
4595
        and then Ekind (Gen_Unit) /= E_Generic_Function
4596
      then
4597
         if Ekind (Gen_Unit) = E_Generic_Procedure then
4598
            Error_Msg_N
4599
              ("cannot instantiate generic procedure as function", Gen_Id);
4600
         else
4601
            Error_Msg_N
4602
              ("expect name of generic function in instantiation", Gen_Id);
4603
         end if;
4604
 
4605
      else
4606
         Set_Entity (Gen_Id, Gen_Unit);
4607
         Set_Is_Instantiated (Gen_Unit);
4608
 
4609
         if In_Extended_Main_Source_Unit (N) then
4610
            Generate_Reference (Gen_Unit, N);
4611
         end if;
4612
 
4613
         --  If renaming, get original unit
4614
 
4615
         if Present (Renamed_Object (Gen_Unit))
4616
           and then (Ekind (Renamed_Object (Gen_Unit)) = E_Generic_Procedure
4617
                       or else
4618
                     Ekind (Renamed_Object (Gen_Unit)) = E_Generic_Function)
4619
         then
4620
            Gen_Unit := Renamed_Object (Gen_Unit);
4621
            Set_Is_Instantiated (Gen_Unit);
4622
            Generate_Reference  (Gen_Unit, N);
4623
         end if;
4624
 
4625
         if Contains_Instance_Of (Gen_Unit, Current_Scope, Gen_Id) then
4626
            Error_Msg_Node_2 := Current_Scope;
4627
            Error_Msg_NE
4628
              ("circular Instantiation: & instantiated in &!", N, Gen_Unit);
4629
            Circularity_Detected := True;
4630
            Restore_Hidden_Primitives (Vis_Prims_List);
4631
            goto Leave;
4632
         end if;
4633
 
4634
         Gen_Decl := Unit_Declaration_Node (Gen_Unit);
4635
 
4636
         --  Initialize renamings map, for error checking
4637
 
4638
         Generic_Renamings.Set_Last (0);
4639
         Generic_Renamings_HTable.Reset;
4640
 
4641
         Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment);
4642
 
4643
         --  Copy original generic tree, to produce text for instantiation
4644
 
4645
         Act_Tree :=
4646
           Copy_Generic_Node
4647
             (Original_Node (Gen_Decl), Empty, Instantiating => True);
4648
 
4649
         --  Inherit overriding indicator from instance node
4650
 
4651
         Act_Spec := Specification (Act_Tree);
4652
         Set_Must_Override     (Act_Spec, Must_Override (N));
4653
         Set_Must_Not_Override (Act_Spec, Must_Not_Override (N));
4654
 
4655
         Renaming_List :=
4656
           Analyze_Associations
4657
             (I_Node  => N,
4658
              Formals => Generic_Formal_Declarations (Act_Tree),
4659
              F_Copy  => Generic_Formal_Declarations (Gen_Decl));
4660
 
4661
         Vis_Prims_List := Check_Hidden_Primitives (Renaming_List);
4662
 
4663
         --  The subprogram itself cannot contain a nested instance, so the
4664
         --  current parent is left empty.
4665
 
4666
         Set_Instance_Env (Gen_Unit, Empty);
4667
 
4668
         --  Build the subprogram declaration, which does not appear in the
4669
         --  generic template, and give it a sloc consistent with that of the
4670
         --  template.
4671
 
4672
         Set_Defining_Unit_Name (Act_Spec, Anon_Id);
4673
         Set_Generic_Parent (Act_Spec, Gen_Unit);
4674
         Act_Decl :=
4675
           Make_Subprogram_Declaration (Sloc (Act_Spec),
4676
             Specification => Act_Spec);
4677
 
4678
         --  The aspects have been copied previously, but they have to be
4679
         --  linked explicitly to the new subprogram declaration. Explicit
4680
         --  pre/postconditions on the instance are analyzed below, in a
4681
         --  separate step.
4682
 
4683
         Move_Aspects (Act_Tree, Act_Decl);
4684
         Set_Categorization_From_Pragmas (Act_Decl);
4685
 
4686
         if Parent_Installed then
4687
            Hide_Current_Scope;
4688
         end if;
4689
 
4690
         Append (Act_Decl, Renaming_List);
4691
         Analyze_Instance_And_Renamings;
4692
 
4693
         --  If the generic is marked Import (Intrinsic), then so is the
4694
         --  instance. This indicates that there is no body to instantiate. If
4695
         --  generic is marked inline, so it the instance, and the anonymous
4696
         --  subprogram it renames. If inlined, or else if inlining is enabled
4697
         --  for the compilation, we generate the instance body even if it is
4698
         --  not within the main unit.
4699
 
4700
         if Is_Intrinsic_Subprogram (Gen_Unit) then
4701
            Set_Is_Intrinsic_Subprogram (Anon_Id);
4702
            Set_Is_Intrinsic_Subprogram (Act_Decl_Id);
4703
 
4704
            if Chars (Gen_Unit) = Name_Unchecked_Conversion then
4705
               Validate_Unchecked_Conversion (N, Act_Decl_Id);
4706
            end if;
4707
         end if;
4708
 
4709
         --  Inherit convention from generic unit. Intrinsic convention, as for
4710
         --  an instance of unchecked conversion, is not inherited because an
4711
         --  explicit Ada instance has been created.
4712
 
4713
         if Has_Convention_Pragma (Gen_Unit)
4714
           and then Convention (Gen_Unit) /= Convention_Intrinsic
4715
         then
4716
            Set_Convention (Act_Decl_Id, Convention (Gen_Unit));
4717
            Set_Is_Exported (Act_Decl_Id, Is_Exported (Gen_Unit));
4718
         end if;
4719
 
4720
         Generate_Definition (Act_Decl_Id);
4721
         --  Set_Contract (Anon_Id, Make_Contract (Sloc (Anon_Id)));
4722
         --  ??? needed?
4723
         Set_Contract (Act_Decl_Id, Make_Contract (Sloc (Act_Decl_Id)));
4724
 
4725
         --  Inherit all inlining-related flags which apply to the generic in
4726
         --  the subprogram and its declaration.
4727
 
4728
         Set_Is_Inlined (Act_Decl_Id, Is_Inlined (Gen_Unit));
4729
         Set_Is_Inlined (Anon_Id,     Is_Inlined (Gen_Unit));
4730
 
4731
         Set_Has_Pragma_Inline (Act_Decl_Id, Has_Pragma_Inline (Gen_Unit));
4732
         Set_Has_Pragma_Inline (Anon_Id,     Has_Pragma_Inline (Gen_Unit));
4733
 
4734
         Set_Has_Pragma_Inline_Always
4735
           (Act_Decl_Id, Has_Pragma_Inline_Always (Gen_Unit));
4736
         Set_Has_Pragma_Inline_Always
4737
           (Anon_Id,     Has_Pragma_Inline_Always (Gen_Unit));
4738
 
4739
         if not Is_Intrinsic_Subprogram (Gen_Unit) then
4740
            Check_Elab_Instantiation (N);
4741
         end if;
4742
 
4743
         if Is_Dispatching_Operation (Act_Decl_Id)
4744
           and then Ada_Version >= Ada_2005
4745
         then
4746
            declare
4747
               Formal : Entity_Id;
4748
 
4749
            begin
4750
               Formal := First_Formal (Act_Decl_Id);
4751
               while Present (Formal) loop
4752
                  if Ekind (Etype (Formal)) = E_Anonymous_Access_Type
4753
                    and then Is_Controlling_Formal (Formal)
4754
                    and then not Can_Never_Be_Null (Formal)
4755
                  then
4756
                     Error_Msg_NE ("access parameter& is controlling,",
4757
                       N, Formal);
4758
                     Error_Msg_NE
4759
                       ("\corresponding parameter of & must be"
4760
                       & " explicitly null-excluding", N, Gen_Id);
4761
                  end if;
4762
 
4763
                  Next_Formal (Formal);
4764
               end loop;
4765
            end;
4766
         end if;
4767
 
4768
         Check_Hidden_Child_Unit (N, Gen_Unit, Act_Decl_Id);
4769
 
4770
         Validate_Categorization_Dependency (N, Act_Decl_Id);
4771
 
4772
         if not Is_Intrinsic_Subprogram (Act_Decl_Id) then
4773
            Inherit_Context (Gen_Decl, N);
4774
 
4775
            Restore_Private_Views (Pack_Id, False);
4776
 
4777
            --  If the context requires a full instantiation, mark node for
4778
            --  subsequent construction of the body.
4779
 
4780
            if Need_Subprogram_Instance_Body (N, Act_Decl_Id) then
4781
 
4782
               Check_Forward_Instantiation (Gen_Decl);
4783
 
4784
               --  The wrapper package is always delayed, because it does not
4785
               --  constitute a freeze point, but to insure that the freeze
4786
               --  node is placed properly, it is created directly when
4787
               --  instantiating the body (otherwise the freeze node might
4788
               --  appear to early for nested instantiations).
4789
 
4790
            elsif Nkind (Parent (N)) = N_Compilation_Unit then
4791
 
4792
               --  For ASIS purposes, indicate that the wrapper package has
4793
               --  replaced the instantiation node.
4794
 
4795
               Rewrite (N, Unit (Parent (N)));
4796
               Set_Unit (Parent (N), N);
4797
            end if;
4798
 
4799
         elsif Nkind (Parent (N)) = N_Compilation_Unit then
4800
 
4801
               --  Replace instance node for library-level instantiations of
4802
               --  intrinsic subprograms, for ASIS use.
4803
 
4804
               Rewrite (N, Unit (Parent (N)));
4805
               Set_Unit (Parent (N), N);
4806
         end if;
4807
 
4808
         if Parent_Installed then
4809
            Remove_Parent;
4810
         end if;
4811
 
4812
         Restore_Hidden_Primitives (Vis_Prims_List);
4813
         Restore_Env;
4814
         Env_Installed := False;
4815
         Generic_Renamings.Set_Last (0);
4816
         Generic_Renamings_HTable.Reset;
4817
      end if;
4818
 
4819
      Style_Check := Save_Style_Check;
4820
 
4821
   <<Leave>>
4822
      if Has_Aspects (N) then
4823
         Analyze_Aspect_Specifications (N, Act_Decl_Id);
4824
      end if;
4825
 
4826
   exception
4827
      when Instantiation_Error =>
4828
         if Parent_Installed then
4829
            Remove_Parent;
4830
         end if;
4831
 
4832
         if Env_Installed then
4833
            Restore_Env;
4834
         end if;
4835
 
4836
         Style_Check := Save_Style_Check;
4837
   end Analyze_Subprogram_Instantiation;
4838
 
4839
   -------------------------
4840
   -- Get_Associated_Node --
4841
   -------------------------
4842
 
4843
   function Get_Associated_Node (N : Node_Id) return Node_Id is
4844
      Assoc : Node_Id;
4845
 
4846
   begin
4847
      Assoc := Associated_Node (N);
4848
 
4849
      if Nkind (Assoc) /= Nkind (N) then
4850
         return Assoc;
4851
 
4852
      elsif Nkind_In (Assoc, N_Aggregate, N_Extension_Aggregate) then
4853
         return Assoc;
4854
 
4855
      else
4856
         --  If the node is part of an inner generic, it may itself have been
4857
         --  remapped into a further generic copy. Associated_Node is otherwise
4858
         --  used for the entity of the node, and will be of a different node
4859
         --  kind, or else N has been rewritten as a literal or function call.
4860
 
4861
         while Present (Associated_Node (Assoc))
4862
           and then Nkind (Associated_Node (Assoc)) = Nkind (Assoc)
4863
         loop
4864
            Assoc := Associated_Node (Assoc);
4865
         end loop;
4866
 
4867
         --  Follow and additional link in case the final node was rewritten.
4868
         --  This can only happen with nested generic units.
4869
 
4870
         if (Nkind (Assoc) = N_Identifier or else Nkind (Assoc) in N_Op)
4871
           and then Present (Associated_Node (Assoc))
4872
           and then (Nkind_In (Associated_Node (Assoc), N_Function_Call,
4873
                                                        N_Explicit_Dereference,
4874
                                                        N_Integer_Literal,
4875
                                                        N_Real_Literal,
4876
                                                        N_String_Literal))
4877
         then
4878
            Assoc := Associated_Node (Assoc);
4879
         end if;
4880
 
4881
         return Assoc;
4882
      end if;
4883
   end Get_Associated_Node;
4884
 
4885
   -------------------------------------------
4886
   -- Build_Instance_Compilation_Unit_Nodes --
4887
   -------------------------------------------
4888
 
4889
   procedure Build_Instance_Compilation_Unit_Nodes
4890
     (N        : Node_Id;
4891
      Act_Body : Node_Id;
4892
      Act_Decl : Node_Id)
4893
   is
4894
      Decl_Cunit : Node_Id;
4895
      Body_Cunit : Node_Id;
4896
      Citem      : Node_Id;
4897
      New_Main   : constant Entity_Id := Defining_Entity (Act_Decl);
4898
      Old_Main   : constant Entity_Id := Cunit_Entity (Main_Unit);
4899
 
4900
   begin
4901
      --  A new compilation unit node is built for the instance declaration
4902
 
4903
      Decl_Cunit :=
4904
        Make_Compilation_Unit (Sloc (N),
4905
          Context_Items  => Empty_List,
4906
          Unit           => Act_Decl,
4907
          Aux_Decls_Node =>
4908
            Make_Compilation_Unit_Aux (Sloc (N)));
4909
 
4910
      Set_Parent_Spec   (Act_Decl, Parent_Spec (N));
4911
 
4912
      --  The new compilation unit is linked to its body, but both share the
4913
      --  same file, so we do not set Body_Required on the new unit so as not
4914
      --  to create a spurious dependency on a non-existent body in the ali.
4915
      --  This simplifies CodePeer unit traversal.
4916
 
4917
      --  We use the original instantiation compilation unit as the resulting
4918
      --  compilation unit of the instance, since this is the main unit.
4919
 
4920
      Rewrite (N, Act_Body);
4921
      Body_Cunit := Parent (N);
4922
 
4923
      --  The two compilation unit nodes are linked by the Library_Unit field
4924
 
4925
      Set_Library_Unit  (Decl_Cunit, Body_Cunit);
4926
      Set_Library_Unit  (Body_Cunit, Decl_Cunit);
4927
 
4928
      --  Preserve the private nature of the package if needed
4929
 
4930
      Set_Private_Present (Decl_Cunit, Private_Present (Body_Cunit));
4931
 
4932
      --  If the instance is not the main unit, its context, categorization
4933
      --  and elaboration entity are not relevant to the compilation.
4934
 
4935
      if Body_Cunit /= Cunit (Main_Unit) then
4936
         Make_Instance_Unit (Body_Cunit, In_Main => False);
4937
         return;
4938
      end if;
4939
 
4940
      --  The context clause items on the instantiation, which are now attached
4941
      --  to the body compilation unit (since the body overwrote the original
4942
      --  instantiation node), semantically belong on the spec, so copy them
4943
      --  there. It's harmless to leave them on the body as well. In fact one
4944
      --  could argue that they belong in both places.
4945
 
4946
      Citem := First (Context_Items (Body_Cunit));
4947
      while Present (Citem) loop
4948
         Append (New_Copy (Citem), Context_Items (Decl_Cunit));
4949
         Next (Citem);
4950
      end loop;
4951
 
4952
      --  Propagate categorization flags on packages, so that they appear in
4953
      --  the ali file for the spec of the unit.
4954
 
4955
      if Ekind (New_Main) = E_Package then
4956
         Set_Is_Pure           (Old_Main, Is_Pure (New_Main));
4957
         Set_Is_Preelaborated  (Old_Main, Is_Preelaborated (New_Main));
4958
         Set_Is_Remote_Types   (Old_Main, Is_Remote_Types (New_Main));
4959
         Set_Is_Shared_Passive (Old_Main, Is_Shared_Passive (New_Main));
4960
         Set_Is_Remote_Call_Interface
4961
           (Old_Main, Is_Remote_Call_Interface (New_Main));
4962
      end if;
4963
 
4964
      --  Make entry in Units table, so that binder can generate call to
4965
      --  elaboration procedure for body, if any.
4966
 
4967
      Make_Instance_Unit (Body_Cunit, In_Main => True);
4968
      Main_Unit_Entity := New_Main;
4969
      Set_Cunit_Entity (Main_Unit, Main_Unit_Entity);
4970
 
4971
      --  Build elaboration entity, since the instance may certainly generate
4972
      --  elaboration code requiring a flag for protection.
4973
 
4974
      Build_Elaboration_Entity (Decl_Cunit, New_Main);
4975
   end Build_Instance_Compilation_Unit_Nodes;
4976
 
4977
   -----------------------------
4978
   -- Check_Access_Definition --
4979
   -----------------------------
4980
 
4981
   procedure Check_Access_Definition (N : Node_Id) is
4982
   begin
4983
      pragma Assert
4984
        (Ada_Version >= Ada_2005
4985
           and then Present (Access_Definition (N)));
4986
      null;
4987
   end Check_Access_Definition;
4988
 
4989
   -----------------------------------
4990
   -- Check_Formal_Package_Instance --
4991
   -----------------------------------
4992
 
4993
   --  If the formal has specific parameters, they must match those of the
4994
   --  actual. Both of them are instances, and the renaming declarations for
4995
   --  their formal parameters appear in the same order in both. The analyzed
4996
   --  formal has been analyzed in the context of the current instance.
4997
 
4998
   procedure Check_Formal_Package_Instance
4999
     (Formal_Pack : Entity_Id;
5000
      Actual_Pack : Entity_Id)
5001
   is
5002
      E1 : Entity_Id := First_Entity (Actual_Pack);
5003
      E2 : Entity_Id := First_Entity (Formal_Pack);
5004
 
5005
      Expr1 : Node_Id;
5006
      Expr2 : Node_Id;
5007
 
5008
      procedure Check_Mismatch (B : Boolean);
5009
      --  Common error routine for mismatch between the parameters of the
5010
      --  actual instance and those of the formal package.
5011
 
5012
      function Same_Instantiated_Constant (E1, E2 : Entity_Id) return Boolean;
5013
      --  The formal may come from a nested formal package, and the actual may
5014
      --  have been constant-folded. To determine whether the two denote the
5015
      --  same entity we may have to traverse several definitions to recover
5016
      --  the ultimate entity that they refer to.
5017
 
5018
      function Same_Instantiated_Variable (E1, E2 : Entity_Id) return Boolean;
5019
      --  Similarly, if the formal comes from a nested formal package, the
5020
      --  actual may designate the formal through multiple renamings, which
5021
      --  have to be followed to determine the original variable in question.
5022
 
5023
      --------------------
5024
      -- Check_Mismatch --
5025
      --------------------
5026
 
5027
      procedure Check_Mismatch (B : Boolean) is
5028
         Kind : constant Node_Kind := Nkind (Parent (E2));
5029
 
5030
      begin
5031
         if Kind = N_Formal_Type_Declaration then
5032
            return;
5033
 
5034
         elsif Nkind_In (Kind, N_Formal_Object_Declaration,
5035
                               N_Formal_Package_Declaration)
5036
           or else Kind in N_Formal_Subprogram_Declaration
5037
         then
5038
            null;
5039
 
5040
         elsif B then
5041
            Error_Msg_NE
5042
              ("actual for & in actual instance does not match formal",
5043
               Parent (Actual_Pack), E1);
5044
         end if;
5045
      end Check_Mismatch;
5046
 
5047
      --------------------------------
5048
      -- Same_Instantiated_Constant --
5049
      --------------------------------
5050
 
5051
      function Same_Instantiated_Constant
5052
        (E1, E2 : Entity_Id) return Boolean
5053
      is
5054
         Ent : Entity_Id;
5055
 
5056
      begin
5057
         Ent := E2;
5058
         while Present (Ent) loop
5059
            if E1 = Ent then
5060
               return True;
5061
 
5062
            elsif Ekind (Ent) /= E_Constant then
5063
               return False;
5064
 
5065
            elsif Is_Entity_Name (Constant_Value (Ent)) then
5066
               if  Entity (Constant_Value (Ent)) = E1 then
5067
                  return True;
5068
               else
5069
                  Ent := Entity (Constant_Value (Ent));
5070
               end if;
5071
 
5072
            --  The actual may be a constant that has been folded. Recover
5073
            --  original name.
5074
 
5075
            elsif Is_Entity_Name (Original_Node (Constant_Value (Ent))) then
5076
                  Ent := Entity (Original_Node (Constant_Value (Ent)));
5077
            else
5078
               return False;
5079
            end if;
5080
         end loop;
5081
 
5082
         return False;
5083
      end Same_Instantiated_Constant;
5084
 
5085
      --------------------------------
5086
      -- Same_Instantiated_Variable --
5087
      --------------------------------
5088
 
5089
      function Same_Instantiated_Variable
5090
        (E1, E2 : Entity_Id) return Boolean
5091
      is
5092
         function Original_Entity (E : Entity_Id) return Entity_Id;
5093
         --  Follow chain of renamings to the ultimate ancestor
5094
 
5095
         ---------------------
5096
         -- Original_Entity --
5097
         ---------------------
5098
 
5099
         function Original_Entity (E : Entity_Id) return Entity_Id is
5100
            Orig : Entity_Id;
5101
 
5102
         begin
5103
            Orig := E;
5104
            while Nkind (Parent (Orig)) = N_Object_Renaming_Declaration
5105
              and then Present (Renamed_Object (Orig))
5106
              and then Is_Entity_Name (Renamed_Object (Orig))
5107
            loop
5108
               Orig := Entity (Renamed_Object (Orig));
5109
            end loop;
5110
 
5111
            return Orig;
5112
         end Original_Entity;
5113
 
5114
      --  Start of processing for Same_Instantiated_Variable
5115
 
5116
      begin
5117
         return Ekind (E1) = Ekind (E2)
5118
           and then Original_Entity (E1) = Original_Entity (E2);
5119
      end Same_Instantiated_Variable;
5120
 
5121
   --  Start of processing for Check_Formal_Package_Instance
5122
 
5123
   begin
5124
      while Present (E1)
5125
        and then Present (E2)
5126
      loop
5127
         exit when Ekind (E1) = E_Package
5128
           and then Renamed_Entity (E1) = Renamed_Entity (Actual_Pack);
5129
 
5130
         --  If the formal is the renaming of the formal package, this
5131
         --  is the end of its formal part, which may occur before the
5132
         --  end of the formal part in the actual in the presence of
5133
         --  defaulted parameters in the formal package.
5134
 
5135
         exit when Nkind (Parent (E2)) = N_Package_Renaming_Declaration
5136
           and then Renamed_Entity (E2) = Scope (E2);
5137
 
5138
         --  The analysis of the actual may generate additional internal
5139
         --  entities. If the formal is defaulted, there is no corresponding
5140
         --  analysis and the internal entities must be skipped, until we
5141
         --  find corresponding entities again.
5142
 
5143
         if Comes_From_Source (E2)
5144
           and then not Comes_From_Source (E1)
5145
           and then Chars (E1) /= Chars (E2)
5146
         then
5147
            while Present (E1)
5148
              and then  Chars (E1) /= Chars (E2)
5149
            loop
5150
               Next_Entity (E1);
5151
            end loop;
5152
         end if;
5153
 
5154
         if No (E1) then
5155
            return;
5156
 
5157
         --  If the formal entity comes from a formal declaration, it was
5158
         --  defaulted in the formal package, and no check is needed on it.
5159
 
5160
         elsif Nkind (Parent (E2)) =  N_Formal_Object_Declaration then
5161
            goto Next_E;
5162
 
5163
         elsif Is_Type (E1) then
5164
 
5165
            --  Subtypes must statically match. E1, E2 are the local entities
5166
            --  that are subtypes of the actuals. Itypes generated for other
5167
            --  parameters need not be checked, the check will be performed
5168
            --  on the parameters themselves.
5169
 
5170
            --  If E2 is a formal type declaration, it is a defaulted parameter
5171
            --  and needs no checking.
5172
 
5173
            if not Is_Itype (E1)
5174
              and then not Is_Itype (E2)
5175
            then
5176
               Check_Mismatch
5177
                 (not Is_Type (E2)
5178
                   or else Etype (E1) /= Etype (E2)
5179
                   or else not Subtypes_Statically_Match (E1, E2));
5180
            end if;
5181
 
5182
         elsif Ekind (E1) = E_Constant then
5183
 
5184
            --  IN parameters must denote the same static value, or the same
5185
            --  constant, or the literal null.
5186
 
5187
            Expr1 := Expression (Parent (E1));
5188
 
5189
            if Ekind (E2) /= E_Constant then
5190
               Check_Mismatch (True);
5191
               goto Next_E;
5192
            else
5193
               Expr2 := Expression (Parent (E2));
5194
            end if;
5195
 
5196
            if Is_Static_Expression (Expr1) then
5197
 
5198
               if not Is_Static_Expression (Expr2) then
5199
                  Check_Mismatch (True);
5200
 
5201
               elsif Is_Discrete_Type (Etype (E1)) then
5202
                  declare
5203
                     V1 : constant Uint := Expr_Value (Expr1);
5204
                     V2 : constant Uint := Expr_Value (Expr2);
5205
                  begin
5206
                     Check_Mismatch (V1 /= V2);
5207
                  end;
5208
 
5209
               elsif Is_Real_Type (Etype (E1)) then
5210
                  declare
5211
                     V1 : constant Ureal := Expr_Value_R (Expr1);
5212
                     V2 : constant Ureal := Expr_Value_R (Expr2);
5213
                  begin
5214
                     Check_Mismatch (V1 /= V2);
5215
                  end;
5216
 
5217
               elsif Is_String_Type (Etype (E1))
5218
                 and then Nkind (Expr1) = N_String_Literal
5219
               then
5220
                  if Nkind (Expr2) /= N_String_Literal then
5221
                     Check_Mismatch (True);
5222
                  else
5223
                     Check_Mismatch
5224
                       (not String_Equal (Strval (Expr1), Strval (Expr2)));
5225
                  end if;
5226
               end if;
5227
 
5228
            elsif Is_Entity_Name (Expr1) then
5229
               if Is_Entity_Name (Expr2) then
5230
                  if Entity (Expr1) = Entity (Expr2) then
5231
                     null;
5232
                  else
5233
                     Check_Mismatch
5234
                       (not Same_Instantiated_Constant
5235
                         (Entity (Expr1), Entity (Expr2)));
5236
                  end if;
5237
               else
5238
                  Check_Mismatch (True);
5239
               end if;
5240
 
5241
            elsif Is_Entity_Name (Original_Node (Expr1))
5242
              and then Is_Entity_Name (Expr2)
5243
            and then
5244
              Same_Instantiated_Constant
5245
                (Entity (Original_Node (Expr1)), Entity (Expr2))
5246
            then
5247
               null;
5248
 
5249
            elsif Nkind (Expr1) = N_Null then
5250
               Check_Mismatch (Nkind (Expr1) /= N_Null);
5251
 
5252
            else
5253
               Check_Mismatch (True);
5254
            end if;
5255
 
5256
         elsif Ekind (E1) = E_Variable then
5257
            Check_Mismatch (not Same_Instantiated_Variable (E1, E2));
5258
 
5259
         elsif Ekind (E1) = E_Package then
5260
            Check_Mismatch
5261
              (Ekind (E1) /= Ekind (E2)
5262
                or else Renamed_Object (E1) /= Renamed_Object (E2));
5263
 
5264
         elsif Is_Overloadable (E1) then
5265
 
5266
            --  Verify that the actual subprograms match. Note that actuals
5267
            --  that are attributes are rewritten as subprograms. If the
5268
            --  subprogram in the formal package is defaulted, no check is
5269
            --  needed. Note that this can only happen in Ada 2005 when the
5270
            --  formal package can be partially parameterized.
5271
 
5272
            if Nkind (Unit_Declaration_Node (E1)) =
5273
                                           N_Subprogram_Renaming_Declaration
5274
              and then From_Default (Unit_Declaration_Node (E1))
5275
            then
5276
               null;
5277
 
5278
            --  If the formal package has an "others"  box association that
5279
            --  covers this formal, there is no need for a check either.
5280
 
5281
            elsif Nkind (Unit_Declaration_Node (E2)) in
5282
                    N_Formal_Subprogram_Declaration
5283
              and then Box_Present (Unit_Declaration_Node (E2))
5284
            then
5285
               null;
5286
 
5287
            --  No check needed if subprogram is a defaulted null procedure
5288
 
5289
            elsif No (Alias (E2))
5290
              and then Ekind (E2) = E_Procedure
5291
              and then
5292
                Null_Present (Specification (Unit_Declaration_Node (E2)))
5293
            then
5294
               null;
5295
 
5296
            --  Otherwise the actual in the formal and the actual in the
5297
            --  instantiation of the formal must match, up to renamings.
5298
 
5299
            else
5300
               Check_Mismatch
5301
                 (Ekind (E2) /= Ekind (E1) or else (Alias (E1)) /= Alias (E2));
5302
            end if;
5303
 
5304
         else
5305
            raise Program_Error;
5306
         end if;
5307
 
5308
         <<Next_E>>
5309
            Next_Entity (E1);
5310
            Next_Entity (E2);
5311
      end loop;
5312
   end Check_Formal_Package_Instance;
5313
 
5314
   ---------------------------
5315
   -- Check_Formal_Packages --
5316
   ---------------------------
5317
 
5318
   procedure Check_Formal_Packages (P_Id : Entity_Id) is
5319
      E        : Entity_Id;
5320
      Formal_P : Entity_Id;
5321
 
5322
   begin
5323
      --  Iterate through the declarations in the instance, looking for package
5324
      --  renaming declarations that denote instances of formal packages. Stop
5325
      --  when we find the renaming of the current package itself. The
5326
      --  declaration for a formal package without a box is followed by an
5327
      --  internal entity that repeats the instantiation.
5328
 
5329
      E := First_Entity (P_Id);
5330
      while Present (E) loop
5331
         if Ekind (E) = E_Package then
5332
            if Renamed_Object (E) = P_Id then
5333
               exit;
5334
 
5335
            elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then
5336
               null;
5337
 
5338
            elsif not Box_Present (Parent (Associated_Formal_Package (E))) then
5339
               Formal_P := Next_Entity (E);
5340
               Check_Formal_Package_Instance (Formal_P, E);
5341
 
5342
               --  After checking, remove the internal validating package. It
5343
               --  is only needed for semantic checks, and as it may contain
5344
               --  generic formal declarations it should not reach gigi.
5345
 
5346
               Remove (Unit_Declaration_Node (Formal_P));
5347
            end if;
5348
         end if;
5349
 
5350
         Next_Entity (E);
5351
      end loop;
5352
   end Check_Formal_Packages;
5353
 
5354
   ---------------------------------
5355
   -- Check_Forward_Instantiation --
5356
   ---------------------------------
5357
 
5358
   procedure Check_Forward_Instantiation (Decl : Node_Id) is
5359
      S        : Entity_Id;
5360
      Gen_Comp : Entity_Id := Cunit_Entity (Get_Source_Unit (Decl));
5361
 
5362
   begin
5363
      --  The instantiation appears before the generic body if we are in the
5364
      --  scope of the unit containing the generic, either in its spec or in
5365
      --  the package body, and before the generic body.
5366
 
5367
      if Ekind (Gen_Comp) = E_Package_Body then
5368
         Gen_Comp := Spec_Entity (Gen_Comp);
5369
      end if;
5370
 
5371
      if In_Open_Scopes (Gen_Comp)
5372
        and then No (Corresponding_Body (Decl))
5373
      then
5374
         S := Current_Scope;
5375
 
5376
         while Present (S)
5377
           and then not Is_Compilation_Unit (S)
5378
           and then not Is_Child_Unit (S)
5379
         loop
5380
            if Ekind (S) = E_Package then
5381
               Set_Has_Forward_Instantiation (S);
5382
            end if;
5383
 
5384
            S := Scope (S);
5385
         end loop;
5386
      end if;
5387
   end Check_Forward_Instantiation;
5388
 
5389
   ---------------------------
5390
   -- Check_Generic_Actuals --
5391
   ---------------------------
5392
 
5393
   --  The visibility of the actuals may be different between the point of
5394
   --  generic instantiation and the instantiation of the body.
5395
 
5396
   procedure Check_Generic_Actuals
5397
     (Instance      : Entity_Id;
5398
      Is_Formal_Box : Boolean)
5399
   is
5400
      E      : Entity_Id;
5401
      Astype : Entity_Id;
5402
 
5403
      function Denotes_Previous_Actual (Typ : Entity_Id) return Boolean;
5404
      --  For a formal that is an array type, the component type is often a
5405
      --  previous formal in the same unit. The privacy status of the component
5406
      --  type will have been examined earlier in the traversal of the
5407
      --  corresponding actuals, and this status should not be modified for the
5408
      --  array type itself.
5409
      --
5410
      --  To detect this case we have to rescan the list of formals, which
5411
      --  is usually short enough to ignore the resulting inefficiency.
5412
 
5413
      -----------------------------
5414
      -- Denotes_Previous_Actual --
5415
      -----------------------------
5416
 
5417
      function Denotes_Previous_Actual (Typ : Entity_Id) return Boolean is
5418
         Prev : Entity_Id;
5419
 
5420
      begin
5421
         Prev := First_Entity (Instance);
5422
         while Present (Prev) loop
5423
            if Is_Type (Prev)
5424
              and then Nkind (Parent (Prev)) = N_Subtype_Declaration
5425
              and then Is_Entity_Name (Subtype_Indication (Parent (Prev)))
5426
              and then Entity (Subtype_Indication (Parent (Prev))) = Typ
5427
            then
5428
               return True;
5429
 
5430
            elsif Prev = E then
5431
               return False;
5432
 
5433
            else
5434
               Next_Entity (Prev);
5435
            end if;
5436
         end loop;
5437
 
5438
         return False;
5439
      end Denotes_Previous_Actual;
5440
 
5441
   --  Start of processing for Check_Generic_Actuals
5442
 
5443
   begin
5444
      E := First_Entity (Instance);
5445
      while Present (E) loop
5446
         if Is_Type (E)
5447
           and then Nkind (Parent (E)) = N_Subtype_Declaration
5448
           and then Scope (Etype (E)) /= Instance
5449
           and then Is_Entity_Name (Subtype_Indication (Parent (E)))
5450
         then
5451
            if Is_Array_Type (E)
5452
              and then Denotes_Previous_Actual (Component_Type (E))
5453
            then
5454
               null;
5455
            else
5456
               Check_Private_View (Subtype_Indication (Parent (E)));
5457
            end if;
5458
 
5459
            Set_Is_Generic_Actual_Type (E, True);
5460
            Set_Is_Hidden (E, False);
5461
            Set_Is_Potentially_Use_Visible (E,
5462
              In_Use (Instance));
5463
 
5464
            --  We constructed the generic actual type as a subtype of the
5465
            --  supplied type. This means that it normally would not inherit
5466
            --  subtype specific attributes of the actual, which is wrong for
5467
            --  the generic case.
5468
 
5469
            Astype := Ancestor_Subtype (E);
5470
 
5471
            if No (Astype) then
5472
 
5473
               --  This can happen when E is an itype that is the full view of
5474
               --  a private type completed, e.g. with a constrained array. In
5475
               --  that case, use the first subtype, which will carry size
5476
               --  information. The base type itself is unconstrained and will
5477
               --  not carry it.
5478
 
5479
               Astype := First_Subtype (E);
5480
            end if;
5481
 
5482
            Set_Size_Info      (E,                (Astype));
5483
            Set_RM_Size        (E, RM_Size        (Astype));
5484
            Set_First_Rep_Item (E, First_Rep_Item (Astype));
5485
 
5486
            if Is_Discrete_Or_Fixed_Point_Type (E) then
5487
               Set_RM_Size (E, RM_Size (Astype));
5488
 
5489
            --  In  nested instances, the base type of an access actual
5490
            --  may itself be private, and need to be exchanged.
5491
 
5492
            elsif Is_Access_Type (E)
5493
              and then Is_Private_Type (Etype (E))
5494
            then
5495
               Check_Private_View
5496
                 (New_Occurrence_Of (Etype (E), Sloc (Instance)));
5497
            end if;
5498
 
5499
         elsif Ekind (E) = E_Package then
5500
 
5501
            --  If this is the renaming for the current instance, we're done.
5502
            --  Otherwise it is a formal package. If the corresponding formal
5503
            --  was declared with a box, the (instantiations of the) generic
5504
            --  formal part are also visible. Otherwise, ignore the entity
5505
            --  created to validate the actuals.
5506
 
5507
            if Renamed_Object (E) = Instance then
5508
               exit;
5509
 
5510
            elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then
5511
               null;
5512
 
5513
            --  The visibility of a formal of an enclosing generic is already
5514
            --  correct.
5515
 
5516
            elsif Denotes_Formal_Package (E) then
5517
               null;
5518
 
5519
            elsif Present (Associated_Formal_Package (E))
5520
              and then not Is_Generic_Formal (E)
5521
            then
5522
               if Box_Present (Parent (Associated_Formal_Package (E))) then
5523
                  Check_Generic_Actuals (Renamed_Object (E), True);
5524
 
5525
               else
5526
                  Check_Generic_Actuals (Renamed_Object (E), False);
5527
               end if;
5528
 
5529
               Set_Is_Hidden (E, False);
5530
            end if;
5531
 
5532
         --  If this is a subprogram instance (in a wrapper package) the
5533
         --  actual is fully visible.
5534
 
5535
         elsif Is_Wrapper_Package (Instance) then
5536
            Set_Is_Hidden (E, False);
5537
 
5538
         --  If the formal package is declared with a box, or if the formal
5539
         --  parameter is defaulted, it is visible in the body.
5540
 
5541
         elsif Is_Formal_Box
5542
           or else Is_Visible_Formal (E)
5543
         then
5544
            Set_Is_Hidden (E, False);
5545
         end if;
5546
 
5547
         if Ekind (E) = E_Constant then
5548
 
5549
            --  If the type of the actual is a private type declared in the
5550
            --  enclosing scope of the generic unit, the body of the generic
5551
            --  sees the full view of the type (because it has to appear in
5552
            --  the corresponding package body). If the type is private now,
5553
            --  exchange views to restore the proper visiblity in the instance.
5554
 
5555
            declare
5556
               Typ : constant Entity_Id := Base_Type (Etype (E));
5557
               --  The type of the actual
5558
 
5559
               Gen_Id : Entity_Id;
5560
               --  The generic unit
5561
 
5562
               Parent_Scope : Entity_Id;
5563
               --  The enclosing scope of the generic unit
5564
 
5565
            begin
5566
               if Is_Wrapper_Package (Instance) then
5567
                  Gen_Id :=
5568
                     Generic_Parent
5569
                       (Specification
5570
                         (Unit_Declaration_Node
5571
                           (Related_Instance (Instance))));
5572
               else
5573
                  Gen_Id :=
5574
                    Generic_Parent
5575
                      (Specification (Unit_Declaration_Node (Instance)));
5576
               end if;
5577
 
5578
               Parent_Scope := Scope (Gen_Id);
5579
 
5580
               --  The exchange is only needed if the generic is defined
5581
               --  within a package which is not a common ancestor of the
5582
               --  scope of the instance, and is not already in scope.
5583
 
5584
               if Is_Private_Type (Typ)
5585
                 and then Scope (Typ) = Parent_Scope
5586
                 and then Scope (Instance) /= Parent_Scope
5587
                 and then Ekind (Parent_Scope) = E_Package
5588
                 and then not Is_Child_Unit (Gen_Id)
5589
               then
5590
                  Switch_View (Typ);
5591
 
5592
                  --  If the type of the entity is a subtype, it may also
5593
                  --  have to be made visible, together with the base type
5594
                  --  of its full view, after exchange.
5595
 
5596
                  if Is_Private_Type (Etype (E)) then
5597
                     Switch_View (Etype (E));
5598
                     Switch_View (Base_Type (Etype (E)));
5599
                  end if;
5600
               end if;
5601
            end;
5602
         end if;
5603
 
5604
         Next_Entity (E);
5605
      end loop;
5606
   end Check_Generic_Actuals;
5607
 
5608
   ------------------------------
5609
   -- Check_Generic_Child_Unit --
5610
   ------------------------------
5611
 
5612
   procedure Check_Generic_Child_Unit
5613
     (Gen_Id           : Node_Id;
5614
      Parent_Installed : in out Boolean)
5615
   is
5616
      Loc      : constant Source_Ptr := Sloc (Gen_Id);
5617
      Gen_Par  : Entity_Id := Empty;
5618
      E        : Entity_Id;
5619
      Inst_Par : Entity_Id;
5620
      S        : Node_Id;
5621
 
5622
      function Find_Generic_Child
5623
        (Scop : Entity_Id;
5624
         Id   : Node_Id) return Entity_Id;
5625
      --  Search generic parent for possible child unit with the given name
5626
 
5627
      function In_Enclosing_Instance return Boolean;
5628
      --  Within an instance of the parent, the child unit may be denoted
5629
      --  by a simple name, or an abbreviated expanded name. Examine enclosing
5630
      --  scopes to locate a possible parent instantiation.
5631
 
5632
      ------------------------
5633
      -- Find_Generic_Child --
5634
      ------------------------
5635
 
5636
      function Find_Generic_Child
5637
        (Scop : Entity_Id;
5638
         Id   : Node_Id) return Entity_Id
5639
      is
5640
         E : Entity_Id;
5641
 
5642
      begin
5643
         --  If entity of name is already set, instance has already been
5644
         --  resolved, e.g. in an enclosing instantiation.
5645
 
5646
         if Present (Entity (Id)) then
5647
            if Scope (Entity (Id)) = Scop then
5648
               return Entity (Id);
5649
            else
5650
               return Empty;
5651
            end if;
5652
 
5653
         else
5654
            E := First_Entity (Scop);
5655
            while Present (E) loop
5656
               if Chars (E) = Chars (Id)
5657
                 and then Is_Child_Unit (E)
5658
               then
5659
                  if Is_Child_Unit (E)
5660
                    and then not Is_Visible_Child_Unit (E)
5661
                  then
5662
                     Error_Msg_NE
5663
                       ("generic child unit& is not visible", Gen_Id, E);
5664
                  end if;
5665
 
5666
                  Set_Entity (Id, E);
5667
                  return E;
5668
               end if;
5669
 
5670
               Next_Entity (E);
5671
            end loop;
5672
 
5673
            return Empty;
5674
         end if;
5675
      end Find_Generic_Child;
5676
 
5677
      ---------------------------
5678
      -- In_Enclosing_Instance --
5679
      ---------------------------
5680
 
5681
      function In_Enclosing_Instance return Boolean is
5682
         Enclosing_Instance : Node_Id;
5683
         Instance_Decl      : Node_Id;
5684
 
5685
      begin
5686
         --  We do not inline any call that contains instantiations, except
5687
         --  for instantiations of Unchecked_Conversion, so if we are within
5688
         --  an inlined body the current instance does not require parents.
5689
 
5690
         if In_Inlined_Body then
5691
            pragma Assert (Chars (Gen_Id) = Name_Unchecked_Conversion);
5692
            return False;
5693
         end if;
5694
 
5695
         --  Loop to check enclosing scopes
5696
 
5697
         Enclosing_Instance := Current_Scope;
5698
         while Present (Enclosing_Instance) loop
5699
            Instance_Decl := Unit_Declaration_Node (Enclosing_Instance);
5700
 
5701
            if Ekind (Enclosing_Instance) = E_Package
5702
              and then Is_Generic_Instance (Enclosing_Instance)
5703
              and then Present
5704
                (Generic_Parent (Specification (Instance_Decl)))
5705
            then
5706
               --  Check whether the generic we are looking for is a child of
5707
               --  this instance.
5708
 
5709
               E := Find_Generic_Child
5710
                      (Generic_Parent (Specification (Instance_Decl)), Gen_Id);
5711
               exit when Present (E);
5712
 
5713
            else
5714
               E := Empty;
5715
            end if;
5716
 
5717
            Enclosing_Instance := Scope (Enclosing_Instance);
5718
         end loop;
5719
 
5720
         if No (E) then
5721
 
5722
            --  Not a child unit
5723
 
5724
            Analyze (Gen_Id);
5725
            return False;
5726
 
5727
         else
5728
            Rewrite (Gen_Id,
5729
              Make_Expanded_Name (Loc,
5730
                Chars         => Chars (E),
5731
                Prefix        => New_Occurrence_Of (Enclosing_Instance, Loc),
5732
                Selector_Name => New_Occurrence_Of (E, Loc)));
5733
 
5734
            Set_Entity (Gen_Id, E);
5735
            Set_Etype  (Gen_Id, Etype (E));
5736
            Parent_Installed := False;      -- Already in scope.
5737
            return True;
5738
         end if;
5739
      end In_Enclosing_Instance;
5740
 
5741
   --  Start of processing for Check_Generic_Child_Unit
5742
 
5743
   begin
5744
      --  If the name of the generic is given by a selected component, it may
5745
      --  be the name of a generic child unit, and the prefix is the name of an
5746
      --  instance of the parent, in which case the child unit must be visible.
5747
      --  If this instance is not in scope, it must be placed there and removed
5748
      --  after instantiation, because what is being instantiated is not the
5749
      --  original child, but the corresponding child present in the instance
5750
      --  of the parent.
5751
 
5752
      --  If the child is instantiated within the parent, it can be given by
5753
      --  a simple name. In this case the instance is already in scope, but
5754
      --  the child generic must be recovered from the generic parent as well.
5755
 
5756
      if Nkind (Gen_Id) = N_Selected_Component then
5757
         S := Selector_Name (Gen_Id);
5758
         Analyze (Prefix (Gen_Id));
5759
         Inst_Par := Entity (Prefix (Gen_Id));
5760
 
5761
         if Ekind (Inst_Par) = E_Package
5762
           and then Present (Renamed_Object (Inst_Par))
5763
         then
5764
            Inst_Par := Renamed_Object (Inst_Par);
5765
         end if;
5766
 
5767
         if Ekind (Inst_Par) = E_Package then
5768
            if Nkind (Parent (Inst_Par)) = N_Package_Specification then
5769
               Gen_Par := Generic_Parent (Parent (Inst_Par));
5770
 
5771
            elsif Nkind (Parent (Inst_Par)) = N_Defining_Program_Unit_Name
5772
              and then
5773
                Nkind (Parent (Parent (Inst_Par))) = N_Package_Specification
5774
            then
5775
               Gen_Par := Generic_Parent (Parent (Parent (Inst_Par)));
5776
            end if;
5777
 
5778
         elsif Ekind (Inst_Par) = E_Generic_Package
5779
           and then Nkind (Parent (Gen_Id)) = N_Formal_Package_Declaration
5780
         then
5781
            --  A formal package may be a real child package, and not the
5782
            --  implicit instance within a parent. In this case the child is
5783
            --  not visible and has to be retrieved explicitly as well.
5784
 
5785
            Gen_Par := Inst_Par;
5786
         end if;
5787
 
5788
         if Present (Gen_Par) then
5789
 
5790
            --  The prefix denotes an instantiation. The entity itself may be a
5791
            --  nested generic, or a child unit.
5792
 
5793
            E := Find_Generic_Child (Gen_Par, S);
5794
 
5795
            if Present (E) then
5796
               Change_Selected_Component_To_Expanded_Name (Gen_Id);
5797
               Set_Entity (Gen_Id, E);
5798
               Set_Etype (Gen_Id, Etype (E));
5799
               Set_Entity (S, E);
5800
               Set_Etype (S, Etype (E));
5801
 
5802
               --  Indicate that this is a reference to the parent
5803
 
5804
               if In_Extended_Main_Source_Unit (Gen_Id) then
5805
                  Set_Is_Instantiated (Inst_Par);
5806
               end if;
5807
 
5808
               --  A common mistake is to replicate the naming scheme of a
5809
               --  hierarchy by instantiating a generic child directly, rather
5810
               --  than the implicit child in a parent instance:
5811
 
5812
               --  generic .. package Gpar is ..
5813
               --  generic .. package Gpar.Child is ..
5814
               --  package Par is new Gpar ();
5815
 
5816
               --  with Gpar.Child;
5817
               --  package Par.Child is new Gpar.Child ();
5818
               --                           rather than Par.Child
5819
 
5820
               --  In this case the instantiation is within Par, which is an
5821
               --  instance, but Gpar does not denote Par because we are not IN
5822
               --  the instance of Gpar, so this is illegal. The test below
5823
               --  recognizes this particular case.
5824
 
5825
               if Is_Child_Unit (E)
5826
                 and then not Comes_From_Source (Entity (Prefix (Gen_Id)))
5827
                 and then (not In_Instance
5828
                             or else Nkind (Parent (Parent (Gen_Id))) =
5829
                                                         N_Compilation_Unit)
5830
               then
5831
                  Error_Msg_N
5832
                    ("prefix of generic child unit must be instance of parent",
5833
                      Gen_Id);
5834
               end if;
5835
 
5836
               if not In_Open_Scopes (Inst_Par)
5837
                 and then Nkind (Parent (Gen_Id)) not in
5838
                                           N_Generic_Renaming_Declaration
5839
               then
5840
                  Install_Parent (Inst_Par);
5841
                  Parent_Installed := True;
5842
 
5843
               elsif In_Open_Scopes (Inst_Par) then
5844
 
5845
                  --  If the parent is already installed, install the actuals
5846
                  --  for its formal packages. This is necessary when the
5847
                  --  child instance is a child of the parent instance:
5848
                  --  in this case, the parent is placed on the scope stack
5849
                  --  but the formal packages are not made visible.
5850
 
5851
                  Install_Formal_Packages (Inst_Par);
5852
               end if;
5853
 
5854
            else
5855
               --  If the generic parent does not contain an entity that
5856
               --  corresponds to the selector, the instance doesn't either.
5857
               --  Analyzing the node will yield the appropriate error message.
5858
               --  If the entity is not a child unit, then it is an inner
5859
               --  generic in the parent.
5860
 
5861
               Analyze (Gen_Id);
5862
            end if;
5863
 
5864
         else
5865
            Analyze (Gen_Id);
5866
 
5867
            if Is_Child_Unit (Entity (Gen_Id))
5868
              and then
5869
                Nkind (Parent (Gen_Id)) not in N_Generic_Renaming_Declaration
5870
              and then not In_Open_Scopes (Inst_Par)
5871
            then
5872
               Install_Parent (Inst_Par);
5873
               Parent_Installed := True;
5874
 
5875
            --  The generic unit may be the renaming of the implicit child
5876
            --  present in an instance. In that case the parent instance is
5877
            --  obtained from the name of the renamed entity.
5878
 
5879
            elsif Ekind (Entity (Gen_Id)) = E_Generic_Package
5880
              and then Present (Renamed_Entity (Entity (Gen_Id)))
5881
              and then Is_Child_Unit (Renamed_Entity (Entity (Gen_Id)))
5882
            then
5883
               declare
5884
                  Renamed_Package : constant Node_Id :=
5885
                                      Name (Parent (Entity (Gen_Id)));
5886
               begin
5887
                  if Nkind (Renamed_Package) = N_Expanded_Name then
5888
                     Inst_Par := Entity (Prefix (Renamed_Package));
5889
                     Install_Parent (Inst_Par);
5890
                     Parent_Installed := True;
5891
                  end if;
5892
               end;
5893
            end if;
5894
         end if;
5895
 
5896
      elsif Nkind (Gen_Id) = N_Expanded_Name then
5897
 
5898
         --  Entity already present, analyze prefix, whose meaning may be
5899
         --  an instance in the current context. If it is an instance of
5900
         --  a relative within another, the proper parent may still have
5901
         --  to be installed, if they are not of the same generation.
5902
 
5903
         Analyze (Prefix (Gen_Id));
5904
 
5905
         --  In the unlikely case that a local declaration hides the name
5906
         --  of the parent package, locate it on the homonym chain. If the
5907
         --  context is an instance of the parent, the renaming entity is
5908
         --  flagged as such.
5909
 
5910
         Inst_Par := Entity (Prefix (Gen_Id));
5911
         while Present (Inst_Par)
5912
           and then not Is_Package_Or_Generic_Package (Inst_Par)
5913
         loop
5914
            Inst_Par := Homonym (Inst_Par);
5915
         end loop;
5916
 
5917
         pragma Assert (Present (Inst_Par));
5918
         Set_Entity (Prefix (Gen_Id), Inst_Par);
5919
 
5920
         if In_Enclosing_Instance then
5921
            null;
5922
 
5923
         elsif Present (Entity (Gen_Id))
5924
           and then Is_Child_Unit (Entity (Gen_Id))
5925
           and then not In_Open_Scopes (Inst_Par)
5926
         then
5927
            Install_Parent (Inst_Par);
5928
            Parent_Installed := True;
5929
         end if;
5930
 
5931
      elsif In_Enclosing_Instance then
5932
 
5933
         --  The child unit is found in some enclosing scope
5934
 
5935
         null;
5936
 
5937
      else
5938
         Analyze (Gen_Id);
5939
 
5940
         --  If this is the renaming of the implicit child in a parent
5941
         --  instance, recover the parent name and install it.
5942
 
5943
         if Is_Entity_Name (Gen_Id) then
5944
            E := Entity (Gen_Id);
5945
 
5946
            if Is_Generic_Unit (E)
5947
              and then Nkind (Parent (E)) in N_Generic_Renaming_Declaration
5948
              and then Is_Child_Unit (Renamed_Object (E))
5949
              and then Is_Generic_Unit (Scope (Renamed_Object (E)))
5950
              and then Nkind (Name (Parent (E))) = N_Expanded_Name
5951
            then
5952
               Rewrite (Gen_Id,
5953
                 New_Copy_Tree (Name (Parent (E))));
5954
               Inst_Par := Entity (Prefix (Gen_Id));
5955
 
5956
               if not In_Open_Scopes (Inst_Par) then
5957
                  Install_Parent (Inst_Par);
5958
                  Parent_Installed := True;
5959
               end if;
5960
 
5961
            --  If it is a child unit of a non-generic parent, it may be
5962
            --  use-visible and given by a direct name. Install parent as
5963
            --  for other cases.
5964
 
5965
            elsif Is_Generic_Unit (E)
5966
              and then Is_Child_Unit (E)
5967
              and then
5968
                Nkind (Parent (Gen_Id)) not in N_Generic_Renaming_Declaration
5969
              and then not Is_Generic_Unit (Scope (E))
5970
            then
5971
               if not In_Open_Scopes (Scope (E)) then
5972
                  Install_Parent (Scope (E));
5973
                  Parent_Installed := True;
5974
               end if;
5975
            end if;
5976
         end if;
5977
      end if;
5978
   end Check_Generic_Child_Unit;
5979
 
5980
   -----------------------------
5981
   -- Check_Hidden_Child_Unit --
5982
   -----------------------------
5983
 
5984
   procedure Check_Hidden_Child_Unit
5985
     (N           : Node_Id;
5986
      Gen_Unit    : Entity_Id;
5987
      Act_Decl_Id : Entity_Id)
5988
   is
5989
      Gen_Id : constant Node_Id := Name (N);
5990
 
5991
   begin
5992
      if Is_Child_Unit (Gen_Unit)
5993
        and then Is_Child_Unit (Act_Decl_Id)
5994
        and then Nkind (Gen_Id) = N_Expanded_Name
5995
        and then Entity (Prefix (Gen_Id)) = Scope (Act_Decl_Id)
5996
        and then Chars (Gen_Unit) = Chars (Act_Decl_Id)
5997
      then
5998
         Error_Msg_Node_2 := Scope (Act_Decl_Id);
5999
         Error_Msg_NE
6000
           ("generic unit & is implicitly declared in &",
6001
             Defining_Unit_Name (N), Gen_Unit);
6002
         Error_Msg_N ("\instance must have different name",
6003
           Defining_Unit_Name (N));
6004
      end if;
6005
   end Check_Hidden_Child_Unit;
6006
 
6007
   ------------------------
6008
   -- Check_Private_View --
6009
   ------------------------
6010
 
6011
   procedure Check_Private_View (N : Node_Id) is
6012
      T : constant Entity_Id := Etype (N);
6013
      BT : Entity_Id;
6014
 
6015
   begin
6016
      --  Exchange views if the type was not private in the generic but is
6017
      --  private at the point of instantiation. Do not exchange views if
6018
      --  the scope of the type is in scope. This can happen if both generic
6019
      --  and instance are sibling units, or if type is defined in a parent.
6020
      --  In this case the visibility of the type will be correct for all
6021
      --  semantic checks.
6022
 
6023
      if Present (T) then
6024
         BT := Base_Type (T);
6025
 
6026
         if Is_Private_Type (T)
6027
           and then not Has_Private_View (N)
6028
           and then Present (Full_View (T))
6029
           and then not In_Open_Scopes (Scope (T))
6030
         then
6031
            --  In the generic, the full type was visible. Save the private
6032
            --  entity, for subsequent exchange.
6033
 
6034
            Switch_View (T);
6035
 
6036
         elsif Has_Private_View (N)
6037
           and then not Is_Private_Type (T)
6038
           and then not Has_Been_Exchanged (T)
6039
           and then Etype (Get_Associated_Node (N)) /= T
6040
         then
6041
            --  Only the private declaration was visible in the generic. If
6042
            --  the type appears in a subtype declaration, the subtype in the
6043
            --  instance must have a view compatible with that of its parent,
6044
            --  which must be exchanged (see corresponding code in Restore_
6045
            --  Private_Views). Otherwise, if the type is defined in a parent
6046
            --  unit, leave full visibility within instance, which is safe.
6047
 
6048
            if In_Open_Scopes (Scope (Base_Type (T)))
6049
              and then not Is_Private_Type (Base_Type (T))
6050
              and then Comes_From_Source (Base_Type (T))
6051
            then
6052
               null;
6053
 
6054
            elsif Nkind (Parent (N)) = N_Subtype_Declaration
6055
              or else not In_Private_Part (Scope (Base_Type (T)))
6056
            then
6057
               Prepend_Elmt (T, Exchanged_Views);
6058
               Exchange_Declarations (Etype (Get_Associated_Node (N)));
6059
            end if;
6060
 
6061
         --  For composite types with inconsistent representation exchange
6062
         --  component types accordingly.
6063
 
6064
         elsif Is_Access_Type (T)
6065
           and then Is_Private_Type (Designated_Type (T))
6066
           and then not Has_Private_View (N)
6067
           and then Present (Full_View (Designated_Type (T)))
6068
         then
6069
            Switch_View (Designated_Type (T));
6070
 
6071
         elsif Is_Array_Type (T) then
6072
            if Is_Private_Type (Component_Type (T))
6073
              and then not Has_Private_View (N)
6074
              and then Present (Full_View (Component_Type (T)))
6075
            then
6076
               Switch_View (Component_Type (T));
6077
            end if;
6078
 
6079
            --  The normal exchange mechanism relies on the setting of a
6080
            --  flag on the reference in the generic. However, an additional
6081
            --  mechanism is needed for types that are not explicitly mentioned
6082
            --  in the generic, but may be needed in expanded code in the
6083
            --  instance. This includes component types of arrays and
6084
            --  designated types of access types. This processing must also
6085
            --  include the index types of arrays which we take care of here.
6086
 
6087
            declare
6088
               Indx : Node_Id;
6089
               Typ  : Entity_Id;
6090
 
6091
            begin
6092
               Indx := First_Index (T);
6093
               Typ  := Base_Type (Etype (Indx));
6094
               while Present (Indx) loop
6095
                  if Is_Private_Type (Typ)
6096
                    and then Present (Full_View (Typ))
6097
                  then
6098
                     Switch_View (Typ);
6099
                  end if;
6100
 
6101
                  Next_Index (Indx);
6102
               end loop;
6103
            end;
6104
 
6105
         elsif Is_Private_Type (T)
6106
           and then Present (Full_View (T))
6107
           and then Is_Array_Type (Full_View (T))
6108
           and then Is_Private_Type (Component_Type (Full_View (T)))
6109
         then
6110
            Switch_View (T);
6111
 
6112
         --  Finally, a non-private subtype may have a private base type, which
6113
         --  must be exchanged for consistency. This can happen when a package
6114
         --  body is instantiated, when the scope stack is empty but in fact
6115
         --  the subtype and the base type are declared in an enclosing scope.
6116
 
6117
         --  Note that in this case we introduce an inconsistency in the view
6118
         --  set, because we switch the base type BT, but there could be some
6119
         --  private dependent subtypes of BT which remain unswitched. Such
6120
         --  subtypes might need to be switched at a later point (see specific
6121
         --  provision for that case in Switch_View).
6122
 
6123
         elsif not Is_Private_Type (T)
6124
           and then not Has_Private_View (N)
6125
           and then Is_Private_Type (BT)
6126
           and then Present (Full_View (BT))
6127
           and then not Is_Generic_Type (BT)
6128
           and then not In_Open_Scopes (BT)
6129
         then
6130
            Prepend_Elmt (Full_View (BT), Exchanged_Views);
6131
            Exchange_Declarations (BT);
6132
         end if;
6133
      end if;
6134
   end Check_Private_View;
6135
 
6136
   -----------------------------
6137
   -- Check_Hidden_Primitives --
6138
   -----------------------------
6139
 
6140
   function Check_Hidden_Primitives (Assoc_List : List_Id) return Elist_Id is
6141
      Actual : Node_Id;
6142
      Gen_T  : Entity_Id;
6143
      Result : Elist_Id := No_Elist;
6144
 
6145
   begin
6146
      if No (Assoc_List) then
6147
         return No_Elist;
6148
      end if;
6149
 
6150
      --  Traverse the list of associations between formals and actuals
6151
      --  searching for renamings of tagged types
6152
 
6153
      Actual := First (Assoc_List);
6154
      while Present (Actual) loop
6155
         if Nkind (Actual) = N_Subtype_Declaration then
6156
            Gen_T := Generic_Parent_Type (Actual);
6157
 
6158
            if Present (Gen_T)
6159
              and then Is_Tagged_Type (Gen_T)
6160
            then
6161
               --  Traverse the list of primitives of the actual types
6162
               --  searching for hidden primitives that are visible in the
6163
               --  corresponding generic formal; leave them visible and
6164
               --  append them to Result to restore their decoration later.
6165
 
6166
               Install_Hidden_Primitives
6167
                 (Prims_List => Result,
6168
                  Gen_T      => Gen_T,
6169
                  Act_T      => Entity (Subtype_Indication (Actual)));
6170
            end if;
6171
         end if;
6172
 
6173
         Next (Actual);
6174
      end loop;
6175
 
6176
      return Result;
6177
   end Check_Hidden_Primitives;
6178
 
6179
   --------------------------
6180
   -- Contains_Instance_Of --
6181
   --------------------------
6182
 
6183
   function Contains_Instance_Of
6184
     (Inner : Entity_Id;
6185
      Outer : Entity_Id;
6186
      N     : Node_Id) return Boolean
6187
   is
6188
      Elmt : Elmt_Id;
6189
      Scop : Entity_Id;
6190
 
6191
   begin
6192
      Scop := Outer;
6193
 
6194
      --  Verify that there are no circular instantiations. We check whether
6195
      --  the unit contains an instance of the current scope or some enclosing
6196
      --  scope (in case one of the instances appears in a subunit). Longer
6197
      --  circularities involving subunits might seem too pathological to
6198
      --  consider, but they were not too pathological for the authors of
6199
      --  DEC bc30vsq, so we loop over all enclosing scopes, and mark all
6200
      --  enclosing generic scopes as containing an instance.
6201
 
6202
      loop
6203
         --  Within a generic subprogram body, the scope is not generic, to
6204
         --  allow for recursive subprograms. Use the declaration to determine
6205
         --  whether this is a generic unit.
6206
 
6207
         if Ekind (Scop) = E_Generic_Package
6208
           or else (Is_Subprogram (Scop)
6209
                      and then Nkind (Unit_Declaration_Node (Scop)) =
6210
                                        N_Generic_Subprogram_Declaration)
6211
         then
6212
            Elmt := First_Elmt (Inner_Instances (Inner));
6213
 
6214
            while Present (Elmt) loop
6215
               if Node (Elmt) = Scop then
6216
                  Error_Msg_Node_2 := Inner;
6217
                  Error_Msg_NE
6218
                    ("circular Instantiation: & instantiated within &!",
6219
                       N, Scop);
6220
                  return True;
6221
 
6222
               elsif Node (Elmt) = Inner then
6223
                  return True;
6224
 
6225
               elsif Contains_Instance_Of (Node (Elmt), Scop, N) then
6226
                  Error_Msg_Node_2 := Inner;
6227
                  Error_Msg_NE
6228
                    ("circular Instantiation: & instantiated within &!",
6229
                      N, Node (Elmt));
6230
                  return True;
6231
               end if;
6232
 
6233
               Next_Elmt (Elmt);
6234
            end loop;
6235
 
6236
            --  Indicate that Inner is being instantiated within Scop
6237
 
6238
            Append_Elmt (Inner, Inner_Instances (Scop));
6239
         end if;
6240
 
6241
         if Scop = Standard_Standard then
6242
            exit;
6243
         else
6244
            Scop := Scope (Scop);
6245
         end if;
6246
      end loop;
6247
 
6248
      return False;
6249
   end Contains_Instance_Of;
6250
 
6251
   -----------------------
6252
   -- Copy_Generic_Node --
6253
   -----------------------
6254
 
6255
   function Copy_Generic_Node
6256
     (N             : Node_Id;
6257
      Parent_Id     : Node_Id;
6258
      Instantiating : Boolean) return Node_Id
6259
   is
6260
      Ent   : Entity_Id;
6261
      New_N : Node_Id;
6262
 
6263
      function Copy_Generic_Descendant (D : Union_Id) return Union_Id;
6264
      --  Check the given value of one of the Fields referenced by the
6265
      --  current node to determine whether to copy it recursively. The
6266
      --  field may hold a Node_Id, a List_Id, or an Elist_Id, or a plain
6267
      --  value (Sloc, Uint, Char) in which case it need not be copied.
6268
 
6269
      procedure Copy_Descendants;
6270
      --  Common utility for various nodes
6271
 
6272
      function Copy_Generic_Elist (E : Elist_Id) return Elist_Id;
6273
      --  Make copy of element list
6274
 
6275
      function Copy_Generic_List
6276
        (L         : List_Id;
6277
         Parent_Id : Node_Id) return List_Id;
6278
      --  Apply Copy_Node recursively to the members of a node list
6279
 
6280
      function In_Defining_Unit_Name (Nam : Node_Id) return Boolean;
6281
      --  True if an identifier is part of the defining program unit name
6282
      --  of a child unit. The entity of such an identifier must be kept
6283
      --  (for ASIS use) even though as the name of an enclosing generic
6284
      --   it would otherwise not be preserved in the generic tree.
6285
 
6286
      ----------------------
6287
      -- Copy_Descendants --
6288
      ----------------------
6289
 
6290
      procedure Copy_Descendants is
6291
 
6292
         use Atree.Unchecked_Access;
6293
         --  This code section is part of the implementation of an untyped
6294
         --  tree traversal, so it needs direct access to node fields.
6295
 
6296
      begin
6297
         Set_Field1 (New_N, Copy_Generic_Descendant (Field1 (N)));
6298
         Set_Field2 (New_N, Copy_Generic_Descendant (Field2 (N)));
6299
         Set_Field3 (New_N, Copy_Generic_Descendant (Field3 (N)));
6300
         Set_Field4 (New_N, Copy_Generic_Descendant (Field4 (N)));
6301
         Set_Field5 (New_N, Copy_Generic_Descendant (Field5 (N)));
6302
      end Copy_Descendants;
6303
 
6304
      -----------------------------
6305
      -- Copy_Generic_Descendant --
6306
      -----------------------------
6307
 
6308
      function Copy_Generic_Descendant (D : Union_Id) return Union_Id is
6309
      begin
6310
         if D = Union_Id (Empty) then
6311
            return D;
6312
 
6313
         elsif D in Node_Range then
6314
            return Union_Id
6315
              (Copy_Generic_Node (Node_Id (D), New_N, Instantiating));
6316
 
6317
         elsif D in List_Range then
6318
            return Union_Id (Copy_Generic_List (List_Id (D), New_N));
6319
 
6320
         elsif D in Elist_Range then
6321
            return Union_Id (Copy_Generic_Elist (Elist_Id (D)));
6322
 
6323
         --  Nothing else is copyable (e.g. Uint values), return as is
6324
 
6325
         else
6326
            return D;
6327
         end if;
6328
      end Copy_Generic_Descendant;
6329
 
6330
      ------------------------
6331
      -- Copy_Generic_Elist --
6332
      ------------------------
6333
 
6334
      function Copy_Generic_Elist (E : Elist_Id) return Elist_Id is
6335
         M : Elmt_Id;
6336
         L : Elist_Id;
6337
 
6338
      begin
6339
         if Present (E) then
6340
            L := New_Elmt_List;
6341
            M := First_Elmt (E);
6342
            while Present (M) loop
6343
               Append_Elmt
6344
                 (Copy_Generic_Node (Node (M), Empty, Instantiating), L);
6345
               Next_Elmt (M);
6346
            end loop;
6347
 
6348
            return L;
6349
 
6350
         else
6351
            return No_Elist;
6352
         end if;
6353
      end Copy_Generic_Elist;
6354
 
6355
      -----------------------
6356
      -- Copy_Generic_List --
6357
      -----------------------
6358
 
6359
      function Copy_Generic_List
6360
        (L         : List_Id;
6361
         Parent_Id : Node_Id) return List_Id
6362
      is
6363
         N     : Node_Id;
6364
         New_L : List_Id;
6365
 
6366
      begin
6367
         if Present (L) then
6368
            New_L := New_List;
6369
            Set_Parent (New_L, Parent_Id);
6370
 
6371
            N := First (L);
6372
            while Present (N) loop
6373
               Append (Copy_Generic_Node (N, Empty, Instantiating), New_L);
6374
               Next (N);
6375
            end loop;
6376
 
6377
            return New_L;
6378
 
6379
         else
6380
            return No_List;
6381
         end if;
6382
      end Copy_Generic_List;
6383
 
6384
      ---------------------------
6385
      -- In_Defining_Unit_Name --
6386
      ---------------------------
6387
 
6388
      function In_Defining_Unit_Name (Nam : Node_Id) return Boolean is
6389
      begin
6390
         return Present (Parent (Nam))
6391
           and then (Nkind (Parent (Nam)) = N_Defining_Program_Unit_Name
6392
                      or else
6393
                        (Nkind (Parent (Nam)) = N_Expanded_Name
6394
                          and then In_Defining_Unit_Name (Parent (Nam))));
6395
      end In_Defining_Unit_Name;
6396
 
6397
   --  Start of processing for Copy_Generic_Node
6398
 
6399
   begin
6400
      if N = Empty then
6401
         return N;
6402
      end if;
6403
 
6404
      New_N := New_Copy (N);
6405
 
6406
      --  Copy aspects if present
6407
 
6408
      if Has_Aspects (N) then
6409
         Set_Has_Aspects (New_N, False);
6410
         Set_Aspect_Specifications
6411
           (New_N, Copy_Generic_List (Aspect_Specifications (N), Parent_Id));
6412
      end if;
6413
 
6414
      if Instantiating then
6415
         Adjust_Instantiation_Sloc (New_N, S_Adjustment);
6416
      end if;
6417
 
6418
      if not Is_List_Member (N) then
6419
         Set_Parent (New_N, Parent_Id);
6420
      end if;
6421
 
6422
      --  If defining identifier, then all fields have been copied already
6423
 
6424
      if Nkind (New_N) in N_Entity then
6425
         null;
6426
 
6427
      --  Special casing for identifiers and other entity names and operators
6428
 
6429
      elsif Nkind_In (New_N, N_Identifier,
6430
                             N_Character_Literal,
6431
                             N_Expanded_Name,
6432
                             N_Operator_Symbol)
6433
        or else Nkind (New_N) in N_Op
6434
      then
6435
         if not Instantiating then
6436
 
6437
            --  Link both nodes in order to assign subsequently the entity of
6438
            --  the copy to the original node, in case this is a global
6439
            --  reference.
6440
 
6441
            Set_Associated_Node (N, New_N);
6442
 
6443
            --  If we are within an instantiation, this is a nested generic
6444
            --  that has already been analyzed at the point of definition. We
6445
            --  must preserve references that were global to the enclosing
6446
            --  parent at that point. Other occurrences, whether global or
6447
            --  local to the current generic, must be resolved anew, so we
6448
            --  reset the entity in the generic copy. A global reference has a
6449
            --  smaller depth than the parent, or else the same depth in case
6450
            --  both are distinct compilation units.
6451
            --  A child unit is implicitly declared within the enclosing parent
6452
            --  but is in fact global to it, and must be preserved.
6453
 
6454
            --  It is also possible for Current_Instantiated_Parent to be
6455
            --  defined, and for this not to be a nested generic, namely if the
6456
            --  unit is loaded through Rtsfind. In that case, the entity of
6457
            --  New_N is only a link to the associated node, and not a defining
6458
            --  occurrence.
6459
 
6460
            --  The entities for parent units in the defining_program_unit of a
6461
            --  generic child unit are established when the context of the unit
6462
            --  is first analyzed, before the generic copy is made. They are
6463
            --  preserved in the copy for use in ASIS queries.
6464
 
6465
            Ent := Entity (New_N);
6466
 
6467
            if No (Current_Instantiated_Parent.Gen_Id) then
6468
               if No (Ent)
6469
                 or else Nkind (Ent) /= N_Defining_Identifier
6470
                 or else not In_Defining_Unit_Name (N)
6471
               then
6472
                  Set_Associated_Node (New_N, Empty);
6473
               end if;
6474
 
6475
            elsif No (Ent)
6476
              or else
6477
                not Nkind_In (Ent, N_Defining_Identifier,
6478
                                   N_Defining_Character_Literal,
6479
                                   N_Defining_Operator_Symbol)
6480
              or else No (Scope (Ent))
6481
              or else
6482
                (Scope (Ent) = Current_Instantiated_Parent.Gen_Id
6483
                  and then not Is_Child_Unit (Ent))
6484
              or else
6485
                (Scope_Depth (Scope (Ent)) >
6486
                             Scope_Depth (Current_Instantiated_Parent.Gen_Id)
6487
                  and then
6488
                    Get_Source_Unit (Ent) =
6489
                    Get_Source_Unit (Current_Instantiated_Parent.Gen_Id))
6490
            then
6491
               Set_Associated_Node (New_N, Empty);
6492
            end if;
6493
 
6494
         --  Case of instantiating identifier or some other name or operator
6495
 
6496
         else
6497
            --  If the associated node is still defined, the entity in it is
6498
            --  global, and must be copied to the instance. If this copy is
6499
            --  being made for a body to inline, it is applied to an
6500
            --  instantiated tree, and the entity is already present and must
6501
            --  be also preserved.
6502
 
6503
            declare
6504
               Assoc : constant Node_Id := Get_Associated_Node (N);
6505
 
6506
            begin
6507
               if Present (Assoc) then
6508
                  if Nkind (Assoc) = Nkind (N) then
6509
                     Set_Entity (New_N, Entity (Assoc));
6510
                     Check_Private_View (N);
6511
 
6512
                  elsif Nkind (Assoc) = N_Function_Call then
6513
                     Set_Entity (New_N, Entity (Name (Assoc)));
6514
 
6515
                  elsif Nkind_In (Assoc, N_Defining_Identifier,
6516
                                         N_Defining_Character_Literal,
6517
                                         N_Defining_Operator_Symbol)
6518
                    and then Expander_Active
6519
                  then
6520
                     --  Inlining case: we are copying a tree that contains
6521
                     --  global entities, which are preserved in the copy to be
6522
                     --  used for subsequent inlining.
6523
 
6524
                     null;
6525
 
6526
                  else
6527
                     Set_Entity (New_N, Empty);
6528
                  end if;
6529
               end if;
6530
            end;
6531
         end if;
6532
 
6533
         --  For expanded name, we must copy the Prefix and Selector_Name
6534
 
6535
         if Nkind (N) = N_Expanded_Name then
6536
            Set_Prefix
6537
              (New_N, Copy_Generic_Node (Prefix (N), New_N, Instantiating));
6538
 
6539
            Set_Selector_Name (New_N,
6540
              Copy_Generic_Node (Selector_Name (N), New_N, Instantiating));
6541
 
6542
         --  For operators, we must copy the right operand
6543
 
6544
         elsif Nkind (N) in N_Op then
6545
            Set_Right_Opnd (New_N,
6546
              Copy_Generic_Node (Right_Opnd (N), New_N, Instantiating));
6547
 
6548
            --  And for binary operators, the left operand as well
6549
 
6550
            if Nkind (N) in N_Binary_Op then
6551
               Set_Left_Opnd (New_N,
6552
                 Copy_Generic_Node (Left_Opnd (N), New_N, Instantiating));
6553
            end if;
6554
         end if;
6555
 
6556
      --  Special casing for stubs
6557
 
6558
      elsif Nkind (N) in N_Body_Stub then
6559
 
6560
         --  In any case, we must copy the specification or defining
6561
         --  identifier as appropriate.
6562
 
6563
         if Nkind (N) = N_Subprogram_Body_Stub then
6564
            Set_Specification (New_N,
6565
              Copy_Generic_Node (Specification (N), New_N, Instantiating));
6566
 
6567
         else
6568
            Set_Defining_Identifier (New_N,
6569
              Copy_Generic_Node
6570
                (Defining_Identifier (N), New_N, Instantiating));
6571
         end if;
6572
 
6573
         --  If we are not instantiating, then this is where we load and
6574
         --  analyze subunits, i.e. at the point where the stub occurs. A
6575
         --  more permissive system might defer this analysis to the point
6576
         --  of instantiation, but this seems to complicated for now.
6577
 
6578
         if not Instantiating then
6579
            declare
6580
               Subunit_Name : constant Unit_Name_Type := Get_Unit_Name (N);
6581
               Subunit      : Node_Id;
6582
               Unum         : Unit_Number_Type;
6583
               New_Body     : Node_Id;
6584
 
6585
            begin
6586
               --  Make sure that, if it is a subunit of the main unit that is
6587
               --  preprocessed and if -gnateG is specified, the preprocessed
6588
               --  file will be written.
6589
 
6590
               Lib.Analysing_Subunit_Of_Main :=
6591
                 Lib.In_Extended_Main_Source_Unit (N);
6592
               Unum :=
6593
                 Load_Unit
6594
                   (Load_Name  => Subunit_Name,
6595
                    Required   => False,
6596
                    Subunit    => True,
6597
                    Error_Node => N);
6598
               Lib.Analysing_Subunit_Of_Main := False;
6599
 
6600
               --  If the proper body is not found, a warning message will be
6601
               --  emitted when analyzing the stub, or later at the point
6602
               --  of instantiation. Here we just leave the stub as is.
6603
 
6604
               if Unum = No_Unit then
6605
                  Subunits_Missing := True;
6606
                  goto Subunit_Not_Found;
6607
               end if;
6608
 
6609
               Subunit := Cunit (Unum);
6610
 
6611
               if Nkind (Unit (Subunit)) /= N_Subunit then
6612
                  Error_Msg_N
6613
                    ("found child unit instead of expected SEPARATE subunit",
6614
                     Subunit);
6615
                  Error_Msg_Sloc := Sloc (N);
6616
                  Error_Msg_N ("\to complete stub #", Subunit);
6617
                  goto Subunit_Not_Found;
6618
               end if;
6619
 
6620
               --  We must create a generic copy of the subunit, in order to
6621
               --  perform semantic analysis on it, and we must replace the
6622
               --  stub in the original generic unit with the subunit, in order
6623
               --  to preserve non-local references within.
6624
 
6625
               --  Only the proper body needs to be copied. Library_Unit and
6626
               --  context clause are simply inherited by the generic copy.
6627
               --  Note that the copy (which may be recursive if there are
6628
               --  nested subunits) must be done first, before attaching it to
6629
               --  the enclosing generic.
6630
 
6631
               New_Body :=
6632
                 Copy_Generic_Node
6633
                   (Proper_Body (Unit (Subunit)),
6634
                    Empty, Instantiating => False);
6635
 
6636
               --  Now place the original proper body in the original generic
6637
               --  unit. This is a body, not a compilation unit.
6638
 
6639
               Rewrite (N, Proper_Body (Unit (Subunit)));
6640
               Set_Is_Compilation_Unit (Defining_Entity (N), False);
6641
               Set_Was_Originally_Stub (N);
6642
 
6643
               --  Finally replace the body of the subunit with its copy, and
6644
               --  make this new subunit into the library unit of the generic
6645
               --  copy, which does not have stubs any longer.
6646
 
6647
               Set_Proper_Body (Unit (Subunit), New_Body);
6648
               Set_Library_Unit (New_N, Subunit);
6649
               Inherit_Context (Unit (Subunit), N);
6650
            end;
6651
 
6652
         --  If we are instantiating, this must be an error case, since
6653
         --  otherwise we would have replaced the stub node by the proper body
6654
         --  that corresponds. So just ignore it in the copy (i.e. we have
6655
         --  copied it, and that is good enough).
6656
 
6657
         else
6658
            null;
6659
         end if;
6660
 
6661
         <<Subunit_Not_Found>> null;
6662
 
6663
      --  If the node is a compilation unit, it is the subunit of a stub, which
6664
      --  has been loaded already (see code below). In this case, the library
6665
      --  unit field of N points to the parent unit (which is a compilation
6666
      --  unit) and need not (and cannot!) be copied.
6667
 
6668
      --  When the proper body of the stub is analyzed, the library_unit link
6669
      --  is used to establish the proper context (see sem_ch10).
6670
 
6671
      --  The other fields of a compilation unit are copied as usual
6672
 
6673
      elsif Nkind (N) = N_Compilation_Unit then
6674
 
6675
         --  This code can only be executed when not instantiating, because in
6676
         --  the copy made for an instantiation, the compilation unit node has
6677
         --  disappeared at the point that a stub is replaced by its proper
6678
         --  body.
6679
 
6680
         pragma Assert (not Instantiating);
6681
 
6682
         Set_Context_Items (New_N,
6683
           Copy_Generic_List (Context_Items (N), New_N));
6684
 
6685
         Set_Unit (New_N,
6686
           Copy_Generic_Node (Unit (N), New_N, False));
6687
 
6688
         Set_First_Inlined_Subprogram (New_N,
6689
           Copy_Generic_Node
6690
             (First_Inlined_Subprogram (N), New_N, False));
6691
 
6692
         Set_Aux_Decls_Node (New_N,
6693
           Copy_Generic_Node (Aux_Decls_Node (N), New_N, False));
6694
 
6695
      --  For an assignment node, the assignment is known to be semantically
6696
      --  legal if we are instantiating the template. This avoids incorrect
6697
      --  diagnostics in generated code.
6698
 
6699
      elsif Nkind (N) = N_Assignment_Statement then
6700
 
6701
         --  Copy name and expression fields in usual manner
6702
 
6703
         Set_Name (New_N,
6704
           Copy_Generic_Node (Name (N), New_N, Instantiating));
6705
 
6706
         Set_Expression (New_N,
6707
           Copy_Generic_Node (Expression (N), New_N, Instantiating));
6708
 
6709
         if Instantiating then
6710
            Set_Assignment_OK (Name (New_N), True);
6711
         end if;
6712
 
6713
      elsif Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then
6714
         if not Instantiating then
6715
            Set_Associated_Node (N, New_N);
6716
 
6717
         else
6718
            if Present (Get_Associated_Node (N))
6719
              and then Nkind (Get_Associated_Node (N)) = Nkind (N)
6720
            then
6721
               --  In the generic the aggregate has some composite type. If at
6722
               --  the point of instantiation the type has a private view,
6723
               --  install the full view (and that of its ancestors, if any).
6724
 
6725
               declare
6726
                  T   : Entity_Id := (Etype (Get_Associated_Node (New_N)));
6727
                  Rt  : Entity_Id;
6728
 
6729
               begin
6730
                  if Present (T)
6731
                    and then Is_Private_Type (T)
6732
                  then
6733
                     Switch_View (T);
6734
                  end if;
6735
 
6736
                  if Present (T)
6737
                    and then Is_Tagged_Type (T)
6738
                    and then Is_Derived_Type (T)
6739
                  then
6740
                     Rt := Root_Type (T);
6741
 
6742
                     loop
6743
                        T := Etype (T);
6744
 
6745
                        if Is_Private_Type (T) then
6746
                           Switch_View (T);
6747
                        end if;
6748
 
6749
                        exit when T = Rt;
6750
                     end loop;
6751
                  end if;
6752
               end;
6753
            end if;
6754
         end if;
6755
 
6756
         --  Do not copy the associated node, which points to the generic copy
6757
         --  of the aggregate.
6758
 
6759
         declare
6760
            use Atree.Unchecked_Access;
6761
            --  This code section is part of the implementation of an untyped
6762
            --  tree traversal, so it needs direct access to node fields.
6763
 
6764
         begin
6765
            Set_Field1 (New_N, Copy_Generic_Descendant (Field1 (N)));
6766
            Set_Field2 (New_N, Copy_Generic_Descendant (Field2 (N)));
6767
            Set_Field3 (New_N, Copy_Generic_Descendant (Field3 (N)));
6768
            Set_Field5 (New_N, Copy_Generic_Descendant (Field5 (N)));
6769
         end;
6770
 
6771
      --  Allocators do not have an identifier denoting the access type, so we
6772
      --  must locate it through the expression to check whether the views are
6773
      --  consistent.
6774
 
6775
      elsif Nkind (N) = N_Allocator
6776
        and then Nkind (Expression (N)) = N_Qualified_Expression
6777
        and then Is_Entity_Name (Subtype_Mark (Expression (N)))
6778
        and then Instantiating
6779
      then
6780
         declare
6781
            T     : constant Node_Id :=
6782
                      Get_Associated_Node (Subtype_Mark (Expression (N)));
6783
            Acc_T : Entity_Id;
6784
 
6785
         begin
6786
            if Present (T) then
6787
 
6788
               --  Retrieve the allocator node in the generic copy
6789
 
6790
               Acc_T := Etype (Parent (Parent (T)));
6791
               if Present (Acc_T)
6792
                 and then Is_Private_Type (Acc_T)
6793
               then
6794
                  Switch_View (Acc_T);
6795
               end if;
6796
            end if;
6797
 
6798
            Copy_Descendants;
6799
         end;
6800
 
6801
      --  For a proper body, we must catch the case of a proper body that
6802
      --  replaces a stub. This represents the point at which a separate
6803
      --  compilation unit, and hence template file, may be referenced, so we
6804
      --  must make a new source instantiation entry for the template of the
6805
      --  subunit, and ensure that all nodes in the subunit are adjusted using
6806
      --  this new source instantiation entry.
6807
 
6808
      elsif Nkind (N) in N_Proper_Body then
6809
         declare
6810
            Save_Adjustment : constant Sloc_Adjustment := S_Adjustment;
6811
 
6812
         begin
6813
            if Instantiating and then Was_Originally_Stub (N) then
6814
               Create_Instantiation_Source
6815
                 (Instantiation_Node,
6816
                  Defining_Entity (N),
6817
                  False,
6818
                  S_Adjustment);
6819
            end if;
6820
 
6821
            --  Now copy the fields of the proper body, using the new
6822
            --  adjustment factor if one was needed as per test above.
6823
 
6824
            Copy_Descendants;
6825
 
6826
            --  Restore the original adjustment factor in case changed
6827
 
6828
            S_Adjustment := Save_Adjustment;
6829
         end;
6830
 
6831
      --  Don't copy Ident or Comment pragmas, since the comment belongs to the
6832
      --  generic unit, not to the instantiating unit.
6833
 
6834
      elsif Nkind (N) = N_Pragma and then Instantiating then
6835
         declare
6836
            Prag_Id : constant Pragma_Id := Get_Pragma_Id (N);
6837
         begin
6838
            if Prag_Id = Pragma_Ident or else Prag_Id = Pragma_Comment then
6839
               New_N := Make_Null_Statement (Sloc (N));
6840
 
6841
            else
6842
               Copy_Descendants;
6843
            end if;
6844
         end;
6845
 
6846
      elsif Nkind_In (N, N_Integer_Literal, N_Real_Literal) then
6847
 
6848
         --  No descendant fields need traversing
6849
 
6850
         null;
6851
 
6852
      elsif Nkind (N) = N_String_Literal
6853
        and then Present (Etype (N))
6854
        and then Instantiating
6855
      then
6856
         --  If the string is declared in an outer scope, the string_literal
6857
         --  subtype created for it may have the wrong scope. We force the
6858
         --  reanalysis of the constant to generate a new itype in the proper
6859
         --  context.
6860
 
6861
         Set_Etype (New_N, Empty);
6862
         Set_Analyzed (New_N, False);
6863
 
6864
      --  For the remaining nodes, copy their descendants recursively
6865
 
6866
      else
6867
         Copy_Descendants;
6868
 
6869
         if Instantiating and then Nkind (N) = N_Subprogram_Body then
6870
            Set_Generic_Parent (Specification (New_N), N);
6871
 
6872
            --  Should preserve Corresponding_Spec??? (12.3(14))
6873
         end if;
6874
      end if;
6875
 
6876
      return New_N;
6877
   end Copy_Generic_Node;
6878
 
6879
   ----------------------------
6880
   -- Denotes_Formal_Package --
6881
   ----------------------------
6882
 
6883
   function Denotes_Formal_Package
6884
     (Pack     : Entity_Id;
6885
      On_Exit  : Boolean := False;
6886
      Instance : Entity_Id := Empty) return Boolean
6887
   is
6888
      Par  : Entity_Id;
6889
      Scop : constant Entity_Id := Scope (Pack);
6890
      E    : Entity_Id;
6891
 
6892
      function Is_Actual_Of_Previous_Formal (P : Entity_Id) return Boolean;
6893
      --  The package in question may be an actual for a previous formal
6894
      --  package P of the current instance, so examine its actuals as well.
6895
      --  This must be recursive over other formal packages.
6896
 
6897
      ----------------------------------
6898
      -- Is_Actual_Of_Previous_Formal --
6899
      ----------------------------------
6900
 
6901
      function Is_Actual_Of_Previous_Formal (P : Entity_Id) return Boolean is
6902
         E1 : Entity_Id;
6903
 
6904
      begin
6905
         E1 := First_Entity (P);
6906
         while Present (E1) and then  E1 /= Instance loop
6907
            if Ekind (E1) = E_Package
6908
              and then Nkind (Parent (E1)) = N_Package_Renaming_Declaration
6909
            then
6910
               if Renamed_Object (E1) = Pack then
6911
                  return True;
6912
 
6913
               elsif E1 = P or else  Renamed_Object (E1) = P then
6914
                  return False;
6915
 
6916
               elsif Is_Actual_Of_Previous_Formal (E1) then
6917
                  return True;
6918
               end if;
6919
            end if;
6920
 
6921
            Next_Entity (E1);
6922
         end loop;
6923
 
6924
         return False;
6925
      end Is_Actual_Of_Previous_Formal;
6926
 
6927
   --  Start of processing for Denotes_Formal_Package
6928
 
6929
   begin
6930
      if On_Exit then
6931
         Par :=
6932
           Instance_Envs.Table
6933
             (Instance_Envs.Last).Instantiated_Parent.Act_Id;
6934
      else
6935
         Par := Current_Instantiated_Parent.Act_Id;
6936
      end if;
6937
 
6938
      if Ekind (Scop) = E_Generic_Package
6939
        or else Nkind (Unit_Declaration_Node (Scop)) =
6940
                                         N_Generic_Subprogram_Declaration
6941
      then
6942
         return True;
6943
 
6944
      elsif Nkind (Original_Node (Unit_Declaration_Node (Pack))) =
6945
        N_Formal_Package_Declaration
6946
      then
6947
         return True;
6948
 
6949
      elsif No (Par) then
6950
         return False;
6951
 
6952
      else
6953
         --  Check whether this package is associated with a formal package of
6954
         --  the enclosing instantiation. Iterate over the list of renamings.
6955
 
6956
         E := First_Entity (Par);
6957
         while Present (E) loop
6958
            if Ekind (E) /= E_Package
6959
              or else Nkind (Parent (E)) /= N_Package_Renaming_Declaration
6960
            then
6961
               null;
6962
 
6963
            elsif Renamed_Object (E) = Par then
6964
               return False;
6965
 
6966
            elsif Renamed_Object (E) = Pack then
6967
               return True;
6968
 
6969
            elsif Is_Actual_Of_Previous_Formal (E) then
6970
               return True;
6971
 
6972
            end if;
6973
 
6974
            Next_Entity (E);
6975
         end loop;
6976
 
6977
         return False;
6978
      end if;
6979
   end Denotes_Formal_Package;
6980
 
6981
   -----------------
6982
   -- End_Generic --
6983
   -----------------
6984
 
6985
   procedure End_Generic is
6986
   begin
6987
      --  ??? More things could be factored out in this routine. Should
6988
      --  probably be done at a later stage.
6989
 
6990
      Inside_A_Generic := Generic_Flags.Table (Generic_Flags.Last);
6991
      Generic_Flags.Decrement_Last;
6992
 
6993
      Expander_Mode_Restore;
6994
   end End_Generic;
6995
 
6996
   -------------
6997
   -- Earlier --
6998
   -------------
6999
 
7000
   function Earlier (N1, N2 : Node_Id) return Boolean is
7001
      procedure Find_Depth (P : in out Node_Id; D : in out Integer);
7002
      --  Find distance from given node to enclosing compilation unit
7003
 
7004
      ----------------
7005
      -- Find_Depth --
7006
      ----------------
7007
 
7008
      procedure Find_Depth (P : in out Node_Id; D : in out Integer) is
7009
      begin
7010
         while Present (P)
7011
           and then Nkind (P) /= N_Compilation_Unit
7012
         loop
7013
            P := True_Parent (P);
7014
            D := D + 1;
7015
         end loop;
7016
      end Find_Depth;
7017
 
7018
      --  Local declarations
7019
 
7020
      D1 : Integer := 0;
7021
      D2 : Integer := 0;
7022
      P1 : Node_Id := N1;
7023
      P2 : Node_Id := N2;
7024
 
7025
   --  Start of processing for Earlier
7026
 
7027
   begin
7028
      Find_Depth (P1, D1);
7029
      Find_Depth (P2, D2);
7030
 
7031
      if P1 /= P2 then
7032
         return False;
7033
      else
7034
         P1 := N1;
7035
         P2 := N2;
7036
      end if;
7037
 
7038
      while D1 > D2 loop
7039
         P1 := True_Parent (P1);
7040
         D1 := D1 - 1;
7041
      end loop;
7042
 
7043
      while D2 > D1 loop
7044
         P2 := True_Parent (P2);
7045
         D2 := D2 - 1;
7046
      end loop;
7047
 
7048
      --  At this point P1 and P2 are at the same distance from the root.
7049
      --  We examine their parents until we find a common declarative list.
7050
      --  If we reach the root, N1 and N2 do not descend from the same
7051
      --  declarative list (e.g. one is nested in the declarative part and
7052
      --  the other is in a block in the statement part) and the earlier
7053
      --  one is already frozen.
7054
 
7055
      while not Is_List_Member (P1)
7056
        or else not Is_List_Member (P2)
7057
        or else List_Containing (P1) /= List_Containing (P2)
7058
      loop
7059
         P1 := True_Parent (P1);
7060
         P2 := True_Parent (P2);
7061
 
7062
         if Nkind (Parent (P1)) = N_Subunit then
7063
            P1 := Corresponding_Stub (Parent (P1));
7064
         end if;
7065
 
7066
         if Nkind (Parent (P2)) = N_Subunit then
7067
            P2 := Corresponding_Stub (Parent (P2));
7068
         end if;
7069
 
7070
         if P1 = P2 then
7071
            return False;
7072
         end if;
7073
      end loop;
7074
 
7075
      --  Expanded code usually shares the source location of the original
7076
      --  construct it was generated for. This however may not necessarely
7077
      --  reflect the true location of the code within the tree.
7078
 
7079
      --  Before comparing the slocs of the two nodes, make sure that we are
7080
      --  working with correct source locations. Assume that P1 is to the left
7081
      --  of P2. If either one does not come from source, traverse the common
7082
      --  list heading towards the other node and locate the first source
7083
      --  statement.
7084
 
7085
      --             P1                     P2
7086
      --     ----+===+===+--------------+===+===+----
7087
      --          expanded code          expanded code
7088
 
7089
      if not Comes_From_Source (P1) then
7090
         while Present (P1) loop
7091
 
7092
            --  Neither P2 nor a source statement were located during the
7093
            --  search. If we reach the end of the list, then P1 does not
7094
            --  occur earlier than P2.
7095
 
7096
            --                     ---->
7097
            --   start --- P2 ----- P1 --- end
7098
 
7099
            if No (Next (P1)) then
7100
               return False;
7101
 
7102
            --  We encounter P2 while going to the right of the list. This
7103
            --  means that P1 does indeed appear earlier.
7104
 
7105
            --             ---->
7106
            --    start --- P1 ===== P2 --- end
7107
            --                 expanded code in between
7108
 
7109
            elsif P1 = P2 then
7110
               return True;
7111
 
7112
            --  No need to look any further since we have located a source
7113
            --  statement.
7114
 
7115
            elsif Comes_From_Source (P1) then
7116
               exit;
7117
            end if;
7118
 
7119
            --  Keep going right
7120
 
7121
            Next (P1);
7122
         end loop;
7123
      end if;
7124
 
7125
      if not Comes_From_Source (P2) then
7126
         while Present (P2) loop
7127
 
7128
            --  Neither P1 nor a source statement were located during the
7129
            --  search. If we reach the start of the list, then P1 does not
7130
            --  occur earlier than P2.
7131
 
7132
            --            <----
7133
            --    start --- P2 --- P1 --- end
7134
 
7135
            if No (Prev (P2)) then
7136
               return False;
7137
 
7138
            --  We encounter P1 while going to the left of the list. This
7139
            --  means that P1 does indeed appear earlier.
7140
 
7141
            --                     <----
7142
            --    start --- P1 ===== P2 --- end
7143
            --                 expanded code in between
7144
 
7145
            elsif P2 = P1 then
7146
               return True;
7147
 
7148
            --  No need to look any further since we have located a source
7149
            --  statement.
7150
 
7151
            elsif Comes_From_Source (P2) then
7152
               exit;
7153
            end if;
7154
 
7155
            --  Keep going left
7156
 
7157
            Prev (P2);
7158
         end loop;
7159
      end if;
7160
 
7161
      --  At this point either both nodes came from source or we approximated
7162
      --  their source locations through neighbouring source statements. There
7163
      --  is no need to look at the top level locations of P1 and P2 because
7164
      --  both nodes are in the same list and whether the enclosing context is
7165
      --  instantiated is irrelevant.
7166
 
7167
      return Sloc (P1) < Sloc (P2);
7168
   end Earlier;
7169
 
7170
   ----------------------
7171
   -- Find_Actual_Type --
7172
   ----------------------
7173
 
7174
   function Find_Actual_Type
7175
     (Typ      : Entity_Id;
7176
      Gen_Type : Entity_Id) return Entity_Id
7177
   is
7178
      Gen_Scope : constant Entity_Id := Scope (Gen_Type);
7179
      T         : Entity_Id;
7180
 
7181
   begin
7182
      --  Special processing only applies to child units
7183
 
7184
      if not Is_Child_Unit (Gen_Scope) then
7185
         return Get_Instance_Of (Typ);
7186
 
7187
      --  If designated or component type is itself a formal of the child unit,
7188
      --  its instance is available.
7189
 
7190
      elsif Scope (Typ) = Gen_Scope then
7191
         return Get_Instance_Of (Typ);
7192
 
7193
      --  If the array or access type is not declared in the parent unit,
7194
      --  no special processing needed.
7195
 
7196
      elsif not Is_Generic_Type (Typ)
7197
        and then Scope (Gen_Scope) /= Scope (Typ)
7198
      then
7199
         return Get_Instance_Of (Typ);
7200
 
7201
      --  Otherwise, retrieve designated or component type by visibility
7202
 
7203
      else
7204
         T := Current_Entity (Typ);
7205
         while Present (T) loop
7206
            if In_Open_Scopes (Scope (T)) then
7207
               return T;
7208
 
7209
            elsif Is_Generic_Actual_Type (T) then
7210
               return T;
7211
            end if;
7212
 
7213
            T := Homonym (T);
7214
         end loop;
7215
 
7216
         return Typ;
7217
      end if;
7218
   end Find_Actual_Type;
7219
 
7220
   ----------------------------
7221
   -- Freeze_Subprogram_Body --
7222
   ----------------------------
7223
 
7224
   procedure Freeze_Subprogram_Body
7225
     (Inst_Node : Node_Id;
7226
      Gen_Body  : Node_Id;
7227
      Pack_Id   : Entity_Id)
7228
  is
7229
      Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node);
7230
      Par      : constant Entity_Id := Scope (Gen_Unit);
7231
      E_G_Id   : Entity_Id;
7232
      Enc_G    : Entity_Id;
7233
      Enc_I    : Node_Id;
7234
      F_Node   : Node_Id;
7235
 
7236
      function Enclosing_Package_Body (N : Node_Id) return Node_Id;
7237
      --  Find innermost package body that encloses the given node, and which
7238
      --  is not a compilation unit. Freeze nodes for the instance, or for its
7239
      --  enclosing body, may be inserted after the enclosing_body of the
7240
      --  generic unit. Used to determine proper placement of freeze node for
7241
      --  both package and subprogram instances.
7242
 
7243
      function Package_Freeze_Node (B : Node_Id) return Node_Id;
7244
      --  Find entity for given package body, and locate or create a freeze
7245
      --  node for it.
7246
 
7247
      ----------------------------
7248
      -- Enclosing_Package_Body --
7249
      ----------------------------
7250
 
7251
      function Enclosing_Package_Body (N : Node_Id) return Node_Id is
7252
         P : Node_Id;
7253
 
7254
      begin
7255
         P := Parent (N);
7256
         while Present (P)
7257
           and then Nkind (Parent (P)) /= N_Compilation_Unit
7258
         loop
7259
            if Nkind (P) = N_Package_Body then
7260
               if Nkind (Parent (P)) = N_Subunit then
7261
                  return Corresponding_Stub (Parent (P));
7262
               else
7263
                  return P;
7264
               end if;
7265
            end if;
7266
 
7267
            P := True_Parent (P);
7268
         end loop;
7269
 
7270
         return Empty;
7271
      end Enclosing_Package_Body;
7272
 
7273
      -------------------------
7274
      -- Package_Freeze_Node --
7275
      -------------------------
7276
 
7277
      function Package_Freeze_Node (B : Node_Id) return Node_Id is
7278
         Id : Entity_Id;
7279
 
7280
      begin
7281
         if Nkind (B) = N_Package_Body then
7282
            Id := Corresponding_Spec (B);
7283
         else pragma Assert (Nkind (B) = N_Package_Body_Stub);
7284
            Id := Corresponding_Spec (Proper_Body (Unit (Library_Unit (B))));
7285
         end if;
7286
 
7287
         Ensure_Freeze_Node (Id);
7288
         return Freeze_Node (Id);
7289
      end Package_Freeze_Node;
7290
 
7291
   --  Start of processing of Freeze_Subprogram_Body
7292
 
7293
   begin
7294
      --  If the instance and the generic body appear within the same unit, and
7295
      --  the instance precedes the generic, the freeze node for the instance
7296
      --  must appear after that of the generic. If the generic is nested
7297
      --  within another instance I2, then current instance must be frozen
7298
      --  after I2. In both cases, the freeze nodes are those of enclosing
7299
      --  packages. Otherwise, the freeze node is placed at the end of the
7300
      --  current declarative part.
7301
 
7302
      Enc_G  := Enclosing_Package_Body (Gen_Body);
7303
      Enc_I  := Enclosing_Package_Body (Inst_Node);
7304
      Ensure_Freeze_Node (Pack_Id);
7305
      F_Node := Freeze_Node (Pack_Id);
7306
 
7307
      if Is_Generic_Instance (Par)
7308
        and then Present (Freeze_Node (Par))
7309
        and then In_Same_Declarative_Part (Freeze_Node (Par), Inst_Node)
7310
      then
7311
         --  The parent was a premature instantiation. Insert freeze node at
7312
         --  the end the current declarative part.
7313
 
7314
         if ABE_Is_Certain (Get_Package_Instantiation_Node (Par)) then
7315
            Insert_Freeze_Node_For_Instance (Inst_Node, F_Node);
7316
 
7317
         --  Handle the following case:
7318
         --
7319
         --    package Parent_Inst is new ...
7320
         --    Parent_Inst []
7321
         --
7322
         --    procedure P ...  --  this body freezes Parent_Inst
7323
         --
7324
         --    package Inst is new ...
7325
         --
7326
         --  In this particular scenario, the freeze node for Inst must be
7327
         --  inserted in the same manner as that of Parent_Inst - before the
7328
         --  next source body or at the end of the declarative list (body not
7329
         --  available). If body P did not exist and Parent_Inst was frozen
7330
         --  after Inst, either by a body following Inst or at the end of the
7331
         --  declarative region, the freeze node for Inst must be inserted
7332
         --  after that of Parent_Inst. This relation is established by
7333
         --  comparing the Slocs of Parent_Inst freeze node and Inst.
7334
 
7335
         elsif List_Containing (Get_Package_Instantiation_Node (Par)) =
7336
               List_Containing (Inst_Node)
7337
           and then Sloc (Freeze_Node (Par)) < Sloc (Inst_Node)
7338
         then
7339
            Insert_Freeze_Node_For_Instance (Inst_Node, F_Node);
7340
 
7341
         else
7342
            Insert_After (Freeze_Node (Par), F_Node);
7343
         end if;
7344
 
7345
      --  The body enclosing the instance should be frozen after the body that
7346
      --  includes the generic, because the body of the instance may make
7347
      --  references to entities therein. If the two are not in the same
7348
      --  declarative part, or if the one enclosing the instance is frozen
7349
      --  already, freeze the instance at the end of the current declarative
7350
      --  part.
7351
 
7352
      elsif Is_Generic_Instance (Par)
7353
        and then Present (Freeze_Node (Par))
7354
        and then Present (Enc_I)
7355
      then
7356
         if In_Same_Declarative_Part (Freeze_Node (Par), Enc_I)
7357
           or else
7358
             (Nkind (Enc_I) = N_Package_Body
7359
               and then
7360
                 In_Same_Declarative_Part (Freeze_Node (Par), Parent (Enc_I)))
7361
         then
7362
            --  The enclosing package may contain several instances. Rather
7363
            --  than computing the earliest point at which to insert its freeze
7364
            --  node, we place it at the end of the declarative part of the
7365
            --  parent of the generic.
7366
 
7367
            Insert_Freeze_Node_For_Instance
7368
              (Freeze_Node (Par), Package_Freeze_Node (Enc_I));
7369
         end if;
7370
 
7371
         Insert_Freeze_Node_For_Instance (Inst_Node, F_Node);
7372
 
7373
      elsif Present (Enc_G)
7374
        and then Present (Enc_I)
7375
        and then Enc_G /= Enc_I
7376
        and then Earlier (Inst_Node, Gen_Body)
7377
      then
7378
         if Nkind (Enc_G) = N_Package_Body then
7379
            E_G_Id := Corresponding_Spec (Enc_G);
7380
         else pragma Assert (Nkind (Enc_G) = N_Package_Body_Stub);
7381
            E_G_Id :=
7382
              Corresponding_Spec (Proper_Body (Unit (Library_Unit (Enc_G))));
7383
         end if;
7384
 
7385
         --  Freeze package that encloses instance, and place node after
7386
         --  package that encloses generic. If enclosing package is already
7387
         --  frozen we have to assume it is at the proper place. This may be a
7388
         --  potential ABE that requires dynamic checking. Do not add a freeze
7389
         --  node if the package that encloses the generic is inside the body
7390
         --  that encloses the instance, because the freeze node would be in
7391
         --  the wrong scope. Additional contortions needed if the bodies are
7392
         --  within a subunit.
7393
 
7394
         declare
7395
            Enclosing_Body : Node_Id;
7396
 
7397
         begin
7398
            if Nkind (Enc_I) = N_Package_Body_Stub then
7399
               Enclosing_Body := Proper_Body (Unit (Library_Unit (Enc_I)));
7400
            else
7401
               Enclosing_Body := Enc_I;
7402
            end if;
7403
 
7404
            if Parent (List_Containing (Enc_G)) /= Enclosing_Body then
7405
               Insert_Freeze_Node_For_Instance
7406
                 (Enc_G, Package_Freeze_Node (Enc_I));
7407
            end if;
7408
         end;
7409
 
7410
         --  Freeze enclosing subunit before instance
7411
 
7412
         Ensure_Freeze_Node (E_G_Id);
7413
 
7414
         if not Is_List_Member (Freeze_Node (E_G_Id)) then
7415
            Insert_After (Enc_G, Freeze_Node (E_G_Id));
7416
         end if;
7417
 
7418
         Insert_Freeze_Node_For_Instance (Inst_Node, F_Node);
7419
 
7420
      else
7421
         --  If none of the above, insert freeze node at the end of the current
7422
         --  declarative part.
7423
 
7424
         Insert_Freeze_Node_For_Instance (Inst_Node, F_Node);
7425
      end if;
7426
   end Freeze_Subprogram_Body;
7427
 
7428
   ----------------
7429
   -- Get_Gen_Id --
7430
   ----------------
7431
 
7432
   function Get_Gen_Id (E : Assoc_Ptr) return Entity_Id is
7433
   begin
7434
      return Generic_Renamings.Table (E).Gen_Id;
7435
   end Get_Gen_Id;
7436
 
7437
   ---------------------
7438
   -- Get_Instance_Of --
7439
   ---------------------
7440
 
7441
   function Get_Instance_Of (A : Entity_Id) return Entity_Id is
7442
      Res : constant Assoc_Ptr := Generic_Renamings_HTable.Get (A);
7443
 
7444
   begin
7445
      if Res /= Assoc_Null then
7446
         return Generic_Renamings.Table (Res).Act_Id;
7447
      else
7448
         --  On exit, entity is not instantiated: not a generic parameter, or
7449
         --  else parameter of an inner generic unit.
7450
 
7451
         return A;
7452
      end if;
7453
   end Get_Instance_Of;
7454
 
7455
   ------------------------------------
7456
   -- Get_Package_Instantiation_Node --
7457
   ------------------------------------
7458
 
7459
   function Get_Package_Instantiation_Node (A : Entity_Id) return Node_Id is
7460
      Decl : Node_Id := Unit_Declaration_Node (A);
7461
      Inst : Node_Id;
7462
 
7463
   begin
7464
      --  If the Package_Instantiation attribute has been set on the package
7465
      --  entity, then use it directly when it (or its Original_Node) refers
7466
      --  to an N_Package_Instantiation node. In principle it should be
7467
      --  possible to have this field set in all cases, which should be
7468
      --  investigated, and would allow this function to be significantly
7469
      --  simplified. ???
7470
 
7471
      Inst := Package_Instantiation (A);
7472
 
7473
      if Present (Inst) then
7474
         if Nkind (Inst) = N_Package_Instantiation then
7475
            return Inst;
7476
 
7477
         elsif Nkind (Original_Node (Inst)) = N_Package_Instantiation then
7478
            return Original_Node (Inst);
7479
         end if;
7480
      end if;
7481
 
7482
      --  If the instantiation is a compilation unit that does not need body
7483
      --  then the instantiation node has been rewritten as a package
7484
      --  declaration for the instance, and we return the original node.
7485
 
7486
      --  If it is a compilation unit and the instance node has not been
7487
      --  rewritten, then it is still the unit of the compilation. Finally, if
7488
      --  a body is present, this is a parent of the main unit whose body has
7489
      --  been compiled for inlining purposes, and the instantiation node has
7490
      --  been rewritten with the instance body.
7491
 
7492
      --  Otherwise the instantiation node appears after the declaration. If
7493
      --  the entity is a formal package, the declaration may have been
7494
      --  rewritten as a generic declaration (in the case of a formal with box)
7495
      --  or left as a formal package declaration if it has actuals, and is
7496
      --  found with a forward search.
7497
 
7498
      if Nkind (Parent (Decl)) = N_Compilation_Unit then
7499
         if Nkind (Decl) = N_Package_Declaration
7500
           and then Present (Corresponding_Body (Decl))
7501
         then
7502
            Decl := Unit_Declaration_Node (Corresponding_Body (Decl));
7503
         end if;
7504
 
7505
         if Nkind (Original_Node (Decl)) = N_Package_Instantiation then
7506
            return Original_Node (Decl);
7507
         else
7508
            return Unit (Parent (Decl));
7509
         end if;
7510
 
7511
      elsif Nkind (Decl) = N_Package_Declaration
7512
        and then Nkind (Original_Node (Decl)) = N_Formal_Package_Declaration
7513
      then
7514
         return Original_Node (Decl);
7515
 
7516
      else
7517
         Inst := Next (Decl);
7518
         while not Nkind_In (Inst, N_Package_Instantiation,
7519
                                   N_Formal_Package_Declaration)
7520
         loop
7521
            Next (Inst);
7522
         end loop;
7523
 
7524
         return Inst;
7525
      end if;
7526
   end Get_Package_Instantiation_Node;
7527
 
7528
   ------------------------
7529
   -- Has_Been_Exchanged --
7530
   ------------------------
7531
 
7532
   function Has_Been_Exchanged (E : Entity_Id) return Boolean is
7533
      Next : Elmt_Id;
7534
 
7535
   begin
7536
      Next := First_Elmt (Exchanged_Views);
7537
      while Present (Next) loop
7538
         if Full_View (Node (Next)) = E then
7539
            return True;
7540
         end if;
7541
 
7542
         Next_Elmt (Next);
7543
      end loop;
7544
 
7545
      return False;
7546
   end Has_Been_Exchanged;
7547
 
7548
   ----------
7549
   -- Hash --
7550
   ----------
7551
 
7552
   function Hash (F : Entity_Id) return HTable_Range is
7553
   begin
7554
      return HTable_Range (F mod HTable_Size);
7555
   end Hash;
7556
 
7557
   ------------------------
7558
   -- Hide_Current_Scope --
7559
   ------------------------
7560
 
7561
   procedure Hide_Current_Scope is
7562
      C : constant Entity_Id := Current_Scope;
7563
      E : Entity_Id;
7564
 
7565
   begin
7566
      Set_Is_Hidden_Open_Scope (C);
7567
 
7568
      E := First_Entity (C);
7569
      while Present (E) loop
7570
         if Is_Immediately_Visible (E) then
7571
            Set_Is_Immediately_Visible (E, False);
7572
            Append_Elmt (E, Hidden_Entities);
7573
         end if;
7574
 
7575
         Next_Entity (E);
7576
      end loop;
7577
 
7578
      --  Make the scope name invisible as well. This is necessary, but might
7579
      --  conflict with calls to Rtsfind later on, in case the scope is a
7580
      --  predefined one. There is no clean solution to this problem, so for
7581
      --  now we depend on the user not redefining Standard itself in one of
7582
      --  the parent units.
7583
 
7584
      if Is_Immediately_Visible (C) and then C /= Standard_Standard then
7585
         Set_Is_Immediately_Visible (C, False);
7586
         Append_Elmt (C, Hidden_Entities);
7587
      end if;
7588
 
7589
   end Hide_Current_Scope;
7590
 
7591
   --------------
7592
   -- Init_Env --
7593
   --------------
7594
 
7595
   procedure Init_Env is
7596
      Saved : Instance_Env;
7597
 
7598
   begin
7599
      Saved.Instantiated_Parent  := Current_Instantiated_Parent;
7600
      Saved.Exchanged_Views      := Exchanged_Views;
7601
      Saved.Hidden_Entities      := Hidden_Entities;
7602
      Saved.Current_Sem_Unit     := Current_Sem_Unit;
7603
      Saved.Parent_Unit_Visible  := Parent_Unit_Visible;
7604
      Saved.Instance_Parent_Unit := Instance_Parent_Unit;
7605
 
7606
      --  Save configuration switches. These may be reset if the unit is a
7607
      --  predefined unit, and the current mode is not Ada 2005.
7608
 
7609
      Save_Opt_Config_Switches (Saved.Switches);
7610
 
7611
      Instance_Envs.Append (Saved);
7612
 
7613
      Exchanged_Views := New_Elmt_List;
7614
      Hidden_Entities := New_Elmt_List;
7615
 
7616
      --  Make dummy entry for Instantiated parent. If generic unit is legal,
7617
      --  this is set properly in Set_Instance_Env.
7618
 
7619
      Current_Instantiated_Parent :=
7620
        (Current_Scope, Current_Scope, Assoc_Null);
7621
   end Init_Env;
7622
 
7623
   ------------------------------
7624
   -- In_Same_Declarative_Part --
7625
   ------------------------------
7626
 
7627
   function In_Same_Declarative_Part
7628
     (F_Node : Node_Id;
7629
      Inst   : Node_Id) return Boolean
7630
   is
7631
      Decls : constant Node_Id := Parent (F_Node);
7632
      Nod   : Node_Id := Parent (Inst);
7633
 
7634
   begin
7635
      while Present (Nod) loop
7636
         if Nod = Decls then
7637
            return True;
7638
 
7639
         elsif Nkind_In (Nod, N_Subprogram_Body,
7640
                              N_Package_Body,
7641
                              N_Package_Declaration,
7642
                              N_Task_Body,
7643
                              N_Protected_Body,
7644
                              N_Block_Statement)
7645
         then
7646
            return False;
7647
 
7648
         elsif Nkind (Nod) = N_Subunit then
7649
            Nod := Corresponding_Stub (Nod);
7650
 
7651
         elsif Nkind (Nod) = N_Compilation_Unit then
7652
            return False;
7653
 
7654
         else
7655
            Nod := Parent (Nod);
7656
         end if;
7657
      end loop;
7658
 
7659
      return False;
7660
   end In_Same_Declarative_Part;
7661
 
7662
   ---------------------
7663
   -- In_Main_Context --
7664
   ---------------------
7665
 
7666
   function In_Main_Context (E : Entity_Id) return Boolean is
7667
      Context : List_Id;
7668
      Clause  : Node_Id;
7669
      Nam     : Node_Id;
7670
 
7671
   begin
7672
      if not Is_Compilation_Unit (E)
7673
        or else Ekind (E) /= E_Package
7674
        or else In_Private_Part (E)
7675
      then
7676
         return False;
7677
      end if;
7678
 
7679
      Context := Context_Items (Cunit (Main_Unit));
7680
 
7681
      Clause  := First (Context);
7682
      while Present (Clause) loop
7683
         if Nkind (Clause) = N_With_Clause then
7684
            Nam := Name (Clause);
7685
 
7686
            --  If the current scope is part of the context of the main unit,
7687
            --  analysis of the corresponding with_clause is not complete, and
7688
            --  the entity is not set. We use the Chars field directly, which
7689
            --  might produce false positives in rare cases, but guarantees
7690
            --  that we produce all the instance bodies we will need.
7691
 
7692
            if (Is_Entity_Name (Nam) and then Chars (Nam) = Chars (E))
7693
                 or else (Nkind (Nam) = N_Selected_Component
7694
                           and then Chars (Selector_Name (Nam)) = Chars (E))
7695
            then
7696
               return True;
7697
            end if;
7698
         end if;
7699
 
7700
         Next (Clause);
7701
      end loop;
7702
 
7703
      return False;
7704
   end In_Main_Context;
7705
 
7706
   ---------------------
7707
   -- Inherit_Context --
7708
   ---------------------
7709
 
7710
   procedure Inherit_Context (Gen_Decl : Node_Id; Inst : Node_Id) is
7711
      Current_Context : List_Id;
7712
      Current_Unit    : Node_Id;
7713
      Item            : Node_Id;
7714
      New_I           : Node_Id;
7715
 
7716
   begin
7717
      if Nkind (Parent (Gen_Decl)) = N_Compilation_Unit then
7718
 
7719
         --  The inherited context is attached to the enclosing compilation
7720
         --  unit. This is either the main unit, or the declaration for the
7721
         --  main unit (in case the instantiation appears within the package
7722
         --  declaration and the main unit is its body).
7723
 
7724
         Current_Unit := Parent (Inst);
7725
         while Present (Current_Unit)
7726
           and then Nkind (Current_Unit) /= N_Compilation_Unit
7727
         loop
7728
            Current_Unit := Parent (Current_Unit);
7729
         end loop;
7730
 
7731
         Current_Context := Context_Items (Current_Unit);
7732
 
7733
         Item := First (Context_Items (Parent (Gen_Decl)));
7734
         while Present (Item) loop
7735
            if Nkind (Item) = N_With_Clause then
7736
 
7737
               --  Take care to prevent direct cyclic with's, which can happen
7738
               --  if the generic body with's the current unit. Such a case
7739
               --  would result in binder errors (or run-time errors if the
7740
               --  -gnatE switch is in effect), but we want to prevent it here,
7741
               --  because Sem.Walk_Library_Items doesn't like cycles. Note
7742
               --  that we don't bother to detect indirect cycles.
7743
 
7744
               if Library_Unit (Item) /= Current_Unit then
7745
                  New_I := New_Copy (Item);
7746
                  Set_Implicit_With (New_I, True);
7747
                  Append (New_I, Current_Context);
7748
               end if;
7749
            end if;
7750
 
7751
            Next (Item);
7752
         end loop;
7753
      end if;
7754
   end Inherit_Context;
7755
 
7756
   ----------------
7757
   -- Initialize --
7758
   ----------------
7759
 
7760
   procedure Initialize is
7761
   begin
7762
      Generic_Renamings.Init;
7763
      Instance_Envs.Init;
7764
      Generic_Flags.Init;
7765
      Generic_Renamings_HTable.Reset;
7766
      Circularity_Detected := False;
7767
      Exchanged_Views      := No_Elist;
7768
      Hidden_Entities      := No_Elist;
7769
   end Initialize;
7770
 
7771
   -------------------------------------
7772
   -- Insert_Freeze_Node_For_Instance --
7773
   -------------------------------------
7774
 
7775
   procedure Insert_Freeze_Node_For_Instance
7776
     (N      : Node_Id;
7777
      F_Node : Node_Id)
7778
   is
7779
      Inst  : constant Entity_Id := Entity (F_Node);
7780
      Decl  : Node_Id;
7781
      Decls : List_Id;
7782
      Par_N : Node_Id;
7783
 
7784
      function Enclosing_Body (N : Node_Id) return Node_Id;
7785
      --  Find enclosing package or subprogram body, if any. Freeze node
7786
      --  may be placed at end of current declarative list if previous
7787
      --  instance and current one have different enclosing bodies.
7788
 
7789
      function Previous_Instance (Gen : Entity_Id) return Entity_Id;
7790
      --  Find the local instance, if any, that declares the generic that is
7791
      --  being instantiated. If present, the freeze node for this instance
7792
      --  must follow the freeze node for the previous instance.
7793
 
7794
      --------------------
7795
      -- Enclosing_Body --
7796
      --------------------
7797
 
7798
      function Enclosing_Body (N : Node_Id) return Node_Id is
7799
         P : Node_Id;
7800
 
7801
      begin
7802
         P := Parent (N);
7803
         while Present (P)
7804
           and then Nkind (Parent (P)) /= N_Compilation_Unit
7805
         loop
7806
            if Nkind_In (P, N_Package_Body, N_Subprogram_Body) then
7807
               if Nkind (Parent (P)) = N_Subunit then
7808
                  return Corresponding_Stub (Parent (P));
7809
               else
7810
                  return P;
7811
               end if;
7812
            end if;
7813
 
7814
            P := True_Parent (P);
7815
         end loop;
7816
 
7817
         return Empty;
7818
      end Enclosing_Body;
7819
 
7820
      -----------------------
7821
      -- Previous_Instance --
7822
      -----------------------
7823
 
7824
      function Previous_Instance (Gen : Entity_Id) return Entity_Id is
7825
         S : Entity_Id;
7826
 
7827
      begin
7828
         S := Scope (Gen);
7829
         while Present (S)
7830
           and then S /= Standard_Standard
7831
         loop
7832
            if Is_Generic_Instance (S)
7833
              and then In_Same_Source_Unit (S, N)
7834
            then
7835
               return S;
7836
            end if;
7837
 
7838
            S := Scope (S);
7839
         end loop;
7840
 
7841
         return Empty;
7842
      end Previous_Instance;
7843
 
7844
   --  Start of processing for Insert_Freeze_Node_For_Instance
7845
 
7846
   begin
7847
      if not Is_List_Member (F_Node) then
7848
         Decls := List_Containing (N);
7849
         Par_N := Parent (Decls);
7850
         Decl  := N;
7851
 
7852
         --  If this is a package instance, check whether the generic is
7853
         --  declared in a previous instance and the current instance is
7854
         --  not within the previous one.
7855
 
7856
         if Present (Generic_Parent (Parent (Inst)))
7857
           and then Is_In_Main_Unit (N)
7858
         then
7859
            declare
7860
               Enclosing_N : constant Node_Id := Enclosing_Body (N);
7861
               Par_I       : constant Entity_Id :=
7862
                               Previous_Instance
7863
                                 (Generic_Parent (Parent (Inst)));
7864
               Scop        : Entity_Id;
7865
 
7866
            begin
7867
               if Present (Par_I)
7868
                 and then Earlier (N, Freeze_Node (Par_I))
7869
               then
7870
                  Scop := Scope (Inst);
7871
 
7872
                  --  If the current instance is within the one that contains
7873
                  --  the generic, the freeze node for the current one must
7874
                  --  appear in the current declarative part. Ditto, if the
7875
                  --  current instance is within another package instance or
7876
                  --  within a body that does not enclose the current instance.
7877
                  --  In these three cases the freeze node of the previous
7878
                  --  instance is not relevant.
7879
 
7880
                  while Present (Scop)
7881
                    and then Scop /= Standard_Standard
7882
                  loop
7883
                     exit when Scop = Par_I
7884
                       or else
7885
                         (Is_Generic_Instance (Scop)
7886
                           and then Scope_Depth (Scop) > Scope_Depth (Par_I));
7887
                     Scop := Scope (Scop);
7888
                  end loop;
7889
 
7890
                  --  Previous instance encloses current instance
7891
 
7892
                  if Scop = Par_I then
7893
                     null;
7894
 
7895
                  --  If the next node is a source  body we must freeze in
7896
                  --  the current scope as well.
7897
 
7898
                  elsif Present (Next (N))
7899
                    and then Nkind_In (Next (N),
7900
                      N_Subprogram_Body, N_Package_Body)
7901
                    and then Comes_From_Source (Next (N))
7902
                  then
7903
                     null;
7904
 
7905
                  --  Current instance is within an unrelated instance
7906
 
7907
                  elsif Is_Generic_Instance (Scop) then
7908
                     null;
7909
 
7910
                  --  Current instance is within an unrelated body
7911
 
7912
                  elsif Present (Enclosing_N)
7913
                     and then Enclosing_N /= Enclosing_Body (Par_I)
7914
                  then
7915
                     null;
7916
 
7917
                  else
7918
                     Insert_After (Freeze_Node (Par_I), F_Node);
7919
                     return;
7920
                  end if;
7921
               end if;
7922
            end;
7923
         end if;
7924
 
7925
         --  When the instantiation occurs in a package declaration, append the
7926
         --  freeze node to the private declarations (if any).
7927
 
7928
         if Nkind (Par_N) = N_Package_Specification
7929
           and then Decls = Visible_Declarations (Par_N)
7930
           and then Present (Private_Declarations (Par_N))
7931
           and then not Is_Empty_List (Private_Declarations (Par_N))
7932
         then
7933
            Decls := Private_Declarations (Par_N);
7934
            Decl  := First (Decls);
7935
         end if;
7936
 
7937
         --  Determine the proper freeze point of a package instantiation. We
7938
         --  adhere to the general rule of a package or subprogram body causing
7939
         --  freezing of anything before it in the same declarative region. In
7940
         --  this case, the proper freeze point of a package instantiation is
7941
         --  before the first source body which follows, or before a stub. This
7942
         --  ensures that entities coming from the instance are already frozen
7943
         --  and usable in source bodies.
7944
 
7945
         if Nkind (Par_N) /= N_Package_Declaration
7946
           and then Ekind (Inst) = E_Package
7947
           and then Is_Generic_Instance (Inst)
7948
           and then
7949
             not In_Same_Source_Unit (Generic_Parent (Parent (Inst)), Inst)
7950
         then
7951
            while Present (Decl) loop
7952
               if (Nkind (Decl) in N_Unit_Body
7953
                     or else
7954
                   Nkind (Decl) in N_Body_Stub)
7955
                 and then Comes_From_Source (Decl)
7956
               then
7957
                  Insert_Before (Decl, F_Node);
7958
                  return;
7959
               end if;
7960
 
7961
               Next (Decl);
7962
            end loop;
7963
         end if;
7964
 
7965
         --  In a package declaration, or if no previous body, insert at end
7966
         --  of list.
7967
 
7968
         Set_Sloc (F_Node, Sloc (Last (Decls)));
7969
         Insert_After (Last (Decls), F_Node);
7970
      end if;
7971
   end Insert_Freeze_Node_For_Instance;
7972
 
7973
   ------------------
7974
   -- Install_Body --
7975
   ------------------
7976
 
7977
   procedure Install_Body
7978
     (Act_Body : Node_Id;
7979
      N        : Node_Id;
7980
      Gen_Body : Node_Id;
7981
      Gen_Decl : Node_Id)
7982
   is
7983
      Act_Id    : constant Entity_Id := Corresponding_Spec (Act_Body);
7984
      Act_Unit  : constant Node_Id   := Unit (Cunit (Get_Source_Unit (N)));
7985
      Gen_Id    : constant Entity_Id := Corresponding_Spec (Gen_Body);
7986
      Par       : constant Entity_Id := Scope (Gen_Id);
7987
      Gen_Unit  : constant Node_Id   :=
7988
                    Unit (Cunit (Get_Source_Unit (Gen_Decl)));
7989
      Orig_Body : Node_Id := Gen_Body;
7990
      F_Node    : Node_Id;
7991
      Body_Unit : Node_Id;
7992
 
7993
      Must_Delay : Boolean;
7994
 
7995
      function Enclosing_Subp (Id : Entity_Id) return Entity_Id;
7996
      --  Find subprogram (if any) that encloses instance and/or generic body
7997
 
7998
      function True_Sloc (N : Node_Id) return Source_Ptr;
7999
      --  If the instance is nested inside a generic unit, the Sloc of the
8000
      --  instance indicates the place of the original definition, not the
8001
      --  point of the current enclosing instance. Pending a better usage of
8002
      --  Slocs to indicate instantiation places, we determine the place of
8003
      --  origin of a node by finding the maximum sloc of any ancestor node.
8004
      --  Why is this not equivalent to Top_Level_Location ???
8005
 
8006
      --------------------
8007
      -- Enclosing_Subp --
8008
      --------------------
8009
 
8010
      function Enclosing_Subp (Id : Entity_Id) return Entity_Id is
8011
         Scop : Entity_Id;
8012
 
8013
      begin
8014
         Scop := Scope (Id);
8015
         while Scop /= Standard_Standard
8016
           and then not Is_Overloadable (Scop)
8017
         loop
8018
            Scop := Scope (Scop);
8019
         end loop;
8020
 
8021
         return Scop;
8022
      end Enclosing_Subp;
8023
 
8024
      ---------------
8025
      -- True_Sloc --
8026
      ---------------
8027
 
8028
      function True_Sloc (N : Node_Id) return Source_Ptr is
8029
         Res : Source_Ptr;
8030
         N1  : Node_Id;
8031
 
8032
      begin
8033
         Res := Sloc (N);
8034
         N1 := N;
8035
         while Present (N1) and then N1 /= Act_Unit loop
8036
            if Sloc (N1) > Res then
8037
               Res := Sloc (N1);
8038
            end if;
8039
 
8040
            N1 := Parent (N1);
8041
         end loop;
8042
 
8043
         return Res;
8044
      end True_Sloc;
8045
 
8046
   --  Start of processing for Install_Body
8047
 
8048
   begin
8049
      --  If the body is a subunit, the freeze point is the corresponding stub
8050
      --  in the current compilation, not the subunit itself.
8051
 
8052
      if Nkind (Parent (Gen_Body)) = N_Subunit then
8053
         Orig_Body := Corresponding_Stub (Parent (Gen_Body));
8054
      else
8055
         Orig_Body := Gen_Body;
8056
      end if;
8057
 
8058
      Body_Unit := Unit (Cunit (Get_Source_Unit (Orig_Body)));
8059
 
8060
      --  If the instantiation and the generic definition appear in the same
8061
      --  package declaration, this is an early instantiation. If they appear
8062
      --  in the same declarative part, it is an early instantiation only if
8063
      --  the generic body appears textually later, and the generic body is
8064
      --  also in the main unit.
8065
 
8066
      --  If instance is nested within a subprogram, and the generic body is
8067
      --  not, the instance is delayed because the enclosing body is. If
8068
      --  instance and body are within the same scope, or the same sub-
8069
      --  program body, indicate explicitly that the instance is delayed.
8070
 
8071
      Must_Delay :=
8072
        (Gen_Unit = Act_Unit
8073
          and then (Nkind_In (Gen_Unit, N_Package_Declaration,
8074
                                        N_Generic_Package_Declaration)
8075
                      or else (Gen_Unit = Body_Unit
8076
                                and then True_Sloc (N) < Sloc (Orig_Body)))
8077
          and then Is_In_Main_Unit (Gen_Unit)
8078
          and then (Scope (Act_Id) = Scope (Gen_Id)
8079
                      or else
8080
                    Enclosing_Subp (Act_Id) = Enclosing_Subp (Gen_Id)));
8081
 
8082
      --  If this is an early instantiation, the freeze node is placed after
8083
      --  the generic body. Otherwise, if the generic appears in an instance,
8084
      --  we cannot freeze the current instance until the outer one is frozen.
8085
      --  This is only relevant if the current instance is nested within some
8086
      --  inner scope not itself within the outer instance. If this scope is
8087
      --  a package body in the same declarative part as the outer instance,
8088
      --  then that body needs to be frozen after the outer instance. Finally,
8089
      --  if no delay is needed, we place the freeze node at the end of the
8090
      --  current declarative part.
8091
 
8092
      if Expander_Active then
8093
         Ensure_Freeze_Node (Act_Id);
8094
         F_Node := Freeze_Node (Act_Id);
8095
 
8096
         if Must_Delay then
8097
            Insert_After (Orig_Body, F_Node);
8098
 
8099
         elsif Is_Generic_Instance (Par)
8100
           and then Present (Freeze_Node (Par))
8101
           and then Scope (Act_Id) /= Par
8102
         then
8103
            --  Freeze instance of inner generic after instance of enclosing
8104
            --  generic.
8105
 
8106
            if In_Same_Declarative_Part (Freeze_Node (Par), N) then
8107
 
8108
               --  Handle the following case:
8109
 
8110
               --    package Parent_Inst is new ...
8111
               --    Parent_Inst []
8112
 
8113
               --    procedure P ...  --  this body freezes Parent_Inst
8114
 
8115
               --    package Inst is new ...
8116
 
8117
               --  In this particular scenario, the freeze node for Inst must
8118
               --  be inserted in the same manner as that of Parent_Inst -
8119
               --  before the next source body or at the end of the declarative
8120
               --  list (body not available). If body P did not exist and
8121
               --  Parent_Inst was frozen after Inst, either by a body
8122
               --  following Inst or at the end of the declarative region, the
8123
               --  freeze node for Inst must be inserted after that of
8124
               --  Parent_Inst. This relation is established by comparing the
8125
               --  Slocs of Parent_Inst freeze node and Inst.
8126
 
8127
               if List_Containing (Get_Package_Instantiation_Node (Par)) =
8128
                  List_Containing (N)
8129
                 and then Sloc (Freeze_Node (Par)) < Sloc (N)
8130
               then
8131
                  Insert_Freeze_Node_For_Instance (N, F_Node);
8132
               else
8133
                  Insert_After (Freeze_Node (Par), F_Node);
8134
               end if;
8135
 
8136
            --  Freeze package enclosing instance of inner generic after
8137
            --  instance of enclosing generic.
8138
 
8139
            elsif Nkind_In (Parent (N), N_Package_Body, N_Subprogram_Body)
8140
              and then In_Same_Declarative_Part (Freeze_Node (Par), Parent (N))
8141
            then
8142
               declare
8143
                  Enclosing :  Entity_Id;
8144
 
8145
               begin
8146
                  Enclosing := Corresponding_Spec (Parent (N));
8147
 
8148
                  if No (Enclosing) then
8149
                     Enclosing := Defining_Entity (Parent (N));
8150
                  end if;
8151
 
8152
                  Insert_Freeze_Node_For_Instance (N, F_Node);
8153
                  Ensure_Freeze_Node (Enclosing);
8154
 
8155
                  if not Is_List_Member (Freeze_Node (Enclosing)) then
8156
 
8157
                     --  The enclosing context is a subunit, insert the freeze
8158
                     --  node after the stub.
8159
 
8160
                     if Nkind (Parent (Parent (N))) = N_Subunit then
8161
                        Insert_Freeze_Node_For_Instance
8162
                          (Corresponding_Stub (Parent (Parent (N))),
8163
                           Freeze_Node (Enclosing));
8164
 
8165
                     --  The enclosing context is a package with a stub body
8166
                     --  which has already been replaced by the real body.
8167
                     --  Insert the freeze node after the actual body.
8168
 
8169
                     elsif Ekind (Enclosing) = E_Package
8170
                       and then Present (Body_Entity (Enclosing))
8171
                       and then Was_Originally_Stub
8172
                                  (Parent (Body_Entity (Enclosing)))
8173
                     then
8174
                        Insert_Freeze_Node_For_Instance
8175
                          (Parent (Body_Entity (Enclosing)),
8176
                           Freeze_Node (Enclosing));
8177
 
8178
                     --  The parent instance has been frozen before the body of
8179
                     --  the enclosing package, insert the freeze node after
8180
                     --  the body.
8181
 
8182
                     elsif List_Containing (Freeze_Node (Par)) =
8183
                           List_Containing (Parent (N))
8184
                       and then Sloc (Freeze_Node (Par)) < Sloc (Parent (N))
8185
                     then
8186
                        Insert_Freeze_Node_For_Instance
8187
                          (Parent (N), Freeze_Node (Enclosing));
8188
 
8189
                     else
8190
                        Insert_After
8191
                          (Freeze_Node (Par), Freeze_Node (Enclosing));
8192
                     end if;
8193
                  end if;
8194
               end;
8195
 
8196
            else
8197
               Insert_Freeze_Node_For_Instance (N, F_Node);
8198
            end if;
8199
 
8200
         else
8201
            Insert_Freeze_Node_For_Instance (N, F_Node);
8202
         end if;
8203
      end if;
8204
 
8205
      Set_Is_Frozen (Act_Id);
8206
      Insert_Before (N, Act_Body);
8207
      Mark_Rewrite_Insertion (Act_Body);
8208
   end Install_Body;
8209
 
8210
   -----------------------------
8211
   -- Install_Formal_Packages --
8212
   -----------------------------
8213
 
8214
   procedure Install_Formal_Packages (Par : Entity_Id) is
8215
      E     : Entity_Id;
8216
      Gen   : Entity_Id;
8217
      Gen_E : Entity_Id := Empty;
8218
 
8219
   begin
8220
      E := First_Entity (Par);
8221
 
8222
      --  If we are installing an instance parent, locate the formal packages
8223
      --  of its generic parent.
8224
 
8225
      if Is_Generic_Instance (Par) then
8226
         Gen   := Generic_Parent (Specification (Unit_Declaration_Node (Par)));
8227
         Gen_E := First_Entity (Gen);
8228
      end if;
8229
 
8230
      while Present (E) loop
8231
         if Ekind (E) = E_Package
8232
           and then Nkind (Parent (E)) = N_Package_Renaming_Declaration
8233
         then
8234
            --  If this is the renaming for the parent instance, done
8235
 
8236
            if Renamed_Object (E) = Par then
8237
               exit;
8238
 
8239
            --  The visibility of a formal of an enclosing generic is already
8240
            --  correct.
8241
 
8242
            elsif Denotes_Formal_Package (E) then
8243
               null;
8244
 
8245
            elsif Present (Associated_Formal_Package (E)) then
8246
               Check_Generic_Actuals (Renamed_Object (E), True);
8247
               Set_Is_Hidden (E, False);
8248
 
8249
               --  Find formal package in generic unit that corresponds to
8250
               --  (instance of) formal package in instance.
8251
 
8252
               while Present (Gen_E) and then Chars (Gen_E) /= Chars (E) loop
8253
                  Next_Entity (Gen_E);
8254
               end loop;
8255
 
8256
               if Present (Gen_E) then
8257
                  Map_Formal_Package_Entities (Gen_E, E);
8258
               end if;
8259
            end if;
8260
         end if;
8261
 
8262
         Next_Entity (E);
8263
         if Present (Gen_E) then
8264
            Next_Entity (Gen_E);
8265
         end if;
8266
      end loop;
8267
   end Install_Formal_Packages;
8268
 
8269
   --------------------
8270
   -- Install_Parent --
8271
   --------------------
8272
 
8273
   procedure Install_Parent (P : Entity_Id; In_Body : Boolean := False) is
8274
      Ancestors : constant Elist_Id  := New_Elmt_List;
8275
      S         : constant Entity_Id := Current_Scope;
8276
      Inst_Par  : Entity_Id;
8277
      First_Par : Entity_Id;
8278
      Inst_Node : Node_Id;
8279
      Gen_Par   : Entity_Id;
8280
      First_Gen : Entity_Id;
8281
      Elmt      : Elmt_Id;
8282
 
8283
      procedure Install_Noninstance_Specs (Par : Entity_Id);
8284
      --  Install the scopes of noninstance parent units ending with Par
8285
 
8286
      procedure Install_Spec (Par : Entity_Id);
8287
      --  The child unit is within the declarative part of the parent, so
8288
      --  the declarations within the parent are immediately visible.
8289
 
8290
      -------------------------------
8291
      -- Install_Noninstance_Specs --
8292
      -------------------------------
8293
 
8294
      procedure Install_Noninstance_Specs (Par : Entity_Id) is
8295
      begin
8296
         if Present (Par)
8297
           and then Par /= Standard_Standard
8298
           and then not In_Open_Scopes (Par)
8299
         then
8300
            Install_Noninstance_Specs (Scope (Par));
8301
            Install_Spec (Par);
8302
         end if;
8303
      end Install_Noninstance_Specs;
8304
 
8305
      ------------------
8306
      -- Install_Spec --
8307
      ------------------
8308
 
8309
      procedure Install_Spec (Par : Entity_Id) is
8310
         Spec : constant Node_Id :=
8311
                  Specification (Unit_Declaration_Node (Par));
8312
 
8313
      begin
8314
         --  If this parent of the child instance is a top-level unit,
8315
         --  then record the unit and its visibility for later resetting
8316
         --  in Remove_Parent. We exclude units that are generic instances,
8317
         --  as we only want to record this information for the ultimate
8318
         --  top-level noninstance parent (is that always correct???).
8319
 
8320
         if Scope (Par) = Standard_Standard
8321
           and then not Is_Generic_Instance (Par)
8322
         then
8323
            Parent_Unit_Visible := Is_Immediately_Visible (Par);
8324
            Instance_Parent_Unit := Par;
8325
         end if;
8326
 
8327
         --  Open the parent scope and make it and its declarations visible.
8328
         --  If this point is not within a body, then only the visible
8329
         --  declarations should be made visible, and installation of the
8330
         --  private declarations is deferred until the appropriate point
8331
         --  within analysis of the spec being instantiated (see the handling
8332
         --  of parent visibility in Analyze_Package_Specification). This is
8333
         --  relaxed in the case where the parent unit is Ada.Tags, to avoid
8334
         --  private view problems that occur when compiling instantiations of
8335
         --  a generic child of that package (Generic_Dispatching_Constructor).
8336
         --  If the instance freezes a tagged type, inlinings of operations
8337
         --  from Ada.Tags may need the full view of type Tag. If inlining took
8338
         --  proper account of establishing visibility of inlined subprograms'
8339
         --  parents then it should be possible to remove this
8340
         --  special check. ???
8341
 
8342
         Push_Scope (Par);
8343
         Set_Is_Immediately_Visible   (Par);
8344
         Install_Visible_Declarations (Par);
8345
         Set_Use (Visible_Declarations (Spec));
8346
 
8347
         if In_Body or else Is_RTU (Par, Ada_Tags) then
8348
            Install_Private_Declarations (Par);
8349
            Set_Use (Private_Declarations (Spec));
8350
         end if;
8351
      end Install_Spec;
8352
 
8353
   --  Start of processing for Install_Parent
8354
 
8355
   begin
8356
      --  We need to install the parent instance to compile the instantiation
8357
      --  of the child, but the child instance must appear in the current
8358
      --  scope. Given that we cannot place the parent above the current scope
8359
      --  in the scope stack, we duplicate the current scope and unstack both
8360
      --  after the instantiation is complete.
8361
 
8362
      --  If the parent is itself the instantiation of a child unit, we must
8363
      --  also stack the instantiation of its parent, and so on. Each such
8364
      --  ancestor is the prefix of the name in a prior instantiation.
8365
 
8366
      --  If this is a nested instance, the parent unit itself resolves to
8367
      --  a renaming of the parent instance, whose declaration we need.
8368
 
8369
      --  Finally, the parent may be a generic (not an instance) when the
8370
      --  child unit appears as a formal package.
8371
 
8372
      Inst_Par := P;
8373
 
8374
      if Present (Renamed_Entity (Inst_Par)) then
8375
         Inst_Par := Renamed_Entity (Inst_Par);
8376
      end if;
8377
 
8378
      First_Par := Inst_Par;
8379
 
8380
      Gen_Par :=
8381
        Generic_Parent (Specification (Unit_Declaration_Node (Inst_Par)));
8382
 
8383
      First_Gen := Gen_Par;
8384
 
8385
      while Present (Gen_Par)
8386
        and then Is_Child_Unit (Gen_Par)
8387
      loop
8388
         --  Load grandparent instance as well
8389
 
8390
         Inst_Node := Get_Package_Instantiation_Node (Inst_Par);
8391
 
8392
         if Nkind (Name (Inst_Node)) = N_Expanded_Name then
8393
            Inst_Par := Entity (Prefix (Name (Inst_Node)));
8394
 
8395
            if Present (Renamed_Entity (Inst_Par)) then
8396
               Inst_Par := Renamed_Entity (Inst_Par);
8397
            end if;
8398
 
8399
            Gen_Par :=
8400
              Generic_Parent
8401
                (Specification (Unit_Declaration_Node (Inst_Par)));
8402
 
8403
            if Present (Gen_Par) then
8404
               Prepend_Elmt (Inst_Par, Ancestors);
8405
 
8406
            else
8407
               --  Parent is not the name of an instantiation
8408
 
8409
               Install_Noninstance_Specs (Inst_Par);
8410
               exit;
8411
            end if;
8412
 
8413
         else
8414
            --  Previous error
8415
 
8416
            exit;
8417
         end if;
8418
      end loop;
8419
 
8420
      if Present (First_Gen) then
8421
         Append_Elmt (First_Par, Ancestors);
8422
      else
8423
         Install_Noninstance_Specs (First_Par);
8424
      end if;
8425
 
8426
      if not Is_Empty_Elmt_List (Ancestors) then
8427
         Elmt := First_Elmt (Ancestors);
8428
         while Present (Elmt) loop
8429
            Install_Spec (Node (Elmt));
8430
            Install_Formal_Packages (Node (Elmt));
8431
            Next_Elmt (Elmt);
8432
         end loop;
8433
      end if;
8434
 
8435
      if not In_Body then
8436
         Push_Scope (S);
8437
      end if;
8438
   end Install_Parent;
8439
 
8440
   -------------------------------
8441
   -- Install_Hidden_Primitives --
8442
   -------------------------------
8443
 
8444
   procedure Install_Hidden_Primitives
8445
     (Prims_List : in out Elist_Id;
8446
      Gen_T      : Entity_Id;
8447
      Act_T      : Entity_Id)
8448
   is
8449
      Elmt        : Elmt_Id;
8450
      List        : Elist_Id := No_Elist;
8451
      Prim_G_Elmt : Elmt_Id;
8452
      Prim_A_Elmt : Elmt_Id;
8453
      Prim_G      : Node_Id;
8454
      Prim_A      : Node_Id;
8455
 
8456
   begin
8457
      --  No action needed in case of serious errors because we cannot trust
8458
      --  in the order of primitives
8459
 
8460
      if Serious_Errors_Detected > 0 then
8461
         return;
8462
 
8463
      --  No action possible if we don't have available the list of primitive
8464
      --  operations
8465
 
8466
      elsif No (Gen_T)
8467
        or else not Is_Record_Type (Gen_T)
8468
        or else not Is_Tagged_Type (Gen_T)
8469
        or else not Is_Record_Type (Act_T)
8470
        or else not Is_Tagged_Type (Act_T)
8471
      then
8472
         return;
8473
 
8474
      --  There is no need to handle interface types since their primitives
8475
      --  cannot be hidden
8476
 
8477
      elsif Is_Interface (Gen_T) then
8478
         return;
8479
      end if;
8480
 
8481
      Prim_G_Elmt := First_Elmt (Primitive_Operations (Gen_T));
8482
 
8483
      if not Is_Class_Wide_Type (Act_T) then
8484
         Prim_A_Elmt := First_Elmt (Primitive_Operations (Act_T));
8485
      else
8486
         Prim_A_Elmt := First_Elmt (Primitive_Operations (Root_Type (Act_T)));
8487
      end if;
8488
 
8489
      loop
8490
         --  Skip predefined primitives in the generic formal
8491
 
8492
         while Present (Prim_G_Elmt)
8493
           and then Is_Predefined_Dispatching_Operation (Node (Prim_G_Elmt))
8494
         loop
8495
            Next_Elmt (Prim_G_Elmt);
8496
         end loop;
8497
 
8498
         --  Skip predefined primitives in the generic actual
8499
 
8500
         while Present (Prim_A_Elmt)
8501
           and then Is_Predefined_Dispatching_Operation (Node (Prim_A_Elmt))
8502
         loop
8503
            Next_Elmt (Prim_A_Elmt);
8504
         end loop;
8505
 
8506
         exit when No (Prim_G_Elmt) or else No (Prim_A_Elmt);
8507
 
8508
         Prim_G := Node (Prim_G_Elmt);
8509
         Prim_A := Node (Prim_A_Elmt);
8510
 
8511
         --  There is no need to handle interface primitives because their
8512
         --  primitives are not hidden
8513
 
8514
         exit when Present (Interface_Alias (Prim_G));
8515
 
8516
         --  Here we install one hidden primitive
8517
 
8518
         if Chars (Prim_G) /= Chars (Prim_A)
8519
           and then Has_Suffix (Prim_A, 'P')
8520
           and then Remove_Suffix (Prim_A, 'P') = Chars (Prim_G)
8521
         then
8522
            Set_Chars (Prim_A, Chars (Prim_G));
8523
 
8524
            if List = No_Elist then
8525
               List := New_Elmt_List;
8526
            end if;
8527
 
8528
            Append_Elmt (Prim_A, List);
8529
         end if;
8530
 
8531
         Next_Elmt (Prim_A_Elmt);
8532
         Next_Elmt (Prim_G_Elmt);
8533
      end loop;
8534
 
8535
      --  Append the elements to the list of temporarily visible primitives
8536
      --  avoiding duplicates.
8537
 
8538
      if Present (List) then
8539
         if No (Prims_List) then
8540
            Prims_List := New_Elmt_List;
8541
         end if;
8542
 
8543
         Elmt := First_Elmt (List);
8544
         while Present (Elmt) loop
8545
            Append_Unique_Elmt (Node (Elmt), Prims_List);
8546
            Next_Elmt (Elmt);
8547
         end loop;
8548
      end if;
8549
   end Install_Hidden_Primitives;
8550
 
8551
   -------------------------------
8552
   -- Restore_Hidden_Primitives --
8553
   -------------------------------
8554
 
8555
   procedure Restore_Hidden_Primitives (Prims_List : in out Elist_Id) is
8556
      Prim_Elmt : Elmt_Id;
8557
      Prim      : Node_Id;
8558
 
8559
   begin
8560
      if Prims_List /= No_Elist then
8561
         Prim_Elmt := First_Elmt (Prims_List);
8562
         while Present (Prim_Elmt) loop
8563
            Prim := Node (Prim_Elmt);
8564
            Set_Chars (Prim, Add_Suffix (Prim, 'P'));
8565
            Next_Elmt (Prim_Elmt);
8566
         end loop;
8567
 
8568
         Prims_List := No_Elist;
8569
      end if;
8570
   end Restore_Hidden_Primitives;
8571
 
8572
   --------------------------------
8573
   -- Instantiate_Formal_Package --
8574
   --------------------------------
8575
 
8576
   function Instantiate_Formal_Package
8577
     (Formal          : Node_Id;
8578
      Actual          : Node_Id;
8579
      Analyzed_Formal : Node_Id) return List_Id
8580
   is
8581
      Loc         : constant Source_Ptr := Sloc (Actual);
8582
      Actual_Pack : Entity_Id;
8583
      Formal_Pack : Entity_Id;
8584
      Gen_Parent  : Entity_Id;
8585
      Decls       : List_Id;
8586
      Nod         : Node_Id;
8587
      Parent_Spec : Node_Id;
8588
 
8589
      procedure Find_Matching_Actual
8590
       (F    : Node_Id;
8591
        Act  : in out Entity_Id);
8592
      --  We need to associate each formal entity in the formal package
8593
      --  with the corresponding entity in the actual package. The actual
8594
      --  package has been analyzed and possibly expanded, and as a result
8595
      --  there is no one-to-one correspondence between the two lists (for
8596
      --  example, the actual may include subtypes, itypes, and inherited
8597
      --  primitive operations, interspersed among the renaming declarations
8598
      --  for the actuals) . We retrieve the corresponding actual by name
8599
      --  because each actual has the same name as the formal, and they do
8600
      --  appear in the same order.
8601
 
8602
      function Get_Formal_Entity (N : Node_Id) return Entity_Id;
8603
      --  Retrieve entity of defining entity of  generic formal parameter.
8604
      --  Only the declarations of formals need to be considered when
8605
      --  linking them to actuals, but the declarative list may include
8606
      --  internal entities generated during analysis, and those are ignored.
8607
 
8608
      procedure Match_Formal_Entity
8609
        (Formal_Node : Node_Id;
8610
         Formal_Ent  : Entity_Id;
8611
         Actual_Ent  : Entity_Id);
8612
      --  Associates the formal entity with the actual. In the case
8613
      --  where Formal_Ent is a formal package, this procedure iterates
8614
      --  through all of its formals and enters associations between the
8615
      --  actuals occurring in the formal package's corresponding actual
8616
      --  package (given by Actual_Ent) and the formal package's formal
8617
      --  parameters. This procedure recurses if any of the parameters is
8618
      --  itself a package.
8619
 
8620
      function Is_Instance_Of
8621
        (Act_Spec : Entity_Id;
8622
         Gen_Anc  : Entity_Id) return Boolean;
8623
      --  The actual can be an instantiation of a generic within another
8624
      --  instance, in which case there is no direct link from it to the
8625
      --  original generic ancestor. In that case, we recognize that the
8626
      --  ultimate ancestor is the same by examining names and scopes.
8627
 
8628
      procedure Process_Nested_Formal (Formal : Entity_Id);
8629
      --  If the current formal is declared with a box, its own formals are
8630
      --  visible in the instance, as they were in the generic, and their
8631
      --  Hidden flag must be reset. If some of these formals are themselves
8632
      --  packages declared with a box, the processing must be recursive.
8633
 
8634
      --------------------------
8635
      -- Find_Matching_Actual --
8636
      --------------------------
8637
 
8638
      procedure Find_Matching_Actual
8639
        (F   : Node_Id;
8640
         Act : in out Entity_Id)
8641
     is
8642
         Formal_Ent : Entity_Id;
8643
 
8644
      begin
8645
         case Nkind (Original_Node (F)) is
8646
            when N_Formal_Object_Declaration |
8647
                 N_Formal_Type_Declaration   =>
8648
               Formal_Ent := Defining_Identifier (F);
8649
 
8650
               while Chars (Act) /= Chars (Formal_Ent) loop
8651
                  Next_Entity (Act);
8652
               end loop;
8653
 
8654
            when N_Formal_Subprogram_Declaration |
8655
                 N_Formal_Package_Declaration    |
8656
                 N_Package_Declaration           |
8657
                 N_Generic_Package_Declaration   =>
8658
               Formal_Ent := Defining_Entity (F);
8659
 
8660
               while Chars (Act) /= Chars (Formal_Ent) loop
8661
                  Next_Entity (Act);
8662
               end loop;
8663
 
8664
            when others =>
8665
               raise Program_Error;
8666
         end case;
8667
      end Find_Matching_Actual;
8668
 
8669
      -------------------------
8670
      -- Match_Formal_Entity --
8671
      -------------------------
8672
 
8673
      procedure Match_Formal_Entity
8674
        (Formal_Node : Node_Id;
8675
         Formal_Ent  : Entity_Id;
8676
         Actual_Ent  : Entity_Id)
8677
      is
8678
         Act_Pkg   : Entity_Id;
8679
 
8680
      begin
8681
         Set_Instance_Of (Formal_Ent, Actual_Ent);
8682
 
8683
         if Ekind (Actual_Ent) = E_Package then
8684
 
8685
            --  Record associations for each parameter
8686
 
8687
            Act_Pkg := Actual_Ent;
8688
 
8689
            declare
8690
               A_Ent  : Entity_Id := First_Entity (Act_Pkg);
8691
               F_Ent  : Entity_Id;
8692
               F_Node : Node_Id;
8693
 
8694
               Gen_Decl : Node_Id;
8695
               Formals  : List_Id;
8696
               Actual   : Entity_Id;
8697
 
8698
            begin
8699
               --  Retrieve the actual given in the formal package declaration
8700
 
8701
               Actual := Entity (Name (Original_Node (Formal_Node)));
8702
 
8703
               --  The actual in the formal package declaration  may be a
8704
               --  renamed generic package, in which case we want to retrieve
8705
               --  the original generic in order to traverse its formal part.
8706
 
8707
               if Present (Renamed_Entity (Actual)) then
8708
                  Gen_Decl := Unit_Declaration_Node (Renamed_Entity (Actual));
8709
               else
8710
                  Gen_Decl := Unit_Declaration_Node (Actual);
8711
               end if;
8712
 
8713
               Formals := Generic_Formal_Declarations (Gen_Decl);
8714
 
8715
               if Present (Formals) then
8716
                  F_Node := First_Non_Pragma (Formals);
8717
               else
8718
                  F_Node := Empty;
8719
               end if;
8720
 
8721
               while Present (A_Ent)
8722
                 and then Present (F_Node)
8723
                 and then A_Ent /= First_Private_Entity (Act_Pkg)
8724
               loop
8725
                  F_Ent := Get_Formal_Entity (F_Node);
8726
 
8727
                  if Present (F_Ent) then
8728
 
8729
                     --  This is a formal of the original package. Record
8730
                     --  association and recurse.
8731
 
8732
                     Find_Matching_Actual (F_Node, A_Ent);
8733
                     Match_Formal_Entity (F_Node, F_Ent, A_Ent);
8734
                     Next_Entity (A_Ent);
8735
                  end if;
8736
 
8737
                  Next_Non_Pragma (F_Node);
8738
               end loop;
8739
            end;
8740
         end if;
8741
      end Match_Formal_Entity;
8742
 
8743
      -----------------------
8744
      -- Get_Formal_Entity --
8745
      -----------------------
8746
 
8747
      function Get_Formal_Entity (N : Node_Id) return Entity_Id is
8748
         Kind : constant Node_Kind := Nkind (Original_Node (N));
8749
      begin
8750
         case Kind is
8751
            when N_Formal_Object_Declaration     =>
8752
               return Defining_Identifier (N);
8753
 
8754
            when N_Formal_Type_Declaration       =>
8755
               return Defining_Identifier (N);
8756
 
8757
            when N_Formal_Subprogram_Declaration =>
8758
               return Defining_Unit_Name (Specification (N));
8759
 
8760
            when N_Formal_Package_Declaration    =>
8761
               return Defining_Identifier (Original_Node (N));
8762
 
8763
            when N_Generic_Package_Declaration   =>
8764
               return Defining_Identifier (Original_Node (N));
8765
 
8766
            --  All other declarations are introduced by semantic analysis and
8767
            --  have no match in the actual.
8768
 
8769
            when others =>
8770
               return Empty;
8771
         end case;
8772
      end Get_Formal_Entity;
8773
 
8774
      --------------------
8775
      -- Is_Instance_Of --
8776
      --------------------
8777
 
8778
      function Is_Instance_Of
8779
        (Act_Spec : Entity_Id;
8780
         Gen_Anc  : Entity_Id) return Boolean
8781
      is
8782
         Gen_Par : constant Entity_Id := Generic_Parent (Act_Spec);
8783
 
8784
      begin
8785
         if No (Gen_Par) then
8786
            return False;
8787
 
8788
         --  Simplest case: the generic parent of the actual is the formal
8789
 
8790
         elsif Gen_Par = Gen_Anc then
8791
            return True;
8792
 
8793
         elsif Chars (Gen_Par) /= Chars (Gen_Anc) then
8794
            return False;
8795
 
8796
         --  The actual may be obtained through several instantiations. Its
8797
         --  scope must itself be an instance of a generic declared in the
8798
         --  same scope as the formal. Any other case is detected above.
8799
 
8800
         elsif not Is_Generic_Instance (Scope (Gen_Par)) then
8801
            return False;
8802
 
8803
         else
8804
            return Generic_Parent (Parent (Scope (Gen_Par))) = Scope (Gen_Anc);
8805
         end if;
8806
      end Is_Instance_Of;
8807
 
8808
      ---------------------------
8809
      -- Process_Nested_Formal --
8810
      ---------------------------
8811
 
8812
      procedure Process_Nested_Formal (Formal : Entity_Id) is
8813
         Ent : Entity_Id;
8814
 
8815
      begin
8816
         if Present (Associated_Formal_Package (Formal))
8817
           and then Box_Present (Parent (Associated_Formal_Package (Formal)))
8818
         then
8819
            Ent := First_Entity (Formal);
8820
            while Present (Ent) loop
8821
               Set_Is_Hidden (Ent, False);
8822
               Set_Is_Visible_Formal (Ent);
8823
               Set_Is_Potentially_Use_Visible
8824
                 (Ent, Is_Potentially_Use_Visible (Formal));
8825
 
8826
               if Ekind (Ent) = E_Package then
8827
                  exit when Renamed_Entity (Ent) = Renamed_Entity (Formal);
8828
                  Process_Nested_Formal (Ent);
8829
               end if;
8830
 
8831
               Next_Entity (Ent);
8832
            end loop;
8833
         end if;
8834
      end Process_Nested_Formal;
8835
 
8836
   --  Start of processing for Instantiate_Formal_Package
8837
 
8838
   begin
8839
      Analyze (Actual);
8840
 
8841
      if not Is_Entity_Name (Actual)
8842
        or else  Ekind (Entity (Actual)) /= E_Package
8843
      then
8844
         Error_Msg_N
8845
           ("expect package instance to instantiate formal", Actual);
8846
         Abandon_Instantiation (Actual);
8847
         raise Program_Error;
8848
 
8849
      else
8850
         Actual_Pack := Entity (Actual);
8851
         Set_Is_Instantiated (Actual_Pack);
8852
 
8853
         --  The actual may be a renamed package, or an outer generic formal
8854
         --  package whose instantiation is converted into a renaming.
8855
 
8856
         if Present (Renamed_Object (Actual_Pack)) then
8857
            Actual_Pack := Renamed_Object (Actual_Pack);
8858
         end if;
8859
 
8860
         if Nkind (Analyzed_Formal) = N_Formal_Package_Declaration then
8861
            Gen_Parent  := Get_Instance_Of (Entity (Name (Analyzed_Formal)));
8862
            Formal_Pack := Defining_Identifier (Analyzed_Formal);
8863
         else
8864
            Gen_Parent :=
8865
              Generic_Parent (Specification (Analyzed_Formal));
8866
            Formal_Pack :=
8867
              Defining_Unit_Name (Specification (Analyzed_Formal));
8868
         end if;
8869
 
8870
         if Nkind (Parent (Actual_Pack)) = N_Defining_Program_Unit_Name then
8871
            Parent_Spec := Specification (Unit_Declaration_Node (Actual_Pack));
8872
         else
8873
            Parent_Spec := Parent (Actual_Pack);
8874
         end if;
8875
 
8876
         if Gen_Parent = Any_Id then
8877
            Error_Msg_N
8878
              ("previous error in declaration of formal package", Actual);
8879
            Abandon_Instantiation (Actual);
8880
 
8881
         elsif
8882
           Is_Instance_Of (Parent_Spec, Get_Instance_Of (Gen_Parent))
8883
         then
8884
            null;
8885
 
8886
         else
8887
            Error_Msg_NE
8888
              ("actual parameter must be instance of&", Actual, Gen_Parent);
8889
            Abandon_Instantiation (Actual);
8890
         end if;
8891
 
8892
         Set_Instance_Of (Defining_Identifier (Formal), Actual_Pack);
8893
         Map_Formal_Package_Entities (Formal_Pack, Actual_Pack);
8894
 
8895
         Nod :=
8896
           Make_Package_Renaming_Declaration (Loc,
8897
             Defining_Unit_Name => New_Copy (Defining_Identifier (Formal)),
8898
             Name               => New_Reference_To (Actual_Pack, Loc));
8899
 
8900
         Set_Associated_Formal_Package (Defining_Unit_Name (Nod),
8901
           Defining_Identifier (Formal));
8902
         Decls := New_List (Nod);
8903
 
8904
         --  If the formal F has a box, then the generic declarations are
8905
         --  visible in the generic G. In an instance of G, the corresponding
8906
         --  entities in the actual for F (which are the actuals for the
8907
         --  instantiation of the generic that F denotes) must also be made
8908
         --  visible for analysis of the current instance. On exit from the
8909
         --  current instance, those entities are made private again. If the
8910
         --  actual is currently in use, these entities are also use-visible.
8911
 
8912
         --  The loop through the actual entities also steps through the formal
8913
         --  entities and enters associations from formals to actuals into the
8914
         --  renaming map. This is necessary to properly handle checking of
8915
         --  actual parameter associations for later formals that depend on
8916
         --  actuals declared in the formal package.
8917
 
8918
         --  In Ada 2005, partial parametrization requires that we make visible
8919
         --  the actuals corresponding to formals that were defaulted in the
8920
         --  formal package. There formals are identified because they remain
8921
         --  formal generics within the formal package, rather than being
8922
         --  renamings of the actuals supplied.
8923
 
8924
         declare
8925
            Gen_Decl : constant Node_Id :=
8926
                         Unit_Declaration_Node (Gen_Parent);
8927
            Formals  : constant List_Id :=
8928
                         Generic_Formal_Declarations (Gen_Decl);
8929
 
8930
            Actual_Ent       : Entity_Id;
8931
            Actual_Of_Formal : Node_Id;
8932
            Formal_Node      : Node_Id;
8933
            Formal_Ent       : Entity_Id;
8934
 
8935
         begin
8936
            if Present (Formals) then
8937
               Formal_Node := First_Non_Pragma (Formals);
8938
            else
8939
               Formal_Node := Empty;
8940
            end if;
8941
 
8942
            Actual_Ent := First_Entity (Actual_Pack);
8943
            Actual_Of_Formal :=
8944
               First (Visible_Declarations (Specification (Analyzed_Formal)));
8945
            while Present (Actual_Ent)
8946
              and then Actual_Ent /= First_Private_Entity (Actual_Pack)
8947
            loop
8948
               if Present (Formal_Node) then
8949
                  Formal_Ent := Get_Formal_Entity (Formal_Node);
8950
 
8951
                  if Present (Formal_Ent) then
8952
                     Find_Matching_Actual (Formal_Node, Actual_Ent);
8953
                     Match_Formal_Entity
8954
                       (Formal_Node, Formal_Ent, Actual_Ent);
8955
 
8956
                     --  We iterate at the same time over the actuals of the
8957
                     --  local package created for the formal, to determine
8958
                     --  which one of the formals of the original generic were
8959
                     --  defaulted in the formal. The corresponding actual
8960
                     --  entities are visible in the enclosing instance.
8961
 
8962
                     if Box_Present (Formal)
8963
                       or else
8964
                         (Present (Actual_Of_Formal)
8965
                           and then
8966
                             Is_Generic_Formal
8967
                               (Get_Formal_Entity (Actual_Of_Formal)))
8968
                     then
8969
                        Set_Is_Hidden (Actual_Ent, False);
8970
                        Set_Is_Visible_Formal (Actual_Ent);
8971
                        Set_Is_Potentially_Use_Visible
8972
                          (Actual_Ent, In_Use (Actual_Pack));
8973
 
8974
                        if Ekind (Actual_Ent) = E_Package then
8975
                           Process_Nested_Formal (Actual_Ent);
8976
                        end if;
8977
 
8978
                     else
8979
                        Set_Is_Hidden (Actual_Ent);
8980
                        Set_Is_Potentially_Use_Visible (Actual_Ent, False);
8981
                     end if;
8982
                  end if;
8983
 
8984
                  Next_Non_Pragma (Formal_Node);
8985
                  Next (Actual_Of_Formal);
8986
 
8987
               else
8988
                  --  No further formals to match, but the generic part may
8989
                  --  contain inherited operation that are not hidden in the
8990
                  --  enclosing instance.
8991
 
8992
                  Next_Entity (Actual_Ent);
8993
               end if;
8994
            end loop;
8995
 
8996
            --  Inherited subprograms generated by formal derived types are
8997
            --  also visible if the types are.
8998
 
8999
            Actual_Ent := First_Entity (Actual_Pack);
9000
            while Present (Actual_Ent)
9001
              and then Actual_Ent /= First_Private_Entity (Actual_Pack)
9002
            loop
9003
               if Is_Overloadable (Actual_Ent)
9004
                 and then
9005
                   Nkind (Parent (Actual_Ent)) = N_Subtype_Declaration
9006
                 and then
9007
                   not Is_Hidden (Defining_Identifier (Parent (Actual_Ent)))
9008
               then
9009
                  Set_Is_Hidden (Actual_Ent, False);
9010
                  Set_Is_Potentially_Use_Visible
9011
                    (Actual_Ent, In_Use (Actual_Pack));
9012
               end if;
9013
 
9014
               Next_Entity (Actual_Ent);
9015
            end loop;
9016
         end;
9017
 
9018
         --  If the formal is not declared with a box, reanalyze it as an
9019
         --  abbreviated instantiation, to verify the matching rules of 12.7.
9020
         --  The actual checks are performed after the generic associations
9021
         --  have been analyzed, to guarantee the same visibility for this
9022
         --  instantiation and for the actuals.
9023
 
9024
         --  In Ada 2005, the generic associations for the formal can include
9025
         --  defaulted parameters. These are ignored during check. This
9026
         --  internal instantiation is removed from the tree after conformance
9027
         --  checking, because it contains formal declarations for those
9028
         --  defaulted parameters, and those should not reach the back-end.
9029
 
9030
         if not Box_Present (Formal) then
9031
            declare
9032
               I_Pack : constant Entity_Id :=
9033
                          Make_Temporary (Sloc (Actual), 'P');
9034
 
9035
            begin
9036
               Set_Is_Internal (I_Pack);
9037
 
9038
               Append_To (Decls,
9039
                 Make_Package_Instantiation (Sloc (Actual),
9040
                   Defining_Unit_Name => I_Pack,
9041
                   Name =>
9042
                     New_Occurrence_Of
9043
                       (Get_Instance_Of (Gen_Parent), Sloc (Actual)),
9044
                   Generic_Associations =>
9045
                     Generic_Associations (Formal)));
9046
            end;
9047
         end if;
9048
 
9049
         return Decls;
9050
      end if;
9051
   end Instantiate_Formal_Package;
9052
 
9053
   -----------------------------------
9054
   -- Instantiate_Formal_Subprogram --
9055
   -----------------------------------
9056
 
9057
   function Instantiate_Formal_Subprogram
9058
     (Formal          : Node_Id;
9059
      Actual          : Node_Id;
9060
      Analyzed_Formal : Node_Id) return Node_Id
9061
   is
9062
      Loc        : Source_Ptr;
9063
      Formal_Sub : constant Entity_Id :=
9064
                     Defining_Unit_Name (Specification (Formal));
9065
      Analyzed_S : constant Entity_Id :=
9066
                     Defining_Unit_Name (Specification (Analyzed_Formal));
9067
      Decl_Node  : Node_Id;
9068
      Nam        : Node_Id;
9069
      New_Spec   : Node_Id;
9070
 
9071
      function From_Parent_Scope (Subp : Entity_Id) return Boolean;
9072
      --  If the generic is a child unit, the parent has been installed on the
9073
      --  scope stack, but a default subprogram cannot resolve to something on
9074
      --  the parent because that parent is not really part of the visible
9075
      --  context (it is there to resolve explicit local entities). If the
9076
      --  default has resolved in this way, we remove the entity from
9077
      --  immediate visibility and analyze the node again to emit an error
9078
      --  message or find another visible candidate.
9079
 
9080
      procedure Valid_Actual_Subprogram (Act : Node_Id);
9081
      --  Perform legality check and raise exception on failure
9082
 
9083
      -----------------------
9084
      -- From_Parent_Scope --
9085
      -----------------------
9086
 
9087
      function From_Parent_Scope (Subp : Entity_Id) return Boolean is
9088
         Gen_Scope : Node_Id;
9089
 
9090
      begin
9091
         Gen_Scope := Scope (Analyzed_S);
9092
         while Present (Gen_Scope) and then Is_Child_Unit (Gen_Scope) loop
9093
            if Scope (Subp) = Scope (Gen_Scope) then
9094
               return True;
9095
            end if;
9096
 
9097
            Gen_Scope := Scope (Gen_Scope);
9098
         end loop;
9099
 
9100
         return False;
9101
      end From_Parent_Scope;
9102
 
9103
      -----------------------------
9104
      -- Valid_Actual_Subprogram --
9105
      -----------------------------
9106
 
9107
      procedure Valid_Actual_Subprogram (Act : Node_Id) is
9108
         Act_E : Entity_Id;
9109
 
9110
      begin
9111
         if Is_Entity_Name (Act) then
9112
            Act_E := Entity (Act);
9113
 
9114
         elsif Nkind (Act) = N_Selected_Component
9115
           and then Is_Entity_Name (Selector_Name (Act))
9116
         then
9117
            Act_E := Entity (Selector_Name (Act));
9118
 
9119
         else
9120
            Act_E := Empty;
9121
         end if;
9122
 
9123
         if (Present (Act_E) and then Is_Overloadable (Act_E))
9124
           or else Nkind_In (Act, N_Attribute_Reference,
9125
                                  N_Indexed_Component,
9126
                                  N_Character_Literal,
9127
                                  N_Explicit_Dereference)
9128
         then
9129
            return;
9130
         end if;
9131
 
9132
         Error_Msg_NE
9133
           ("expect subprogram or entry name in instantiation of&",
9134
            Instantiation_Node, Formal_Sub);
9135
         Abandon_Instantiation (Instantiation_Node);
9136
 
9137
      end Valid_Actual_Subprogram;
9138
 
9139
   --  Start of processing for Instantiate_Formal_Subprogram
9140
 
9141
   begin
9142
      New_Spec := New_Copy_Tree (Specification (Formal));
9143
 
9144
      --  The tree copy has created the proper instantiation sloc for the
9145
      --  new specification. Use this location for all other constructed
9146
      --  declarations.
9147
 
9148
      Loc := Sloc (Defining_Unit_Name (New_Spec));
9149
 
9150
      --  Create new entity for the actual (New_Copy_Tree does not)
9151
 
9152
      Set_Defining_Unit_Name
9153
        (New_Spec, Make_Defining_Identifier (Loc, Chars (Formal_Sub)));
9154
 
9155
      --  Create new entities for the each of the formals in the
9156
      --  specification of the renaming declaration built for the actual.
9157
 
9158
      if Present (Parameter_Specifications (New_Spec)) then
9159
         declare
9160
            F : Node_Id;
9161
         begin
9162
            F := First (Parameter_Specifications (New_Spec));
9163
            while Present (F) loop
9164
               Set_Defining_Identifier (F,
9165
                  Make_Defining_Identifier (Sloc (F),
9166
                    Chars => Chars (Defining_Identifier (F))));
9167
               Next (F);
9168
            end loop;
9169
         end;
9170
      end if;
9171
 
9172
      --  Find entity of actual. If the actual is an attribute reference, it
9173
      --  cannot be resolved here (its formal is missing) but is handled
9174
      --  instead in Attribute_Renaming. If the actual is overloaded, it is
9175
      --  fully resolved subsequently, when the renaming declaration for the
9176
      --  formal is analyzed. If it is an explicit dereference, resolve the
9177
      --  prefix but not the actual itself, to prevent interpretation as call.
9178
 
9179
      if Present (Actual) then
9180
         Loc := Sloc (Actual);
9181
         Set_Sloc (New_Spec, Loc);
9182
 
9183
         if Nkind (Actual) = N_Operator_Symbol then
9184
            Find_Direct_Name (Actual);
9185
 
9186
         elsif Nkind (Actual) = N_Explicit_Dereference then
9187
            Analyze (Prefix (Actual));
9188
 
9189
         elsif Nkind (Actual) /= N_Attribute_Reference then
9190
            Analyze (Actual);
9191
         end if;
9192
 
9193
         Valid_Actual_Subprogram (Actual);
9194
         Nam := Actual;
9195
 
9196
      elsif Present (Default_Name (Formal)) then
9197
         if not Nkind_In (Default_Name (Formal), N_Attribute_Reference,
9198
                                                 N_Selected_Component,
9199
                                                 N_Indexed_Component,
9200
                                                 N_Character_Literal)
9201
           and then Present (Entity (Default_Name (Formal)))
9202
         then
9203
            Nam := New_Occurrence_Of (Entity (Default_Name (Formal)), Loc);
9204
         else
9205
            Nam := New_Copy (Default_Name (Formal));
9206
            Set_Sloc (Nam, Loc);
9207
         end if;
9208
 
9209
      elsif Box_Present (Formal) then
9210
 
9211
         --  Actual is resolved at the point of instantiation. Create an
9212
         --  identifier or operator with the same name as the formal.
9213
 
9214
         if Nkind (Formal_Sub) = N_Defining_Operator_Symbol then
9215
            Nam := Make_Operator_Symbol (Loc,
9216
              Chars =>  Chars (Formal_Sub),
9217
              Strval => No_String);
9218
         else
9219
            Nam := Make_Identifier (Loc, Chars (Formal_Sub));
9220
         end if;
9221
 
9222
      elsif Nkind (Specification (Formal)) = N_Procedure_Specification
9223
        and then Null_Present (Specification (Formal))
9224
      then
9225
         --  Generate null body for procedure, for use in the instance
9226
 
9227
         Decl_Node :=
9228
           Make_Subprogram_Body (Loc,
9229
             Specification              => New_Spec,
9230
             Declarations               => New_List,
9231
             Handled_Statement_Sequence =>
9232
               Make_Handled_Sequence_Of_Statements (Loc,
9233
                 Statements => New_List (Make_Null_Statement (Loc))));
9234
 
9235
         Set_Is_Intrinsic_Subprogram (Defining_Unit_Name (New_Spec));
9236
         return Decl_Node;
9237
 
9238
      else
9239
         Error_Msg_Sloc := Sloc (Scope (Analyzed_S));
9240
         Error_Msg_NE
9241
           ("missing actual&", Instantiation_Node, Formal_Sub);
9242
         Error_Msg_NE
9243
           ("\in instantiation of & declared#",
9244
              Instantiation_Node, Scope (Analyzed_S));
9245
         Abandon_Instantiation (Instantiation_Node);
9246
      end if;
9247
 
9248
      Decl_Node :=
9249
        Make_Subprogram_Renaming_Declaration (Loc,
9250
          Specification => New_Spec,
9251
          Name          => Nam);
9252
 
9253
      --  If we do not have an actual and the formal specified <> then set to
9254
      --  get proper default.
9255
 
9256
      if No (Actual) and then Box_Present (Formal) then
9257
         Set_From_Default (Decl_Node);
9258
      end if;
9259
 
9260
      --  Gather possible interpretations for the actual before analyzing the
9261
      --  instance. If overloaded, it will be resolved when analyzing the
9262
      --  renaming declaration.
9263
 
9264
      if Box_Present (Formal)
9265
        and then No (Actual)
9266
      then
9267
         Analyze (Nam);
9268
 
9269
         if Is_Child_Unit (Scope (Analyzed_S))
9270
           and then Present (Entity (Nam))
9271
         then
9272
            if not Is_Overloaded (Nam) then
9273
               if From_Parent_Scope (Entity (Nam)) then
9274
                  Set_Is_Immediately_Visible (Entity (Nam), False);
9275
                  Set_Entity (Nam, Empty);
9276
                  Set_Etype (Nam, Empty);
9277
 
9278
                  Analyze (Nam);
9279
                  Set_Is_Immediately_Visible (Entity (Nam));
9280
               end if;
9281
 
9282
            else
9283
               declare
9284
                  I  : Interp_Index;
9285
                  It : Interp;
9286
 
9287
               begin
9288
                  Get_First_Interp (Nam, I, It);
9289
                  while Present (It.Nam) loop
9290
                     if From_Parent_Scope (It.Nam) then
9291
                        Remove_Interp (I);
9292
                     end if;
9293
 
9294
                     Get_Next_Interp (I, It);
9295
                  end loop;
9296
               end;
9297
            end if;
9298
         end if;
9299
      end if;
9300
 
9301
      --  The generic instantiation freezes the actual. This can only be done
9302
      --  once the actual is resolved, in the analysis of the renaming
9303
      --  declaration. To make the formal subprogram entity available, we set
9304
      --  Corresponding_Formal_Spec to point to the formal subprogram entity.
9305
      --  This is also needed in Analyze_Subprogram_Renaming for the processing
9306
      --  of formal abstract subprograms.
9307
 
9308
      Set_Corresponding_Formal_Spec (Decl_Node, Analyzed_S);
9309
 
9310
      --  We cannot analyze the renaming declaration, and thus find the actual,
9311
      --  until all the actuals are assembled in the instance. For subsequent
9312
      --  checks of other actuals, indicate the node that will hold the
9313
      --  instance of this formal.
9314
 
9315
      Set_Instance_Of (Analyzed_S, Nam);
9316
 
9317
      if Nkind (Actual) = N_Selected_Component
9318
        and then Is_Task_Type (Etype (Prefix (Actual)))
9319
        and then not Is_Frozen (Etype (Prefix (Actual)))
9320
      then
9321
         --  The renaming declaration will create a body, which must appear
9322
         --  outside of the instantiation, We move the renaming declaration
9323
         --  out of the instance, and create an additional renaming inside,
9324
         --  to prevent freezing anomalies.
9325
 
9326
         declare
9327
            Anon_Id : constant Entity_Id := Make_Temporary (Loc, 'E');
9328
 
9329
         begin
9330
            Set_Defining_Unit_Name (New_Spec, Anon_Id);
9331
            Insert_Before (Instantiation_Node, Decl_Node);
9332
            Analyze (Decl_Node);
9333
 
9334
            --  Now create renaming within the instance
9335
 
9336
            Decl_Node :=
9337
              Make_Subprogram_Renaming_Declaration (Loc,
9338
                Specification => New_Copy_Tree (New_Spec),
9339
                Name => New_Occurrence_Of (Anon_Id, Loc));
9340
 
9341
            Set_Defining_Unit_Name (Specification (Decl_Node),
9342
              Make_Defining_Identifier (Loc, Chars (Formal_Sub)));
9343
         end;
9344
      end if;
9345
 
9346
      return Decl_Node;
9347
   end Instantiate_Formal_Subprogram;
9348
 
9349
   ------------------------
9350
   -- Instantiate_Object --
9351
   ------------------------
9352
 
9353
   function Instantiate_Object
9354
     (Formal          : Node_Id;
9355
      Actual          : Node_Id;
9356
      Analyzed_Formal : Node_Id) return List_Id
9357
   is
9358
      Gen_Obj     : constant Entity_Id  := Defining_Identifier (Formal);
9359
      A_Gen_Obj   : constant Entity_Id  :=
9360
                      Defining_Identifier (Analyzed_Formal);
9361
      Acc_Def     : Node_Id             := Empty;
9362
      Act_Assoc   : constant Node_Id    := Parent (Actual);
9363
      Actual_Decl : Node_Id             := Empty;
9364
      Decl_Node   : Node_Id;
9365
      Def         : Node_Id;
9366
      Ftyp        : Entity_Id;
9367
      List        : constant List_Id    := New_List;
9368
      Loc         : constant Source_Ptr := Sloc (Actual);
9369
      Orig_Ftyp   : constant Entity_Id  := Etype (A_Gen_Obj);
9370
      Subt_Decl   : Node_Id             := Empty;
9371
      Subt_Mark   : Node_Id             := Empty;
9372
 
9373
   begin
9374
      if Present (Subtype_Mark (Formal)) then
9375
         Subt_Mark := Subtype_Mark (Formal);
9376
      else
9377
         Check_Access_Definition (Formal);
9378
         Acc_Def := Access_Definition (Formal);
9379
      end if;
9380
 
9381
      --  Sloc for error message on missing actual
9382
 
9383
      Error_Msg_Sloc := Sloc (Scope (A_Gen_Obj));
9384
 
9385
      if Get_Instance_Of (Gen_Obj) /= Gen_Obj then
9386
         Error_Msg_N ("duplicate instantiation of generic parameter", Actual);
9387
      end if;
9388
 
9389
      Set_Parent (List, Parent (Actual));
9390
 
9391
      --  OUT present
9392
 
9393
      if Out_Present (Formal) then
9394
 
9395
         --  An IN OUT generic actual must be a name. The instantiation is a
9396
         --  renaming declaration. The actual is the name being renamed. We
9397
         --  use the actual directly, rather than a copy, because it is not
9398
         --  used further in the list of actuals, and because a copy or a use
9399
         --  of relocate_node is incorrect if the instance is nested within a
9400
         --  generic. In order to simplify ASIS searches, the Generic_Parent
9401
         --  field links the declaration to the generic association.
9402
 
9403
         if No (Actual) then
9404
            Error_Msg_NE
9405
              ("missing actual&",
9406
               Instantiation_Node, Gen_Obj);
9407
            Error_Msg_NE
9408
              ("\in instantiation of & declared#",
9409
                 Instantiation_Node, Scope (A_Gen_Obj));
9410
            Abandon_Instantiation (Instantiation_Node);
9411
         end if;
9412
 
9413
         if Present (Subt_Mark) then
9414
            Decl_Node :=
9415
              Make_Object_Renaming_Declaration (Loc,
9416
                Defining_Identifier => New_Copy (Gen_Obj),
9417
                Subtype_Mark        => New_Copy_Tree (Subt_Mark),
9418
                Name                => Actual);
9419
 
9420
         else pragma Assert (Present (Acc_Def));
9421
            Decl_Node :=
9422
              Make_Object_Renaming_Declaration (Loc,
9423
                Defining_Identifier => New_Copy (Gen_Obj),
9424
                Access_Definition   => New_Copy_Tree (Acc_Def),
9425
                Name                => Actual);
9426
         end if;
9427
 
9428
         Set_Corresponding_Generic_Association (Decl_Node, Act_Assoc);
9429
 
9430
         --  The analysis of the actual may produce Insert_Action nodes, so
9431
         --  the declaration must have a context in which to attach them.
9432
 
9433
         Append (Decl_Node, List);
9434
         Analyze (Actual);
9435
 
9436
         --  Return if the analysis of the actual reported some error
9437
 
9438
         if Etype (Actual) = Any_Type then
9439
            return List;
9440
         end if;
9441
 
9442
         --  This check is performed here because Analyze_Object_Renaming will
9443
         --  not check it when Comes_From_Source is False. Note though that the
9444
         --  check for the actual being the name of an object will be performed
9445
         --  in Analyze_Object_Renaming.
9446
 
9447
         if Is_Object_Reference (Actual)
9448
           and then Is_Dependent_Component_Of_Mutable_Object (Actual)
9449
         then
9450
            Error_Msg_N
9451
              ("illegal discriminant-dependent component for in out parameter",
9452
               Actual);
9453
         end if;
9454
 
9455
         --  The actual has to be resolved in order to check that it is a
9456
         --  variable (due to cases such as F (1), where F returns access to an
9457
         --  array, and for overloaded prefixes).
9458
 
9459
         Ftyp := Get_Instance_Of (Etype (A_Gen_Obj));
9460
 
9461
         --  If the type of the formal is not itself a formal, and the
9462
         --  current unit is a child unit, the formal type must be declared
9463
         --  in a parent, and must be retrieved by visibility.
9464
 
9465
         if Ftyp = Orig_Ftyp
9466
           and then Is_Generic_Unit (Scope (Ftyp))
9467
           and then Is_Child_Unit (Scope (A_Gen_Obj))
9468
         then
9469
            declare
9470
               Temp : constant Node_Id :=
9471
                        New_Copy_Tree (Subtype_Mark (Analyzed_Formal));
9472
            begin
9473
               Set_Entity (Temp, Empty);
9474
               Find_Type (Temp);
9475
               Ftyp := Entity (Temp);
9476
            end;
9477
         end if;
9478
 
9479
         if Is_Private_Type (Ftyp)
9480
           and then not Is_Private_Type (Etype (Actual))
9481
           and then (Base_Type (Full_View (Ftyp)) = Base_Type (Etype (Actual))
9482
                      or else Base_Type (Etype (Actual)) = Ftyp)
9483
         then
9484
            --  If the actual has the type of the full view of the formal, or
9485
            --  else a non-private subtype of the formal, then the visibility
9486
            --  of the formal type has changed. Add to the actuals a subtype
9487
            --  declaration that will force the exchange of views in the body
9488
            --  of the instance as well.
9489
 
9490
            Subt_Decl :=
9491
              Make_Subtype_Declaration (Loc,
9492
                 Defining_Identifier => Make_Temporary (Loc, 'P'),
9493
                 Subtype_Indication  => New_Occurrence_Of (Ftyp, Loc));
9494
 
9495
            Prepend (Subt_Decl, List);
9496
 
9497
            Prepend_Elmt (Full_View (Ftyp), Exchanged_Views);
9498
            Exchange_Declarations (Ftyp);
9499
         end if;
9500
 
9501
         Resolve (Actual, Ftyp);
9502
 
9503
         if not Denotes_Variable (Actual) then
9504
            Error_Msg_NE
9505
              ("actual for& must be a variable", Actual, Gen_Obj);
9506
 
9507
         elsif Base_Type (Ftyp) /= Base_Type (Etype (Actual)) then
9508
 
9509
            --  Ada 2005 (AI-423): For a generic formal object of mode in out,
9510
            --  the type of the actual shall resolve to a specific anonymous
9511
            --  access type.
9512
 
9513
            if Ada_Version < Ada_2005
9514
              or else
9515
                Ekind (Base_Type (Ftyp)) /=
9516
                  E_Anonymous_Access_Type
9517
              or else
9518
                Ekind (Base_Type (Etype (Actual))) /=
9519
                  E_Anonymous_Access_Type
9520
            then
9521
               Error_Msg_NE ("type of actual does not match type of&",
9522
                             Actual, Gen_Obj);
9523
            end if;
9524
         end if;
9525
 
9526
         Note_Possible_Modification (Actual, Sure => True);
9527
 
9528
         --  Check for instantiation of atomic/volatile actual for
9529
         --  non-atomic/volatile formal (RM C.6 (12)).
9530
 
9531
         if Is_Atomic_Object (Actual)
9532
           and then not Is_Atomic (Orig_Ftyp)
9533
         then
9534
            Error_Msg_N
9535
              ("cannot instantiate non-atomic formal object " &
9536
               "with atomic actual", Actual);
9537
 
9538
         elsif Is_Volatile_Object (Actual)
9539
           and then not Is_Volatile (Orig_Ftyp)
9540
         then
9541
            Error_Msg_N
9542
              ("cannot instantiate non-volatile formal object " &
9543
               "with volatile actual", Actual);
9544
         end if;
9545
 
9546
      --  Formal in-parameter
9547
 
9548
      else
9549
         --  The instantiation of a generic formal in-parameter is constant
9550
         --  declaration. The actual is the expression for that declaration.
9551
 
9552
         if Present (Actual) then
9553
            if Present (Subt_Mark) then
9554
               Def := Subt_Mark;
9555
            else pragma Assert (Present (Acc_Def));
9556
               Def := Acc_Def;
9557
            end if;
9558
 
9559
            Decl_Node :=
9560
              Make_Object_Declaration (Loc,
9561
                Defining_Identifier    => New_Copy (Gen_Obj),
9562
                Constant_Present       => True,
9563
                Null_Exclusion_Present => Null_Exclusion_Present (Formal),
9564
                Object_Definition      => New_Copy_Tree (Def),
9565
                Expression             => Actual);
9566
 
9567
            Set_Corresponding_Generic_Association (Decl_Node, Act_Assoc);
9568
 
9569
            --  A generic formal object of a tagged type is defined to be
9570
            --  aliased so the new constant must also be treated as aliased.
9571
 
9572
            if Is_Tagged_Type (Etype (A_Gen_Obj)) then
9573
               Set_Aliased_Present (Decl_Node);
9574
            end if;
9575
 
9576
            Append (Decl_Node, List);
9577
 
9578
            --  No need to repeat (pre-)analysis of some expression nodes
9579
            --  already handled in Preanalyze_Actuals.
9580
 
9581
            if Nkind (Actual) /= N_Allocator then
9582
               Analyze (Actual);
9583
 
9584
               --  Return if the analysis of the actual reported some error
9585
 
9586
               if Etype (Actual) = Any_Type then
9587
                  return List;
9588
               end if;
9589
            end if;
9590
 
9591
            declare
9592
               Formal_Type : constant Entity_Id := Etype (A_Gen_Obj);
9593
               Typ         : Entity_Id;
9594
 
9595
            begin
9596
               Typ := Get_Instance_Of (Formal_Type);
9597
 
9598
               Freeze_Before (Instantiation_Node, Typ);
9599
 
9600
               --  If the actual is an aggregate, perform name resolution on
9601
               --  its components (the analysis of an aggregate does not do it)
9602
               --  to capture local names that may be hidden if the generic is
9603
               --  a child unit.
9604
 
9605
               if Nkind (Actual) = N_Aggregate then
9606
                  Preanalyze_And_Resolve (Actual, Typ);
9607
               end if;
9608
 
9609
               if Is_Limited_Type (Typ)
9610
                 and then not OK_For_Limited_Init (Typ, Actual)
9611
               then
9612
                  Error_Msg_N
9613
                    ("initialization not allowed for limited types", Actual);
9614
                  Explain_Limited_Type (Typ, Actual);
9615
               end if;
9616
            end;
9617
 
9618
         elsif Present (Default_Expression (Formal)) then
9619
 
9620
            --  Use default to construct declaration
9621
 
9622
            if Present (Subt_Mark) then
9623
               Def := Subt_Mark;
9624
            else pragma Assert (Present (Acc_Def));
9625
               Def := Acc_Def;
9626
            end if;
9627
 
9628
            Decl_Node :=
9629
              Make_Object_Declaration (Sloc (Formal),
9630
                Defining_Identifier    => New_Copy (Gen_Obj),
9631
                Constant_Present       => True,
9632
                Null_Exclusion_Present => Null_Exclusion_Present (Formal),
9633
                Object_Definition      => New_Copy (Def),
9634
                Expression             => New_Copy_Tree
9635
                                            (Default_Expression (Formal)));
9636
 
9637
            Append (Decl_Node, List);
9638
            Set_Analyzed (Expression (Decl_Node), False);
9639
 
9640
         else
9641
            Error_Msg_NE
9642
              ("missing actual&",
9643
                Instantiation_Node, Gen_Obj);
9644
            Error_Msg_NE ("\in instantiation of & declared#",
9645
              Instantiation_Node, Scope (A_Gen_Obj));
9646
 
9647
            if Is_Scalar_Type (Etype (A_Gen_Obj)) then
9648
 
9649
               --  Create dummy constant declaration so that instance can be
9650
               --  analyzed, to minimize cascaded visibility errors.
9651
 
9652
               if Present (Subt_Mark) then
9653
                  Def := Subt_Mark;
9654
               else pragma Assert (Present (Acc_Def));
9655
                  Def := Acc_Def;
9656
               end if;
9657
 
9658
               Decl_Node :=
9659
                 Make_Object_Declaration (Loc,
9660
                   Defining_Identifier    => New_Copy (Gen_Obj),
9661
                   Constant_Present       => True,
9662
                   Null_Exclusion_Present => Null_Exclusion_Present (Formal),
9663
                   Object_Definition      => New_Copy (Def),
9664
                   Expression             =>
9665
                     Make_Attribute_Reference (Sloc (Gen_Obj),
9666
                       Attribute_Name => Name_First,
9667
                       Prefix         => New_Copy (Def)));
9668
 
9669
               Append (Decl_Node, List);
9670
 
9671
            else
9672
               Abandon_Instantiation (Instantiation_Node);
9673
            end if;
9674
         end if;
9675
      end if;
9676
 
9677
      if Nkind (Actual) in N_Has_Entity then
9678
         Actual_Decl := Parent (Entity (Actual));
9679
      end if;
9680
 
9681
      --  Ada 2005 (AI-423): For a formal object declaration with a null
9682
      --  exclusion or an access definition that has a null exclusion: If the
9683
      --  actual matching the formal object declaration denotes a generic
9684
      --  formal object of another generic unit G, and the instantiation
9685
      --  containing the actual occurs within the body of G or within the body
9686
      --  of a generic unit declared within the declarative region of G, then
9687
      --  the declaration of the formal object of G must have a null exclusion.
9688
      --  Otherwise, the subtype of the actual matching the formal object
9689
      --  declaration shall exclude null.
9690
 
9691
      if Ada_Version >= Ada_2005
9692
        and then Present (Actual_Decl)
9693
        and then
9694
          Nkind_In (Actual_Decl, N_Formal_Object_Declaration,
9695
                                 N_Object_Declaration)
9696
        and then Nkind (Analyzed_Formal) = N_Formal_Object_Declaration
9697
        and then not Has_Null_Exclusion (Actual_Decl)
9698
        and then Has_Null_Exclusion (Analyzed_Formal)
9699
      then
9700
         Error_Msg_Sloc := Sloc (Analyzed_Formal);
9701
         Error_Msg_N
9702
           ("actual must exclude null to match generic formal#", Actual);
9703
      end if;
9704
 
9705
      return List;
9706
   end Instantiate_Object;
9707
 
9708
   ------------------------------
9709
   -- Instantiate_Package_Body --
9710
   ------------------------------
9711
 
9712
   procedure Instantiate_Package_Body
9713
     (Body_Info     : Pending_Body_Info;
9714
      Inlined_Body  : Boolean := False;
9715
      Body_Optional : Boolean := False)
9716
   is
9717
      Act_Decl    : constant Node_Id    := Body_Info.Act_Decl;
9718
      Inst_Node   : constant Node_Id    := Body_Info.Inst_Node;
9719
      Loc         : constant Source_Ptr := Sloc (Inst_Node);
9720
 
9721
      Gen_Id      : constant Node_Id    := Name (Inst_Node);
9722
      Gen_Unit    : constant Entity_Id  := Get_Generic_Entity (Inst_Node);
9723
      Gen_Decl    : constant Node_Id    := Unit_Declaration_Node (Gen_Unit);
9724
      Act_Spec    : constant Node_Id    := Specification (Act_Decl);
9725
      Act_Decl_Id : constant Entity_Id  := Defining_Entity (Act_Spec);
9726
 
9727
      Act_Body_Name : Node_Id;
9728
      Gen_Body      : Node_Id;
9729
      Gen_Body_Id   : Node_Id;
9730
      Act_Body      : Node_Id;
9731
      Act_Body_Id   : Entity_Id;
9732
 
9733
      Parent_Installed : Boolean := False;
9734
      Save_Style_Check : constant Boolean := Style_Check;
9735
 
9736
      Par_Ent : Entity_Id := Empty;
9737
      Par_Vis : Boolean   := False;
9738
 
9739
      Vis_Prims_List : Elist_Id := No_Elist;
9740
      --  List of primitives made temporarily visible in the instantiation
9741
      --  to match the visibility of the formal type
9742
 
9743
   begin
9744
      Gen_Body_Id := Corresponding_Body (Gen_Decl);
9745
 
9746
      --  The instance body may already have been processed, as the parent of
9747
      --  another instance that is inlined (Load_Parent_Of_Generic).
9748
 
9749
      if Present (Corresponding_Body (Instance_Spec (Inst_Node))) then
9750
         return;
9751
      end if;
9752
 
9753
      Expander_Mode_Save_And_Set (Body_Info.Expander_Status);
9754
 
9755
      --  Re-establish the state of information on which checks are suppressed.
9756
      --  This information was set in Body_Info at the point of instantiation,
9757
      --  and now we restore it so that the instance is compiled using the
9758
      --  check status at the instantiation (RM 11.5 (7.2/2), AI95-00224-01).
9759
 
9760
      Local_Suppress_Stack_Top := Body_Info.Local_Suppress_Stack_Top;
9761
      Scope_Suppress           := Body_Info.Scope_Suppress;
9762
      Opt.Ada_Version          := Body_Info.Version;
9763
 
9764
      if No (Gen_Body_Id) then
9765
         Load_Parent_Of_Generic
9766
           (Inst_Node, Specification (Gen_Decl), Body_Optional);
9767
         Gen_Body_Id := Corresponding_Body (Gen_Decl);
9768
      end if;
9769
 
9770
      --  Establish global variable for sloc adjustment and for error recovery
9771
 
9772
      Instantiation_Node := Inst_Node;
9773
 
9774
      if Present (Gen_Body_Id) then
9775
         Save_Env (Gen_Unit, Act_Decl_Id);
9776
         Style_Check := False;
9777
         Current_Sem_Unit := Body_Info.Current_Sem_Unit;
9778
 
9779
         Gen_Body := Unit_Declaration_Node (Gen_Body_Id);
9780
 
9781
         Create_Instantiation_Source
9782
           (Inst_Node, Gen_Body_Id, False, S_Adjustment);
9783
 
9784
         Act_Body :=
9785
           Copy_Generic_Node
9786
             (Original_Node (Gen_Body), Empty, Instantiating => True);
9787
 
9788
         --  Build new name (possibly qualified) for body declaration
9789
 
9790
         Act_Body_Id := New_Copy (Act_Decl_Id);
9791
 
9792
         --  Some attributes of spec entity are not inherited by body entity
9793
 
9794
         Set_Handler_Records (Act_Body_Id, No_List);
9795
 
9796
         if Nkind (Defining_Unit_Name (Act_Spec)) =
9797
                                           N_Defining_Program_Unit_Name
9798
         then
9799
            Act_Body_Name :=
9800
              Make_Defining_Program_Unit_Name (Loc,
9801
                Name => New_Copy_Tree (Name (Defining_Unit_Name (Act_Spec))),
9802
                Defining_Identifier => Act_Body_Id);
9803
         else
9804
            Act_Body_Name :=  Act_Body_Id;
9805
         end if;
9806
 
9807
         Set_Defining_Unit_Name (Act_Body, Act_Body_Name);
9808
 
9809
         Set_Corresponding_Spec (Act_Body, Act_Decl_Id);
9810
         Check_Generic_Actuals (Act_Decl_Id, False);
9811
 
9812
         --  Install primitives hidden at the point of the instantiation but
9813
         --  visible when processing the generic formals
9814
 
9815
         declare
9816
            E : Entity_Id;
9817
 
9818
         begin
9819
            E := First_Entity (Act_Decl_Id);
9820
            while Present (E) loop
9821
               if Is_Type (E)
9822
                 and then Is_Generic_Actual_Type (E)
9823
                 and then Is_Tagged_Type (E)
9824
               then
9825
                  Install_Hidden_Primitives
9826
                    (Prims_List => Vis_Prims_List,
9827
                     Gen_T      => Generic_Parent_Type (Parent (E)),
9828
                     Act_T      => E);
9829
               end if;
9830
 
9831
               Next_Entity (E);
9832
            end loop;
9833
         end;
9834
 
9835
         --  If it is a child unit, make the parent instance (which is an
9836
         --  instance of the parent of the generic) visible. The parent
9837
         --  instance is the prefix of the name of the generic unit.
9838
 
9839
         if Ekind (Scope (Gen_Unit)) = E_Generic_Package
9840
           and then Nkind (Gen_Id) = N_Expanded_Name
9841
         then
9842
            Par_Ent := Entity (Prefix (Gen_Id));
9843
            Par_Vis := Is_Immediately_Visible (Par_Ent);
9844
            Install_Parent (Par_Ent, In_Body => True);
9845
            Parent_Installed := True;
9846
 
9847
         elsif Is_Child_Unit (Gen_Unit) then
9848
            Par_Ent := Scope (Gen_Unit);
9849
            Par_Vis := Is_Immediately_Visible (Par_Ent);
9850
            Install_Parent (Par_Ent, In_Body => True);
9851
            Parent_Installed := True;
9852
         end if;
9853
 
9854
         --  If the instantiation is a library unit, and this is the main unit,
9855
         --  then build the resulting compilation unit nodes for the instance.
9856
         --  If this is a compilation unit but it is not the main unit, then it
9857
         --  is the body of a unit in the context, that is being compiled
9858
         --  because it is encloses some inlined unit or another generic unit
9859
         --  being instantiated. In that case, this body is not part of the
9860
         --  current compilation, and is not attached to the tree, but its
9861
         --  parent must be set for analysis.
9862
 
9863
         if Nkind (Parent (Inst_Node)) = N_Compilation_Unit then
9864
 
9865
            --  Replace instance node with body of instance, and create new
9866
            --  node for corresponding instance declaration.
9867
 
9868
            Build_Instance_Compilation_Unit_Nodes
9869
              (Inst_Node, Act_Body, Act_Decl);
9870
            Analyze (Inst_Node);
9871
 
9872
            if Parent (Inst_Node) = Cunit (Main_Unit) then
9873
 
9874
               --  If the instance is a child unit itself, then set the scope
9875
               --  of the expanded body to be the parent of the instantiation
9876
               --  (ensuring that the fully qualified name will be generated
9877
               --  for the elaboration subprogram).
9878
 
9879
               if Nkind (Defining_Unit_Name (Act_Spec)) =
9880
                                              N_Defining_Program_Unit_Name
9881
               then
9882
                  Set_Scope
9883
                    (Defining_Entity (Inst_Node), Scope (Act_Decl_Id));
9884
               end if;
9885
            end if;
9886
 
9887
         --  Case where instantiation is not a library unit
9888
 
9889
         else
9890
            --  If this is an early instantiation, i.e. appears textually
9891
            --  before the corresponding body and must be elaborated first,
9892
            --  indicate that the body instance is to be delayed.
9893
 
9894
            Install_Body (Act_Body, Inst_Node, Gen_Body, Gen_Decl);
9895
 
9896
            --  Now analyze the body. We turn off all checks if this is an
9897
            --  internal unit, since there is no reason to have checks on for
9898
            --  any predefined run-time library code. All such code is designed
9899
            --  to be compiled with checks off.
9900
 
9901
            --  Note that we do NOT apply this criterion to children of GNAT
9902
            --  (or on VMS, children of DEC). The latter units must suppress
9903
            --  checks explicitly if this is needed.
9904
 
9905
            if Is_Predefined_File_Name
9906
                 (Unit_File_Name (Get_Source_Unit (Gen_Decl)))
9907
            then
9908
               Analyze (Act_Body, Suppress => All_Checks);
9909
            else
9910
               Analyze (Act_Body);
9911
            end if;
9912
         end if;
9913
 
9914
         Inherit_Context (Gen_Body, Inst_Node);
9915
 
9916
         --  Remove the parent instances if they have been placed on the scope
9917
         --  stack to compile the body.
9918
 
9919
         if Parent_Installed then
9920
            Remove_Parent (In_Body => True);
9921
 
9922
            --  Restore the previous visibility of the parent
9923
 
9924
            Set_Is_Immediately_Visible (Par_Ent, Par_Vis);
9925
         end if;
9926
 
9927
         Restore_Hidden_Primitives (Vis_Prims_List);
9928
         Restore_Private_Views (Act_Decl_Id);
9929
 
9930
         --  Remove the current unit from visibility if this is an instance
9931
         --  that is not elaborated on the fly for inlining purposes.
9932
 
9933
         if not Inlined_Body then
9934
            Set_Is_Immediately_Visible (Act_Decl_Id, False);
9935
         end if;
9936
 
9937
         Restore_Env;
9938
         Style_Check := Save_Style_Check;
9939
 
9940
      --  If we have no body, and the unit requires a body, then complain. This
9941
      --  complaint is suppressed if we have detected other errors (since a
9942
      --  common reason for missing the body is that it had errors).
9943
      --  In CodePeer mode, a warning has been emitted already, no need for
9944
      --  further messages.
9945
 
9946
      elsif Unit_Requires_Body (Gen_Unit)
9947
        and then not Body_Optional
9948
      then
9949
         if CodePeer_Mode then
9950
            null;
9951
 
9952
         elsif Serious_Errors_Detected = 0 then
9953
            Error_Msg_NE
9954
              ("cannot find body of generic package &", Inst_Node, Gen_Unit);
9955
 
9956
         --  Don't attempt to perform any cleanup actions if some other error
9957
         --  was already detected, since this can cause blowups.
9958
 
9959
         else
9960
            return;
9961
         end if;
9962
 
9963
      --  Case of package that does not need a body
9964
 
9965
      else
9966
         --  If the instantiation of the declaration is a library unit, rewrite
9967
         --  the original package instantiation as a package declaration in the
9968
         --  compilation unit node.
9969
 
9970
         if Nkind (Parent (Inst_Node)) = N_Compilation_Unit then
9971
            Set_Parent_Spec (Act_Decl, Parent_Spec (Inst_Node));
9972
            Rewrite (Inst_Node, Act_Decl);
9973
 
9974
            --  Generate elaboration entity, in case spec has elaboration code.
9975
            --  This cannot be done when the instance is analyzed, because it
9976
            --  is not known yet whether the body exists.
9977
 
9978
            Set_Elaboration_Entity_Required (Act_Decl_Id, False);
9979
            Build_Elaboration_Entity (Parent (Inst_Node), Act_Decl_Id);
9980
 
9981
         --  If the instantiation is not a library unit, then append the
9982
         --  declaration to the list of implicitly generated entities, unless
9983
         --  it is already a list member which means that it was already
9984
         --  processed
9985
 
9986
         elsif not Is_List_Member (Act_Decl) then
9987
            Mark_Rewrite_Insertion (Act_Decl);
9988
            Insert_Before (Inst_Node, Act_Decl);
9989
         end if;
9990
      end if;
9991
 
9992
      Expander_Mode_Restore;
9993
   end Instantiate_Package_Body;
9994
 
9995
   ---------------------------------
9996
   -- Instantiate_Subprogram_Body --
9997
   ---------------------------------
9998
 
9999
   procedure Instantiate_Subprogram_Body
10000
     (Body_Info     : Pending_Body_Info;
10001
      Body_Optional : Boolean := False)
10002
   is
10003
      Act_Decl      : constant Node_Id    := Body_Info.Act_Decl;
10004
      Inst_Node     : constant Node_Id    := Body_Info.Inst_Node;
10005
      Loc           : constant Source_Ptr := Sloc (Inst_Node);
10006
      Gen_Id        : constant Node_Id    := Name (Inst_Node);
10007
      Gen_Unit      : constant Entity_Id  := Get_Generic_Entity (Inst_Node);
10008
      Gen_Decl      : constant Node_Id    := Unit_Declaration_Node (Gen_Unit);
10009
      Anon_Id       : constant Entity_Id  :=
10010
                        Defining_Unit_Name (Specification (Act_Decl));
10011
      Pack_Id       : constant Entity_Id  :=
10012
                        Defining_Unit_Name (Parent (Act_Decl));
10013
      Decls         : List_Id;
10014
      Gen_Body      : Node_Id;
10015
      Gen_Body_Id   : Node_Id;
10016
      Act_Body      : Node_Id;
10017
      Pack_Body     : Node_Id;
10018
      Prev_Formal   : Entity_Id;
10019
      Ret_Expr      : Node_Id;
10020
      Unit_Renaming : Node_Id;
10021
 
10022
      Parent_Installed : Boolean := False;
10023
      Save_Style_Check : constant Boolean := Style_Check;
10024
 
10025
      Par_Ent : Entity_Id := Empty;
10026
      Par_Vis : Boolean   := False;
10027
 
10028
   begin
10029
      Gen_Body_Id := Corresponding_Body (Gen_Decl);
10030
 
10031
      --  Subprogram body may have been created already because of an inline
10032
      --  pragma, or because of multiple elaborations of the enclosing package
10033
      --  when several instances of the subprogram appear in the main unit.
10034
 
10035
      if Present (Corresponding_Body (Act_Decl)) then
10036
         return;
10037
      end if;
10038
 
10039
      Expander_Mode_Save_And_Set (Body_Info.Expander_Status);
10040
 
10041
      --  Re-establish the state of information on which checks are suppressed.
10042
      --  This information was set in Body_Info at the point of instantiation,
10043
      --  and now we restore it so that the instance is compiled using the
10044
      --  check status at the instantiation (RM 11.5 (7.2/2), AI95-00224-01).
10045
 
10046
      Local_Suppress_Stack_Top := Body_Info.Local_Suppress_Stack_Top;
10047
      Scope_Suppress           := Body_Info.Scope_Suppress;
10048
      Opt.Ada_Version          := Body_Info.Version;
10049
 
10050
      if No (Gen_Body_Id) then
10051
 
10052
         --  For imported generic subprogram, no body to compile, complete
10053
         --  the spec entity appropriately.
10054
 
10055
         if Is_Imported (Gen_Unit) then
10056
            Set_Is_Imported (Anon_Id);
10057
            Set_First_Rep_Item (Anon_Id, First_Rep_Item (Gen_Unit));
10058
            Set_Interface_Name (Anon_Id, Interface_Name (Gen_Unit));
10059
            Set_Convention     (Anon_Id, Convention     (Gen_Unit));
10060
            Set_Has_Completion (Anon_Id);
10061
            return;
10062
 
10063
         --  For other cases, compile the body
10064
 
10065
         else
10066
            Load_Parent_Of_Generic
10067
              (Inst_Node, Specification (Gen_Decl), Body_Optional);
10068
            Gen_Body_Id := Corresponding_Body (Gen_Decl);
10069
         end if;
10070
      end if;
10071
 
10072
      Instantiation_Node := Inst_Node;
10073
 
10074
      if Present (Gen_Body_Id) then
10075
         Gen_Body := Unit_Declaration_Node (Gen_Body_Id);
10076
 
10077
         if Nkind (Gen_Body) = N_Subprogram_Body_Stub then
10078
 
10079
            --  Either body is not present, or context is non-expanding, as
10080
            --  when compiling a subunit. Mark the instance as completed, and
10081
            --  diagnose a missing body when needed.
10082
 
10083
            if Expander_Active
10084
              and then Operating_Mode = Generate_Code
10085
            then
10086
               Error_Msg_N
10087
                 ("missing proper body for instantiation", Gen_Body);
10088
            end if;
10089
 
10090
            Set_Has_Completion (Anon_Id);
10091
            return;
10092
         end if;
10093
 
10094
         Save_Env (Gen_Unit, Anon_Id);
10095
         Style_Check := False;
10096
         Current_Sem_Unit := Body_Info.Current_Sem_Unit;
10097
         Create_Instantiation_Source
10098
           (Inst_Node,
10099
            Gen_Body_Id,
10100
            False,
10101
            S_Adjustment);
10102
 
10103
         Act_Body :=
10104
           Copy_Generic_Node
10105
             (Original_Node (Gen_Body), Empty, Instantiating => True);
10106
 
10107
         --  Create proper defining name for the body, to correspond to
10108
         --  the one in the spec.
10109
 
10110
         Set_Defining_Unit_Name (Specification (Act_Body),
10111
           Make_Defining_Identifier
10112
             (Sloc (Defining_Entity (Inst_Node)), Chars (Anon_Id)));
10113
         Set_Corresponding_Spec (Act_Body, Anon_Id);
10114
         Set_Has_Completion (Anon_Id);
10115
         Check_Generic_Actuals (Pack_Id, False);
10116
 
10117
         --  Generate a reference to link the visible subprogram instance to
10118
         --  the generic body, which for navigation purposes is the only
10119
         --  available source for the instance.
10120
 
10121
         Generate_Reference
10122
           (Related_Instance (Pack_Id),
10123
             Gen_Body_Id, 'b', Set_Ref => False, Force => True);
10124
 
10125
         --  If it is a child unit, make the parent instance (which is an
10126
         --  instance of the parent of the generic) visible. The parent
10127
         --  instance is the prefix of the name of the generic unit.
10128
 
10129
         if Ekind (Scope (Gen_Unit)) = E_Generic_Package
10130
           and then Nkind (Gen_Id) = N_Expanded_Name
10131
         then
10132
            Par_Ent := Entity (Prefix (Gen_Id));
10133
            Par_Vis := Is_Immediately_Visible (Par_Ent);
10134
            Install_Parent (Par_Ent, In_Body => True);
10135
            Parent_Installed := True;
10136
 
10137
         elsif Is_Child_Unit (Gen_Unit) then
10138
            Par_Ent := Scope (Gen_Unit);
10139
            Par_Vis := Is_Immediately_Visible (Par_Ent);
10140
            Install_Parent (Par_Ent, In_Body => True);
10141
            Parent_Installed := True;
10142
         end if;
10143
 
10144
         --  Inside its body, a reference to the generic unit is a reference
10145
         --  to the instance. The corresponding renaming is the first
10146
         --  declaration in the body.
10147
 
10148
         Unit_Renaming :=
10149
           Make_Subprogram_Renaming_Declaration (Loc,
10150
             Specification =>
10151
               Copy_Generic_Node (
10152
                 Specification (Original_Node (Gen_Body)),
10153
                 Empty,
10154
                 Instantiating => True),
10155
             Name => New_Occurrence_Of (Anon_Id, Loc));
10156
 
10157
         --  If there is a formal subprogram with the same name as the unit
10158
         --  itself, do not add this renaming declaration. This is a temporary
10159
         --  fix for one ACVC test. ???
10160
 
10161
         Prev_Formal := First_Entity (Pack_Id);
10162
         while Present (Prev_Formal) loop
10163
            if Chars (Prev_Formal) = Chars (Gen_Unit)
10164
              and then Is_Overloadable (Prev_Formal)
10165
            then
10166
               exit;
10167
            end if;
10168
 
10169
            Next_Entity (Prev_Formal);
10170
         end loop;
10171
 
10172
         if Present (Prev_Formal) then
10173
            Decls :=  New_List (Act_Body);
10174
         else
10175
            Decls :=  New_List (Unit_Renaming, Act_Body);
10176
         end if;
10177
 
10178
         --  The subprogram body is placed in the body of a dummy package body,
10179
         --  whose spec contains the subprogram declaration as well as the
10180
         --  renaming declarations for the generic parameters.
10181
 
10182
         Pack_Body := Make_Package_Body (Loc,
10183
           Defining_Unit_Name => New_Copy (Pack_Id),
10184
           Declarations       => Decls);
10185
 
10186
         Set_Corresponding_Spec (Pack_Body, Pack_Id);
10187
 
10188
         --  If the instantiation is a library unit, then build resulting
10189
         --  compilation unit nodes for the instance. The declaration of
10190
         --  the enclosing package is the grandparent of the subprogram
10191
         --  declaration. First replace the instantiation node as the unit
10192
         --  of the corresponding compilation.
10193
 
10194
         if Nkind (Parent (Inst_Node)) = N_Compilation_Unit then
10195
            if Parent (Inst_Node) = Cunit (Main_Unit) then
10196
               Set_Unit (Parent (Inst_Node), Inst_Node);
10197
               Build_Instance_Compilation_Unit_Nodes
10198
                 (Inst_Node, Pack_Body, Parent (Parent (Act_Decl)));
10199
               Analyze (Inst_Node);
10200
            else
10201
               Set_Parent (Pack_Body, Parent (Inst_Node));
10202
               Analyze (Pack_Body);
10203
            end if;
10204
 
10205
         else
10206
            Insert_Before (Inst_Node, Pack_Body);
10207
            Mark_Rewrite_Insertion (Pack_Body);
10208
            Analyze (Pack_Body);
10209
 
10210
            if Expander_Active then
10211
               Freeze_Subprogram_Body (Inst_Node, Gen_Body, Pack_Id);
10212
            end if;
10213
         end if;
10214
 
10215
         Inherit_Context (Gen_Body, Inst_Node);
10216
 
10217
         Restore_Private_Views (Pack_Id, False);
10218
 
10219
         if Parent_Installed then
10220
            Remove_Parent (In_Body => True);
10221
 
10222
            --  Restore the previous visibility of the parent
10223
 
10224
            Set_Is_Immediately_Visible (Par_Ent, Par_Vis);
10225
         end if;
10226
 
10227
         Restore_Env;
10228
         Style_Check := Save_Style_Check;
10229
 
10230
      --  Body not found. Error was emitted already. If there were no previous
10231
      --  errors, this may be an instance whose scope is a premature instance.
10232
      --  In that case we must insure that the (legal) program does raise
10233
      --  program error if executed. We generate a subprogram body for this
10234
      --  purpose. See DEC ac30vso.
10235
 
10236
      --  Should not reference proprietary DEC tests in comments ???
10237
 
10238
      elsif Serious_Errors_Detected = 0
10239
        and then Nkind (Parent (Inst_Node)) /= N_Compilation_Unit
10240
      then
10241
         if Body_Optional then
10242
            return;
10243
 
10244
         elsif Ekind (Anon_Id) = E_Procedure then
10245
            Act_Body :=
10246
              Make_Subprogram_Body (Loc,
10247
                 Specification              =>
10248
                   Make_Procedure_Specification (Loc,
10249
                     Defining_Unit_Name         =>
10250
                       Make_Defining_Identifier (Loc, Chars (Anon_Id)),
10251
                       Parameter_Specifications =>
10252
                       New_Copy_List
10253
                         (Parameter_Specifications (Parent (Anon_Id)))),
10254
 
10255
                 Declarations               => Empty_List,
10256
                 Handled_Statement_Sequence =>
10257
                   Make_Handled_Sequence_Of_Statements (Loc,
10258
                     Statements =>
10259
                       New_List (
10260
                         Make_Raise_Program_Error (Loc,
10261
                           Reason =>
10262
                             PE_Access_Before_Elaboration))));
10263
 
10264
         else
10265
            Ret_Expr :=
10266
              Make_Raise_Program_Error (Loc,
10267
                Reason => PE_Access_Before_Elaboration);
10268
 
10269
            Set_Etype (Ret_Expr, (Etype (Anon_Id)));
10270
            Set_Analyzed (Ret_Expr);
10271
 
10272
            Act_Body :=
10273
              Make_Subprogram_Body (Loc,
10274
                Specification =>
10275
                  Make_Function_Specification (Loc,
10276
                     Defining_Unit_Name         =>
10277
                       Make_Defining_Identifier (Loc, Chars (Anon_Id)),
10278
                       Parameter_Specifications =>
10279
                       New_Copy_List
10280
                         (Parameter_Specifications (Parent (Anon_Id))),
10281
                     Result_Definition =>
10282
                       New_Occurrence_Of (Etype (Anon_Id), Loc)),
10283
 
10284
                  Declarations               => Empty_List,
10285
                  Handled_Statement_Sequence =>
10286
                    Make_Handled_Sequence_Of_Statements (Loc,
10287
                      Statements =>
10288
                        New_List
10289
                          (Make_Simple_Return_Statement (Loc, Ret_Expr))));
10290
         end if;
10291
 
10292
         Pack_Body := Make_Package_Body (Loc,
10293
           Defining_Unit_Name => New_Copy (Pack_Id),
10294
           Declarations       => New_List (Act_Body));
10295
 
10296
         Insert_After (Inst_Node, Pack_Body);
10297
         Set_Corresponding_Spec (Pack_Body, Pack_Id);
10298
         Analyze (Pack_Body);
10299
      end if;
10300
 
10301
      Expander_Mode_Restore;
10302
   end Instantiate_Subprogram_Body;
10303
 
10304
   ----------------------
10305
   -- Instantiate_Type --
10306
   ----------------------
10307
 
10308
   function Instantiate_Type
10309
     (Formal          : Node_Id;
10310
      Actual          : Node_Id;
10311
      Analyzed_Formal : Node_Id;
10312
      Actual_Decls    : List_Id) return List_Id
10313
   is
10314
      Gen_T      : constant Entity_Id  := Defining_Identifier (Formal);
10315
      A_Gen_T    : constant Entity_Id  :=
10316
                     Defining_Identifier (Analyzed_Formal);
10317
      Ancestor   : Entity_Id := Empty;
10318
      Def        : constant Node_Id    := Formal_Type_Definition (Formal);
10319
      Act_T      : Entity_Id;
10320
      Decl_Node  : Node_Id;
10321
      Decl_Nodes : List_Id;
10322
      Loc        : Source_Ptr;
10323
      Subt       : Entity_Id;
10324
 
10325
      procedure Validate_Array_Type_Instance;
10326
      procedure Validate_Access_Subprogram_Instance;
10327
      procedure Validate_Access_Type_Instance;
10328
      procedure Validate_Derived_Type_Instance;
10329
      procedure Validate_Derived_Interface_Type_Instance;
10330
      procedure Validate_Discriminated_Formal_Type;
10331
      procedure Validate_Interface_Type_Instance;
10332
      procedure Validate_Private_Type_Instance;
10333
      procedure Validate_Incomplete_Type_Instance;
10334
      --  These procedures perform validation tests for the named case.
10335
      --  Validate_Discriminated_Formal_Type is shared by formal private
10336
      --  types and Ada 2012 formal incomplete types.
10337
 
10338
      function Subtypes_Match (Gen_T, Act_T : Entity_Id) return Boolean;
10339
      --  Check that base types are the same and that the subtypes match
10340
      --  statically. Used in several of the above.
10341
 
10342
      --------------------
10343
      -- Subtypes_Match --
10344
      --------------------
10345
 
10346
      function Subtypes_Match (Gen_T, Act_T : Entity_Id) return Boolean is
10347
         T : constant Entity_Id := Get_Instance_Of (Gen_T);
10348
 
10349
      begin
10350
         return (Base_Type (T) = Base_Type (Act_T)
10351
                  and then Subtypes_Statically_Match (T, Act_T))
10352
 
10353
           or else (Is_Class_Wide_Type (Gen_T)
10354
                     and then Is_Class_Wide_Type (Act_T)
10355
                     and then
10356
                       Subtypes_Match
10357
                        (Get_Instance_Of (Root_Type (Gen_T)),
10358
                         Root_Type (Act_T)))
10359
 
10360
           or else
10361
             ((Ekind (Gen_T) = E_Anonymous_Access_Subprogram_Type
10362
                 or else Ekind (Gen_T) = E_Anonymous_Access_Type)
10363
               and then Ekind (Act_T) = Ekind (Gen_T)
10364
               and then
10365
                 Subtypes_Statically_Match
10366
                   (Designated_Type (Gen_T), Designated_Type (Act_T)));
10367
      end Subtypes_Match;
10368
 
10369
      -----------------------------------------
10370
      -- Validate_Access_Subprogram_Instance --
10371
      -----------------------------------------
10372
 
10373
      procedure Validate_Access_Subprogram_Instance is
10374
      begin
10375
         if not Is_Access_Type (Act_T)
10376
           or else Ekind (Designated_Type (Act_T)) /= E_Subprogram_Type
10377
         then
10378
            Error_Msg_NE
10379
              ("expect access type in instantiation of &", Actual, Gen_T);
10380
            Abandon_Instantiation (Actual);
10381
         end if;
10382
 
10383
         Check_Mode_Conformant
10384
           (Designated_Type (Act_T),
10385
            Designated_Type (A_Gen_T),
10386
            Actual,
10387
            Get_Inst => True);
10388
 
10389
         if Ekind (Base_Type (Act_T)) = E_Access_Protected_Subprogram_Type then
10390
            if Ekind (A_Gen_T) = E_Access_Subprogram_Type then
10391
               Error_Msg_NE
10392
                 ("protected access type not allowed for formal &",
10393
                  Actual, Gen_T);
10394
            end if;
10395
 
10396
         elsif Ekind (A_Gen_T) = E_Access_Protected_Subprogram_Type then
10397
            Error_Msg_NE
10398
              ("expect protected access type for formal &",
10399
               Actual, Gen_T);
10400
         end if;
10401
      end Validate_Access_Subprogram_Instance;
10402
 
10403
      -----------------------------------
10404
      -- Validate_Access_Type_Instance --
10405
      -----------------------------------
10406
 
10407
      procedure Validate_Access_Type_Instance is
10408
         Desig_Type : constant Entity_Id :=
10409
                        Find_Actual_Type (Designated_Type (A_Gen_T), A_Gen_T);
10410
         Desig_Act  : Entity_Id;
10411
 
10412
      begin
10413
         if not Is_Access_Type (Act_T) then
10414
            Error_Msg_NE
10415
              ("expect access type in instantiation of &", Actual, Gen_T);
10416
            Abandon_Instantiation (Actual);
10417
         end if;
10418
 
10419
         if Is_Access_Constant (A_Gen_T) then
10420
            if not Is_Access_Constant (Act_T) then
10421
               Error_Msg_N
10422
                 ("actual type must be access-to-constant type", Actual);
10423
               Abandon_Instantiation (Actual);
10424
            end if;
10425
         else
10426
            if Is_Access_Constant (Act_T) then
10427
               Error_Msg_N
10428
                 ("actual type must be access-to-variable type", Actual);
10429
               Abandon_Instantiation (Actual);
10430
 
10431
            elsif Ekind (A_Gen_T) = E_General_Access_Type
10432
              and then Ekind (Base_Type (Act_T)) /= E_General_Access_Type
10433
            then
10434
               Error_Msg_N -- CODEFIX
10435
                 ("actual must be general access type!", Actual);
10436
               Error_Msg_NE -- CODEFIX
10437
                 ("add ALL to }!", Actual, Act_T);
10438
               Abandon_Instantiation (Actual);
10439
            end if;
10440
         end if;
10441
 
10442
         --  The designated subtypes, that is to say the subtypes introduced
10443
         --  by an access type declaration (and not by a subtype declaration)
10444
         --  must match.
10445
 
10446
         Desig_Act := Designated_Type (Base_Type (Act_T));
10447
 
10448
         --  The designated type may have been introduced through a limited_
10449
         --  with clause, in which case retrieve the non-limited view. This
10450
         --  applies to incomplete types as well as to class-wide types.
10451
 
10452
         if From_With_Type (Desig_Act) then
10453
            Desig_Act := Available_View (Desig_Act);
10454
         end if;
10455
 
10456
         if not Subtypes_Match
10457
           (Desig_Type, Desig_Act) then
10458
            Error_Msg_NE
10459
              ("designated type of actual does not match that of formal &",
10460
                 Actual, Gen_T);
10461
            Abandon_Instantiation (Actual);
10462
 
10463
         elsif Is_Access_Type (Designated_Type (Act_T))
10464
           and then Is_Constrained (Designated_Type (Designated_Type (Act_T)))
10465
                      /=
10466
                  Is_Constrained (Designated_Type (Desig_Type))
10467
         then
10468
            Error_Msg_NE
10469
              ("designated type of actual does not match that of formal &",
10470
                 Actual, Gen_T);
10471
            Abandon_Instantiation (Actual);
10472
         end if;
10473
 
10474
         --  Ada 2005: null-exclusion indicators of the two types must agree
10475
 
10476
         if Can_Never_Be_Null (A_Gen_T) /=  Can_Never_Be_Null (Act_T) then
10477
            Error_Msg_NE
10478
              ("non null exclusion of actual and formal & do not match",
10479
                 Actual, Gen_T);
10480
         end if;
10481
      end Validate_Access_Type_Instance;
10482
 
10483
      ----------------------------------
10484
      -- Validate_Array_Type_Instance --
10485
      ----------------------------------
10486
 
10487
      procedure Validate_Array_Type_Instance is
10488
         I1 : Node_Id;
10489
         I2 : Node_Id;
10490
         T2 : Entity_Id;
10491
 
10492
         function Formal_Dimensions return Int;
10493
         --  Count number of dimensions in array type formal
10494
 
10495
         -----------------------
10496
         -- Formal_Dimensions --
10497
         -----------------------
10498
 
10499
         function Formal_Dimensions return Int is
10500
            Num   : Int := 0;
10501
            Index : Node_Id;
10502
 
10503
         begin
10504
            if Nkind (Def) = N_Constrained_Array_Definition then
10505
               Index := First (Discrete_Subtype_Definitions (Def));
10506
            else
10507
               Index := First (Subtype_Marks (Def));
10508
            end if;
10509
 
10510
            while Present (Index) loop
10511
               Num := Num + 1;
10512
               Next_Index (Index);
10513
            end loop;
10514
 
10515
            return Num;
10516
         end Formal_Dimensions;
10517
 
10518
      --  Start of processing for Validate_Array_Type_Instance
10519
 
10520
      begin
10521
         if not Is_Array_Type (Act_T) then
10522
            Error_Msg_NE
10523
              ("expect array type in instantiation of &", Actual, Gen_T);
10524
            Abandon_Instantiation (Actual);
10525
 
10526
         elsif Nkind (Def) = N_Constrained_Array_Definition then
10527
            if not (Is_Constrained (Act_T)) then
10528
               Error_Msg_NE
10529
                 ("expect constrained array in instantiation of &",
10530
                  Actual, Gen_T);
10531
               Abandon_Instantiation (Actual);
10532
            end if;
10533
 
10534
         else
10535
            if Is_Constrained (Act_T) then
10536
               Error_Msg_NE
10537
                 ("expect unconstrained array in instantiation of &",
10538
                  Actual, Gen_T);
10539
               Abandon_Instantiation (Actual);
10540
            end if;
10541
         end if;
10542
 
10543
         if Formal_Dimensions /= Number_Dimensions (Act_T) then
10544
            Error_Msg_NE
10545
              ("dimensions of actual do not match formal &", Actual, Gen_T);
10546
            Abandon_Instantiation (Actual);
10547
         end if;
10548
 
10549
         I1 := First_Index (A_Gen_T);
10550
         I2 := First_Index (Act_T);
10551
         for J in 1 .. Formal_Dimensions loop
10552
 
10553
            --  If the indexes of the actual were given by a subtype_mark,
10554
            --  the index was transformed into a range attribute. Retrieve
10555
            --  the original type mark for checking.
10556
 
10557
            if Is_Entity_Name (Original_Node (I2)) then
10558
               T2 := Entity (Original_Node (I2));
10559
            else
10560
               T2 := Etype (I2);
10561
            end if;
10562
 
10563
            if not Subtypes_Match
10564
                     (Find_Actual_Type (Etype (I1), A_Gen_T), T2)
10565
            then
10566
               Error_Msg_NE
10567
                 ("index types of actual do not match those of formal &",
10568
                  Actual, Gen_T);
10569
               Abandon_Instantiation (Actual);
10570
            end if;
10571
 
10572
            Next_Index (I1);
10573
            Next_Index (I2);
10574
         end loop;
10575
 
10576
         --  Check matching subtypes. Note that there are complex visibility
10577
         --  issues when the generic is a child unit and some aspect of the
10578
         --  generic type is declared in a parent unit of the generic. We do
10579
         --  the test to handle this special case only after a direct check
10580
         --  for static matching has failed.
10581
 
10582
         if Subtypes_Match
10583
           (Component_Type (A_Gen_T), Component_Type (Act_T))
10584
             or else Subtypes_Match
10585
                      (Find_Actual_Type (Component_Type (A_Gen_T), A_Gen_T),
10586
                       Component_Type (Act_T))
10587
         then
10588
            null;
10589
         else
10590
            Error_Msg_NE
10591
              ("component subtype of actual does not match that of formal &",
10592
               Actual, Gen_T);
10593
            Abandon_Instantiation (Actual);
10594
         end if;
10595
 
10596
         if Has_Aliased_Components (A_Gen_T)
10597
           and then not Has_Aliased_Components (Act_T)
10598
         then
10599
            Error_Msg_NE
10600
              ("actual must have aliased components to match formal type &",
10601
               Actual, Gen_T);
10602
         end if;
10603
      end Validate_Array_Type_Instance;
10604
 
10605
      -----------------------------------------------
10606
      --  Validate_Derived_Interface_Type_Instance --
10607
      -----------------------------------------------
10608
 
10609
      procedure Validate_Derived_Interface_Type_Instance is
10610
         Par  : constant Entity_Id := Entity (Subtype_Indication (Def));
10611
         Elmt : Elmt_Id;
10612
 
10613
      begin
10614
         --  First apply interface instance checks
10615
 
10616
         Validate_Interface_Type_Instance;
10617
 
10618
         --  Verify that immediate parent interface is an ancestor of
10619
         --  the actual.
10620
 
10621
         if Present (Par)
10622
           and then not Interface_Present_In_Ancestor (Act_T, Par)
10623
         then
10624
            Error_Msg_NE
10625
              ("interface actual must include progenitor&", Actual, Par);
10626
         end if;
10627
 
10628
         --  Now verify that the actual includes all other ancestors of
10629
         --  the formal.
10630
 
10631
         Elmt := First_Elmt (Interfaces (A_Gen_T));
10632
         while Present (Elmt) loop
10633
            if not Interface_Present_In_Ancestor
10634
                     (Act_T, Get_Instance_Of (Node (Elmt)))
10635
            then
10636
               Error_Msg_NE
10637
                 ("interface actual must include progenitor&",
10638
                    Actual, Node (Elmt));
10639
            end if;
10640
 
10641
            Next_Elmt (Elmt);
10642
         end loop;
10643
      end Validate_Derived_Interface_Type_Instance;
10644
 
10645
      ------------------------------------
10646
      -- Validate_Derived_Type_Instance --
10647
      ------------------------------------
10648
 
10649
      procedure Validate_Derived_Type_Instance is
10650
         Actual_Discr   : Entity_Id;
10651
         Ancestor_Discr : Entity_Id;
10652
 
10653
      begin
10654
         --  If the parent type in the generic declaration is itself a previous
10655
         --  formal type, then it is local to the generic and absent from the
10656
         --  analyzed generic definition. In that case the ancestor is the
10657
         --  instance of the formal (which must have been instantiated
10658
         --  previously), unless the ancestor is itself a formal derived type.
10659
         --  In this latter case (which is the subject of Corrigendum 8652/0038
10660
         --  (AI-202) the ancestor of the formals is the ancestor of its
10661
         --  parent. Otherwise, the analyzed generic carries the parent type.
10662
         --  If the parent type is defined in a previous formal package, then
10663
         --  the scope of that formal package is that of the generic type
10664
         --  itself, and it has already been mapped into the corresponding type
10665
         --  in the actual package.
10666
 
10667
         --  Common case: parent type defined outside of the generic
10668
 
10669
         if Is_Entity_Name (Subtype_Mark (Def))
10670
           and then Present (Entity (Subtype_Mark (Def)))
10671
         then
10672
            Ancestor := Get_Instance_Of (Entity (Subtype_Mark (Def)));
10673
 
10674
         --  Check whether parent is defined in a previous formal package
10675
 
10676
         elsif
10677
           Scope (Scope (Base_Type (Etype (A_Gen_T)))) = Scope (A_Gen_T)
10678
         then
10679
            Ancestor :=
10680
              Get_Instance_Of (Base_Type (Etype (A_Gen_T)));
10681
 
10682
         --  The type may be a local derivation, or a type extension of a
10683
         --  previous formal, or of a formal of a parent package.
10684
 
10685
         elsif Is_Derived_Type (Get_Instance_Of (A_Gen_T))
10686
          or else
10687
            Ekind (Get_Instance_Of (A_Gen_T)) = E_Record_Type_With_Private
10688
         then
10689
            --  Check whether the parent is another derived formal type in the
10690
            --  same generic unit.
10691
 
10692
            if Etype (A_Gen_T) /= A_Gen_T
10693
              and then Is_Generic_Type (Etype (A_Gen_T))
10694
              and then Scope (Etype (A_Gen_T)) = Scope (A_Gen_T)
10695
              and then Etype (Etype (A_Gen_T)) /= Etype (A_Gen_T)
10696
            then
10697
               --  Locate ancestor of parent from the subtype declaration
10698
               --  created for the actual.
10699
 
10700
               declare
10701
                  Decl : Node_Id;
10702
 
10703
               begin
10704
                  Decl := First (Actual_Decls);
10705
                  while Present (Decl) loop
10706
                     if Nkind (Decl) = N_Subtype_Declaration
10707
                       and then Chars (Defining_Identifier (Decl)) =
10708
                                                    Chars (Etype (A_Gen_T))
10709
                     then
10710
                        Ancestor := Generic_Parent_Type (Decl);
10711
                        exit;
10712
                     else
10713
                        Next (Decl);
10714
                     end if;
10715
                  end loop;
10716
               end;
10717
 
10718
               pragma Assert (Present (Ancestor));
10719
 
10720
            else
10721
               Ancestor :=
10722
                 Get_Instance_Of (Base_Type (Get_Instance_Of (A_Gen_T)));
10723
            end if;
10724
 
10725
         else
10726
            Ancestor := Get_Instance_Of (Etype (Base_Type (A_Gen_T)));
10727
         end if;
10728
 
10729
         --  If the formal derived type has pragma Preelaborable_Initialization
10730
         --  then the actual type must have preelaborable initialization.
10731
 
10732
         if Known_To_Have_Preelab_Init (A_Gen_T)
10733
           and then not Has_Preelaborable_Initialization (Act_T)
10734
         then
10735
            Error_Msg_NE
10736
              ("actual for & must have preelaborable initialization",
10737
               Actual, Gen_T);
10738
         end if;
10739
 
10740
         --  Ada 2005 (AI-251)
10741
 
10742
         if Ada_Version >= Ada_2005
10743
           and then Is_Interface (Ancestor)
10744
         then
10745
            if not Interface_Present_In_Ancestor (Act_T, Ancestor) then
10746
               Error_Msg_NE
10747
                 ("(Ada 2005) expected type implementing & in instantiation",
10748
                  Actual, Ancestor);
10749
            end if;
10750
 
10751
         elsif not Is_Ancestor (Base_Type (Ancestor), Act_T) then
10752
            Error_Msg_NE
10753
              ("expect type derived from & in instantiation",
10754
               Actual, First_Subtype (Ancestor));
10755
            Abandon_Instantiation (Actual);
10756
         end if;
10757
 
10758
         --  Ada 2005 (AI-443): Synchronized formal derived type checks. Note
10759
         --  that the formal type declaration has been rewritten as a private
10760
         --  extension.
10761
 
10762
         if Ada_Version >= Ada_2005
10763
           and then Nkind (Parent (A_Gen_T)) = N_Private_Extension_Declaration
10764
           and then Synchronized_Present (Parent (A_Gen_T))
10765
         then
10766
            --  The actual must be a synchronized tagged type
10767
 
10768
            if not Is_Tagged_Type (Act_T) then
10769
               Error_Msg_N
10770
                 ("actual of synchronized type must be tagged", Actual);
10771
               Abandon_Instantiation (Actual);
10772
 
10773
            elsif Nkind (Parent (Act_T)) = N_Full_Type_Declaration
10774
              and then Nkind (Type_Definition (Parent (Act_T))) =
10775
                         N_Derived_Type_Definition
10776
              and then not Synchronized_Present (Type_Definition
10777
                             (Parent (Act_T)))
10778
            then
10779
               Error_Msg_N
10780
                 ("actual of synchronized type must be synchronized", Actual);
10781
               Abandon_Instantiation (Actual);
10782
            end if;
10783
         end if;
10784
 
10785
         --  Perform atomic/volatile checks (RM C.6(12)). Note that AI05-0218-1
10786
         --  removes the second instance of the phrase "or allow pass by copy".
10787
 
10788
         if Is_Atomic (Act_T) and then not Is_Atomic (Ancestor) then
10789
            Error_Msg_N
10790
              ("cannot have atomic actual type for non-atomic formal type",
10791
               Actual);
10792
 
10793
         elsif Is_Volatile (Act_T) and then not Is_Volatile (Ancestor) then
10794
            Error_Msg_N
10795
              ("cannot have volatile actual type for non-volatile formal type",
10796
               Actual);
10797
         end if;
10798
 
10799
         --  It should not be necessary to check for unknown discriminants on
10800
         --  Formal, but for some reason Has_Unknown_Discriminants is false for
10801
         --  A_Gen_T, so Is_Indefinite_Subtype incorrectly returns False. This
10802
         --  needs fixing. ???
10803
 
10804
         if not Is_Indefinite_Subtype (A_Gen_T)
10805
           and then not Unknown_Discriminants_Present (Formal)
10806
           and then Is_Indefinite_Subtype (Act_T)
10807
         then
10808
            Error_Msg_N
10809
              ("actual subtype must be constrained", Actual);
10810
            Abandon_Instantiation (Actual);
10811
         end if;
10812
 
10813
         if not Unknown_Discriminants_Present (Formal) then
10814
            if Is_Constrained (Ancestor) then
10815
               if not Is_Constrained (Act_T) then
10816
                  Error_Msg_N
10817
                    ("actual subtype must be constrained", Actual);
10818
                  Abandon_Instantiation (Actual);
10819
               end if;
10820
 
10821
            --  Ancestor is unconstrained, Check if generic formal and actual
10822
            --  agree on constrainedness. The check only applies to array types
10823
            --  and discriminated types.
10824
 
10825
            elsif Is_Constrained (Act_T) then
10826
               if Ekind (Ancestor) = E_Access_Type
10827
                 or else
10828
                   (not Is_Constrained (A_Gen_T)
10829
                     and then Is_Composite_Type (A_Gen_T))
10830
               then
10831
                  Error_Msg_N
10832
                    ("actual subtype must be unconstrained", Actual);
10833
                  Abandon_Instantiation (Actual);
10834
               end if;
10835
 
10836
            --  A class-wide type is only allowed if the formal has unknown
10837
            --  discriminants.
10838
 
10839
            elsif Is_Class_Wide_Type (Act_T)
10840
              and then not Has_Unknown_Discriminants (Ancestor)
10841
            then
10842
               Error_Msg_NE
10843
                 ("actual for & cannot be a class-wide type", Actual, Gen_T);
10844
               Abandon_Instantiation (Actual);
10845
 
10846
            --  Otherwise, the formal and actual shall have the same number
10847
            --  of discriminants and each discriminant of the actual must
10848
            --  correspond to a discriminant of the formal.
10849
 
10850
            elsif Has_Discriminants (Act_T)
10851
              and then not Has_Unknown_Discriminants (Act_T)
10852
              and then Has_Discriminants (Ancestor)
10853
            then
10854
               Actual_Discr   := First_Discriminant (Act_T);
10855
               Ancestor_Discr := First_Discriminant (Ancestor);
10856
               while Present (Actual_Discr)
10857
                 and then Present (Ancestor_Discr)
10858
               loop
10859
                  if Base_Type (Act_T) /= Base_Type (Ancestor) and then
10860
                    No (Corresponding_Discriminant (Actual_Discr))
10861
                  then
10862
                     Error_Msg_NE
10863
                       ("discriminant & does not correspond " &
10864
                        "to ancestor discriminant", Actual, Actual_Discr);
10865
                     Abandon_Instantiation (Actual);
10866
                  end if;
10867
 
10868
                  Next_Discriminant (Actual_Discr);
10869
                  Next_Discriminant (Ancestor_Discr);
10870
               end loop;
10871
 
10872
               if Present (Actual_Discr) or else Present (Ancestor_Discr) then
10873
                  Error_Msg_NE
10874
                    ("actual for & must have same number of discriminants",
10875
                     Actual, Gen_T);
10876
                  Abandon_Instantiation (Actual);
10877
               end if;
10878
 
10879
            --  This case should be caught by the earlier check for
10880
            --  constrainedness, but the check here is added for completeness.
10881
 
10882
            elsif Has_Discriminants (Act_T)
10883
              and then not Has_Unknown_Discriminants (Act_T)
10884
            then
10885
               Error_Msg_NE
10886
                 ("actual for & must not have discriminants", Actual, Gen_T);
10887
               Abandon_Instantiation (Actual);
10888
 
10889
            elsif Has_Discriminants (Ancestor) then
10890
               Error_Msg_NE
10891
                 ("actual for & must have known discriminants", Actual, Gen_T);
10892
               Abandon_Instantiation (Actual);
10893
            end if;
10894
 
10895
            if not Subtypes_Statically_Compatible (Act_T, Ancestor) then
10896
               Error_Msg_N
10897
                 ("constraint on actual is incompatible with formal", Actual);
10898
               Abandon_Instantiation (Actual);
10899
            end if;
10900
         end if;
10901
 
10902
         --  If the formal and actual types are abstract, check that there
10903
         --  are no abstract primitives of the actual type that correspond to
10904
         --  nonabstract primitives of the formal type (second sentence of
10905
         --  RM95-3.9.3(9)).
10906
 
10907
         if Is_Abstract_Type (A_Gen_T) and then Is_Abstract_Type (Act_T) then
10908
            Check_Abstract_Primitives : declare
10909
               Gen_Prims  : constant Elist_Id :=
10910
                             Primitive_Operations (A_Gen_T);
10911
               Gen_Elmt   : Elmt_Id;
10912
               Gen_Subp   : Entity_Id;
10913
               Anc_Subp   : Entity_Id;
10914
               Anc_Formal : Entity_Id;
10915
               Anc_F_Type : Entity_Id;
10916
 
10917
               Act_Prims  : constant Elist_Id  := Primitive_Operations (Act_T);
10918
               Act_Elmt   : Elmt_Id;
10919
               Act_Subp   : Entity_Id;
10920
               Act_Formal : Entity_Id;
10921
               Act_F_Type : Entity_Id;
10922
 
10923
               Subprograms_Correspond : Boolean;
10924
 
10925
               function Is_Tagged_Ancestor (T1, T2 : Entity_Id) return Boolean;
10926
               --  Returns true if T2 is derived directly or indirectly from
10927
               --  T1, including derivations from interfaces. T1 and T2 are
10928
               --  required to be specific tagged base types.
10929
 
10930
               ------------------------
10931
               -- Is_Tagged_Ancestor --
10932
               ------------------------
10933
 
10934
               function Is_Tagged_Ancestor (T1, T2 : Entity_Id) return Boolean
10935
               is
10936
                  Intfc_Elmt : Elmt_Id;
10937
 
10938
               begin
10939
                  --  The predicate is satisfied if the types are the same
10940
 
10941
                  if T1 = T2 then
10942
                     return True;
10943
 
10944
                  --  If we've reached the top of the derivation chain then
10945
                  --  we know that T1 is not an ancestor of T2.
10946
 
10947
                  elsif Etype (T2) = T2 then
10948
                     return False;
10949
 
10950
                  --  Proceed to check T2's immediate parent
10951
 
10952
                  elsif Is_Ancestor (T1, Base_Type (Etype (T2))) then
10953
                     return True;
10954
 
10955
                  --  Finally, check to see if T1 is an ancestor of any of T2's
10956
                  --  progenitors.
10957
 
10958
                  else
10959
                     Intfc_Elmt := First_Elmt (Interfaces (T2));
10960
                     while Present (Intfc_Elmt) loop
10961
                        if Is_Ancestor (T1, Node (Intfc_Elmt)) then
10962
                           return True;
10963
                        end if;
10964
 
10965
                        Next_Elmt (Intfc_Elmt);
10966
                     end loop;
10967
                  end if;
10968
 
10969
                  return False;
10970
               end Is_Tagged_Ancestor;
10971
 
10972
            --  Start of processing for Check_Abstract_Primitives
10973
 
10974
            begin
10975
               --  Loop over all of the formal derived type's primitives
10976
 
10977
               Gen_Elmt := First_Elmt (Gen_Prims);
10978
               while Present (Gen_Elmt) loop
10979
                  Gen_Subp := Node (Gen_Elmt);
10980
 
10981
                  --  If the primitive of the formal is not abstract, then
10982
                  --  determine whether there is a corresponding primitive of
10983
                  --  the actual type that's abstract.
10984
 
10985
                  if not Is_Abstract_Subprogram (Gen_Subp) then
10986
                     Act_Elmt := First_Elmt (Act_Prims);
10987
                     while Present (Act_Elmt) loop
10988
                        Act_Subp := Node (Act_Elmt);
10989
 
10990
                        --  If we find an abstract primitive of the actual,
10991
                        --  then we need to test whether it corresponds to the
10992
                        --  subprogram from which the generic formal primitive
10993
                        --  is inherited.
10994
 
10995
                        if Is_Abstract_Subprogram (Act_Subp) then
10996
                           Anc_Subp := Alias (Gen_Subp);
10997
 
10998
                           --  Test whether we have a corresponding primitive
10999
                           --  by comparing names, kinds, formal types, and
11000
                           --  result types.
11001
 
11002
                           if Chars (Anc_Subp) = Chars (Act_Subp)
11003
                             and then Ekind (Anc_Subp) = Ekind (Act_Subp)
11004
                           then
11005
                              Anc_Formal := First_Formal (Anc_Subp);
11006
                              Act_Formal := First_Formal (Act_Subp);
11007
                              while Present (Anc_Formal)
11008
                                and then Present (Act_Formal)
11009
                              loop
11010
                                 Anc_F_Type := Etype (Anc_Formal);
11011
                                 Act_F_Type := Etype (Act_Formal);
11012
 
11013
                                 if Ekind (Anc_F_Type)
11014
                                      = E_Anonymous_Access_Type
11015
                                 then
11016
                                    Anc_F_Type := Designated_Type (Anc_F_Type);
11017
 
11018
                                    if Ekind (Act_F_Type)
11019
                                         = E_Anonymous_Access_Type
11020
                                    then
11021
                                       Act_F_Type :=
11022
                                         Designated_Type (Act_F_Type);
11023
                                    else
11024
                                       exit;
11025
                                    end if;
11026
 
11027
                                 elsif
11028
                                   Ekind (Act_F_Type) = E_Anonymous_Access_Type
11029
                                 then
11030
                                    exit;
11031
                                 end if;
11032
 
11033
                                 Anc_F_Type := Base_Type (Anc_F_Type);
11034
                                 Act_F_Type := Base_Type (Act_F_Type);
11035
 
11036
                                 --  If the formal is controlling, then the
11037
                                 --  the type of the actual primitive's formal
11038
                                 --  must be derived directly or indirectly
11039
                                 --  from the type of the ancestor primitive's
11040
                                 --  formal.
11041
 
11042
                                 if Is_Controlling_Formal (Anc_Formal) then
11043
                                    if not Is_Tagged_Ancestor
11044
                                             (Anc_F_Type, Act_F_Type)
11045
                                    then
11046
                                       exit;
11047
                                    end if;
11048
 
11049
                                 --  Otherwise the types of the formals must
11050
                                 --  be the same.
11051
 
11052
                                 elsif Anc_F_Type /= Act_F_Type then
11053
                                    exit;
11054
                                 end if;
11055
 
11056
                                 Next_Entity (Anc_Formal);
11057
                                 Next_Entity (Act_Formal);
11058
                              end loop;
11059
 
11060
                              --  If we traversed through all of the formals
11061
                              --  then so far the subprograms correspond, so
11062
                              --  now check that any result types correspond.
11063
 
11064
                              if No (Anc_Formal) and then No (Act_Formal) then
11065
                                 Subprograms_Correspond := True;
11066
 
11067
                                 if Ekind (Act_Subp) = E_Function then
11068
                                    Anc_F_Type := Etype (Anc_Subp);
11069
                                    Act_F_Type := Etype (Act_Subp);
11070
 
11071
                                    if Ekind (Anc_F_Type)
11072
                                         = E_Anonymous_Access_Type
11073
                                    then
11074
                                       Anc_F_Type :=
11075
                                         Designated_Type (Anc_F_Type);
11076
 
11077
                                       if Ekind (Act_F_Type)
11078
                                            = E_Anonymous_Access_Type
11079
                                       then
11080
                                          Act_F_Type :=
11081
                                            Designated_Type (Act_F_Type);
11082
                                       else
11083
                                          Subprograms_Correspond := False;
11084
                                       end if;
11085
 
11086
                                    elsif
11087
                                      Ekind (Act_F_Type)
11088
                                        = E_Anonymous_Access_Type
11089
                                    then
11090
                                       Subprograms_Correspond := False;
11091
                                    end if;
11092
 
11093
                                    Anc_F_Type := Base_Type (Anc_F_Type);
11094
                                    Act_F_Type := Base_Type (Act_F_Type);
11095
 
11096
                                    --  Now either the result types must be
11097
                                    --  the same or, if the result type is
11098
                                    --  controlling, the result type of the
11099
                                    --  actual primitive must descend from the
11100
                                    --  result type of the ancestor primitive.
11101
 
11102
                                    if Subprograms_Correspond
11103
                                      and then Anc_F_Type /= Act_F_Type
11104
                                      and then
11105
                                        Has_Controlling_Result (Anc_Subp)
11106
                                      and then
11107
                                        not Is_Tagged_Ancestor
11108
                                              (Anc_F_Type, Act_F_Type)
11109
                                    then
11110
                                       Subprograms_Correspond := False;
11111
                                    end if;
11112
                                 end if;
11113
 
11114
                                 --  Found a matching subprogram belonging to
11115
                                 --  formal ancestor type, so actual subprogram
11116
                                 --  corresponds and this violates 3.9.3(9).
11117
 
11118
                                 if Subprograms_Correspond then
11119
                                    Error_Msg_NE
11120
                                      ("abstract subprogram & overrides " &
11121
                                       "nonabstract subprogram of ancestor",
11122
                                       Actual,
11123
                                       Act_Subp);
11124
                                 end if;
11125
                              end if;
11126
                           end if;
11127
                        end if;
11128
 
11129
                        Next_Elmt (Act_Elmt);
11130
                     end loop;
11131
                  end if;
11132
 
11133
                  Next_Elmt (Gen_Elmt);
11134
               end loop;
11135
            end Check_Abstract_Primitives;
11136
         end if;
11137
 
11138
         --  Verify that limitedness matches. If parent is a limited
11139
         --  interface then  the generic formal is not unless declared
11140
         --  explicitly so. If not declared limited, the actual cannot be
11141
         --  limited (see AI05-0087).
11142
 
11143
         --  Even though this AI is a binding interpretation, we enable the
11144
         --  check only in Ada 2012 mode, because this improper construct
11145
         --  shows up in user code and in existing B-tests.
11146
 
11147
         if Is_Limited_Type (Act_T)
11148
           and then not Is_Limited_Type (A_Gen_T)
11149
           and then Ada_Version >= Ada_2012
11150
         then
11151
            if In_Instance then
11152
               null;
11153
            else
11154
               Error_Msg_NE
11155
                 ("actual for non-limited & cannot be a limited type", Actual,
11156
                  Gen_T);
11157
               Explain_Limited_Type (Act_T, Actual);
11158
               Abandon_Instantiation (Actual);
11159
            end if;
11160
         end if;
11161
      end Validate_Derived_Type_Instance;
11162
 
11163
      ----------------------------------------
11164
      -- Validate_Discriminated_Formal_Type --
11165
      ----------------------------------------
11166
 
11167
      procedure Validate_Discriminated_Formal_Type is
11168
         Formal_Discr : Entity_Id;
11169
         Actual_Discr : Entity_Id;
11170
         Formal_Subt  : Entity_Id;
11171
 
11172
      begin
11173
         if Has_Discriminants (A_Gen_T) then
11174
            if not Has_Discriminants (Act_T) then
11175
               Error_Msg_NE
11176
                 ("actual for & must have discriminants", Actual, Gen_T);
11177
               Abandon_Instantiation (Actual);
11178
 
11179
            elsif Is_Constrained (Act_T) then
11180
               Error_Msg_NE
11181
                 ("actual for & must be unconstrained", Actual, Gen_T);
11182
               Abandon_Instantiation (Actual);
11183
 
11184
            else
11185
               Formal_Discr := First_Discriminant (A_Gen_T);
11186
               Actual_Discr := First_Discriminant (Act_T);
11187
               while Formal_Discr /= Empty loop
11188
                  if Actual_Discr = Empty then
11189
                     Error_Msg_NE
11190
                       ("discriminants on actual do not match formal",
11191
                        Actual, Gen_T);
11192
                     Abandon_Instantiation (Actual);
11193
                  end if;
11194
 
11195
                  Formal_Subt := Get_Instance_Of (Etype (Formal_Discr));
11196
 
11197
                  --  Access discriminants match if designated types do
11198
 
11199
                  if Ekind (Base_Type (Formal_Subt)) = E_Anonymous_Access_Type
11200
                    and then (Ekind (Base_Type (Etype (Actual_Discr)))) =
11201
                                E_Anonymous_Access_Type
11202
                    and then
11203
                      Get_Instance_Of
11204
                        (Designated_Type (Base_Type (Formal_Subt))) =
11205
                           Designated_Type (Base_Type (Etype (Actual_Discr)))
11206
                  then
11207
                     null;
11208
 
11209
                  elsif Base_Type (Formal_Subt) /=
11210
                          Base_Type (Etype (Actual_Discr))
11211
                  then
11212
                     Error_Msg_NE
11213
                       ("types of actual discriminants must match formal",
11214
                        Actual, Gen_T);
11215
                     Abandon_Instantiation (Actual);
11216
 
11217
                  elsif not Subtypes_Statically_Match
11218
                              (Formal_Subt, Etype (Actual_Discr))
11219
                    and then Ada_Version >= Ada_95
11220
                  then
11221
                     Error_Msg_NE
11222
                       ("subtypes of actual discriminants must match formal",
11223
                        Actual, Gen_T);
11224
                     Abandon_Instantiation (Actual);
11225
                  end if;
11226
 
11227
                  Next_Discriminant (Formal_Discr);
11228
                  Next_Discriminant (Actual_Discr);
11229
               end loop;
11230
 
11231
               if Actual_Discr /= Empty then
11232
                  Error_Msg_NE
11233
                    ("discriminants on actual do not match formal",
11234
                     Actual, Gen_T);
11235
                  Abandon_Instantiation (Actual);
11236
               end if;
11237
            end if;
11238
         end if;
11239
      end Validate_Discriminated_Formal_Type;
11240
 
11241
      ---------------------------------------
11242
      -- Validate_Incomplete_Type_Instance --
11243
      ---------------------------------------
11244
 
11245
      procedure Validate_Incomplete_Type_Instance is
11246
      begin
11247
         if not Is_Tagged_Type (Act_T)
11248
           and then Is_Tagged_Type (A_Gen_T)
11249
         then
11250
            Error_Msg_NE
11251
              ("actual for & must be a tagged type", Actual, Gen_T);
11252
         end if;
11253
 
11254
         Validate_Discriminated_Formal_Type;
11255
      end Validate_Incomplete_Type_Instance;
11256
 
11257
      --------------------------------------
11258
      -- Validate_Interface_Type_Instance --
11259
      --------------------------------------
11260
 
11261
      procedure Validate_Interface_Type_Instance is
11262
      begin
11263
         if not Is_Interface (Act_T) then
11264
            Error_Msg_NE
11265
              ("actual for formal interface type must be an interface",
11266
                Actual, Gen_T);
11267
 
11268
         elsif Is_Limited_Type (Act_T) /= Is_Limited_Type (A_Gen_T)
11269
           or else
11270
             Is_Task_Interface (A_Gen_T) /= Is_Task_Interface (Act_T)
11271
           or else
11272
             Is_Protected_Interface (A_Gen_T) /=
11273
               Is_Protected_Interface (Act_T)
11274
           or else
11275
             Is_Synchronized_Interface (A_Gen_T) /=
11276
               Is_Synchronized_Interface (Act_T)
11277
         then
11278
            Error_Msg_NE
11279
              ("actual for interface& does not match (RM 12.5.5(4))",
11280
               Actual, Gen_T);
11281
         end if;
11282
      end Validate_Interface_Type_Instance;
11283
 
11284
      ------------------------------------
11285
      -- Validate_Private_Type_Instance --
11286
      ------------------------------------
11287
 
11288
      procedure Validate_Private_Type_Instance is
11289
      begin
11290
         if Is_Limited_Type (Act_T)
11291
           and then not Is_Limited_Type (A_Gen_T)
11292
         then
11293
            if In_Instance then
11294
               null;
11295
            else
11296
               Error_Msg_NE
11297
                 ("actual for non-limited & cannot be a limited type", Actual,
11298
                  Gen_T);
11299
               Explain_Limited_Type (Act_T, Actual);
11300
               Abandon_Instantiation (Actual);
11301
            end if;
11302
 
11303
         elsif Known_To_Have_Preelab_Init (A_Gen_T)
11304
           and then not Has_Preelaborable_Initialization (Act_T)
11305
         then
11306
            Error_Msg_NE
11307
              ("actual for & must have preelaborable initialization", Actual,
11308
               Gen_T);
11309
 
11310
         elsif Is_Indefinite_Subtype (Act_T)
11311
            and then not Is_Indefinite_Subtype (A_Gen_T)
11312
            and then Ada_Version >= Ada_95
11313
         then
11314
            Error_Msg_NE
11315
              ("actual for & must be a definite subtype", Actual, Gen_T);
11316
 
11317
         elsif not Is_Tagged_Type (Act_T)
11318
           and then Is_Tagged_Type (A_Gen_T)
11319
         then
11320
            Error_Msg_NE
11321
              ("actual for & must be a tagged type", Actual, Gen_T);
11322
         end if;
11323
 
11324
         Validate_Discriminated_Formal_Type;
11325
         Ancestor := Gen_T;
11326
      end Validate_Private_Type_Instance;
11327
 
11328
   --  Start of processing for Instantiate_Type
11329
 
11330
   begin
11331
      if Get_Instance_Of (A_Gen_T) /= A_Gen_T then
11332
         Error_Msg_N ("duplicate instantiation of generic type", Actual);
11333
         return New_List (Error);
11334
 
11335
      elsif not Is_Entity_Name (Actual)
11336
        or else not Is_Type (Entity (Actual))
11337
      then
11338
         Error_Msg_NE
11339
           ("expect valid subtype mark to instantiate &", Actual, Gen_T);
11340
         Abandon_Instantiation (Actual);
11341
 
11342
      else
11343
         Act_T := Entity (Actual);
11344
 
11345
         --  Ada 2005 (AI-216): An Unchecked_Union subtype shall only be passed
11346
         --  as a generic actual parameter if the corresponding formal type
11347
         --  does not have a known_discriminant_part, or is a formal derived
11348
         --  type that is an Unchecked_Union type.
11349
 
11350
         if Is_Unchecked_Union (Base_Type (Act_T)) then
11351
            if not Has_Discriminants (A_Gen_T)
11352
                     or else
11353
                   (Is_Derived_Type (A_Gen_T)
11354
                     and then
11355
                    Is_Unchecked_Union (A_Gen_T))
11356
            then
11357
               null;
11358
            else
11359
               Error_Msg_N ("Unchecked_Union cannot be the actual for a" &
11360
                 " discriminated formal type", Act_T);
11361
 
11362
            end if;
11363
         end if;
11364
 
11365
         --  Deal with fixed/floating restrictions
11366
 
11367
         if Is_Floating_Point_Type (Act_T) then
11368
            Check_Restriction (No_Floating_Point, Actual);
11369
         elsif Is_Fixed_Point_Type (Act_T) then
11370
            Check_Restriction (No_Fixed_Point, Actual);
11371
         end if;
11372
 
11373
         --  Deal with error of using incomplete type as generic actual.
11374
         --  This includes limited views of a type, even if the non-limited
11375
         --  view may be available.
11376
 
11377
         if Ekind (Act_T) = E_Incomplete_Type
11378
           or else (Is_Class_Wide_Type (Act_T)
11379
                      and then
11380
                         Ekind (Root_Type (Act_T)) = E_Incomplete_Type)
11381
         then
11382
            --  If the formal is an incomplete type, the actual can be
11383
            --  incomplete as well.
11384
 
11385
            if Ekind (A_Gen_T) = E_Incomplete_Type then
11386
               null;
11387
 
11388
            elsif Is_Class_Wide_Type (Act_T)
11389
              or else No (Full_View (Act_T))
11390
            then
11391
               Error_Msg_N ("premature use of incomplete type", Actual);
11392
               Abandon_Instantiation (Actual);
11393
            else
11394
               Act_T := Full_View (Act_T);
11395
               Set_Entity (Actual, Act_T);
11396
 
11397
               if Has_Private_Component (Act_T) then
11398
                  Error_Msg_N
11399
                    ("premature use of type with private component", Actual);
11400
               end if;
11401
            end if;
11402
 
11403
         --  Deal with error of premature use of private type as generic actual
11404
 
11405
         elsif Is_Private_Type (Act_T)
11406
           and then Is_Private_Type (Base_Type (Act_T))
11407
           and then not Is_Generic_Type (Act_T)
11408
           and then not Is_Derived_Type (Act_T)
11409
           and then No (Full_View (Root_Type (Act_T)))
11410
         then
11411
            --  If the formal is an incomplete type, the actual can be
11412
            --  private or incomplete as well.
11413
 
11414
            if Ekind (A_Gen_T) = E_Incomplete_Type then
11415
               null;
11416
            else
11417
               Error_Msg_N ("premature use of private type", Actual);
11418
            end if;
11419
 
11420
         elsif Has_Private_Component (Act_T) then
11421
            Error_Msg_N
11422
              ("premature use of type with private component", Actual);
11423
         end if;
11424
 
11425
         Set_Instance_Of (A_Gen_T, Act_T);
11426
 
11427
         --  If the type is generic, the class-wide type may also be used
11428
 
11429
         if Is_Tagged_Type (A_Gen_T)
11430
           and then Is_Tagged_Type (Act_T)
11431
           and then not Is_Class_Wide_Type (A_Gen_T)
11432
         then
11433
            Set_Instance_Of (Class_Wide_Type (A_Gen_T),
11434
              Class_Wide_Type (Act_T));
11435
         end if;
11436
 
11437
         if not Is_Abstract_Type (A_Gen_T)
11438
           and then Is_Abstract_Type (Act_T)
11439
         then
11440
            Error_Msg_N
11441
              ("actual of non-abstract formal cannot be abstract", Actual);
11442
         end if;
11443
 
11444
         --  A generic scalar type is a first subtype for which we generate
11445
         --  an anonymous base type. Indicate that the instance of this base
11446
         --  is the base type of the actual.
11447
 
11448
         if Is_Scalar_Type (A_Gen_T) then
11449
            Set_Instance_Of (Etype (A_Gen_T), Etype (Act_T));
11450
         end if;
11451
      end if;
11452
 
11453
      if Error_Posted (Act_T) then
11454
         null;
11455
      else
11456
         case Nkind (Def) is
11457
            when N_Formal_Private_Type_Definition =>
11458
               Validate_Private_Type_Instance;
11459
 
11460
            when N_Formal_Incomplete_Type_Definition =>
11461
               Validate_Incomplete_Type_Instance;
11462
 
11463
            when N_Formal_Derived_Type_Definition =>
11464
               Validate_Derived_Type_Instance;
11465
 
11466
            when N_Formal_Discrete_Type_Definition =>
11467
               if not Is_Discrete_Type (Act_T) then
11468
                  Error_Msg_NE
11469
                    ("expect discrete type in instantiation of&",
11470
                       Actual, Gen_T);
11471
                  Abandon_Instantiation (Actual);
11472
               end if;
11473
 
11474
            when N_Formal_Signed_Integer_Type_Definition =>
11475
               if not Is_Signed_Integer_Type (Act_T) then
11476
                  Error_Msg_NE
11477
                    ("expect signed integer type in instantiation of&",
11478
                     Actual, Gen_T);
11479
                  Abandon_Instantiation (Actual);
11480
               end if;
11481
 
11482
            when N_Formal_Modular_Type_Definition =>
11483
               if not Is_Modular_Integer_Type (Act_T) then
11484
                  Error_Msg_NE
11485
                    ("expect modular type in instantiation of &",
11486
                       Actual, Gen_T);
11487
                  Abandon_Instantiation (Actual);
11488
               end if;
11489
 
11490
            when N_Formal_Floating_Point_Definition =>
11491
               if not Is_Floating_Point_Type (Act_T) then
11492
                  Error_Msg_NE
11493
                    ("expect float type in instantiation of &", Actual, Gen_T);
11494
                  Abandon_Instantiation (Actual);
11495
               end if;
11496
 
11497
            when N_Formal_Ordinary_Fixed_Point_Definition =>
11498
               if not Is_Ordinary_Fixed_Point_Type (Act_T) then
11499
                  Error_Msg_NE
11500
                    ("expect ordinary fixed point type in instantiation of &",
11501
                     Actual, Gen_T);
11502
                  Abandon_Instantiation (Actual);
11503
               end if;
11504
 
11505
            when N_Formal_Decimal_Fixed_Point_Definition =>
11506
               if not Is_Decimal_Fixed_Point_Type (Act_T) then
11507
                  Error_Msg_NE
11508
                    ("expect decimal type in instantiation of &",
11509
                     Actual, Gen_T);
11510
                  Abandon_Instantiation (Actual);
11511
               end if;
11512
 
11513
            when N_Array_Type_Definition =>
11514
               Validate_Array_Type_Instance;
11515
 
11516
            when N_Access_To_Object_Definition =>
11517
               Validate_Access_Type_Instance;
11518
 
11519
            when N_Access_Function_Definition |
11520
                 N_Access_Procedure_Definition =>
11521
               Validate_Access_Subprogram_Instance;
11522
 
11523
            when N_Record_Definition           =>
11524
               Validate_Interface_Type_Instance;
11525
 
11526
            when N_Derived_Type_Definition     =>
11527
               Validate_Derived_Interface_Type_Instance;
11528
 
11529
            when others =>
11530
               raise Program_Error;
11531
 
11532
         end case;
11533
      end if;
11534
 
11535
      Subt := New_Copy (Gen_T);
11536
 
11537
      --  Use adjusted sloc of subtype name as the location for other nodes in
11538
      --  the subtype declaration.
11539
 
11540
      Loc  := Sloc (Subt);
11541
 
11542
      Decl_Node :=
11543
        Make_Subtype_Declaration (Loc,
11544
          Defining_Identifier => Subt,
11545
          Subtype_Indication  => New_Reference_To (Act_T, Loc));
11546
 
11547
      if Is_Private_Type (Act_T) then
11548
         Set_Has_Private_View (Subtype_Indication (Decl_Node));
11549
 
11550
      elsif Is_Access_Type (Act_T)
11551
        and then Is_Private_Type (Designated_Type (Act_T))
11552
      then
11553
         Set_Has_Private_View (Subtype_Indication (Decl_Node));
11554
      end if;
11555
 
11556
      Decl_Nodes := New_List (Decl_Node);
11557
 
11558
      --  Flag actual derived types so their elaboration produces the
11559
      --  appropriate renamings for the primitive operations of the ancestor.
11560
      --  Flag actual for formal private types as well, to determine whether
11561
      --  operations in the private part may override inherited operations.
11562
      --  If the formal has an interface list, the ancestor is not the
11563
      --  parent, but the analyzed formal that includes the interface
11564
      --  operations of all its progenitors.
11565
 
11566
      --  Same treatment for formal private types, so we can check whether the
11567
      --  type is tagged limited when validating derivations in the private
11568
      --  part. (See AI05-096).
11569
 
11570
      if Nkind (Def) = N_Formal_Derived_Type_Definition then
11571
         if Present (Interface_List (Def)) then
11572
            Set_Generic_Parent_Type (Decl_Node, A_Gen_T);
11573
         else
11574
            Set_Generic_Parent_Type (Decl_Node, Ancestor);
11575
         end if;
11576
 
11577
      elsif Nkind_In (Def,
11578
        N_Formal_Private_Type_Definition,
11579
        N_Formal_Incomplete_Type_Definition)
11580
      then
11581
         Set_Generic_Parent_Type (Decl_Node, A_Gen_T);
11582
      end if;
11583
 
11584
      --  If the actual is a synchronized type that implements an interface,
11585
      --  the primitive operations are attached to the corresponding record,
11586
      --  and we have to treat it as an additional generic actual, so that its
11587
      --  primitive operations become visible in the instance. The task or
11588
      --  protected type itself does not carry primitive operations.
11589
 
11590
      if Is_Concurrent_Type (Act_T)
11591
        and then Is_Tagged_Type (Act_T)
11592
        and then Present (Corresponding_Record_Type (Act_T))
11593
        and then Present (Ancestor)
11594
        and then Is_Interface (Ancestor)
11595
      then
11596
         declare
11597
            Corr_Rec  : constant Entity_Id :=
11598
                          Corresponding_Record_Type (Act_T);
11599
            New_Corr  : Entity_Id;
11600
            Corr_Decl : Node_Id;
11601
 
11602
         begin
11603
            New_Corr := Make_Temporary (Loc, 'S');
11604
            Corr_Decl :=
11605
              Make_Subtype_Declaration (Loc,
11606
                Defining_Identifier => New_Corr,
11607
                Subtype_Indication  =>
11608
                  New_Reference_To (Corr_Rec, Loc));
11609
            Append_To (Decl_Nodes, Corr_Decl);
11610
 
11611
            if Ekind (Act_T) = E_Task_Type then
11612
               Set_Ekind (Subt, E_Task_Subtype);
11613
            else
11614
               Set_Ekind (Subt, E_Protected_Subtype);
11615
            end if;
11616
 
11617
            Set_Corresponding_Record_Type (Subt, Corr_Rec);
11618
            Set_Generic_Parent_Type (Corr_Decl, Ancestor);
11619
            Set_Generic_Parent_Type (Decl_Node, Empty);
11620
         end;
11621
      end if;
11622
 
11623
      return Decl_Nodes;
11624
   end Instantiate_Type;
11625
 
11626
   ---------------------
11627
   -- Is_In_Main_Unit --
11628
   ---------------------
11629
 
11630
   function Is_In_Main_Unit (N : Node_Id) return Boolean is
11631
      Unum         : constant Unit_Number_Type := Get_Source_Unit (N);
11632
      Current_Unit : Node_Id;
11633
 
11634
   begin
11635
      if Unum = Main_Unit then
11636
         return True;
11637
 
11638
      --  If the current unit is a subunit then it is either the main unit or
11639
      --  is being compiled as part of the main unit.
11640
 
11641
      elsif Nkind (N) = N_Compilation_Unit then
11642
         return Nkind (Unit (N)) = N_Subunit;
11643
      end if;
11644
 
11645
      Current_Unit := Parent (N);
11646
      while Present (Current_Unit)
11647
        and then Nkind (Current_Unit) /= N_Compilation_Unit
11648
      loop
11649
         Current_Unit := Parent (Current_Unit);
11650
      end loop;
11651
 
11652
      --  The instantiation node is in the main unit, or else the current node
11653
      --  (perhaps as the result of nested instantiations) is in the main unit,
11654
      --  or in the declaration of the main unit, which in this last case must
11655
      --  be a body.
11656
 
11657
      return Unum = Main_Unit
11658
        or else Current_Unit = Cunit (Main_Unit)
11659
        or else Current_Unit = Library_Unit (Cunit (Main_Unit))
11660
        or else (Present (Library_Unit (Current_Unit))
11661
                  and then Is_In_Main_Unit (Library_Unit (Current_Unit)));
11662
   end Is_In_Main_Unit;
11663
 
11664
   ----------------------------
11665
   -- Load_Parent_Of_Generic --
11666
   ----------------------------
11667
 
11668
   procedure Load_Parent_Of_Generic
11669
     (N             : Node_Id;
11670
      Spec          : Node_Id;
11671
      Body_Optional : Boolean := False)
11672
   is
11673
      Comp_Unit          : constant Node_Id := Cunit (Get_Source_Unit (Spec));
11674
      Save_Style_Check   : constant Boolean := Style_Check;
11675
      True_Parent        : Node_Id;
11676
      Inst_Node          : Node_Id;
11677
      OK                 : Boolean;
11678
      Previous_Instances : constant Elist_Id := New_Elmt_List;
11679
 
11680
      procedure Collect_Previous_Instances (Decls : List_Id);
11681
      --  Collect all instantiations in the given list of declarations, that
11682
      --  precede the generic that we need to load. If the bodies of these
11683
      --  instantiations are available, we must analyze them, to ensure that
11684
      --  the public symbols generated are the same when the unit is compiled
11685
      --  to generate code, and when it is compiled in the context of a unit
11686
      --  that needs a particular nested instance. This process is applied to
11687
      --  both package and subprogram instances.
11688
 
11689
      --------------------------------
11690
      -- Collect_Previous_Instances --
11691
      --------------------------------
11692
 
11693
      procedure Collect_Previous_Instances (Decls : List_Id) is
11694
         Decl : Node_Id;
11695
 
11696
      begin
11697
         Decl := First (Decls);
11698
         while Present (Decl) loop
11699
            if Sloc (Decl) >= Sloc (Inst_Node) then
11700
               return;
11701
 
11702
            --  If Decl is an instantiation, then record it as requiring
11703
            --  instantiation of the corresponding body, except if it is an
11704
            --  abbreviated instantiation generated internally for conformance
11705
            --  checking purposes only for the case of a formal package
11706
            --  declared without a box (see Instantiate_Formal_Package). Such
11707
            --  an instantiation does not generate any code (the actual code
11708
            --  comes from actual) and thus does not need to be analyzed here.
11709
            --  If the instantiation appears with a generic package body it is
11710
            --  not analyzed here either.
11711
 
11712
            elsif Nkind (Decl) = N_Package_Instantiation
11713
              and then not Is_Internal (Defining_Entity (Decl))
11714
            then
11715
               Append_Elmt (Decl, Previous_Instances);
11716
 
11717
            --  For a subprogram instantiation, omit instantiations intrinsic
11718
            --  operations (Unchecked_Conversions, etc.) that have no bodies.
11719
 
11720
            elsif Nkind_In (Decl, N_Function_Instantiation,
11721
                                  N_Procedure_Instantiation)
11722
              and then not Is_Intrinsic_Subprogram (Entity (Name (Decl)))
11723
            then
11724
               Append_Elmt (Decl, Previous_Instances);
11725
 
11726
            elsif Nkind (Decl) = N_Package_Declaration then
11727
               Collect_Previous_Instances
11728
                 (Visible_Declarations (Specification (Decl)));
11729
               Collect_Previous_Instances
11730
                 (Private_Declarations (Specification (Decl)));
11731
 
11732
            --  Previous non-generic bodies may contain instances as well
11733
 
11734
            elsif Nkind (Decl) = N_Package_Body
11735
              and then Ekind (Corresponding_Spec (Decl)) /= E_Generic_Package
11736
            then
11737
               Collect_Previous_Instances (Declarations (Decl));
11738
 
11739
            elsif Nkind (Decl) = N_Subprogram_Body
11740
              and then not Acts_As_Spec (Decl)
11741
              and then not Is_Generic_Subprogram (Corresponding_Spec (Decl))
11742
            then
11743
               Collect_Previous_Instances (Declarations (Decl));
11744
            end if;
11745
 
11746
            Next (Decl);
11747
         end loop;
11748
      end Collect_Previous_Instances;
11749
 
11750
   --  Start of processing for Load_Parent_Of_Generic
11751
 
11752
   begin
11753
      if not In_Same_Source_Unit (N, Spec)
11754
        or else Nkind (Unit (Comp_Unit)) = N_Package_Declaration
11755
        or else (Nkind (Unit (Comp_Unit)) = N_Package_Body
11756
                   and then not Is_In_Main_Unit (Spec))
11757
      then
11758
         --  Find body of parent of spec, and analyze it. A special case arises
11759
         --  when the parent is an instantiation, that is to say when we are
11760
         --  currently instantiating a nested generic. In that case, there is
11761
         --  no separate file for the body of the enclosing instance. Instead,
11762
         --  the enclosing body must be instantiated as if it were a pending
11763
         --  instantiation, in order to produce the body for the nested generic
11764
         --  we require now. Note that in that case the generic may be defined
11765
         --  in a package body, the instance defined in the same package body,
11766
         --  and the original enclosing body may not be in the main unit.
11767
 
11768
         Inst_Node := Empty;
11769
 
11770
         True_Parent := Parent (Spec);
11771
         while Present (True_Parent)
11772
           and then Nkind (True_Parent) /= N_Compilation_Unit
11773
         loop
11774
            if Nkind (True_Parent) = N_Package_Declaration
11775
                 and then
11776
               Nkind (Original_Node (True_Parent)) = N_Package_Instantiation
11777
            then
11778
               --  Parent is a compilation unit that is an instantiation.
11779
               --  Instantiation node has been replaced with package decl.
11780
 
11781
               Inst_Node := Original_Node (True_Parent);
11782
               exit;
11783
 
11784
            elsif Nkind (True_Parent) = N_Package_Declaration
11785
              and then Present (Generic_Parent (Specification (True_Parent)))
11786
              and then Nkind (Parent (True_Parent)) /= N_Compilation_Unit
11787
            then
11788
               --  Parent is an instantiation within another specification.
11789
               --  Declaration for instance has been inserted before original
11790
               --  instantiation node. A direct link would be preferable?
11791
 
11792
               Inst_Node := Next (True_Parent);
11793
               while Present (Inst_Node)
11794
                 and then Nkind (Inst_Node) /= N_Package_Instantiation
11795
               loop
11796
                  Next (Inst_Node);
11797
               end loop;
11798
 
11799
               --  If the instance appears within a generic, and the generic
11800
               --  unit is defined within a formal package of the enclosing
11801
               --  generic, there is no generic body available, and none
11802
               --  needed. A more precise test should be used ???
11803
 
11804
               if No (Inst_Node) then
11805
                  return;
11806
               end if;
11807
 
11808
               exit;
11809
 
11810
            else
11811
               True_Parent := Parent (True_Parent);
11812
            end if;
11813
         end loop;
11814
 
11815
         --  Case where we are currently instantiating a nested generic
11816
 
11817
         if Present (Inst_Node) then
11818
            if Nkind (Parent (True_Parent)) = N_Compilation_Unit then
11819
 
11820
               --  Instantiation node and declaration of instantiated package
11821
               --  were exchanged when only the declaration was needed.
11822
               --  Restore instantiation node before proceeding with body.
11823
 
11824
               Set_Unit (Parent (True_Parent), Inst_Node);
11825
            end if;
11826
 
11827
            --  Now complete instantiation of enclosing body, if it appears in
11828
            --  some other unit. If it appears in the current unit, the body
11829
            --  will have been instantiated already.
11830
 
11831
            if No (Corresponding_Body (Instance_Spec (Inst_Node))) then
11832
 
11833
               --  We need to determine the expander mode to instantiate the
11834
               --  enclosing body. Because the generic body we need may use
11835
               --  global entities declared in the enclosing package (including
11836
               --  aggregates) it is in general necessary to compile this body
11837
               --  with expansion enabled, except if we are within a generic
11838
               --  package, in which case the usual generic rule applies.
11839
 
11840
               declare
11841
                  Exp_Status         : Boolean := True;
11842
                  Scop               : Entity_Id;
11843
 
11844
               begin
11845
                  --  Loop through scopes looking for generic package
11846
 
11847
                  Scop := Scope (Defining_Entity (Instance_Spec (Inst_Node)));
11848
                  while Present (Scop)
11849
                    and then Scop /= Standard_Standard
11850
                  loop
11851
                     if Ekind (Scop) = E_Generic_Package then
11852
                        Exp_Status := False;
11853
                        exit;
11854
                     end if;
11855
 
11856
                     Scop := Scope (Scop);
11857
                  end loop;
11858
 
11859
                  --  Collect previous instantiations in the unit that contains
11860
                  --  the desired generic.
11861
 
11862
                  if Nkind (Parent (True_Parent)) /= N_Compilation_Unit
11863
                    and then not Body_Optional
11864
                  then
11865
                     declare
11866
                        Decl : Elmt_Id;
11867
                        Info : Pending_Body_Info;
11868
                        Par  : Node_Id;
11869
 
11870
                     begin
11871
                        Par := Parent (Inst_Node);
11872
                        while Present (Par) loop
11873
                           exit when Nkind (Parent (Par)) = N_Compilation_Unit;
11874
                           Par := Parent (Par);
11875
                        end loop;
11876
 
11877
                        pragma Assert (Present (Par));
11878
 
11879
                        if Nkind (Par) = N_Package_Body then
11880
                           Collect_Previous_Instances (Declarations (Par));
11881
 
11882
                        elsif Nkind (Par) = N_Package_Declaration then
11883
                           Collect_Previous_Instances
11884
                             (Visible_Declarations (Specification (Par)));
11885
                           Collect_Previous_Instances
11886
                             (Private_Declarations (Specification (Par)));
11887
 
11888
                        else
11889
                           --  Enclosing unit is a subprogram body. In this
11890
                           --  case all instance bodies are processed in order
11891
                           --  and there is no need to collect them separately.
11892
 
11893
                           null;
11894
                        end if;
11895
 
11896
                        Decl := First_Elmt (Previous_Instances);
11897
                        while Present (Decl) loop
11898
                           Info :=
11899
                             (Inst_Node                => Node (Decl),
11900
                              Act_Decl                 =>
11901
                                Instance_Spec (Node (Decl)),
11902
                              Expander_Status          => Exp_Status,
11903
                              Current_Sem_Unit         =>
11904
                                Get_Code_Unit (Sloc (Node (Decl))),
11905
                              Scope_Suppress           => Scope_Suppress,
11906
                              Local_Suppress_Stack_Top =>
11907
                                Local_Suppress_Stack_Top,
11908
                              Version                  => Ada_Version);
11909
 
11910
                           --  Package instance
11911
 
11912
                           if
11913
                             Nkind (Node (Decl)) = N_Package_Instantiation
11914
                           then
11915
                              Instantiate_Package_Body
11916
                                (Info, Body_Optional => True);
11917
 
11918
                           --  Subprogram instance
11919
 
11920
                           else
11921
                              --  The instance_spec is the wrapper package,
11922
                              --  and the subprogram declaration is the last
11923
                              --  declaration in the wrapper.
11924
 
11925
                              Info.Act_Decl :=
11926
                                Last
11927
                                  (Visible_Declarations
11928
                                    (Specification (Info.Act_Decl)));
11929
 
11930
                              Instantiate_Subprogram_Body
11931
                                (Info, Body_Optional => True);
11932
                           end if;
11933
 
11934
                           Next_Elmt (Decl);
11935
                        end loop;
11936
                     end;
11937
                  end if;
11938
 
11939
                  Instantiate_Package_Body
11940
                    (Body_Info =>
11941
                       ((Inst_Node                => Inst_Node,
11942
                         Act_Decl                 => True_Parent,
11943
                         Expander_Status          => Exp_Status,
11944
                         Current_Sem_Unit         =>
11945
                           Get_Code_Unit (Sloc (Inst_Node)),
11946
                         Scope_Suppress           => Scope_Suppress,
11947
                         Local_Suppress_Stack_Top =>
11948
                           Local_Suppress_Stack_Top,
11949
                           Version                => Ada_Version)),
11950
                     Body_Optional => Body_Optional);
11951
               end;
11952
            end if;
11953
 
11954
         --  Case where we are not instantiating a nested generic
11955
 
11956
         else
11957
            Opt.Style_Check := False;
11958
            Expander_Mode_Save_And_Set (True);
11959
            Load_Needed_Body (Comp_Unit, OK);
11960
            Opt.Style_Check := Save_Style_Check;
11961
            Expander_Mode_Restore;
11962
 
11963
            if not OK
11964
              and then Unit_Requires_Body (Defining_Entity (Spec))
11965
              and then not Body_Optional
11966
            then
11967
               declare
11968
                  Bname : constant Unit_Name_Type :=
11969
                            Get_Body_Name (Get_Unit_Name (Unit (Comp_Unit)));
11970
 
11971
               begin
11972
                  --  In CodePeer mode, the missing body may make the analysis
11973
                  --  incomplete, but we do not treat it as fatal.
11974
 
11975
                  if CodePeer_Mode then
11976
                     return;
11977
 
11978
                  else
11979
                     Error_Msg_Unit_1 := Bname;
11980
                     Error_Msg_N ("this instantiation requires$!", N);
11981
                     Error_Msg_File_1 :=
11982
                       Get_File_Name (Bname, Subunit => False);
11983
                     Error_Msg_N ("\but file{ was not found!", N);
11984
                     raise Unrecoverable_Error;
11985
                  end if;
11986
               end;
11987
            end if;
11988
         end if;
11989
      end if;
11990
 
11991
      --  If loading parent of the generic caused an instantiation circularity,
11992
      --  we abandon compilation at this point, because otherwise in some cases
11993
      --  we get into trouble with infinite recursions after this point.
11994
 
11995
      if Circularity_Detected then
11996
         raise Unrecoverable_Error;
11997
      end if;
11998
   end Load_Parent_Of_Generic;
11999
 
12000
   ---------------------------------
12001
   -- Map_Formal_Package_Entities --
12002
   ---------------------------------
12003
 
12004
   procedure Map_Formal_Package_Entities (Form : Entity_Id; Act : Entity_Id) is
12005
      E1 : Entity_Id;
12006
      E2 : Entity_Id;
12007
 
12008
   begin
12009
      Set_Instance_Of (Form, Act);
12010
 
12011
      --  Traverse formal and actual package to map the corresponding entities.
12012
      --  We skip over internal entities that may be generated during semantic
12013
      --  analysis, and find the matching entities by name, given that they
12014
      --  must appear in the same order.
12015
 
12016
      E1 := First_Entity (Form);
12017
      E2 := First_Entity (Act);
12018
      while Present (E1) and then E1 /= First_Private_Entity (Form) loop
12019
         --  Could this test be a single condition???
12020
         --  Seems like it could, and isn't FPE (Form) a constant anyway???
12021
 
12022
         if not Is_Internal (E1)
12023
           and then Present (Parent (E1))
12024
           and then not Is_Class_Wide_Type (E1)
12025
           and then not Is_Internal_Name (Chars (E1))
12026
         then
12027
            while Present (E2) and then Chars (E2) /= Chars (E1) loop
12028
               Next_Entity (E2);
12029
            end loop;
12030
 
12031
            if No (E2) then
12032
               exit;
12033
            else
12034
               Set_Instance_Of (E1, E2);
12035
 
12036
               if Is_Type (E1) and then Is_Tagged_Type (E2) then
12037
                  Set_Instance_Of (Class_Wide_Type (E1), Class_Wide_Type (E2));
12038
               end if;
12039
 
12040
               if Is_Constrained (E1) then
12041
                  Set_Instance_Of (Base_Type (E1), Base_Type (E2));
12042
               end if;
12043
 
12044
               if Ekind (E1) = E_Package and then No (Renamed_Object (E1)) then
12045
                  Map_Formal_Package_Entities (E1, E2);
12046
               end if;
12047
            end if;
12048
         end if;
12049
 
12050
         Next_Entity (E1);
12051
      end loop;
12052
   end Map_Formal_Package_Entities;
12053
 
12054
   -----------------------
12055
   -- Move_Freeze_Nodes --
12056
   -----------------------
12057
 
12058
   procedure Move_Freeze_Nodes
12059
     (Out_Of : Entity_Id;
12060
      After  : Node_Id;
12061
      L      : List_Id)
12062
   is
12063
      Decl      : Node_Id;
12064
      Next_Decl : Node_Id;
12065
      Next_Node : Node_Id := After;
12066
      Spec      : Node_Id;
12067
 
12068
      function Is_Outer_Type (T : Entity_Id) return Boolean;
12069
      --  Check whether entity is declared in a scope external to that of the
12070
      --  generic unit.
12071
 
12072
      -------------------
12073
      -- Is_Outer_Type --
12074
      -------------------
12075
 
12076
      function Is_Outer_Type (T : Entity_Id) return Boolean is
12077
         Scop : Entity_Id := Scope (T);
12078
 
12079
      begin
12080
         if Scope_Depth (Scop) < Scope_Depth (Out_Of) then
12081
            return True;
12082
 
12083
         else
12084
            while Scop /= Standard_Standard loop
12085
               if Scop = Out_Of then
12086
                  return False;
12087
               else
12088
                  Scop := Scope (Scop);
12089
               end if;
12090
            end loop;
12091
 
12092
            return True;
12093
         end if;
12094
      end Is_Outer_Type;
12095
 
12096
   --  Start of processing for Move_Freeze_Nodes
12097
 
12098
   begin
12099
      if No (L) then
12100
         return;
12101
      end if;
12102
 
12103
      --  First remove the freeze nodes that may appear before all other
12104
      --  declarations.
12105
 
12106
      Decl := First (L);
12107
      while Present (Decl)
12108
        and then Nkind (Decl) = N_Freeze_Entity
12109
        and then Is_Outer_Type (Entity (Decl))
12110
      loop
12111
         Decl := Remove_Head (L);
12112
         Insert_After (Next_Node, Decl);
12113
         Set_Analyzed (Decl, False);
12114
         Next_Node := Decl;
12115
         Decl := First (L);
12116
      end loop;
12117
 
12118
      --  Next scan the list of declarations and remove each freeze node that
12119
      --  appears ahead of the current node.
12120
 
12121
      while Present (Decl) loop
12122
         while Present (Next (Decl))
12123
           and then Nkind (Next (Decl)) = N_Freeze_Entity
12124
           and then Is_Outer_Type (Entity (Next (Decl)))
12125
         loop
12126
            Next_Decl := Remove_Next (Decl);
12127
            Insert_After (Next_Node, Next_Decl);
12128
            Set_Analyzed (Next_Decl, False);
12129
            Next_Node := Next_Decl;
12130
         end loop;
12131
 
12132
         --  If the declaration is a nested package or concurrent type, then
12133
         --  recurse. Nested generic packages will have been processed from the
12134
         --  inside out.
12135
 
12136
         case Nkind (Decl) is
12137
            when N_Package_Declaration =>
12138
               Spec := Specification (Decl);
12139
 
12140
            when N_Task_Type_Declaration =>
12141
               Spec := Task_Definition (Decl);
12142
 
12143
            when N_Protected_Type_Declaration =>
12144
               Spec := Protected_Definition (Decl);
12145
 
12146
            when others =>
12147
               Spec := Empty;
12148
         end case;
12149
 
12150
         if Present (Spec) then
12151
            Move_Freeze_Nodes (Out_Of, Next_Node, Visible_Declarations (Spec));
12152
            Move_Freeze_Nodes (Out_Of, Next_Node, Private_Declarations (Spec));
12153
         end if;
12154
 
12155
         Next (Decl);
12156
      end loop;
12157
   end Move_Freeze_Nodes;
12158
 
12159
   ----------------
12160
   -- Next_Assoc --
12161
   ----------------
12162
 
12163
   function Next_Assoc (E : Assoc_Ptr) return Assoc_Ptr is
12164
   begin
12165
      return Generic_Renamings.Table (E).Next_In_HTable;
12166
   end Next_Assoc;
12167
 
12168
   ------------------------
12169
   -- Preanalyze_Actuals --
12170
   ------------------------
12171
 
12172
   procedure Preanalyze_Actuals (N : Node_Id) is
12173
      Assoc : Node_Id;
12174
      Act   : Node_Id;
12175
      Errs  : constant Int := Serious_Errors_Detected;
12176
 
12177
      Cur : Entity_Id := Empty;
12178
      --  Current homograph of the instance name
12179
 
12180
      Vis : Boolean;
12181
      --  Saved visibility status of the current homograph
12182
 
12183
   begin
12184
      Assoc := First (Generic_Associations (N));
12185
 
12186
      --  If the instance is a child unit, its name may hide an outer homonym,
12187
      --  so make it invisible to perform name resolution on the actuals.
12188
 
12189
      if Nkind (Defining_Unit_Name (N)) = N_Defining_Program_Unit_Name
12190
        and then Present
12191
          (Current_Entity (Defining_Identifier (Defining_Unit_Name (N))))
12192
      then
12193
         Cur := Current_Entity (Defining_Identifier (Defining_Unit_Name (N)));
12194
 
12195
         if Is_Compilation_Unit (Cur) then
12196
            Vis := Is_Immediately_Visible (Cur);
12197
            Set_Is_Immediately_Visible (Cur, False);
12198
         else
12199
            Cur := Empty;
12200
         end if;
12201
      end if;
12202
 
12203
      while Present (Assoc) loop
12204
         if Nkind (Assoc) /= N_Others_Choice then
12205
            Act := Explicit_Generic_Actual_Parameter (Assoc);
12206
 
12207
            --  Within a nested instantiation, a defaulted actual is an empty
12208
            --  association, so nothing to analyze. If the subprogram actual
12209
            --  is an attribute, analyze prefix only, because actual is not a
12210
            --  complete attribute reference.
12211
 
12212
            --  If actual is an allocator, analyze expression only. The full
12213
            --  analysis can generate code, and if instance is a compilation
12214
            --  unit we have to wait until the package instance is installed
12215
            --  to have a proper place to insert this code.
12216
 
12217
            --  String literals may be operators, but at this point we do not
12218
            --  know whether the actual is a formal subprogram or a string.
12219
 
12220
            if No (Act) then
12221
               null;
12222
 
12223
            elsif Nkind (Act) = N_Attribute_Reference then
12224
               Analyze (Prefix (Act));
12225
 
12226
            elsif Nkind (Act) = N_Explicit_Dereference then
12227
               Analyze (Prefix (Act));
12228
 
12229
            elsif Nkind (Act) = N_Allocator then
12230
               declare
12231
                  Expr : constant Node_Id := Expression (Act);
12232
 
12233
               begin
12234
                  if Nkind (Expr) = N_Subtype_Indication then
12235
                     Analyze (Subtype_Mark (Expr));
12236
 
12237
                     --  Analyze separately each discriminant constraint, when
12238
                     --  given with a named association.
12239
 
12240
                     declare
12241
                        Constr : Node_Id;
12242
 
12243
                     begin
12244
                        Constr := First (Constraints (Constraint (Expr)));
12245
                        while Present (Constr) loop
12246
                           if Nkind (Constr) = N_Discriminant_Association then
12247
                              Analyze (Expression (Constr));
12248
                           else
12249
                              Analyze (Constr);
12250
                           end if;
12251
 
12252
                           Next (Constr);
12253
                        end loop;
12254
                     end;
12255
 
12256
                  else
12257
                     Analyze (Expr);
12258
                  end if;
12259
               end;
12260
 
12261
            elsif Nkind (Act) /= N_Operator_Symbol then
12262
               Analyze (Act);
12263
            end if;
12264
 
12265
            if Errs /= Serious_Errors_Detected then
12266
 
12267
               --  Do a minimal analysis of the generic, to prevent spurious
12268
               --  warnings complaining about the generic being unreferenced,
12269
               --  before abandoning the instantiation.
12270
 
12271
               Analyze (Name (N));
12272
 
12273
               if Is_Entity_Name (Name (N))
12274
                 and then Etype (Name (N)) /= Any_Type
12275
               then
12276
                  Generate_Reference  (Entity (Name (N)), Name (N));
12277
                  Set_Is_Instantiated (Entity (Name (N)));
12278
               end if;
12279
 
12280
               if Present (Cur) then
12281
 
12282
                  --  For the case of a child instance hiding an outer homonym,
12283
                  --  provide additional warning which might explain the error.
12284
 
12285
                  Set_Is_Immediately_Visible (Cur, Vis);
12286
                  Error_Msg_NE ("& hides outer unit with the same name?",
12287
                    N, Defining_Unit_Name (N));
12288
               end if;
12289
 
12290
               Abandon_Instantiation (Act);
12291
            end if;
12292
         end if;
12293
 
12294
         Next (Assoc);
12295
      end loop;
12296
 
12297
      if Present (Cur) then
12298
         Set_Is_Immediately_Visible (Cur, Vis);
12299
      end if;
12300
   end Preanalyze_Actuals;
12301
 
12302
   -------------------
12303
   -- Remove_Parent --
12304
   -------------------
12305
 
12306
   procedure Remove_Parent (In_Body : Boolean := False) is
12307
      S : Entity_Id := Current_Scope;
12308
      --  S is the scope containing the instantiation just completed. The scope
12309
      --  stack contains the parent instances of the instantiation, followed by
12310
      --  the original S.
12311
 
12312
      Cur_P  : Entity_Id;
12313
      E      : Entity_Id;
12314
      P      : Entity_Id;
12315
      Hidden : Elmt_Id;
12316
 
12317
   begin
12318
      --  After child instantiation is complete, remove from scope stack the
12319
      --  extra copy of the current scope, and then remove parent instances.
12320
 
12321
      if not In_Body then
12322
         Pop_Scope;
12323
 
12324
         while Current_Scope /= S loop
12325
            P := Current_Scope;
12326
            End_Package_Scope (Current_Scope);
12327
 
12328
            if In_Open_Scopes (P) then
12329
               E := First_Entity (P);
12330
               while Present (E) loop
12331
                  Set_Is_Immediately_Visible (E, True);
12332
                  Next_Entity (E);
12333
               end loop;
12334
 
12335
               --  If instantiation is declared in a block, it is the enclosing
12336
               --  scope that might be a parent instance. Note that only one
12337
               --  block can be involved, because the parent instances have
12338
               --  been installed within it.
12339
 
12340
               if Ekind (P) = E_Block then
12341
                  Cur_P := Scope (P);
12342
               else
12343
                  Cur_P := P;
12344
               end if;
12345
 
12346
               if Is_Generic_Instance (Cur_P) and then P /= Current_Scope then
12347
                  --  We are within an instance of some sibling. Retain
12348
                  --  visibility of parent, for proper subsequent cleanup, and
12349
                  --  reinstall private declarations as well.
12350
 
12351
                  Set_In_Private_Part (P);
12352
                  Install_Private_Declarations (P);
12353
               end if;
12354
 
12355
            --  If the ultimate parent is a top-level unit recorded in
12356
            --  Instance_Parent_Unit, then reset its visibility to what it was
12357
            --  before instantiation. (It's not clear what the purpose is of
12358
            --  testing whether Scope (P) is In_Open_Scopes, but that test was
12359
            --  present before the ultimate parent test was added.???)
12360
 
12361
            elsif not In_Open_Scopes (Scope (P))
12362
              or else (P = Instance_Parent_Unit
12363
                        and then not Parent_Unit_Visible)
12364
            then
12365
               Set_Is_Immediately_Visible (P, False);
12366
 
12367
            --  If the current scope is itself an instantiation of a generic
12368
            --  nested within P, and we are in the private part of body of this
12369
            --  instantiation, restore the full views of P, that were removed
12370
            --  in End_Package_Scope above. This obscure case can occur when a
12371
            --  subunit of a generic contains an instance of a child unit of
12372
            --  its generic parent unit.
12373
 
12374
            elsif S = Current_Scope and then Is_Generic_Instance (S) then
12375
               declare
12376
                  Par : constant Entity_Id :=
12377
                          Generic_Parent
12378
                            (Specification (Unit_Declaration_Node (S)));
12379
               begin
12380
                  if Present (Par)
12381
                    and then P = Scope (Par)
12382
                    and then (In_Package_Body (S) or else In_Private_Part (S))
12383
                  then
12384
                     Set_In_Private_Part (P);
12385
                     Install_Private_Declarations (P);
12386
                  end if;
12387
               end;
12388
            end if;
12389
         end loop;
12390
 
12391
         --  Reset visibility of entities in the enclosing scope
12392
 
12393
         Set_Is_Hidden_Open_Scope (Current_Scope, False);
12394
 
12395
         Hidden := First_Elmt (Hidden_Entities);
12396
         while Present (Hidden) loop
12397
            Set_Is_Immediately_Visible (Node (Hidden), True);
12398
            Next_Elmt (Hidden);
12399
         end loop;
12400
 
12401
      else
12402
         --  Each body is analyzed separately, and there is no context that
12403
         --  needs preserving from one body instance to the next, so remove all
12404
         --  parent scopes that have been installed.
12405
 
12406
         while Present (S) loop
12407
            End_Package_Scope (S);
12408
            Set_Is_Immediately_Visible (S, False);
12409
            S := Current_Scope;
12410
            exit when S = Standard_Standard;
12411
         end loop;
12412
      end if;
12413
   end Remove_Parent;
12414
 
12415
   -----------------
12416
   -- Restore_Env --
12417
   -----------------
12418
 
12419
   procedure Restore_Env is
12420
      Saved : Instance_Env renames Instance_Envs.Table (Instance_Envs.Last);
12421
 
12422
   begin
12423
      if No (Current_Instantiated_Parent.Act_Id) then
12424
         --  Restore environment after subprogram inlining
12425
 
12426
         Restore_Private_Views (Empty);
12427
      end if;
12428
 
12429
      Current_Instantiated_Parent := Saved.Instantiated_Parent;
12430
      Exchanged_Views             := Saved.Exchanged_Views;
12431
      Hidden_Entities             := Saved.Hidden_Entities;
12432
      Current_Sem_Unit            := Saved.Current_Sem_Unit;
12433
      Parent_Unit_Visible         := Saved.Parent_Unit_Visible;
12434
      Instance_Parent_Unit        := Saved.Instance_Parent_Unit;
12435
 
12436
      Restore_Opt_Config_Switches (Saved.Switches);
12437
 
12438
      Instance_Envs.Decrement_Last;
12439
   end Restore_Env;
12440
 
12441
   ---------------------------
12442
   -- Restore_Private_Views --
12443
   ---------------------------
12444
 
12445
   procedure Restore_Private_Views
12446
     (Pack_Id    : Entity_Id;
12447
      Is_Package : Boolean := True)
12448
   is
12449
      M        : Elmt_Id;
12450
      E        : Entity_Id;
12451
      Typ      : Entity_Id;
12452
      Dep_Elmt : Elmt_Id;
12453
      Dep_Typ  : Node_Id;
12454
 
12455
      procedure Restore_Nested_Formal (Formal : Entity_Id);
12456
      --  Hide the generic formals of formal packages declared with box which
12457
      --  were reachable in the current instantiation.
12458
 
12459
      ---------------------------
12460
      -- Restore_Nested_Formal --
12461
      ---------------------------
12462
 
12463
      procedure Restore_Nested_Formal (Formal : Entity_Id) is
12464
         Ent : Entity_Id;
12465
 
12466
      begin
12467
         if Present (Renamed_Object (Formal))
12468
           and then Denotes_Formal_Package (Renamed_Object (Formal), True)
12469
         then
12470
            return;
12471
 
12472
         elsif Present (Associated_Formal_Package (Formal)) then
12473
            Ent := First_Entity (Formal);
12474
            while Present (Ent) loop
12475
               exit when Ekind (Ent) = E_Package
12476
                 and then Renamed_Entity (Ent) = Renamed_Entity (Formal);
12477
 
12478
               Set_Is_Hidden (Ent);
12479
               Set_Is_Potentially_Use_Visible (Ent, False);
12480
 
12481
               --  If package, then recurse
12482
 
12483
               if Ekind (Ent) = E_Package then
12484
                  Restore_Nested_Formal (Ent);
12485
               end if;
12486
 
12487
               Next_Entity (Ent);
12488
            end loop;
12489
         end if;
12490
      end Restore_Nested_Formal;
12491
 
12492
   --  Start of processing for Restore_Private_Views
12493
 
12494
   begin
12495
      M := First_Elmt (Exchanged_Views);
12496
      while Present (M) loop
12497
         Typ := Node (M);
12498
 
12499
         --  Subtypes of types whose views have been exchanged, and that are
12500
         --  defined within the instance, were not on the Private_Dependents
12501
         --  list on entry to the instance, so they have to be exchanged
12502
         --  explicitly now, in order to remain consistent with the view of the
12503
         --  parent type.
12504
 
12505
         if Ekind_In (Typ, E_Private_Type,
12506
                           E_Limited_Private_Type,
12507
                           E_Record_Type_With_Private)
12508
         then
12509
            Dep_Elmt := First_Elmt (Private_Dependents (Typ));
12510
            while Present (Dep_Elmt) loop
12511
               Dep_Typ := Node (Dep_Elmt);
12512
 
12513
               if Scope (Dep_Typ) = Pack_Id
12514
                 and then Present (Full_View (Dep_Typ))
12515
               then
12516
                  Replace_Elmt (Dep_Elmt, Full_View (Dep_Typ));
12517
                  Exchange_Declarations (Dep_Typ);
12518
               end if;
12519
 
12520
               Next_Elmt (Dep_Elmt);
12521
            end loop;
12522
         end if;
12523
 
12524
         Exchange_Declarations (Node (M));
12525
         Next_Elmt (M);
12526
      end loop;
12527
 
12528
      if No (Pack_Id) then
12529
         return;
12530
      end if;
12531
 
12532
      --  Make the generic formal parameters private, and make the formal types
12533
      --  into subtypes of the actuals again.
12534
 
12535
      E := First_Entity (Pack_Id);
12536
      while Present (E) loop
12537
         Set_Is_Hidden (E, True);
12538
 
12539
         if Is_Type (E)
12540
           and then Nkind (Parent (E)) = N_Subtype_Declaration
12541
         then
12542
            Set_Is_Generic_Actual_Type (E, False);
12543
 
12544
            --  An unusual case of aliasing: the actual may also be directly
12545
            --  visible in the generic, and be private there, while it is fully
12546
            --  visible in the context of the instance. The internal subtype
12547
            --  is private in the instance but has full visibility like its
12548
            --  parent in the enclosing scope. This enforces the invariant that
12549
            --  the privacy status of all private dependents of a type coincide
12550
            --  with that of the parent type. This can only happen when a
12551
            --  generic child unit is instantiated within a sibling.
12552
 
12553
            if Is_Private_Type (E)
12554
              and then not Is_Private_Type (Etype (E))
12555
            then
12556
               Exchange_Declarations (E);
12557
            end if;
12558
 
12559
         elsif Ekind (E) = E_Package then
12560
 
12561
            --  The end of the renaming list is the renaming of the generic
12562
            --  package itself. If the instance is a subprogram, all entities
12563
            --  in the corresponding package are renamings. If this entity is
12564
            --  a formal package, make its own formals private as well. The
12565
            --  actual in this case is itself the renaming of an instantiation.
12566
            --  If the entity is not a package renaming, it is the entity
12567
            --  created to validate formal package actuals: ignore it.
12568
 
12569
            --  If the actual is itself a formal package for the enclosing
12570
            --  generic, or the actual for such a formal package, it remains
12571
            --  visible on exit from the instance, and therefore nothing needs
12572
            --  to be done either, except to keep it accessible.
12573
 
12574
            if Is_Package and then Renamed_Object (E) = Pack_Id then
12575
               exit;
12576
 
12577
            elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then
12578
               null;
12579
 
12580
            elsif
12581
              Denotes_Formal_Package (Renamed_Object (E), True, Pack_Id)
12582
            then
12583
               Set_Is_Hidden (E, False);
12584
 
12585
            else
12586
               declare
12587
                  Act_P : constant Entity_Id := Renamed_Object (E);
12588
                  Id    : Entity_Id;
12589
 
12590
               begin
12591
                  Id := First_Entity (Act_P);
12592
                  while Present (Id)
12593
                    and then Id /= First_Private_Entity (Act_P)
12594
                  loop
12595
                     exit when Ekind (Id) = E_Package
12596
                                 and then Renamed_Object (Id) = Act_P;
12597
 
12598
                     Set_Is_Hidden (Id, True);
12599
                     Set_Is_Potentially_Use_Visible (Id, In_Use (Act_P));
12600
 
12601
                     if Ekind (Id) = E_Package then
12602
                        Restore_Nested_Formal (Id);
12603
                     end if;
12604
 
12605
                     Next_Entity (Id);
12606
                  end loop;
12607
               end;
12608
            end if;
12609
         end if;
12610
 
12611
         Next_Entity (E);
12612
      end loop;
12613
   end Restore_Private_Views;
12614
 
12615
   --------------
12616
   -- Save_Env --
12617
   --------------
12618
 
12619
   procedure Save_Env
12620
     (Gen_Unit : Entity_Id;
12621
      Act_Unit : Entity_Id)
12622
   is
12623
   begin
12624
      Init_Env;
12625
      Set_Instance_Env (Gen_Unit, Act_Unit);
12626
   end Save_Env;
12627
 
12628
   ----------------------------
12629
   -- Save_Global_References --
12630
   ----------------------------
12631
 
12632
   procedure Save_Global_References (N : Node_Id) is
12633
      Gen_Scope : Entity_Id;
12634
      E         : Entity_Id;
12635
      N2        : Node_Id;
12636
 
12637
      function Is_Global (E : Entity_Id) return Boolean;
12638
      --  Check whether entity is defined outside of generic unit. Examine the
12639
      --  scope of an entity, and the scope of the scope, etc, until we find
12640
      --  either Standard, in which case the entity is global, or the generic
12641
      --  unit itself, which indicates that the entity is local. If the entity
12642
      --  is the generic unit itself, as in the case of a recursive call, or
12643
      --  the enclosing generic unit, if different from the current scope, then
12644
      --  it is local as well, because it will be replaced at the point of
12645
      --  instantiation. On the other hand, if it is a reference to a child
12646
      --  unit of a common ancestor, which appears in an instantiation, it is
12647
      --  global because it is used to denote a specific compilation unit at
12648
      --  the time the instantiations will be analyzed.
12649
 
12650
      procedure Reset_Entity (N : Node_Id);
12651
      --  Save semantic information on global entity so that it is not resolved
12652
      --  again at instantiation time.
12653
 
12654
      procedure Save_Entity_Descendants (N : Node_Id);
12655
      --  Apply Save_Global_References to the two syntactic descendants of
12656
      --  non-terminal nodes that carry an Associated_Node and are processed
12657
      --  through Reset_Entity. Once the global entity (if any) has been
12658
      --  captured together with its type, only two syntactic descendants need
12659
      --  to be traversed to complete the processing of the tree rooted at N.
12660
      --  This applies to Selected_Components, Expanded_Names, and to Operator
12661
      --  nodes. N can also be a character literal, identifier, or operator
12662
      --  symbol node, but the call has no effect in these cases.
12663
 
12664
      procedure Save_Global_Defaults (N1, N2 : Node_Id);
12665
      --  Default actuals in nested instances must be handled specially
12666
      --  because there is no link to them from the original tree. When an
12667
      --  actual subprogram is given by a default, we add an explicit generic
12668
      --  association for it in the instantiation node. When we save the
12669
      --  global references on the name of the instance, we recover the list
12670
      --  of generic associations, and add an explicit one to the original
12671
      --  generic tree, through which a global actual can be preserved.
12672
      --  Similarly, if a child unit is instantiated within a sibling, in the
12673
      --  context of the parent, we must preserve the identifier of the parent
12674
      --  so that it can be properly resolved in a subsequent instantiation.
12675
 
12676
      procedure Save_Global_Descendant (D : Union_Id);
12677
      --  Apply Save_Global_References recursively to the descendents of the
12678
      --  current node.
12679
 
12680
      procedure Save_References (N : Node_Id);
12681
      --  This is the recursive procedure that does the work, once the
12682
      --  enclosing generic scope has been established.
12683
 
12684
      ---------------
12685
      -- Is_Global --
12686
      ---------------
12687
 
12688
      function Is_Global (E : Entity_Id) return Boolean is
12689
         Se : Entity_Id;
12690
 
12691
         function Is_Instance_Node (Decl : Node_Id) return Boolean;
12692
         --  Determine whether the parent node of a reference to a child unit
12693
         --  denotes an instantiation or a formal package, in which case the
12694
         --  reference to the child unit is global, even if it appears within
12695
         --  the current scope (e.g. when the instance appears within the body
12696
         --  of an ancestor).
12697
 
12698
         ----------------------
12699
         -- Is_Instance_Node --
12700
         ----------------------
12701
 
12702
         function Is_Instance_Node (Decl : Node_Id) return Boolean is
12703
         begin
12704
            return Nkind (Decl) in N_Generic_Instantiation
12705
                     or else
12706
                   Nkind (Original_Node (Decl)) = N_Formal_Package_Declaration;
12707
         end Is_Instance_Node;
12708
 
12709
      --  Start of processing for Is_Global
12710
 
12711
      begin
12712
         if E = Gen_Scope then
12713
            return False;
12714
 
12715
         elsif E = Standard_Standard then
12716
            return True;
12717
 
12718
         elsif Is_Child_Unit (E)
12719
           and then (Is_Instance_Node (Parent (N2))
12720
                      or else (Nkind (Parent (N2)) = N_Expanded_Name
12721
                                and then N2 = Selector_Name (Parent (N2))
12722
                                and then
12723
                                  Is_Instance_Node (Parent (Parent (N2)))))
12724
         then
12725
            return True;
12726
 
12727
         else
12728
            Se := Scope (E);
12729
            while Se /= Gen_Scope loop
12730
               if Se = Standard_Standard then
12731
                  return True;
12732
               else
12733
                  Se := Scope (Se);
12734
               end if;
12735
            end loop;
12736
 
12737
            return False;
12738
         end if;
12739
      end Is_Global;
12740
 
12741
      ------------------
12742
      -- Reset_Entity --
12743
      ------------------
12744
 
12745
      procedure Reset_Entity (N : Node_Id) is
12746
 
12747
         procedure Set_Global_Type (N : Node_Id; N2 : Node_Id);
12748
         --  If the type of N2 is global to the generic unit, save the type in
12749
         --  the generic node. Just as we perform name capture for explicit
12750
         --  references within the generic, we must capture the global types
12751
         --  of local entities because they may participate in resolution in
12752
         --  the instance.
12753
 
12754
         function Top_Ancestor (E : Entity_Id) return Entity_Id;
12755
         --  Find the ultimate ancestor of the current unit. If it is not a
12756
         --  generic unit, then the name of the current unit in the prefix of
12757
         --  an expanded name must be replaced with its generic homonym to
12758
         --  ensure that it will be properly resolved in an instance.
12759
 
12760
         ---------------------
12761
         -- Set_Global_Type --
12762
         ---------------------
12763
 
12764
         procedure Set_Global_Type (N : Node_Id; N2 : Node_Id) is
12765
            Typ : constant Entity_Id := Etype (N2);
12766
 
12767
         begin
12768
            Set_Etype (N, Typ);
12769
 
12770
            if Entity (N) /= N2
12771
              and then Has_Private_View (Entity (N))
12772
            then
12773
               --  If the entity of N is not the associated node, this is a
12774
               --  nested generic and it has an associated node as well, whose
12775
               --  type is already the full view (see below). Indicate that the
12776
               --  original node has a private view.
12777
 
12778
               Set_Has_Private_View (N);
12779
            end if;
12780
 
12781
            --  If not a private type, nothing else to do
12782
 
12783
            if not Is_Private_Type (Typ) then
12784
               if Is_Array_Type (Typ)
12785
                 and then Is_Private_Type (Component_Type (Typ))
12786
               then
12787
                  Set_Has_Private_View (N);
12788
               end if;
12789
 
12790
            --  If it is a derivation of a private type in a context where no
12791
            --  full view is needed, nothing to do either.
12792
 
12793
            elsif No (Full_View (Typ)) and then Typ /= Etype (Typ) then
12794
               null;
12795
 
12796
            --  Otherwise mark the type for flipping and use the full view when
12797
            --  available.
12798
 
12799
            else
12800
               Set_Has_Private_View (N);
12801
 
12802
               if Present (Full_View (Typ)) then
12803
                  Set_Etype (N2, Full_View (Typ));
12804
               end if;
12805
            end if;
12806
         end Set_Global_Type;
12807
 
12808
         ------------------
12809
         -- Top_Ancestor --
12810
         ------------------
12811
 
12812
         function Top_Ancestor (E : Entity_Id) return Entity_Id is
12813
            Par : Entity_Id;
12814
 
12815
         begin
12816
            Par := E;
12817
            while Is_Child_Unit (Par) loop
12818
               Par := Scope (Par);
12819
            end loop;
12820
 
12821
            return Par;
12822
         end Top_Ancestor;
12823
 
12824
      --  Start of processing for Reset_Entity
12825
 
12826
      begin
12827
         N2 := Get_Associated_Node (N);
12828
         E := Entity (N2);
12829
 
12830
         if Present (E) then
12831
 
12832
            --  If the node is an entry call to an entry in an enclosing task,
12833
            --  it is rewritten as a selected component. No global entity to
12834
            --  preserve in this case, since the expansion will be redone in
12835
            --  the instance.
12836
 
12837
            if not Nkind_In (E, N_Defining_Identifier,
12838
                                N_Defining_Character_Literal,
12839
                                N_Defining_Operator_Symbol)
12840
            then
12841
               Set_Associated_Node (N, Empty);
12842
               Set_Etype  (N, Empty);
12843
               return;
12844
            end if;
12845
 
12846
            --  If the entity is an itype created as a subtype of an access
12847
            --  type with a null exclusion restore source entity for proper
12848
            --  visibility. The itype will be created anew in the instance.
12849
 
12850
            if Is_Itype (E)
12851
              and then Ekind (E) = E_Access_Subtype
12852
              and then Is_Entity_Name (N)
12853
              and then Chars (Etype (E)) = Chars (N)
12854
            then
12855
               E := Etype (E);
12856
               Set_Entity (N2, E);
12857
               Set_Etype  (N2, E);
12858
            end if;
12859
 
12860
            if Is_Global (E) then
12861
               Set_Global_Type (N, N2);
12862
 
12863
            elsif Nkind (N) = N_Op_Concat
12864
              and then Is_Generic_Type (Etype (N2))
12865
              and then (Base_Type (Etype (Right_Opnd (N2))) = Etype (N2)
12866
                         or else
12867
                        Base_Type (Etype (Left_Opnd (N2)))  = Etype (N2))
12868
              and then Is_Intrinsic_Subprogram (E)
12869
            then
12870
               null;
12871
 
12872
            else
12873
               --  Entity is local. Mark generic node as unresolved.
12874
               --  Note that now it does not have an entity.
12875
 
12876
               Set_Associated_Node (N, Empty);
12877
               Set_Etype  (N, Empty);
12878
            end if;
12879
 
12880
            if Nkind (Parent (N)) in N_Generic_Instantiation
12881
              and then N = Name (Parent (N))
12882
            then
12883
               Save_Global_Defaults (Parent (N), Parent (N2));
12884
            end if;
12885
 
12886
         elsif Nkind (Parent (N)) = N_Selected_Component
12887
           and then Nkind (Parent (N2)) = N_Expanded_Name
12888
         then
12889
            if Is_Global (Entity (Parent (N2))) then
12890
               Change_Selected_Component_To_Expanded_Name (Parent (N));
12891
               Set_Associated_Node (Parent (N), Parent (N2));
12892
               Set_Global_Type (Parent (N), Parent (N2));
12893
               Save_Entity_Descendants (N);
12894
 
12895
            --  If this is a reference to the current generic entity, replace
12896
            --  by the name of the generic homonym of the current package. This
12897
            --  is because in an instantiation Par.P.Q will not resolve to the
12898
            --  name of the instance, whose enclosing scope is not necessarily
12899
            --  Par. We use the generic homonym rather that the name of the
12900
            --  generic itself because it may be hidden by a local declaration.
12901
 
12902
            elsif In_Open_Scopes (Entity (Parent (N2)))
12903
              and then not
12904
                Is_Generic_Unit (Top_Ancestor (Entity (Prefix (Parent (N2)))))
12905
            then
12906
               if Ekind (Entity (Parent (N2))) = E_Generic_Package then
12907
                  Rewrite (Parent (N),
12908
                    Make_Identifier (Sloc (N),
12909
                      Chars =>
12910
                        Chars (Generic_Homonym (Entity (Parent (N2))))));
12911
               else
12912
                  Rewrite (Parent (N),
12913
                    Make_Identifier (Sloc (N),
12914
                      Chars => Chars (Selector_Name (Parent (N2)))));
12915
               end if;
12916
            end if;
12917
 
12918
            if Nkind (Parent (Parent (N))) in N_Generic_Instantiation
12919
              and then Parent (N) = Name (Parent (Parent (N)))
12920
            then
12921
               Save_Global_Defaults
12922
                 (Parent (Parent (N)), Parent (Parent ((N2))));
12923
            end if;
12924
 
12925
         --  A selected component may denote a static constant that has been
12926
         --  folded. If the static constant is global to the generic, capture
12927
         --  its value. Otherwise the folding will happen in any instantiation.
12928
 
12929
         elsif Nkind (Parent (N)) = N_Selected_Component
12930
           and then Nkind_In (Parent (N2), N_Integer_Literal, N_Real_Literal)
12931
         then
12932
            if Present (Entity (Original_Node (Parent (N2))))
12933
              and then Is_Global (Entity (Original_Node (Parent (N2))))
12934
            then
12935
               Rewrite (Parent (N), New_Copy (Parent (N2)));
12936
               Set_Analyzed (Parent (N), False);
12937
 
12938
            else
12939
               null;
12940
            end if;
12941
 
12942
         --  A selected component may be transformed into a parameterless
12943
         --  function call. If the called entity is global, rewrite the node
12944
         --  appropriately, i.e. as an extended name for the global entity.
12945
 
12946
         elsif Nkind (Parent (N)) = N_Selected_Component
12947
           and then Nkind (Parent (N2)) = N_Function_Call
12948
           and then N = Selector_Name (Parent (N))
12949
         then
12950
            if No (Parameter_Associations (Parent (N2))) then
12951
               if Is_Global (Entity (Name (Parent (N2)))) then
12952
                  Change_Selected_Component_To_Expanded_Name (Parent (N));
12953
                  Set_Associated_Node (Parent (N), Name (Parent (N2)));
12954
                  Set_Global_Type (Parent (N), Name (Parent (N2)));
12955
                  Save_Entity_Descendants (N);
12956
 
12957
               else
12958
                  Set_Is_Prefixed_Call (Parent (N));
12959
                  Set_Associated_Node (N, Empty);
12960
                  Set_Etype (N, Empty);
12961
               end if;
12962
 
12963
            --  In Ada 2005, X.F may be a call to a primitive operation,
12964
            --  rewritten as F (X). This rewriting will be done again in an
12965
            --  instance, so keep the original node. Global entities will be
12966
            --  captured as for other constructs. Indicate that this must
12967
            --  resolve as a call, to prevent accidental overloading in the
12968
            --  instance, if both a component and a primitive operation appear
12969
            --  as candidates.
12970
 
12971
            else
12972
               Set_Is_Prefixed_Call (Parent (N));
12973
            end if;
12974
 
12975
         --  Entity is local. Reset in generic unit, so that node is resolved
12976
         --  anew at the point of instantiation.
12977
 
12978
         else
12979
            Set_Associated_Node (N, Empty);
12980
            Set_Etype (N, Empty);
12981
         end if;
12982
      end Reset_Entity;
12983
 
12984
      -----------------------------
12985
      -- Save_Entity_Descendants --
12986
      -----------------------------
12987
 
12988
      procedure Save_Entity_Descendants (N : Node_Id) is
12989
      begin
12990
         case Nkind (N) is
12991
            when N_Binary_Op =>
12992
               Save_Global_Descendant (Union_Id (Left_Opnd (N)));
12993
               Save_Global_Descendant (Union_Id (Right_Opnd (N)));
12994
 
12995
            when N_Unary_Op =>
12996
               Save_Global_Descendant (Union_Id (Right_Opnd (N)));
12997
 
12998
            when N_Expanded_Name | N_Selected_Component =>
12999
               Save_Global_Descendant (Union_Id (Prefix (N)));
13000
               Save_Global_Descendant (Union_Id (Selector_Name (N)));
13001
 
13002
            when N_Identifier | N_Character_Literal | N_Operator_Symbol =>
13003
               null;
13004
 
13005
            when others =>
13006
               raise Program_Error;
13007
         end case;
13008
      end Save_Entity_Descendants;
13009
 
13010
      --------------------------
13011
      -- Save_Global_Defaults --
13012
      --------------------------
13013
 
13014
      procedure Save_Global_Defaults (N1, N2 : Node_Id) is
13015
         Loc    : constant Source_Ptr := Sloc (N1);
13016
         Assoc2 : constant List_Id    := Generic_Associations (N2);
13017
         Gen_Id : constant Entity_Id  := Get_Generic_Entity (N2);
13018
         Assoc1 : List_Id;
13019
         Act1   : Node_Id;
13020
         Act2   : Node_Id;
13021
         Def    : Node_Id;
13022
         Ndec   : Node_Id;
13023
         Subp   : Entity_Id;
13024
         Actual : Entity_Id;
13025
 
13026
      begin
13027
         Assoc1 := Generic_Associations (N1);
13028
 
13029
         if Present (Assoc1) then
13030
            Act1 := First (Assoc1);
13031
         else
13032
            Act1 := Empty;
13033
            Set_Generic_Associations (N1, New_List);
13034
            Assoc1 := Generic_Associations (N1);
13035
         end if;
13036
 
13037
         if Present (Assoc2) then
13038
            Act2 := First (Assoc2);
13039
         else
13040
            return;
13041
         end if;
13042
 
13043
         while Present (Act1) and then Present (Act2) loop
13044
            Next (Act1);
13045
            Next (Act2);
13046
         end loop;
13047
 
13048
         --  Find the associations added for default subprograms
13049
 
13050
         if Present (Act2) then
13051
            while Nkind (Act2) /= N_Generic_Association
13052
              or else No (Entity (Selector_Name (Act2)))
13053
              or else not Is_Overloadable (Entity (Selector_Name (Act2)))
13054
            loop
13055
               Next (Act2);
13056
            end loop;
13057
 
13058
            --  Add a similar association if the default is global. The
13059
            --  renaming declaration for the actual has been analyzed, and
13060
            --  its alias is the program it renames. Link the actual in the
13061
            --  original generic tree with the node in the analyzed tree.
13062
 
13063
            while Present (Act2) loop
13064
               Subp := Entity (Selector_Name (Act2));
13065
               Def  := Explicit_Generic_Actual_Parameter (Act2);
13066
 
13067
               --  Following test is defence against rubbish errors
13068
 
13069
               if No (Alias (Subp)) then
13070
                  return;
13071
               end if;
13072
 
13073
               --  Retrieve the resolved actual from the renaming declaration
13074
               --  created for the instantiated formal.
13075
 
13076
               Actual := Entity (Name (Parent (Parent (Subp))));
13077
               Set_Entity (Def, Actual);
13078
               Set_Etype (Def, Etype (Actual));
13079
 
13080
               if Is_Global (Actual) then
13081
                  Ndec :=
13082
                    Make_Generic_Association (Loc,
13083
                      Selector_Name => New_Occurrence_Of (Subp, Loc),
13084
                        Explicit_Generic_Actual_Parameter =>
13085
                          New_Occurrence_Of (Actual, Loc));
13086
 
13087
                  Set_Associated_Node
13088
                    (Explicit_Generic_Actual_Parameter (Ndec), Def);
13089
 
13090
                  Append (Ndec, Assoc1);
13091
 
13092
               --  If there are other defaults, add a dummy association in case
13093
               --  there are other defaulted formals with the same name.
13094
 
13095
               elsif Present (Next (Act2)) then
13096
                  Ndec :=
13097
                    Make_Generic_Association (Loc,
13098
                      Selector_Name => New_Occurrence_Of (Subp, Loc),
13099
                        Explicit_Generic_Actual_Parameter => Empty);
13100
 
13101
                  Append (Ndec, Assoc1);
13102
               end if;
13103
 
13104
               Next (Act2);
13105
            end loop;
13106
         end if;
13107
 
13108
         if Nkind (Name (N1)) = N_Identifier
13109
           and then Is_Child_Unit (Gen_Id)
13110
           and then Is_Global (Gen_Id)
13111
           and then Is_Generic_Unit (Scope (Gen_Id))
13112
           and then In_Open_Scopes (Scope (Gen_Id))
13113
         then
13114
            --  This is an instantiation of a child unit within a sibling, so
13115
            --  that the generic parent is in scope. An eventual instance must
13116
            --  occur within the scope of an instance of the parent. Make name
13117
            --  in instance into an expanded name, to preserve the identifier
13118
            --  of the parent, so it can be resolved subsequently.
13119
 
13120
            Rewrite (Name (N2),
13121
              Make_Expanded_Name (Loc,
13122
                Chars         => Chars (Gen_Id),
13123
                Prefix        => New_Occurrence_Of (Scope (Gen_Id), Loc),
13124
                Selector_Name => New_Occurrence_Of (Gen_Id, Loc)));
13125
            Set_Entity (Name (N2), Gen_Id);
13126
 
13127
            Rewrite (Name (N1),
13128
               Make_Expanded_Name (Loc,
13129
                Chars         => Chars (Gen_Id),
13130
                Prefix        => New_Occurrence_Of (Scope (Gen_Id), Loc),
13131
                Selector_Name => New_Occurrence_Of (Gen_Id, Loc)));
13132
 
13133
            Set_Associated_Node (Name (N1), Name (N2));
13134
            Set_Associated_Node (Prefix (Name (N1)), Empty);
13135
            Set_Associated_Node
13136
              (Selector_Name (Name (N1)), Selector_Name (Name (N2)));
13137
            Set_Etype (Name (N1), Etype (Gen_Id));
13138
         end if;
13139
 
13140
      end Save_Global_Defaults;
13141
 
13142
      ----------------------------
13143
      -- Save_Global_Descendant --
13144
      ----------------------------
13145
 
13146
      procedure Save_Global_Descendant (D : Union_Id) is
13147
         N1 : Node_Id;
13148
 
13149
      begin
13150
         if D in Node_Range then
13151
            if D = Union_Id (Empty) then
13152
               null;
13153
 
13154
            elsif Nkind (Node_Id (D)) /= N_Compilation_Unit then
13155
               Save_References (Node_Id (D));
13156
            end if;
13157
 
13158
         elsif D in List_Range then
13159
            if D = Union_Id (No_List)
13160
              or else Is_Empty_List (List_Id (D))
13161
            then
13162
               null;
13163
 
13164
            else
13165
               N1 := First (List_Id (D));
13166
               while Present (N1) loop
13167
                  Save_References (N1);
13168
                  Next (N1);
13169
               end loop;
13170
            end if;
13171
 
13172
         --  Element list or other non-node field, nothing to do
13173
 
13174
         else
13175
            null;
13176
         end if;
13177
      end Save_Global_Descendant;
13178
 
13179
      ---------------------
13180
      -- Save_References --
13181
      ---------------------
13182
 
13183
      --  This is the recursive procedure that does the work once the enclosing
13184
      --  generic scope has been established. We have to treat specially a
13185
      --  number of node rewritings that are required by semantic processing
13186
      --  and which change the kind of nodes in the generic copy: typically
13187
      --  constant-folding, replacing an operator node by a string literal, or
13188
      --  a selected component by an expanded name. In each of those cases, the
13189
      --  transformation is propagated to the generic unit.
13190
 
13191
      procedure Save_References (N : Node_Id) is
13192
         Loc : constant Source_Ptr := Sloc (N);
13193
 
13194
      begin
13195
         if N = Empty then
13196
            null;
13197
 
13198
         elsif Nkind_In (N, N_Character_Literal, N_Operator_Symbol) then
13199
            if Nkind (N) = Nkind (Get_Associated_Node (N)) then
13200
               Reset_Entity (N);
13201
 
13202
            elsif Nkind (N) = N_Operator_Symbol
13203
              and then Nkind (Get_Associated_Node (N)) = N_String_Literal
13204
            then
13205
               Change_Operator_Symbol_To_String_Literal (N);
13206
            end if;
13207
 
13208
         elsif Nkind (N) in N_Op then
13209
            if Nkind (N) = Nkind (Get_Associated_Node (N)) then
13210
               if Nkind (N) = N_Op_Concat then
13211
                  Set_Is_Component_Left_Opnd (N,
13212
                    Is_Component_Left_Opnd (Get_Associated_Node (N)));
13213
 
13214
                  Set_Is_Component_Right_Opnd (N,
13215
                    Is_Component_Right_Opnd (Get_Associated_Node (N)));
13216
               end if;
13217
 
13218
               Reset_Entity (N);
13219
 
13220
            else
13221
               --  Node may be transformed into call to a user-defined operator
13222
 
13223
               N2 := Get_Associated_Node (N);
13224
 
13225
               if Nkind (N2) = N_Function_Call then
13226
                  E := Entity (Name (N2));
13227
 
13228
                  if Present (E)
13229
                    and then Is_Global (E)
13230
                  then
13231
                     Set_Etype (N, Etype (N2));
13232
                  else
13233
                     Set_Associated_Node (N, Empty);
13234
                     Set_Etype (N, Empty);
13235
                  end if;
13236
 
13237
               elsif Nkind_In (N2, N_Integer_Literal,
13238
                                   N_Real_Literal,
13239
                                   N_String_Literal)
13240
               then
13241
                  if Present (Original_Node (N2))
13242
                    and then Nkind (Original_Node (N2)) = Nkind (N)
13243
                  then
13244
 
13245
                     --  Operation was constant-folded. Whenever possible,
13246
                     --  recover semantic information from unfolded node,
13247
                     --  for ASIS use.
13248
 
13249
                     Set_Associated_Node (N, Original_Node (N2));
13250
 
13251
                     if Nkind (N) = N_Op_Concat then
13252
                        Set_Is_Component_Left_Opnd (N,
13253
                          Is_Component_Left_Opnd  (Get_Associated_Node (N)));
13254
                        Set_Is_Component_Right_Opnd (N,
13255
                          Is_Component_Right_Opnd (Get_Associated_Node (N)));
13256
                     end if;
13257
 
13258
                     Reset_Entity (N);
13259
 
13260
                  else
13261
                     --  If original node is already modified, propagate
13262
                     --  constant-folding to template.
13263
 
13264
                     Rewrite (N, New_Copy (N2));
13265
                     Set_Analyzed (N, False);
13266
                  end if;
13267
 
13268
               elsif Nkind (N2) = N_Identifier
13269
                 and then Ekind (Entity (N2)) = E_Enumeration_Literal
13270
               then
13271
                  --  Same if call was folded into a literal, but in this case
13272
                  --  retain the entity to avoid spurious ambiguities if it is
13273
                  --  overloaded at the point of instantiation or inlining.
13274
 
13275
                  Rewrite (N, New_Copy (N2));
13276
                  Set_Analyzed (N, False);
13277
               end if;
13278
            end if;
13279
 
13280
            --  Complete operands check if node has not been constant-folded
13281
 
13282
            if Nkind (N) in N_Op then
13283
               Save_Entity_Descendants (N);
13284
            end if;
13285
 
13286
         elsif Nkind (N) = N_Identifier then
13287
            if Nkind (N) = Nkind (Get_Associated_Node (N)) then
13288
 
13289
               --  If this is a discriminant reference, always save it. It is
13290
               --  used in the instance to find the corresponding discriminant
13291
               --  positionally rather than by name.
13292
 
13293
               Set_Original_Discriminant
13294
                 (N, Original_Discriminant (Get_Associated_Node (N)));
13295
               Reset_Entity (N);
13296
 
13297
            else
13298
               N2 := Get_Associated_Node (N);
13299
 
13300
               if Nkind (N2) = N_Function_Call then
13301
                  E := Entity (Name (N2));
13302
 
13303
                  --  Name resolves to a call to parameterless function. If
13304
                  --  original entity is global, mark node as resolved.
13305
 
13306
                  if Present (E)
13307
                    and then Is_Global (E)
13308
                  then
13309
                     Set_Etype (N, Etype (N2));
13310
                  else
13311
                     Set_Associated_Node (N, Empty);
13312
                     Set_Etype (N, Empty);
13313
                  end if;
13314
 
13315
               elsif Nkind_In (N2, N_Integer_Literal, N_Real_Literal)
13316
                 and then Is_Entity_Name (Original_Node (N2))
13317
               then
13318
                  --  Name resolves to named number that is constant-folded,
13319
                  --  We must preserve the original name for ASIS use, and
13320
                  --  undo the constant-folding, which will be repeated in
13321
                  --  each instance.
13322
 
13323
                  Set_Associated_Node (N, Original_Node (N2));
13324
                  Reset_Entity (N);
13325
 
13326
               elsif Nkind (N2) = N_String_Literal then
13327
 
13328
                  --  Name resolves to string literal. Perform the same
13329
                  --  replacement in generic.
13330
 
13331
                  Rewrite (N, New_Copy (N2));
13332
 
13333
               elsif Nkind (N2) = N_Explicit_Dereference then
13334
 
13335
                  --  An identifier is rewritten as a dereference if it is the
13336
                  --  prefix in an implicit dereference (call or attribute).
13337
                  --  The analysis of an instantiation will expand the node
13338
                  --  again, so we preserve the original tree but link it to
13339
                  --  the resolved entity in case it is global.
13340
 
13341
                  if Is_Entity_Name (Prefix (N2))
13342
                    and then Present (Entity (Prefix (N2)))
13343
                    and then Is_Global (Entity (Prefix (N2)))
13344
                  then
13345
                     Set_Associated_Node (N, Prefix (N2));
13346
 
13347
                  elsif Nkind (Prefix (N2)) = N_Function_Call
13348
                    and then Is_Global (Entity (Name (Prefix (N2))))
13349
                  then
13350
                     Rewrite (N,
13351
                       Make_Explicit_Dereference (Loc,
13352
                          Prefix => Make_Function_Call (Loc,
13353
                            Name =>
13354
                              New_Occurrence_Of (Entity (Name (Prefix (N2))),
13355
                                                 Loc))));
13356
 
13357
                  else
13358
                     Set_Associated_Node (N, Empty);
13359
                     Set_Etype (N, Empty);
13360
                  end if;
13361
 
13362
               --  The subtype mark of a nominally unconstrained object is
13363
               --  rewritten as a subtype indication using the bounds of the
13364
               --  expression. Recover the original subtype mark.
13365
 
13366
               elsif Nkind (N2) = N_Subtype_Indication
13367
                 and then Is_Entity_Name (Original_Node (N2))
13368
               then
13369
                  Set_Associated_Node (N, Original_Node (N2));
13370
                  Reset_Entity (N);
13371
 
13372
               else
13373
                  null;
13374
               end if;
13375
            end if;
13376
 
13377
         elsif Nkind (N) in N_Entity then
13378
            null;
13379
 
13380
         else
13381
            declare
13382
               Qual : Node_Id := Empty;
13383
               Typ  : Entity_Id := Empty;
13384
               Nam  : Node_Id;
13385
 
13386
               use Atree.Unchecked_Access;
13387
               --  This code section is part of implementing an untyped tree
13388
               --  traversal, so it needs direct access to node fields.
13389
 
13390
            begin
13391
               if Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then
13392
                  N2 := Get_Associated_Node (N);
13393
 
13394
                  if No (N2) then
13395
                     Typ := Empty;
13396
                  else
13397
                     Typ := Etype (N2);
13398
 
13399
                     --  In an instance within a generic, use the name of the
13400
                     --  actual and not the original generic parameter. If the
13401
                     --  actual is global in the current generic it must be
13402
                     --  preserved for its instantiation.
13403
 
13404
                     if Nkind (Parent (Typ)) = N_Subtype_Declaration
13405
                       and then
13406
                         Present (Generic_Parent_Type (Parent (Typ)))
13407
                     then
13408
                        Typ := Base_Type (Typ);
13409
                        Set_Etype (N2, Typ);
13410
                     end if;
13411
                  end if;
13412
 
13413
                  if No (N2)
13414
                    or else No (Typ)
13415
                    or else not Is_Global (Typ)
13416
                  then
13417
                     Set_Associated_Node (N, Empty);
13418
 
13419
                     --  If the aggregate is an actual in a call, it has been
13420
                     --  resolved in the current context, to some local type.
13421
                     --  The enclosing call may have been disambiguated by the
13422
                     --  aggregate, and this disambiguation might fail at
13423
                     --  instantiation time because the type to which the
13424
                     --  aggregate did resolve is not preserved. In order to
13425
                     --  preserve some of this information, we wrap the
13426
                     --  aggregate in a qualified expression, using the id of
13427
                     --  its type. For further disambiguation we qualify the
13428
                     --  type name with its scope (if visible) because both
13429
                     --  id's will have corresponding entities in an instance.
13430
                     --  This resolves most of the problems with missing type
13431
                     --  information on aggregates in instances.
13432
 
13433
                     if Nkind (N2) = Nkind (N)
13434
                       and then
13435
                         Nkind_In (Parent (N2), N_Procedure_Call_Statement,
13436
                                                N_Function_Call)
13437
                       and then Comes_From_Source (Typ)
13438
                     then
13439
                        if Is_Immediately_Visible (Scope (Typ)) then
13440
                           Nam := Make_Selected_Component (Loc,
13441
                             Prefix =>
13442
                               Make_Identifier (Loc, Chars (Scope (Typ))),
13443
                             Selector_Name =>
13444
                               Make_Identifier (Loc, Chars (Typ)));
13445
                        else
13446
                           Nam := Make_Identifier (Loc, Chars (Typ));
13447
                        end if;
13448
 
13449
                        Qual :=
13450
                          Make_Qualified_Expression (Loc,
13451
                            Subtype_Mark => Nam,
13452
                            Expression => Relocate_Node (N));
13453
                     end if;
13454
                  end if;
13455
 
13456
                  Save_Global_Descendant (Field1 (N));
13457
                  Save_Global_Descendant (Field2 (N));
13458
                  Save_Global_Descendant (Field3 (N));
13459
                  Save_Global_Descendant (Field5 (N));
13460
 
13461
                  if Present (Qual) then
13462
                     Rewrite (N, Qual);
13463
                  end if;
13464
 
13465
               --  All other cases than aggregates
13466
 
13467
               else
13468
                  Save_Global_Descendant (Field1 (N));
13469
                  Save_Global_Descendant (Field2 (N));
13470
                  Save_Global_Descendant (Field3 (N));
13471
                  Save_Global_Descendant (Field4 (N));
13472
                  Save_Global_Descendant (Field5 (N));
13473
               end if;
13474
            end;
13475
         end if;
13476
 
13477
         --  If a node has aspects, references within their expressions must
13478
         --  be saved separately, given that they are not directly in the
13479
         --  tree.
13480
 
13481
         if Has_Aspects (N) then
13482
            declare
13483
               Aspect : Node_Id;
13484
            begin
13485
               Aspect := First (Aspect_Specifications (N));
13486
               while Present (Aspect) loop
13487
                  Save_Global_References (Expression (Aspect));
13488
                  Next (Aspect);
13489
               end loop;
13490
            end;
13491
         end if;
13492
      end Save_References;
13493
 
13494
   --  Start of processing for Save_Global_References
13495
 
13496
   begin
13497
      Gen_Scope := Current_Scope;
13498
 
13499
      --  If the generic unit is a child unit, references to entities in the
13500
      --  parent are treated as local, because they will be resolved anew in
13501
      --  the context of the instance of the parent.
13502
 
13503
      while Is_Child_Unit (Gen_Scope)
13504
        and then Ekind (Scope (Gen_Scope)) = E_Generic_Package
13505
      loop
13506
         Gen_Scope := Scope (Gen_Scope);
13507
      end loop;
13508
 
13509
      Save_References (N);
13510
   end Save_Global_References;
13511
 
13512
   --------------------------------------
13513
   -- Set_Copied_Sloc_For_Inlined_Body --
13514
   --------------------------------------
13515
 
13516
   procedure Set_Copied_Sloc_For_Inlined_Body (N : Node_Id; E : Entity_Id) is
13517
   begin
13518
      Create_Instantiation_Source (N, E, True, S_Adjustment);
13519
   end Set_Copied_Sloc_For_Inlined_Body;
13520
 
13521
   ---------------------
13522
   -- Set_Instance_Of --
13523
   ---------------------
13524
 
13525
   procedure Set_Instance_Of (A : Entity_Id; B : Entity_Id) is
13526
   begin
13527
      Generic_Renamings.Table (Generic_Renamings.Last) := (A, B, Assoc_Null);
13528
      Generic_Renamings_HTable.Set (Generic_Renamings.Last);
13529
      Generic_Renamings.Increment_Last;
13530
   end Set_Instance_Of;
13531
 
13532
   --------------------
13533
   -- Set_Next_Assoc --
13534
   --------------------
13535
 
13536
   procedure Set_Next_Assoc (E : Assoc_Ptr; Next : Assoc_Ptr) is
13537
   begin
13538
      Generic_Renamings.Table (E).Next_In_HTable := Next;
13539
   end Set_Next_Assoc;
13540
 
13541
   -------------------
13542
   -- Start_Generic --
13543
   -------------------
13544
 
13545
   procedure Start_Generic is
13546
   begin
13547
      --  ??? More things could be factored out in this routine.
13548
      --  Should probably be done at a later stage.
13549
 
13550
      Generic_Flags.Append (Inside_A_Generic);
13551
      Inside_A_Generic := True;
13552
 
13553
      Expander_Mode_Save_And_Set (False);
13554
   end Start_Generic;
13555
 
13556
   ----------------------
13557
   -- Set_Instance_Env --
13558
   ----------------------
13559
 
13560
   procedure Set_Instance_Env
13561
     (Gen_Unit : Entity_Id;
13562
      Act_Unit : Entity_Id)
13563
   is
13564
   begin
13565
      --  Regardless of the current mode, predefined units are analyzed in the
13566
      --  most current Ada mode, and earlier version Ada checks do not apply
13567
      --  to predefined units. Nothing needs to be done for non-internal units.
13568
      --  These are always analyzed in the current mode.
13569
 
13570
      if Is_Internal_File_Name
13571
           (Fname              => Unit_File_Name (Get_Source_Unit (Gen_Unit)),
13572
            Renamings_Included => True)
13573
      then
13574
         Set_Opt_Config_Switches (True, Current_Sem_Unit = Main_Unit);
13575
      end if;
13576
 
13577
      Current_Instantiated_Parent :=
13578
        (Gen_Id         => Gen_Unit,
13579
         Act_Id         => Act_Unit,
13580
         Next_In_HTable => Assoc_Null);
13581
   end Set_Instance_Env;
13582
 
13583
   -----------------
13584
   -- Switch_View --
13585
   -----------------
13586
 
13587
   procedure Switch_View (T : Entity_Id) is
13588
      BT        : constant Entity_Id := Base_Type (T);
13589
      Priv_Elmt : Elmt_Id := No_Elmt;
13590
      Priv_Sub  : Entity_Id;
13591
 
13592
   begin
13593
      --  T may be private but its base type may have been exchanged through
13594
      --  some other occurrence, in which case there is nothing to switch
13595
      --  besides T itself. Note that a private dependent subtype of a private
13596
      --  type might not have been switched even if the base type has been,
13597
      --  because of the last branch of Check_Private_View (see comment there).
13598
 
13599
      if not Is_Private_Type (BT) then
13600
         Prepend_Elmt (Full_View (T), Exchanged_Views);
13601
         Exchange_Declarations (T);
13602
         return;
13603
      end if;
13604
 
13605
      Priv_Elmt := First_Elmt (Private_Dependents (BT));
13606
 
13607
      if Present (Full_View (BT)) then
13608
         Prepend_Elmt (Full_View (BT), Exchanged_Views);
13609
         Exchange_Declarations (BT);
13610
      end if;
13611
 
13612
      while Present (Priv_Elmt) loop
13613
         Priv_Sub := (Node (Priv_Elmt));
13614
 
13615
         --  We avoid flipping the subtype if the Etype of its full view is
13616
         --  private because this would result in a malformed subtype. This
13617
         --  occurs when the Etype of the subtype full view is the full view of
13618
         --  the base type (and since the base types were just switched, the
13619
         --  subtype is pointing to the wrong view). This is currently the case
13620
         --  for tagged record types, access types (maybe more?) and needs to
13621
         --  be resolved. ???
13622
 
13623
         if Present (Full_View (Priv_Sub))
13624
           and then not Is_Private_Type (Etype (Full_View (Priv_Sub)))
13625
         then
13626
            Prepend_Elmt (Full_View (Priv_Sub), Exchanged_Views);
13627
            Exchange_Declarations (Priv_Sub);
13628
         end if;
13629
 
13630
         Next_Elmt (Priv_Elmt);
13631
      end loop;
13632
   end Switch_View;
13633
 
13634
   -----------------
13635
   -- True_Parent --
13636
   -----------------
13637
 
13638
   function True_Parent (N : Node_Id) return Node_Id is
13639
   begin
13640
      if Nkind (Parent (N)) = N_Subunit then
13641
         return Parent (Corresponding_Stub (Parent (N)));
13642
      else
13643
         return Parent (N);
13644
      end if;
13645
   end True_Parent;
13646
 
13647
   -----------------------------
13648
   -- Valid_Default_Attribute --
13649
   -----------------------------
13650
 
13651
   procedure Valid_Default_Attribute (Nam : Entity_Id; Def : Node_Id) is
13652
      Attr_Id : constant Attribute_Id :=
13653
                  Get_Attribute_Id (Attribute_Name (Def));
13654
      T       : constant Entity_Id := Entity (Prefix (Def));
13655
      Is_Fun  : constant Boolean := (Ekind (Nam) = E_Function);
13656
      F       : Entity_Id;
13657
      Num_F   : Int;
13658
      OK      : Boolean;
13659
 
13660
   begin
13661
      if No (T)
13662
        or else T = Any_Id
13663
      then
13664
         return;
13665
      end if;
13666
 
13667
      Num_F := 0;
13668
      F := First_Formal (Nam);
13669
      while Present (F) loop
13670
         Num_F := Num_F + 1;
13671
         Next_Formal (F);
13672
      end loop;
13673
 
13674
      case Attr_Id is
13675
         when Attribute_Adjacent |  Attribute_Ceiling   | Attribute_Copy_Sign |
13676
              Attribute_Floor    |  Attribute_Fraction  | Attribute_Machine   |
13677
              Attribute_Model    |  Attribute_Remainder | Attribute_Rounding  |
13678
              Attribute_Unbiased_Rounding  =>
13679
            OK := Is_Fun
13680
                    and then Num_F = 1
13681
                    and then Is_Floating_Point_Type (T);
13682
 
13683
         when Attribute_Image    | Attribute_Pred       | Attribute_Succ |
13684
              Attribute_Value    | Attribute_Wide_Image |
13685
              Attribute_Wide_Value  =>
13686
            OK := (Is_Fun and then Num_F = 1 and then Is_Scalar_Type (T));
13687
 
13688
         when Attribute_Max      |  Attribute_Min  =>
13689
            OK := (Is_Fun and then Num_F = 2 and then Is_Scalar_Type (T));
13690
 
13691
         when Attribute_Input =>
13692
            OK := (Is_Fun and then Num_F = 1);
13693
 
13694
         when Attribute_Output | Attribute_Read | Attribute_Write =>
13695
            OK := (not Is_Fun and then Num_F = 2);
13696
 
13697
         when others =>
13698
            OK := False;
13699
      end case;
13700
 
13701
      if not OK then
13702
         Error_Msg_N ("attribute reference has wrong profile for subprogram",
13703
           Def);
13704
      end if;
13705
   end Valid_Default_Attribute;
13706
 
13707
end Sem_Ch12;

powered by: WebSVN 2.1.0

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