Properly regenerate gcc/configure.
[official-gcc.git] / gcc / ada / sem_ch12.adb
blobdd8badb1065d595d47f9ed4117786d54d991b923
1 ------------------------------------------------------------------------------
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-2014, 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 ------------------------------------------------------------------------------
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 Exp_Util; use Exp_Util;
34 with Fname; use Fname;
35 with Fname.UF; use Fname.UF;
36 with Freeze; use Freeze;
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 with Warnsw; use Warnsw;
81 with GNAT.HTable;
83 package body Sem_Ch12 is
85 ----------------------------------------------------------
86 -- Implementation of Generic Analysis and Instantiation --
87 ----------------------------------------------------------
89 -- GNAT implements generics by macro expansion. No attempt is made to share
90 -- generic instantiations (for now). Analysis of a generic definition does
91 -- not perform any expansion action, but the expander must be called on the
92 -- tree for each instantiation, because the expansion may of course depend
93 -- on the generic actuals. All of this is best achieved as follows:
95 -- a) Semantic analysis of a generic unit is performed on a copy of the
96 -- tree for the generic unit. All tree modifications that follow analysis
97 -- do not affect the original tree. Links are kept between the original
98 -- tree and the copy, in order to recognize non-local references within
99 -- the generic, and propagate them to each instance (recall that name
100 -- resolution is done on the generic declaration: generics are not really
101 -- macros). This is summarized in the following diagram:
103 -- .-----------. .----------.
104 -- | semantic |<--------------| generic |
105 -- | copy | | unit |
106 -- | |==============>| |
107 -- |___________| global |__________|
108 -- references | | |
109 -- | | |
110 -- .-----|--|.
111 -- | .-----|---.
112 -- | | .----------.
113 -- | | | generic |
114 -- |__| | |
115 -- |__| instance |
116 -- |__________|
118 -- b) Each instantiation copies the original tree, and inserts into it a
119 -- series of declarations that describe the mapping between generic formals
120 -- and actuals. For example, a generic In OUT parameter is an object
121 -- renaming of the corresponding actual, etc. Generic IN parameters are
122 -- constant declarations.
124 -- c) In order to give the right visibility for these renamings, we use
125 -- a different scheme for package and subprogram instantiations. For
126 -- packages, the list of renamings is inserted into the package
127 -- specification, before the visible declarations of the package. The
128 -- renamings are analyzed before any of the text of the instance, and are
129 -- thus visible at the right place. Furthermore, outside of the instance,
130 -- the generic parameters are visible and denote their corresponding
131 -- actuals.
133 -- For subprograms, we create a container package to hold the renamings
134 -- and the subprogram instance itself. Analysis of the package makes the
135 -- renaming declarations visible to the subprogram. After analyzing the
136 -- package, the defining entity for the subprogram is touched-up so that
137 -- it appears declared in the current scope, and not inside the container
138 -- package.
140 -- If the instantiation is a compilation unit, the container package is
141 -- given the same name as the subprogram instance. This ensures that
142 -- the elaboration procedure called by the binder, using the compilation
143 -- unit name, calls in fact the elaboration procedure for the package.
145 -- Not surprisingly, private types complicate this approach. By saving in
146 -- the original generic object the non-local references, we guarantee that
147 -- the proper entities are referenced at the point of instantiation.
148 -- However, for private types, this by itself does not insure that the
149 -- proper VIEW of the entity is used (the full type may be visible at the
150 -- point of generic definition, but not at instantiation, or vice-versa).
151 -- In order to reference the proper view, we special-case any reference
152 -- to private types in the generic object, by saving both views, one in
153 -- the generic and one in the semantic copy. At time of instantiation, we
154 -- check whether the two views are consistent, and exchange declarations if
155 -- necessary, in order to restore the correct visibility. Similarly, if
156 -- the instance view is private when the generic view was not, we perform
157 -- the exchange. After completing the instantiation, we restore the
158 -- current visibility. The flag Has_Private_View marks identifiers in the
159 -- the generic unit that require checking.
161 -- Visibility within nested generic units requires special handling.
162 -- Consider the following scheme:
164 -- type Global is ... -- outside of generic unit.
165 -- generic ...
166 -- package Outer is
167 -- ...
168 -- type Semi_Global is ... -- global to inner.
170 -- generic ... -- 1
171 -- procedure inner (X1 : Global; X2 : Semi_Global);
173 -- procedure in2 is new inner (...); -- 4
174 -- end Outer;
176 -- package New_Outer is new Outer (...); -- 2
177 -- procedure New_Inner is new New_Outer.Inner (...); -- 3
179 -- The semantic analysis of Outer captures all occurrences of Global.
180 -- The semantic analysis of Inner (at 1) captures both occurrences of
181 -- Global and Semi_Global.
183 -- At point 2 (instantiation of Outer), we also produce a generic copy
184 -- of Inner, even though Inner is, at that point, not being instantiated.
185 -- (This is just part of the semantic analysis of New_Outer).
187 -- Critically, references to Global within Inner must be preserved, while
188 -- references to Semi_Global should not preserved, because they must now
189 -- resolve to an entity within New_Outer. To distinguish between these, we
190 -- use a global variable, Current_Instantiated_Parent, which is set when
191 -- performing a generic copy during instantiation (at 2). This variable is
192 -- used when performing a generic copy that is not an instantiation, but
193 -- that is nested within one, as the occurrence of 1 within 2. The analysis
194 -- of a nested generic only preserves references that are global to the
195 -- enclosing Current_Instantiated_Parent. We use the Scope_Depth value to
196 -- determine whether a reference is external to the given parent.
198 -- The instantiation at point 3 requires no special treatment. The method
199 -- works as well for further nestings of generic units, but of course the
200 -- variable Current_Instantiated_Parent must be stacked because nested
201 -- instantiations can occur, e.g. the occurrence of 4 within 2.
203 -- The instantiation of package and subprogram bodies is handled in a
204 -- similar manner, except that it is delayed until after semantic
205 -- analysis is complete. In this fashion complex cross-dependencies
206 -- between several package declarations and bodies containing generics
207 -- can be compiled which otherwise would diagnose spurious circularities.
209 -- For example, it is possible to compile two packages A and B that
210 -- have the following structure:
212 -- package A is package B is
213 -- generic ... generic ...
214 -- package G_A is package G_B is
216 -- with B; with A;
217 -- package body A is package body B is
218 -- package N_B is new G_B (..) package N_A is new G_A (..)
220 -- The table Pending_Instantiations in package Inline is used to keep
221 -- track of body instantiations that are delayed in this manner. Inline
222 -- handles the actual calls to do the body instantiations. This activity
223 -- is part of Inline, since the processing occurs at the same point, and
224 -- for essentially the same reason, as the handling of inlined routines.
226 ----------------------------------------------
227 -- Detection of Instantiation Circularities --
228 ----------------------------------------------
230 -- If we have a chain of instantiations that is circular, this is static
231 -- error which must be detected at compile time. The detection of these
232 -- circularities is carried out at the point that we insert a generic
233 -- instance spec or body. If there is a circularity, then the analysis of
234 -- the offending spec or body will eventually result in trying to load the
235 -- same unit again, and we detect this problem as we analyze the package
236 -- instantiation for the second time.
238 -- At least in some cases after we have detected the circularity, we get
239 -- into trouble if we try to keep going. The following flag is set if a
240 -- circularity is detected, and used to abandon compilation after the
241 -- messages have been posted.
243 Circularity_Detected : Boolean := False;
244 -- This should really be reset on encountering a new main unit, but in
245 -- practice we are not using multiple main units so it is not critical.
247 --------------------------------------------------
248 -- Formal packages and partial parameterization --
249 --------------------------------------------------
251 -- When compiling a generic, a formal package is a local instantiation. If
252 -- declared with a box, its generic formals are visible in the enclosing
253 -- generic. If declared with a partial list of actuals, those actuals that
254 -- are defaulted (covered by an Others clause, or given an explicit box
255 -- initialization) are also visible in the enclosing generic, while those
256 -- that have a corresponding actual are not.
258 -- In our source model of instantiation, the same visibility must be
259 -- present in the spec and body of an instance: the names of the formals
260 -- that are defaulted must be made visible within the instance, and made
261 -- invisible (hidden) after the instantiation is complete, so that they
262 -- are not accessible outside of the instance.
264 -- In a generic, a formal package is treated like a special instantiation.
265 -- Our Ada 95 compiler handled formals with and without box in different
266 -- ways. With partial parameterization, we use a single model for both.
267 -- We create a package declaration that consists of the specification of
268 -- the generic package, and a set of declarations that map the actuals
269 -- into local renamings, just as we do for bona fide instantiations. For
270 -- defaulted parameters and formals with a box, we copy directly the
271 -- declarations of the formal into this local package. The result is a
272 -- a package whose visible declarations may include generic formals. This
273 -- package is only used for type checking and visibility analysis, and
274 -- never reaches the back-end, so it can freely violate the placement
275 -- rules for generic formal declarations.
277 -- The list of declarations (renamings and copies of formals) is built
278 -- by Analyze_Associations, just as for regular instantiations.
280 -- At the point of instantiation, conformance checking must be applied only
281 -- to those parameters that were specified in the formal. We perform this
282 -- checking by creating another internal instantiation, this one including
283 -- only the renamings and the formals (the rest of the package spec is not
284 -- relevant to conformance checking). We can then traverse two lists: the
285 -- list of actuals in the instance that corresponds to the formal package,
286 -- and the list of actuals produced for this bogus instantiation. We apply
287 -- the conformance rules to those actuals that are not defaulted (i.e.
288 -- which still appear as generic formals.
290 -- When we compile an instance body we must make the right parameters
291 -- visible again. The predicate Is_Generic_Formal indicates which of the
292 -- formals should have its Is_Hidden flag reset.
294 -----------------------
295 -- Local subprograms --
296 -----------------------
298 procedure Abandon_Instantiation (N : Node_Id);
299 pragma No_Return (Abandon_Instantiation);
300 -- Posts an error message "instantiation abandoned" at the indicated node
301 -- and then raises the exception Instantiation_Error to do it.
303 procedure Analyze_Formal_Array_Type
304 (T : in out Entity_Id;
305 Def : Node_Id);
306 -- A formal array type is treated like an array type declaration, and
307 -- invokes Array_Type_Declaration (sem_ch3) whose first parameter is
308 -- in-out, because in the case of an anonymous type the entity is
309 -- actually created in the procedure.
311 -- The following procedures treat other kinds of formal parameters
313 procedure Analyze_Formal_Derived_Interface_Type
314 (N : Node_Id;
315 T : Entity_Id;
316 Def : Node_Id);
318 procedure Analyze_Formal_Derived_Type
319 (N : Node_Id;
320 T : Entity_Id;
321 Def : Node_Id);
323 procedure Analyze_Formal_Interface_Type
324 (N : Node_Id;
325 T : Entity_Id;
326 Def : Node_Id);
328 -- The following subprograms create abbreviated declarations for formal
329 -- scalar types. We introduce an anonymous base of the proper class for
330 -- each of them, and define the formals as constrained first subtypes of
331 -- their bases. The bounds are expressions that are non-static in the
332 -- generic.
334 procedure Analyze_Formal_Decimal_Fixed_Point_Type
335 (T : Entity_Id; Def : Node_Id);
336 procedure Analyze_Formal_Discrete_Type (T : Entity_Id; Def : Node_Id);
337 procedure Analyze_Formal_Floating_Type (T : Entity_Id; Def : Node_Id);
338 procedure Analyze_Formal_Signed_Integer_Type (T : Entity_Id; Def : Node_Id);
339 procedure Analyze_Formal_Modular_Type (T : Entity_Id; Def : Node_Id);
340 procedure Analyze_Formal_Ordinary_Fixed_Point_Type
341 (T : Entity_Id; Def : Node_Id);
343 procedure Analyze_Formal_Private_Type
344 (N : Node_Id;
345 T : Entity_Id;
346 Def : Node_Id);
347 -- Creates a new private type, which does not require completion
349 procedure Analyze_Formal_Incomplete_Type (T : Entity_Id; Def : Node_Id);
350 -- Ada 2012: Creates a new incomplete type whose actual does not freeze
352 procedure Analyze_Generic_Formal_Part (N : Node_Id);
353 -- Analyze generic formal part
355 procedure Analyze_Generic_Access_Type (T : Entity_Id; Def : Node_Id);
356 -- Create a new access type with the given designated type
358 function Analyze_Associations
359 (I_Node : Node_Id;
360 Formals : List_Id;
361 F_Copy : List_Id) return List_Id;
362 -- At instantiation time, build the list of associations between formals
363 -- and actuals. Each association becomes a renaming declaration for the
364 -- formal entity. F_Copy is the analyzed list of formals in the generic
365 -- copy. It is used to apply legality checks to the actuals. I_Node is the
366 -- instantiation node itself.
368 procedure Analyze_Subprogram_Instantiation
369 (N : Node_Id;
370 K : Entity_Kind);
372 procedure Build_Instance_Compilation_Unit_Nodes
373 (N : Node_Id;
374 Act_Body : Node_Id;
375 Act_Decl : Node_Id);
376 -- This procedure is used in the case where the generic instance of a
377 -- subprogram body or package body is a library unit. In this case, the
378 -- original library unit node for the generic instantiation must be
379 -- replaced by the resulting generic body, and a link made to a new
380 -- compilation unit node for the generic declaration. The argument N is
381 -- the original generic instantiation. Act_Body and Act_Decl are the body
382 -- and declaration of the instance (either package body and declaration
383 -- nodes or subprogram body and declaration nodes depending on the case).
384 -- On return, the node N has been rewritten with the actual body.
386 procedure Check_Access_Definition (N : Node_Id);
387 -- Subsidiary routine to null exclusion processing. Perform an assertion
388 -- check on Ada version and the presence of an access definition in N.
390 procedure Check_Formal_Packages (P_Id : Entity_Id);
391 -- Apply the following to all formal packages in generic associations
393 procedure Check_Formal_Package_Instance
394 (Formal_Pack : Entity_Id;
395 Actual_Pack : Entity_Id);
396 -- Verify that the actuals of the actual instance match the actuals of
397 -- the template for a formal package that is not declared with a box.
399 procedure Check_Forward_Instantiation (Decl : Node_Id);
400 -- If the generic is a local entity and the corresponding body has not
401 -- been seen yet, flag enclosing packages to indicate that it will be
402 -- elaborated after the generic body. Subprograms declared in the same
403 -- package cannot be inlined by the front-end because front-end inlining
404 -- requires a strict linear order of elaboration.
406 function Check_Hidden_Primitives (Assoc_List : List_Id) return Elist_Id;
407 -- Check if some association between formals and actuals requires to make
408 -- visible primitives of a tagged type, and make those primitives visible.
409 -- Return the list of primitives whose visibility is modified (to restore
410 -- their visibility later through Restore_Hidden_Primitives). If no
411 -- candidate is found then return No_Elist.
413 procedure Check_Hidden_Child_Unit
414 (N : Node_Id;
415 Gen_Unit : Entity_Id;
416 Act_Decl_Id : Entity_Id);
417 -- If the generic unit is an implicit child instance within a parent
418 -- instance, we need to make an explicit test that it is not hidden by
419 -- a child instance of the same name and parent.
421 procedure Check_Generic_Actuals
422 (Instance : Entity_Id;
423 Is_Formal_Box : Boolean);
424 -- Similar to previous one. Check the actuals in the instantiation,
425 -- whose views can change between the point of instantiation and the point
426 -- of instantiation of the body. In addition, mark the generic renamings
427 -- as generic actuals, so that they are not compatible with other actuals.
428 -- Recurse on an actual that is a formal package whose declaration has
429 -- a box.
431 function Contains_Instance_Of
432 (Inner : Entity_Id;
433 Outer : Entity_Id;
434 N : Node_Id) return Boolean;
435 -- Inner is instantiated within the generic Outer. Check whether Inner
436 -- directly or indirectly contains an instance of Outer or of one of its
437 -- parents, in the case of a subunit. Each generic unit holds a list of
438 -- the entities instantiated within (at any depth). This procedure
439 -- determines whether the set of such lists contains a cycle, i.e. an
440 -- illegal circular instantiation.
442 function Denotes_Formal_Package
443 (Pack : Entity_Id;
444 On_Exit : Boolean := False;
445 Instance : Entity_Id := Empty) return Boolean;
446 -- Returns True if E is a formal package of an enclosing generic, or
447 -- the actual for such a formal in an enclosing instantiation. If such
448 -- a package is used as a formal in an nested generic, or as an actual
449 -- in a nested instantiation, the visibility of ITS formals should not
450 -- be modified. When called from within Restore_Private_Views, the flag
451 -- On_Exit is true, to indicate that the search for a possible enclosing
452 -- instance should ignore the current one. In that case Instance denotes
453 -- the declaration for which this is an actual. This declaration may be
454 -- an instantiation in the source, or the internal instantiation that
455 -- corresponds to the actual for a formal package.
457 function Earlier (N1, N2 : Node_Id) return Boolean;
458 -- Yields True if N1 and N2 appear in the same compilation unit,
459 -- ignoring subunits, and if N1 is to the left of N2 in a left-to-right
460 -- traversal of the tree for the unit. Used to determine the placement
461 -- of freeze nodes for instance bodies that may depend on other instances.
463 function Find_Actual_Type
464 (Typ : Entity_Id;
465 Gen_Type : Entity_Id) return Entity_Id;
466 -- When validating the actual types of a child instance, check whether
467 -- the formal is a formal type of the parent unit, and retrieve the current
468 -- actual for it. Typ is the entity in the analyzed formal type declaration
469 -- (component or index type of an array type, or designated type of an
470 -- access formal) and Gen_Type is the enclosing analyzed formal array
471 -- or access type. The desired actual may be a formal of a parent, or may
472 -- be declared in a formal package of a parent. In both cases it is a
473 -- generic actual type because it appears within a visible instance.
474 -- Finally, it may be declared in a parent unit without being a formal
475 -- of that unit, in which case it must be retrieved by visibility.
476 -- Ambiguities may still arise if two homonyms are declared in two formal
477 -- packages, and the prefix of the formal type may be needed to resolve
478 -- the ambiguity in the instance ???
480 function In_Same_Declarative_Part
481 (F_Node : Node_Id;
482 Inst : Node_Id) return Boolean;
483 -- True if the instantiation Inst and the given freeze_node F_Node appear
484 -- within the same declarative part, ignoring subunits, but with no inter-
485 -- vening subprograms or concurrent units. Used to find the proper plave
486 -- for the freeze node of an instance, when the generic is declared in a
487 -- previous instance. If predicate is true, the freeze node of the instance
488 -- can be placed after the freeze node of the previous instance, Otherwise
489 -- it has to be placed at the end of the current declarative part.
491 function In_Main_Context (E : Entity_Id) return Boolean;
492 -- Check whether an instantiation is in the context of the main unit.
493 -- Used to determine whether its body should be elaborated to allow
494 -- front-end inlining.
496 procedure Set_Instance_Env
497 (Gen_Unit : Entity_Id;
498 Act_Unit : Entity_Id);
499 -- Save current instance on saved environment, to be used to determine
500 -- the global status of entities in nested instances. Part of Save_Env.
501 -- called after verifying that the generic unit is legal for the instance,
502 -- The procedure also examines whether the generic unit is a predefined
503 -- unit, in order to set configuration switches accordingly. As a result
504 -- the procedure must be called after analyzing and freezing the actuals.
506 procedure Set_Instance_Of (A : Entity_Id; B : Entity_Id);
507 -- Associate analyzed generic parameter with corresponding
508 -- instance. Used for semantic checks at instantiation time.
510 function Has_Been_Exchanged (E : Entity_Id) return Boolean;
511 -- Traverse the Exchanged_Views list to see if a type was private
512 -- and has already been flipped during this phase of instantiation.
514 procedure Hide_Current_Scope;
515 -- When instantiating a generic child unit, the parent context must be
516 -- present, but the instance and all entities that may be generated
517 -- must be inserted in the current scope. We leave the current scope
518 -- on the stack, but make its entities invisible to avoid visibility
519 -- problems. This is reversed at the end of the instantiation. This is
520 -- not done for the instantiation of the bodies, which only require the
521 -- instances of the generic parents to be in scope.
523 procedure Install_Body
524 (Act_Body : Node_Id;
525 N : Node_Id;
526 Gen_Body : Node_Id;
527 Gen_Decl : Node_Id);
528 -- If the instantiation happens textually before the body of the generic,
529 -- the instantiation of the body must be analyzed after the generic body,
530 -- and not at the point of instantiation. Such early instantiations can
531 -- happen if the generic and the instance appear in a package declaration
532 -- because the generic body can only appear in the corresponding package
533 -- body. Early instantiations can also appear if generic, instance and
534 -- body are all in the declarative part of a subprogram or entry. Entities
535 -- of packages that are early instantiations are delayed, and their freeze
536 -- node appears after the generic body.
538 procedure Insert_Freeze_Node_For_Instance
539 (N : Node_Id;
540 F_Node : Node_Id);
541 -- N denotes a package or a subprogram instantiation and F_Node is the
542 -- associated freeze node. Insert the freeze node before the first source
543 -- body which follows immediately after N. If no such body is found, the
544 -- freeze node is inserted at the end of the declarative region which
545 -- contains N.
547 procedure Freeze_Subprogram_Body
548 (Inst_Node : Node_Id;
549 Gen_Body : Node_Id;
550 Pack_Id : Entity_Id);
551 -- The generic body may appear textually after the instance, including
552 -- in the proper body of a stub, or within a different package instance.
553 -- Given that the instance can only be elaborated after the generic, we
554 -- place freeze_nodes for the instance and/or for packages that may enclose
555 -- the instance and the generic, so that the back-end can establish the
556 -- proper order of elaboration.
558 procedure Init_Env;
559 -- Establish environment for subsequent instantiation. Separated from
560 -- Save_Env because data-structures for visibility handling must be
561 -- initialized before call to Check_Generic_Child_Unit.
563 procedure Install_Formal_Packages (Par : Entity_Id);
564 -- Install the visible part of any formal of the parent that is a formal
565 -- package. Note that for the case of a formal package with a box, this
566 -- includes the formal part of the formal package (12.7(10/2)).
568 procedure Install_Parent (P : Entity_Id; In_Body : Boolean := False);
569 -- When compiling an instance of a child unit the parent (which is
570 -- itself an instance) is an enclosing scope that must be made
571 -- immediately visible. This procedure is also used to install the non-
572 -- generic parent of a generic child unit when compiling its body, so
573 -- that full views of types in the parent are made visible.
575 procedure Remove_Parent (In_Body : Boolean := False);
576 -- Reverse effect after instantiation of child is complete
578 procedure Install_Hidden_Primitives
579 (Prims_List : in out Elist_Id;
580 Gen_T : Entity_Id;
581 Act_T : Entity_Id);
582 -- Remove suffix 'P' from hidden primitives of Act_T to match the
583 -- visibility of primitives of Gen_T. The list of primitives to which
584 -- the suffix is removed is added to Prims_List to restore them later.
586 procedure Restore_Hidden_Primitives (Prims_List : in out Elist_Id);
587 -- Restore suffix 'P' to primitives of Prims_List and leave Prims_List
588 -- set to No_Elist.
590 procedure Inline_Instance_Body
591 (N : Node_Id;
592 Gen_Unit : Entity_Id;
593 Act_Decl : Node_Id);
594 -- If front-end inlining is requested, instantiate the package body,
595 -- and preserve the visibility of its compilation unit, to insure
596 -- that successive instantiations succeed.
598 -- The functions Instantiate_XXX perform various legality checks and build
599 -- the declarations for instantiated generic parameters. In all of these
600 -- Formal is the entity in the generic unit, Actual is the entity of
601 -- expression in the generic associations, and Analyzed_Formal is the
602 -- formal in the generic copy, which contains the semantic information to
603 -- be used to validate the actual.
605 function Instantiate_Object
606 (Formal : Node_Id;
607 Actual : Node_Id;
608 Analyzed_Formal : Node_Id) return List_Id;
610 function Instantiate_Type
611 (Formal : Node_Id;
612 Actual : Node_Id;
613 Analyzed_Formal : Node_Id;
614 Actual_Decls : List_Id) return List_Id;
616 function Instantiate_Formal_Subprogram
617 (Formal : Node_Id;
618 Actual : Node_Id;
619 Analyzed_Formal : Node_Id) return Node_Id;
621 function Instantiate_Formal_Package
622 (Formal : Node_Id;
623 Actual : Node_Id;
624 Analyzed_Formal : Node_Id) return List_Id;
625 -- If the formal package is declared with a box, special visibility rules
626 -- apply to its formals: they are in the visible part of the package. This
627 -- is true in the declarative region of the formal package, that is to say
628 -- in the enclosing generic or instantiation. For an instantiation, the
629 -- parameters of the formal package are made visible in an explicit step.
630 -- Furthermore, if the actual has a visible USE clause, these formals must
631 -- be made potentially use-visible as well. On exit from the enclosing
632 -- instantiation, the reverse must be done.
634 -- For a formal package declared without a box, there are conformance rules
635 -- that apply to the actuals in the generic declaration and the actuals of
636 -- the actual package in the enclosing instantiation. The simplest way to
637 -- apply these rules is to repeat the instantiation of the formal package
638 -- in the context of the enclosing instance, and compare the generic
639 -- associations of this instantiation with those of the actual package.
640 -- This internal instantiation only needs to contain the renamings of the
641 -- formals: the visible and private declarations themselves need not be
642 -- created.
644 -- In Ada 2005, the formal package may be only partially parameterized.
645 -- In that case the visibility step must make visible those actuals whose
646 -- corresponding formals were given with a box. A final complication
647 -- involves inherited operations from formal derived types, which must
648 -- be visible if the type is.
650 function Is_In_Main_Unit (N : Node_Id) return Boolean;
651 -- Test if given node is in the main unit
653 procedure Load_Parent_Of_Generic
654 (N : Node_Id;
655 Spec : Node_Id;
656 Body_Optional : Boolean := False);
657 -- If the generic appears in a separate non-generic library unit, load the
658 -- corresponding body to retrieve the body of the generic. N is the node
659 -- for the generic instantiation, Spec is the generic package declaration.
661 -- Body_Optional is a flag that indicates that the body is being loaded to
662 -- ensure that temporaries are generated consistently when there are other
663 -- instances in the current declarative part that precede the one being
664 -- loaded. In that case a missing body is acceptable.
666 procedure Inherit_Context (Gen_Decl : Node_Id; Inst : Node_Id);
667 -- Add the context clause of the unit containing a generic unit to a
668 -- compilation unit that is, or contains, an instantiation.
670 function Get_Associated_Node (N : Node_Id) return Node_Id;
671 -- In order to propagate semantic information back from the analyzed copy
672 -- to the original generic, we maintain links between selected nodes in the
673 -- generic and their corresponding copies. At the end of generic analysis,
674 -- the routine Save_Global_References traverses the generic tree, examines
675 -- the semantic information, and preserves the links to those nodes that
676 -- contain global information. At instantiation, the information from the
677 -- associated node is placed on the new copy, so that name resolution is
678 -- not repeated.
680 -- Three kinds of source nodes have associated nodes:
682 -- a) those that can reference (denote) entities, that is identifiers,
683 -- character literals, expanded_names, operator symbols, operators,
684 -- and attribute reference nodes. These nodes have an Entity field
685 -- and are the set of nodes that are in N_Has_Entity.
687 -- b) aggregates (N_Aggregate and N_Extension_Aggregate)
689 -- c) selected components (N_Selected_Component)
691 -- For the first class, the associated node preserves the entity if it is
692 -- global. If the generic contains nested instantiations, the associated
693 -- node itself has been recopied, and a chain of them must be followed.
695 -- For aggregates, the associated node allows retrieval of the type, which
696 -- may otherwise not appear in the generic. The view of this type may be
697 -- different between generic and instantiation, and the full view can be
698 -- installed before the instantiation is analyzed. For aggregates of type
699 -- extensions, the same view exchange may have to be performed for some of
700 -- the ancestor types, if their view is private at the point of
701 -- instantiation.
703 -- Nodes that are selected components in the parse tree may be rewritten
704 -- as expanded names after resolution, and must be treated as potential
705 -- entity holders, which is why they also have an Associated_Node.
707 -- Nodes that do not come from source, such as freeze nodes, do not appear
708 -- in the generic tree, and need not have an associated node.
710 -- The associated node is stored in the Associated_Node field. Note that
711 -- this field overlaps Entity, which is fine, because the whole point is
712 -- that we don't need or want the normal Entity field in this situation.
714 procedure Map_Formal_Package_Entities (Form : Entity_Id; Act : Entity_Id);
715 -- Within the generic part, entities in the formal package are
716 -- visible. To validate subsequent type declarations, indicate
717 -- the correspondence between the entities in the analyzed formal,
718 -- and the entities in the actual package. There are three packages
719 -- involved in the instantiation of a formal package: the parent
720 -- generic P1 which appears in the generic declaration, the fake
721 -- instantiation P2 which appears in the analyzed generic, and whose
722 -- visible entities may be used in subsequent formals, and the actual
723 -- P3 in the instance. To validate subsequent formals, me indicate
724 -- that the entities in P2 are mapped into those of P3. The mapping of
725 -- entities has to be done recursively for nested packages.
727 procedure Move_Freeze_Nodes
728 (Out_Of : Entity_Id;
729 After : Node_Id;
730 L : List_Id);
731 -- Freeze nodes can be generated in the analysis of a generic unit, but
732 -- will not be seen by the back-end. It is necessary to move those nodes
733 -- to the enclosing scope if they freeze an outer entity. We place them
734 -- at the end of the enclosing generic package, which is semantically
735 -- neutral.
737 procedure Preanalyze_Actuals (N : Node_Id);
738 -- Analyze actuals to perform name resolution. Full resolution is done
739 -- later, when the expected types are known, but names have to be captured
740 -- before installing parents of generics, that are not visible for the
741 -- actuals themselves.
743 function True_Parent (N : Node_Id) return Node_Id;
744 -- For a subunit, return parent of corresponding stub, else return
745 -- parent of node.
747 procedure Valid_Default_Attribute (Nam : Entity_Id; Def : Node_Id);
748 -- Verify that an attribute that appears as the default for a formal
749 -- subprogram is a function or procedure with the correct profile.
751 -------------------------------------------
752 -- Data Structures for Generic Renamings --
753 -------------------------------------------
755 -- The map Generic_Renamings associates generic entities with their
756 -- corresponding actuals. Currently used to validate type instances. It
757 -- will eventually be used for all generic parameters to eliminate the
758 -- need for overload resolution in the instance.
760 type Assoc_Ptr is new Int;
762 Assoc_Null : constant Assoc_Ptr := -1;
764 type Assoc is record
765 Gen_Id : Entity_Id;
766 Act_Id : Entity_Id;
767 Next_In_HTable : Assoc_Ptr;
768 end record;
770 package Generic_Renamings is new Table.Table
771 (Table_Component_Type => Assoc,
772 Table_Index_Type => Assoc_Ptr,
773 Table_Low_Bound => 0,
774 Table_Initial => 10,
775 Table_Increment => 100,
776 Table_Name => "Generic_Renamings");
778 -- Variable to hold enclosing instantiation. When the environment is
779 -- saved for a subprogram inlining, the corresponding Act_Id is empty.
781 Current_Instantiated_Parent : Assoc := (Empty, Empty, Assoc_Null);
783 -- Hash table for associations
785 HTable_Size : constant := 37;
786 type HTable_Range is range 0 .. HTable_Size - 1;
788 procedure Set_Next_Assoc (E : Assoc_Ptr; Next : Assoc_Ptr);
789 function Next_Assoc (E : Assoc_Ptr) return Assoc_Ptr;
790 function Get_Gen_Id (E : Assoc_Ptr) return Entity_Id;
791 function Hash (F : Entity_Id) return HTable_Range;
793 package Generic_Renamings_HTable is new GNAT.HTable.Static_HTable (
794 Header_Num => HTable_Range,
795 Element => Assoc,
796 Elmt_Ptr => Assoc_Ptr,
797 Null_Ptr => Assoc_Null,
798 Set_Next => Set_Next_Assoc,
799 Next => Next_Assoc,
800 Key => Entity_Id,
801 Get_Key => Get_Gen_Id,
802 Hash => Hash,
803 Equal => "=");
805 Exchanged_Views : Elist_Id;
806 -- This list holds the private views that have been exchanged during
807 -- instantiation to restore the visibility of the generic declaration.
808 -- (see comments above). After instantiation, the current visibility is
809 -- reestablished by means of a traversal of this list.
811 Hidden_Entities : Elist_Id;
812 -- This list holds the entities of the current scope that are removed
813 -- from immediate visibility when instantiating a child unit. Their
814 -- visibility is restored in Remove_Parent.
816 -- Because instantiations can be recursive, the following must be saved
817 -- on entry and restored on exit from an instantiation (spec or body).
818 -- This is done by the two procedures Save_Env and Restore_Env. For
819 -- package and subprogram instantiations (but not for the body instances)
820 -- the action of Save_Env is done in two steps: Init_Env is called before
821 -- Check_Generic_Child_Unit, because setting the parent instances requires
822 -- that the visibility data structures be properly initialized. Once the
823 -- generic is unit is validated, Set_Instance_Env completes Save_Env.
825 Parent_Unit_Visible : Boolean := False;
826 -- Parent_Unit_Visible is used when the generic is a child unit, and
827 -- indicates whether the ultimate parent of the generic is visible in the
828 -- instantiation environment. It is used to reset the visibility of the
829 -- parent at the end of the instantiation (see Remove_Parent).
831 Instance_Parent_Unit : Entity_Id := Empty;
832 -- This records the ultimate parent unit of an instance of a generic
833 -- child unit and is used in conjunction with Parent_Unit_Visible to
834 -- indicate the unit to which the Parent_Unit_Visible flag corresponds.
836 type Instance_Env is record
837 Instantiated_Parent : Assoc;
838 Exchanged_Views : Elist_Id;
839 Hidden_Entities : Elist_Id;
840 Current_Sem_Unit : Unit_Number_Type;
841 Parent_Unit_Visible : Boolean := False;
842 Instance_Parent_Unit : Entity_Id := Empty;
843 Switches : Config_Switches_Type;
844 end record;
846 package Instance_Envs is new Table.Table (
847 Table_Component_Type => Instance_Env,
848 Table_Index_Type => Int,
849 Table_Low_Bound => 0,
850 Table_Initial => 32,
851 Table_Increment => 100,
852 Table_Name => "Instance_Envs");
854 procedure Restore_Private_Views
855 (Pack_Id : Entity_Id;
856 Is_Package : Boolean := True);
857 -- Restore the private views of external types, and unmark the generic
858 -- renamings of actuals, so that they become compatible subtypes again.
859 -- For subprograms, Pack_Id is the package constructed to hold the
860 -- renamings.
862 procedure Switch_View (T : Entity_Id);
863 -- Switch the partial and full views of a type and its private
864 -- dependents (i.e. its subtypes and derived types).
866 ------------------------------------
867 -- Structures for Error Reporting --
868 ------------------------------------
870 Instantiation_Node : Node_Id;
871 -- Used by subprograms that validate instantiation of formal parameters
872 -- where there might be no actual on which to place the error message.
873 -- Also used to locate the instantiation node for generic subunits.
875 Instantiation_Error : exception;
876 -- When there is a semantic error in the generic parameter matching,
877 -- there is no point in continuing the instantiation, because the
878 -- number of cascaded errors is unpredictable. This exception aborts
879 -- the instantiation process altogether.
881 S_Adjustment : Sloc_Adjustment;
882 -- Offset created for each node in an instantiation, in order to keep
883 -- track of the source position of the instantiation in each of its nodes.
884 -- A subsequent semantic error or warning on a construct of the instance
885 -- points to both places: the original generic node, and the point of
886 -- instantiation. See Sinput and Sinput.L for additional details.
888 ------------------------------------------------------------
889 -- Data structure for keeping track when inside a Generic --
890 ------------------------------------------------------------
892 -- The following table is used to save values of the Inside_A_Generic
893 -- flag (see spec of Sem) when they are saved by Start_Generic.
895 package Generic_Flags is new Table.Table (
896 Table_Component_Type => Boolean,
897 Table_Index_Type => Int,
898 Table_Low_Bound => 0,
899 Table_Initial => 32,
900 Table_Increment => 200,
901 Table_Name => "Generic_Flags");
903 ---------------------------
904 -- Abandon_Instantiation --
905 ---------------------------
907 procedure Abandon_Instantiation (N : Node_Id) is
908 begin
909 Error_Msg_N ("\instantiation abandoned!", N);
910 raise Instantiation_Error;
911 end Abandon_Instantiation;
913 --------------------------
914 -- Analyze_Associations --
915 --------------------------
917 function Analyze_Associations
918 (I_Node : Node_Id;
919 Formals : List_Id;
920 F_Copy : List_Id) return List_Id
922 Actuals_To_Freeze : constant Elist_Id := New_Elmt_List;
923 Assoc : constant List_Id := New_List;
924 Default_Actuals : constant Elist_Id := New_Elmt_List;
925 Gen_Unit : constant Entity_Id :=
926 Defining_Entity (Parent (F_Copy));
928 Actuals : List_Id;
929 Actual : Node_Id;
930 Analyzed_Formal : Node_Id;
931 First_Named : Node_Id := Empty;
932 Formal : Node_Id;
933 Match : Node_Id;
934 Named : Node_Id;
935 Saved_Formal : Node_Id;
937 Default_Formals : constant List_Id := New_List;
938 -- If an Others_Choice is present, some of the formals may be defaulted.
939 -- To simplify the treatment of visibility in an instance, we introduce
940 -- individual defaults for each such formal. These defaults are
941 -- appended to the list of associations and replace the Others_Choice.
943 Found_Assoc : Node_Id;
944 -- Association for the current formal being match. Empty if there are
945 -- no remaining actuals, or if there is no named association with the
946 -- name of the formal.
948 Is_Named_Assoc : Boolean;
949 Num_Matched : Int := 0;
950 Num_Actuals : Int := 0;
952 Others_Present : Boolean := False;
953 Others_Choice : Node_Id := Empty;
954 -- In Ada 2005, indicates partial parameterization of a formal
955 -- package. As usual an other association must be last in the list.
957 function Build_Wrapper
958 (Formal : Entity_Id;
959 Actual : Entity_Id := Empty) return Node_Id;
960 -- In GNATProve mode, create a wrapper function for actuals that are
961 -- operators, in order to propagate their contract to the renaming
962 -- declarations generated for them. If the actual is absent, this is
963 -- a formal with a default, and the name of the operator is that of the
964 -- formal.
966 procedure Check_Overloaded_Formal_Subprogram (Formal : Entity_Id);
967 -- Apply RM 12.3 (9): if a formal subprogram is overloaded, the instance
968 -- cannot have a named association for it. AI05-0025 extends this rule
969 -- to formals of formal packages by AI05-0025, and it also applies to
970 -- box-initialized formals.
972 function Has_Fully_Defined_Profile (Subp : Entity_Id) return Boolean;
973 -- Determine whether the parameter types and the return type of Subp
974 -- are fully defined at the point of instantiation.
976 function Matching_Actual
977 (F : Entity_Id;
978 A_F : Entity_Id) return Node_Id;
979 -- Find actual that corresponds to a given a formal parameter. If the
980 -- actuals are positional, return the next one, if any. If the actuals
981 -- are named, scan the parameter associations to find the right one.
982 -- A_F is the corresponding entity in the analyzed generic,which is
983 -- placed on the selector name for ASIS use.
985 -- In Ada 2005, a named association may be given with a box, in which
986 -- case Matching_Actual sets Found_Assoc to the generic association,
987 -- but return Empty for the actual itself. In this case the code below
988 -- creates a corresponding declaration for the formal.
990 function Partial_Parameterization return Boolean;
991 -- Ada 2005: if no match is found for a given formal, check if the
992 -- association for it includes a box, or whether the associations
993 -- include an Others clause.
995 procedure Process_Default (F : Entity_Id);
996 -- Add a copy of the declaration of generic formal F to the list of
997 -- associations, and add an explicit box association for F if there
998 -- is none yet, and the default comes from an Others_Choice.
1000 function Renames_Standard_Subprogram (Subp : Entity_Id) return Boolean;
1001 -- Determine whether Subp renames one of the subprograms defined in the
1002 -- generated package Standard.
1004 procedure Set_Analyzed_Formal;
1005 -- Find the node in the generic copy that corresponds to a given formal.
1006 -- The semantic information on this node is used to perform legality
1007 -- checks on the actuals. Because semantic analysis can introduce some
1008 -- anonymous entities or modify the declaration node itself, the
1009 -- correspondence between the two lists is not one-one. In addition to
1010 -- anonymous types, the presence a formal equality will introduce an
1011 -- implicit declaration for the corresponding inequality.
1013 -------------------
1014 -- Build_Wrapper --
1015 -------------------
1017 function Build_Wrapper
1018 (Formal : Entity_Id;
1019 Actual : Entity_Id := Empty) return Node_Id
1021 Loc : constant Source_Ptr := Sloc (I_Node);
1022 Typ : constant Entity_Id := Etype (Formal);
1023 Is_Binary : constant Boolean :=
1024 Present (Next_Formal (First_Formal (Formal)));
1026 Decl : Node_Id;
1027 Expr : Node_Id;
1028 F1, F2 : Entity_Id;
1029 Func : Entity_Id;
1030 Op_Name : Name_Id;
1031 Spec : Node_Id;
1033 L, R : Node_Id;
1035 begin
1036 if No (Actual) then
1037 Op_Name := Chars (Formal);
1038 else
1039 Op_Name := Chars (Actual);
1040 end if;
1042 -- Create entities for wrapper function and its formals
1044 F1 := Make_Temporary (Loc, 'A');
1045 F2 := Make_Temporary (Loc, 'B');
1046 L := New_Occurrence_Of (F1, Loc);
1047 R := New_Occurrence_Of (F2, Loc);
1049 Func := Make_Defining_Identifier (Loc, Chars (Formal));
1050 Set_Ekind (Func, E_Function);
1051 Set_Is_Generic_Actual_Subprogram (Func);
1053 Spec :=
1054 Make_Function_Specification (Loc,
1055 Defining_Unit_Name => Func,
1056 Parameter_Specifications => New_List (
1057 Make_Parameter_Specification (Loc,
1058 Defining_Identifier => F1,
1059 Parameter_Type =>
1060 Make_Identifier (Loc,
1061 Chars => Chars (Etype (First_Formal (Formal)))))),
1062 Result_Definition => Make_Identifier (Loc, Chars (Typ)));
1064 if Is_Binary then
1065 Append_To (Parameter_Specifications (Spec),
1066 Make_Parameter_Specification (Loc,
1067 Defining_Identifier => F2,
1068 Parameter_Type =>
1069 Make_Identifier (Loc,
1070 Chars (Etype (Next_Formal (First_Formal (Formal)))))));
1071 end if;
1073 -- Build expression as a function call, or as an operator node
1074 -- that corresponds to the name of the actual, starting with binary
1075 -- operators.
1077 if Present (Actual) and then Op_Name not in Any_Operator_Name then
1078 Expr :=
1079 Make_Function_Call (Loc,
1080 Name =>
1081 New_Occurrence_Of (Entity (Actual), Loc),
1082 Parameter_Associations => New_List (L));
1084 if Is_Binary then
1085 Append_To (Parameter_Associations (Expr), R);
1086 end if;
1088 -- Binary operators
1090 elsif Is_Binary then
1091 if Op_Name = Name_Op_And then
1092 Expr := Make_Op_And (Loc, Left_Opnd => L, Right_Opnd => R);
1093 elsif Op_Name = Name_Op_Or then
1094 Expr := Make_Op_Or (Loc, Left_Opnd => L, Right_Opnd => R);
1095 elsif Op_Name = Name_Op_Xor then
1096 Expr := Make_Op_Xor (Loc, Left_Opnd => L, Right_Opnd => R);
1097 elsif Op_Name = Name_Op_Eq then
1098 Expr := Make_Op_Eq (Loc, Left_Opnd => L, Right_Opnd => R);
1099 elsif Op_Name = Name_Op_Ne then
1100 Expr := Make_Op_Ne (Loc, Left_Opnd => L, Right_Opnd => R);
1101 elsif Op_Name = Name_Op_Le then
1102 Expr := Make_Op_Le (Loc, Left_Opnd => L, Right_Opnd => R);
1103 elsif Op_Name = Name_Op_Gt then
1104 Expr := Make_Op_Gt (Loc, Left_Opnd => L, Right_Opnd => R);
1105 elsif Op_Name = Name_Op_Ge then
1106 Expr := Make_Op_Ge (Loc, Left_Opnd => L, Right_Opnd => R);
1107 elsif Op_Name = Name_Op_Lt then
1108 Expr := Make_Op_Lt (Loc, Left_Opnd => L, Right_Opnd => R);
1109 elsif Op_Name = Name_Op_Add then
1110 Expr := Make_Op_Add (Loc, Left_Opnd => L, Right_Opnd => R);
1111 elsif Op_Name = Name_Op_Subtract then
1112 Expr := Make_Op_Subtract (Loc, Left_Opnd => L, Right_Opnd => R);
1113 elsif Op_Name = Name_Op_Concat then
1114 Expr := Make_Op_Concat (Loc, Left_Opnd => L, Right_Opnd => R);
1115 elsif Op_Name = Name_Op_Multiply then
1116 Expr := Make_Op_Multiply (Loc, Left_Opnd => L, Right_Opnd => R);
1117 elsif Op_Name = Name_Op_Divide then
1118 Expr := Make_Op_Divide (Loc, Left_Opnd => L, Right_Opnd => R);
1119 elsif Op_Name = Name_Op_Mod then
1120 Expr := Make_Op_Mod (Loc, Left_Opnd => L, Right_Opnd => R);
1121 elsif Op_Name = Name_Op_Rem then
1122 Expr := Make_Op_Rem (Loc, Left_Opnd => L, Right_Opnd => R);
1123 elsif Op_Name = Name_Op_Expon then
1124 Expr := Make_Op_Expon (Loc, Left_Opnd => L, Right_Opnd => R);
1125 end if;
1127 -- Unary operators
1129 else
1130 if Op_Name = Name_Op_Add then
1131 Expr := Make_Op_Plus (Loc, Right_Opnd => L);
1132 elsif Op_Name = Name_Op_Subtract then
1133 Expr := Make_Op_Minus (Loc, Right_Opnd => L);
1134 elsif Op_Name = Name_Op_Abs then
1135 Expr := Make_Op_Abs (Loc, Right_Opnd => L);
1136 elsif Op_Name = Name_Op_Not then
1137 Expr := Make_Op_Not (Loc, Right_Opnd => L);
1138 end if;
1139 end if;
1141 -- Propagate visible entity to operator node, either from a
1142 -- given actual or from a default.
1144 if Is_Entity_Name (Actual) and then Nkind (Expr) in N_Op then
1145 Set_Entity (Expr, Entity (Actual));
1146 end if;
1148 Decl :=
1149 Make_Expression_Function (Loc,
1150 Specification => Spec,
1151 Expression => Expr);
1153 return Decl;
1154 end Build_Wrapper;
1156 ----------------------------------------
1157 -- Check_Overloaded_Formal_Subprogram --
1158 ----------------------------------------
1160 procedure Check_Overloaded_Formal_Subprogram (Formal : Entity_Id) is
1161 Temp_Formal : Entity_Id;
1163 begin
1164 Temp_Formal := First (Formals);
1165 while Present (Temp_Formal) loop
1166 if Nkind (Temp_Formal) in N_Formal_Subprogram_Declaration
1167 and then Temp_Formal /= Formal
1168 and then
1169 Chars (Defining_Unit_Name (Specification (Formal))) =
1170 Chars (Defining_Unit_Name (Specification (Temp_Formal)))
1171 then
1172 if Present (Found_Assoc) then
1173 Error_Msg_N
1174 ("named association not allowed for overloaded formal",
1175 Found_Assoc);
1177 else
1178 Error_Msg_N
1179 ("named association not allowed for overloaded formal",
1180 Others_Choice);
1181 end if;
1183 Abandon_Instantiation (Instantiation_Node);
1184 end if;
1186 Next (Temp_Formal);
1187 end loop;
1188 end Check_Overloaded_Formal_Subprogram;
1190 -------------------------------
1191 -- Has_Fully_Defined_Profile --
1192 -------------------------------
1194 function Has_Fully_Defined_Profile (Subp : Entity_Id) return Boolean is
1195 function Is_Fully_Defined_Type (Typ : Entity_Id) return Boolean;
1196 -- Determine whethet type Typ is fully defined
1198 ---------------------------
1199 -- Is_Fully_Defined_Type --
1200 ---------------------------
1202 function Is_Fully_Defined_Type (Typ : Entity_Id) return Boolean is
1203 begin
1204 -- A private type without a full view is not fully defined
1206 if Is_Private_Type (Typ)
1207 and then No (Full_View (Typ))
1208 then
1209 return False;
1211 -- An incomplete type is never fully defined
1213 elsif Is_Incomplete_Type (Typ) then
1214 return False;
1216 -- All other types are fully defined
1218 else
1219 return True;
1220 end if;
1221 end Is_Fully_Defined_Type;
1223 -- Local declarations
1225 Param : Entity_Id;
1227 -- Start of processing for Has_Fully_Defined_Profile
1229 begin
1230 -- Check the parameters
1232 Param := First_Formal (Subp);
1233 while Present (Param) loop
1234 if not Is_Fully_Defined_Type (Etype (Param)) then
1235 return False;
1236 end if;
1238 Next_Formal (Param);
1239 end loop;
1241 -- Check the return type
1243 return Is_Fully_Defined_Type (Etype (Subp));
1244 end Has_Fully_Defined_Profile;
1246 ---------------------
1247 -- Matching_Actual --
1248 ---------------------
1250 function Matching_Actual
1251 (F : Entity_Id;
1252 A_F : Entity_Id) return Node_Id
1254 Prev : Node_Id;
1255 Act : Node_Id;
1257 begin
1258 Is_Named_Assoc := False;
1260 -- End of list of purely positional parameters
1262 if No (Actual) or else Nkind (Actual) = N_Others_Choice then
1263 Found_Assoc := Empty;
1264 Act := Empty;
1266 -- Case of positional parameter corresponding to current formal
1268 elsif No (Selector_Name (Actual)) then
1269 Found_Assoc := Actual;
1270 Act := Explicit_Generic_Actual_Parameter (Actual);
1271 Num_Matched := Num_Matched + 1;
1272 Next (Actual);
1274 -- Otherwise scan list of named actuals to find the one with the
1275 -- desired name. All remaining actuals have explicit names.
1277 else
1278 Is_Named_Assoc := True;
1279 Found_Assoc := Empty;
1280 Act := Empty;
1281 Prev := Empty;
1283 while Present (Actual) loop
1284 if Chars (Selector_Name (Actual)) = Chars (F) then
1285 Set_Entity (Selector_Name (Actual), A_F);
1286 Set_Etype (Selector_Name (Actual), Etype (A_F));
1287 Generate_Reference (A_F, Selector_Name (Actual));
1288 Found_Assoc := Actual;
1289 Act := Explicit_Generic_Actual_Parameter (Actual);
1290 Num_Matched := Num_Matched + 1;
1291 exit;
1292 end if;
1294 Prev := Actual;
1295 Next (Actual);
1296 end loop;
1298 -- Reset for subsequent searches. In most cases the named
1299 -- associations are in order. If they are not, we reorder them
1300 -- to avoid scanning twice the same actual. This is not just a
1301 -- question of efficiency: there may be multiple defaults with
1302 -- boxes that have the same name. In a nested instantiation we
1303 -- insert actuals for those defaults, and cannot rely on their
1304 -- names to disambiguate them.
1306 if Actual = First_Named then
1307 Next (First_Named);
1309 elsif Present (Actual) then
1310 Insert_Before (First_Named, Remove_Next (Prev));
1311 end if;
1313 Actual := First_Named;
1314 end if;
1316 if Is_Entity_Name (Act) and then Present (Entity (Act)) then
1317 Set_Used_As_Generic_Actual (Entity (Act));
1318 end if;
1320 return Act;
1321 end Matching_Actual;
1323 ------------------------------
1324 -- Partial_Parameterization --
1325 ------------------------------
1327 function Partial_Parameterization return Boolean is
1328 begin
1329 return Others_Present
1330 or else (Present (Found_Assoc) and then Box_Present (Found_Assoc));
1331 end Partial_Parameterization;
1333 ---------------------
1334 -- Process_Default --
1335 ---------------------
1337 procedure Process_Default (F : Entity_Id) is
1338 Loc : constant Source_Ptr := Sloc (I_Node);
1339 F_Id : constant Entity_Id := Defining_Entity (F);
1340 Decl : Node_Id;
1341 Default : Node_Id;
1342 Id : Entity_Id;
1344 begin
1345 -- Append copy of formal declaration to associations, and create new
1346 -- defining identifier for it.
1348 Decl := New_Copy_Tree (F);
1349 Id := Make_Defining_Identifier (Sloc (F_Id), Chars (F_Id));
1351 if Nkind (F) in N_Formal_Subprogram_Declaration then
1352 Set_Defining_Unit_Name (Specification (Decl), Id);
1354 else
1355 Set_Defining_Identifier (Decl, Id);
1356 end if;
1358 Append (Decl, Assoc);
1360 if No (Found_Assoc) then
1361 Default :=
1362 Make_Generic_Association (Loc,
1363 Selector_Name => New_Occurrence_Of (Id, Loc),
1364 Explicit_Generic_Actual_Parameter => Empty);
1365 Set_Box_Present (Default);
1366 Append (Default, Default_Formals);
1367 end if;
1368 end Process_Default;
1370 ---------------------------------
1371 -- Renames_Standard_Subprogram --
1372 ---------------------------------
1374 function Renames_Standard_Subprogram (Subp : Entity_Id) return Boolean is
1375 Id : Entity_Id;
1377 begin
1378 Id := Alias (Subp);
1379 while Present (Id) loop
1380 if Scope (Id) = Standard_Standard then
1381 return True;
1382 end if;
1384 Id := Alias (Id);
1385 end loop;
1387 return False;
1388 end Renames_Standard_Subprogram;
1390 -------------------------
1391 -- Set_Analyzed_Formal --
1392 -------------------------
1394 procedure Set_Analyzed_Formal is
1395 Kind : Node_Kind;
1397 begin
1398 while Present (Analyzed_Formal) loop
1399 Kind := Nkind (Analyzed_Formal);
1401 case Nkind (Formal) is
1403 when N_Formal_Subprogram_Declaration =>
1404 exit when Kind in N_Formal_Subprogram_Declaration
1405 and then
1406 Chars
1407 (Defining_Unit_Name (Specification (Formal))) =
1408 Chars
1409 (Defining_Unit_Name (Specification (Analyzed_Formal)));
1411 when N_Formal_Package_Declaration =>
1412 exit when Nkind_In (Kind, N_Formal_Package_Declaration,
1413 N_Generic_Package_Declaration,
1414 N_Package_Declaration);
1416 when N_Use_Package_Clause | N_Use_Type_Clause => exit;
1418 when others =>
1420 -- Skip freeze nodes, and nodes inserted to replace
1421 -- unrecognized pragmas.
1423 exit when
1424 Kind not in N_Formal_Subprogram_Declaration
1425 and then not Nkind_In (Kind, N_Subprogram_Declaration,
1426 N_Freeze_Entity,
1427 N_Null_Statement,
1428 N_Itype_Reference)
1429 and then Chars (Defining_Identifier (Formal)) =
1430 Chars (Defining_Identifier (Analyzed_Formal));
1431 end case;
1433 Next (Analyzed_Formal);
1434 end loop;
1435 end Set_Analyzed_Formal;
1437 -- Start of processing for Analyze_Associations
1439 begin
1440 Actuals := Generic_Associations (I_Node);
1442 if Present (Actuals) then
1444 -- Check for an Others choice, indicating a partial parameterization
1445 -- for a formal package.
1447 Actual := First (Actuals);
1448 while Present (Actual) loop
1449 if Nkind (Actual) = N_Others_Choice then
1450 Others_Present := True;
1451 Others_Choice := Actual;
1453 if Present (Next (Actual)) then
1454 Error_Msg_N ("others must be last association", Actual);
1455 end if;
1457 -- This subprogram is used both for formal packages and for
1458 -- instantiations. For the latter, associations must all be
1459 -- explicit.
1461 if Nkind (I_Node) /= N_Formal_Package_Declaration
1462 and then Comes_From_Source (I_Node)
1463 then
1464 Error_Msg_N
1465 ("others association not allowed in an instance",
1466 Actual);
1467 end if;
1469 -- In any case, nothing to do after the others association
1471 exit;
1473 elsif Box_Present (Actual)
1474 and then Comes_From_Source (I_Node)
1475 and then Nkind (I_Node) /= N_Formal_Package_Declaration
1476 then
1477 Error_Msg_N
1478 ("box association not allowed in an instance", Actual);
1479 end if;
1481 Next (Actual);
1482 end loop;
1484 -- If named associations are present, save first named association
1485 -- (it may of course be Empty) to facilitate subsequent name search.
1487 First_Named := First (Actuals);
1488 while Present (First_Named)
1489 and then Nkind (First_Named) /= N_Others_Choice
1490 and then No (Selector_Name (First_Named))
1491 loop
1492 Num_Actuals := Num_Actuals + 1;
1493 Next (First_Named);
1494 end loop;
1495 end if;
1497 Named := First_Named;
1498 while Present (Named) loop
1499 if Nkind (Named) /= N_Others_Choice
1500 and then No (Selector_Name (Named))
1501 then
1502 Error_Msg_N ("invalid positional actual after named one", Named);
1503 Abandon_Instantiation (Named);
1504 end if;
1506 -- A named association may lack an actual parameter, if it was
1507 -- introduced for a default subprogram that turns out to be local
1508 -- to the outer instantiation.
1510 if Nkind (Named) /= N_Others_Choice
1511 and then Present (Explicit_Generic_Actual_Parameter (Named))
1512 then
1513 Num_Actuals := Num_Actuals + 1;
1514 end if;
1516 Next (Named);
1517 end loop;
1519 if Present (Formals) then
1520 Formal := First_Non_Pragma (Formals);
1521 Analyzed_Formal := First_Non_Pragma (F_Copy);
1523 if Present (Actuals) then
1524 Actual := First (Actuals);
1526 -- All formals should have default values
1528 else
1529 Actual := Empty;
1530 end if;
1532 while Present (Formal) loop
1533 Set_Analyzed_Formal;
1534 Saved_Formal := Next_Non_Pragma (Formal);
1536 case Nkind (Formal) is
1537 when N_Formal_Object_Declaration =>
1538 Match :=
1539 Matching_Actual (
1540 Defining_Identifier (Formal),
1541 Defining_Identifier (Analyzed_Formal));
1543 if No (Match) and then Partial_Parameterization then
1544 Process_Default (Formal);
1545 else
1546 Append_List
1547 (Instantiate_Object (Formal, Match, Analyzed_Formal),
1548 Assoc);
1549 end if;
1551 when N_Formal_Type_Declaration =>
1552 Match :=
1553 Matching_Actual (
1554 Defining_Identifier (Formal),
1555 Defining_Identifier (Analyzed_Formal));
1557 if No (Match) then
1558 if Partial_Parameterization then
1559 Process_Default (Formal);
1561 else
1562 Error_Msg_Sloc := Sloc (Gen_Unit);
1563 Error_Msg_NE
1564 ("missing actual&",
1565 Instantiation_Node,
1566 Defining_Identifier (Formal));
1567 Error_Msg_NE ("\in instantiation of & declared#",
1568 Instantiation_Node, Gen_Unit);
1569 Abandon_Instantiation (Instantiation_Node);
1570 end if;
1572 else
1573 Analyze (Match);
1574 Append_List
1575 (Instantiate_Type
1576 (Formal, Match, Analyzed_Formal, Assoc),
1577 Assoc);
1579 -- An instantiation is a freeze point for the actuals,
1580 -- unless this is a rewritten formal package, or the
1581 -- formal is an Ada 2012 formal incomplete type.
1583 if Nkind (I_Node) = N_Formal_Package_Declaration
1584 or else
1585 (Ada_Version >= Ada_2012
1586 and then
1587 Ekind (Defining_Identifier (Analyzed_Formal)) =
1588 E_Incomplete_Type)
1589 then
1590 null;
1592 else
1593 Append_Elmt (Entity (Match), Actuals_To_Freeze);
1594 end if;
1595 end if;
1597 -- A remote access-to-class-wide type is not a legal actual
1598 -- for a generic formal of an access type (E.2.2(17/2)).
1599 -- In GNAT an exception to this rule is introduced when
1600 -- the formal is marked as remote using implementation
1601 -- defined aspect/pragma Remote_Access_Type. In that case
1602 -- the actual must be remote as well.
1604 -- If the current instantiation is the construction of a
1605 -- local copy for a formal package the actuals may be
1606 -- defaulted, and there is no matching actual to check.
1608 if Nkind (Analyzed_Formal) = N_Formal_Type_Declaration
1609 and then
1610 Nkind (Formal_Type_Definition (Analyzed_Formal)) =
1611 N_Access_To_Object_Definition
1612 and then Present (Match)
1613 then
1614 declare
1615 Formal_Ent : constant Entity_Id :=
1616 Defining_Identifier (Analyzed_Formal);
1617 begin
1618 if Is_Remote_Access_To_Class_Wide_Type (Entity (Match))
1619 = Is_Remote_Types (Formal_Ent)
1620 then
1621 -- Remoteness of formal and actual match
1623 null;
1625 elsif Is_Remote_Types (Formal_Ent) then
1627 -- Remote formal, non-remote actual
1629 Error_Msg_NE
1630 ("actual for& must be remote", Match, Formal_Ent);
1632 else
1633 -- Non-remote formal, remote actual
1635 Error_Msg_NE
1636 ("actual for& may not be remote",
1637 Match, Formal_Ent);
1638 end if;
1639 end;
1640 end if;
1642 when N_Formal_Subprogram_Declaration =>
1643 Match :=
1644 Matching_Actual
1645 (Defining_Unit_Name (Specification (Formal)),
1646 Defining_Unit_Name (Specification (Analyzed_Formal)));
1648 -- If the formal subprogram has the same name as another
1649 -- formal subprogram of the generic, then a named
1650 -- association is illegal (12.3(9)). Exclude named
1651 -- associations that are generated for a nested instance.
1653 if Present (Match)
1654 and then Is_Named_Assoc
1655 and then Comes_From_Source (Found_Assoc)
1656 then
1657 Check_Overloaded_Formal_Subprogram (Formal);
1658 end if;
1660 -- If there is no corresponding actual, this may be case
1661 -- of partial parameterization, or else the formal has a
1662 -- default or a box.
1664 if No (Match) and then Partial_Parameterization then
1665 Process_Default (Formal);
1667 if Nkind (I_Node) = N_Formal_Package_Declaration then
1668 Check_Overloaded_Formal_Subprogram (Formal);
1669 end if;
1671 else
1672 if GNATprove_Mode
1673 and then
1674 Present
1675 (Get_First_Parent_With_Ext_Axioms_For_Entity
1676 (Defining_Entity (Analyzed_Formal)))
1677 and then Ekind (Defining_Entity (Analyzed_Formal)) =
1678 E_Function
1679 then
1680 -- If actual is an entity (function or operator),
1681 -- build wrapper for it.
1683 if Present (Match) then
1684 if Nkind (Match) = N_Operator_Symbol then
1686 -- If the name is a default, find its visible
1687 -- entity at the point of instantiation.
1689 if Is_Entity_Name (Match)
1690 and then No (Entity (Match))
1691 then
1692 Find_Direct_Name (Match);
1693 end if;
1695 Append_To
1696 (Assoc,
1697 Build_Wrapper
1698 (Defining_Entity (Analyzed_Formal), Match));
1700 else
1701 Append_To (Assoc,
1702 Instantiate_Formal_Subprogram
1703 (Formal, Match, Analyzed_Formal));
1704 end if;
1706 -- Ditto if formal is an operator with a default.
1708 elsif Box_Present (Formal)
1709 and then Nkind (Defining_Entity (Analyzed_Formal)) =
1710 N_Defining_Operator_Symbol
1711 then
1712 Append_To (Assoc,
1713 Build_Wrapper
1714 (Defining_Entity (Analyzed_Formal)));
1716 -- Otherwise create renaming declaration.
1718 else
1719 Append_To (Assoc,
1720 Instantiate_Formal_Subprogram
1721 (Formal, Match, Analyzed_Formal));
1722 end if;
1724 else
1725 Append_To (Assoc,
1726 Instantiate_Formal_Subprogram
1727 (Formal, Match, Analyzed_Formal));
1728 end if;
1730 -- An instantiation is a freeze point for the actuals,
1731 -- unless this is a rewritten formal package.
1733 if Nkind (I_Node) /= N_Formal_Package_Declaration
1734 and then Nkind (Match) = N_Identifier
1735 and then Is_Subprogram (Entity (Match))
1737 -- The actual subprogram may rename a routine defined
1738 -- in Standard. Avoid freezing such renamings because
1739 -- subprograms coming from Standard cannot be frozen.
1741 and then
1742 not Renames_Standard_Subprogram (Entity (Match))
1744 -- If the actual subprogram comes from a different
1745 -- unit, it is already frozen, either by a body in
1746 -- that unit or by the end of the declarative part
1747 -- of the unit. This check avoids the freezing of
1748 -- subprograms defined in Standard which are used
1749 -- as generic actuals.
1751 and then In_Same_Code_Unit (Entity (Match), I_Node)
1752 and then Has_Fully_Defined_Profile (Entity (Match))
1753 then
1754 -- Mark the subprogram as having a delayed freeze
1755 -- since this may be an out-of-order action.
1757 Set_Has_Delayed_Freeze (Entity (Match));
1758 Append_Elmt (Entity (Match), Actuals_To_Freeze);
1759 end if;
1760 end if;
1762 -- If this is a nested generic, preserve default for later
1763 -- instantiations.
1765 if No (Match) and then Box_Present (Formal) then
1766 Append_Elmt
1767 (Defining_Unit_Name (Specification (Last (Assoc))),
1768 Default_Actuals);
1769 end if;
1771 when N_Formal_Package_Declaration =>
1772 Match :=
1773 Matching_Actual (
1774 Defining_Identifier (Formal),
1775 Defining_Identifier (Original_Node (Analyzed_Formal)));
1777 if No (Match) then
1778 if Partial_Parameterization then
1779 Process_Default (Formal);
1781 else
1782 Error_Msg_Sloc := Sloc (Gen_Unit);
1783 Error_Msg_NE
1784 ("missing actual&",
1785 Instantiation_Node, Defining_Identifier (Formal));
1786 Error_Msg_NE ("\in instantiation of & declared#",
1787 Instantiation_Node, Gen_Unit);
1789 Abandon_Instantiation (Instantiation_Node);
1790 end if;
1792 else
1793 Analyze (Match);
1794 Append_List
1795 (Instantiate_Formal_Package
1796 (Formal, Match, Analyzed_Formal),
1797 Assoc);
1798 end if;
1800 -- For use type and use package appearing in the generic part,
1801 -- we have already copied them, so we can just move them where
1802 -- they belong (we mustn't recopy them since this would mess up
1803 -- the Sloc values).
1805 when N_Use_Package_Clause |
1806 N_Use_Type_Clause =>
1807 if Nkind (Original_Node (I_Node)) =
1808 N_Formal_Package_Declaration
1809 then
1810 Append (New_Copy_Tree (Formal), Assoc);
1811 else
1812 Remove (Formal);
1813 Append (Formal, Assoc);
1814 end if;
1816 when others =>
1817 raise Program_Error;
1819 end case;
1821 Formal := Saved_Formal;
1822 Next_Non_Pragma (Analyzed_Formal);
1823 end loop;
1825 if Num_Actuals > Num_Matched then
1826 Error_Msg_Sloc := Sloc (Gen_Unit);
1828 if Present (Selector_Name (Actual)) then
1829 Error_Msg_NE
1830 ("unmatched actual&",
1831 Actual, Selector_Name (Actual));
1832 Error_Msg_NE ("\in instantiation of& declared#",
1833 Actual, Gen_Unit);
1834 else
1835 Error_Msg_NE
1836 ("unmatched actual in instantiation of& declared#",
1837 Actual, Gen_Unit);
1838 end if;
1839 end if;
1841 elsif Present (Actuals) then
1842 Error_Msg_N
1843 ("too many actuals in generic instantiation", Instantiation_Node);
1844 end if;
1846 -- An instantiation freezes all generic actuals. The only exceptions
1847 -- to this are incomplete types and subprograms which are not fully
1848 -- defined at the point of instantiation.
1850 declare
1851 Elmt : Elmt_Id := First_Elmt (Actuals_To_Freeze);
1852 begin
1853 while Present (Elmt) loop
1854 Freeze_Before (I_Node, Node (Elmt));
1855 Next_Elmt (Elmt);
1856 end loop;
1857 end;
1859 -- If there are default subprograms, normalize the tree by adding
1860 -- explicit associations for them. This is required if the instance
1861 -- appears within a generic.
1863 declare
1864 Elmt : Elmt_Id;
1865 Subp : Entity_Id;
1866 New_D : Node_Id;
1868 begin
1869 Elmt := First_Elmt (Default_Actuals);
1870 while Present (Elmt) loop
1871 if No (Actuals) then
1872 Actuals := New_List;
1873 Set_Generic_Associations (I_Node, Actuals);
1874 end if;
1876 Subp := Node (Elmt);
1877 New_D :=
1878 Make_Generic_Association (Sloc (Subp),
1879 Selector_Name => New_Occurrence_Of (Subp, Sloc (Subp)),
1880 Explicit_Generic_Actual_Parameter =>
1881 New_Occurrence_Of (Subp, Sloc (Subp)));
1882 Mark_Rewrite_Insertion (New_D);
1883 Append_To (Actuals, New_D);
1884 Next_Elmt (Elmt);
1885 end loop;
1886 end;
1888 -- If this is a formal package, normalize the parameter list by adding
1889 -- explicit box associations for the formals that are covered by an
1890 -- Others_Choice.
1892 if not Is_Empty_List (Default_Formals) then
1893 Append_List (Default_Formals, Formals);
1894 end if;
1896 return Assoc;
1897 end Analyze_Associations;
1899 -------------------------------
1900 -- Analyze_Formal_Array_Type --
1901 -------------------------------
1903 procedure Analyze_Formal_Array_Type
1904 (T : in out Entity_Id;
1905 Def : Node_Id)
1907 DSS : Node_Id;
1909 begin
1910 -- Treated like a non-generic array declaration, with additional
1911 -- semantic checks.
1913 Enter_Name (T);
1915 if Nkind (Def) = N_Constrained_Array_Definition then
1916 DSS := First (Discrete_Subtype_Definitions (Def));
1917 while Present (DSS) loop
1918 if Nkind_In (DSS, N_Subtype_Indication,
1919 N_Range,
1920 N_Attribute_Reference)
1921 then
1922 Error_Msg_N ("only a subtype mark is allowed in a formal", DSS);
1923 end if;
1925 Next (DSS);
1926 end loop;
1927 end if;
1929 Array_Type_Declaration (T, Def);
1930 Set_Is_Generic_Type (Base_Type (T));
1932 if Ekind (Component_Type (T)) = E_Incomplete_Type
1933 and then No (Full_View (Component_Type (T)))
1934 then
1935 Error_Msg_N ("premature usage of incomplete type", Def);
1937 -- Check that range constraint is not allowed on the component type
1938 -- of a generic formal array type (AARM 12.5.3(3))
1940 elsif Is_Internal (Component_Type (T))
1941 and then Present (Subtype_Indication (Component_Definition (Def)))
1942 and then Nkind (Original_Node
1943 (Subtype_Indication (Component_Definition (Def)))) =
1944 N_Subtype_Indication
1945 then
1946 Error_Msg_N
1947 ("in a formal, a subtype indication can only be "
1948 & "a subtype mark (RM 12.5.3(3))",
1949 Subtype_Indication (Component_Definition (Def)));
1950 end if;
1952 end Analyze_Formal_Array_Type;
1954 ---------------------------------------------
1955 -- Analyze_Formal_Decimal_Fixed_Point_Type --
1956 ---------------------------------------------
1958 -- As for other generic types, we create a valid type representation with
1959 -- legal but arbitrary attributes, whose values are never considered
1960 -- static. For all scalar types we introduce an anonymous base type, with
1961 -- the same attributes. We choose the corresponding integer type to be
1962 -- Standard_Integer.
1963 -- Here and in other similar routines, the Sloc of the generated internal
1964 -- type must be the same as the sloc of the defining identifier of the
1965 -- formal type declaration, to provide proper source navigation.
1967 procedure Analyze_Formal_Decimal_Fixed_Point_Type
1968 (T : Entity_Id;
1969 Def : Node_Id)
1971 Loc : constant Source_Ptr := Sloc (Def);
1973 Base : constant Entity_Id :=
1974 New_Internal_Entity
1975 (E_Decimal_Fixed_Point_Type,
1976 Current_Scope,
1977 Sloc (Defining_Identifier (Parent (Def))), 'G');
1979 Int_Base : constant Entity_Id := Standard_Integer;
1980 Delta_Val : constant Ureal := Ureal_1;
1981 Digs_Val : constant Uint := Uint_6;
1983 function Make_Dummy_Bound return Node_Id;
1984 -- Return a properly typed universal real literal to use as a bound
1986 ----------------------
1987 -- Make_Dummy_Bound --
1988 ----------------------
1990 function Make_Dummy_Bound return Node_Id is
1991 Bound : constant Node_Id := Make_Real_Literal (Loc, Ureal_1);
1992 begin
1993 Set_Etype (Bound, Universal_Real);
1994 return Bound;
1995 end Make_Dummy_Bound;
1997 -- Start of processing for Analyze_Formal_Decimal_Fixed_Point_Type
1999 begin
2000 Enter_Name (T);
2002 Set_Etype (Base, Base);
2003 Set_Size_Info (Base, Int_Base);
2004 Set_RM_Size (Base, RM_Size (Int_Base));
2005 Set_First_Rep_Item (Base, First_Rep_Item (Int_Base));
2006 Set_Digits_Value (Base, Digs_Val);
2007 Set_Delta_Value (Base, Delta_Val);
2008 Set_Small_Value (Base, Delta_Val);
2009 Set_Scalar_Range (Base,
2010 Make_Range (Loc,
2011 Low_Bound => Make_Dummy_Bound,
2012 High_Bound => Make_Dummy_Bound));
2014 Set_Is_Generic_Type (Base);
2015 Set_Parent (Base, Parent (Def));
2017 Set_Ekind (T, E_Decimal_Fixed_Point_Subtype);
2018 Set_Etype (T, Base);
2019 Set_Size_Info (T, Int_Base);
2020 Set_RM_Size (T, RM_Size (Int_Base));
2021 Set_First_Rep_Item (T, First_Rep_Item (Int_Base));
2022 Set_Digits_Value (T, Digs_Val);
2023 Set_Delta_Value (T, Delta_Val);
2024 Set_Small_Value (T, Delta_Val);
2025 Set_Scalar_Range (T, Scalar_Range (Base));
2026 Set_Is_Constrained (T);
2028 Check_Restriction (No_Fixed_Point, Def);
2029 end Analyze_Formal_Decimal_Fixed_Point_Type;
2031 -------------------------------------------
2032 -- Analyze_Formal_Derived_Interface_Type --
2033 -------------------------------------------
2035 procedure Analyze_Formal_Derived_Interface_Type
2036 (N : Node_Id;
2037 T : Entity_Id;
2038 Def : Node_Id)
2040 Loc : constant Source_Ptr := Sloc (Def);
2042 begin
2043 -- Rewrite as a type declaration of a derived type. This ensures that
2044 -- the interface list and primitive operations are properly captured.
2046 Rewrite (N,
2047 Make_Full_Type_Declaration (Loc,
2048 Defining_Identifier => T,
2049 Type_Definition => Def));
2050 Analyze (N);
2051 Set_Is_Generic_Type (T);
2052 end Analyze_Formal_Derived_Interface_Type;
2054 ---------------------------------
2055 -- Analyze_Formal_Derived_Type --
2056 ---------------------------------
2058 procedure Analyze_Formal_Derived_Type
2059 (N : Node_Id;
2060 T : Entity_Id;
2061 Def : Node_Id)
2063 Loc : constant Source_Ptr := Sloc (Def);
2064 Unk_Disc : constant Boolean := Unknown_Discriminants_Present (N);
2065 New_N : Node_Id;
2067 begin
2068 Set_Is_Generic_Type (T);
2070 if Private_Present (Def) then
2071 New_N :=
2072 Make_Private_Extension_Declaration (Loc,
2073 Defining_Identifier => T,
2074 Discriminant_Specifications => Discriminant_Specifications (N),
2075 Unknown_Discriminants_Present => Unk_Disc,
2076 Subtype_Indication => Subtype_Mark (Def),
2077 Interface_List => Interface_List (Def));
2079 Set_Abstract_Present (New_N, Abstract_Present (Def));
2080 Set_Limited_Present (New_N, Limited_Present (Def));
2081 Set_Synchronized_Present (New_N, Synchronized_Present (Def));
2083 else
2084 New_N :=
2085 Make_Full_Type_Declaration (Loc,
2086 Defining_Identifier => T,
2087 Discriminant_Specifications =>
2088 Discriminant_Specifications (Parent (T)),
2089 Type_Definition =>
2090 Make_Derived_Type_Definition (Loc,
2091 Subtype_Indication => Subtype_Mark (Def)));
2093 Set_Abstract_Present
2094 (Type_Definition (New_N), Abstract_Present (Def));
2095 Set_Limited_Present
2096 (Type_Definition (New_N), Limited_Present (Def));
2097 end if;
2099 Rewrite (N, New_N);
2100 Analyze (N);
2102 if Unk_Disc then
2103 if not Is_Composite_Type (T) then
2104 Error_Msg_N
2105 ("unknown discriminants not allowed for elementary types", N);
2106 else
2107 Set_Has_Unknown_Discriminants (T);
2108 Set_Is_Constrained (T, False);
2109 end if;
2110 end if;
2112 -- If the parent type has a known size, so does the formal, which makes
2113 -- legal representation clauses that involve the formal.
2115 Set_Size_Known_At_Compile_Time
2116 (T, Size_Known_At_Compile_Time (Entity (Subtype_Mark (Def))));
2117 end Analyze_Formal_Derived_Type;
2119 ----------------------------------
2120 -- Analyze_Formal_Discrete_Type --
2121 ----------------------------------
2123 -- The operations defined for a discrete types are those of an enumeration
2124 -- type. The size is set to an arbitrary value, for use in analyzing the
2125 -- generic unit.
2127 procedure Analyze_Formal_Discrete_Type (T : Entity_Id; Def : Node_Id) is
2128 Loc : constant Source_Ptr := Sloc (Def);
2129 Lo : Node_Id;
2130 Hi : Node_Id;
2132 Base : constant Entity_Id :=
2133 New_Internal_Entity
2134 (E_Floating_Point_Type, Current_Scope,
2135 Sloc (Defining_Identifier (Parent (Def))), 'G');
2137 begin
2138 Enter_Name (T);
2139 Set_Ekind (T, E_Enumeration_Subtype);
2140 Set_Etype (T, Base);
2141 Init_Size (T, 8);
2142 Init_Alignment (T);
2143 Set_Is_Generic_Type (T);
2144 Set_Is_Constrained (T);
2146 -- For semantic analysis, the bounds of the type must be set to some
2147 -- non-static value. The simplest is to create attribute nodes for those
2148 -- bounds, that refer to the type itself. These bounds are never
2149 -- analyzed but serve as place-holders.
2151 Lo :=
2152 Make_Attribute_Reference (Loc,
2153 Attribute_Name => Name_First,
2154 Prefix => New_Occurrence_Of (T, Loc));
2155 Set_Etype (Lo, T);
2157 Hi :=
2158 Make_Attribute_Reference (Loc,
2159 Attribute_Name => Name_Last,
2160 Prefix => New_Occurrence_Of (T, Loc));
2161 Set_Etype (Hi, T);
2163 Set_Scalar_Range (T,
2164 Make_Range (Loc,
2165 Low_Bound => Lo,
2166 High_Bound => Hi));
2168 Set_Ekind (Base, E_Enumeration_Type);
2169 Set_Etype (Base, Base);
2170 Init_Size (Base, 8);
2171 Init_Alignment (Base);
2172 Set_Is_Generic_Type (Base);
2173 Set_Scalar_Range (Base, Scalar_Range (T));
2174 Set_Parent (Base, Parent (Def));
2175 end Analyze_Formal_Discrete_Type;
2177 ----------------------------------
2178 -- Analyze_Formal_Floating_Type --
2179 ---------------------------------
2181 procedure Analyze_Formal_Floating_Type (T : Entity_Id; Def : Node_Id) is
2182 Base : constant Entity_Id :=
2183 New_Internal_Entity
2184 (E_Floating_Point_Type, Current_Scope,
2185 Sloc (Defining_Identifier (Parent (Def))), 'G');
2187 begin
2188 -- The various semantic attributes are taken from the predefined type
2189 -- Float, just so that all of them are initialized. Their values are
2190 -- never used because no constant folding or expansion takes place in
2191 -- the generic itself.
2193 Enter_Name (T);
2194 Set_Ekind (T, E_Floating_Point_Subtype);
2195 Set_Etype (T, Base);
2196 Set_Size_Info (T, (Standard_Float));
2197 Set_RM_Size (T, RM_Size (Standard_Float));
2198 Set_Digits_Value (T, Digits_Value (Standard_Float));
2199 Set_Scalar_Range (T, Scalar_Range (Standard_Float));
2200 Set_Is_Constrained (T);
2202 Set_Is_Generic_Type (Base);
2203 Set_Etype (Base, Base);
2204 Set_Size_Info (Base, (Standard_Float));
2205 Set_RM_Size (Base, RM_Size (Standard_Float));
2206 Set_Digits_Value (Base, Digits_Value (Standard_Float));
2207 Set_Scalar_Range (Base, Scalar_Range (Standard_Float));
2208 Set_Parent (Base, Parent (Def));
2210 Check_Restriction (No_Floating_Point, Def);
2211 end Analyze_Formal_Floating_Type;
2213 -----------------------------------
2214 -- Analyze_Formal_Interface_Type;--
2215 -----------------------------------
2217 procedure Analyze_Formal_Interface_Type
2218 (N : Node_Id;
2219 T : Entity_Id;
2220 Def : Node_Id)
2222 Loc : constant Source_Ptr := Sloc (N);
2223 New_N : Node_Id;
2225 begin
2226 New_N :=
2227 Make_Full_Type_Declaration (Loc,
2228 Defining_Identifier => T,
2229 Type_Definition => Def);
2231 Rewrite (N, New_N);
2232 Analyze (N);
2233 Set_Is_Generic_Type (T);
2234 end Analyze_Formal_Interface_Type;
2236 ---------------------------------
2237 -- Analyze_Formal_Modular_Type --
2238 ---------------------------------
2240 procedure Analyze_Formal_Modular_Type (T : Entity_Id; Def : Node_Id) is
2241 begin
2242 -- Apart from their entity kind, generic modular types are treated like
2243 -- signed integer types, and have the same attributes.
2245 Analyze_Formal_Signed_Integer_Type (T, Def);
2246 Set_Ekind (T, E_Modular_Integer_Subtype);
2247 Set_Ekind (Etype (T), E_Modular_Integer_Type);
2249 end Analyze_Formal_Modular_Type;
2251 ---------------------------------------
2252 -- Analyze_Formal_Object_Declaration --
2253 ---------------------------------------
2255 procedure Analyze_Formal_Object_Declaration (N : Node_Id) is
2256 E : constant Node_Id := Default_Expression (N);
2257 Id : constant Node_Id := Defining_Identifier (N);
2258 K : Entity_Kind;
2259 T : Node_Id;
2261 begin
2262 Enter_Name (Id);
2264 -- Determine the mode of the formal object
2266 if Out_Present (N) then
2267 K := E_Generic_In_Out_Parameter;
2269 if not In_Present (N) then
2270 Error_Msg_N ("formal generic objects cannot have mode OUT", N);
2271 end if;
2273 else
2274 K := E_Generic_In_Parameter;
2275 end if;
2277 if Present (Subtype_Mark (N)) then
2278 Find_Type (Subtype_Mark (N));
2279 T := Entity (Subtype_Mark (N));
2281 -- Verify that there is no redundant null exclusion
2283 if Null_Exclusion_Present (N) then
2284 if not Is_Access_Type (T) then
2285 Error_Msg_N
2286 ("null exclusion can only apply to an access type", N);
2288 elsif Can_Never_Be_Null (T) then
2289 Error_Msg_NE
2290 ("`NOT NULL` not allowed (& already excludes null)",
2291 N, T);
2292 end if;
2293 end if;
2295 -- Ada 2005 (AI-423): Formal object with an access definition
2297 else
2298 Check_Access_Definition (N);
2299 T := Access_Definition
2300 (Related_Nod => N,
2301 N => Access_Definition (N));
2302 end if;
2304 if Ekind (T) = E_Incomplete_Type then
2305 declare
2306 Error_Node : Node_Id;
2308 begin
2309 if Present (Subtype_Mark (N)) then
2310 Error_Node := Subtype_Mark (N);
2311 else
2312 Check_Access_Definition (N);
2313 Error_Node := Access_Definition (N);
2314 end if;
2316 Error_Msg_N ("premature usage of incomplete type", Error_Node);
2317 end;
2318 end if;
2320 if K = E_Generic_In_Parameter then
2322 -- Ada 2005 (AI-287): Limited aggregates allowed in generic formals
2324 if Ada_Version < Ada_2005 and then Is_Limited_Type (T) then
2325 Error_Msg_N
2326 ("generic formal of mode IN must not be of limited type", N);
2327 Explain_Limited_Type (T, N);
2328 end if;
2330 if Is_Abstract_Type (T) then
2331 Error_Msg_N
2332 ("generic formal of mode IN must not be of abstract type", N);
2333 end if;
2335 if Present (E) then
2336 Preanalyze_Spec_Expression (E, T);
2338 if Is_Limited_Type (T) and then not OK_For_Limited_Init (T, E) then
2339 Error_Msg_N
2340 ("initialization not allowed for limited types", E);
2341 Explain_Limited_Type (T, E);
2342 end if;
2343 end if;
2345 Set_Ekind (Id, K);
2346 Set_Etype (Id, T);
2348 -- Case of generic IN OUT parameter
2350 else
2351 -- If the formal has an unconstrained type, construct its actual
2352 -- subtype, as is done for subprogram formals. In this fashion, all
2353 -- its uses can refer to specific bounds.
2355 Set_Ekind (Id, K);
2356 Set_Etype (Id, T);
2358 if (Is_Array_Type (T)
2359 and then not Is_Constrained (T))
2360 or else
2361 (Ekind (T) = E_Record_Type
2362 and then Has_Discriminants (T))
2363 then
2364 declare
2365 Non_Freezing_Ref : constant Node_Id :=
2366 New_Occurrence_Of (Id, Sloc (Id));
2367 Decl : Node_Id;
2369 begin
2370 -- Make sure the actual subtype doesn't generate bogus freezing
2372 Set_Must_Not_Freeze (Non_Freezing_Ref);
2373 Decl := Build_Actual_Subtype (T, Non_Freezing_Ref);
2374 Insert_Before_And_Analyze (N, Decl);
2375 Set_Actual_Subtype (Id, Defining_Identifier (Decl));
2376 end;
2377 else
2378 Set_Actual_Subtype (Id, T);
2379 end if;
2381 if Present (E) then
2382 Error_Msg_N
2383 ("initialization not allowed for `IN OUT` formals", N);
2384 end if;
2385 end if;
2387 if Has_Aspects (N) then
2388 Analyze_Aspect_Specifications (N, Id);
2389 end if;
2390 end Analyze_Formal_Object_Declaration;
2392 ----------------------------------------------
2393 -- Analyze_Formal_Ordinary_Fixed_Point_Type --
2394 ----------------------------------------------
2396 procedure Analyze_Formal_Ordinary_Fixed_Point_Type
2397 (T : Entity_Id;
2398 Def : Node_Id)
2400 Loc : constant Source_Ptr := Sloc (Def);
2401 Base : constant Entity_Id :=
2402 New_Internal_Entity
2403 (E_Ordinary_Fixed_Point_Type, Current_Scope,
2404 Sloc (Defining_Identifier (Parent (Def))), 'G');
2406 begin
2407 -- The semantic attributes are set for completeness only, their values
2408 -- will never be used, since all properties of the type are non-static.
2410 Enter_Name (T);
2411 Set_Ekind (T, E_Ordinary_Fixed_Point_Subtype);
2412 Set_Etype (T, Base);
2413 Set_Size_Info (T, Standard_Integer);
2414 Set_RM_Size (T, RM_Size (Standard_Integer));
2415 Set_Small_Value (T, Ureal_1);
2416 Set_Delta_Value (T, Ureal_1);
2417 Set_Scalar_Range (T,
2418 Make_Range (Loc,
2419 Low_Bound => Make_Real_Literal (Loc, Ureal_1),
2420 High_Bound => Make_Real_Literal (Loc, Ureal_1)));
2421 Set_Is_Constrained (T);
2423 Set_Is_Generic_Type (Base);
2424 Set_Etype (Base, Base);
2425 Set_Size_Info (Base, Standard_Integer);
2426 Set_RM_Size (Base, RM_Size (Standard_Integer));
2427 Set_Small_Value (Base, Ureal_1);
2428 Set_Delta_Value (Base, Ureal_1);
2429 Set_Scalar_Range (Base, Scalar_Range (T));
2430 Set_Parent (Base, Parent (Def));
2432 Check_Restriction (No_Fixed_Point, Def);
2433 end Analyze_Formal_Ordinary_Fixed_Point_Type;
2435 ----------------------------------------
2436 -- Analyze_Formal_Package_Declaration --
2437 ----------------------------------------
2439 procedure Analyze_Formal_Package_Declaration (N : Node_Id) is
2440 Loc : constant Source_Ptr := Sloc (N);
2441 Pack_Id : constant Entity_Id := Defining_Identifier (N);
2442 Formal : Entity_Id;
2443 Gen_Id : constant Node_Id := Name (N);
2444 Gen_Decl : Node_Id;
2445 Gen_Unit : Entity_Id;
2446 New_N : Node_Id;
2447 Parent_Installed : Boolean := False;
2448 Renaming : Node_Id;
2449 Parent_Instance : Entity_Id;
2450 Renaming_In_Par : Entity_Id;
2451 Associations : Boolean := True;
2453 Vis_Prims_List : Elist_Id := No_Elist;
2454 -- List of primitives made temporarily visible in the instantiation
2455 -- to match the visibility of the formal type
2457 function Build_Local_Package return Node_Id;
2458 -- The formal package is rewritten so that its parameters are replaced
2459 -- with corresponding declarations. For parameters with bona fide
2460 -- associations these declarations are created by Analyze_Associations
2461 -- as for a regular instantiation. For boxed parameters, we preserve
2462 -- the formal declarations and analyze them, in order to introduce
2463 -- entities of the right kind in the environment of the formal.
2465 -------------------------
2466 -- Build_Local_Package --
2467 -------------------------
2469 function Build_Local_Package return Node_Id is
2470 Decls : List_Id;
2471 Pack_Decl : Node_Id;
2473 begin
2474 -- Within the formal, the name of the generic package is a renaming
2475 -- of the formal (as for a regular instantiation).
2477 Pack_Decl :=
2478 Make_Package_Declaration (Loc,
2479 Specification =>
2480 Copy_Generic_Node
2481 (Specification (Original_Node (Gen_Decl)),
2482 Empty, Instantiating => True));
2484 Renaming := Make_Package_Renaming_Declaration (Loc,
2485 Defining_Unit_Name =>
2486 Make_Defining_Identifier (Loc, Chars (Gen_Unit)),
2487 Name => New_Occurrence_Of (Formal, Loc));
2489 if Nkind (Gen_Id) = N_Identifier
2490 and then Chars (Gen_Id) = Chars (Pack_Id)
2491 then
2492 Error_Msg_NE
2493 ("& is hidden within declaration of instance", Gen_Id, Gen_Unit);
2494 end if;
2496 -- If the formal is declared with a box, or with an others choice,
2497 -- create corresponding declarations for all entities in the formal
2498 -- part, so that names with the proper types are available in the
2499 -- specification of the formal package.
2501 -- On the other hand, if there are no associations, then all the
2502 -- formals must have defaults, and this will be checked by the
2503 -- call to Analyze_Associations.
2505 if Box_Present (N)
2506 or else Nkind (First (Generic_Associations (N))) = N_Others_Choice
2507 then
2508 declare
2509 Formal_Decl : Node_Id;
2511 begin
2512 -- TBA : for a formal package, need to recurse ???
2514 Decls := New_List;
2515 Formal_Decl :=
2516 First
2517 (Generic_Formal_Declarations (Original_Node (Gen_Decl)));
2518 while Present (Formal_Decl) loop
2519 Append_To
2520 (Decls, Copy_Generic_Node (Formal_Decl, Empty, True));
2521 Next (Formal_Decl);
2522 end loop;
2523 end;
2525 -- If generic associations are present, use Analyze_Associations to
2526 -- create the proper renaming declarations.
2528 else
2529 declare
2530 Act_Tree : constant Node_Id :=
2531 Copy_Generic_Node
2532 (Original_Node (Gen_Decl), Empty,
2533 Instantiating => True);
2535 begin
2536 Generic_Renamings.Set_Last (0);
2537 Generic_Renamings_HTable.Reset;
2538 Instantiation_Node := N;
2540 Decls :=
2541 Analyze_Associations
2542 (I_Node => Original_Node (N),
2543 Formals => Generic_Formal_Declarations (Act_Tree),
2544 F_Copy => Generic_Formal_Declarations (Gen_Decl));
2546 Vis_Prims_List := Check_Hidden_Primitives (Decls);
2547 end;
2548 end if;
2550 Append (Renaming, To => Decls);
2552 -- Add generated declarations ahead of local declarations in
2553 -- the package.
2555 if No (Visible_Declarations (Specification (Pack_Decl))) then
2556 Set_Visible_Declarations (Specification (Pack_Decl), Decls);
2557 else
2558 Insert_List_Before
2559 (First (Visible_Declarations (Specification (Pack_Decl))),
2560 Decls);
2561 end if;
2563 return Pack_Decl;
2564 end Build_Local_Package;
2566 -- Start of processing for Analyze_Formal_Package_Declaration
2568 begin
2569 Check_Text_IO_Special_Unit (Gen_Id);
2571 Init_Env;
2572 Check_Generic_Child_Unit (Gen_Id, Parent_Installed);
2573 Gen_Unit := Entity (Gen_Id);
2575 -- Check for a formal package that is a package renaming
2577 if Present (Renamed_Object (Gen_Unit)) then
2579 -- Indicate that unit is used, before replacing it with renamed
2580 -- entity for use below.
2582 if In_Extended_Main_Source_Unit (N) then
2583 Set_Is_Instantiated (Gen_Unit);
2584 Generate_Reference (Gen_Unit, N);
2585 end if;
2587 Gen_Unit := Renamed_Object (Gen_Unit);
2588 end if;
2590 if Ekind (Gen_Unit) /= E_Generic_Package then
2591 Error_Msg_N ("expect generic package name", Gen_Id);
2592 Restore_Env;
2593 goto Leave;
2595 elsif Gen_Unit = Current_Scope then
2596 Error_Msg_N
2597 ("generic package cannot be used as a formal package of itself",
2598 Gen_Id);
2599 Restore_Env;
2600 goto Leave;
2602 elsif In_Open_Scopes (Gen_Unit) then
2603 if Is_Compilation_Unit (Gen_Unit)
2604 and then Is_Child_Unit (Current_Scope)
2605 then
2606 -- Special-case the error when the formal is a parent, and
2607 -- continue analysis to minimize cascaded errors.
2609 Error_Msg_N
2610 ("generic parent cannot be used as formal package "
2611 & "of a child unit",
2612 Gen_Id);
2614 else
2615 Error_Msg_N
2616 ("generic package cannot be used as a formal package "
2617 & "within itself",
2618 Gen_Id);
2619 Restore_Env;
2620 goto Leave;
2621 end if;
2622 end if;
2624 -- Check that name of formal package does not hide name of generic,
2625 -- or its leading prefix. This check must be done separately because
2626 -- the name of the generic has already been analyzed.
2628 declare
2629 Gen_Name : Entity_Id;
2631 begin
2632 Gen_Name := Gen_Id;
2633 while Nkind (Gen_Name) = N_Expanded_Name loop
2634 Gen_Name := Prefix (Gen_Name);
2635 end loop;
2637 if Chars (Gen_Name) = Chars (Pack_Id) then
2638 Error_Msg_NE
2639 ("& is hidden within declaration of formal package",
2640 Gen_Id, Gen_Name);
2641 end if;
2642 end;
2644 if Box_Present (N)
2645 or else No (Generic_Associations (N))
2646 or else Nkind (First (Generic_Associations (N))) = N_Others_Choice
2647 then
2648 Associations := False;
2649 end if;
2651 -- If there are no generic associations, the generic parameters appear
2652 -- as local entities and are instantiated like them. We copy the generic
2653 -- package declaration as if it were an instantiation, and analyze it
2654 -- like a regular package, except that we treat the formals as
2655 -- additional visible components.
2657 Gen_Decl := Unit_Declaration_Node (Gen_Unit);
2659 if In_Extended_Main_Source_Unit (N) then
2660 Set_Is_Instantiated (Gen_Unit);
2661 Generate_Reference (Gen_Unit, N);
2662 end if;
2664 Formal := New_Copy (Pack_Id);
2665 Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment);
2667 begin
2668 -- Make local generic without formals. The formals will be replaced
2669 -- with internal declarations.
2671 New_N := Build_Local_Package;
2673 -- If there are errors in the parameter list, Analyze_Associations
2674 -- raises Instantiation_Error. Patch the declaration to prevent
2675 -- further exception propagation.
2677 exception
2678 when Instantiation_Error =>
2680 Enter_Name (Formal);
2681 Set_Ekind (Formal, E_Variable);
2682 Set_Etype (Formal, Any_Type);
2683 Restore_Hidden_Primitives (Vis_Prims_List);
2685 if Parent_Installed then
2686 Remove_Parent;
2687 end if;
2689 goto Leave;
2690 end;
2692 Rewrite (N, New_N);
2693 Set_Defining_Unit_Name (Specification (New_N), Formal);
2694 Set_Generic_Parent (Specification (N), Gen_Unit);
2695 Set_Instance_Env (Gen_Unit, Formal);
2696 Set_Is_Generic_Instance (Formal);
2698 Enter_Name (Formal);
2699 Set_Ekind (Formal, E_Package);
2700 Set_Etype (Formal, Standard_Void_Type);
2701 Set_Inner_Instances (Formal, New_Elmt_List);
2702 Push_Scope (Formal);
2704 if Is_Child_Unit (Gen_Unit)
2705 and then Parent_Installed
2706 then
2707 -- Similarly, we have to make the name of the formal visible in the
2708 -- parent instance, to resolve properly fully qualified names that
2709 -- may appear in the generic unit. The parent instance has been
2710 -- placed on the scope stack ahead of the current scope.
2712 Parent_Instance := Scope_Stack.Table (Scope_Stack.Last - 1).Entity;
2714 Renaming_In_Par :=
2715 Make_Defining_Identifier (Loc, Chars (Gen_Unit));
2716 Set_Ekind (Renaming_In_Par, E_Package);
2717 Set_Etype (Renaming_In_Par, Standard_Void_Type);
2718 Set_Scope (Renaming_In_Par, Parent_Instance);
2719 Set_Parent (Renaming_In_Par, Parent (Formal));
2720 Set_Renamed_Object (Renaming_In_Par, Formal);
2721 Append_Entity (Renaming_In_Par, Parent_Instance);
2722 end if;
2724 Analyze (Specification (N));
2726 -- The formals for which associations are provided are not visible
2727 -- outside of the formal package. The others are still declared by a
2728 -- formal parameter declaration.
2730 -- If there are no associations, the only local entity to hide is the
2731 -- generated package renaming itself.
2733 declare
2734 E : Entity_Id;
2736 begin
2737 E := First_Entity (Formal);
2738 while Present (E) loop
2739 if Associations
2740 and then not Is_Generic_Formal (E)
2741 then
2742 Set_Is_Hidden (E);
2743 end if;
2745 if Ekind (E) = E_Package
2746 and then Renamed_Entity (E) = Formal
2747 then
2748 Set_Is_Hidden (E);
2749 exit;
2750 end if;
2752 Next_Entity (E);
2753 end loop;
2754 end;
2756 End_Package_Scope (Formal);
2757 Restore_Hidden_Primitives (Vis_Prims_List);
2759 if Parent_Installed then
2760 Remove_Parent;
2761 end if;
2763 Restore_Env;
2765 -- Inside the generic unit, the formal package is a regular package, but
2766 -- no body is needed for it. Note that after instantiation, the defining
2767 -- unit name we need is in the new tree and not in the original (see
2768 -- Package_Instantiation). A generic formal package is an instance, and
2769 -- can be used as an actual for an inner instance.
2771 Set_Has_Completion (Formal, True);
2773 -- Add semantic information to the original defining identifier.
2774 -- for ASIS use.
2776 Set_Ekind (Pack_Id, E_Package);
2777 Set_Etype (Pack_Id, Standard_Void_Type);
2778 Set_Scope (Pack_Id, Scope (Formal));
2779 Set_Has_Completion (Pack_Id, True);
2781 <<Leave>>
2782 if Has_Aspects (N) then
2783 Analyze_Aspect_Specifications (N, Pack_Id);
2784 end if;
2785 end Analyze_Formal_Package_Declaration;
2787 ---------------------------------
2788 -- Analyze_Formal_Private_Type --
2789 ---------------------------------
2791 procedure Analyze_Formal_Private_Type
2792 (N : Node_Id;
2793 T : Entity_Id;
2794 Def : Node_Id)
2796 begin
2797 New_Private_Type (N, T, Def);
2799 -- Set the size to an arbitrary but legal value
2801 Set_Size_Info (T, Standard_Integer);
2802 Set_RM_Size (T, RM_Size (Standard_Integer));
2803 end Analyze_Formal_Private_Type;
2805 ------------------------------------
2806 -- Analyze_Formal_Incomplete_Type --
2807 ------------------------------------
2809 procedure Analyze_Formal_Incomplete_Type
2810 (T : Entity_Id;
2811 Def : Node_Id)
2813 begin
2814 Enter_Name (T);
2815 Set_Ekind (T, E_Incomplete_Type);
2816 Set_Etype (T, T);
2817 Set_Private_Dependents (T, New_Elmt_List);
2819 if Tagged_Present (Def) then
2820 Set_Is_Tagged_Type (T);
2821 Make_Class_Wide_Type (T);
2822 Set_Direct_Primitive_Operations (T, New_Elmt_List);
2823 end if;
2824 end Analyze_Formal_Incomplete_Type;
2826 ----------------------------------------
2827 -- Analyze_Formal_Signed_Integer_Type --
2828 ----------------------------------------
2830 procedure Analyze_Formal_Signed_Integer_Type
2831 (T : Entity_Id;
2832 Def : Node_Id)
2834 Base : constant Entity_Id :=
2835 New_Internal_Entity
2836 (E_Signed_Integer_Type,
2837 Current_Scope,
2838 Sloc (Defining_Identifier (Parent (Def))), 'G');
2840 begin
2841 Enter_Name (T);
2843 Set_Ekind (T, E_Signed_Integer_Subtype);
2844 Set_Etype (T, Base);
2845 Set_Size_Info (T, Standard_Integer);
2846 Set_RM_Size (T, RM_Size (Standard_Integer));
2847 Set_Scalar_Range (T, Scalar_Range (Standard_Integer));
2848 Set_Is_Constrained (T);
2850 Set_Is_Generic_Type (Base);
2851 Set_Size_Info (Base, Standard_Integer);
2852 Set_RM_Size (Base, RM_Size (Standard_Integer));
2853 Set_Etype (Base, Base);
2854 Set_Scalar_Range (Base, Scalar_Range (Standard_Integer));
2855 Set_Parent (Base, Parent (Def));
2856 end Analyze_Formal_Signed_Integer_Type;
2858 -------------------------------------------
2859 -- Analyze_Formal_Subprogram_Declaration --
2860 -------------------------------------------
2862 procedure Analyze_Formal_Subprogram_Declaration (N : Node_Id) is
2863 Spec : constant Node_Id := Specification (N);
2864 Def : constant Node_Id := Default_Name (N);
2865 Nam : constant Entity_Id := Defining_Unit_Name (Spec);
2866 Subp : Entity_Id;
2868 begin
2869 if Nam = Error then
2870 return;
2871 end if;
2873 if Nkind (Nam) = N_Defining_Program_Unit_Name then
2874 Error_Msg_N ("name of formal subprogram must be a direct name", Nam);
2875 goto Leave;
2876 end if;
2878 Analyze_Subprogram_Declaration (N);
2879 Set_Is_Formal_Subprogram (Nam);
2880 Set_Has_Completion (Nam);
2882 if Nkind (N) = N_Formal_Abstract_Subprogram_Declaration then
2883 Set_Is_Abstract_Subprogram (Nam);
2884 Set_Is_Dispatching_Operation (Nam);
2886 declare
2887 Ctrl_Type : constant Entity_Id := Find_Dispatching_Type (Nam);
2888 begin
2889 if No (Ctrl_Type) then
2890 Error_Msg_N
2891 ("abstract formal subprogram must have a controlling type",
2894 elsif Ada_Version >= Ada_2012
2895 and then Is_Incomplete_Type (Ctrl_Type)
2896 then
2897 Error_Msg_NE
2898 ("controlling type of abstract formal subprogram cannot " &
2899 "be incomplete type", N, Ctrl_Type);
2901 else
2902 Check_Controlling_Formals (Ctrl_Type, Nam);
2903 end if;
2904 end;
2905 end if;
2907 -- Default name is resolved at the point of instantiation
2909 if Box_Present (N) then
2910 null;
2912 -- Else default is bound at the point of generic declaration
2914 elsif Present (Def) then
2915 if Nkind (Def) = N_Operator_Symbol then
2916 Find_Direct_Name (Def);
2918 elsif Nkind (Def) /= N_Attribute_Reference then
2919 Analyze (Def);
2921 else
2922 -- For an attribute reference, analyze the prefix and verify
2923 -- that it has the proper profile for the subprogram.
2925 Analyze (Prefix (Def));
2926 Valid_Default_Attribute (Nam, Def);
2927 goto Leave;
2928 end if;
2930 -- Default name may be overloaded, in which case the interpretation
2931 -- with the correct profile must be selected, as for a renaming.
2932 -- If the definition is an indexed component, it must denote a
2933 -- member of an entry family. If it is a selected component, it
2934 -- can be a protected operation.
2936 if Etype (Def) = Any_Type then
2937 goto Leave;
2939 elsif Nkind (Def) = N_Selected_Component then
2940 if not Is_Overloadable (Entity (Selector_Name (Def))) then
2941 Error_Msg_N ("expect valid subprogram name as default", Def);
2942 end if;
2944 elsif Nkind (Def) = N_Indexed_Component then
2945 if Is_Entity_Name (Prefix (Def)) then
2946 if Ekind (Entity (Prefix (Def))) /= E_Entry_Family then
2947 Error_Msg_N ("expect valid subprogram name as default", Def);
2948 end if;
2950 elsif Nkind (Prefix (Def)) = N_Selected_Component then
2951 if Ekind (Entity (Selector_Name (Prefix (Def)))) /=
2952 E_Entry_Family
2953 then
2954 Error_Msg_N ("expect valid subprogram name as default", Def);
2955 end if;
2957 else
2958 Error_Msg_N ("expect valid subprogram name as default", Def);
2959 goto Leave;
2960 end if;
2962 elsif Nkind (Def) = N_Character_Literal then
2964 -- Needs some type checks: subprogram should be parameterless???
2966 Resolve (Def, (Etype (Nam)));
2968 elsif not Is_Entity_Name (Def)
2969 or else not Is_Overloadable (Entity (Def))
2970 then
2971 Error_Msg_N ("expect valid subprogram name as default", Def);
2972 goto Leave;
2974 elsif not Is_Overloaded (Def) then
2975 Subp := Entity (Def);
2977 if Subp = Nam then
2978 Error_Msg_N ("premature usage of formal subprogram", Def);
2980 elsif not Entity_Matches_Spec (Subp, Nam) then
2981 Error_Msg_N ("no visible entity matches specification", Def);
2982 end if;
2984 -- More than one interpretation, so disambiguate as for a renaming
2986 else
2987 declare
2988 I : Interp_Index;
2989 I1 : Interp_Index := 0;
2990 It : Interp;
2991 It1 : Interp;
2993 begin
2994 Subp := Any_Id;
2995 Get_First_Interp (Def, I, It);
2996 while Present (It.Nam) loop
2997 if Entity_Matches_Spec (It.Nam, Nam) then
2998 if Subp /= Any_Id then
2999 It1 := Disambiguate (Def, I1, I, Etype (Subp));
3001 if It1 = No_Interp then
3002 Error_Msg_N ("ambiguous default subprogram", Def);
3003 else
3004 Subp := It1.Nam;
3005 end if;
3007 exit;
3009 else
3010 I1 := I;
3011 Subp := It.Nam;
3012 end if;
3013 end if;
3015 Get_Next_Interp (I, It);
3016 end loop;
3017 end;
3019 if Subp /= Any_Id then
3021 -- Subprogram found, generate reference to it
3023 Set_Entity (Def, Subp);
3024 Generate_Reference (Subp, Def);
3026 if Subp = Nam then
3027 Error_Msg_N ("premature usage of formal subprogram", Def);
3029 elsif Ekind (Subp) /= E_Operator then
3030 Check_Mode_Conformant (Subp, Nam);
3031 end if;
3033 else
3034 Error_Msg_N ("no visible subprogram matches specification", N);
3035 end if;
3036 end if;
3037 end if;
3039 <<Leave>>
3040 if Has_Aspects (N) then
3041 Analyze_Aspect_Specifications (N, Nam);
3042 end if;
3044 end Analyze_Formal_Subprogram_Declaration;
3046 -------------------------------------
3047 -- Analyze_Formal_Type_Declaration --
3048 -------------------------------------
3050 procedure Analyze_Formal_Type_Declaration (N : Node_Id) is
3051 Def : constant Node_Id := Formal_Type_Definition (N);
3052 T : Entity_Id;
3054 begin
3055 T := Defining_Identifier (N);
3057 if Present (Discriminant_Specifications (N))
3058 and then Nkind (Def) /= N_Formal_Private_Type_Definition
3059 then
3060 Error_Msg_N
3061 ("discriminants not allowed for this formal type", T);
3062 end if;
3064 -- Enter the new name, and branch to specific routine
3066 case Nkind (Def) is
3067 when N_Formal_Private_Type_Definition =>
3068 Analyze_Formal_Private_Type (N, T, Def);
3070 when N_Formal_Derived_Type_Definition =>
3071 Analyze_Formal_Derived_Type (N, T, Def);
3073 when N_Formal_Incomplete_Type_Definition =>
3074 Analyze_Formal_Incomplete_Type (T, Def);
3076 when N_Formal_Discrete_Type_Definition =>
3077 Analyze_Formal_Discrete_Type (T, Def);
3079 when N_Formal_Signed_Integer_Type_Definition =>
3080 Analyze_Formal_Signed_Integer_Type (T, Def);
3082 when N_Formal_Modular_Type_Definition =>
3083 Analyze_Formal_Modular_Type (T, Def);
3085 when N_Formal_Floating_Point_Definition =>
3086 Analyze_Formal_Floating_Type (T, Def);
3088 when N_Formal_Ordinary_Fixed_Point_Definition =>
3089 Analyze_Formal_Ordinary_Fixed_Point_Type (T, Def);
3091 when N_Formal_Decimal_Fixed_Point_Definition =>
3092 Analyze_Formal_Decimal_Fixed_Point_Type (T, Def);
3094 when N_Array_Type_Definition =>
3095 Analyze_Formal_Array_Type (T, Def);
3097 when N_Access_To_Object_Definition |
3098 N_Access_Function_Definition |
3099 N_Access_Procedure_Definition =>
3100 Analyze_Generic_Access_Type (T, Def);
3102 -- Ada 2005: a interface declaration is encoded as an abstract
3103 -- record declaration or a abstract type derivation.
3105 when N_Record_Definition =>
3106 Analyze_Formal_Interface_Type (N, T, Def);
3108 when N_Derived_Type_Definition =>
3109 Analyze_Formal_Derived_Interface_Type (N, T, Def);
3111 when N_Error =>
3112 null;
3114 when others =>
3115 raise Program_Error;
3117 end case;
3119 Set_Is_Generic_Type (T);
3121 if Has_Aspects (N) then
3122 Analyze_Aspect_Specifications (N, T);
3123 end if;
3124 end Analyze_Formal_Type_Declaration;
3126 ------------------------------------
3127 -- Analyze_Function_Instantiation --
3128 ------------------------------------
3130 procedure Analyze_Function_Instantiation (N : Node_Id) is
3131 begin
3132 Analyze_Subprogram_Instantiation (N, E_Function);
3133 end Analyze_Function_Instantiation;
3135 ---------------------------------
3136 -- Analyze_Generic_Access_Type --
3137 ---------------------------------
3139 procedure Analyze_Generic_Access_Type (T : Entity_Id; Def : Node_Id) is
3140 begin
3141 Enter_Name (T);
3143 if Nkind (Def) = N_Access_To_Object_Definition then
3144 Access_Type_Declaration (T, Def);
3146 if Is_Incomplete_Or_Private_Type (Designated_Type (T))
3147 and then No (Full_View (Designated_Type (T)))
3148 and then not Is_Generic_Type (Designated_Type (T))
3149 then
3150 Error_Msg_N ("premature usage of incomplete type", Def);
3152 elsif not Is_Entity_Name (Subtype_Indication (Def)) then
3153 Error_Msg_N
3154 ("only a subtype mark is allowed in a formal", Def);
3155 end if;
3157 else
3158 Access_Subprogram_Declaration (T, Def);
3159 end if;
3160 end Analyze_Generic_Access_Type;
3162 ---------------------------------
3163 -- Analyze_Generic_Formal_Part --
3164 ---------------------------------
3166 procedure Analyze_Generic_Formal_Part (N : Node_Id) is
3167 Gen_Parm_Decl : Node_Id;
3169 begin
3170 -- The generic formals are processed in the scope of the generic unit,
3171 -- where they are immediately visible. The scope is installed by the
3172 -- caller.
3174 Gen_Parm_Decl := First (Generic_Formal_Declarations (N));
3176 while Present (Gen_Parm_Decl) loop
3177 Analyze (Gen_Parm_Decl);
3178 Next (Gen_Parm_Decl);
3179 end loop;
3181 Generate_Reference_To_Generic_Formals (Current_Scope);
3182 end Analyze_Generic_Formal_Part;
3184 ------------------------------------------
3185 -- Analyze_Generic_Package_Declaration --
3186 ------------------------------------------
3188 procedure Analyze_Generic_Package_Declaration (N : Node_Id) is
3189 Loc : constant Source_Ptr := Sloc (N);
3190 Id : Entity_Id;
3191 New_N : Node_Id;
3192 Save_Parent : Node_Id;
3193 Renaming : Node_Id;
3194 Decls : constant List_Id :=
3195 Visible_Declarations (Specification (N));
3196 Decl : Node_Id;
3198 begin
3199 Check_SPARK_05_Restriction ("generic is not allowed", N);
3201 -- We introduce a renaming of the enclosing package, to have a usable
3202 -- entity as the prefix of an expanded name for a local entity of the
3203 -- form Par.P.Q, where P is the generic package. This is because a local
3204 -- entity named P may hide it, so that the usual visibility rules in
3205 -- the instance will not resolve properly.
3207 Renaming :=
3208 Make_Package_Renaming_Declaration (Loc,
3209 Defining_Unit_Name =>
3210 Make_Defining_Identifier (Loc,
3211 Chars => New_External_Name (Chars (Defining_Entity (N)), "GH")),
3212 Name => Make_Identifier (Loc, Chars (Defining_Entity (N))));
3214 if Present (Decls) then
3215 Decl := First (Decls);
3216 while Present (Decl)
3217 and then Nkind (Decl) = N_Pragma
3218 loop
3219 Next (Decl);
3220 end loop;
3222 if Present (Decl) then
3223 Insert_Before (Decl, Renaming);
3224 else
3225 Append (Renaming, Visible_Declarations (Specification (N)));
3226 end if;
3228 else
3229 Set_Visible_Declarations (Specification (N), New_List (Renaming));
3230 end if;
3232 -- Create copy of generic unit, and save for instantiation. If the unit
3233 -- is a child unit, do not copy the specifications for the parent, which
3234 -- are not part of the generic tree.
3236 Save_Parent := Parent_Spec (N);
3237 Set_Parent_Spec (N, Empty);
3239 New_N := Copy_Generic_Node (N, Empty, Instantiating => False);
3240 Set_Parent_Spec (New_N, Save_Parent);
3241 Rewrite (N, New_N);
3243 -- Once the contents of the generic copy and the template are swapped,
3244 -- do the same for their respective aspect specifications.
3246 Exchange_Aspects (N, New_N);
3247 Id := Defining_Entity (N);
3248 Generate_Definition (Id);
3250 -- Expansion is not applied to generic units
3252 Start_Generic;
3254 Enter_Name (Id);
3255 Set_Ekind (Id, E_Generic_Package);
3256 Set_Etype (Id, Standard_Void_Type);
3257 Set_Contract (Id, Make_Contract (Sloc (Id)));
3259 -- Analyze aspects now, so that generated pragmas appear in the
3260 -- declarations before building and analyzing the generic copy.
3262 if Has_Aspects (N) then
3263 Analyze_Aspect_Specifications (N, Id);
3264 end if;
3266 Push_Scope (Id);
3267 Enter_Generic_Scope (Id);
3268 Set_Inner_Instances (Id, New_Elmt_List);
3270 Set_Categorization_From_Pragmas (N);
3271 Set_Is_Pure (Id, Is_Pure (Current_Scope));
3273 -- Link the declaration of the generic homonym in the generic copy to
3274 -- the package it renames, so that it is always resolved properly.
3276 Set_Generic_Homonym (Id, Defining_Unit_Name (Renaming));
3277 Set_Entity (Associated_Node (Name (Renaming)), Id);
3279 -- For a library unit, we have reconstructed the entity for the unit,
3280 -- and must reset it in the library tables.
3282 if Nkind (Parent (N)) = N_Compilation_Unit then
3283 Set_Cunit_Entity (Current_Sem_Unit, Id);
3284 end if;
3286 Analyze_Generic_Formal_Part (N);
3288 -- After processing the generic formals, analysis proceeds as for a
3289 -- non-generic package.
3291 Analyze (Specification (N));
3293 Validate_Categorization_Dependency (N, Id);
3295 End_Generic;
3297 End_Package_Scope (Id);
3298 Exit_Generic_Scope (Id);
3300 if Nkind (Parent (N)) /= N_Compilation_Unit then
3301 Move_Freeze_Nodes (Id, N, Visible_Declarations (Specification (N)));
3302 Move_Freeze_Nodes (Id, N, Private_Declarations (Specification (N)));
3303 Move_Freeze_Nodes (Id, N, Generic_Formal_Declarations (N));
3305 else
3306 Set_Body_Required (Parent (N), Unit_Requires_Body (Id));
3307 Validate_RT_RAT_Component (N);
3309 -- If this is a spec without a body, check that generic parameters
3310 -- are referenced.
3312 if not Body_Required (Parent (N)) then
3313 Check_References (Id);
3314 end if;
3315 end if;
3316 end Analyze_Generic_Package_Declaration;
3318 --------------------------------------------
3319 -- Analyze_Generic_Subprogram_Declaration --
3320 --------------------------------------------
3322 procedure Analyze_Generic_Subprogram_Declaration (N : Node_Id) is
3323 Spec : Node_Id;
3324 Id : Entity_Id;
3325 Formals : List_Id;
3326 New_N : Node_Id;
3327 Result_Type : Entity_Id;
3328 Save_Parent : Node_Id;
3329 Typ : Entity_Id;
3331 begin
3332 Check_SPARK_05_Restriction ("generic is not allowed", N);
3334 -- Create copy of generic unit, and save for instantiation. If the unit
3335 -- is a child unit, do not copy the specifications for the parent, which
3336 -- are not part of the generic tree.
3338 Save_Parent := Parent_Spec (N);
3339 Set_Parent_Spec (N, Empty);
3341 New_N := Copy_Generic_Node (N, Empty, Instantiating => False);
3342 Set_Parent_Spec (New_N, Save_Parent);
3343 Rewrite (N, New_N);
3345 -- Once the contents of the generic copy and the template are swapped,
3346 -- do the same for their respective aspect specifications.
3348 Exchange_Aspects (N, New_N);
3350 Spec := Specification (N);
3351 Id := Defining_Entity (Spec);
3352 Generate_Definition (Id);
3353 Set_Contract (Id, Make_Contract (Sloc (Id)));
3355 if Nkind (Id) = N_Defining_Operator_Symbol then
3356 Error_Msg_N
3357 ("operator symbol not allowed for generic subprogram", Id);
3358 end if;
3360 Start_Generic;
3362 Enter_Name (Id);
3363 Set_Scope_Depth_Value (Id, Scope_Depth (Current_Scope) + 1);
3365 -- Analyze the aspects of the generic copy to ensure that all generated
3366 -- pragmas (if any) perform their semantic effects.
3368 if Has_Aspects (N) then
3369 Analyze_Aspect_Specifications (N, Id);
3370 end if;
3372 Push_Scope (Id);
3373 Enter_Generic_Scope (Id);
3374 Set_Inner_Instances (Id, New_Elmt_List);
3375 Set_Is_Pure (Id, Is_Pure (Current_Scope));
3377 Analyze_Generic_Formal_Part (N);
3379 Formals := Parameter_Specifications (Spec);
3381 if Present (Formals) then
3382 Process_Formals (Formals, Spec);
3383 end if;
3385 if Nkind (Spec) = N_Function_Specification then
3386 Set_Ekind (Id, E_Generic_Function);
3388 if Nkind (Result_Definition (Spec)) = N_Access_Definition then
3389 Result_Type := Access_Definition (Spec, Result_Definition (Spec));
3390 Set_Etype (Id, Result_Type);
3392 -- Check restriction imposed by AI05-073: a generic function
3393 -- cannot return an abstract type or an access to such.
3395 -- This is a binding interpretation should it apply to earlier
3396 -- versions of Ada as well as Ada 2012???
3398 if Is_Abstract_Type (Designated_Type (Result_Type))
3399 and then Ada_Version >= Ada_2012
3400 then
3401 Error_Msg_N ("generic function cannot have an access result"
3402 & " that designates an abstract type", Spec);
3403 end if;
3405 else
3406 Find_Type (Result_Definition (Spec));
3407 Typ := Entity (Result_Definition (Spec));
3409 if Is_Abstract_Type (Typ)
3410 and then Ada_Version >= Ada_2012
3411 then
3412 Error_Msg_N
3413 ("generic function cannot have abstract result type", Spec);
3414 end if;
3416 -- If a null exclusion is imposed on the result type, then create
3417 -- a null-excluding itype (an access subtype) and use it as the
3418 -- function's Etype.
3420 if Is_Access_Type (Typ)
3421 and then Null_Exclusion_Present (Spec)
3422 then
3423 Set_Etype (Id,
3424 Create_Null_Excluding_Itype
3425 (T => Typ,
3426 Related_Nod => Spec,
3427 Scope_Id => Defining_Unit_Name (Spec)));
3428 else
3429 Set_Etype (Id, Typ);
3430 end if;
3431 end if;
3433 else
3434 Set_Ekind (Id, E_Generic_Procedure);
3435 Set_Etype (Id, Standard_Void_Type);
3436 end if;
3438 -- For a library unit, we have reconstructed the entity for the unit,
3439 -- and must reset it in the library tables. We also make sure that
3440 -- Body_Required is set properly in the original compilation unit node.
3442 if Nkind (Parent (N)) = N_Compilation_Unit then
3443 Set_Cunit_Entity (Current_Sem_Unit, Id);
3444 Set_Body_Required (Parent (N), Unit_Requires_Body (Id));
3445 end if;
3447 Set_Categorization_From_Pragmas (N);
3448 Validate_Categorization_Dependency (N, Id);
3450 Save_Global_References (Original_Node (N));
3452 -- For ASIS purposes, convert any postcondition, precondition pragmas
3453 -- into aspects, if N is not a compilation unit by itself, in order to
3454 -- enable the analysis of expressions inside the corresponding PPC
3455 -- pragmas.
3457 if ASIS_Mode and then Is_List_Member (N) then
3458 Make_Aspect_For_PPC_In_Gen_Sub_Decl (N);
3459 end if;
3461 End_Generic;
3462 End_Scope;
3463 Exit_Generic_Scope (Id);
3464 Generate_Reference_To_Formals (Id);
3466 List_Inherited_Pre_Post_Aspects (Id);
3467 end Analyze_Generic_Subprogram_Declaration;
3469 -----------------------------------
3470 -- Analyze_Package_Instantiation --
3471 -----------------------------------
3473 procedure Analyze_Package_Instantiation (N : Node_Id) is
3474 Loc : constant Source_Ptr := Sloc (N);
3475 Gen_Id : constant Node_Id := Name (N);
3477 Act_Decl : Node_Id;
3478 Act_Decl_Name : Node_Id;
3479 Act_Decl_Id : Entity_Id;
3480 Act_Spec : Node_Id;
3481 Act_Tree : Node_Id;
3483 Gen_Decl : Node_Id;
3484 Gen_Unit : Entity_Id;
3486 Is_Actual_Pack : constant Boolean :=
3487 Is_Internal (Defining_Entity (N));
3489 Env_Installed : Boolean := False;
3490 Parent_Installed : Boolean := False;
3491 Renaming_List : List_Id;
3492 Unit_Renaming : Node_Id;
3493 Needs_Body : Boolean;
3494 Inline_Now : Boolean := False;
3496 Save_IPSM : constant Boolean := Ignore_Pragma_SPARK_Mode;
3497 -- Save flag Ignore_Pragma_SPARK_Mode for restore on exit
3499 Save_SM : constant SPARK_Mode_Type := SPARK_Mode;
3500 Save_SMP : constant Node_Id := SPARK_Mode_Pragma;
3501 -- Save the SPARK_Mode-related data for restore on exit
3503 Save_Style_Check : constant Boolean := Style_Check;
3504 -- Save style check mode for restore on exit
3506 procedure Delay_Descriptors (E : Entity_Id);
3507 -- Delay generation of subprogram descriptors for given entity
3509 function Might_Inline_Subp return Boolean;
3510 -- If inlining is active and the generic contains inlined subprograms,
3511 -- we instantiate the body. This may cause superfluous instantiations,
3512 -- but it is simpler than detecting the need for the body at the point
3513 -- of inlining, when the context of the instance is not available.
3515 function Must_Inline_Subp return Boolean;
3516 -- If inlining is active and the generic contains inlined subprograms,
3517 -- return True if some of the inlined subprograms must be inlined by
3518 -- the frontend.
3520 -----------------------
3521 -- Delay_Descriptors --
3522 -----------------------
3524 procedure Delay_Descriptors (E : Entity_Id) is
3525 begin
3526 if not Delay_Subprogram_Descriptors (E) then
3527 Set_Delay_Subprogram_Descriptors (E);
3528 Pending_Descriptor.Append (E);
3529 end if;
3530 end Delay_Descriptors;
3532 -----------------------
3533 -- Might_Inline_Subp --
3534 -----------------------
3536 function Might_Inline_Subp return Boolean is
3537 E : Entity_Id;
3539 begin
3540 if not Inline_Processing_Required then
3541 return False;
3543 else
3544 E := First_Entity (Gen_Unit);
3545 while Present (E) loop
3546 if Is_Subprogram (E)
3547 and then Is_Inlined (E)
3548 then
3549 return True;
3550 end if;
3552 Next_Entity (E);
3553 end loop;
3554 end if;
3556 return False;
3557 end Might_Inline_Subp;
3559 ----------------------
3560 -- Must_Inline_Subp --
3561 ----------------------
3563 function Must_Inline_Subp return Boolean is
3564 E : Entity_Id;
3566 begin
3567 if not Inline_Processing_Required then
3568 return False;
3570 else
3571 E := First_Entity (Gen_Unit);
3572 while Present (E) loop
3573 if Is_Subprogram (E)
3574 and then Is_Inlined (E)
3575 and then Must_Inline (E)
3576 then
3577 return True;
3578 end if;
3580 Next_Entity (E);
3581 end loop;
3582 end if;
3584 return False;
3585 end Must_Inline_Subp;
3587 -- Local declarations
3589 Vis_Prims_List : Elist_Id := No_Elist;
3590 -- List of primitives made temporarily visible in the instantiation
3591 -- to match the visibility of the formal type
3593 -- Start of processing for Analyze_Package_Instantiation
3595 begin
3596 Check_SPARK_05_Restriction ("generic is not allowed", N);
3598 -- Very first thing: check for Text_IO sp[ecial unit in case we are
3599 -- instantiating one of the children of [[Wide_]Wide_]Text_IO.
3601 Check_Text_IO_Special_Unit (Name (N));
3603 -- Make node global for error reporting
3605 Instantiation_Node := N;
3607 -- Turn off style checking in instances. If the check is enabled on the
3608 -- generic unit, a warning in an instance would just be noise. If not
3609 -- enabled on the generic, then a warning in an instance is just wrong.
3611 Style_Check := False;
3613 -- Case of instantiation of a generic package
3615 if Nkind (N) = N_Package_Instantiation then
3616 Act_Decl_Id := New_Copy (Defining_Entity (N));
3617 Set_Comes_From_Source (Act_Decl_Id, True);
3619 if Nkind (Defining_Unit_Name (N)) = N_Defining_Program_Unit_Name then
3620 Act_Decl_Name :=
3621 Make_Defining_Program_Unit_Name (Loc,
3622 Name => New_Copy_Tree (Name (Defining_Unit_Name (N))),
3623 Defining_Identifier => Act_Decl_Id);
3624 else
3625 Act_Decl_Name := Act_Decl_Id;
3626 end if;
3628 -- Case of instantiation of a formal package
3630 else
3631 Act_Decl_Id := Defining_Identifier (N);
3632 Act_Decl_Name := Act_Decl_Id;
3633 end if;
3635 Generate_Definition (Act_Decl_Id);
3636 Preanalyze_Actuals (N);
3638 Init_Env;
3639 Env_Installed := True;
3641 -- Reset renaming map for formal types. The mapping is established
3642 -- when analyzing the generic associations, but some mappings are
3643 -- inherited from formal packages of parent units, and these are
3644 -- constructed when the parents are installed.
3646 Generic_Renamings.Set_Last (0);
3647 Generic_Renamings_HTable.Reset;
3649 Check_Generic_Child_Unit (Gen_Id, Parent_Installed);
3650 Gen_Unit := Entity (Gen_Id);
3652 -- Verify that it is the name of a generic package
3654 -- A visibility glitch: if the instance is a child unit and the generic
3655 -- is the generic unit of a parent instance (i.e. both the parent and
3656 -- the child units are instances of the same package) the name now
3657 -- denotes the renaming within the parent, not the intended generic
3658 -- unit. See if there is a homonym that is the desired generic. The
3659 -- renaming declaration must be visible inside the instance of the
3660 -- child, but not when analyzing the name in the instantiation itself.
3662 if Ekind (Gen_Unit) = E_Package
3663 and then Present (Renamed_Entity (Gen_Unit))
3664 and then In_Open_Scopes (Renamed_Entity (Gen_Unit))
3665 and then Is_Generic_Instance (Renamed_Entity (Gen_Unit))
3666 and then Present (Homonym (Gen_Unit))
3667 then
3668 Gen_Unit := Homonym (Gen_Unit);
3669 end if;
3671 if Etype (Gen_Unit) = Any_Type then
3672 Restore_Env;
3673 goto Leave;
3675 elsif Ekind (Gen_Unit) /= E_Generic_Package then
3677 -- Ada 2005 (AI-50217): Cannot use instance in limited with_clause
3679 if From_Limited_With (Gen_Unit) then
3680 Error_Msg_N
3681 ("cannot instantiate a limited withed package", Gen_Id);
3682 else
3683 Error_Msg_NE
3684 ("& is not the name of a generic package", Gen_Id, Gen_Unit);
3685 end if;
3687 Restore_Env;
3688 goto Leave;
3689 end if;
3691 if In_Extended_Main_Source_Unit (N) then
3692 Set_Is_Instantiated (Gen_Unit);
3693 Generate_Reference (Gen_Unit, N);
3695 if Present (Renamed_Object (Gen_Unit)) then
3696 Set_Is_Instantiated (Renamed_Object (Gen_Unit));
3697 Generate_Reference (Renamed_Object (Gen_Unit), N);
3698 end if;
3699 end if;
3701 if Nkind (Gen_Id) = N_Identifier
3702 and then Chars (Gen_Unit) = Chars (Defining_Entity (N))
3703 then
3704 Error_Msg_NE
3705 ("& is hidden within declaration of instance", Gen_Id, Gen_Unit);
3707 elsif Nkind (Gen_Id) = N_Expanded_Name
3708 and then Is_Child_Unit (Gen_Unit)
3709 and then Nkind (Prefix (Gen_Id)) = N_Identifier
3710 and then Chars (Act_Decl_Id) = Chars (Prefix (Gen_Id))
3711 then
3712 Error_Msg_N
3713 ("& is hidden within declaration of instance ", Prefix (Gen_Id));
3714 end if;
3716 Set_Entity (Gen_Id, Gen_Unit);
3718 -- If generic is a renaming, get original generic unit
3720 if Present (Renamed_Object (Gen_Unit))
3721 and then Ekind (Renamed_Object (Gen_Unit)) = E_Generic_Package
3722 then
3723 Gen_Unit := Renamed_Object (Gen_Unit);
3724 end if;
3726 -- Verify that there are no circular instantiations
3728 if In_Open_Scopes (Gen_Unit) then
3729 Error_Msg_NE ("instantiation of & within itself", N, Gen_Unit);
3730 Restore_Env;
3731 goto Leave;
3733 elsif Contains_Instance_Of (Gen_Unit, Current_Scope, Gen_Id) then
3734 Error_Msg_Node_2 := Current_Scope;
3735 Error_Msg_NE
3736 ("circular Instantiation: & instantiated in &!", N, Gen_Unit);
3737 Circularity_Detected := True;
3738 Restore_Env;
3739 goto Leave;
3741 else
3742 -- If the context of the instance is subject to SPARK_Mode "off",
3743 -- set the global flag which signals Analyze_Pragma to ignore all
3744 -- SPARK_Mode pragmas within the instance.
3746 if SPARK_Mode = Off then
3747 Ignore_Pragma_SPARK_Mode := True;
3748 end if;
3750 Gen_Decl := Unit_Declaration_Node (Gen_Unit);
3752 -- Initialize renamings map, for error checking, and the list that
3753 -- holds private entities whose views have changed between generic
3754 -- definition and instantiation. If this is the instance created to
3755 -- validate an actual package, the instantiation environment is that
3756 -- of the enclosing instance.
3758 Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment);
3760 -- Copy original generic tree, to produce text for instantiation
3762 Act_Tree :=
3763 Copy_Generic_Node
3764 (Original_Node (Gen_Decl), Empty, Instantiating => True);
3766 Act_Spec := Specification (Act_Tree);
3768 -- If this is the instance created to validate an actual package,
3769 -- only the formals matter, do not examine the package spec itself.
3771 if Is_Actual_Pack then
3772 Set_Visible_Declarations (Act_Spec, New_List);
3773 Set_Private_Declarations (Act_Spec, New_List);
3774 end if;
3776 Renaming_List :=
3777 Analyze_Associations
3778 (I_Node => N,
3779 Formals => Generic_Formal_Declarations (Act_Tree),
3780 F_Copy => Generic_Formal_Declarations (Gen_Decl));
3782 Vis_Prims_List := Check_Hidden_Primitives (Renaming_List);
3784 Set_Instance_Env (Gen_Unit, Act_Decl_Id);
3785 Set_Defining_Unit_Name (Act_Spec, Act_Decl_Name);
3786 Set_Is_Generic_Instance (Act_Decl_Id);
3787 Set_Generic_Parent (Act_Spec, Gen_Unit);
3789 -- References to the generic in its own declaration or its body are
3790 -- references to the instance. Add a renaming declaration for the
3791 -- generic unit itself. This declaration, as well as the renaming
3792 -- declarations for the generic formals, must remain private to the
3793 -- unit: the formals, because this is the language semantics, and
3794 -- the unit because its use is an artifact of the implementation.
3796 Unit_Renaming :=
3797 Make_Package_Renaming_Declaration (Loc,
3798 Defining_Unit_Name =>
3799 Make_Defining_Identifier (Loc, Chars (Gen_Unit)),
3800 Name => New_Occurrence_Of (Act_Decl_Id, Loc));
3802 Append (Unit_Renaming, Renaming_List);
3804 -- The renaming declarations are the first local declarations of the
3805 -- new unit.
3807 if Is_Non_Empty_List (Visible_Declarations (Act_Spec)) then
3808 Insert_List_Before
3809 (First (Visible_Declarations (Act_Spec)), Renaming_List);
3810 else
3811 Set_Visible_Declarations (Act_Spec, Renaming_List);
3812 end if;
3814 Act_Decl := Make_Package_Declaration (Loc, Specification => Act_Spec);
3816 -- Propagate the aspect specifications from the package declaration
3817 -- template to the instantiated version of the package declaration.
3819 if Has_Aspects (Act_Tree) then
3820 Set_Aspect_Specifications (Act_Decl,
3821 New_Copy_List_Tree (Aspect_Specifications (Act_Tree)));
3822 end if;
3824 -- Save the instantiation node, for subsequent instantiation of the
3825 -- body, if there is one and we are generating code for the current
3826 -- unit. Mark unit as having a body (avoids premature error message).
3828 -- We instantiate the body if we are generating code, if we are
3829 -- generating cross-reference information, or if we are building
3830 -- trees for ASIS use or GNATprove use.
3832 declare
3833 Enclosing_Body_Present : Boolean := False;
3834 -- If the generic unit is not a compilation unit, then a body may
3835 -- be present in its parent even if none is required. We create a
3836 -- tentative pending instantiation for the body, which will be
3837 -- discarded if none is actually present.
3839 Scop : Entity_Id;
3841 begin
3842 if Scope (Gen_Unit) /= Standard_Standard
3843 and then not Is_Child_Unit (Gen_Unit)
3844 then
3845 Scop := Scope (Gen_Unit);
3847 while Present (Scop)
3848 and then Scop /= Standard_Standard
3849 loop
3850 if Unit_Requires_Body (Scop) then
3851 Enclosing_Body_Present := True;
3852 exit;
3854 elsif In_Open_Scopes (Scop)
3855 and then In_Package_Body (Scop)
3856 then
3857 Enclosing_Body_Present := True;
3858 exit;
3859 end if;
3861 exit when Is_Compilation_Unit (Scop);
3862 Scop := Scope (Scop);
3863 end loop;
3864 end if;
3866 -- If front-end inlining is enabled, and this is a unit for which
3867 -- code will be generated, we instantiate the body at once.
3869 -- This is done if the instance is not the main unit, and if the
3870 -- generic is not a child unit of another generic, to avoid scope
3871 -- problems and the reinstallation of parent instances.
3873 if Expander_Active
3874 and then (not Is_Child_Unit (Gen_Unit)
3875 or else not Is_Generic_Unit (Scope (Gen_Unit)))
3876 and then Might_Inline_Subp
3877 and then not Is_Actual_Pack
3878 then
3879 if not Back_End_Inlining
3880 and then Front_End_Inlining
3881 and then (Is_In_Main_Unit (N)
3882 or else In_Main_Context (Current_Scope))
3883 and then Nkind (Parent (N)) /= N_Compilation_Unit
3884 then
3885 Inline_Now := True;
3887 elsif Back_End_Inlining
3888 and then Must_Inline_Subp
3889 and then (Is_In_Main_Unit (N)
3890 or else In_Main_Context (Current_Scope))
3891 and then Nkind (Parent (N)) /= N_Compilation_Unit
3892 then
3893 Inline_Now := True;
3895 -- In configurable_run_time mode we force the inlining of
3896 -- predefined subprograms marked Inline_Always, to minimize
3897 -- the use of the run-time library.
3899 elsif Is_Predefined_File_Name
3900 (Unit_File_Name (Get_Source_Unit (Gen_Decl)))
3901 and then Configurable_Run_Time_Mode
3902 and then Nkind (Parent (N)) /= N_Compilation_Unit
3903 then
3904 Inline_Now := True;
3905 end if;
3907 -- If the current scope is itself an instance within a child
3908 -- unit, there will be duplications in the scope stack, and the
3909 -- unstacking mechanism in Inline_Instance_Body will fail.
3910 -- This loses some rare cases of optimization, and might be
3911 -- improved some day, if we can find a proper abstraction for
3912 -- "the complete compilation context" that can be saved and
3913 -- restored. ???
3915 if Is_Generic_Instance (Current_Scope) then
3916 declare
3917 Curr_Unit : constant Entity_Id :=
3918 Cunit_Entity (Current_Sem_Unit);
3919 begin
3920 if Curr_Unit /= Current_Scope
3921 and then Is_Child_Unit (Curr_Unit)
3922 then
3923 Inline_Now := False;
3924 end if;
3925 end;
3926 end if;
3927 end if;
3929 Needs_Body :=
3930 (Unit_Requires_Body (Gen_Unit)
3931 or else Enclosing_Body_Present
3932 or else Present (Corresponding_Body (Gen_Decl)))
3933 and then (Is_In_Main_Unit (N) or else Might_Inline_Subp)
3934 and then not Is_Actual_Pack
3935 and then not Inline_Now
3936 and then (Operating_Mode = Generate_Code
3938 -- Need comment for this check ???
3940 or else (Operating_Mode = Check_Semantics
3941 and then (ASIS_Mode or GNATprove_Mode)));
3943 -- If front_end_inlining is enabled, do not instantiate body if
3944 -- within a generic context.
3946 if (Front_End_Inlining and then not Expander_Active)
3947 or else Is_Generic_Unit (Cunit_Entity (Main_Unit))
3948 then
3949 Needs_Body := False;
3950 end if;
3952 -- If the current context is generic, and the package being
3953 -- instantiated is declared within a formal package, there is no
3954 -- body to instantiate until the enclosing generic is instantiated
3955 -- and there is an actual for the formal package. If the formal
3956 -- package has parameters, we build a regular package instance for
3957 -- it, that precedes the original formal package declaration.
3959 if In_Open_Scopes (Scope (Scope (Gen_Unit))) then
3960 declare
3961 Decl : constant Node_Id :=
3962 Original_Node
3963 (Unit_Declaration_Node (Scope (Gen_Unit)));
3964 begin
3965 if Nkind (Decl) = N_Formal_Package_Declaration
3966 or else (Nkind (Decl) = N_Package_Declaration
3967 and then Is_List_Member (Decl)
3968 and then Present (Next (Decl))
3969 and then
3970 Nkind (Next (Decl)) =
3971 N_Formal_Package_Declaration)
3972 then
3973 Needs_Body := False;
3974 end if;
3975 end;
3976 end if;
3977 end;
3979 -- For RCI unit calling stubs, we omit the instance body if the
3980 -- instance is the RCI library unit itself.
3982 -- However there is a special case for nested instances: in this case
3983 -- we do generate the instance body, as it might be required, e.g.
3984 -- because it provides stream attributes for some type used in the
3985 -- profile of a remote subprogram. This is consistent with 12.3(12),
3986 -- which indicates that the instance body occurs at the place of the
3987 -- instantiation, and thus is part of the RCI declaration, which is
3988 -- present on all client partitions (this is E.2.3(18)).
3990 -- Note that AI12-0002 may make it illegal at some point to have
3991 -- stream attributes defined in an RCI unit, in which case this
3992 -- special case will become unnecessary. In the meantime, there
3993 -- is known application code in production that depends on this
3994 -- being possible, so we definitely cannot eliminate the body in
3995 -- the case of nested instances for the time being.
3997 -- When we generate a nested instance body, calling stubs for any
3998 -- relevant subprogram will be be inserted immediately after the
3999 -- subprogram declarations, and will take precedence over the
4000 -- subsequent (original) body. (The stub and original body will be
4001 -- complete homographs, but this is permitted in an instance).
4002 -- (Could we do better and remove the original body???)
4004 if Distribution_Stub_Mode = Generate_Caller_Stub_Body
4005 and then Comes_From_Source (N)
4006 and then Nkind (Parent (N)) = N_Compilation_Unit
4007 then
4008 Needs_Body := False;
4009 end if;
4011 if Needs_Body then
4013 -- Here is a defence against a ludicrous number of instantiations
4014 -- caused by a circular set of instantiation attempts.
4016 if Pending_Instantiations.Last > Maximum_Instantiations then
4017 Error_Msg_Uint_1 := UI_From_Int (Maximum_Instantiations);
4018 Error_Msg_N ("too many instantiations, exceeds max of^", N);
4019 Error_Msg_N ("\limit can be changed using -gnateinn switch", N);
4020 raise Unrecoverable_Error;
4021 end if;
4023 -- Indicate that the enclosing scopes contain an instantiation,
4024 -- and that cleanup actions should be delayed until after the
4025 -- instance body is expanded.
4027 Check_Forward_Instantiation (Gen_Decl);
4028 if Nkind (N) = N_Package_Instantiation then
4029 declare
4030 Enclosing_Master : Entity_Id;
4032 begin
4033 -- Loop to search enclosing masters
4035 Enclosing_Master := Current_Scope;
4036 Scope_Loop : while Enclosing_Master /= Standard_Standard loop
4037 if Ekind (Enclosing_Master) = E_Package then
4038 if Is_Compilation_Unit (Enclosing_Master) then
4039 if In_Package_Body (Enclosing_Master) then
4040 Delay_Descriptors
4041 (Body_Entity (Enclosing_Master));
4042 else
4043 Delay_Descriptors
4044 (Enclosing_Master);
4045 end if;
4047 exit Scope_Loop;
4049 else
4050 Enclosing_Master := Scope (Enclosing_Master);
4051 end if;
4053 elsif Is_Generic_Unit (Enclosing_Master)
4054 or else Ekind (Enclosing_Master) = E_Void
4055 then
4056 -- Cleanup actions will eventually be performed on the
4057 -- enclosing subprogram or package instance, if any.
4058 -- Enclosing scope is void in the formal part of a
4059 -- generic subprogram.
4061 exit Scope_Loop;
4063 else
4064 if Ekind (Enclosing_Master) = E_Entry
4065 and then
4066 Ekind (Scope (Enclosing_Master)) = E_Protected_Type
4067 then
4068 if not Expander_Active then
4069 exit Scope_Loop;
4070 else
4071 Enclosing_Master :=
4072 Protected_Body_Subprogram (Enclosing_Master);
4073 end if;
4074 end if;
4076 Set_Delay_Cleanups (Enclosing_Master);
4078 while Ekind (Enclosing_Master) = E_Block loop
4079 Enclosing_Master := Scope (Enclosing_Master);
4080 end loop;
4082 if Is_Subprogram (Enclosing_Master) then
4083 Delay_Descriptors (Enclosing_Master);
4085 elsif Is_Task_Type (Enclosing_Master) then
4086 declare
4087 TBP : constant Node_Id :=
4088 Get_Task_Body_Procedure
4089 (Enclosing_Master);
4090 begin
4091 if Present (TBP) then
4092 Delay_Descriptors (TBP);
4093 Set_Delay_Cleanups (TBP);
4094 end if;
4095 end;
4096 end if;
4098 exit Scope_Loop;
4099 end if;
4100 end loop Scope_Loop;
4101 end;
4103 -- Make entry in table
4105 Pending_Instantiations.Append
4106 ((Inst_Node => N,
4107 Act_Decl => Act_Decl,
4108 Expander_Status => Expander_Active,
4109 Current_Sem_Unit => Current_Sem_Unit,
4110 Scope_Suppress => Scope_Suppress,
4111 Local_Suppress_Stack_Top => Local_Suppress_Stack_Top,
4112 Version => Ada_Version,
4113 Version_Pragma => Ada_Version_Pragma,
4114 Warnings => Save_Warnings,
4115 SPARK_Mode => SPARK_Mode,
4116 SPARK_Mode_Pragma => SPARK_Mode_Pragma));
4117 end if;
4118 end if;
4120 Set_Categorization_From_Pragmas (Act_Decl);
4122 if Parent_Installed then
4123 Hide_Current_Scope;
4124 end if;
4126 Set_Instance_Spec (N, Act_Decl);
4128 -- If not a compilation unit, insert the package declaration before
4129 -- the original instantiation node.
4131 if Nkind (Parent (N)) /= N_Compilation_Unit then
4132 Mark_Rewrite_Insertion (Act_Decl);
4133 Insert_Before (N, Act_Decl);
4134 Analyze (Act_Decl);
4136 -- For an instantiation that is a compilation unit, place
4137 -- declaration on current node so context is complete for analysis
4138 -- (including nested instantiations). If this is the main unit,
4139 -- the declaration eventually replaces the instantiation node.
4140 -- If the instance body is created later, it replaces the
4141 -- instance node, and the declaration is attached to it
4142 -- (see Build_Instance_Compilation_Unit_Nodes).
4144 else
4145 if Cunit_Entity (Current_Sem_Unit) = Defining_Entity (N) then
4147 -- The entity for the current unit is the newly created one,
4148 -- and all semantic information is attached to it.
4150 Set_Cunit_Entity (Current_Sem_Unit, Act_Decl_Id);
4152 -- If this is the main unit, replace the main entity as well
4154 if Current_Sem_Unit = Main_Unit then
4155 Main_Unit_Entity := Act_Decl_Id;
4156 end if;
4157 end if;
4159 Set_Unit (Parent (N), Act_Decl);
4160 Set_Parent_Spec (Act_Decl, Parent_Spec (N));
4161 Set_Package_Instantiation (Act_Decl_Id, N);
4163 -- Process aspect specifications of the instance node, if any, to
4164 -- take into account categorization pragmas before analyzing the
4165 -- instance.
4167 if Has_Aspects (N) then
4168 Analyze_Aspect_Specifications (N, Act_Decl_Id);
4169 end if;
4171 Analyze (Act_Decl);
4172 Set_Unit (Parent (N), N);
4173 Set_Body_Required (Parent (N), False);
4175 -- We never need elaboration checks on instantiations, since by
4176 -- definition, the body instantiation is elaborated at the same
4177 -- time as the spec instantiation.
4179 Set_Suppress_Elaboration_Warnings (Act_Decl_Id);
4180 Set_Kill_Elaboration_Checks (Act_Decl_Id);
4181 end if;
4183 Check_Elab_Instantiation (N);
4185 if ABE_Is_Certain (N) and then Needs_Body then
4186 Pending_Instantiations.Decrement_Last;
4187 end if;
4189 Check_Hidden_Child_Unit (N, Gen_Unit, Act_Decl_Id);
4191 Set_First_Private_Entity (Defining_Unit_Name (Unit_Renaming),
4192 First_Private_Entity (Act_Decl_Id));
4194 -- If the instantiation will receive a body, the unit will be
4195 -- transformed into a package body, and receive its own elaboration
4196 -- entity. Otherwise, the nature of the unit is now a package
4197 -- declaration.
4199 if Nkind (Parent (N)) = N_Compilation_Unit
4200 and then not Needs_Body
4201 then
4202 Rewrite (N, Act_Decl);
4203 end if;
4205 if Present (Corresponding_Body (Gen_Decl))
4206 or else Unit_Requires_Body (Gen_Unit)
4207 then
4208 Set_Has_Completion (Act_Decl_Id);
4209 end if;
4211 Check_Formal_Packages (Act_Decl_Id);
4213 Restore_Hidden_Primitives (Vis_Prims_List);
4214 Restore_Private_Views (Act_Decl_Id);
4216 Inherit_Context (Gen_Decl, N);
4218 if Parent_Installed then
4219 Remove_Parent;
4220 end if;
4222 Restore_Env;
4223 Env_Installed := False;
4224 end if;
4226 Validate_Categorization_Dependency (N, Act_Decl_Id);
4228 -- There used to be a check here to prevent instantiations in local
4229 -- contexts if the No_Local_Allocators restriction was active. This
4230 -- check was removed by a binding interpretation in AI-95-00130/07,
4231 -- but we retain the code for documentation purposes.
4233 -- if Ekind (Act_Decl_Id) /= E_Void
4234 -- and then not Is_Library_Level_Entity (Act_Decl_Id)
4235 -- then
4236 -- Check_Restriction (No_Local_Allocators, N);
4237 -- end if;
4239 if Inline_Now then
4240 Inline_Instance_Body (N, Gen_Unit, Act_Decl);
4241 end if;
4243 -- The following is a tree patch for ASIS: ASIS needs separate nodes to
4244 -- be used as defining identifiers for a formal package and for the
4245 -- corresponding expanded package.
4247 if Nkind (N) = N_Formal_Package_Declaration then
4248 Act_Decl_Id := New_Copy (Defining_Entity (N));
4249 Set_Comes_From_Source (Act_Decl_Id, True);
4250 Set_Is_Generic_Instance (Act_Decl_Id, False);
4251 Set_Defining_Identifier (N, Act_Decl_Id);
4252 end if;
4254 Ignore_Pragma_SPARK_Mode := Save_IPSM;
4255 SPARK_Mode := Save_SM;
4256 SPARK_Mode_Pragma := Save_SMP;
4257 Style_Check := Save_Style_Check;
4259 -- Check that if N is an instantiation of System.Dim_Float_IO or
4260 -- System.Dim_Integer_IO, the formal type has a dimension system.
4262 if Nkind (N) = N_Package_Instantiation
4263 and then Is_Dim_IO_Package_Instantiation (N)
4264 then
4265 declare
4266 Assoc : constant Node_Id := First (Generic_Associations (N));
4267 begin
4268 if not Has_Dimension_System
4269 (Etype (Explicit_Generic_Actual_Parameter (Assoc)))
4270 then
4271 Error_Msg_N ("type with a dimension system expected", Assoc);
4272 end if;
4273 end;
4274 end if;
4276 <<Leave>>
4277 if Has_Aspects (N) and then Nkind (Parent (N)) /= N_Compilation_Unit then
4278 Analyze_Aspect_Specifications (N, Act_Decl_Id);
4279 end if;
4281 exception
4282 when Instantiation_Error =>
4283 if Parent_Installed then
4284 Remove_Parent;
4285 end if;
4287 if Env_Installed then
4288 Restore_Env;
4289 end if;
4291 Ignore_Pragma_SPARK_Mode := Save_IPSM;
4292 SPARK_Mode := Save_SM;
4293 SPARK_Mode_Pragma := Save_SMP;
4294 Style_Check := Save_Style_Check;
4295 end Analyze_Package_Instantiation;
4297 --------------------------
4298 -- Inline_Instance_Body --
4299 --------------------------
4301 procedure Inline_Instance_Body
4302 (N : Node_Id;
4303 Gen_Unit : Entity_Id;
4304 Act_Decl : Node_Id)
4306 Vis : Boolean;
4307 Gen_Comp : constant Entity_Id :=
4308 Cunit_Entity (Get_Source_Unit (Gen_Unit));
4309 Curr_Comp : constant Node_Id := Cunit (Current_Sem_Unit);
4310 Curr_Scope : Entity_Id := Empty;
4311 Curr_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
4312 Removed : Boolean := False;
4313 Num_Scopes : Int := 0;
4315 Scope_Stack_Depth : constant Int :=
4316 Scope_Stack.Last - Scope_Stack.First + 1;
4318 Use_Clauses : array (1 .. Scope_Stack_Depth) of Node_Id;
4319 Instances : array (1 .. Scope_Stack_Depth) of Entity_Id;
4320 Inner_Scopes : array (1 .. Scope_Stack_Depth) of Entity_Id;
4321 List : Elist_Id;
4322 Num_Inner : Int := 0;
4323 N_Instances : Int := 0;
4324 S : Entity_Id;
4326 begin
4327 -- Case of generic unit defined in another unit. We must remove the
4328 -- complete context of the current unit to install that of the generic.
4330 if Gen_Comp /= Cunit_Entity (Current_Sem_Unit) then
4332 -- Add some comments for the following two loops ???
4334 S := Current_Scope;
4335 while Present (S) and then S /= Standard_Standard loop
4336 loop
4337 Num_Scopes := Num_Scopes + 1;
4339 Use_Clauses (Num_Scopes) :=
4340 (Scope_Stack.Table
4341 (Scope_Stack.Last - Num_Scopes + 1).
4342 First_Use_Clause);
4343 End_Use_Clauses (Use_Clauses (Num_Scopes));
4345 exit when Scope_Stack.Last - Num_Scopes + 1 = Scope_Stack.First
4346 or else Scope_Stack.Table
4347 (Scope_Stack.Last - Num_Scopes).Entity
4348 = Scope (S);
4349 end loop;
4351 exit when Is_Generic_Instance (S)
4352 and then (In_Package_Body (S)
4353 or else Ekind (S) = E_Procedure
4354 or else Ekind (S) = E_Function);
4355 S := Scope (S);
4356 end loop;
4358 Vis := Is_Immediately_Visible (Gen_Comp);
4360 -- Find and save all enclosing instances
4362 S := Current_Scope;
4364 while Present (S)
4365 and then S /= Standard_Standard
4366 loop
4367 if Is_Generic_Instance (S) then
4368 N_Instances := N_Instances + 1;
4369 Instances (N_Instances) := S;
4371 exit when In_Package_Body (S);
4372 end if;
4374 S := Scope (S);
4375 end loop;
4377 -- Remove context of current compilation unit, unless we are within a
4378 -- nested package instantiation, in which case the context has been
4379 -- removed previously.
4381 -- If current scope is the body of a child unit, remove context of
4382 -- spec as well. If an enclosing scope is an instance body, the
4383 -- context has already been removed, but the entities in the body
4384 -- must be made invisible as well.
4386 S := Current_Scope;
4388 while Present (S)
4389 and then S /= Standard_Standard
4390 loop
4391 if Is_Generic_Instance (S)
4392 and then (In_Package_Body (S)
4393 or else Ekind (S) = E_Procedure
4394 or else Ekind (S) = E_Function)
4395 then
4396 -- We still have to remove the entities of the enclosing
4397 -- instance from direct visibility.
4399 declare
4400 E : Entity_Id;
4401 begin
4402 E := First_Entity (S);
4403 while Present (E) loop
4404 Set_Is_Immediately_Visible (E, False);
4405 Next_Entity (E);
4406 end loop;
4407 end;
4409 exit;
4410 end if;
4412 if S = Curr_Unit
4413 or else (Ekind (Curr_Unit) = E_Package_Body
4414 and then S = Spec_Entity (Curr_Unit))
4415 or else (Ekind (Curr_Unit) = E_Subprogram_Body
4416 and then S =
4417 Corresponding_Spec
4418 (Unit_Declaration_Node (Curr_Unit)))
4419 then
4420 Removed := True;
4422 -- Remove entities in current scopes from visibility, so that
4423 -- instance body is compiled in a clean environment.
4425 List := Save_Scope_Stack (Handle_Use => False);
4427 if Is_Child_Unit (S) then
4429 -- Remove child unit from stack, as well as inner scopes.
4430 -- Removing the context of a child unit removes parent units
4431 -- as well.
4433 while Current_Scope /= S loop
4434 Num_Inner := Num_Inner + 1;
4435 Inner_Scopes (Num_Inner) := Current_Scope;
4436 Pop_Scope;
4437 end loop;
4439 Pop_Scope;
4440 Remove_Context (Curr_Comp);
4441 Curr_Scope := S;
4443 else
4444 Remove_Context (Curr_Comp);
4445 end if;
4447 if Ekind (Curr_Unit) = E_Package_Body then
4448 Remove_Context (Library_Unit (Curr_Comp));
4449 end if;
4450 end if;
4452 S := Scope (S);
4453 end loop;
4454 pragma Assert (Num_Inner < Num_Scopes);
4456 Push_Scope (Standard_Standard);
4457 Scope_Stack.Table (Scope_Stack.Last).Is_Active_Stack_Base := True;
4458 Instantiate_Package_Body
4459 (Body_Info =>
4460 ((Inst_Node => N,
4461 Act_Decl => Act_Decl,
4462 Expander_Status => Expander_Active,
4463 Current_Sem_Unit => Current_Sem_Unit,
4464 Scope_Suppress => Scope_Suppress,
4465 Local_Suppress_Stack_Top => Local_Suppress_Stack_Top,
4466 Version => Ada_Version,
4467 Version_Pragma => Ada_Version_Pragma,
4468 Warnings => Save_Warnings,
4469 SPARK_Mode => SPARK_Mode,
4470 SPARK_Mode_Pragma => SPARK_Mode_Pragma)),
4471 Inlined_Body => True);
4473 Pop_Scope;
4475 -- Restore context
4477 Set_Is_Immediately_Visible (Gen_Comp, Vis);
4479 -- Reset Generic_Instance flag so that use clauses can be installed
4480 -- in the proper order. (See Use_One_Package for effect of enclosing
4481 -- instances on processing of use clauses).
4483 for J in 1 .. N_Instances loop
4484 Set_Is_Generic_Instance (Instances (J), False);
4485 end loop;
4487 if Removed then
4488 Install_Context (Curr_Comp);
4490 if Present (Curr_Scope)
4491 and then Is_Child_Unit (Curr_Scope)
4492 then
4493 Push_Scope (Curr_Scope);
4494 Set_Is_Immediately_Visible (Curr_Scope);
4496 -- Finally, restore inner scopes as well
4498 for J in reverse 1 .. Num_Inner loop
4499 Push_Scope (Inner_Scopes (J));
4500 end loop;
4501 end if;
4503 Restore_Scope_Stack (List, Handle_Use => False);
4505 if Present (Curr_Scope)
4506 and then
4507 (In_Private_Part (Curr_Scope)
4508 or else In_Package_Body (Curr_Scope))
4509 then
4510 -- Install private declaration of ancestor units, which are
4511 -- currently available. Restore_Scope_Stack and Install_Context
4512 -- only install the visible part of parents.
4514 declare
4515 Par : Entity_Id;
4516 begin
4517 Par := Scope (Curr_Scope);
4518 while (Present (Par))
4519 and then Par /= Standard_Standard
4520 loop
4521 Install_Private_Declarations (Par);
4522 Par := Scope (Par);
4523 end loop;
4524 end;
4525 end if;
4526 end if;
4528 -- Restore use clauses. For a child unit, use clauses in the parents
4529 -- are restored when installing the context, so only those in inner
4530 -- scopes (and those local to the child unit itself) need to be
4531 -- installed explicitly.
4533 if Is_Child_Unit (Curr_Unit)
4534 and then Removed
4535 then
4536 for J in reverse 1 .. Num_Inner + 1 loop
4537 Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause :=
4538 Use_Clauses (J);
4539 Install_Use_Clauses (Use_Clauses (J));
4540 end loop;
4542 else
4543 for J in reverse 1 .. Num_Scopes loop
4544 Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause :=
4545 Use_Clauses (J);
4546 Install_Use_Clauses (Use_Clauses (J));
4547 end loop;
4548 end if;
4550 -- Restore status of instances. If one of them is a body, make its
4551 -- local entities visible again.
4553 declare
4554 E : Entity_Id;
4555 Inst : Entity_Id;
4557 begin
4558 for J in 1 .. N_Instances loop
4559 Inst := Instances (J);
4560 Set_Is_Generic_Instance (Inst, True);
4562 if In_Package_Body (Inst)
4563 or else Ekind (S) = E_Procedure
4564 or else Ekind (S) = E_Function
4565 then
4566 E := First_Entity (Instances (J));
4567 while Present (E) loop
4568 Set_Is_Immediately_Visible (E);
4569 Next_Entity (E);
4570 end loop;
4571 end if;
4572 end loop;
4573 end;
4575 -- If generic unit is in current unit, current context is correct
4577 else
4578 Instantiate_Package_Body
4579 (Body_Info =>
4580 ((Inst_Node => N,
4581 Act_Decl => Act_Decl,
4582 Expander_Status => Expander_Active,
4583 Current_Sem_Unit => Current_Sem_Unit,
4584 Scope_Suppress => Scope_Suppress,
4585 Local_Suppress_Stack_Top => Local_Suppress_Stack_Top,
4586 Version => Ada_Version,
4587 Version_Pragma => Ada_Version_Pragma,
4588 Warnings => Save_Warnings,
4589 SPARK_Mode => SPARK_Mode,
4590 SPARK_Mode_Pragma => SPARK_Mode_Pragma)),
4591 Inlined_Body => True);
4592 end if;
4593 end Inline_Instance_Body;
4595 -------------------------------------
4596 -- Analyze_Procedure_Instantiation --
4597 -------------------------------------
4599 procedure Analyze_Procedure_Instantiation (N : Node_Id) is
4600 begin
4601 Analyze_Subprogram_Instantiation (N, E_Procedure);
4602 end Analyze_Procedure_Instantiation;
4604 -----------------------------------
4605 -- Need_Subprogram_Instance_Body --
4606 -----------------------------------
4608 function Need_Subprogram_Instance_Body
4609 (N : Node_Id;
4610 Subp : Entity_Id) return Boolean
4612 begin
4613 -- Must be inlined (or inlined renaming)
4615 if (Is_In_Main_Unit (N)
4616 or else Is_Inlined (Subp)
4617 or else Is_Inlined (Alias (Subp)))
4619 -- Must be generating code or analyzing code in ASIS/GNATprove mode
4621 and then (Operating_Mode = Generate_Code
4622 or else (Operating_Mode = Check_Semantics
4623 and then (ASIS_Mode or GNATprove_Mode)))
4625 -- The body is needed when generating code (full expansion), in ASIS
4626 -- mode for other tools, and in GNATprove mode (special expansion) for
4627 -- formal verification of the body itself.
4629 and then (Expander_Active or ASIS_Mode or GNATprove_Mode)
4631 -- No point in inlining if ABE is inevitable
4633 and then not ABE_Is_Certain (N)
4635 -- Or if subprogram is eliminated
4637 and then not Is_Eliminated (Subp)
4638 then
4639 Pending_Instantiations.Append
4640 ((Inst_Node => N,
4641 Act_Decl => Unit_Declaration_Node (Subp),
4642 Expander_Status => Expander_Active,
4643 Current_Sem_Unit => Current_Sem_Unit,
4644 Scope_Suppress => Scope_Suppress,
4645 Local_Suppress_Stack_Top => Local_Suppress_Stack_Top,
4646 Version => Ada_Version,
4647 Version_Pragma => Ada_Version_Pragma,
4648 Warnings => Save_Warnings,
4649 SPARK_Mode => SPARK_Mode,
4650 SPARK_Mode_Pragma => SPARK_Mode_Pragma));
4651 return True;
4653 -- Here if not inlined, or we ignore the inlining
4655 else
4656 return False;
4657 end if;
4658 end Need_Subprogram_Instance_Body;
4660 --------------------------------------
4661 -- Analyze_Subprogram_Instantiation --
4662 --------------------------------------
4664 procedure Analyze_Subprogram_Instantiation
4665 (N : Node_Id;
4666 K : Entity_Kind)
4668 Loc : constant Source_Ptr := Sloc (N);
4669 Gen_Id : constant Node_Id := Name (N);
4671 Anon_Id : constant Entity_Id :=
4672 Make_Defining_Identifier (Sloc (Defining_Entity (N)),
4673 Chars => New_External_Name
4674 (Chars (Defining_Entity (N)), 'R'));
4676 Act_Decl_Id : Entity_Id;
4677 Act_Decl : Node_Id;
4678 Act_Spec : Node_Id;
4679 Act_Tree : Node_Id;
4681 Env_Installed : Boolean := False;
4682 Gen_Unit : Entity_Id;
4683 Gen_Decl : Node_Id;
4684 Pack_Id : Entity_Id;
4685 Parent_Installed : Boolean := False;
4686 Renaming_List : List_Id;
4688 procedure Analyze_Instance_And_Renamings;
4689 -- The instance must be analyzed in a context that includes the mappings
4690 -- of generic parameters into actuals. We create a package declaration
4691 -- for this purpose, and a subprogram with an internal name within the
4692 -- package. The subprogram instance is simply an alias for the internal
4693 -- subprogram, declared in the current scope.
4695 ------------------------------------
4696 -- Analyze_Instance_And_Renamings --
4697 ------------------------------------
4699 procedure Analyze_Instance_And_Renamings is
4700 Def_Ent : constant Entity_Id := Defining_Entity (N);
4701 Pack_Decl : Node_Id;
4703 begin
4704 if Nkind (Parent (N)) = N_Compilation_Unit then
4706 -- For the case of a compilation unit, the container package has
4707 -- the same name as the instantiation, to insure that the binder
4708 -- calls the elaboration procedure with the right name. Copy the
4709 -- entity of the instance, which may have compilation level flags
4710 -- (e.g. Is_Child_Unit) set.
4712 Pack_Id := New_Copy (Def_Ent);
4714 else
4715 -- Otherwise we use the name of the instantiation concatenated
4716 -- with its source position to ensure uniqueness if there are
4717 -- several instantiations with the same name.
4719 Pack_Id :=
4720 Make_Defining_Identifier (Loc,
4721 Chars => New_External_Name
4722 (Related_Id => Chars (Def_Ent),
4723 Suffix => "GP",
4724 Suffix_Index => Source_Offset (Sloc (Def_Ent))));
4725 end if;
4727 Pack_Decl := Make_Package_Declaration (Loc,
4728 Specification => Make_Package_Specification (Loc,
4729 Defining_Unit_Name => Pack_Id,
4730 Visible_Declarations => Renaming_List,
4731 End_Label => Empty));
4733 Set_Instance_Spec (N, Pack_Decl);
4734 Set_Is_Generic_Instance (Pack_Id);
4735 Set_Debug_Info_Needed (Pack_Id);
4737 -- Case of not a compilation unit
4739 if Nkind (Parent (N)) /= N_Compilation_Unit then
4740 Mark_Rewrite_Insertion (Pack_Decl);
4741 Insert_Before (N, Pack_Decl);
4742 Set_Has_Completion (Pack_Id);
4744 -- Case of an instantiation that is a compilation unit
4746 -- Place declaration on current node so context is complete for
4747 -- analysis (including nested instantiations), and for use in a
4748 -- context_clause (see Analyze_With_Clause).
4750 else
4751 Set_Unit (Parent (N), Pack_Decl);
4752 Set_Parent_Spec (Pack_Decl, Parent_Spec (N));
4753 end if;
4755 Analyze (Pack_Decl);
4756 Check_Formal_Packages (Pack_Id);
4757 Set_Is_Generic_Instance (Pack_Id, False);
4759 -- Why do we clear Is_Generic_Instance??? We set it 20 lines
4760 -- above???
4762 -- Body of the enclosing package is supplied when instantiating the
4763 -- subprogram body, after semantic analysis is completed.
4765 if Nkind (Parent (N)) = N_Compilation_Unit then
4767 -- Remove package itself from visibility, so it does not
4768 -- conflict with subprogram.
4770 Set_Name_Entity_Id (Chars (Pack_Id), Homonym (Pack_Id));
4772 -- Set name and scope of internal subprogram so that the proper
4773 -- external name will be generated. The proper scope is the scope
4774 -- of the wrapper package. We need to generate debugging info for
4775 -- the internal subprogram, so set flag accordingly.
4777 Set_Chars (Anon_Id, Chars (Defining_Entity (N)));
4778 Set_Scope (Anon_Id, Scope (Pack_Id));
4780 -- Mark wrapper package as referenced, to avoid spurious warnings
4781 -- if the instantiation appears in various with_ clauses of
4782 -- subunits of the main unit.
4784 Set_Referenced (Pack_Id);
4785 end if;
4787 Set_Is_Generic_Instance (Anon_Id);
4788 Set_Debug_Info_Needed (Anon_Id);
4789 Act_Decl_Id := New_Copy (Anon_Id);
4791 Set_Parent (Act_Decl_Id, Parent (Anon_Id));
4792 Set_Chars (Act_Decl_Id, Chars (Defining_Entity (N)));
4793 Set_Sloc (Act_Decl_Id, Sloc (Defining_Entity (N)));
4794 Set_Comes_From_Source (Act_Decl_Id, True);
4796 -- The signature may involve types that are not frozen yet, but the
4797 -- subprogram will be frozen at the point the wrapper package is
4798 -- frozen, so it does not need its own freeze node. In fact, if one
4799 -- is created, it might conflict with the freezing actions from the
4800 -- wrapper package.
4802 Set_Has_Delayed_Freeze (Anon_Id, False);
4804 -- If the instance is a child unit, mark the Id accordingly. Mark
4805 -- the anonymous entity as well, which is the real subprogram and
4806 -- which is used when the instance appears in a context clause.
4807 -- Similarly, propagate the Is_Eliminated flag to handle properly
4808 -- nested eliminated subprograms.
4810 Set_Is_Child_Unit (Act_Decl_Id, Is_Child_Unit (Defining_Entity (N)));
4811 Set_Is_Child_Unit (Anon_Id, Is_Child_Unit (Defining_Entity (N)));
4812 New_Overloaded_Entity (Act_Decl_Id);
4813 Check_Eliminated (Act_Decl_Id);
4814 Set_Is_Eliminated (Anon_Id, Is_Eliminated (Act_Decl_Id));
4816 -- In compilation unit case, kill elaboration checks on the
4817 -- instantiation, since they are never needed -- the body is
4818 -- instantiated at the same point as the spec.
4820 if Nkind (Parent (N)) = N_Compilation_Unit then
4821 Set_Suppress_Elaboration_Warnings (Act_Decl_Id);
4822 Set_Kill_Elaboration_Checks (Act_Decl_Id);
4823 Set_Is_Compilation_Unit (Anon_Id);
4825 Set_Cunit_Entity (Current_Sem_Unit, Pack_Id);
4826 end if;
4828 -- The instance is not a freezing point for the new subprogram
4830 Set_Is_Frozen (Act_Decl_Id, False);
4832 if Nkind (Defining_Entity (N)) = N_Defining_Operator_Symbol then
4833 Valid_Operator_Definition (Act_Decl_Id);
4834 end if;
4836 Set_Alias (Act_Decl_Id, Anon_Id);
4837 Set_Parent (Act_Decl_Id, Parent (Anon_Id));
4838 Set_Has_Completion (Act_Decl_Id);
4839 Set_Related_Instance (Pack_Id, Act_Decl_Id);
4841 if Nkind (Parent (N)) = N_Compilation_Unit then
4842 Set_Body_Required (Parent (N), False);
4843 end if;
4844 end Analyze_Instance_And_Renamings;
4846 -- Local variables
4848 Save_IPSM : constant Boolean := Ignore_Pragma_SPARK_Mode;
4849 -- Save flag Ignore_Pragma_SPARK_Mode for restore on exit
4851 Save_SM : constant SPARK_Mode_Type := SPARK_Mode;
4852 Save_SMP : constant Node_Id := SPARK_Mode_Pragma;
4853 -- Save the SPARK_Mode-related data for restore on exit
4855 Vis_Prims_List : Elist_Id := No_Elist;
4856 -- List of primitives made temporarily visible in the instantiation
4857 -- to match the visibility of the formal type
4859 -- Start of processing for Analyze_Subprogram_Instantiation
4861 begin
4862 Check_SPARK_05_Restriction ("generic is not allowed", N);
4864 -- Very first thing: check for special Text_IO unit in case we are
4865 -- instantiating one of the children of [[Wide_]Wide_]Text_IO. Of course
4866 -- such an instantiation is bogus (these are packages, not subprograms),
4867 -- but we get a better error message if we do this.
4869 Check_Text_IO_Special_Unit (Gen_Id);
4871 -- Make node global for error reporting
4873 Instantiation_Node := N;
4875 -- For package instantiations we turn off style checks, because they
4876 -- will have been emitted in the generic. For subprogram instantiations
4877 -- we want to apply at least the check on overriding indicators so we
4878 -- do not modify the style check status.
4880 -- The renaming declarations for the actuals do not come from source and
4881 -- will not generate spurious warnings.
4883 Preanalyze_Actuals (N);
4885 Init_Env;
4886 Env_Installed := True;
4887 Check_Generic_Child_Unit (Gen_Id, Parent_Installed);
4888 Gen_Unit := Entity (Gen_Id);
4890 Generate_Reference (Gen_Unit, Gen_Id);
4892 if Nkind (Gen_Id) = N_Identifier
4893 and then Chars (Gen_Unit) = Chars (Defining_Entity (N))
4894 then
4895 Error_Msg_NE
4896 ("& is hidden within declaration of instance", Gen_Id, Gen_Unit);
4897 end if;
4899 if Etype (Gen_Unit) = Any_Type then
4900 Restore_Env;
4901 return;
4902 end if;
4904 -- Verify that it is a generic subprogram of the right kind, and that
4905 -- it does not lead to a circular instantiation.
4907 if K = E_Procedure and then Ekind (Gen_Unit) /= E_Generic_Procedure then
4908 Error_Msg_NE
4909 ("& is not the name of a generic procedure", Gen_Id, Gen_Unit);
4911 elsif K = E_Function and then Ekind (Gen_Unit) /= E_Generic_Function then
4912 Error_Msg_NE
4913 ("& is not the name of a generic function", Gen_Id, Gen_Unit);
4915 elsif In_Open_Scopes (Gen_Unit) then
4916 Error_Msg_NE ("instantiation of & within itself", N, Gen_Unit);
4918 else
4919 -- If the context of the instance is subject to SPARK_Mode "off",
4920 -- set the global flag which signals Analyze_Pragma to ignore all
4921 -- SPARK_Mode pragmas within the instance.
4923 if SPARK_Mode = Off then
4924 Ignore_Pragma_SPARK_Mode := True;
4925 end if;
4927 Set_Entity (Gen_Id, Gen_Unit);
4928 Set_Is_Instantiated (Gen_Unit);
4930 if In_Extended_Main_Source_Unit (N) then
4931 Generate_Reference (Gen_Unit, N);
4932 end if;
4934 -- If renaming, get original unit
4936 if Present (Renamed_Object (Gen_Unit))
4937 and then (Ekind (Renamed_Object (Gen_Unit)) = E_Generic_Procedure
4938 or else
4939 Ekind (Renamed_Object (Gen_Unit)) = E_Generic_Function)
4940 then
4941 Gen_Unit := Renamed_Object (Gen_Unit);
4942 Set_Is_Instantiated (Gen_Unit);
4943 Generate_Reference (Gen_Unit, N);
4944 end if;
4946 if Contains_Instance_Of (Gen_Unit, Current_Scope, Gen_Id) then
4947 Error_Msg_Node_2 := Current_Scope;
4948 Error_Msg_NE
4949 ("circular Instantiation: & instantiated in &!", N, Gen_Unit);
4950 Circularity_Detected := True;
4951 Restore_Hidden_Primitives (Vis_Prims_List);
4952 goto Leave;
4953 end if;
4955 Gen_Decl := Unit_Declaration_Node (Gen_Unit);
4957 -- Initialize renamings map, for error checking
4959 Generic_Renamings.Set_Last (0);
4960 Generic_Renamings_HTable.Reset;
4962 Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment);
4964 -- Copy original generic tree, to produce text for instantiation
4966 Act_Tree :=
4967 Copy_Generic_Node
4968 (Original_Node (Gen_Decl), Empty, Instantiating => True);
4970 -- Inherit overriding indicator from instance node
4972 Act_Spec := Specification (Act_Tree);
4973 Set_Must_Override (Act_Spec, Must_Override (N));
4974 Set_Must_Not_Override (Act_Spec, Must_Not_Override (N));
4976 Renaming_List :=
4977 Analyze_Associations
4978 (I_Node => N,
4979 Formals => Generic_Formal_Declarations (Act_Tree),
4980 F_Copy => Generic_Formal_Declarations (Gen_Decl));
4982 Vis_Prims_List := Check_Hidden_Primitives (Renaming_List);
4984 -- The subprogram itself cannot contain a nested instance, so the
4985 -- current parent is left empty.
4987 Set_Instance_Env (Gen_Unit, Empty);
4989 -- Build the subprogram declaration, which does not appear in the
4990 -- generic template, and give it a sloc consistent with that of the
4991 -- template.
4993 Set_Defining_Unit_Name (Act_Spec, Anon_Id);
4994 Set_Generic_Parent (Act_Spec, Gen_Unit);
4995 Act_Decl :=
4996 Make_Subprogram_Declaration (Sloc (Act_Spec),
4997 Specification => Act_Spec);
4999 -- The aspects have been copied previously, but they have to be
5000 -- linked explicitly to the new subprogram declaration. Explicit
5001 -- pre/postconditions on the instance are analyzed below, in a
5002 -- separate step.
5004 Move_Aspects (Act_Tree, To => Act_Decl);
5005 Set_Categorization_From_Pragmas (Act_Decl);
5007 if Parent_Installed then
5008 Hide_Current_Scope;
5009 end if;
5011 Append (Act_Decl, Renaming_List);
5012 Analyze_Instance_And_Renamings;
5014 -- If the generic is marked Import (Intrinsic), then so is the
5015 -- instance. This indicates that there is no body to instantiate. If
5016 -- generic is marked inline, so it the instance, and the anonymous
5017 -- subprogram it renames. If inlined, or else if inlining is enabled
5018 -- for the compilation, we generate the instance body even if it is
5019 -- not within the main unit.
5021 if Is_Intrinsic_Subprogram (Gen_Unit) then
5022 Set_Is_Intrinsic_Subprogram (Anon_Id);
5023 Set_Is_Intrinsic_Subprogram (Act_Decl_Id);
5025 if Chars (Gen_Unit) = Name_Unchecked_Conversion then
5026 Validate_Unchecked_Conversion (N, Act_Decl_Id);
5027 end if;
5028 end if;
5030 -- Inherit convention from generic unit. Intrinsic convention, as for
5031 -- an instance of unchecked conversion, is not inherited because an
5032 -- explicit Ada instance has been created.
5034 if Has_Convention_Pragma (Gen_Unit)
5035 and then Convention (Gen_Unit) /= Convention_Intrinsic
5036 then
5037 Set_Convention (Act_Decl_Id, Convention (Gen_Unit));
5038 Set_Is_Exported (Act_Decl_Id, Is_Exported (Gen_Unit));
5039 end if;
5041 Generate_Definition (Act_Decl_Id);
5042 -- Set_Contract (Anon_Id, Make_Contract (Sloc (Anon_Id)));
5043 -- ??? needed?
5044 Set_Contract (Act_Decl_Id, Make_Contract (Sloc (Act_Decl_Id)));
5046 -- Inherit all inlining-related flags which apply to the generic in
5047 -- the subprogram and its declaration.
5049 Set_Is_Inlined (Act_Decl_Id, Is_Inlined (Gen_Unit));
5050 Set_Is_Inlined (Anon_Id, Is_Inlined (Gen_Unit));
5052 Set_Has_Pragma_Inline (Act_Decl_Id, Has_Pragma_Inline (Gen_Unit));
5053 Set_Has_Pragma_Inline (Anon_Id, Has_Pragma_Inline (Gen_Unit));
5055 Set_Has_Pragma_Inline_Always
5056 (Act_Decl_Id, Has_Pragma_Inline_Always (Gen_Unit));
5057 Set_Has_Pragma_Inline_Always
5058 (Anon_Id, Has_Pragma_Inline_Always (Gen_Unit));
5060 if not Is_Intrinsic_Subprogram (Gen_Unit) then
5061 Check_Elab_Instantiation (N);
5062 end if;
5064 if Is_Dispatching_Operation (Act_Decl_Id)
5065 and then Ada_Version >= Ada_2005
5066 then
5067 declare
5068 Formal : Entity_Id;
5070 begin
5071 Formal := First_Formal (Act_Decl_Id);
5072 while Present (Formal) loop
5073 if Ekind (Etype (Formal)) = E_Anonymous_Access_Type
5074 and then Is_Controlling_Formal (Formal)
5075 and then not Can_Never_Be_Null (Formal)
5076 then
5077 Error_Msg_NE ("access parameter& is controlling,",
5078 N, Formal);
5079 Error_Msg_NE
5080 ("\corresponding parameter of & must be"
5081 & " explicitly null-excluding", N, Gen_Id);
5082 end if;
5084 Next_Formal (Formal);
5085 end loop;
5086 end;
5087 end if;
5089 Check_Hidden_Child_Unit (N, Gen_Unit, Act_Decl_Id);
5091 Validate_Categorization_Dependency (N, Act_Decl_Id);
5093 if not Is_Intrinsic_Subprogram (Act_Decl_Id) then
5094 Inherit_Context (Gen_Decl, N);
5096 Restore_Private_Views (Pack_Id, False);
5098 -- If the context requires a full instantiation, mark node for
5099 -- subsequent construction of the body.
5101 if Need_Subprogram_Instance_Body (N, Act_Decl_Id) then
5102 Check_Forward_Instantiation (Gen_Decl);
5104 -- The wrapper package is always delayed, because it does not
5105 -- constitute a freeze point, but to insure that the freeze
5106 -- node is placed properly, it is created directly when
5107 -- instantiating the body (otherwise the freeze node might
5108 -- appear to early for nested instantiations).
5110 elsif Nkind (Parent (N)) = N_Compilation_Unit then
5112 -- For ASIS purposes, indicate that the wrapper package has
5113 -- replaced the instantiation node.
5115 Rewrite (N, Unit (Parent (N)));
5116 Set_Unit (Parent (N), N);
5117 end if;
5119 elsif Nkind (Parent (N)) = N_Compilation_Unit then
5121 -- Replace instance node for library-level instantiations of
5122 -- intrinsic subprograms, for ASIS use.
5124 Rewrite (N, Unit (Parent (N)));
5125 Set_Unit (Parent (N), N);
5126 end if;
5128 if Parent_Installed then
5129 Remove_Parent;
5130 end if;
5132 Restore_Hidden_Primitives (Vis_Prims_List);
5133 Restore_Env;
5134 Env_Installed := False;
5135 Generic_Renamings.Set_Last (0);
5136 Generic_Renamings_HTable.Reset;
5138 Ignore_Pragma_SPARK_Mode := Save_IPSM;
5139 SPARK_Mode := Save_SM;
5140 SPARK_Mode_Pragma := Save_SMP;
5141 end if;
5143 <<Leave>>
5144 if Has_Aspects (N) then
5145 Analyze_Aspect_Specifications (N, Act_Decl_Id);
5146 end if;
5148 exception
5149 when Instantiation_Error =>
5150 if Parent_Installed then
5151 Remove_Parent;
5152 end if;
5154 if Env_Installed then
5155 Restore_Env;
5156 end if;
5158 Ignore_Pragma_SPARK_Mode := Save_IPSM;
5159 SPARK_Mode := Save_SM;
5160 SPARK_Mode_Pragma := Save_SMP;
5161 end Analyze_Subprogram_Instantiation;
5163 -------------------------
5164 -- Get_Associated_Node --
5165 -------------------------
5167 function Get_Associated_Node (N : Node_Id) return Node_Id is
5168 Assoc : Node_Id;
5170 begin
5171 Assoc := Associated_Node (N);
5173 if Nkind (Assoc) /= Nkind (N) then
5174 return Assoc;
5176 elsif Nkind_In (Assoc, N_Aggregate, N_Extension_Aggregate) then
5177 return Assoc;
5179 else
5180 -- If the node is part of an inner generic, it may itself have been
5181 -- remapped into a further generic copy. Associated_Node is otherwise
5182 -- used for the entity of the node, and will be of a different node
5183 -- kind, or else N has been rewritten as a literal or function call.
5185 while Present (Associated_Node (Assoc))
5186 and then Nkind (Associated_Node (Assoc)) = Nkind (Assoc)
5187 loop
5188 Assoc := Associated_Node (Assoc);
5189 end loop;
5191 -- Follow and additional link in case the final node was rewritten.
5192 -- This can only happen with nested generic units.
5194 if (Nkind (Assoc) = N_Identifier or else Nkind (Assoc) in N_Op)
5195 and then Present (Associated_Node (Assoc))
5196 and then (Nkind_In (Associated_Node (Assoc), N_Function_Call,
5197 N_Explicit_Dereference,
5198 N_Integer_Literal,
5199 N_Real_Literal,
5200 N_String_Literal))
5201 then
5202 Assoc := Associated_Node (Assoc);
5203 end if;
5205 -- An additional special case: an unconstrained type in an object
5206 -- declaration may have been rewritten as a local subtype constrained
5207 -- by the expression in the declaration. We need to recover the
5208 -- original entity which may be global.
5210 if Present (Original_Node (Assoc))
5211 and then Nkind (Parent (N)) = N_Object_Declaration
5212 then
5213 Assoc := Original_Node (Assoc);
5214 end if;
5216 return Assoc;
5217 end if;
5218 end Get_Associated_Node;
5220 -------------------------------------------
5221 -- Build_Instance_Compilation_Unit_Nodes --
5222 -------------------------------------------
5224 procedure Build_Instance_Compilation_Unit_Nodes
5225 (N : Node_Id;
5226 Act_Body : Node_Id;
5227 Act_Decl : Node_Id)
5229 Decl_Cunit : Node_Id;
5230 Body_Cunit : Node_Id;
5231 Citem : Node_Id;
5232 New_Main : constant Entity_Id := Defining_Entity (Act_Decl);
5233 Old_Main : constant Entity_Id := Cunit_Entity (Main_Unit);
5235 begin
5236 -- A new compilation unit node is built for the instance declaration
5238 Decl_Cunit :=
5239 Make_Compilation_Unit (Sloc (N),
5240 Context_Items => Empty_List,
5241 Unit => Act_Decl,
5242 Aux_Decls_Node => Make_Compilation_Unit_Aux (Sloc (N)));
5244 Set_Parent_Spec (Act_Decl, Parent_Spec (N));
5246 -- The new compilation unit is linked to its body, but both share the
5247 -- same file, so we do not set Body_Required on the new unit so as not
5248 -- to create a spurious dependency on a non-existent body in the ali.
5249 -- This simplifies CodePeer unit traversal.
5251 -- We use the original instantiation compilation unit as the resulting
5252 -- compilation unit of the instance, since this is the main unit.
5254 Rewrite (N, Act_Body);
5256 -- Propagate the aspect specifications from the package body template to
5257 -- the instantiated version of the package body.
5259 if Has_Aspects (Act_Body) then
5260 Set_Aspect_Specifications
5261 (N, New_Copy_List_Tree (Aspect_Specifications (Act_Body)));
5262 end if;
5264 Body_Cunit := Parent (N);
5266 -- The two compilation unit nodes are linked by the Library_Unit field
5268 Set_Library_Unit (Decl_Cunit, Body_Cunit);
5269 Set_Library_Unit (Body_Cunit, Decl_Cunit);
5271 -- Preserve the private nature of the package if needed
5273 Set_Private_Present (Decl_Cunit, Private_Present (Body_Cunit));
5275 -- If the instance is not the main unit, its context, categorization
5276 -- and elaboration entity are not relevant to the compilation.
5278 if Body_Cunit /= Cunit (Main_Unit) then
5279 Make_Instance_Unit (Body_Cunit, In_Main => False);
5280 return;
5281 end if;
5283 -- The context clause items on the instantiation, which are now attached
5284 -- to the body compilation unit (since the body overwrote the original
5285 -- instantiation node), semantically belong on the spec, so copy them
5286 -- there. It's harmless to leave them on the body as well. In fact one
5287 -- could argue that they belong in both places.
5289 Citem := First (Context_Items (Body_Cunit));
5290 while Present (Citem) loop
5291 Append (New_Copy (Citem), Context_Items (Decl_Cunit));
5292 Next (Citem);
5293 end loop;
5295 -- Propagate categorization flags on packages, so that they appear in
5296 -- the ali file for the spec of the unit.
5298 if Ekind (New_Main) = E_Package then
5299 Set_Is_Pure (Old_Main, Is_Pure (New_Main));
5300 Set_Is_Preelaborated (Old_Main, Is_Preelaborated (New_Main));
5301 Set_Is_Remote_Types (Old_Main, Is_Remote_Types (New_Main));
5302 Set_Is_Shared_Passive (Old_Main, Is_Shared_Passive (New_Main));
5303 Set_Is_Remote_Call_Interface
5304 (Old_Main, Is_Remote_Call_Interface (New_Main));
5305 end if;
5307 -- Make entry in Units table, so that binder can generate call to
5308 -- elaboration procedure for body, if any.
5310 Make_Instance_Unit (Body_Cunit, In_Main => True);
5311 Main_Unit_Entity := New_Main;
5312 Set_Cunit_Entity (Main_Unit, Main_Unit_Entity);
5314 -- Build elaboration entity, since the instance may certainly generate
5315 -- elaboration code requiring a flag for protection.
5317 Build_Elaboration_Entity (Decl_Cunit, New_Main);
5318 end Build_Instance_Compilation_Unit_Nodes;
5320 -----------------------------
5321 -- Check_Access_Definition --
5322 -----------------------------
5324 procedure Check_Access_Definition (N : Node_Id) is
5325 begin
5326 pragma Assert
5327 (Ada_Version >= Ada_2005 and then Present (Access_Definition (N)));
5328 null;
5329 end Check_Access_Definition;
5331 -----------------------------------
5332 -- Check_Formal_Package_Instance --
5333 -----------------------------------
5335 -- If the formal has specific parameters, they must match those of the
5336 -- actual. Both of them are instances, and the renaming declarations for
5337 -- their formal parameters appear in the same order in both. The analyzed
5338 -- formal has been analyzed in the context of the current instance.
5340 procedure Check_Formal_Package_Instance
5341 (Formal_Pack : Entity_Id;
5342 Actual_Pack : Entity_Id)
5344 E1 : Entity_Id := First_Entity (Actual_Pack);
5345 E2 : Entity_Id := First_Entity (Formal_Pack);
5347 Expr1 : Node_Id;
5348 Expr2 : Node_Id;
5350 procedure Check_Mismatch (B : Boolean);
5351 -- Common error routine for mismatch between the parameters of the
5352 -- actual instance and those of the formal package.
5354 function Same_Instantiated_Constant (E1, E2 : Entity_Id) return Boolean;
5355 -- The formal may come from a nested formal package, and the actual may
5356 -- have been constant-folded. To determine whether the two denote the
5357 -- same entity we may have to traverse several definitions to recover
5358 -- the ultimate entity that they refer to.
5360 function Same_Instantiated_Variable (E1, E2 : Entity_Id) return Boolean;
5361 -- Similarly, if the formal comes from a nested formal package, the
5362 -- actual may designate the formal through multiple renamings, which
5363 -- have to be followed to determine the original variable in question.
5365 --------------------
5366 -- Check_Mismatch --
5367 --------------------
5369 procedure Check_Mismatch (B : Boolean) is
5370 Kind : constant Node_Kind := Nkind (Parent (E2));
5372 begin
5373 if Kind = N_Formal_Type_Declaration then
5374 return;
5376 elsif Nkind_In (Kind, N_Formal_Object_Declaration,
5377 N_Formal_Package_Declaration)
5378 or else Kind in N_Formal_Subprogram_Declaration
5379 then
5380 null;
5382 elsif B then
5383 Error_Msg_NE
5384 ("actual for & in actual instance does not match formal",
5385 Parent (Actual_Pack), E1);
5386 end if;
5387 end Check_Mismatch;
5389 --------------------------------
5390 -- Same_Instantiated_Constant --
5391 --------------------------------
5393 function Same_Instantiated_Constant
5394 (E1, E2 : Entity_Id) return Boolean
5396 Ent : Entity_Id;
5398 begin
5399 Ent := E2;
5400 while Present (Ent) loop
5401 if E1 = Ent then
5402 return True;
5404 elsif Ekind (Ent) /= E_Constant then
5405 return False;
5407 elsif Is_Entity_Name (Constant_Value (Ent)) then
5408 if Entity (Constant_Value (Ent)) = E1 then
5409 return True;
5410 else
5411 Ent := Entity (Constant_Value (Ent));
5412 end if;
5414 -- The actual may be a constant that has been folded. Recover
5415 -- original name.
5417 elsif Is_Entity_Name (Original_Node (Constant_Value (Ent))) then
5418 Ent := Entity (Original_Node (Constant_Value (Ent)));
5419 else
5420 return False;
5421 end if;
5422 end loop;
5424 return False;
5425 end Same_Instantiated_Constant;
5427 --------------------------------
5428 -- Same_Instantiated_Variable --
5429 --------------------------------
5431 function Same_Instantiated_Variable
5432 (E1, E2 : Entity_Id) return Boolean
5434 function Original_Entity (E : Entity_Id) return Entity_Id;
5435 -- Follow chain of renamings to the ultimate ancestor
5437 ---------------------
5438 -- Original_Entity --
5439 ---------------------
5441 function Original_Entity (E : Entity_Id) return Entity_Id is
5442 Orig : Entity_Id;
5444 begin
5445 Orig := E;
5446 while Nkind (Parent (Orig)) = N_Object_Renaming_Declaration
5447 and then Present (Renamed_Object (Orig))
5448 and then Is_Entity_Name (Renamed_Object (Orig))
5449 loop
5450 Orig := Entity (Renamed_Object (Orig));
5451 end loop;
5453 return Orig;
5454 end Original_Entity;
5456 -- Start of processing for Same_Instantiated_Variable
5458 begin
5459 return Ekind (E1) = Ekind (E2)
5460 and then Original_Entity (E1) = Original_Entity (E2);
5461 end Same_Instantiated_Variable;
5463 -- Start of processing for Check_Formal_Package_Instance
5465 begin
5466 while Present (E1)
5467 and then Present (E2)
5468 loop
5469 exit when Ekind (E1) = E_Package
5470 and then Renamed_Entity (E1) = Renamed_Entity (Actual_Pack);
5472 -- If the formal is the renaming of the formal package, this
5473 -- is the end of its formal part, which may occur before the
5474 -- end of the formal part in the actual in the presence of
5475 -- defaulted parameters in the formal package.
5477 exit when Nkind (Parent (E2)) = N_Package_Renaming_Declaration
5478 and then Renamed_Entity (E2) = Scope (E2);
5480 -- The analysis of the actual may generate additional internal
5481 -- entities. If the formal is defaulted, there is no corresponding
5482 -- analysis and the internal entities must be skipped, until we
5483 -- find corresponding entities again.
5485 if Comes_From_Source (E2)
5486 and then not Comes_From_Source (E1)
5487 and then Chars (E1) /= Chars (E2)
5488 then
5489 while Present (E1)
5490 and then Chars (E1) /= Chars (E2)
5491 loop
5492 Next_Entity (E1);
5493 end loop;
5494 end if;
5496 if No (E1) then
5497 return;
5499 -- If the formal entity comes from a formal declaration, it was
5500 -- defaulted in the formal package, and no check is needed on it.
5502 elsif Nkind (Parent (E2)) = N_Formal_Object_Declaration then
5503 goto Next_E;
5505 -- Ditto for defaulted formal subprograms.
5507 elsif Is_Overloadable (E1)
5508 and then Nkind (Unit_Declaration_Node (E2)) in
5509 N_Formal_Subprogram_Declaration
5510 then
5511 goto Next_E;
5513 elsif Is_Type (E1) then
5515 -- Subtypes must statically match. E1, E2 are the local entities
5516 -- that are subtypes of the actuals. Itypes generated for other
5517 -- parameters need not be checked, the check will be performed
5518 -- on the parameters themselves.
5520 -- If E2 is a formal type declaration, it is a defaulted parameter
5521 -- and needs no checking.
5523 if not Is_Itype (E1)
5524 and then not Is_Itype (E2)
5525 then
5526 Check_Mismatch
5527 (not Is_Type (E2)
5528 or else Etype (E1) /= Etype (E2)
5529 or else not Subtypes_Statically_Match (E1, E2));
5530 end if;
5532 elsif Ekind (E1) = E_Constant then
5534 -- IN parameters must denote the same static value, or the same
5535 -- constant, or the literal null.
5537 Expr1 := Expression (Parent (E1));
5539 if Ekind (E2) /= E_Constant then
5540 Check_Mismatch (True);
5541 goto Next_E;
5542 else
5543 Expr2 := Expression (Parent (E2));
5544 end if;
5546 if Is_OK_Static_Expression (Expr1) then
5547 if not Is_OK_Static_Expression (Expr2) then
5548 Check_Mismatch (True);
5550 elsif Is_Discrete_Type (Etype (E1)) then
5551 declare
5552 V1 : constant Uint := Expr_Value (Expr1);
5553 V2 : constant Uint := Expr_Value (Expr2);
5554 begin
5555 Check_Mismatch (V1 /= V2);
5556 end;
5558 elsif Is_Real_Type (Etype (E1)) then
5559 declare
5560 V1 : constant Ureal := Expr_Value_R (Expr1);
5561 V2 : constant Ureal := Expr_Value_R (Expr2);
5562 begin
5563 Check_Mismatch (V1 /= V2);
5564 end;
5566 elsif Is_String_Type (Etype (E1))
5567 and then Nkind (Expr1) = N_String_Literal
5568 then
5569 if Nkind (Expr2) /= N_String_Literal then
5570 Check_Mismatch (True);
5571 else
5572 Check_Mismatch
5573 (not String_Equal (Strval (Expr1), Strval (Expr2)));
5574 end if;
5575 end if;
5577 elsif Is_Entity_Name (Expr1) then
5578 if Is_Entity_Name (Expr2) then
5579 if Entity (Expr1) = Entity (Expr2) then
5580 null;
5581 else
5582 Check_Mismatch
5583 (not Same_Instantiated_Constant
5584 (Entity (Expr1), Entity (Expr2)));
5585 end if;
5586 else
5587 Check_Mismatch (True);
5588 end if;
5590 elsif Is_Entity_Name (Original_Node (Expr1))
5591 and then Is_Entity_Name (Expr2)
5592 and then
5593 Same_Instantiated_Constant
5594 (Entity (Original_Node (Expr1)), Entity (Expr2))
5595 then
5596 null;
5598 elsif Nkind (Expr1) = N_Null then
5599 Check_Mismatch (Nkind (Expr1) /= N_Null);
5601 else
5602 Check_Mismatch (True);
5603 end if;
5605 elsif Ekind (E1) = E_Variable then
5606 Check_Mismatch (not Same_Instantiated_Variable (E1, E2));
5608 elsif Ekind (E1) = E_Package then
5609 Check_Mismatch
5610 (Ekind (E1) /= Ekind (E2)
5611 or else Renamed_Object (E1) /= Renamed_Object (E2));
5613 elsif Is_Overloadable (E1) then
5615 -- Verify that the actual subprograms match. Note that actuals
5616 -- that are attributes are rewritten as subprograms. If the
5617 -- subprogram in the formal package is defaulted, no check is
5618 -- needed. Note that this can only happen in Ada 2005 when the
5619 -- formal package can be partially parameterized.
5621 if Nkind (Unit_Declaration_Node (E1)) =
5622 N_Subprogram_Renaming_Declaration
5623 and then From_Default (Unit_Declaration_Node (E1))
5624 then
5625 null;
5627 -- If the formal package has an "others" box association that
5628 -- covers this formal, there is no need for a check either.
5630 elsif Nkind (Unit_Declaration_Node (E2)) in
5631 N_Formal_Subprogram_Declaration
5632 and then Box_Present (Unit_Declaration_Node (E2))
5633 then
5634 null;
5636 -- No check needed if subprogram is a defaulted null procedure
5638 elsif No (Alias (E2))
5639 and then Ekind (E2) = E_Procedure
5640 and then
5641 Null_Present (Specification (Unit_Declaration_Node (E2)))
5642 then
5643 null;
5645 -- Otherwise the actual in the formal and the actual in the
5646 -- instantiation of the formal must match, up to renamings.
5648 else
5649 Check_Mismatch
5650 (Ekind (E2) /= Ekind (E1) or else (Alias (E1)) /= Alias (E2));
5651 end if;
5653 else
5654 raise Program_Error;
5655 end if;
5657 <<Next_E>>
5658 Next_Entity (E1);
5659 Next_Entity (E2);
5660 end loop;
5661 end Check_Formal_Package_Instance;
5663 ---------------------------
5664 -- Check_Formal_Packages --
5665 ---------------------------
5667 procedure Check_Formal_Packages (P_Id : Entity_Id) is
5668 E : Entity_Id;
5669 Formal_P : Entity_Id;
5671 begin
5672 -- Iterate through the declarations in the instance, looking for package
5673 -- renaming declarations that denote instances of formal packages. Stop
5674 -- when we find the renaming of the current package itself. The
5675 -- declaration for a formal package without a box is followed by an
5676 -- internal entity that repeats the instantiation.
5678 E := First_Entity (P_Id);
5679 while Present (E) loop
5680 if Ekind (E) = E_Package then
5681 if Renamed_Object (E) = P_Id then
5682 exit;
5684 elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then
5685 null;
5687 elsif not Box_Present (Parent (Associated_Formal_Package (E))) then
5688 Formal_P := Next_Entity (E);
5689 Check_Formal_Package_Instance (Formal_P, E);
5691 -- After checking, remove the internal validating package. It
5692 -- is only needed for semantic checks, and as it may contain
5693 -- generic formal declarations it should not reach gigi.
5695 Remove (Unit_Declaration_Node (Formal_P));
5696 end if;
5697 end if;
5699 Next_Entity (E);
5700 end loop;
5701 end Check_Formal_Packages;
5703 ---------------------------------
5704 -- Check_Forward_Instantiation --
5705 ---------------------------------
5707 procedure Check_Forward_Instantiation (Decl : Node_Id) is
5708 S : Entity_Id;
5709 Gen_Comp : Entity_Id := Cunit_Entity (Get_Source_Unit (Decl));
5711 begin
5712 -- The instantiation appears before the generic body if we are in the
5713 -- scope of the unit containing the generic, either in its spec or in
5714 -- the package body, and before the generic body.
5716 if Ekind (Gen_Comp) = E_Package_Body then
5717 Gen_Comp := Spec_Entity (Gen_Comp);
5718 end if;
5720 if In_Open_Scopes (Gen_Comp)
5721 and then No (Corresponding_Body (Decl))
5722 then
5723 S := Current_Scope;
5725 while Present (S)
5726 and then not Is_Compilation_Unit (S)
5727 and then not Is_Child_Unit (S)
5728 loop
5729 if Ekind (S) = E_Package then
5730 Set_Has_Forward_Instantiation (S);
5731 end if;
5733 S := Scope (S);
5734 end loop;
5735 end if;
5736 end Check_Forward_Instantiation;
5738 ---------------------------
5739 -- Check_Generic_Actuals --
5740 ---------------------------
5742 -- The visibility of the actuals may be different between the point of
5743 -- generic instantiation and the instantiation of the body.
5745 procedure Check_Generic_Actuals
5746 (Instance : Entity_Id;
5747 Is_Formal_Box : Boolean)
5749 E : Entity_Id;
5750 Astype : Entity_Id;
5752 function Denotes_Previous_Actual (Typ : Entity_Id) return Boolean;
5753 -- For a formal that is an array type, the component type is often a
5754 -- previous formal in the same unit. The privacy status of the component
5755 -- type will have been examined earlier in the traversal of the
5756 -- corresponding actuals, and this status should not be modified for
5757 -- the array (sub)type itself. However, if the base type of the array
5758 -- (sub)type is private, its full view must be restored in the body to
5759 -- be consistent with subsequent index subtypes, etc.
5761 -- To detect this case we have to rescan the list of formals, which is
5762 -- usually short enough to ignore the resulting inefficiency.
5764 -----------------------------
5765 -- Denotes_Previous_Actual --
5766 -----------------------------
5768 function Denotes_Previous_Actual (Typ : Entity_Id) return Boolean is
5769 Prev : Entity_Id;
5771 begin
5772 Prev := First_Entity (Instance);
5773 while Present (Prev) loop
5774 if Is_Type (Prev)
5775 and then Nkind (Parent (Prev)) = N_Subtype_Declaration
5776 and then Is_Entity_Name (Subtype_Indication (Parent (Prev)))
5777 and then Entity (Subtype_Indication (Parent (Prev))) = Typ
5778 then
5779 return True;
5781 elsif Prev = E then
5782 return False;
5784 else
5785 Next_Entity (Prev);
5786 end if;
5787 end loop;
5789 return False;
5790 end Denotes_Previous_Actual;
5792 -- Start of processing for Check_Generic_Actuals
5794 begin
5795 E := First_Entity (Instance);
5796 while Present (E) loop
5797 if Is_Type (E)
5798 and then Nkind (Parent (E)) = N_Subtype_Declaration
5799 and then Scope (Etype (E)) /= Instance
5800 and then Is_Entity_Name (Subtype_Indication (Parent (E)))
5801 then
5802 if Is_Array_Type (E)
5803 and then not Is_Private_Type (Etype (E))
5804 and then Denotes_Previous_Actual (Component_Type (E))
5805 then
5806 null;
5807 else
5808 Check_Private_View (Subtype_Indication (Parent (E)));
5809 end if;
5811 Set_Is_Generic_Actual_Type (E, True);
5812 Set_Is_Hidden (E, False);
5813 Set_Is_Potentially_Use_Visible (E,
5814 In_Use (Instance));
5816 -- We constructed the generic actual type as a subtype of the
5817 -- supplied type. This means that it normally would not inherit
5818 -- subtype specific attributes of the actual, which is wrong for
5819 -- the generic case.
5821 Astype := Ancestor_Subtype (E);
5823 if No (Astype) then
5825 -- This can happen when E is an itype that is the full view of
5826 -- a private type completed, e.g. with a constrained array. In
5827 -- that case, use the first subtype, which will carry size
5828 -- information. The base type itself is unconstrained and will
5829 -- not carry it.
5831 Astype := First_Subtype (E);
5832 end if;
5834 Set_Size_Info (E, (Astype));
5835 Set_RM_Size (E, RM_Size (Astype));
5836 Set_First_Rep_Item (E, First_Rep_Item (Astype));
5838 if Is_Discrete_Or_Fixed_Point_Type (E) then
5839 Set_RM_Size (E, RM_Size (Astype));
5841 -- In nested instances, the base type of an access actual may
5842 -- itself be private, and need to be exchanged.
5844 elsif Is_Access_Type (E)
5845 and then Is_Private_Type (Etype (E))
5846 then
5847 Check_Private_View
5848 (New_Occurrence_Of (Etype (E), Sloc (Instance)));
5849 end if;
5851 elsif Ekind (E) = E_Package then
5853 -- If this is the renaming for the current instance, we're done.
5854 -- Otherwise it is a formal package. If the corresponding formal
5855 -- was declared with a box, the (instantiations of the) generic
5856 -- formal part are also visible. Otherwise, ignore the entity
5857 -- created to validate the actuals.
5859 if Renamed_Object (E) = Instance then
5860 exit;
5862 elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then
5863 null;
5865 -- The visibility of a formal of an enclosing generic is already
5866 -- correct.
5868 elsif Denotes_Formal_Package (E) then
5869 null;
5871 elsif Present (Associated_Formal_Package (E))
5872 and then not Is_Generic_Formal (E)
5873 then
5874 if Box_Present (Parent (Associated_Formal_Package (E))) then
5875 Check_Generic_Actuals (Renamed_Object (E), True);
5877 else
5878 Check_Generic_Actuals (Renamed_Object (E), False);
5879 end if;
5881 Set_Is_Hidden (E, False);
5882 end if;
5884 -- If this is a subprogram instance (in a wrapper package) the
5885 -- actual is fully visible.
5887 elsif Is_Wrapper_Package (Instance) then
5888 Set_Is_Hidden (E, False);
5890 -- If the formal package is declared with a box, or if the formal
5891 -- parameter is defaulted, it is visible in the body.
5893 elsif Is_Formal_Box
5894 or else Is_Visible_Formal (E)
5895 then
5896 Set_Is_Hidden (E, False);
5897 end if;
5899 if Ekind (E) = E_Constant then
5901 -- If the type of the actual is a private type declared in the
5902 -- enclosing scope of the generic unit, the body of the generic
5903 -- sees the full view of the type (because it has to appear in
5904 -- the corresponding package body). If the type is private now,
5905 -- exchange views to restore the proper visiblity in the instance.
5907 declare
5908 Typ : constant Entity_Id := Base_Type (Etype (E));
5909 -- The type of the actual
5911 Gen_Id : Entity_Id;
5912 -- The generic unit
5914 Parent_Scope : Entity_Id;
5915 -- The enclosing scope of the generic unit
5917 begin
5918 if Is_Wrapper_Package (Instance) then
5919 Gen_Id :=
5920 Generic_Parent
5921 (Specification
5922 (Unit_Declaration_Node
5923 (Related_Instance (Instance))));
5924 else
5925 Gen_Id :=
5926 Generic_Parent (Package_Specification (Instance));
5927 end if;
5929 Parent_Scope := Scope (Gen_Id);
5931 -- The exchange is only needed if the generic is defined
5932 -- within a package which is not a common ancestor of the
5933 -- scope of the instance, and is not already in scope.
5935 if Is_Private_Type (Typ)
5936 and then Scope (Typ) = Parent_Scope
5937 and then Scope (Instance) /= Parent_Scope
5938 and then Ekind (Parent_Scope) = E_Package
5939 and then not Is_Child_Unit (Gen_Id)
5940 then
5941 Switch_View (Typ);
5943 -- If the type of the entity is a subtype, it may also have
5944 -- to be made visible, together with the base type of its
5945 -- full view, after exchange.
5947 if Is_Private_Type (Etype (E)) then
5948 Switch_View (Etype (E));
5949 Switch_View (Base_Type (Etype (E)));
5950 end if;
5951 end if;
5952 end;
5953 end if;
5955 Next_Entity (E);
5956 end loop;
5957 end Check_Generic_Actuals;
5959 ------------------------------
5960 -- Check_Generic_Child_Unit --
5961 ------------------------------
5963 procedure Check_Generic_Child_Unit
5964 (Gen_Id : Node_Id;
5965 Parent_Installed : in out Boolean)
5967 Loc : constant Source_Ptr := Sloc (Gen_Id);
5968 Gen_Par : Entity_Id := Empty;
5969 E : Entity_Id;
5970 Inst_Par : Entity_Id;
5971 S : Node_Id;
5973 function Find_Generic_Child
5974 (Scop : Entity_Id;
5975 Id : Node_Id) return Entity_Id;
5976 -- Search generic parent for possible child unit with the given name
5978 function In_Enclosing_Instance return Boolean;
5979 -- Within an instance of the parent, the child unit may be denoted by
5980 -- a simple name, or an abbreviated expanded name. Examine enclosing
5981 -- scopes to locate a possible parent instantiation.
5983 ------------------------
5984 -- Find_Generic_Child --
5985 ------------------------
5987 function Find_Generic_Child
5988 (Scop : Entity_Id;
5989 Id : Node_Id) return Entity_Id
5991 E : Entity_Id;
5993 begin
5994 -- If entity of name is already set, instance has already been
5995 -- resolved, e.g. in an enclosing instantiation.
5997 if Present (Entity (Id)) then
5998 if Scope (Entity (Id)) = Scop then
5999 return Entity (Id);
6000 else
6001 return Empty;
6002 end if;
6004 else
6005 E := First_Entity (Scop);
6006 while Present (E) loop
6007 if Chars (E) = Chars (Id)
6008 and then Is_Child_Unit (E)
6009 then
6010 if Is_Child_Unit (E)
6011 and then not Is_Visible_Lib_Unit (E)
6012 then
6013 Error_Msg_NE
6014 ("generic child unit& is not visible", Gen_Id, E);
6015 end if;
6017 Set_Entity (Id, E);
6018 return E;
6019 end if;
6021 Next_Entity (E);
6022 end loop;
6024 return Empty;
6025 end if;
6026 end Find_Generic_Child;
6028 ---------------------------
6029 -- In_Enclosing_Instance --
6030 ---------------------------
6032 function In_Enclosing_Instance return Boolean is
6033 Enclosing_Instance : Node_Id;
6034 Instance_Decl : Node_Id;
6036 begin
6037 -- We do not inline any call that contains instantiations, except
6038 -- for instantiations of Unchecked_Conversion, so if we are within
6039 -- an inlined body the current instance does not require parents.
6041 if In_Inlined_Body then
6042 pragma Assert (Chars (Gen_Id) = Name_Unchecked_Conversion);
6043 return False;
6044 end if;
6046 -- Loop to check enclosing scopes
6048 Enclosing_Instance := Current_Scope;
6049 while Present (Enclosing_Instance) loop
6050 Instance_Decl := Unit_Declaration_Node (Enclosing_Instance);
6052 if Ekind (Enclosing_Instance) = E_Package
6053 and then Is_Generic_Instance (Enclosing_Instance)
6054 and then Present
6055 (Generic_Parent (Specification (Instance_Decl)))
6056 then
6057 -- Check whether the generic we are looking for is a child of
6058 -- this instance.
6060 E := Find_Generic_Child
6061 (Generic_Parent (Specification (Instance_Decl)), Gen_Id);
6062 exit when Present (E);
6064 else
6065 E := Empty;
6066 end if;
6068 Enclosing_Instance := Scope (Enclosing_Instance);
6069 end loop;
6071 if No (E) then
6073 -- Not a child unit
6075 Analyze (Gen_Id);
6076 return False;
6078 else
6079 Rewrite (Gen_Id,
6080 Make_Expanded_Name (Loc,
6081 Chars => Chars (E),
6082 Prefix => New_Occurrence_Of (Enclosing_Instance, Loc),
6083 Selector_Name => New_Occurrence_Of (E, Loc)));
6085 Set_Entity (Gen_Id, E);
6086 Set_Etype (Gen_Id, Etype (E));
6087 Parent_Installed := False; -- Already in scope.
6088 return True;
6089 end if;
6090 end In_Enclosing_Instance;
6092 -- Start of processing for Check_Generic_Child_Unit
6094 begin
6095 -- If the name of the generic is given by a selected component, it may
6096 -- be the name of a generic child unit, and the prefix is the name of an
6097 -- instance of the parent, in which case the child unit must be visible.
6098 -- If this instance is not in scope, it must be placed there and removed
6099 -- after instantiation, because what is being instantiated is not the
6100 -- original child, but the corresponding child present in the instance
6101 -- of the parent.
6103 -- If the child is instantiated within the parent, it can be given by
6104 -- a simple name. In this case the instance is already in scope, but
6105 -- the child generic must be recovered from the generic parent as well.
6107 if Nkind (Gen_Id) = N_Selected_Component then
6108 S := Selector_Name (Gen_Id);
6109 Analyze (Prefix (Gen_Id));
6110 Inst_Par := Entity (Prefix (Gen_Id));
6112 if Ekind (Inst_Par) = E_Package
6113 and then Present (Renamed_Object (Inst_Par))
6114 then
6115 Inst_Par := Renamed_Object (Inst_Par);
6116 end if;
6118 if Ekind (Inst_Par) = E_Package then
6119 if Nkind (Parent (Inst_Par)) = N_Package_Specification then
6120 Gen_Par := Generic_Parent (Parent (Inst_Par));
6122 elsif Nkind (Parent (Inst_Par)) = N_Defining_Program_Unit_Name
6123 and then
6124 Nkind (Parent (Parent (Inst_Par))) = N_Package_Specification
6125 then
6126 Gen_Par := Generic_Parent (Parent (Parent (Inst_Par)));
6127 end if;
6129 elsif Ekind (Inst_Par) = E_Generic_Package
6130 and then Nkind (Parent (Gen_Id)) = N_Formal_Package_Declaration
6131 then
6132 -- A formal package may be a real child package, and not the
6133 -- implicit instance within a parent. In this case the child is
6134 -- not visible and has to be retrieved explicitly as well.
6136 Gen_Par := Inst_Par;
6137 end if;
6139 if Present (Gen_Par) then
6141 -- The prefix denotes an instantiation. The entity itself may be a
6142 -- nested generic, or a child unit.
6144 E := Find_Generic_Child (Gen_Par, S);
6146 if Present (E) then
6147 Change_Selected_Component_To_Expanded_Name (Gen_Id);
6148 Set_Entity (Gen_Id, E);
6149 Set_Etype (Gen_Id, Etype (E));
6150 Set_Entity (S, E);
6151 Set_Etype (S, Etype (E));
6153 -- Indicate that this is a reference to the parent
6155 if In_Extended_Main_Source_Unit (Gen_Id) then
6156 Set_Is_Instantiated (Inst_Par);
6157 end if;
6159 -- A common mistake is to replicate the naming scheme of a
6160 -- hierarchy by instantiating a generic child directly, rather
6161 -- than the implicit child in a parent instance:
6163 -- generic .. package Gpar is ..
6164 -- generic .. package Gpar.Child is ..
6165 -- package Par is new Gpar ();
6167 -- with Gpar.Child;
6168 -- package Par.Child is new Gpar.Child ();
6169 -- rather than Par.Child
6171 -- In this case the instantiation is within Par, which is an
6172 -- instance, but Gpar does not denote Par because we are not IN
6173 -- the instance of Gpar, so this is illegal. The test below
6174 -- recognizes this particular case.
6176 if Is_Child_Unit (E)
6177 and then not Comes_From_Source (Entity (Prefix (Gen_Id)))
6178 and then (not In_Instance
6179 or else Nkind (Parent (Parent (Gen_Id))) =
6180 N_Compilation_Unit)
6181 then
6182 Error_Msg_N
6183 ("prefix of generic child unit must be instance of parent",
6184 Gen_Id);
6185 end if;
6187 if not In_Open_Scopes (Inst_Par)
6188 and then Nkind (Parent (Gen_Id)) not in
6189 N_Generic_Renaming_Declaration
6190 then
6191 Install_Parent (Inst_Par);
6192 Parent_Installed := True;
6194 elsif In_Open_Scopes (Inst_Par) then
6196 -- If the parent is already installed, install the actuals
6197 -- for its formal packages. This is necessary when the child
6198 -- instance is a child of the parent instance: in this case,
6199 -- the parent is placed on the scope stack but the formal
6200 -- packages are not made visible.
6202 Install_Formal_Packages (Inst_Par);
6203 end if;
6205 else
6206 -- If the generic parent does not contain an entity that
6207 -- corresponds to the selector, the instance doesn't either.
6208 -- Analyzing the node will yield the appropriate error message.
6209 -- If the entity is not a child unit, then it is an inner
6210 -- generic in the parent.
6212 Analyze (Gen_Id);
6213 end if;
6215 else
6216 Analyze (Gen_Id);
6218 if Is_Child_Unit (Entity (Gen_Id))
6219 and then
6220 Nkind (Parent (Gen_Id)) not in N_Generic_Renaming_Declaration
6221 and then not In_Open_Scopes (Inst_Par)
6222 then
6223 Install_Parent (Inst_Par);
6224 Parent_Installed := True;
6226 -- The generic unit may be the renaming of the implicit child
6227 -- present in an instance. In that case the parent instance is
6228 -- obtained from the name of the renamed entity.
6230 elsif Ekind (Entity (Gen_Id)) = E_Generic_Package
6231 and then Present (Renamed_Entity (Entity (Gen_Id)))
6232 and then Is_Child_Unit (Renamed_Entity (Entity (Gen_Id)))
6233 then
6234 declare
6235 Renamed_Package : constant Node_Id :=
6236 Name (Parent (Entity (Gen_Id)));
6237 begin
6238 if Nkind (Renamed_Package) = N_Expanded_Name then
6239 Inst_Par := Entity (Prefix (Renamed_Package));
6240 Install_Parent (Inst_Par);
6241 Parent_Installed := True;
6242 end if;
6243 end;
6244 end if;
6245 end if;
6247 elsif Nkind (Gen_Id) = N_Expanded_Name then
6249 -- Entity already present, analyze prefix, whose meaning may be
6250 -- an instance in the current context. If it is an instance of
6251 -- a relative within another, the proper parent may still have
6252 -- to be installed, if they are not of the same generation.
6254 Analyze (Prefix (Gen_Id));
6256 -- In the unlikely case that a local declaration hides the name
6257 -- of the parent package, locate it on the homonym chain. If the
6258 -- context is an instance of the parent, the renaming entity is
6259 -- flagged as such.
6261 Inst_Par := Entity (Prefix (Gen_Id));
6262 while Present (Inst_Par)
6263 and then not Is_Package_Or_Generic_Package (Inst_Par)
6264 loop
6265 Inst_Par := Homonym (Inst_Par);
6266 end loop;
6268 pragma Assert (Present (Inst_Par));
6269 Set_Entity (Prefix (Gen_Id), Inst_Par);
6271 if In_Enclosing_Instance then
6272 null;
6274 elsif Present (Entity (Gen_Id))
6275 and then Is_Child_Unit (Entity (Gen_Id))
6276 and then not In_Open_Scopes (Inst_Par)
6277 then
6278 Install_Parent (Inst_Par);
6279 Parent_Installed := True;
6280 end if;
6282 elsif In_Enclosing_Instance then
6284 -- The child unit is found in some enclosing scope
6286 null;
6288 else
6289 Analyze (Gen_Id);
6291 -- If this is the renaming of the implicit child in a parent
6292 -- instance, recover the parent name and install it.
6294 if Is_Entity_Name (Gen_Id) then
6295 E := Entity (Gen_Id);
6297 if Is_Generic_Unit (E)
6298 and then Nkind (Parent (E)) in N_Generic_Renaming_Declaration
6299 and then Is_Child_Unit (Renamed_Object (E))
6300 and then Is_Generic_Unit (Scope (Renamed_Object (E)))
6301 and then Nkind (Name (Parent (E))) = N_Expanded_Name
6302 then
6303 Rewrite (Gen_Id,
6304 New_Copy_Tree (Name (Parent (E))));
6305 Inst_Par := Entity (Prefix (Gen_Id));
6307 if not In_Open_Scopes (Inst_Par) then
6308 Install_Parent (Inst_Par);
6309 Parent_Installed := True;
6310 end if;
6312 -- If it is a child unit of a non-generic parent, it may be
6313 -- use-visible and given by a direct name. Install parent as
6314 -- for other cases.
6316 elsif Is_Generic_Unit (E)
6317 and then Is_Child_Unit (E)
6318 and then
6319 Nkind (Parent (Gen_Id)) not in N_Generic_Renaming_Declaration
6320 and then not Is_Generic_Unit (Scope (E))
6321 then
6322 if not In_Open_Scopes (Scope (E)) then
6323 Install_Parent (Scope (E));
6324 Parent_Installed := True;
6325 end if;
6326 end if;
6327 end if;
6328 end if;
6329 end Check_Generic_Child_Unit;
6331 -----------------------------
6332 -- Check_Hidden_Child_Unit --
6333 -----------------------------
6335 procedure Check_Hidden_Child_Unit
6336 (N : Node_Id;
6337 Gen_Unit : Entity_Id;
6338 Act_Decl_Id : Entity_Id)
6340 Gen_Id : constant Node_Id := Name (N);
6342 begin
6343 if Is_Child_Unit (Gen_Unit)
6344 and then Is_Child_Unit (Act_Decl_Id)
6345 and then Nkind (Gen_Id) = N_Expanded_Name
6346 and then Entity (Prefix (Gen_Id)) = Scope (Act_Decl_Id)
6347 and then Chars (Gen_Unit) = Chars (Act_Decl_Id)
6348 then
6349 Error_Msg_Node_2 := Scope (Act_Decl_Id);
6350 Error_Msg_NE
6351 ("generic unit & is implicitly declared in &",
6352 Defining_Unit_Name (N), Gen_Unit);
6353 Error_Msg_N ("\instance must have different name",
6354 Defining_Unit_Name (N));
6355 end if;
6356 end Check_Hidden_Child_Unit;
6358 ------------------------
6359 -- Check_Private_View --
6360 ------------------------
6362 procedure Check_Private_View (N : Node_Id) is
6363 T : constant Entity_Id := Etype (N);
6364 BT : Entity_Id;
6366 begin
6367 -- Exchange views if the type was not private in the generic but is
6368 -- private at the point of instantiation. Do not exchange views if
6369 -- the scope of the type is in scope. This can happen if both generic
6370 -- and instance are sibling units, or if type is defined in a parent.
6371 -- In this case the visibility of the type will be correct for all
6372 -- semantic checks.
6374 if Present (T) then
6375 BT := Base_Type (T);
6377 if Is_Private_Type (T)
6378 and then not Has_Private_View (N)
6379 and then Present (Full_View (T))
6380 and then not In_Open_Scopes (Scope (T))
6381 then
6382 -- In the generic, the full type was visible. Save the private
6383 -- entity, for subsequent exchange.
6385 Switch_View (T);
6387 elsif Has_Private_View (N)
6388 and then not Is_Private_Type (T)
6389 and then not Has_Been_Exchanged (T)
6390 and then Etype (Get_Associated_Node (N)) /= T
6391 then
6392 -- Only the private declaration was visible in the generic. If
6393 -- the type appears in a subtype declaration, the subtype in the
6394 -- instance must have a view compatible with that of its parent,
6395 -- which must be exchanged (see corresponding code in Restore_
6396 -- Private_Views). Otherwise, if the type is defined in a parent
6397 -- unit, leave full visibility within instance, which is safe.
6399 if In_Open_Scopes (Scope (Base_Type (T)))
6400 and then not Is_Private_Type (Base_Type (T))
6401 and then Comes_From_Source (Base_Type (T))
6402 then
6403 null;
6405 elsif Nkind (Parent (N)) = N_Subtype_Declaration
6406 or else not In_Private_Part (Scope (Base_Type (T)))
6407 then
6408 Prepend_Elmt (T, Exchanged_Views);
6409 Exchange_Declarations (Etype (Get_Associated_Node (N)));
6410 end if;
6412 -- For composite types with inconsistent representation exchange
6413 -- component types accordingly.
6415 elsif Is_Access_Type (T)
6416 and then Is_Private_Type (Designated_Type (T))
6417 and then not Has_Private_View (N)
6418 and then Present (Full_View (Designated_Type (T)))
6419 then
6420 Switch_View (Designated_Type (T));
6422 elsif Is_Array_Type (T) then
6423 if Is_Private_Type (Component_Type (T))
6424 and then not Has_Private_View (N)
6425 and then Present (Full_View (Component_Type (T)))
6426 then
6427 Switch_View (Component_Type (T));
6428 end if;
6430 -- The normal exchange mechanism relies on the setting of a
6431 -- flag on the reference in the generic. However, an additional
6432 -- mechanism is needed for types that are not explicitly
6433 -- mentioned in the generic, but may be needed in expanded code
6434 -- in the instance. This includes component types of arrays and
6435 -- designated types of access types. This processing must also
6436 -- include the index types of arrays which we take care of here.
6438 declare
6439 Indx : Node_Id;
6440 Typ : Entity_Id;
6442 begin
6443 Indx := First_Index (T);
6444 while Present (Indx) loop
6445 Typ := Base_Type (Etype (Indx));
6447 if Is_Private_Type (Typ)
6448 and then Present (Full_View (Typ))
6449 then
6450 Switch_View (Typ);
6451 end if;
6453 Next_Index (Indx);
6454 end loop;
6455 end;
6457 elsif Is_Private_Type (T)
6458 and then Present (Full_View (T))
6459 and then Is_Array_Type (Full_View (T))
6460 and then Is_Private_Type (Component_Type (Full_View (T)))
6461 then
6462 Switch_View (T);
6464 -- Finally, a non-private subtype may have a private base type, which
6465 -- must be exchanged for consistency. This can happen when a package
6466 -- body is instantiated, when the scope stack is empty but in fact
6467 -- the subtype and the base type are declared in an enclosing scope.
6469 -- Note that in this case we introduce an inconsistency in the view
6470 -- set, because we switch the base type BT, but there could be some
6471 -- private dependent subtypes of BT which remain unswitched. Such
6472 -- subtypes might need to be switched at a later point (see specific
6473 -- provision for that case in Switch_View).
6475 elsif not Is_Private_Type (T)
6476 and then not Has_Private_View (N)
6477 and then Is_Private_Type (BT)
6478 and then Present (Full_View (BT))
6479 and then not Is_Generic_Type (BT)
6480 and then not In_Open_Scopes (BT)
6481 then
6482 Prepend_Elmt (Full_View (BT), Exchanged_Views);
6483 Exchange_Declarations (BT);
6484 end if;
6485 end if;
6486 end Check_Private_View;
6488 -----------------------------
6489 -- Check_Hidden_Primitives --
6490 -----------------------------
6492 function Check_Hidden_Primitives (Assoc_List : List_Id) return Elist_Id is
6493 Actual : Node_Id;
6494 Gen_T : Entity_Id;
6495 Result : Elist_Id := No_Elist;
6497 begin
6498 if No (Assoc_List) then
6499 return No_Elist;
6500 end if;
6502 -- Traverse the list of associations between formals and actuals
6503 -- searching for renamings of tagged types
6505 Actual := First (Assoc_List);
6506 while Present (Actual) loop
6507 if Nkind (Actual) = N_Subtype_Declaration then
6508 Gen_T := Generic_Parent_Type (Actual);
6510 if Present (Gen_T)
6511 and then Is_Tagged_Type (Gen_T)
6512 then
6513 -- Traverse the list of primitives of the actual types
6514 -- searching for hidden primitives that are visible in the
6515 -- corresponding generic formal; leave them visible and
6516 -- append them to Result to restore their decoration later.
6518 Install_Hidden_Primitives
6519 (Prims_List => Result,
6520 Gen_T => Gen_T,
6521 Act_T => Entity (Subtype_Indication (Actual)));
6522 end if;
6523 end if;
6525 Next (Actual);
6526 end loop;
6528 return Result;
6529 end Check_Hidden_Primitives;
6531 --------------------------
6532 -- Contains_Instance_Of --
6533 --------------------------
6535 function Contains_Instance_Of
6536 (Inner : Entity_Id;
6537 Outer : Entity_Id;
6538 N : Node_Id) return Boolean
6540 Elmt : Elmt_Id;
6541 Scop : Entity_Id;
6543 begin
6544 Scop := Outer;
6546 -- Verify that there are no circular instantiations. We check whether
6547 -- the unit contains an instance of the current scope or some enclosing
6548 -- scope (in case one of the instances appears in a subunit). Longer
6549 -- circularities involving subunits might seem too pathological to
6550 -- consider, but they were not too pathological for the authors of
6551 -- DEC bc30vsq, so we loop over all enclosing scopes, and mark all
6552 -- enclosing generic scopes as containing an instance.
6554 loop
6555 -- Within a generic subprogram body, the scope is not generic, to
6556 -- allow for recursive subprograms. Use the declaration to determine
6557 -- whether this is a generic unit.
6559 if Ekind (Scop) = E_Generic_Package
6560 or else (Is_Subprogram (Scop)
6561 and then Nkind (Unit_Declaration_Node (Scop)) =
6562 N_Generic_Subprogram_Declaration)
6563 then
6564 Elmt := First_Elmt (Inner_Instances (Inner));
6566 while Present (Elmt) loop
6567 if Node (Elmt) = Scop then
6568 Error_Msg_Node_2 := Inner;
6569 Error_Msg_NE
6570 ("circular Instantiation: & instantiated within &!",
6571 N, Scop);
6572 return True;
6574 elsif Node (Elmt) = Inner then
6575 return True;
6577 elsif Contains_Instance_Of (Node (Elmt), Scop, N) then
6578 Error_Msg_Node_2 := Inner;
6579 Error_Msg_NE
6580 ("circular Instantiation: & instantiated within &!",
6581 N, Node (Elmt));
6582 return True;
6583 end if;
6585 Next_Elmt (Elmt);
6586 end loop;
6588 -- Indicate that Inner is being instantiated within Scop
6590 Append_Elmt (Inner, Inner_Instances (Scop));
6591 end if;
6593 if Scop = Standard_Standard then
6594 exit;
6595 else
6596 Scop := Scope (Scop);
6597 end if;
6598 end loop;
6600 return False;
6601 end Contains_Instance_Of;
6603 -----------------------
6604 -- Copy_Generic_Node --
6605 -----------------------
6607 function Copy_Generic_Node
6608 (N : Node_Id;
6609 Parent_Id : Node_Id;
6610 Instantiating : Boolean) return Node_Id
6612 Ent : Entity_Id;
6613 New_N : Node_Id;
6615 function Copy_Generic_Descendant (D : Union_Id) return Union_Id;
6616 -- Check the given value of one of the Fields referenced by the current
6617 -- node to determine whether to copy it recursively. The field may hold
6618 -- a Node_Id, a List_Id, or an Elist_Id, or a plain value (Sloc, Uint,
6619 -- Char) in which case it need not be copied.
6621 procedure Copy_Descendants;
6622 -- Common utility for various nodes
6624 function Copy_Generic_Elist (E : Elist_Id) return Elist_Id;
6625 -- Make copy of element list
6627 function Copy_Generic_List
6628 (L : List_Id;
6629 Parent_Id : Node_Id) return List_Id;
6630 -- Apply Copy_Node recursively to the members of a node list
6632 function In_Defining_Unit_Name (Nam : Node_Id) return Boolean;
6633 -- True if an identifier is part of the defining program unit name of
6634 -- a child unit. The entity of such an identifier must be kept (for
6635 -- ASIS use) even though as the name of an enclosing generic it would
6636 -- otherwise not be preserved in the generic tree.
6638 ----------------------
6639 -- Copy_Descendants --
6640 ----------------------
6642 procedure Copy_Descendants is
6644 use Atree.Unchecked_Access;
6645 -- This code section is part of the implementation of an untyped
6646 -- tree traversal, so it needs direct access to node fields.
6648 begin
6649 Set_Field1 (New_N, Copy_Generic_Descendant (Field1 (N)));
6650 Set_Field2 (New_N, Copy_Generic_Descendant (Field2 (N)));
6651 Set_Field3 (New_N, Copy_Generic_Descendant (Field3 (N)));
6652 Set_Field4 (New_N, Copy_Generic_Descendant (Field4 (N)));
6653 Set_Field5 (New_N, Copy_Generic_Descendant (Field5 (N)));
6654 end Copy_Descendants;
6656 -----------------------------
6657 -- Copy_Generic_Descendant --
6658 -----------------------------
6660 function Copy_Generic_Descendant (D : Union_Id) return Union_Id is
6661 begin
6662 if D = Union_Id (Empty) then
6663 return D;
6665 elsif D in Node_Range then
6666 return Union_Id
6667 (Copy_Generic_Node (Node_Id (D), New_N, Instantiating));
6669 elsif D in List_Range then
6670 return Union_Id (Copy_Generic_List (List_Id (D), New_N));
6672 elsif D in Elist_Range then
6673 return Union_Id (Copy_Generic_Elist (Elist_Id (D)));
6675 -- Nothing else is copyable (e.g. Uint values), return as is
6677 else
6678 return D;
6679 end if;
6680 end Copy_Generic_Descendant;
6682 ------------------------
6683 -- Copy_Generic_Elist --
6684 ------------------------
6686 function Copy_Generic_Elist (E : Elist_Id) return Elist_Id is
6687 M : Elmt_Id;
6688 L : Elist_Id;
6690 begin
6691 if Present (E) then
6692 L := New_Elmt_List;
6693 M := First_Elmt (E);
6694 while Present (M) loop
6695 Append_Elmt
6696 (Copy_Generic_Node (Node (M), Empty, Instantiating), L);
6697 Next_Elmt (M);
6698 end loop;
6700 return L;
6702 else
6703 return No_Elist;
6704 end if;
6705 end Copy_Generic_Elist;
6707 -----------------------
6708 -- Copy_Generic_List --
6709 -----------------------
6711 function Copy_Generic_List
6712 (L : List_Id;
6713 Parent_Id : Node_Id) return List_Id
6715 N : Node_Id;
6716 New_L : List_Id;
6718 begin
6719 if Present (L) then
6720 New_L := New_List;
6721 Set_Parent (New_L, Parent_Id);
6723 N := First (L);
6724 while Present (N) loop
6725 Append (Copy_Generic_Node (N, Empty, Instantiating), New_L);
6726 Next (N);
6727 end loop;
6729 return New_L;
6731 else
6732 return No_List;
6733 end if;
6734 end Copy_Generic_List;
6736 ---------------------------
6737 -- In_Defining_Unit_Name --
6738 ---------------------------
6740 function In_Defining_Unit_Name (Nam : Node_Id) return Boolean is
6741 begin
6742 return Present (Parent (Nam))
6743 and then (Nkind (Parent (Nam)) = N_Defining_Program_Unit_Name
6744 or else
6745 (Nkind (Parent (Nam)) = N_Expanded_Name
6746 and then In_Defining_Unit_Name (Parent (Nam))));
6747 end In_Defining_Unit_Name;
6749 -- Start of processing for Copy_Generic_Node
6751 begin
6752 if N = Empty then
6753 return N;
6754 end if;
6756 New_N := New_Copy (N);
6758 -- Copy aspects if present
6760 if Has_Aspects (N) then
6761 Set_Has_Aspects (New_N, False);
6762 Set_Aspect_Specifications
6763 (New_N, Copy_Generic_List (Aspect_Specifications (N), Parent_Id));
6764 end if;
6766 if Instantiating then
6767 Adjust_Instantiation_Sloc (New_N, S_Adjustment);
6768 end if;
6770 if not Is_List_Member (N) then
6771 Set_Parent (New_N, Parent_Id);
6772 end if;
6774 -- If defining identifier, then all fields have been copied already
6776 if Nkind (New_N) in N_Entity then
6777 null;
6779 -- Special casing for identifiers and other entity names and operators
6781 elsif Nkind_In (New_N, N_Identifier,
6782 N_Character_Literal,
6783 N_Expanded_Name,
6784 N_Operator_Symbol)
6785 or else Nkind (New_N) in N_Op
6786 then
6787 if not Instantiating then
6789 -- Link both nodes in order to assign subsequently the entity of
6790 -- the copy to the original node, in case this is a global
6791 -- reference.
6793 Set_Associated_Node (N, New_N);
6795 -- If we are within an instantiation, this is a nested generic
6796 -- that has already been analyzed at the point of definition.
6797 -- We must preserve references that were global to the enclosing
6798 -- parent at that point. Other occurrences, whether global or
6799 -- local to the current generic, must be resolved anew, so we
6800 -- reset the entity in the generic copy. A global reference has a
6801 -- smaller depth than the parent, or else the same depth in case
6802 -- both are distinct compilation units.
6804 -- A child unit is implicitly declared within the enclosing parent
6805 -- but is in fact global to it, and must be preserved.
6807 -- It is also possible for Current_Instantiated_Parent to be
6808 -- defined, and for this not to be a nested generic, namely if
6809 -- the unit is loaded through Rtsfind. In that case, the entity of
6810 -- New_N is only a link to the associated node, and not a defining
6811 -- occurrence.
6813 -- The entities for parent units in the defining_program_unit of a
6814 -- generic child unit are established when the context of the unit
6815 -- is first analyzed, before the generic copy is made. They are
6816 -- preserved in the copy for use in ASIS queries.
6818 Ent := Entity (New_N);
6820 if No (Current_Instantiated_Parent.Gen_Id) then
6821 if No (Ent)
6822 or else Nkind (Ent) /= N_Defining_Identifier
6823 or else not In_Defining_Unit_Name (N)
6824 then
6825 Set_Associated_Node (New_N, Empty);
6826 end if;
6828 elsif No (Ent)
6829 or else
6830 not Nkind_In (Ent, N_Defining_Identifier,
6831 N_Defining_Character_Literal,
6832 N_Defining_Operator_Symbol)
6833 or else No (Scope (Ent))
6834 or else
6835 (Scope (Ent) = Current_Instantiated_Parent.Gen_Id
6836 and then not Is_Child_Unit (Ent))
6837 or else
6838 (Scope_Depth (Scope (Ent)) >
6839 Scope_Depth (Current_Instantiated_Parent.Gen_Id)
6840 and then
6841 Get_Source_Unit (Ent) =
6842 Get_Source_Unit (Current_Instantiated_Parent.Gen_Id))
6843 then
6844 Set_Associated_Node (New_N, Empty);
6845 end if;
6847 -- Case of instantiating identifier or some other name or operator
6849 else
6850 -- If the associated node is still defined, the entity in it
6851 -- is global, and must be copied to the instance. If this copy
6852 -- is being made for a body to inline, it is applied to an
6853 -- instantiated tree, and the entity is already present and
6854 -- must be also preserved.
6856 declare
6857 Assoc : constant Node_Id := Get_Associated_Node (N);
6859 begin
6860 if Present (Assoc) then
6861 if Nkind (Assoc) = Nkind (N) then
6862 Set_Entity (New_N, Entity (Assoc));
6863 Check_Private_View (N);
6865 -- The name in the call may be a selected component if the
6866 -- call has not been analyzed yet, as may be the case for
6867 -- pre/post conditions in a generic unit.
6869 elsif Nkind (Assoc) = N_Function_Call
6870 and then Is_Entity_Name (Name (Assoc))
6871 then
6872 Set_Entity (New_N, Entity (Name (Assoc)));
6874 elsif Nkind_In (Assoc, N_Defining_Identifier,
6875 N_Defining_Character_Literal,
6876 N_Defining_Operator_Symbol)
6877 and then Expander_Active
6878 then
6879 -- Inlining case: we are copying a tree that contains
6880 -- global entities, which are preserved in the copy to be
6881 -- used for subsequent inlining.
6883 null;
6885 else
6886 Set_Entity (New_N, Empty);
6887 end if;
6888 end if;
6889 end;
6890 end if;
6892 -- For expanded name, we must copy the Prefix and Selector_Name
6894 if Nkind (N) = N_Expanded_Name then
6895 Set_Prefix
6896 (New_N, Copy_Generic_Node (Prefix (N), New_N, Instantiating));
6898 Set_Selector_Name (New_N,
6899 Copy_Generic_Node (Selector_Name (N), New_N, Instantiating));
6901 -- For operators, we must copy the right operand
6903 elsif Nkind (N) in N_Op then
6904 Set_Right_Opnd (New_N,
6905 Copy_Generic_Node (Right_Opnd (N), New_N, Instantiating));
6907 -- And for binary operators, the left operand as well
6909 if Nkind (N) in N_Binary_Op then
6910 Set_Left_Opnd (New_N,
6911 Copy_Generic_Node (Left_Opnd (N), New_N, Instantiating));
6912 end if;
6913 end if;
6915 -- Special casing for stubs
6917 elsif Nkind (N) in N_Body_Stub then
6919 -- In any case, we must copy the specification or defining
6920 -- identifier as appropriate.
6922 if Nkind (N) = N_Subprogram_Body_Stub then
6923 Set_Specification (New_N,
6924 Copy_Generic_Node (Specification (N), New_N, Instantiating));
6926 else
6927 Set_Defining_Identifier (New_N,
6928 Copy_Generic_Node
6929 (Defining_Identifier (N), New_N, Instantiating));
6930 end if;
6932 -- If we are not instantiating, then this is where we load and
6933 -- analyze subunits, i.e. at the point where the stub occurs. A
6934 -- more permissive system might defer this analysis to the point
6935 -- of instantiation, but this seems too complicated for now.
6937 if not Instantiating then
6938 declare
6939 Subunit_Name : constant Unit_Name_Type := Get_Unit_Name (N);
6940 Subunit : Node_Id;
6941 Unum : Unit_Number_Type;
6942 New_Body : Node_Id;
6944 begin
6945 -- Make sure that, if it is a subunit of the main unit that is
6946 -- preprocessed and if -gnateG is specified, the preprocessed
6947 -- file will be written.
6949 Lib.Analysing_Subunit_Of_Main :=
6950 Lib.In_Extended_Main_Source_Unit (N);
6951 Unum :=
6952 Load_Unit
6953 (Load_Name => Subunit_Name,
6954 Required => False,
6955 Subunit => True,
6956 Error_Node => N);
6957 Lib.Analysing_Subunit_Of_Main := False;
6959 -- If the proper body is not found, a warning message will be
6960 -- emitted when analyzing the stub, or later at the point of
6961 -- instantiation. Here we just leave the stub as is.
6963 if Unum = No_Unit then
6964 Subunits_Missing := True;
6965 goto Subunit_Not_Found;
6966 end if;
6968 Subunit := Cunit (Unum);
6970 if Nkind (Unit (Subunit)) /= N_Subunit then
6971 Error_Msg_N
6972 ("found child unit instead of expected SEPARATE subunit",
6973 Subunit);
6974 Error_Msg_Sloc := Sloc (N);
6975 Error_Msg_N ("\to complete stub #", Subunit);
6976 goto Subunit_Not_Found;
6977 end if;
6979 -- We must create a generic copy of the subunit, in order to
6980 -- perform semantic analysis on it, and we must replace the
6981 -- stub in the original generic unit with the subunit, in order
6982 -- to preserve non-local references within.
6984 -- Only the proper body needs to be copied. Library_Unit and
6985 -- context clause are simply inherited by the generic copy.
6986 -- Note that the copy (which may be recursive if there are
6987 -- nested subunits) must be done first, before attaching it to
6988 -- the enclosing generic.
6990 New_Body :=
6991 Copy_Generic_Node
6992 (Proper_Body (Unit (Subunit)),
6993 Empty, Instantiating => False);
6995 -- Now place the original proper body in the original generic
6996 -- unit. This is a body, not a compilation unit.
6998 Rewrite (N, Proper_Body (Unit (Subunit)));
6999 Set_Is_Compilation_Unit (Defining_Entity (N), False);
7000 Set_Was_Originally_Stub (N);
7002 -- Finally replace the body of the subunit with its copy, and
7003 -- make this new subunit into the library unit of the generic
7004 -- copy, which does not have stubs any longer.
7006 Set_Proper_Body (Unit (Subunit), New_Body);
7007 Set_Library_Unit (New_N, Subunit);
7008 Inherit_Context (Unit (Subunit), N);
7009 end;
7011 -- If we are instantiating, this must be an error case, since
7012 -- otherwise we would have replaced the stub node by the proper body
7013 -- that corresponds. So just ignore it in the copy (i.e. we have
7014 -- copied it, and that is good enough).
7016 else
7017 null;
7018 end if;
7020 <<Subunit_Not_Found>> null;
7022 -- If the node is a compilation unit, it is the subunit of a stub, which
7023 -- has been loaded already (see code below). In this case, the library
7024 -- unit field of N points to the parent unit (which is a compilation
7025 -- unit) and need not (and cannot) be copied.
7027 -- When the proper body of the stub is analyzed, the library_unit link
7028 -- is used to establish the proper context (see sem_ch10).
7030 -- The other fields of a compilation unit are copied as usual
7032 elsif Nkind (N) = N_Compilation_Unit then
7034 -- This code can only be executed when not instantiating, because in
7035 -- the copy made for an instantiation, the compilation unit node has
7036 -- disappeared at the point that a stub is replaced by its proper
7037 -- body.
7039 pragma Assert (not Instantiating);
7041 Set_Context_Items (New_N,
7042 Copy_Generic_List (Context_Items (N), New_N));
7044 Set_Unit (New_N,
7045 Copy_Generic_Node (Unit (N), New_N, False));
7047 Set_First_Inlined_Subprogram (New_N,
7048 Copy_Generic_Node
7049 (First_Inlined_Subprogram (N), New_N, False));
7051 Set_Aux_Decls_Node (New_N,
7052 Copy_Generic_Node (Aux_Decls_Node (N), New_N, False));
7054 -- For an assignment node, the assignment is known to be semantically
7055 -- legal if we are instantiating the template. This avoids incorrect
7056 -- diagnostics in generated code.
7058 elsif Nkind (N) = N_Assignment_Statement then
7060 -- Copy name and expression fields in usual manner
7062 Set_Name (New_N,
7063 Copy_Generic_Node (Name (N), New_N, Instantiating));
7065 Set_Expression (New_N,
7066 Copy_Generic_Node (Expression (N), New_N, Instantiating));
7068 if Instantiating then
7069 Set_Assignment_OK (Name (New_N), True);
7070 end if;
7072 elsif Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then
7073 if not Instantiating then
7074 Set_Associated_Node (N, New_N);
7076 else
7077 if Present (Get_Associated_Node (N))
7078 and then Nkind (Get_Associated_Node (N)) = Nkind (N)
7079 then
7080 -- In the generic the aggregate has some composite type. If at
7081 -- the point of instantiation the type has a private view,
7082 -- install the full view (and that of its ancestors, if any).
7084 declare
7085 T : Entity_Id := (Etype (Get_Associated_Node (New_N)));
7086 Rt : Entity_Id;
7088 begin
7089 if Present (T)
7090 and then Is_Private_Type (T)
7091 then
7092 Switch_View (T);
7093 end if;
7095 if Present (T)
7096 and then Is_Tagged_Type (T)
7097 and then Is_Derived_Type (T)
7098 then
7099 Rt := Root_Type (T);
7101 loop
7102 T := Etype (T);
7104 if Is_Private_Type (T) then
7105 Switch_View (T);
7106 end if;
7108 exit when T = Rt;
7109 end loop;
7110 end if;
7111 end;
7112 end if;
7113 end if;
7115 -- Do not copy the associated node, which points to the generic copy
7116 -- of the aggregate.
7118 declare
7119 use Atree.Unchecked_Access;
7120 -- This code section is part of the implementation of an untyped
7121 -- tree traversal, so it needs direct access to node fields.
7123 begin
7124 Set_Field1 (New_N, Copy_Generic_Descendant (Field1 (N)));
7125 Set_Field2 (New_N, Copy_Generic_Descendant (Field2 (N)));
7126 Set_Field3 (New_N, Copy_Generic_Descendant (Field3 (N)));
7127 Set_Field5 (New_N, Copy_Generic_Descendant (Field5 (N)));
7128 end;
7130 -- Allocators do not have an identifier denoting the access type, so we
7131 -- must locate it through the expression to check whether the views are
7132 -- consistent.
7134 elsif Nkind (N) = N_Allocator
7135 and then Nkind (Expression (N)) = N_Qualified_Expression
7136 and then Is_Entity_Name (Subtype_Mark (Expression (N)))
7137 and then Instantiating
7138 then
7139 declare
7140 T : constant Node_Id :=
7141 Get_Associated_Node (Subtype_Mark (Expression (N)));
7142 Acc_T : Entity_Id;
7144 begin
7145 if Present (T) then
7147 -- Retrieve the allocator node in the generic copy
7149 Acc_T := Etype (Parent (Parent (T)));
7150 if Present (Acc_T)
7151 and then Is_Private_Type (Acc_T)
7152 then
7153 Switch_View (Acc_T);
7154 end if;
7155 end if;
7157 Copy_Descendants;
7158 end;
7160 -- For a proper body, we must catch the case of a proper body that
7161 -- replaces a stub. This represents the point at which a separate
7162 -- compilation unit, and hence template file, may be referenced, so we
7163 -- must make a new source instantiation entry for the template of the
7164 -- subunit, and ensure that all nodes in the subunit are adjusted using
7165 -- this new source instantiation entry.
7167 elsif Nkind (N) in N_Proper_Body then
7168 declare
7169 Save_Adjustment : constant Sloc_Adjustment := S_Adjustment;
7171 begin
7172 if Instantiating and then Was_Originally_Stub (N) then
7173 Create_Instantiation_Source
7174 (Instantiation_Node,
7175 Defining_Entity (N),
7176 False,
7177 S_Adjustment);
7178 end if;
7180 -- Now copy the fields of the proper body, using the new
7181 -- adjustment factor if one was needed as per test above.
7183 Copy_Descendants;
7185 -- Restore the original adjustment factor in case changed
7187 S_Adjustment := Save_Adjustment;
7188 end;
7190 -- Don't copy Ident or Comment pragmas, since the comment belongs to the
7191 -- generic unit, not to the instantiating unit.
7193 elsif Nkind (N) = N_Pragma and then Instantiating then
7194 declare
7195 Prag_Id : constant Pragma_Id := Get_Pragma_Id (N);
7196 begin
7197 if Prag_Id = Pragma_Ident or else Prag_Id = Pragma_Comment then
7198 New_N := Make_Null_Statement (Sloc (N));
7199 else
7200 Copy_Descendants;
7201 end if;
7202 end;
7204 elsif Nkind_In (N, N_Integer_Literal, N_Real_Literal) then
7206 -- No descendant fields need traversing
7208 null;
7210 elsif Nkind (N) = N_String_Literal
7211 and then Present (Etype (N))
7212 and then Instantiating
7213 then
7214 -- If the string is declared in an outer scope, the string_literal
7215 -- subtype created for it may have the wrong scope. We force the
7216 -- reanalysis of the constant to generate a new itype in the proper
7217 -- context.
7219 Set_Etype (New_N, Empty);
7220 Set_Analyzed (New_N, False);
7222 -- For the remaining nodes, copy their descendants recursively
7224 else
7225 Copy_Descendants;
7227 if Instantiating and then Nkind (N) = N_Subprogram_Body then
7228 Set_Generic_Parent (Specification (New_N), N);
7230 -- Should preserve Corresponding_Spec??? (12.3(14))
7231 end if;
7232 end if;
7234 return New_N;
7235 end Copy_Generic_Node;
7237 ----------------------------
7238 -- Denotes_Formal_Package --
7239 ----------------------------
7241 function Denotes_Formal_Package
7242 (Pack : Entity_Id;
7243 On_Exit : Boolean := False;
7244 Instance : Entity_Id := Empty) return Boolean
7246 Par : Entity_Id;
7247 Scop : constant Entity_Id := Scope (Pack);
7248 E : Entity_Id;
7250 function Is_Actual_Of_Previous_Formal (P : Entity_Id) return Boolean;
7251 -- The package in question may be an actual for a previous formal
7252 -- package P of the current instance, so examine its actuals as well.
7253 -- This must be recursive over other formal packages.
7255 ----------------------------------
7256 -- Is_Actual_Of_Previous_Formal --
7257 ----------------------------------
7259 function Is_Actual_Of_Previous_Formal (P : Entity_Id) return Boolean is
7260 E1 : Entity_Id;
7262 begin
7263 E1 := First_Entity (P);
7264 while Present (E1) and then E1 /= Instance loop
7265 if Ekind (E1) = E_Package
7266 and then Nkind (Parent (E1)) = N_Package_Renaming_Declaration
7267 then
7268 if Renamed_Object (E1) = Pack then
7269 return True;
7271 elsif E1 = P or else Renamed_Object (E1) = P then
7272 return False;
7274 elsif Is_Actual_Of_Previous_Formal (E1) then
7275 return True;
7276 end if;
7277 end if;
7279 Next_Entity (E1);
7280 end loop;
7282 return False;
7283 end Is_Actual_Of_Previous_Formal;
7285 -- Start of processing for Denotes_Formal_Package
7287 begin
7288 if On_Exit then
7289 Par :=
7290 Instance_Envs.Table
7291 (Instance_Envs.Last).Instantiated_Parent.Act_Id;
7292 else
7293 Par := Current_Instantiated_Parent.Act_Id;
7294 end if;
7296 if Ekind (Scop) = E_Generic_Package
7297 or else Nkind (Unit_Declaration_Node (Scop)) =
7298 N_Generic_Subprogram_Declaration
7299 then
7300 return True;
7302 elsif Nkind (Original_Node (Unit_Declaration_Node (Pack))) =
7303 N_Formal_Package_Declaration
7304 then
7305 return True;
7307 elsif No (Par) then
7308 return False;
7310 else
7311 -- Check whether this package is associated with a formal package of
7312 -- the enclosing instantiation. Iterate over the list of renamings.
7314 E := First_Entity (Par);
7315 while Present (E) loop
7316 if Ekind (E) /= E_Package
7317 or else Nkind (Parent (E)) /= N_Package_Renaming_Declaration
7318 then
7319 null;
7321 elsif Renamed_Object (E) = Par then
7322 return False;
7324 elsif Renamed_Object (E) = Pack then
7325 return True;
7327 elsif Is_Actual_Of_Previous_Formal (E) then
7328 return True;
7330 end if;
7332 Next_Entity (E);
7333 end loop;
7335 return False;
7336 end if;
7337 end Denotes_Formal_Package;
7339 -----------------
7340 -- End_Generic --
7341 -----------------
7343 procedure End_Generic is
7344 begin
7345 -- ??? More things could be factored out in this routine. Should
7346 -- probably be done at a later stage.
7348 Inside_A_Generic := Generic_Flags.Table (Generic_Flags.Last);
7349 Generic_Flags.Decrement_Last;
7351 Expander_Mode_Restore;
7352 end End_Generic;
7354 -------------
7355 -- Earlier --
7356 -------------
7358 function Earlier (N1, N2 : Node_Id) return Boolean is
7359 procedure Find_Depth (P : in out Node_Id; D : in out Integer);
7360 -- Find distance from given node to enclosing compilation unit
7362 ----------------
7363 -- Find_Depth --
7364 ----------------
7366 procedure Find_Depth (P : in out Node_Id; D : in out Integer) is
7367 begin
7368 while Present (P)
7369 and then Nkind (P) /= N_Compilation_Unit
7370 loop
7371 P := True_Parent (P);
7372 D := D + 1;
7373 end loop;
7374 end Find_Depth;
7376 -- Local declarations
7378 D1 : Integer := 0;
7379 D2 : Integer := 0;
7380 P1 : Node_Id := N1;
7381 P2 : Node_Id := N2;
7382 T1 : Source_Ptr;
7383 T2 : Source_Ptr;
7385 -- Start of processing for Earlier
7387 begin
7388 Find_Depth (P1, D1);
7389 Find_Depth (P2, D2);
7391 if P1 /= P2 then
7392 return False;
7393 else
7394 P1 := N1;
7395 P2 := N2;
7396 end if;
7398 while D1 > D2 loop
7399 P1 := True_Parent (P1);
7400 D1 := D1 - 1;
7401 end loop;
7403 while D2 > D1 loop
7404 P2 := True_Parent (P2);
7405 D2 := D2 - 1;
7406 end loop;
7408 -- At this point P1 and P2 are at the same distance from the root.
7409 -- We examine their parents until we find a common declarative list.
7410 -- If we reach the root, N1 and N2 do not descend from the same
7411 -- declarative list (e.g. one is nested in the declarative part and
7412 -- the other is in a block in the statement part) and the earlier
7413 -- one is already frozen.
7415 while not Is_List_Member (P1)
7416 or else not Is_List_Member (P2)
7417 or else List_Containing (P1) /= List_Containing (P2)
7418 loop
7419 P1 := True_Parent (P1);
7420 P2 := True_Parent (P2);
7422 if Nkind (Parent (P1)) = N_Subunit then
7423 P1 := Corresponding_Stub (Parent (P1));
7424 end if;
7426 if Nkind (Parent (P2)) = N_Subunit then
7427 P2 := Corresponding_Stub (Parent (P2));
7428 end if;
7430 if P1 = P2 then
7431 return False;
7432 end if;
7433 end loop;
7435 -- Expanded code usually shares the source location of the original
7436 -- construct it was generated for. This however may not necessarely
7437 -- reflect the true location of the code within the tree.
7439 -- Before comparing the slocs of the two nodes, make sure that we are
7440 -- working with correct source locations. Assume that P1 is to the left
7441 -- of P2. If either one does not come from source, traverse the common
7442 -- list heading towards the other node and locate the first source
7443 -- statement.
7445 -- P1 P2
7446 -- ----+===+===+--------------+===+===+----
7447 -- expanded code expanded code
7449 if not Comes_From_Source (P1) then
7450 while Present (P1) loop
7452 -- Neither P2 nor a source statement were located during the
7453 -- search. If we reach the end of the list, then P1 does not
7454 -- occur earlier than P2.
7456 -- ---->
7457 -- start --- P2 ----- P1 --- end
7459 if No (Next (P1)) then
7460 return False;
7462 -- We encounter P2 while going to the right of the list. This
7463 -- means that P1 does indeed appear earlier.
7465 -- ---->
7466 -- start --- P1 ===== P2 --- end
7467 -- expanded code in between
7469 elsif P1 = P2 then
7470 return True;
7472 -- No need to look any further since we have located a source
7473 -- statement.
7475 elsif Comes_From_Source (P1) then
7476 exit;
7477 end if;
7479 -- Keep going right
7481 Next (P1);
7482 end loop;
7483 end if;
7485 if not Comes_From_Source (P2) then
7486 while Present (P2) loop
7488 -- Neither P1 nor a source statement were located during the
7489 -- search. If we reach the start of the list, then P1 does not
7490 -- occur earlier than P2.
7492 -- <----
7493 -- start --- P2 --- P1 --- end
7495 if No (Prev (P2)) then
7496 return False;
7498 -- We encounter P1 while going to the left of the list. This
7499 -- means that P1 does indeed appear earlier.
7501 -- <----
7502 -- start --- P1 ===== P2 --- end
7503 -- expanded code in between
7505 elsif P2 = P1 then
7506 return True;
7508 -- No need to look any further since we have located a source
7509 -- statement.
7511 elsif Comes_From_Source (P2) then
7512 exit;
7513 end if;
7515 -- Keep going left
7517 Prev (P2);
7518 end loop;
7519 end if;
7521 -- At this point either both nodes came from source or we approximated
7522 -- their source locations through neighbouring source statements.
7524 T1 := Top_Level_Location (Sloc (P1));
7525 T2 := Top_Level_Location (Sloc (P2));
7527 -- When two nodes come from the same instance, they have identical top
7528 -- level locations. To determine proper relation within the tree, check
7529 -- their locations within the template.
7531 if T1 = T2 then
7532 return Sloc (P1) < Sloc (P2);
7534 -- The two nodes either come from unrelated instances or do not come
7535 -- from instantiated code at all.
7537 else
7538 return T1 < T2;
7539 end if;
7540 end Earlier;
7542 ----------------------
7543 -- Find_Actual_Type --
7544 ----------------------
7546 function Find_Actual_Type
7547 (Typ : Entity_Id;
7548 Gen_Type : Entity_Id) return Entity_Id
7550 Gen_Scope : constant Entity_Id := Scope (Gen_Type);
7551 T : Entity_Id;
7553 begin
7554 -- Special processing only applies to child units
7556 if not Is_Child_Unit (Gen_Scope) then
7557 return Get_Instance_Of (Typ);
7559 -- If designated or component type is itself a formal of the child unit,
7560 -- its instance is available.
7562 elsif Scope (Typ) = Gen_Scope then
7563 return Get_Instance_Of (Typ);
7565 -- If the array or access type is not declared in the parent unit,
7566 -- no special processing needed.
7568 elsif not Is_Generic_Type (Typ)
7569 and then Scope (Gen_Scope) /= Scope (Typ)
7570 then
7571 return Get_Instance_Of (Typ);
7573 -- Otherwise, retrieve designated or component type by visibility
7575 else
7576 T := Current_Entity (Typ);
7577 while Present (T) loop
7578 if In_Open_Scopes (Scope (T)) then
7579 return T;
7581 elsif Is_Generic_Actual_Type (T) then
7582 return T;
7583 end if;
7585 T := Homonym (T);
7586 end loop;
7588 return Typ;
7589 end if;
7590 end Find_Actual_Type;
7592 ----------------------------
7593 -- Freeze_Subprogram_Body --
7594 ----------------------------
7596 procedure Freeze_Subprogram_Body
7597 (Inst_Node : Node_Id;
7598 Gen_Body : Node_Id;
7599 Pack_Id : Entity_Id)
7601 Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node);
7602 Par : constant Entity_Id := Scope (Gen_Unit);
7603 E_G_Id : Entity_Id;
7604 Enc_G : Entity_Id;
7605 Enc_I : Node_Id;
7606 F_Node : Node_Id;
7608 function Enclosing_Package_Body (N : Node_Id) return Node_Id;
7609 -- Find innermost package body that encloses the given node, and which
7610 -- is not a compilation unit. Freeze nodes for the instance, or for its
7611 -- enclosing body, may be inserted after the enclosing_body of the
7612 -- generic unit. Used to determine proper placement of freeze node for
7613 -- both package and subprogram instances.
7615 function Package_Freeze_Node (B : Node_Id) return Node_Id;
7616 -- Find entity for given package body, and locate or create a freeze
7617 -- node for it.
7619 ----------------------------
7620 -- Enclosing_Package_Body --
7621 ----------------------------
7623 function Enclosing_Package_Body (N : Node_Id) return Node_Id is
7624 P : Node_Id;
7626 begin
7627 P := Parent (N);
7628 while Present (P)
7629 and then Nkind (Parent (P)) /= N_Compilation_Unit
7630 loop
7631 if Nkind (P) = N_Package_Body then
7632 if Nkind (Parent (P)) = N_Subunit then
7633 return Corresponding_Stub (Parent (P));
7634 else
7635 return P;
7636 end if;
7637 end if;
7639 P := True_Parent (P);
7640 end loop;
7642 return Empty;
7643 end Enclosing_Package_Body;
7645 -------------------------
7646 -- Package_Freeze_Node --
7647 -------------------------
7649 function Package_Freeze_Node (B : Node_Id) return Node_Id is
7650 Id : Entity_Id;
7652 begin
7653 if Nkind (B) = N_Package_Body then
7654 Id := Corresponding_Spec (B);
7655 else pragma Assert (Nkind (B) = N_Package_Body_Stub);
7656 Id := Corresponding_Spec (Proper_Body (Unit (Library_Unit (B))));
7657 end if;
7659 Ensure_Freeze_Node (Id);
7660 return Freeze_Node (Id);
7661 end Package_Freeze_Node;
7663 -- Start of processing of Freeze_Subprogram_Body
7665 begin
7666 -- If the instance and the generic body appear within the same unit, and
7667 -- the instance precedes the generic, the freeze node for the instance
7668 -- must appear after that of the generic. If the generic is nested
7669 -- within another instance I2, then current instance must be frozen
7670 -- after I2. In both cases, the freeze nodes are those of enclosing
7671 -- packages. Otherwise, the freeze node is placed at the end of the
7672 -- current declarative part.
7674 Enc_G := Enclosing_Package_Body (Gen_Body);
7675 Enc_I := Enclosing_Package_Body (Inst_Node);
7676 Ensure_Freeze_Node (Pack_Id);
7677 F_Node := Freeze_Node (Pack_Id);
7679 if Is_Generic_Instance (Par)
7680 and then Present (Freeze_Node (Par))
7681 and then In_Same_Declarative_Part (Freeze_Node (Par), Inst_Node)
7682 then
7683 -- The parent was a premature instantiation. Insert freeze node at
7684 -- the end the current declarative part.
7686 if ABE_Is_Certain (Get_Package_Instantiation_Node (Par)) then
7687 Insert_Freeze_Node_For_Instance (Inst_Node, F_Node);
7689 -- Handle the following case:
7691 -- package Parent_Inst is new ...
7692 -- Parent_Inst []
7694 -- procedure P ... -- this body freezes Parent_Inst
7696 -- package Inst is new ...
7698 -- In this particular scenario, the freeze node for Inst must be
7699 -- inserted in the same manner as that of Parent_Inst - before the
7700 -- next source body or at the end of the declarative list (body not
7701 -- available). If body P did not exist and Parent_Inst was frozen
7702 -- after Inst, either by a body following Inst or at the end of the
7703 -- declarative region, the freeze node for Inst must be inserted
7704 -- after that of Parent_Inst. This relation is established by
7705 -- comparing the Slocs of Parent_Inst freeze node and Inst.
7707 elsif List_Containing (Get_Package_Instantiation_Node (Par)) =
7708 List_Containing (Inst_Node)
7709 and then Sloc (Freeze_Node (Par)) < Sloc (Inst_Node)
7710 then
7711 Insert_Freeze_Node_For_Instance (Inst_Node, F_Node);
7713 else
7714 Insert_After (Freeze_Node (Par), F_Node);
7715 end if;
7717 -- The body enclosing the instance should be frozen after the body that
7718 -- includes the generic, because the body of the instance may make
7719 -- references to entities therein. If the two are not in the same
7720 -- declarative part, or if the one enclosing the instance is frozen
7721 -- already, freeze the instance at the end of the current declarative
7722 -- part.
7724 elsif Is_Generic_Instance (Par)
7725 and then Present (Freeze_Node (Par))
7726 and then Present (Enc_I)
7727 then
7728 if In_Same_Declarative_Part (Freeze_Node (Par), Enc_I)
7729 or else
7730 (Nkind (Enc_I) = N_Package_Body
7731 and then
7732 In_Same_Declarative_Part (Freeze_Node (Par), Parent (Enc_I)))
7733 then
7734 -- The enclosing package may contain several instances. Rather
7735 -- than computing the earliest point at which to insert its freeze
7736 -- node, we place it at the end of the declarative part of the
7737 -- parent of the generic.
7739 Insert_Freeze_Node_For_Instance
7740 (Freeze_Node (Par), Package_Freeze_Node (Enc_I));
7741 end if;
7743 Insert_Freeze_Node_For_Instance (Inst_Node, F_Node);
7745 elsif Present (Enc_G)
7746 and then Present (Enc_I)
7747 and then Enc_G /= Enc_I
7748 and then Earlier (Inst_Node, Gen_Body)
7749 then
7750 if Nkind (Enc_G) = N_Package_Body then
7751 E_G_Id := Corresponding_Spec (Enc_G);
7752 else pragma Assert (Nkind (Enc_G) = N_Package_Body_Stub);
7753 E_G_Id :=
7754 Corresponding_Spec (Proper_Body (Unit (Library_Unit (Enc_G))));
7755 end if;
7757 -- Freeze package that encloses instance, and place node after the
7758 -- package that encloses generic. If enclosing package is already
7759 -- frozen we have to assume it is at the proper place. This may be a
7760 -- potential ABE that requires dynamic checking. Do not add a freeze
7761 -- node if the package that encloses the generic is inside the body
7762 -- that encloses the instance, because the freeze node would be in
7763 -- the wrong scope. Additional contortions needed if the bodies are
7764 -- within a subunit.
7766 declare
7767 Enclosing_Body : Node_Id;
7769 begin
7770 if Nkind (Enc_I) = N_Package_Body_Stub then
7771 Enclosing_Body := Proper_Body (Unit (Library_Unit (Enc_I)));
7772 else
7773 Enclosing_Body := Enc_I;
7774 end if;
7776 if Parent (List_Containing (Enc_G)) /= Enclosing_Body then
7777 Insert_Freeze_Node_For_Instance
7778 (Enc_G, Package_Freeze_Node (Enc_I));
7779 end if;
7780 end;
7782 -- Freeze enclosing subunit before instance
7784 Ensure_Freeze_Node (E_G_Id);
7786 if not Is_List_Member (Freeze_Node (E_G_Id)) then
7787 Insert_After (Enc_G, Freeze_Node (E_G_Id));
7788 end if;
7790 Insert_Freeze_Node_For_Instance (Inst_Node, F_Node);
7792 else
7793 -- If none of the above, insert freeze node at the end of the current
7794 -- declarative part.
7796 Insert_Freeze_Node_For_Instance (Inst_Node, F_Node);
7797 end if;
7798 end Freeze_Subprogram_Body;
7800 ----------------
7801 -- Get_Gen_Id --
7802 ----------------
7804 function Get_Gen_Id (E : Assoc_Ptr) return Entity_Id is
7805 begin
7806 return Generic_Renamings.Table (E).Gen_Id;
7807 end Get_Gen_Id;
7809 ---------------------
7810 -- Get_Instance_Of --
7811 ---------------------
7813 function Get_Instance_Of (A : Entity_Id) return Entity_Id is
7814 Res : constant Assoc_Ptr := Generic_Renamings_HTable.Get (A);
7816 begin
7817 if Res /= Assoc_Null then
7818 return Generic_Renamings.Table (Res).Act_Id;
7819 else
7820 -- On exit, entity is not instantiated: not a generic parameter, or
7821 -- else parameter of an inner generic unit.
7823 return A;
7824 end if;
7825 end Get_Instance_Of;
7827 ------------------------------------
7828 -- Get_Package_Instantiation_Node --
7829 ------------------------------------
7831 function Get_Package_Instantiation_Node (A : Entity_Id) return Node_Id is
7832 Decl : Node_Id := Unit_Declaration_Node (A);
7833 Inst : Node_Id;
7835 begin
7836 -- If the Package_Instantiation attribute has been set on the package
7837 -- entity, then use it directly when it (or its Original_Node) refers
7838 -- to an N_Package_Instantiation node. In principle it should be
7839 -- possible to have this field set in all cases, which should be
7840 -- investigated, and would allow this function to be significantly
7841 -- simplified. ???
7843 Inst := Package_Instantiation (A);
7845 if Present (Inst) then
7846 if Nkind (Inst) = N_Package_Instantiation then
7847 return Inst;
7849 elsif Nkind (Original_Node (Inst)) = N_Package_Instantiation then
7850 return Original_Node (Inst);
7851 end if;
7852 end if;
7854 -- If the instantiation is a compilation unit that does not need body
7855 -- then the instantiation node has been rewritten as a package
7856 -- declaration for the instance, and we return the original node.
7858 -- If it is a compilation unit and the instance node has not been
7859 -- rewritten, then it is still the unit of the compilation. Finally, if
7860 -- a body is present, this is a parent of the main unit whose body has
7861 -- been compiled for inlining purposes, and the instantiation node has
7862 -- been rewritten with the instance body.
7864 -- Otherwise the instantiation node appears after the declaration. If
7865 -- the entity is a formal package, the declaration may have been
7866 -- rewritten as a generic declaration (in the case of a formal with box)
7867 -- or left as a formal package declaration if it has actuals, and is
7868 -- found with a forward search.
7870 if Nkind (Parent (Decl)) = N_Compilation_Unit then
7871 if Nkind (Decl) = N_Package_Declaration
7872 and then Present (Corresponding_Body (Decl))
7873 then
7874 Decl := Unit_Declaration_Node (Corresponding_Body (Decl));
7875 end if;
7877 if Nkind (Original_Node (Decl)) = N_Package_Instantiation then
7878 return Original_Node (Decl);
7879 else
7880 return Unit (Parent (Decl));
7881 end if;
7883 elsif Nkind (Decl) = N_Package_Declaration
7884 and then Nkind (Original_Node (Decl)) = N_Formal_Package_Declaration
7885 then
7886 return Original_Node (Decl);
7888 else
7889 Inst := Next (Decl);
7890 while not Nkind_In (Inst, N_Package_Instantiation,
7891 N_Formal_Package_Declaration)
7892 loop
7893 Next (Inst);
7894 end loop;
7896 return Inst;
7897 end if;
7898 end Get_Package_Instantiation_Node;
7900 ------------------------
7901 -- Has_Been_Exchanged --
7902 ------------------------
7904 function Has_Been_Exchanged (E : Entity_Id) return Boolean is
7905 Next : Elmt_Id;
7907 begin
7908 Next := First_Elmt (Exchanged_Views);
7909 while Present (Next) loop
7910 if Full_View (Node (Next)) = E then
7911 return True;
7912 end if;
7914 Next_Elmt (Next);
7915 end loop;
7917 return False;
7918 end Has_Been_Exchanged;
7920 ----------
7921 -- Hash --
7922 ----------
7924 function Hash (F : Entity_Id) return HTable_Range is
7925 begin
7926 return HTable_Range (F mod HTable_Size);
7927 end Hash;
7929 ------------------------
7930 -- Hide_Current_Scope --
7931 ------------------------
7933 procedure Hide_Current_Scope is
7934 C : constant Entity_Id := Current_Scope;
7935 E : Entity_Id;
7937 begin
7938 Set_Is_Hidden_Open_Scope (C);
7940 E := First_Entity (C);
7941 while Present (E) loop
7942 if Is_Immediately_Visible (E) then
7943 Set_Is_Immediately_Visible (E, False);
7944 Append_Elmt (E, Hidden_Entities);
7945 end if;
7947 Next_Entity (E);
7948 end loop;
7950 -- Make the scope name invisible as well. This is necessary, but might
7951 -- conflict with calls to Rtsfind later on, in case the scope is a
7952 -- predefined one. There is no clean solution to this problem, so for
7953 -- now we depend on the user not redefining Standard itself in one of
7954 -- the parent units.
7956 if Is_Immediately_Visible (C) and then C /= Standard_Standard then
7957 Set_Is_Immediately_Visible (C, False);
7958 Append_Elmt (C, Hidden_Entities);
7959 end if;
7961 end Hide_Current_Scope;
7963 --------------
7964 -- Init_Env --
7965 --------------
7967 procedure Init_Env is
7968 Saved : Instance_Env;
7970 begin
7971 Saved.Instantiated_Parent := Current_Instantiated_Parent;
7972 Saved.Exchanged_Views := Exchanged_Views;
7973 Saved.Hidden_Entities := Hidden_Entities;
7974 Saved.Current_Sem_Unit := Current_Sem_Unit;
7975 Saved.Parent_Unit_Visible := Parent_Unit_Visible;
7976 Saved.Instance_Parent_Unit := Instance_Parent_Unit;
7978 -- Save configuration switches. These may be reset if the unit is a
7979 -- predefined unit, and the current mode is not Ada 2005.
7981 Save_Opt_Config_Switches (Saved.Switches);
7983 Instance_Envs.Append (Saved);
7985 Exchanged_Views := New_Elmt_List;
7986 Hidden_Entities := New_Elmt_List;
7988 -- Make dummy entry for Instantiated parent. If generic unit is legal,
7989 -- this is set properly in Set_Instance_Env.
7991 Current_Instantiated_Parent :=
7992 (Current_Scope, Current_Scope, Assoc_Null);
7993 end Init_Env;
7995 ------------------------------
7996 -- In_Same_Declarative_Part --
7997 ------------------------------
7999 function In_Same_Declarative_Part
8000 (F_Node : Node_Id;
8001 Inst : Node_Id) return Boolean
8003 Decls : constant Node_Id := Parent (F_Node);
8004 Nod : Node_Id := Parent (Inst);
8006 begin
8007 while Present (Nod) loop
8008 if Nod = Decls then
8009 return True;
8011 elsif Nkind_In (Nod, N_Subprogram_Body,
8012 N_Package_Body,
8013 N_Package_Declaration,
8014 N_Task_Body,
8015 N_Protected_Body,
8016 N_Block_Statement)
8017 then
8018 return False;
8020 elsif Nkind (Nod) = N_Subunit then
8021 Nod := Corresponding_Stub (Nod);
8023 elsif Nkind (Nod) = N_Compilation_Unit then
8024 return False;
8026 else
8027 Nod := Parent (Nod);
8028 end if;
8029 end loop;
8031 return False;
8032 end In_Same_Declarative_Part;
8034 ---------------------
8035 -- In_Main_Context --
8036 ---------------------
8038 function In_Main_Context (E : Entity_Id) return Boolean is
8039 Context : List_Id;
8040 Clause : Node_Id;
8041 Nam : Node_Id;
8043 begin
8044 if not Is_Compilation_Unit (E)
8045 or else Ekind (E) /= E_Package
8046 or else In_Private_Part (E)
8047 then
8048 return False;
8049 end if;
8051 Context := Context_Items (Cunit (Main_Unit));
8053 Clause := First (Context);
8054 while Present (Clause) loop
8055 if Nkind (Clause) = N_With_Clause then
8056 Nam := Name (Clause);
8058 -- If the current scope is part of the context of the main unit,
8059 -- analysis of the corresponding with_clause is not complete, and
8060 -- the entity is not set. We use the Chars field directly, which
8061 -- might produce false positives in rare cases, but guarantees
8062 -- that we produce all the instance bodies we will need.
8064 if (Is_Entity_Name (Nam) and then Chars (Nam) = Chars (E))
8065 or else (Nkind (Nam) = N_Selected_Component
8066 and then Chars (Selector_Name (Nam)) = Chars (E))
8067 then
8068 return True;
8069 end if;
8070 end if;
8072 Next (Clause);
8073 end loop;
8075 return False;
8076 end In_Main_Context;
8078 ---------------------
8079 -- Inherit_Context --
8080 ---------------------
8082 procedure Inherit_Context (Gen_Decl : Node_Id; Inst : Node_Id) is
8083 Current_Context : List_Id;
8084 Current_Unit : Node_Id;
8085 Item : Node_Id;
8086 New_I : Node_Id;
8088 Clause : Node_Id;
8089 OK : Boolean;
8090 Lib_Unit : Node_Id;
8092 begin
8093 if Nkind (Parent (Gen_Decl)) = N_Compilation_Unit then
8095 -- The inherited context is attached to the enclosing compilation
8096 -- unit. This is either the main unit, or the declaration for the
8097 -- main unit (in case the instantiation appears within the package
8098 -- declaration and the main unit is its body).
8100 Current_Unit := Parent (Inst);
8101 while Present (Current_Unit)
8102 and then Nkind (Current_Unit) /= N_Compilation_Unit
8103 loop
8104 Current_Unit := Parent (Current_Unit);
8105 end loop;
8107 Current_Context := Context_Items (Current_Unit);
8109 Item := First (Context_Items (Parent (Gen_Decl)));
8110 while Present (Item) loop
8111 if Nkind (Item) = N_With_Clause then
8112 Lib_Unit := Library_Unit (Item);
8114 -- Take care to prevent direct cyclic with's
8116 if Lib_Unit /= Current_Unit then
8118 -- Do not add a unit if it is already in the context
8120 Clause := First (Current_Context);
8121 OK := True;
8122 while Present (Clause) loop
8123 if Nkind (Clause) = N_With_Clause and then
8124 Library_Unit (Clause) = Lib_Unit
8125 then
8126 OK := False;
8127 exit;
8128 end if;
8130 Next (Clause);
8131 end loop;
8133 if OK then
8134 New_I := New_Copy (Item);
8135 Set_Implicit_With (New_I, True);
8136 Set_Implicit_With_From_Instantiation (New_I, True);
8137 Append (New_I, Current_Context);
8138 end if;
8139 end if;
8140 end if;
8142 Next (Item);
8143 end loop;
8144 end if;
8145 end Inherit_Context;
8147 ----------------
8148 -- Initialize --
8149 ----------------
8151 procedure Initialize is
8152 begin
8153 Generic_Renamings.Init;
8154 Instance_Envs.Init;
8155 Generic_Flags.Init;
8156 Generic_Renamings_HTable.Reset;
8157 Circularity_Detected := False;
8158 Exchanged_Views := No_Elist;
8159 Hidden_Entities := No_Elist;
8160 end Initialize;
8162 -------------------------------------
8163 -- Insert_Freeze_Node_For_Instance --
8164 -------------------------------------
8166 procedure Insert_Freeze_Node_For_Instance
8167 (N : Node_Id;
8168 F_Node : Node_Id)
8170 Decl : Node_Id;
8171 Decls : List_Id;
8172 Inst : Entity_Id;
8173 Par_N : Node_Id;
8175 function Enclosing_Body (N : Node_Id) return Node_Id;
8176 -- Find enclosing package or subprogram body, if any. Freeze node may
8177 -- be placed at end of current declarative list if previous instance
8178 -- and current one have different enclosing bodies.
8180 function Previous_Instance (Gen : Entity_Id) return Entity_Id;
8181 -- Find the local instance, if any, that declares the generic that is
8182 -- being instantiated. If present, the freeze node for this instance
8183 -- must follow the freeze node for the previous instance.
8185 --------------------
8186 -- Enclosing_Body --
8187 --------------------
8189 function Enclosing_Body (N : Node_Id) return Node_Id is
8190 P : Node_Id;
8192 begin
8193 P := Parent (N);
8194 while Present (P)
8195 and then Nkind (Parent (P)) /= N_Compilation_Unit
8196 loop
8197 if Nkind_In (P, N_Package_Body, N_Subprogram_Body) then
8198 if Nkind (Parent (P)) = N_Subunit then
8199 return Corresponding_Stub (Parent (P));
8200 else
8201 return P;
8202 end if;
8203 end if;
8205 P := True_Parent (P);
8206 end loop;
8208 return Empty;
8209 end Enclosing_Body;
8211 -----------------------
8212 -- Previous_Instance --
8213 -----------------------
8215 function Previous_Instance (Gen : Entity_Id) return Entity_Id is
8216 S : Entity_Id;
8218 begin
8219 S := Scope (Gen);
8220 while Present (S)
8221 and then S /= Standard_Standard
8222 loop
8223 if Is_Generic_Instance (S)
8224 and then In_Same_Source_Unit (S, N)
8225 then
8226 return S;
8227 end if;
8229 S := Scope (S);
8230 end loop;
8232 return Empty;
8233 end Previous_Instance;
8235 -- Start of processing for Insert_Freeze_Node_For_Instance
8237 begin
8238 if not Is_List_Member (F_Node) then
8239 Decl := N;
8240 Decls := List_Containing (N);
8241 Inst := Entity (F_Node);
8242 Par_N := Parent (Decls);
8244 -- When processing a subprogram instantiation, utilize the actual
8245 -- subprogram instantiation rather than its package wrapper as it
8246 -- carries all the context information.
8248 if Is_Wrapper_Package (Inst) then
8249 Inst := Related_Instance (Inst);
8250 end if;
8252 -- If this is a package instance, check whether the generic is
8253 -- declared in a previous instance and the current instance is
8254 -- not within the previous one.
8256 if Present (Generic_Parent (Parent (Inst)))
8257 and then Is_In_Main_Unit (N)
8258 then
8259 declare
8260 Enclosing_N : constant Node_Id := Enclosing_Body (N);
8261 Par_I : constant Entity_Id :=
8262 Previous_Instance
8263 (Generic_Parent (Parent (Inst)));
8264 Scop : Entity_Id;
8266 begin
8267 if Present (Par_I)
8268 and then Earlier (N, Freeze_Node (Par_I))
8269 then
8270 Scop := Scope (Inst);
8272 -- If the current instance is within the one that contains
8273 -- the generic, the freeze node for the current one must
8274 -- appear in the current declarative part. Ditto, if the
8275 -- current instance is within another package instance or
8276 -- within a body that does not enclose the current instance.
8277 -- In these three cases the freeze node of the previous
8278 -- instance is not relevant.
8280 while Present (Scop)
8281 and then Scop /= Standard_Standard
8282 loop
8283 exit when Scop = Par_I
8284 or else
8285 (Is_Generic_Instance (Scop)
8286 and then Scope_Depth (Scop) > Scope_Depth (Par_I));
8287 Scop := Scope (Scop);
8288 end loop;
8290 -- Previous instance encloses current instance
8292 if Scop = Par_I then
8293 null;
8295 -- If the next node is a source body we must freeze in
8296 -- the current scope as well.
8298 elsif Present (Next (N))
8299 and then Nkind_In (Next (N),
8300 N_Subprogram_Body, N_Package_Body)
8301 and then Comes_From_Source (Next (N))
8302 then
8303 null;
8305 -- Current instance is within an unrelated instance
8307 elsif Is_Generic_Instance (Scop) then
8308 null;
8310 -- Current instance is within an unrelated body
8312 elsif Present (Enclosing_N)
8313 and then Enclosing_N /= Enclosing_Body (Par_I)
8314 then
8315 null;
8317 else
8318 Insert_After (Freeze_Node (Par_I), F_Node);
8319 return;
8320 end if;
8321 end if;
8322 end;
8323 end if;
8325 -- When the instantiation occurs in a package declaration, append the
8326 -- freeze node to the private declarations (if any).
8328 if Nkind (Par_N) = N_Package_Specification
8329 and then Decls = Visible_Declarations (Par_N)
8330 and then Present (Private_Declarations (Par_N))
8331 and then not Is_Empty_List (Private_Declarations (Par_N))
8332 then
8333 Decls := Private_Declarations (Par_N);
8334 Decl := First (Decls);
8335 end if;
8337 -- Determine the proper freeze point of a package instantiation. We
8338 -- adhere to the general rule of a package or subprogram body causing
8339 -- freezing of anything before it in the same declarative region. In
8340 -- this case, the proper freeze point of a package instantiation is
8341 -- before the first source body which follows, or before a stub. This
8342 -- ensures that entities coming from the instance are already frozen
8343 -- and usable in source bodies.
8345 if Nkind (Par_N) /= N_Package_Declaration
8346 and then Ekind (Inst) = E_Package
8347 and then Is_Generic_Instance (Inst)
8348 and then
8349 not In_Same_Source_Unit (Generic_Parent (Parent (Inst)), Inst)
8350 then
8351 while Present (Decl) loop
8352 if (Nkind (Decl) in N_Unit_Body
8353 or else
8354 Nkind (Decl) in N_Body_Stub)
8355 and then Comes_From_Source (Decl)
8356 then
8357 Insert_Before (Decl, F_Node);
8358 return;
8359 end if;
8361 Next (Decl);
8362 end loop;
8363 end if;
8365 -- In a package declaration, or if no previous body, insert at end
8366 -- of list.
8368 Set_Sloc (F_Node, Sloc (Last (Decls)));
8369 Insert_After (Last (Decls), F_Node);
8370 end if;
8371 end Insert_Freeze_Node_For_Instance;
8373 ------------------
8374 -- Install_Body --
8375 ------------------
8377 procedure Install_Body
8378 (Act_Body : Node_Id;
8379 N : Node_Id;
8380 Gen_Body : Node_Id;
8381 Gen_Decl : Node_Id)
8383 Act_Id : constant Entity_Id := Corresponding_Spec (Act_Body);
8384 Act_Unit : constant Node_Id := Unit (Cunit (Get_Source_Unit (N)));
8385 Gen_Id : constant Entity_Id := Corresponding_Spec (Gen_Body);
8386 Par : constant Entity_Id := Scope (Gen_Id);
8387 Gen_Unit : constant Node_Id :=
8388 Unit (Cunit (Get_Source_Unit (Gen_Decl)));
8389 Orig_Body : Node_Id := Gen_Body;
8390 F_Node : Node_Id;
8391 Body_Unit : Node_Id;
8393 Must_Delay : Boolean;
8395 function In_Same_Enclosing_Subp return Boolean;
8396 -- Check whether instance and generic body are within same subprogram.
8398 function True_Sloc (N : Node_Id) return Source_Ptr;
8399 -- If the instance is nested inside a generic unit, the Sloc of the
8400 -- instance indicates the place of the original definition, not the
8401 -- point of the current enclosing instance. Pending a better usage of
8402 -- Slocs to indicate instantiation places, we determine the place of
8403 -- origin of a node by finding the maximum sloc of any ancestor node.
8404 -- Why is this not equivalent to Top_Level_Location ???
8406 ----------------------------
8407 -- In_Same_Enclosing_Subp --
8408 ----------------------------
8410 function In_Same_Enclosing_Subp return Boolean is
8411 Scop : Entity_Id;
8412 Subp : Entity_Id;
8414 begin
8415 Scop := Scope (Act_Id);
8416 while Scop /= Standard_Standard
8417 and then not Is_Overloadable (Scop)
8418 loop
8419 Scop := Scope (Scop);
8420 end loop;
8422 if Scop = Standard_Standard then
8423 return False;
8424 else
8425 Subp := Scop;
8426 end if;
8428 Scop := Scope (Gen_Id);
8429 while Scop /= Standard_Standard loop
8430 if Scop = Subp then
8431 return True;
8432 else
8433 Scop := Scope (Scop);
8434 end if;
8435 end loop;
8437 return False;
8438 end In_Same_Enclosing_Subp;
8440 ---------------
8441 -- True_Sloc --
8442 ---------------
8444 function True_Sloc (N : Node_Id) return Source_Ptr is
8445 Res : Source_Ptr;
8446 N1 : Node_Id;
8448 begin
8449 Res := Sloc (N);
8450 N1 := N;
8451 while Present (N1) and then N1 /= Act_Unit loop
8452 if Sloc (N1) > Res then
8453 Res := Sloc (N1);
8454 end if;
8456 N1 := Parent (N1);
8457 end loop;
8459 return Res;
8460 end True_Sloc;
8462 -- Start of processing for Install_Body
8464 begin
8465 -- If the body is a subunit, the freeze point is the corresponding stub
8466 -- in the current compilation, not the subunit itself.
8468 if Nkind (Parent (Gen_Body)) = N_Subunit then
8469 Orig_Body := Corresponding_Stub (Parent (Gen_Body));
8470 else
8471 Orig_Body := Gen_Body;
8472 end if;
8474 Body_Unit := Unit (Cunit (Get_Source_Unit (Orig_Body)));
8476 -- If the instantiation and the generic definition appear in the same
8477 -- package declaration, this is an early instantiation. If they appear
8478 -- in the same declarative part, it is an early instantiation only if
8479 -- the generic body appears textually later, and the generic body is
8480 -- also in the main unit.
8482 -- If instance is nested within a subprogram, and the generic body
8483 -- is not, the instance is delayed because the enclosing body is. If
8484 -- instance and body are within the same scope, or the same subprogram
8485 -- body, indicate explicitly that the instance is delayed.
8487 Must_Delay :=
8488 (Gen_Unit = Act_Unit
8489 and then (Nkind_In (Gen_Unit, N_Package_Declaration,
8490 N_Generic_Package_Declaration)
8491 or else (Gen_Unit = Body_Unit
8492 and then True_Sloc (N) < Sloc (Orig_Body)))
8493 and then Is_In_Main_Unit (Gen_Unit)
8494 and then (Scope (Act_Id) = Scope (Gen_Id)
8495 or else In_Same_Enclosing_Subp));
8497 -- If this is an early instantiation, the freeze node is placed after
8498 -- the generic body. Otherwise, if the generic appears in an instance,
8499 -- we cannot freeze the current instance until the outer one is frozen.
8500 -- This is only relevant if the current instance is nested within some
8501 -- inner scope not itself within the outer instance. If this scope is
8502 -- a package body in the same declarative part as the outer instance,
8503 -- then that body needs to be frozen after the outer instance. Finally,
8504 -- if no delay is needed, we place the freeze node at the end of the
8505 -- current declarative part.
8507 if Expander_Active then
8508 Ensure_Freeze_Node (Act_Id);
8509 F_Node := Freeze_Node (Act_Id);
8511 if Must_Delay then
8512 Insert_After (Orig_Body, F_Node);
8514 elsif Is_Generic_Instance (Par)
8515 and then Present (Freeze_Node (Par))
8516 and then Scope (Act_Id) /= Par
8517 then
8518 -- Freeze instance of inner generic after instance of enclosing
8519 -- generic.
8521 if In_Same_Declarative_Part (Freeze_Node (Par), N) then
8523 -- Handle the following case:
8525 -- package Parent_Inst is new ...
8526 -- Parent_Inst []
8528 -- procedure P ... -- this body freezes Parent_Inst
8530 -- package Inst is new ...
8532 -- In this particular scenario, the freeze node for Inst must
8533 -- be inserted in the same manner as that of Parent_Inst,
8534 -- before the next source body or at the end of the declarative
8535 -- list (body not available). If body P did not exist and
8536 -- Parent_Inst was frozen after Inst, either by a body
8537 -- following Inst or at the end of the declarative region,
8538 -- the freeze node for Inst must be inserted after that of
8539 -- Parent_Inst. This relation is established by comparing
8540 -- the Slocs of Parent_Inst freeze node and Inst.
8542 if List_Containing (Get_Package_Instantiation_Node (Par)) =
8543 List_Containing (N)
8544 and then Sloc (Freeze_Node (Par)) < Sloc (N)
8545 then
8546 Insert_Freeze_Node_For_Instance (N, F_Node);
8547 else
8548 Insert_After (Freeze_Node (Par), F_Node);
8549 end if;
8551 -- Freeze package enclosing instance of inner generic after
8552 -- instance of enclosing generic.
8554 elsif Nkind_In (Parent (N), N_Package_Body, N_Subprogram_Body)
8555 and then In_Same_Declarative_Part (Freeze_Node (Par), Parent (N))
8556 then
8557 declare
8558 Enclosing : Entity_Id;
8560 begin
8561 Enclosing := Corresponding_Spec (Parent (N));
8563 if No (Enclosing) then
8564 Enclosing := Defining_Entity (Parent (N));
8565 end if;
8567 Insert_Freeze_Node_For_Instance (N, F_Node);
8568 Ensure_Freeze_Node (Enclosing);
8570 if not Is_List_Member (Freeze_Node (Enclosing)) then
8572 -- The enclosing context is a subunit, insert the freeze
8573 -- node after the stub.
8575 if Nkind (Parent (Parent (N))) = N_Subunit then
8576 Insert_Freeze_Node_For_Instance
8577 (Corresponding_Stub (Parent (Parent (N))),
8578 Freeze_Node (Enclosing));
8580 -- The enclosing context is a package with a stub body
8581 -- which has already been replaced by the real body.
8582 -- Insert the freeze node after the actual body.
8584 elsif Ekind (Enclosing) = E_Package
8585 and then Present (Body_Entity (Enclosing))
8586 and then Was_Originally_Stub
8587 (Parent (Body_Entity (Enclosing)))
8588 then
8589 Insert_Freeze_Node_For_Instance
8590 (Parent (Body_Entity (Enclosing)),
8591 Freeze_Node (Enclosing));
8593 -- The parent instance has been frozen before the body of
8594 -- the enclosing package, insert the freeze node after
8595 -- the body.
8597 elsif List_Containing (Freeze_Node (Par)) =
8598 List_Containing (Parent (N))
8599 and then Sloc (Freeze_Node (Par)) < Sloc (Parent (N))
8600 then
8601 Insert_Freeze_Node_For_Instance
8602 (Parent (N), Freeze_Node (Enclosing));
8604 else
8605 Insert_After
8606 (Freeze_Node (Par), Freeze_Node (Enclosing));
8607 end if;
8608 end if;
8609 end;
8611 else
8612 Insert_Freeze_Node_For_Instance (N, F_Node);
8613 end if;
8615 else
8616 Insert_Freeze_Node_For_Instance (N, F_Node);
8617 end if;
8618 end if;
8620 Set_Is_Frozen (Act_Id);
8621 Insert_Before (N, Act_Body);
8622 Mark_Rewrite_Insertion (Act_Body);
8623 end Install_Body;
8625 -----------------------------
8626 -- Install_Formal_Packages --
8627 -----------------------------
8629 procedure Install_Formal_Packages (Par : Entity_Id) is
8630 E : Entity_Id;
8631 Gen : Entity_Id;
8632 Gen_E : Entity_Id := Empty;
8634 begin
8635 E := First_Entity (Par);
8637 -- If we are installing an instance parent, locate the formal packages
8638 -- of its generic parent.
8640 if Is_Generic_Instance (Par) then
8641 Gen := Generic_Parent (Package_Specification (Par));
8642 Gen_E := First_Entity (Gen);
8643 end if;
8645 while Present (E) loop
8646 if Ekind (E) = E_Package
8647 and then Nkind (Parent (E)) = N_Package_Renaming_Declaration
8648 then
8649 -- If this is the renaming for the parent instance, done
8651 if Renamed_Object (E) = Par then
8652 exit;
8654 -- The visibility of a formal of an enclosing generic is already
8655 -- correct.
8657 elsif Denotes_Formal_Package (E) then
8658 null;
8660 elsif Present (Associated_Formal_Package (E)) then
8661 Check_Generic_Actuals (Renamed_Object (E), True);
8662 Set_Is_Hidden (E, False);
8664 -- Find formal package in generic unit that corresponds to
8665 -- (instance of) formal package in instance.
8667 while Present (Gen_E) and then Chars (Gen_E) /= Chars (E) loop
8668 Next_Entity (Gen_E);
8669 end loop;
8671 if Present (Gen_E) then
8672 Map_Formal_Package_Entities (Gen_E, E);
8673 end if;
8674 end if;
8675 end if;
8677 Next_Entity (E);
8678 if Present (Gen_E) then
8679 Next_Entity (Gen_E);
8680 end if;
8681 end loop;
8682 end Install_Formal_Packages;
8684 --------------------
8685 -- Install_Parent --
8686 --------------------
8688 procedure Install_Parent (P : Entity_Id; In_Body : Boolean := False) is
8689 Ancestors : constant Elist_Id := New_Elmt_List;
8690 S : constant Entity_Id := Current_Scope;
8691 Inst_Par : Entity_Id;
8692 First_Par : Entity_Id;
8693 Inst_Node : Node_Id;
8694 Gen_Par : Entity_Id;
8695 First_Gen : Entity_Id;
8696 Elmt : Elmt_Id;
8698 procedure Install_Noninstance_Specs (Par : Entity_Id);
8699 -- Install the scopes of noninstance parent units ending with Par
8701 procedure Install_Spec (Par : Entity_Id);
8702 -- The child unit is within the declarative part of the parent, so the
8703 -- declarations within the parent are immediately visible.
8705 -------------------------------
8706 -- Install_Noninstance_Specs --
8707 -------------------------------
8709 procedure Install_Noninstance_Specs (Par : Entity_Id) is
8710 begin
8711 if Present (Par)
8712 and then Par /= Standard_Standard
8713 and then not In_Open_Scopes (Par)
8714 then
8715 Install_Noninstance_Specs (Scope (Par));
8716 Install_Spec (Par);
8717 end if;
8718 end Install_Noninstance_Specs;
8720 ------------------
8721 -- Install_Spec --
8722 ------------------
8724 procedure Install_Spec (Par : Entity_Id) is
8725 Spec : constant Node_Id := Package_Specification (Par);
8727 begin
8728 -- If this parent of the child instance is a top-level unit,
8729 -- then record the unit and its visibility for later resetting in
8730 -- Remove_Parent. We exclude units that are generic instances, as we
8731 -- only want to record this information for the ultimate top-level
8732 -- noninstance parent (is that always correct???).
8734 if Scope (Par) = Standard_Standard
8735 and then not Is_Generic_Instance (Par)
8736 then
8737 Parent_Unit_Visible := Is_Immediately_Visible (Par);
8738 Instance_Parent_Unit := Par;
8739 end if;
8741 -- Open the parent scope and make it and its declarations visible.
8742 -- If this point is not within a body, then only the visible
8743 -- declarations should be made visible, and installation of the
8744 -- private declarations is deferred until the appropriate point
8745 -- within analysis of the spec being instantiated (see the handling
8746 -- of parent visibility in Analyze_Package_Specification). This is
8747 -- relaxed in the case where the parent unit is Ada.Tags, to avoid
8748 -- private view problems that occur when compiling instantiations of
8749 -- a generic child of that package (Generic_Dispatching_Constructor).
8750 -- If the instance freezes a tagged type, inlinings of operations
8751 -- from Ada.Tags may need the full view of type Tag. If inlining took
8752 -- proper account of establishing visibility of inlined subprograms'
8753 -- parents then it should be possible to remove this
8754 -- special check. ???
8756 Push_Scope (Par);
8757 Set_Is_Immediately_Visible (Par);
8758 Install_Visible_Declarations (Par);
8759 Set_Use (Visible_Declarations (Spec));
8761 if In_Body or else Is_RTU (Par, Ada_Tags) then
8762 Install_Private_Declarations (Par);
8763 Set_Use (Private_Declarations (Spec));
8764 end if;
8765 end Install_Spec;
8767 -- Start of processing for Install_Parent
8769 begin
8770 -- We need to install the parent instance to compile the instantiation
8771 -- of the child, but the child instance must appear in the current
8772 -- scope. Given that we cannot place the parent above the current scope
8773 -- in the scope stack, we duplicate the current scope and unstack both
8774 -- after the instantiation is complete.
8776 -- If the parent is itself the instantiation of a child unit, we must
8777 -- also stack the instantiation of its parent, and so on. Each such
8778 -- ancestor is the prefix of the name in a prior instantiation.
8780 -- If this is a nested instance, the parent unit itself resolves to
8781 -- a renaming of the parent instance, whose declaration we need.
8783 -- Finally, the parent may be a generic (not an instance) when the
8784 -- child unit appears as a formal package.
8786 Inst_Par := P;
8788 if Present (Renamed_Entity (Inst_Par)) then
8789 Inst_Par := Renamed_Entity (Inst_Par);
8790 end if;
8792 First_Par := Inst_Par;
8794 Gen_Par := Generic_Parent (Package_Specification (Inst_Par));
8796 First_Gen := Gen_Par;
8798 while Present (Gen_Par)
8799 and then Is_Child_Unit (Gen_Par)
8800 loop
8801 -- Load grandparent instance as well
8803 Inst_Node := Get_Package_Instantiation_Node (Inst_Par);
8805 if Nkind (Name (Inst_Node)) = N_Expanded_Name then
8806 Inst_Par := Entity (Prefix (Name (Inst_Node)));
8808 if Present (Renamed_Entity (Inst_Par)) then
8809 Inst_Par := Renamed_Entity (Inst_Par);
8810 end if;
8812 Gen_Par := Generic_Parent (Package_Specification (Inst_Par));
8814 if Present (Gen_Par) then
8815 Prepend_Elmt (Inst_Par, Ancestors);
8817 else
8818 -- Parent is not the name of an instantiation
8820 Install_Noninstance_Specs (Inst_Par);
8821 exit;
8822 end if;
8824 else
8825 -- Previous error
8827 exit;
8828 end if;
8829 end loop;
8831 if Present (First_Gen) then
8832 Append_Elmt (First_Par, Ancestors);
8833 else
8834 Install_Noninstance_Specs (First_Par);
8835 end if;
8837 if not Is_Empty_Elmt_List (Ancestors) then
8838 Elmt := First_Elmt (Ancestors);
8839 while Present (Elmt) loop
8840 Install_Spec (Node (Elmt));
8841 Install_Formal_Packages (Node (Elmt));
8842 Next_Elmt (Elmt);
8843 end loop;
8844 end if;
8846 if not In_Body then
8847 Push_Scope (S);
8848 end if;
8849 end Install_Parent;
8851 -------------------------------
8852 -- Install_Hidden_Primitives --
8853 -------------------------------
8855 procedure Install_Hidden_Primitives
8856 (Prims_List : in out Elist_Id;
8857 Gen_T : Entity_Id;
8858 Act_T : Entity_Id)
8860 Elmt : Elmt_Id;
8861 List : Elist_Id := No_Elist;
8862 Prim_G_Elmt : Elmt_Id;
8863 Prim_A_Elmt : Elmt_Id;
8864 Prim_G : Node_Id;
8865 Prim_A : Node_Id;
8867 begin
8868 -- No action needed in case of serious errors because we cannot trust
8869 -- in the order of primitives
8871 if Serious_Errors_Detected > 0 then
8872 return;
8874 -- No action possible if we don't have available the list of primitive
8875 -- operations
8877 elsif No (Gen_T)
8878 or else not Is_Record_Type (Gen_T)
8879 or else not Is_Tagged_Type (Gen_T)
8880 or else not Is_Record_Type (Act_T)
8881 or else not Is_Tagged_Type (Act_T)
8882 then
8883 return;
8885 -- There is no need to handle interface types since their primitives
8886 -- cannot be hidden
8888 elsif Is_Interface (Gen_T) then
8889 return;
8890 end if;
8892 Prim_G_Elmt := First_Elmt (Primitive_Operations (Gen_T));
8894 if not Is_Class_Wide_Type (Act_T) then
8895 Prim_A_Elmt := First_Elmt (Primitive_Operations (Act_T));
8896 else
8897 Prim_A_Elmt := First_Elmt (Primitive_Operations (Root_Type (Act_T)));
8898 end if;
8900 loop
8901 -- Skip predefined primitives in the generic formal
8903 while Present (Prim_G_Elmt)
8904 and then Is_Predefined_Dispatching_Operation (Node (Prim_G_Elmt))
8905 loop
8906 Next_Elmt (Prim_G_Elmt);
8907 end loop;
8909 -- Skip predefined primitives in the generic actual
8911 while Present (Prim_A_Elmt)
8912 and then Is_Predefined_Dispatching_Operation (Node (Prim_A_Elmt))
8913 loop
8914 Next_Elmt (Prim_A_Elmt);
8915 end loop;
8917 exit when No (Prim_G_Elmt) or else No (Prim_A_Elmt);
8919 Prim_G := Node (Prim_G_Elmt);
8920 Prim_A := Node (Prim_A_Elmt);
8922 -- There is no need to handle interface primitives because their
8923 -- primitives are not hidden
8925 exit when Present (Interface_Alias (Prim_G));
8927 -- Here we install one hidden primitive
8929 if Chars (Prim_G) /= Chars (Prim_A)
8930 and then Has_Suffix (Prim_A, 'P')
8931 and then Remove_Suffix (Prim_A, 'P') = Chars (Prim_G)
8932 then
8933 Set_Chars (Prim_A, Chars (Prim_G));
8934 Append_New_Elmt (Prim_A, To => List);
8935 end if;
8937 Next_Elmt (Prim_A_Elmt);
8938 Next_Elmt (Prim_G_Elmt);
8939 end loop;
8941 -- Append the elements to the list of temporarily visible primitives
8942 -- avoiding duplicates.
8944 if Present (List) then
8945 if No (Prims_List) then
8946 Prims_List := New_Elmt_List;
8947 end if;
8949 Elmt := First_Elmt (List);
8950 while Present (Elmt) loop
8951 Append_Unique_Elmt (Node (Elmt), Prims_List);
8952 Next_Elmt (Elmt);
8953 end loop;
8954 end if;
8955 end Install_Hidden_Primitives;
8957 -------------------------------
8958 -- Restore_Hidden_Primitives --
8959 -------------------------------
8961 procedure Restore_Hidden_Primitives (Prims_List : in out Elist_Id) is
8962 Prim_Elmt : Elmt_Id;
8963 Prim : Node_Id;
8965 begin
8966 if Prims_List /= No_Elist then
8967 Prim_Elmt := First_Elmt (Prims_List);
8968 while Present (Prim_Elmt) loop
8969 Prim := Node (Prim_Elmt);
8970 Set_Chars (Prim, Add_Suffix (Prim, 'P'));
8971 Next_Elmt (Prim_Elmt);
8972 end loop;
8974 Prims_List := No_Elist;
8975 end if;
8976 end Restore_Hidden_Primitives;
8978 --------------------------------
8979 -- Instantiate_Formal_Package --
8980 --------------------------------
8982 function Instantiate_Formal_Package
8983 (Formal : Node_Id;
8984 Actual : Node_Id;
8985 Analyzed_Formal : Node_Id) return List_Id
8987 Loc : constant Source_Ptr := Sloc (Actual);
8988 Actual_Pack : Entity_Id;
8989 Formal_Pack : Entity_Id;
8990 Gen_Parent : Entity_Id;
8991 Decls : List_Id;
8992 Nod : Node_Id;
8993 Parent_Spec : Node_Id;
8995 procedure Find_Matching_Actual
8996 (F : Node_Id;
8997 Act : in out Entity_Id);
8998 -- We need to associate each formal entity in the formal package with
8999 -- the corresponding entity in the actual package. The actual package
9000 -- has been analyzed and possibly expanded, and as a result there is
9001 -- no one-to-one correspondence between the two lists (for example,
9002 -- the actual may include subtypes, itypes, and inherited primitive
9003 -- operations, interspersed among the renaming declarations for the
9004 -- actuals) . We retrieve the corresponding actual by name because each
9005 -- actual has the same name as the formal, and they do appear in the
9006 -- same order.
9008 function Get_Formal_Entity (N : Node_Id) return Entity_Id;
9009 -- Retrieve entity of defining entity of generic formal parameter.
9010 -- Only the declarations of formals need to be considered when
9011 -- linking them to actuals, but the declarative list may include
9012 -- internal entities generated during analysis, and those are ignored.
9014 procedure Match_Formal_Entity
9015 (Formal_Node : Node_Id;
9016 Formal_Ent : Entity_Id;
9017 Actual_Ent : Entity_Id);
9018 -- Associates the formal entity with the actual. In the case where
9019 -- Formal_Ent is a formal package, this procedure iterates through all
9020 -- of its formals and enters associations between the actuals occurring
9021 -- in the formal package's corresponding actual package (given by
9022 -- Actual_Ent) and the formal package's formal parameters. This
9023 -- procedure recurses if any of the parameters is itself a package.
9025 function Is_Instance_Of
9026 (Act_Spec : Entity_Id;
9027 Gen_Anc : Entity_Id) return Boolean;
9028 -- The actual can be an instantiation of a generic within another
9029 -- instance, in which case there is no direct link from it to the
9030 -- original generic ancestor. In that case, we recognize that the
9031 -- ultimate ancestor is the same by examining names and scopes.
9033 procedure Process_Nested_Formal (Formal : Entity_Id);
9034 -- If the current formal is declared with a box, its own formals are
9035 -- visible in the instance, as they were in the generic, and their
9036 -- Hidden flag must be reset. If some of these formals are themselves
9037 -- packages declared with a box, the processing must be recursive.
9039 --------------------------
9040 -- Find_Matching_Actual --
9041 --------------------------
9043 procedure Find_Matching_Actual
9044 (F : Node_Id;
9045 Act : in out Entity_Id)
9047 Formal_Ent : Entity_Id;
9049 begin
9050 case Nkind (Original_Node (F)) is
9051 when N_Formal_Object_Declaration |
9052 N_Formal_Type_Declaration =>
9053 Formal_Ent := Defining_Identifier (F);
9055 while Chars (Act) /= Chars (Formal_Ent) loop
9056 Next_Entity (Act);
9057 end loop;
9059 when N_Formal_Subprogram_Declaration |
9060 N_Formal_Package_Declaration |
9061 N_Package_Declaration |
9062 N_Generic_Package_Declaration =>
9063 Formal_Ent := Defining_Entity (F);
9065 while Chars (Act) /= Chars (Formal_Ent) loop
9066 Next_Entity (Act);
9067 end loop;
9069 when others =>
9070 raise Program_Error;
9071 end case;
9072 end Find_Matching_Actual;
9074 -------------------------
9075 -- Match_Formal_Entity --
9076 -------------------------
9078 procedure Match_Formal_Entity
9079 (Formal_Node : Node_Id;
9080 Formal_Ent : Entity_Id;
9081 Actual_Ent : Entity_Id)
9083 Act_Pkg : Entity_Id;
9085 begin
9086 Set_Instance_Of (Formal_Ent, Actual_Ent);
9088 if Ekind (Actual_Ent) = E_Package then
9090 -- Record associations for each parameter
9092 Act_Pkg := Actual_Ent;
9094 declare
9095 A_Ent : Entity_Id := First_Entity (Act_Pkg);
9096 F_Ent : Entity_Id;
9097 F_Node : Node_Id;
9099 Gen_Decl : Node_Id;
9100 Formals : List_Id;
9101 Actual : Entity_Id;
9103 begin
9104 -- Retrieve the actual given in the formal package declaration
9106 Actual := Entity (Name (Original_Node (Formal_Node)));
9108 -- The actual in the formal package declaration may be a
9109 -- renamed generic package, in which case we want to retrieve
9110 -- the original generic in order to traverse its formal part.
9112 if Present (Renamed_Entity (Actual)) then
9113 Gen_Decl := Unit_Declaration_Node (Renamed_Entity (Actual));
9114 else
9115 Gen_Decl := Unit_Declaration_Node (Actual);
9116 end if;
9118 Formals := Generic_Formal_Declarations (Gen_Decl);
9120 if Present (Formals) then
9121 F_Node := First_Non_Pragma (Formals);
9122 else
9123 F_Node := Empty;
9124 end if;
9126 while Present (A_Ent)
9127 and then Present (F_Node)
9128 and then A_Ent /= First_Private_Entity (Act_Pkg)
9129 loop
9130 F_Ent := Get_Formal_Entity (F_Node);
9132 if Present (F_Ent) then
9134 -- This is a formal of the original package. Record
9135 -- association and recurse.
9137 Find_Matching_Actual (F_Node, A_Ent);
9138 Match_Formal_Entity (F_Node, F_Ent, A_Ent);
9139 Next_Entity (A_Ent);
9140 end if;
9142 Next_Non_Pragma (F_Node);
9143 end loop;
9144 end;
9145 end if;
9146 end Match_Formal_Entity;
9148 -----------------------
9149 -- Get_Formal_Entity --
9150 -----------------------
9152 function Get_Formal_Entity (N : Node_Id) return Entity_Id is
9153 Kind : constant Node_Kind := Nkind (Original_Node (N));
9154 begin
9155 case Kind is
9156 when N_Formal_Object_Declaration =>
9157 return Defining_Identifier (N);
9159 when N_Formal_Type_Declaration =>
9160 return Defining_Identifier (N);
9162 when N_Formal_Subprogram_Declaration =>
9163 return Defining_Unit_Name (Specification (N));
9165 when N_Formal_Package_Declaration =>
9166 return Defining_Identifier (Original_Node (N));
9168 when N_Generic_Package_Declaration =>
9169 return Defining_Identifier (Original_Node (N));
9171 -- All other declarations are introduced by semantic analysis and
9172 -- have no match in the actual.
9174 when others =>
9175 return Empty;
9176 end case;
9177 end Get_Formal_Entity;
9179 --------------------
9180 -- Is_Instance_Of --
9181 --------------------
9183 function Is_Instance_Of
9184 (Act_Spec : Entity_Id;
9185 Gen_Anc : Entity_Id) return Boolean
9187 Gen_Par : constant Entity_Id := Generic_Parent (Act_Spec);
9189 begin
9190 if No (Gen_Par) then
9191 return False;
9193 -- Simplest case: the generic parent of the actual is the formal
9195 elsif Gen_Par = Gen_Anc then
9196 return True;
9198 elsif Chars (Gen_Par) /= Chars (Gen_Anc) then
9199 return False;
9201 -- The actual may be obtained through several instantiations. Its
9202 -- scope must itself be an instance of a generic declared in the
9203 -- same scope as the formal. Any other case is detected above.
9205 elsif not Is_Generic_Instance (Scope (Gen_Par)) then
9206 return False;
9208 else
9209 return Generic_Parent (Parent (Scope (Gen_Par))) = Scope (Gen_Anc);
9210 end if;
9211 end Is_Instance_Of;
9213 ---------------------------
9214 -- Process_Nested_Formal --
9215 ---------------------------
9217 procedure Process_Nested_Formal (Formal : Entity_Id) is
9218 Ent : Entity_Id;
9220 begin
9221 if Present (Associated_Formal_Package (Formal))
9222 and then Box_Present (Parent (Associated_Formal_Package (Formal)))
9223 then
9224 Ent := First_Entity (Formal);
9225 while Present (Ent) loop
9226 Set_Is_Hidden (Ent, False);
9227 Set_Is_Visible_Formal (Ent);
9228 Set_Is_Potentially_Use_Visible
9229 (Ent, Is_Potentially_Use_Visible (Formal));
9231 if Ekind (Ent) = E_Package then
9232 exit when Renamed_Entity (Ent) = Renamed_Entity (Formal);
9233 Process_Nested_Formal (Ent);
9234 end if;
9236 Next_Entity (Ent);
9237 end loop;
9238 end if;
9239 end Process_Nested_Formal;
9241 -- Start of processing for Instantiate_Formal_Package
9243 begin
9244 Analyze (Actual);
9246 if not Is_Entity_Name (Actual)
9247 or else Ekind (Entity (Actual)) /= E_Package
9248 then
9249 Error_Msg_N
9250 ("expect package instance to instantiate formal", Actual);
9251 Abandon_Instantiation (Actual);
9252 raise Program_Error;
9254 else
9255 Actual_Pack := Entity (Actual);
9256 Set_Is_Instantiated (Actual_Pack);
9258 -- The actual may be a renamed package, or an outer generic formal
9259 -- package whose instantiation is converted into a renaming.
9261 if Present (Renamed_Object (Actual_Pack)) then
9262 Actual_Pack := Renamed_Object (Actual_Pack);
9263 end if;
9265 if Nkind (Analyzed_Formal) = N_Formal_Package_Declaration then
9266 Gen_Parent := Get_Instance_Of (Entity (Name (Analyzed_Formal)));
9267 Formal_Pack := Defining_Identifier (Analyzed_Formal);
9268 else
9269 Gen_Parent :=
9270 Generic_Parent (Specification (Analyzed_Formal));
9271 Formal_Pack :=
9272 Defining_Unit_Name (Specification (Analyzed_Formal));
9273 end if;
9275 if Nkind (Parent (Actual_Pack)) = N_Defining_Program_Unit_Name then
9276 Parent_Spec := Package_Specification (Actual_Pack);
9277 else
9278 Parent_Spec := Parent (Actual_Pack);
9279 end if;
9281 if Gen_Parent = Any_Id then
9282 Error_Msg_N
9283 ("previous error in declaration of formal package", Actual);
9284 Abandon_Instantiation (Actual);
9286 elsif
9287 Is_Instance_Of (Parent_Spec, Get_Instance_Of (Gen_Parent))
9288 then
9289 null;
9291 else
9292 Error_Msg_NE
9293 ("actual parameter must be instance of&", Actual, Gen_Parent);
9294 Abandon_Instantiation (Actual);
9295 end if;
9297 Set_Instance_Of (Defining_Identifier (Formal), Actual_Pack);
9298 Map_Formal_Package_Entities (Formal_Pack, Actual_Pack);
9300 Nod :=
9301 Make_Package_Renaming_Declaration (Loc,
9302 Defining_Unit_Name => New_Copy (Defining_Identifier (Formal)),
9303 Name => New_Occurrence_Of (Actual_Pack, Loc));
9305 Set_Associated_Formal_Package (Defining_Unit_Name (Nod),
9306 Defining_Identifier (Formal));
9307 Decls := New_List (Nod);
9309 -- If the formal F has a box, then the generic declarations are
9310 -- visible in the generic G. In an instance of G, the corresponding
9311 -- entities in the actual for F (which are the actuals for the
9312 -- instantiation of the generic that F denotes) must also be made
9313 -- visible for analysis of the current instance. On exit from the
9314 -- current instance, those entities are made private again. If the
9315 -- actual is currently in use, these entities are also use-visible.
9317 -- The loop through the actual entities also steps through the formal
9318 -- entities and enters associations from formals to actuals into the
9319 -- renaming map. This is necessary to properly handle checking of
9320 -- actual parameter associations for later formals that depend on
9321 -- actuals declared in the formal package.
9323 -- In Ada 2005, partial parameterization requires that we make
9324 -- visible the actuals corresponding to formals that were defaulted
9325 -- in the formal package. There formals are identified because they
9326 -- remain formal generics within the formal package, rather than
9327 -- being renamings of the actuals supplied.
9329 declare
9330 Gen_Decl : constant Node_Id :=
9331 Unit_Declaration_Node (Gen_Parent);
9332 Formals : constant List_Id :=
9333 Generic_Formal_Declarations (Gen_Decl);
9335 Actual_Ent : Entity_Id;
9336 Actual_Of_Formal : Node_Id;
9337 Formal_Node : Node_Id;
9338 Formal_Ent : Entity_Id;
9340 begin
9341 if Present (Formals) then
9342 Formal_Node := First_Non_Pragma (Formals);
9343 else
9344 Formal_Node := Empty;
9345 end if;
9347 Actual_Ent := First_Entity (Actual_Pack);
9348 Actual_Of_Formal :=
9349 First (Visible_Declarations (Specification (Analyzed_Formal)));
9350 while Present (Actual_Ent)
9351 and then Actual_Ent /= First_Private_Entity (Actual_Pack)
9352 loop
9353 if Present (Formal_Node) then
9354 Formal_Ent := Get_Formal_Entity (Formal_Node);
9356 if Present (Formal_Ent) then
9357 Find_Matching_Actual (Formal_Node, Actual_Ent);
9358 Match_Formal_Entity
9359 (Formal_Node, Formal_Ent, Actual_Ent);
9361 -- We iterate at the same time over the actuals of the
9362 -- local package created for the formal, to determine
9363 -- which one of the formals of the original generic were
9364 -- defaulted in the formal. The corresponding actual
9365 -- entities are visible in the enclosing instance.
9367 if Box_Present (Formal)
9368 or else
9369 (Present (Actual_Of_Formal)
9370 and then
9371 Is_Generic_Formal
9372 (Get_Formal_Entity (Actual_Of_Formal)))
9373 then
9374 Set_Is_Hidden (Actual_Ent, False);
9375 Set_Is_Visible_Formal (Actual_Ent);
9376 Set_Is_Potentially_Use_Visible
9377 (Actual_Ent, In_Use (Actual_Pack));
9379 if Ekind (Actual_Ent) = E_Package then
9380 Process_Nested_Formal (Actual_Ent);
9381 end if;
9383 else
9384 Set_Is_Hidden (Actual_Ent);
9385 Set_Is_Potentially_Use_Visible (Actual_Ent, False);
9386 end if;
9387 end if;
9389 Next_Non_Pragma (Formal_Node);
9390 Next (Actual_Of_Formal);
9392 else
9393 -- No further formals to match, but the generic part may
9394 -- contain inherited operation that are not hidden in the
9395 -- enclosing instance.
9397 Next_Entity (Actual_Ent);
9398 end if;
9399 end loop;
9401 -- Inherited subprograms generated by formal derived types are
9402 -- also visible if the types are.
9404 Actual_Ent := First_Entity (Actual_Pack);
9405 while Present (Actual_Ent)
9406 and then Actual_Ent /= First_Private_Entity (Actual_Pack)
9407 loop
9408 if Is_Overloadable (Actual_Ent)
9409 and then
9410 Nkind (Parent (Actual_Ent)) = N_Subtype_Declaration
9411 and then
9412 not Is_Hidden (Defining_Identifier (Parent (Actual_Ent)))
9413 then
9414 Set_Is_Hidden (Actual_Ent, False);
9415 Set_Is_Potentially_Use_Visible
9416 (Actual_Ent, In_Use (Actual_Pack));
9417 end if;
9419 Next_Entity (Actual_Ent);
9420 end loop;
9421 end;
9423 -- If the formal is not declared with a box, reanalyze it as an
9424 -- abbreviated instantiation, to verify the matching rules of 12.7.
9425 -- The actual checks are performed after the generic associations
9426 -- have been analyzed, to guarantee the same visibility for this
9427 -- instantiation and for the actuals.
9429 -- In Ada 2005, the generic associations for the formal can include
9430 -- defaulted parameters. These are ignored during check. This
9431 -- internal instantiation is removed from the tree after conformance
9432 -- checking, because it contains formal declarations for those
9433 -- defaulted parameters, and those should not reach the back-end.
9435 if not Box_Present (Formal) then
9436 declare
9437 I_Pack : constant Entity_Id :=
9438 Make_Temporary (Sloc (Actual), 'P');
9440 begin
9441 Set_Is_Internal (I_Pack);
9443 Append_To (Decls,
9444 Make_Package_Instantiation (Sloc (Actual),
9445 Defining_Unit_Name => I_Pack,
9446 Name =>
9447 New_Occurrence_Of
9448 (Get_Instance_Of (Gen_Parent), Sloc (Actual)),
9449 Generic_Associations =>
9450 Generic_Associations (Formal)));
9451 end;
9452 end if;
9454 return Decls;
9455 end if;
9456 end Instantiate_Formal_Package;
9458 -----------------------------------
9459 -- Instantiate_Formal_Subprogram --
9460 -----------------------------------
9462 function Instantiate_Formal_Subprogram
9463 (Formal : Node_Id;
9464 Actual : Node_Id;
9465 Analyzed_Formal : Node_Id) return Node_Id
9467 Analyzed_S : constant Entity_Id :=
9468 Defining_Unit_Name (Specification (Analyzed_Formal));
9469 Formal_Sub : constant Entity_Id :=
9470 Defining_Unit_Name (Specification (Formal));
9472 function From_Parent_Scope (Subp : Entity_Id) return Boolean;
9473 -- If the generic is a child unit, the parent has been installed on the
9474 -- scope stack, but a default subprogram cannot resolve to something
9475 -- on the parent because that parent is not really part of the visible
9476 -- context (it is there to resolve explicit local entities). If the
9477 -- default has resolved in this way, we remove the entity from immediate
9478 -- visibility and analyze the node again to emit an error message or
9479 -- find another visible candidate.
9481 procedure Valid_Actual_Subprogram (Act : Node_Id);
9482 -- Perform legality check and raise exception on failure
9484 -----------------------
9485 -- From_Parent_Scope --
9486 -----------------------
9488 function From_Parent_Scope (Subp : Entity_Id) return Boolean is
9489 Gen_Scope : Node_Id;
9491 begin
9492 Gen_Scope := Scope (Analyzed_S);
9493 while Present (Gen_Scope) and then Is_Child_Unit (Gen_Scope) loop
9494 if Scope (Subp) = Scope (Gen_Scope) then
9495 return True;
9496 end if;
9498 Gen_Scope := Scope (Gen_Scope);
9499 end loop;
9501 return False;
9502 end From_Parent_Scope;
9504 -----------------------------
9505 -- Valid_Actual_Subprogram --
9506 -----------------------------
9508 procedure Valid_Actual_Subprogram (Act : Node_Id) is
9509 Act_E : Entity_Id;
9511 begin
9512 if Is_Entity_Name (Act) then
9513 Act_E := Entity (Act);
9515 elsif Nkind (Act) = N_Selected_Component
9516 and then Is_Entity_Name (Selector_Name (Act))
9517 then
9518 Act_E := Entity (Selector_Name (Act));
9520 else
9521 Act_E := Empty;
9522 end if;
9524 if (Present (Act_E) and then Is_Overloadable (Act_E))
9525 or else Nkind_In (Act, N_Attribute_Reference,
9526 N_Indexed_Component,
9527 N_Character_Literal,
9528 N_Explicit_Dereference)
9529 then
9530 return;
9531 end if;
9533 Error_Msg_NE
9534 ("expect subprogram or entry name in instantiation of&",
9535 Instantiation_Node, Formal_Sub);
9536 Abandon_Instantiation (Instantiation_Node);
9537 end Valid_Actual_Subprogram;
9539 -- Local variables
9541 Decl_Node : Node_Id;
9542 Loc : Source_Ptr;
9543 Nam : Node_Id;
9544 New_Spec : Node_Id;
9546 -- Start of processing for Instantiate_Formal_Subprogram
9548 begin
9549 New_Spec := New_Copy_Tree (Specification (Formal));
9551 -- The tree copy has created the proper instantiation sloc for the
9552 -- new specification. Use this location for all other constructed
9553 -- declarations.
9555 Loc := Sloc (Defining_Unit_Name (New_Spec));
9557 -- Create new entity for the actual (New_Copy_Tree does not)
9559 Set_Defining_Unit_Name
9560 (New_Spec, Make_Defining_Identifier (Loc, Chars (Formal_Sub)));
9562 -- Create new entities for the each of the formals in the specification
9563 -- of the renaming declaration built for the actual.
9565 if Present (Parameter_Specifications (New_Spec)) then
9566 declare
9567 F : Node_Id;
9568 F_Id : Entity_Id;
9570 begin
9571 F := First (Parameter_Specifications (New_Spec));
9572 while Present (F) loop
9573 F_Id := Defining_Identifier (F);
9575 Set_Defining_Identifier (F,
9576 Make_Defining_Identifier (Sloc (F_Id), Chars (F_Id)));
9577 Next (F);
9578 end loop;
9579 end;
9580 end if;
9582 -- Find entity of actual. If the actual is an attribute reference, it
9583 -- cannot be resolved here (its formal is missing) but is handled
9584 -- instead in Attribute_Renaming. If the actual is overloaded, it is
9585 -- fully resolved subsequently, when the renaming declaration for the
9586 -- formal is analyzed. If it is an explicit dereference, resolve the
9587 -- prefix but not the actual itself, to prevent interpretation as call.
9589 if Present (Actual) then
9590 Loc := Sloc (Actual);
9591 Set_Sloc (New_Spec, Loc);
9593 if Nkind (Actual) = N_Operator_Symbol then
9594 Find_Direct_Name (Actual);
9596 elsif Nkind (Actual) = N_Explicit_Dereference then
9597 Analyze (Prefix (Actual));
9599 elsif Nkind (Actual) /= N_Attribute_Reference then
9600 Analyze (Actual);
9601 end if;
9603 Valid_Actual_Subprogram (Actual);
9604 Nam := Actual;
9606 elsif Present (Default_Name (Formal)) then
9607 if not Nkind_In (Default_Name (Formal), N_Attribute_Reference,
9608 N_Selected_Component,
9609 N_Indexed_Component,
9610 N_Character_Literal)
9611 and then Present (Entity (Default_Name (Formal)))
9612 then
9613 Nam := New_Occurrence_Of (Entity (Default_Name (Formal)), Loc);
9614 else
9615 Nam := New_Copy (Default_Name (Formal));
9616 Set_Sloc (Nam, Loc);
9617 end if;
9619 elsif Box_Present (Formal) then
9621 -- Actual is resolved at the point of instantiation. Create an
9622 -- identifier or operator with the same name as the formal.
9624 if Nkind (Formal_Sub) = N_Defining_Operator_Symbol then
9625 Nam :=
9626 Make_Operator_Symbol (Loc,
9627 Chars => Chars (Formal_Sub),
9628 Strval => No_String);
9629 else
9630 Nam := Make_Identifier (Loc, Chars (Formal_Sub));
9631 end if;
9633 elsif Nkind (Specification (Formal)) = N_Procedure_Specification
9634 and then Null_Present (Specification (Formal))
9635 then
9636 -- Generate null body for procedure, for use in the instance
9638 Decl_Node :=
9639 Make_Subprogram_Body (Loc,
9640 Specification => New_Spec,
9641 Declarations => New_List,
9642 Handled_Statement_Sequence =>
9643 Make_Handled_Sequence_Of_Statements (Loc,
9644 Statements => New_List (Make_Null_Statement (Loc))));
9646 Set_Is_Intrinsic_Subprogram (Defining_Unit_Name (New_Spec));
9647 return Decl_Node;
9649 else
9650 Error_Msg_Sloc := Sloc (Scope (Analyzed_S));
9651 Error_Msg_NE
9652 ("missing actual&", Instantiation_Node, Formal_Sub);
9653 Error_Msg_NE
9654 ("\in instantiation of & declared#",
9655 Instantiation_Node, Scope (Analyzed_S));
9656 Abandon_Instantiation (Instantiation_Node);
9657 end if;
9659 Decl_Node :=
9660 Make_Subprogram_Renaming_Declaration (Loc,
9661 Specification => New_Spec,
9662 Name => Nam);
9664 -- If we do not have an actual and the formal specified <> then set to
9665 -- get proper default.
9667 if No (Actual) and then Box_Present (Formal) then
9668 Set_From_Default (Decl_Node);
9669 end if;
9671 -- Gather possible interpretations for the actual before analyzing the
9672 -- instance. If overloaded, it will be resolved when analyzing the
9673 -- renaming declaration.
9675 if Box_Present (Formal) and then No (Actual) then
9676 Analyze (Nam);
9678 if Is_Child_Unit (Scope (Analyzed_S))
9679 and then Present (Entity (Nam))
9680 then
9681 if not Is_Overloaded (Nam) then
9682 if From_Parent_Scope (Entity (Nam)) then
9683 Set_Is_Immediately_Visible (Entity (Nam), False);
9684 Set_Entity (Nam, Empty);
9685 Set_Etype (Nam, Empty);
9687 Analyze (Nam);
9688 Set_Is_Immediately_Visible (Entity (Nam));
9689 end if;
9691 else
9692 declare
9693 I : Interp_Index;
9694 It : Interp;
9696 begin
9697 Get_First_Interp (Nam, I, It);
9698 while Present (It.Nam) loop
9699 if From_Parent_Scope (It.Nam) then
9700 Remove_Interp (I);
9701 end if;
9703 Get_Next_Interp (I, It);
9704 end loop;
9705 end;
9706 end if;
9707 end if;
9708 end if;
9710 -- The generic instantiation freezes the actual. This can only be done
9711 -- once the actual is resolved, in the analysis of the renaming
9712 -- declaration. To make the formal subprogram entity available, we set
9713 -- Corresponding_Formal_Spec to point to the formal subprogram entity.
9714 -- This is also needed in Analyze_Subprogram_Renaming for the processing
9715 -- of formal abstract subprograms.
9717 Set_Corresponding_Formal_Spec (Decl_Node, Analyzed_S);
9719 -- We cannot analyze the renaming declaration, and thus find the actual,
9720 -- until all the actuals are assembled in the instance. For subsequent
9721 -- checks of other actuals, indicate the node that will hold the
9722 -- instance of this formal.
9724 Set_Instance_Of (Analyzed_S, Nam);
9726 if Nkind (Actual) = N_Selected_Component
9727 and then Is_Task_Type (Etype (Prefix (Actual)))
9728 and then not Is_Frozen (Etype (Prefix (Actual)))
9729 then
9730 -- The renaming declaration will create a body, which must appear
9731 -- outside of the instantiation, We move the renaming declaration
9732 -- out of the instance, and create an additional renaming inside,
9733 -- to prevent freezing anomalies.
9735 declare
9736 Anon_Id : constant Entity_Id := Make_Temporary (Loc, 'E');
9738 begin
9739 Set_Defining_Unit_Name (New_Spec, Anon_Id);
9740 Insert_Before (Instantiation_Node, Decl_Node);
9741 Analyze (Decl_Node);
9743 -- Now create renaming within the instance
9745 Decl_Node :=
9746 Make_Subprogram_Renaming_Declaration (Loc,
9747 Specification => New_Copy_Tree (New_Spec),
9748 Name => New_Occurrence_Of (Anon_Id, Loc));
9750 Set_Defining_Unit_Name (Specification (Decl_Node),
9751 Make_Defining_Identifier (Loc, Chars (Formal_Sub)));
9752 end;
9753 end if;
9755 return Decl_Node;
9756 end Instantiate_Formal_Subprogram;
9758 ------------------------
9759 -- Instantiate_Object --
9760 ------------------------
9762 function Instantiate_Object
9763 (Formal : Node_Id;
9764 Actual : Node_Id;
9765 Analyzed_Formal : Node_Id) return List_Id
9767 Gen_Obj : constant Entity_Id := Defining_Identifier (Formal);
9768 A_Gen_Obj : constant Entity_Id :=
9769 Defining_Identifier (Analyzed_Formal);
9770 Acc_Def : Node_Id := Empty;
9771 Act_Assoc : constant Node_Id := Parent (Actual);
9772 Actual_Decl : Node_Id := Empty;
9773 Decl_Node : Node_Id;
9774 Def : Node_Id;
9775 Ftyp : Entity_Id;
9776 List : constant List_Id := New_List;
9777 Loc : constant Source_Ptr := Sloc (Actual);
9778 Orig_Ftyp : constant Entity_Id := Etype (A_Gen_Obj);
9779 Subt_Decl : Node_Id := Empty;
9780 Subt_Mark : Node_Id := Empty;
9782 begin
9783 if Present (Subtype_Mark (Formal)) then
9784 Subt_Mark := Subtype_Mark (Formal);
9785 else
9786 Check_Access_Definition (Formal);
9787 Acc_Def := Access_Definition (Formal);
9788 end if;
9790 -- Sloc for error message on missing actual
9792 Error_Msg_Sloc := Sloc (Scope (A_Gen_Obj));
9794 if Get_Instance_Of (Gen_Obj) /= Gen_Obj then
9795 Error_Msg_N ("duplicate instantiation of generic parameter", Actual);
9796 end if;
9798 Set_Parent (List, Parent (Actual));
9800 -- OUT present
9802 if Out_Present (Formal) then
9804 -- An IN OUT generic actual must be a name. The instantiation is a
9805 -- renaming declaration. The actual is the name being renamed. We
9806 -- use the actual directly, rather than a copy, because it is not
9807 -- used further in the list of actuals, and because a copy or a use
9808 -- of relocate_node is incorrect if the instance is nested within a
9809 -- generic. In order to simplify ASIS searches, the Generic_Parent
9810 -- field links the declaration to the generic association.
9812 if No (Actual) then
9813 Error_Msg_NE
9814 ("missing actual&",
9815 Instantiation_Node, Gen_Obj);
9816 Error_Msg_NE
9817 ("\in instantiation of & declared#",
9818 Instantiation_Node, Scope (A_Gen_Obj));
9819 Abandon_Instantiation (Instantiation_Node);
9820 end if;
9822 if Present (Subt_Mark) then
9823 Decl_Node :=
9824 Make_Object_Renaming_Declaration (Loc,
9825 Defining_Identifier => New_Copy (Gen_Obj),
9826 Subtype_Mark => New_Copy_Tree (Subt_Mark),
9827 Name => Actual);
9829 else pragma Assert (Present (Acc_Def));
9830 Decl_Node :=
9831 Make_Object_Renaming_Declaration (Loc,
9832 Defining_Identifier => New_Copy (Gen_Obj),
9833 Access_Definition => New_Copy_Tree (Acc_Def),
9834 Name => Actual);
9835 end if;
9837 Set_Corresponding_Generic_Association (Decl_Node, Act_Assoc);
9839 -- The analysis of the actual may produce Insert_Action nodes, so
9840 -- the declaration must have a context in which to attach them.
9842 Append (Decl_Node, List);
9843 Analyze (Actual);
9845 -- Return if the analysis of the actual reported some error
9847 if Etype (Actual) = Any_Type then
9848 return List;
9849 end if;
9851 -- This check is performed here because Analyze_Object_Renaming will
9852 -- not check it when Comes_From_Source is False. Note though that the
9853 -- check for the actual being the name of an object will be performed
9854 -- in Analyze_Object_Renaming.
9856 if Is_Object_Reference (Actual)
9857 and then Is_Dependent_Component_Of_Mutable_Object (Actual)
9858 then
9859 Error_Msg_N
9860 ("illegal discriminant-dependent component for in out parameter",
9861 Actual);
9862 end if;
9864 -- The actual has to be resolved in order to check that it is a
9865 -- variable (due to cases such as F (1), where F returns access to
9866 -- an array, and for overloaded prefixes).
9868 Ftyp := Get_Instance_Of (Etype (A_Gen_Obj));
9870 -- If the type of the formal is not itself a formal, and the current
9871 -- unit is a child unit, the formal type must be declared in a
9872 -- parent, and must be retrieved by visibility.
9874 if Ftyp = Orig_Ftyp
9875 and then Is_Generic_Unit (Scope (Ftyp))
9876 and then Is_Child_Unit (Scope (A_Gen_Obj))
9877 then
9878 declare
9879 Temp : constant Node_Id :=
9880 New_Copy_Tree (Subtype_Mark (Analyzed_Formal));
9881 begin
9882 Set_Entity (Temp, Empty);
9883 Find_Type (Temp);
9884 Ftyp := Entity (Temp);
9885 end;
9886 end if;
9888 if Is_Private_Type (Ftyp)
9889 and then not Is_Private_Type (Etype (Actual))
9890 and then (Base_Type (Full_View (Ftyp)) = Base_Type (Etype (Actual))
9891 or else Base_Type (Etype (Actual)) = Ftyp)
9892 then
9893 -- If the actual has the type of the full view of the formal, or
9894 -- else a non-private subtype of the formal, then the visibility
9895 -- of the formal type has changed. Add to the actuals a subtype
9896 -- declaration that will force the exchange of views in the body
9897 -- of the instance as well.
9899 Subt_Decl :=
9900 Make_Subtype_Declaration (Loc,
9901 Defining_Identifier => Make_Temporary (Loc, 'P'),
9902 Subtype_Indication => New_Occurrence_Of (Ftyp, Loc));
9904 Prepend (Subt_Decl, List);
9906 Prepend_Elmt (Full_View (Ftyp), Exchanged_Views);
9907 Exchange_Declarations (Ftyp);
9908 end if;
9910 Resolve (Actual, Ftyp);
9912 if not Denotes_Variable (Actual) then
9913 Error_Msg_NE
9914 ("actual for& must be a variable", Actual, Gen_Obj);
9916 elsif Base_Type (Ftyp) /= Base_Type (Etype (Actual)) then
9918 -- Ada 2005 (AI-423): For a generic formal object of mode in out,
9919 -- the type of the actual shall resolve to a specific anonymous
9920 -- access type.
9922 if Ada_Version < Ada_2005
9923 or else
9924 Ekind (Base_Type (Ftyp)) /=
9925 E_Anonymous_Access_Type
9926 or else
9927 Ekind (Base_Type (Etype (Actual))) /=
9928 E_Anonymous_Access_Type
9929 then
9930 Error_Msg_NE ("type of actual does not match type of&",
9931 Actual, Gen_Obj);
9932 end if;
9933 end if;
9935 Note_Possible_Modification (Actual, Sure => True);
9937 -- Check for instantiation of atomic/volatile actual for
9938 -- non-atomic/volatile formal (RM C.6 (12)).
9940 if Is_Atomic_Object (Actual)
9941 and then not Is_Atomic (Orig_Ftyp)
9942 then
9943 Error_Msg_N
9944 ("cannot instantiate non-atomic formal object " &
9945 "with atomic actual", Actual);
9947 elsif Is_Volatile_Object (Actual)
9948 and then not Is_Volatile (Orig_Ftyp)
9949 then
9950 Error_Msg_N
9951 ("cannot instantiate non-volatile formal object " &
9952 "with volatile actual", Actual);
9953 end if;
9955 -- Formal in-parameter
9957 else
9958 -- The instantiation of a generic formal in-parameter is constant
9959 -- declaration. The actual is the expression for that declaration.
9961 if Present (Actual) then
9962 if Present (Subt_Mark) then
9963 Def := Subt_Mark;
9964 else pragma Assert (Present (Acc_Def));
9965 Def := Acc_Def;
9966 end if;
9968 Decl_Node :=
9969 Make_Object_Declaration (Loc,
9970 Defining_Identifier => New_Copy (Gen_Obj),
9971 Constant_Present => True,
9972 Null_Exclusion_Present => Null_Exclusion_Present (Formal),
9973 Object_Definition => New_Copy_Tree (Def),
9974 Expression => Actual);
9976 Set_Corresponding_Generic_Association (Decl_Node, Act_Assoc);
9978 -- A generic formal object of a tagged type is defined to be
9979 -- aliased so the new constant must also be treated as aliased.
9981 if Is_Tagged_Type (Etype (A_Gen_Obj)) then
9982 Set_Aliased_Present (Decl_Node);
9983 end if;
9985 Append (Decl_Node, List);
9987 -- No need to repeat (pre-)analysis of some expression nodes
9988 -- already handled in Preanalyze_Actuals.
9990 if Nkind (Actual) /= N_Allocator then
9991 Analyze (Actual);
9993 -- Return if the analysis of the actual reported some error
9995 if Etype (Actual) = Any_Type then
9996 return List;
9997 end if;
9998 end if;
10000 declare
10001 Formal_Type : constant Entity_Id := Etype (A_Gen_Obj);
10002 Typ : Entity_Id;
10004 begin
10005 Typ := Get_Instance_Of (Formal_Type);
10007 Freeze_Before (Instantiation_Node, Typ);
10009 -- If the actual is an aggregate, perform name resolution on
10010 -- its components (the analysis of an aggregate does not do it)
10011 -- to capture local names that may be hidden if the generic is
10012 -- a child unit.
10014 if Nkind (Actual) = N_Aggregate then
10015 Preanalyze_And_Resolve (Actual, Typ);
10016 end if;
10018 if Is_Limited_Type (Typ)
10019 and then not OK_For_Limited_Init (Typ, Actual)
10020 then
10021 Error_Msg_N
10022 ("initialization not allowed for limited types", Actual);
10023 Explain_Limited_Type (Typ, Actual);
10024 end if;
10025 end;
10027 elsif Present (Default_Expression (Formal)) then
10029 -- Use default to construct declaration
10031 if Present (Subt_Mark) then
10032 Def := Subt_Mark;
10033 else pragma Assert (Present (Acc_Def));
10034 Def := Acc_Def;
10035 end if;
10037 Decl_Node :=
10038 Make_Object_Declaration (Sloc (Formal),
10039 Defining_Identifier => New_Copy (Gen_Obj),
10040 Constant_Present => True,
10041 Null_Exclusion_Present => Null_Exclusion_Present (Formal),
10042 Object_Definition => New_Copy (Def),
10043 Expression => New_Copy_Tree
10044 (Default_Expression (Formal)));
10046 Append (Decl_Node, List);
10047 Set_Analyzed (Expression (Decl_Node), False);
10049 else
10050 Error_Msg_NE
10051 ("missing actual&",
10052 Instantiation_Node, Gen_Obj);
10053 Error_Msg_NE ("\in instantiation of & declared#",
10054 Instantiation_Node, Scope (A_Gen_Obj));
10056 if Is_Scalar_Type (Etype (A_Gen_Obj)) then
10058 -- Create dummy constant declaration so that instance can be
10059 -- analyzed, to minimize cascaded visibility errors.
10061 if Present (Subt_Mark) then
10062 Def := Subt_Mark;
10063 else pragma Assert (Present (Acc_Def));
10064 Def := Acc_Def;
10065 end if;
10067 Decl_Node :=
10068 Make_Object_Declaration (Loc,
10069 Defining_Identifier => New_Copy (Gen_Obj),
10070 Constant_Present => True,
10071 Null_Exclusion_Present => Null_Exclusion_Present (Formal),
10072 Object_Definition => New_Copy (Def),
10073 Expression =>
10074 Make_Attribute_Reference (Sloc (Gen_Obj),
10075 Attribute_Name => Name_First,
10076 Prefix => New_Copy (Def)));
10078 Append (Decl_Node, List);
10080 else
10081 Abandon_Instantiation (Instantiation_Node);
10082 end if;
10083 end if;
10084 end if;
10086 if Nkind (Actual) in N_Has_Entity then
10087 Actual_Decl := Parent (Entity (Actual));
10088 end if;
10090 -- Ada 2005 (AI-423): For a formal object declaration with a null
10091 -- exclusion or an access definition that has a null exclusion: If the
10092 -- actual matching the formal object declaration denotes a generic
10093 -- formal object of another generic unit G, and the instantiation
10094 -- containing the actual occurs within the body of G or within the body
10095 -- of a generic unit declared within the declarative region of G, then
10096 -- the declaration of the formal object of G must have a null exclusion.
10097 -- Otherwise, the subtype of the actual matching the formal object
10098 -- declaration shall exclude null.
10100 if Ada_Version >= Ada_2005
10101 and then Present (Actual_Decl)
10102 and then
10103 Nkind_In (Actual_Decl, N_Formal_Object_Declaration,
10104 N_Object_Declaration)
10105 and then Nkind (Analyzed_Formal) = N_Formal_Object_Declaration
10106 and then not Has_Null_Exclusion (Actual_Decl)
10107 and then Has_Null_Exclusion (Analyzed_Formal)
10108 then
10109 Error_Msg_Sloc := Sloc (Analyzed_Formal);
10110 Error_Msg_N
10111 ("actual must exclude null to match generic formal#", Actual);
10112 end if;
10114 -- An effectively volatile object cannot be used as an actual in
10115 -- a generic instance. The following check is only relevant when
10116 -- SPARK_Mode is on as it is not a standard Ada legality rule.
10118 if SPARK_Mode = On
10119 and then Present (Actual)
10120 and then Is_Effectively_Volatile_Object (Actual)
10121 then
10122 Error_Msg_N
10123 ("volatile object cannot act as actual in generic instantiation "
10124 & "(SPARK RM 7.1.3(8))", Actual);
10125 end if;
10127 return List;
10128 end Instantiate_Object;
10130 ------------------------------
10131 -- Instantiate_Package_Body --
10132 ------------------------------
10134 procedure Instantiate_Package_Body
10135 (Body_Info : Pending_Body_Info;
10136 Inlined_Body : Boolean := False;
10137 Body_Optional : Boolean := False)
10139 Act_Decl : constant Node_Id := Body_Info.Act_Decl;
10140 Inst_Node : constant Node_Id := Body_Info.Inst_Node;
10141 Loc : constant Source_Ptr := Sloc (Inst_Node);
10143 Gen_Id : constant Node_Id := Name (Inst_Node);
10144 Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node);
10145 Gen_Decl : constant Node_Id := Unit_Declaration_Node (Gen_Unit);
10146 Act_Spec : constant Node_Id := Specification (Act_Decl);
10147 Act_Decl_Id : constant Entity_Id := Defining_Entity (Act_Spec);
10149 Act_Body_Name : Node_Id;
10150 Gen_Body : Node_Id;
10151 Gen_Body_Id : Node_Id;
10152 Act_Body : Node_Id;
10153 Act_Body_Id : Entity_Id;
10155 Parent_Installed : Boolean := False;
10156 Save_Style_Check : constant Boolean := Style_Check;
10158 Par_Ent : Entity_Id := Empty;
10159 Par_Vis : Boolean := False;
10161 Vis_Prims_List : Elist_Id := No_Elist;
10162 -- List of primitives made temporarily visible in the instantiation
10163 -- to match the visibility of the formal type
10165 procedure Check_Initialized_Types;
10166 -- In a generic package body, an entity of a generic private type may
10167 -- appear uninitialized. This is suspicious, unless the actual is a
10168 -- fully initialized type.
10170 -----------------------------
10171 -- Check_Initialized_Types --
10172 -----------------------------
10174 procedure Check_Initialized_Types is
10175 Decl : Node_Id;
10176 Formal : Entity_Id;
10177 Actual : Entity_Id;
10178 Uninit_Var : Entity_Id;
10180 begin
10181 Decl := First (Generic_Formal_Declarations (Gen_Decl));
10182 while Present (Decl) loop
10183 Uninit_Var := Empty;
10185 if Nkind (Decl) = N_Private_Extension_Declaration then
10186 Uninit_Var := Uninitialized_Variable (Decl);
10188 elsif Nkind (Decl) = N_Formal_Type_Declaration
10189 and then Nkind (Formal_Type_Definition (Decl)) =
10190 N_Formal_Private_Type_Definition
10191 then
10192 Uninit_Var :=
10193 Uninitialized_Variable (Formal_Type_Definition (Decl));
10194 end if;
10196 if Present (Uninit_Var) then
10197 Formal := Defining_Identifier (Decl);
10198 Actual := First_Entity (Act_Decl_Id);
10200 -- For each formal there is a subtype declaration that renames
10201 -- the actual and has the same name as the formal. Locate the
10202 -- formal for warning message about uninitialized variables
10203 -- in the generic, for which the actual type should be a fully
10204 -- initialized type.
10206 while Present (Actual) loop
10207 exit when Ekind (Actual) = E_Package
10208 and then Present (Renamed_Object (Actual));
10210 if Chars (Actual) = Chars (Formal)
10211 and then not Is_Scalar_Type (Actual)
10212 and then not Is_Fully_Initialized_Type (Actual)
10213 and then Warn_On_No_Value_Assigned
10214 then
10215 Error_Msg_Node_2 := Formal;
10216 Error_Msg_NE
10217 ("generic unit has uninitialized variable& of "
10218 & "formal private type &?v?", Actual, Uninit_Var);
10219 Error_Msg_NE
10220 ("actual type for& should be fully initialized type?v?",
10221 Actual, Formal);
10222 exit;
10223 end if;
10225 Next_Entity (Actual);
10226 end loop;
10227 end if;
10229 Next (Decl);
10230 end loop;
10231 end Check_Initialized_Types;
10233 -- Start of processing for Instantiate_Package_Body
10235 begin
10236 Gen_Body_Id := Corresponding_Body (Gen_Decl);
10238 -- The instance body may already have been processed, as the parent of
10239 -- another instance that is inlined (Load_Parent_Of_Generic).
10241 if Present (Corresponding_Body (Instance_Spec (Inst_Node))) then
10242 return;
10243 end if;
10245 Expander_Mode_Save_And_Set (Body_Info.Expander_Status);
10247 -- Re-establish the state of information on which checks are suppressed.
10248 -- This information was set in Body_Info at the point of instantiation,
10249 -- and now we restore it so that the instance is compiled using the
10250 -- check status at the instantiation (RM 11.5 (7.2/2), AI95-00224-01).
10252 Local_Suppress_Stack_Top := Body_Info.Local_Suppress_Stack_Top;
10253 Scope_Suppress := Body_Info.Scope_Suppress;
10254 Opt.Ada_Version := Body_Info.Version;
10255 Opt.Ada_Version_Pragma := Body_Info.Version_Pragma;
10256 Restore_Warnings (Body_Info.Warnings);
10257 Opt.SPARK_Mode := Body_Info.SPARK_Mode;
10258 Opt.SPARK_Mode_Pragma := Body_Info.SPARK_Mode_Pragma;
10260 if No (Gen_Body_Id) then
10262 -- Do not look for parent of generic body if none is required.
10263 -- This may happen when the routine is called as part of the
10264 -- Pending_Instantiations processing, when nested instances
10265 -- may precede the one generated from the main unit.
10267 if not Unit_Requires_Body (Defining_Entity (Gen_Decl))
10268 and then Body_Optional
10269 then
10270 return;
10271 else
10272 Load_Parent_Of_Generic
10273 (Inst_Node, Specification (Gen_Decl), Body_Optional);
10274 Gen_Body_Id := Corresponding_Body (Gen_Decl);
10275 end if;
10276 end if;
10278 -- Establish global variable for sloc adjustment and for error recovery
10280 Instantiation_Node := Inst_Node;
10282 if Present (Gen_Body_Id) then
10283 Save_Env (Gen_Unit, Act_Decl_Id);
10284 Style_Check := False;
10285 Current_Sem_Unit := Body_Info.Current_Sem_Unit;
10287 Gen_Body := Unit_Declaration_Node (Gen_Body_Id);
10289 Create_Instantiation_Source
10290 (Inst_Node, Gen_Body_Id, False, S_Adjustment);
10292 Act_Body :=
10293 Copy_Generic_Node
10294 (Original_Node (Gen_Body), Empty, Instantiating => True);
10296 -- Build new name (possibly qualified) for body declaration
10298 Act_Body_Id := New_Copy (Act_Decl_Id);
10300 -- Some attributes of spec entity are not inherited by body entity
10302 Set_Handler_Records (Act_Body_Id, No_List);
10304 if Nkind (Defining_Unit_Name (Act_Spec)) =
10305 N_Defining_Program_Unit_Name
10306 then
10307 Act_Body_Name :=
10308 Make_Defining_Program_Unit_Name (Loc,
10309 Name => New_Copy_Tree (Name (Defining_Unit_Name (Act_Spec))),
10310 Defining_Identifier => Act_Body_Id);
10311 else
10312 Act_Body_Name := Act_Body_Id;
10313 end if;
10315 Set_Defining_Unit_Name (Act_Body, Act_Body_Name);
10317 Set_Corresponding_Spec (Act_Body, Act_Decl_Id);
10318 Check_Generic_Actuals (Act_Decl_Id, False);
10319 Check_Initialized_Types;
10321 -- Install primitives hidden at the point of the instantiation but
10322 -- visible when processing the generic formals
10324 declare
10325 E : Entity_Id;
10327 begin
10328 E := First_Entity (Act_Decl_Id);
10329 while Present (E) loop
10330 if Is_Type (E)
10331 and then Is_Generic_Actual_Type (E)
10332 and then Is_Tagged_Type (E)
10333 then
10334 Install_Hidden_Primitives
10335 (Prims_List => Vis_Prims_List,
10336 Gen_T => Generic_Parent_Type (Parent (E)),
10337 Act_T => E);
10338 end if;
10340 Next_Entity (E);
10341 end loop;
10342 end;
10344 -- If it is a child unit, make the parent instance (which is an
10345 -- instance of the parent of the generic) visible. The parent
10346 -- instance is the prefix of the name of the generic unit.
10348 if Ekind (Scope (Gen_Unit)) = E_Generic_Package
10349 and then Nkind (Gen_Id) = N_Expanded_Name
10350 then
10351 Par_Ent := Entity (Prefix (Gen_Id));
10352 Par_Vis := Is_Immediately_Visible (Par_Ent);
10353 Install_Parent (Par_Ent, In_Body => True);
10354 Parent_Installed := True;
10356 elsif Is_Child_Unit (Gen_Unit) then
10357 Par_Ent := Scope (Gen_Unit);
10358 Par_Vis := Is_Immediately_Visible (Par_Ent);
10359 Install_Parent (Par_Ent, In_Body => True);
10360 Parent_Installed := True;
10361 end if;
10363 -- If the instantiation is a library unit, and this is the main unit,
10364 -- then build the resulting compilation unit nodes for the instance.
10365 -- If this is a compilation unit but it is not the main unit, then it
10366 -- is the body of a unit in the context, that is being compiled
10367 -- because it is encloses some inlined unit or another generic unit
10368 -- being instantiated. In that case, this body is not part of the
10369 -- current compilation, and is not attached to the tree, but its
10370 -- parent must be set for analysis.
10372 if Nkind (Parent (Inst_Node)) = N_Compilation_Unit then
10374 -- Replace instance node with body of instance, and create new
10375 -- node for corresponding instance declaration.
10377 Build_Instance_Compilation_Unit_Nodes
10378 (Inst_Node, Act_Body, Act_Decl);
10379 Analyze (Inst_Node);
10381 if Parent (Inst_Node) = Cunit (Main_Unit) then
10383 -- If the instance is a child unit itself, then set the scope
10384 -- of the expanded body to be the parent of the instantiation
10385 -- (ensuring that the fully qualified name will be generated
10386 -- for the elaboration subprogram).
10388 if Nkind (Defining_Unit_Name (Act_Spec)) =
10389 N_Defining_Program_Unit_Name
10390 then
10391 Set_Scope
10392 (Defining_Entity (Inst_Node), Scope (Act_Decl_Id));
10393 end if;
10394 end if;
10396 -- Case where instantiation is not a library unit
10398 else
10399 -- If this is an early instantiation, i.e. appears textually
10400 -- before the corresponding body and must be elaborated first,
10401 -- indicate that the body instance is to be delayed.
10403 Install_Body (Act_Body, Inst_Node, Gen_Body, Gen_Decl);
10405 -- Now analyze the body. We turn off all checks if this is an
10406 -- internal unit, since there is no reason to have checks on for
10407 -- any predefined run-time library code. All such code is designed
10408 -- to be compiled with checks off.
10410 -- Note that we do NOT apply this criterion to children of GNAT
10411 -- The latter units must suppress checks explicitly if needed.
10413 if Is_Predefined_File_Name
10414 (Unit_File_Name (Get_Source_Unit (Gen_Decl)))
10415 then
10416 Analyze (Act_Body, Suppress => All_Checks);
10417 else
10418 Analyze (Act_Body);
10419 end if;
10420 end if;
10422 Inherit_Context (Gen_Body, Inst_Node);
10424 -- Remove the parent instances if they have been placed on the scope
10425 -- stack to compile the body.
10427 if Parent_Installed then
10428 Remove_Parent (In_Body => True);
10430 -- Restore the previous visibility of the parent
10432 Set_Is_Immediately_Visible (Par_Ent, Par_Vis);
10433 end if;
10435 Restore_Hidden_Primitives (Vis_Prims_List);
10436 Restore_Private_Views (Act_Decl_Id);
10438 -- Remove the current unit from visibility if this is an instance
10439 -- that is not elaborated on the fly for inlining purposes.
10441 if not Inlined_Body then
10442 Set_Is_Immediately_Visible (Act_Decl_Id, False);
10443 end if;
10445 Restore_Env;
10446 Style_Check := Save_Style_Check;
10448 -- If we have no body, and the unit requires a body, then complain. This
10449 -- complaint is suppressed if we have detected other errors (since a
10450 -- common reason for missing the body is that it had errors).
10451 -- In CodePeer mode, a warning has been emitted already, no need for
10452 -- further messages.
10454 elsif Unit_Requires_Body (Gen_Unit)
10455 and then not Body_Optional
10456 then
10457 if CodePeer_Mode then
10458 null;
10460 elsif Serious_Errors_Detected = 0 then
10461 Error_Msg_NE
10462 ("cannot find body of generic package &", Inst_Node, Gen_Unit);
10464 -- Don't attempt to perform any cleanup actions if some other error
10465 -- was already detected, since this can cause blowups.
10467 else
10468 return;
10469 end if;
10471 -- Case of package that does not need a body
10473 else
10474 -- If the instantiation of the declaration is a library unit, rewrite
10475 -- the original package instantiation as a package declaration in the
10476 -- compilation unit node.
10478 if Nkind (Parent (Inst_Node)) = N_Compilation_Unit then
10479 Set_Parent_Spec (Act_Decl, Parent_Spec (Inst_Node));
10480 Rewrite (Inst_Node, Act_Decl);
10482 -- Generate elaboration entity, in case spec has elaboration code.
10483 -- This cannot be done when the instance is analyzed, because it
10484 -- is not known yet whether the body exists.
10486 Set_Elaboration_Entity_Required (Act_Decl_Id, False);
10487 Build_Elaboration_Entity (Parent (Inst_Node), Act_Decl_Id);
10489 -- If the instantiation is not a library unit, then append the
10490 -- declaration to the list of implicitly generated entities, unless
10491 -- it is already a list member which means that it was already
10492 -- processed
10494 elsif not Is_List_Member (Act_Decl) then
10495 Mark_Rewrite_Insertion (Act_Decl);
10496 Insert_Before (Inst_Node, Act_Decl);
10497 end if;
10498 end if;
10500 Expander_Mode_Restore;
10501 end Instantiate_Package_Body;
10503 ---------------------------------
10504 -- Instantiate_Subprogram_Body --
10505 ---------------------------------
10507 procedure Instantiate_Subprogram_Body
10508 (Body_Info : Pending_Body_Info;
10509 Body_Optional : Boolean := False)
10511 Act_Decl : constant Node_Id := Body_Info.Act_Decl;
10512 Inst_Node : constant Node_Id := Body_Info.Inst_Node;
10513 Loc : constant Source_Ptr := Sloc (Inst_Node);
10514 Gen_Id : constant Node_Id := Name (Inst_Node);
10515 Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node);
10516 Gen_Decl : constant Node_Id := Unit_Declaration_Node (Gen_Unit);
10517 Anon_Id : constant Entity_Id :=
10518 Defining_Unit_Name (Specification (Act_Decl));
10519 Pack_Id : constant Entity_Id :=
10520 Defining_Unit_Name (Parent (Act_Decl));
10521 Decls : List_Id;
10522 Gen_Body : Node_Id;
10523 Gen_Body_Id : Node_Id;
10524 Act_Body : Node_Id;
10525 Pack_Body : Node_Id;
10526 Prev_Formal : Entity_Id;
10527 Ret_Expr : Node_Id;
10528 Unit_Renaming : Node_Id;
10530 Parent_Installed : Boolean := False;
10532 Saved_Style_Check : constant Boolean := Style_Check;
10533 Saved_Warnings : constant Warning_Record := Save_Warnings;
10535 Par_Ent : Entity_Id := Empty;
10536 Par_Vis : Boolean := False;
10538 begin
10539 Gen_Body_Id := Corresponding_Body (Gen_Decl);
10541 -- Subprogram body may have been created already because of an inline
10542 -- pragma, or because of multiple elaborations of the enclosing package
10543 -- when several instances of the subprogram appear in the main unit.
10545 if Present (Corresponding_Body (Act_Decl)) then
10546 return;
10547 end if;
10549 Expander_Mode_Save_And_Set (Body_Info.Expander_Status);
10551 -- Re-establish the state of information on which checks are suppressed.
10552 -- This information was set in Body_Info at the point of instantiation,
10553 -- and now we restore it so that the instance is compiled using the
10554 -- check status at the instantiation (RM 11.5 (7.2/2), AI95-00224-01).
10556 Local_Suppress_Stack_Top := Body_Info.Local_Suppress_Stack_Top;
10557 Scope_Suppress := Body_Info.Scope_Suppress;
10558 Opt.Ada_Version := Body_Info.Version;
10559 Opt.Ada_Version_Pragma := Body_Info.Version_Pragma;
10560 Restore_Warnings (Body_Info.Warnings);
10561 Opt.SPARK_Mode := Body_Info.SPARK_Mode;
10562 Opt.SPARK_Mode_Pragma := Body_Info.SPARK_Mode_Pragma;
10564 if No (Gen_Body_Id) then
10566 -- For imported generic subprogram, no body to compile, complete
10567 -- the spec entity appropriately.
10569 if Is_Imported (Gen_Unit) then
10570 Set_Is_Imported (Anon_Id);
10571 Set_First_Rep_Item (Anon_Id, First_Rep_Item (Gen_Unit));
10572 Set_Interface_Name (Anon_Id, Interface_Name (Gen_Unit));
10573 Set_Convention (Anon_Id, Convention (Gen_Unit));
10574 Set_Has_Completion (Anon_Id);
10575 return;
10577 -- For other cases, compile the body
10579 else
10580 Load_Parent_Of_Generic
10581 (Inst_Node, Specification (Gen_Decl), Body_Optional);
10582 Gen_Body_Id := Corresponding_Body (Gen_Decl);
10583 end if;
10584 end if;
10586 Instantiation_Node := Inst_Node;
10588 if Present (Gen_Body_Id) then
10589 Gen_Body := Unit_Declaration_Node (Gen_Body_Id);
10591 if Nkind (Gen_Body) = N_Subprogram_Body_Stub then
10593 -- Either body is not present, or context is non-expanding, as
10594 -- when compiling a subunit. Mark the instance as completed, and
10595 -- diagnose a missing body when needed.
10597 if Expander_Active
10598 and then Operating_Mode = Generate_Code
10599 then
10600 Error_Msg_N
10601 ("missing proper body for instantiation", Gen_Body);
10602 end if;
10604 Set_Has_Completion (Anon_Id);
10605 return;
10606 end if;
10608 Save_Env (Gen_Unit, Anon_Id);
10609 Style_Check := False;
10610 Current_Sem_Unit := Body_Info.Current_Sem_Unit;
10611 Create_Instantiation_Source
10612 (Inst_Node,
10613 Gen_Body_Id,
10614 False,
10615 S_Adjustment);
10617 Act_Body :=
10618 Copy_Generic_Node
10619 (Original_Node (Gen_Body), Empty, Instantiating => True);
10621 -- Create proper defining name for the body, to correspond to
10622 -- the one in the spec.
10624 Set_Defining_Unit_Name (Specification (Act_Body),
10625 Make_Defining_Identifier
10626 (Sloc (Defining_Entity (Inst_Node)), Chars (Anon_Id)));
10627 Set_Corresponding_Spec (Act_Body, Anon_Id);
10628 Set_Has_Completion (Anon_Id);
10629 Check_Generic_Actuals (Pack_Id, False);
10631 -- Generate a reference to link the visible subprogram instance to
10632 -- the generic body, which for navigation purposes is the only
10633 -- available source for the instance.
10635 Generate_Reference
10636 (Related_Instance (Pack_Id),
10637 Gen_Body_Id, 'b', Set_Ref => False, Force => True);
10639 -- If it is a child unit, make the parent instance (which is an
10640 -- instance of the parent of the generic) visible. The parent
10641 -- instance is the prefix of the name of the generic unit.
10643 if Ekind (Scope (Gen_Unit)) = E_Generic_Package
10644 and then Nkind (Gen_Id) = N_Expanded_Name
10645 then
10646 Par_Ent := Entity (Prefix (Gen_Id));
10647 Par_Vis := Is_Immediately_Visible (Par_Ent);
10648 Install_Parent (Par_Ent, In_Body => True);
10649 Parent_Installed := True;
10651 elsif Is_Child_Unit (Gen_Unit) then
10652 Par_Ent := Scope (Gen_Unit);
10653 Par_Vis := Is_Immediately_Visible (Par_Ent);
10654 Install_Parent (Par_Ent, In_Body => True);
10655 Parent_Installed := True;
10656 end if;
10658 -- Inside its body, a reference to the generic unit is a reference
10659 -- to the instance. The corresponding renaming is the first
10660 -- declaration in the body.
10662 Unit_Renaming :=
10663 Make_Subprogram_Renaming_Declaration (Loc,
10664 Specification =>
10665 Copy_Generic_Node (
10666 Specification (Original_Node (Gen_Body)),
10667 Empty,
10668 Instantiating => True),
10669 Name => New_Occurrence_Of (Anon_Id, Loc));
10671 -- If there is a formal subprogram with the same name as the unit
10672 -- itself, do not add this renaming declaration. This is a temporary
10673 -- fix for one ACVC test. ???
10675 Prev_Formal := First_Entity (Pack_Id);
10676 while Present (Prev_Formal) loop
10677 if Chars (Prev_Formal) = Chars (Gen_Unit)
10678 and then Is_Overloadable (Prev_Formal)
10679 then
10680 exit;
10681 end if;
10683 Next_Entity (Prev_Formal);
10684 end loop;
10686 if Present (Prev_Formal) then
10687 Decls := New_List (Act_Body);
10688 else
10689 Decls := New_List (Unit_Renaming, Act_Body);
10690 end if;
10692 -- The subprogram body is placed in the body of a dummy package body,
10693 -- whose spec contains the subprogram declaration as well as the
10694 -- renaming declarations for the generic parameters.
10696 Pack_Body := Make_Package_Body (Loc,
10697 Defining_Unit_Name => New_Copy (Pack_Id),
10698 Declarations => Decls);
10700 Set_Corresponding_Spec (Pack_Body, Pack_Id);
10702 -- If the instantiation is a library unit, then build resulting
10703 -- compilation unit nodes for the instance. The declaration of
10704 -- the enclosing package is the grandparent of the subprogram
10705 -- declaration. First replace the instantiation node as the unit
10706 -- of the corresponding compilation.
10708 if Nkind (Parent (Inst_Node)) = N_Compilation_Unit then
10709 if Parent (Inst_Node) = Cunit (Main_Unit) then
10710 Set_Unit (Parent (Inst_Node), Inst_Node);
10711 Build_Instance_Compilation_Unit_Nodes
10712 (Inst_Node, Pack_Body, Parent (Parent (Act_Decl)));
10713 Analyze (Inst_Node);
10714 else
10715 Set_Parent (Pack_Body, Parent (Inst_Node));
10716 Analyze (Pack_Body);
10717 end if;
10719 else
10720 Insert_Before (Inst_Node, Pack_Body);
10721 Mark_Rewrite_Insertion (Pack_Body);
10722 Analyze (Pack_Body);
10724 if Expander_Active then
10725 Freeze_Subprogram_Body (Inst_Node, Gen_Body, Pack_Id);
10726 end if;
10727 end if;
10729 Inherit_Context (Gen_Body, Inst_Node);
10731 Restore_Private_Views (Pack_Id, False);
10733 if Parent_Installed then
10734 Remove_Parent (In_Body => True);
10736 -- Restore the previous visibility of the parent
10738 Set_Is_Immediately_Visible (Par_Ent, Par_Vis);
10739 end if;
10741 Restore_Env;
10742 Style_Check := Saved_Style_Check;
10743 Restore_Warnings (Saved_Warnings);
10745 -- Body not found. Error was emitted already. If there were no previous
10746 -- errors, this may be an instance whose scope is a premature instance.
10747 -- In that case we must insure that the (legal) program does raise
10748 -- program error if executed. We generate a subprogram body for this
10749 -- purpose. See DEC ac30vso.
10751 -- Should not reference proprietary DEC tests in comments ???
10753 elsif Serious_Errors_Detected = 0
10754 and then Nkind (Parent (Inst_Node)) /= N_Compilation_Unit
10755 then
10756 if Body_Optional then
10757 return;
10759 elsif Ekind (Anon_Id) = E_Procedure then
10760 Act_Body :=
10761 Make_Subprogram_Body (Loc,
10762 Specification =>
10763 Make_Procedure_Specification (Loc,
10764 Defining_Unit_Name =>
10765 Make_Defining_Identifier (Loc, Chars (Anon_Id)),
10766 Parameter_Specifications =>
10767 New_Copy_List
10768 (Parameter_Specifications (Parent (Anon_Id)))),
10770 Declarations => Empty_List,
10771 Handled_Statement_Sequence =>
10772 Make_Handled_Sequence_Of_Statements (Loc,
10773 Statements =>
10774 New_List (
10775 Make_Raise_Program_Error (Loc,
10776 Reason =>
10777 PE_Access_Before_Elaboration))));
10779 else
10780 Ret_Expr :=
10781 Make_Raise_Program_Error (Loc,
10782 Reason => PE_Access_Before_Elaboration);
10784 Set_Etype (Ret_Expr, (Etype (Anon_Id)));
10785 Set_Analyzed (Ret_Expr);
10787 Act_Body :=
10788 Make_Subprogram_Body (Loc,
10789 Specification =>
10790 Make_Function_Specification (Loc,
10791 Defining_Unit_Name =>
10792 Make_Defining_Identifier (Loc, Chars (Anon_Id)),
10793 Parameter_Specifications =>
10794 New_Copy_List
10795 (Parameter_Specifications (Parent (Anon_Id))),
10796 Result_Definition =>
10797 New_Occurrence_Of (Etype (Anon_Id), Loc)),
10799 Declarations => Empty_List,
10800 Handled_Statement_Sequence =>
10801 Make_Handled_Sequence_Of_Statements (Loc,
10802 Statements =>
10803 New_List
10804 (Make_Simple_Return_Statement (Loc, Ret_Expr))));
10805 end if;
10807 Pack_Body := Make_Package_Body (Loc,
10808 Defining_Unit_Name => New_Copy (Pack_Id),
10809 Declarations => New_List (Act_Body));
10811 Insert_After (Inst_Node, Pack_Body);
10812 Set_Corresponding_Spec (Pack_Body, Pack_Id);
10813 Analyze (Pack_Body);
10814 end if;
10816 Expander_Mode_Restore;
10817 end Instantiate_Subprogram_Body;
10819 ----------------------
10820 -- Instantiate_Type --
10821 ----------------------
10823 function Instantiate_Type
10824 (Formal : Node_Id;
10825 Actual : Node_Id;
10826 Analyzed_Formal : Node_Id;
10827 Actual_Decls : List_Id) return List_Id
10829 Gen_T : constant Entity_Id := Defining_Identifier (Formal);
10830 A_Gen_T : constant Entity_Id :=
10831 Defining_Identifier (Analyzed_Formal);
10832 Ancestor : Entity_Id := Empty;
10833 Def : constant Node_Id := Formal_Type_Definition (Formal);
10834 Act_T : Entity_Id;
10835 Decl_Node : Node_Id;
10836 Decl_Nodes : List_Id;
10837 Loc : Source_Ptr;
10838 Subt : Entity_Id;
10840 procedure Diagnose_Predicated_Actual;
10841 -- There are a number of constructs in which a discrete type with
10842 -- predicates is illegal, e.g. as an index in an array type declaration.
10843 -- If a generic type is used is such a construct in a generic package
10844 -- declaration, it carries the flag No_Predicate_On_Actual. it is part
10845 -- of the generic contract that the actual cannot have predicates.
10847 procedure Validate_Array_Type_Instance;
10848 procedure Validate_Access_Subprogram_Instance;
10849 procedure Validate_Access_Type_Instance;
10850 procedure Validate_Derived_Type_Instance;
10851 procedure Validate_Derived_Interface_Type_Instance;
10852 procedure Validate_Discriminated_Formal_Type;
10853 procedure Validate_Interface_Type_Instance;
10854 procedure Validate_Private_Type_Instance;
10855 procedure Validate_Incomplete_Type_Instance;
10856 -- These procedures perform validation tests for the named case.
10857 -- Validate_Discriminated_Formal_Type is shared by formal private
10858 -- types and Ada 2012 formal incomplete types.
10860 function Subtypes_Match (Gen_T, Act_T : Entity_Id) return Boolean;
10861 -- Check that base types are the same and that the subtypes match
10862 -- statically. Used in several of the above.
10864 ---------------------------------
10865 -- Diagnose_Predicated_Actual --
10866 ---------------------------------
10868 procedure Diagnose_Predicated_Actual is
10869 begin
10870 if No_Predicate_On_Actual (A_Gen_T)
10871 and then Has_Predicates (Act_T)
10872 then
10873 Error_Msg_NE
10874 ("actual for& cannot be a type with predicate",
10875 Instantiation_Node, A_Gen_T);
10877 elsif No_Dynamic_Predicate_On_Actual (A_Gen_T)
10878 and then Has_Predicates (Act_T)
10879 and then not Has_Static_Predicate_Aspect (Act_T)
10880 then
10881 Error_Msg_NE
10882 ("actual for& cannot be a type with a dynamic predicate",
10883 Instantiation_Node, A_Gen_T);
10884 end if;
10885 end Diagnose_Predicated_Actual;
10887 --------------------
10888 -- Subtypes_Match --
10889 --------------------
10891 function Subtypes_Match (Gen_T, Act_T : Entity_Id) return Boolean is
10892 T : constant Entity_Id := Get_Instance_Of (Gen_T);
10894 begin
10895 -- Some detailed comments would be useful here ???
10897 return ((Base_Type (T) = Act_T
10898 or else Base_Type (T) = Base_Type (Act_T))
10899 and then Subtypes_Statically_Match (T, Act_T))
10901 or else (Is_Class_Wide_Type (Gen_T)
10902 and then Is_Class_Wide_Type (Act_T)
10903 and then Subtypes_Match
10904 (Get_Instance_Of (Root_Type (Gen_T)),
10905 Root_Type (Act_T)))
10907 or else
10908 (Ekind_In (Gen_T, E_Anonymous_Access_Subprogram_Type,
10909 E_Anonymous_Access_Type)
10910 and then Ekind (Act_T) = Ekind (Gen_T)
10911 and then Subtypes_Statically_Match
10912 (Designated_Type (Gen_T), Designated_Type (Act_T)));
10913 end Subtypes_Match;
10915 -----------------------------------------
10916 -- Validate_Access_Subprogram_Instance --
10917 -----------------------------------------
10919 procedure Validate_Access_Subprogram_Instance is
10920 begin
10921 if not Is_Access_Type (Act_T)
10922 or else Ekind (Designated_Type (Act_T)) /= E_Subprogram_Type
10923 then
10924 Error_Msg_NE
10925 ("expect access type in instantiation of &", Actual, Gen_T);
10926 Abandon_Instantiation (Actual);
10927 end if;
10929 -- According to AI05-288, actuals for access_to_subprograms must be
10930 -- subtype conformant with the generic formal. Previous to AI05-288
10931 -- only mode conformance was required.
10933 -- This is a binding interpretation that applies to previous versions
10934 -- of the language, no need to maintain previous weaker checks.
10936 Check_Subtype_Conformant
10937 (Designated_Type (Act_T),
10938 Designated_Type (A_Gen_T),
10939 Actual,
10940 Get_Inst => True);
10942 if Ekind (Base_Type (Act_T)) = E_Access_Protected_Subprogram_Type then
10943 if Ekind (A_Gen_T) = E_Access_Subprogram_Type then
10944 Error_Msg_NE
10945 ("protected access type not allowed for formal &",
10946 Actual, Gen_T);
10947 end if;
10949 elsif Ekind (A_Gen_T) = E_Access_Protected_Subprogram_Type then
10950 Error_Msg_NE
10951 ("expect protected access type for formal &",
10952 Actual, Gen_T);
10953 end if;
10954 end Validate_Access_Subprogram_Instance;
10956 -----------------------------------
10957 -- Validate_Access_Type_Instance --
10958 -----------------------------------
10960 procedure Validate_Access_Type_Instance is
10961 Desig_Type : constant Entity_Id :=
10962 Find_Actual_Type (Designated_Type (A_Gen_T), A_Gen_T);
10963 Desig_Act : Entity_Id;
10965 begin
10966 if not Is_Access_Type (Act_T) then
10967 Error_Msg_NE
10968 ("expect access type in instantiation of &", Actual, Gen_T);
10969 Abandon_Instantiation (Actual);
10970 end if;
10972 if Is_Access_Constant (A_Gen_T) then
10973 if not Is_Access_Constant (Act_T) then
10974 Error_Msg_N
10975 ("actual type must be access-to-constant type", Actual);
10976 Abandon_Instantiation (Actual);
10977 end if;
10978 else
10979 if Is_Access_Constant (Act_T) then
10980 Error_Msg_N
10981 ("actual type must be access-to-variable type", Actual);
10982 Abandon_Instantiation (Actual);
10984 elsif Ekind (A_Gen_T) = E_General_Access_Type
10985 and then Ekind (Base_Type (Act_T)) /= E_General_Access_Type
10986 then
10987 Error_Msg_N -- CODEFIX
10988 ("actual must be general access type!", Actual);
10989 Error_Msg_NE -- CODEFIX
10990 ("add ALL to }!", Actual, Act_T);
10991 Abandon_Instantiation (Actual);
10992 end if;
10993 end if;
10995 -- The designated subtypes, that is to say the subtypes introduced
10996 -- by an access type declaration (and not by a subtype declaration)
10997 -- must match.
10999 Desig_Act := Designated_Type (Base_Type (Act_T));
11001 -- The designated type may have been introduced through a limited_
11002 -- with clause, in which case retrieve the non-limited view. This
11003 -- applies to incomplete types as well as to class-wide types.
11005 if From_Limited_With (Desig_Act) then
11006 Desig_Act := Available_View (Desig_Act);
11007 end if;
11009 if not Subtypes_Match (Desig_Type, Desig_Act) then
11010 Error_Msg_NE
11011 ("designated type of actual does not match that of formal &",
11012 Actual, Gen_T);
11014 if not Predicates_Match (Desig_Type, Desig_Act) then
11015 Error_Msg_N ("\predicates do not match", Actual);
11016 end if;
11018 Abandon_Instantiation (Actual);
11020 elsif Is_Access_Type (Designated_Type (Act_T))
11021 and then Is_Constrained (Designated_Type (Designated_Type (Act_T)))
11023 Is_Constrained (Designated_Type (Desig_Type))
11024 then
11025 Error_Msg_NE
11026 ("designated type of actual does not match that of formal &",
11027 Actual, Gen_T);
11029 if not Predicates_Match (Desig_Type, Desig_Act) then
11030 Error_Msg_N ("\predicates do not match", Actual);
11031 end if;
11033 Abandon_Instantiation (Actual);
11034 end if;
11036 -- Ada 2005: null-exclusion indicators of the two types must agree
11038 if Can_Never_Be_Null (A_Gen_T) /= Can_Never_Be_Null (Act_T) then
11039 Error_Msg_NE
11040 ("non null exclusion of actual and formal & do not match",
11041 Actual, Gen_T);
11042 end if;
11043 end Validate_Access_Type_Instance;
11045 ----------------------------------
11046 -- Validate_Array_Type_Instance --
11047 ----------------------------------
11049 procedure Validate_Array_Type_Instance is
11050 I1 : Node_Id;
11051 I2 : Node_Id;
11052 T2 : Entity_Id;
11054 function Formal_Dimensions return Int;
11055 -- Count number of dimensions in array type formal
11057 -----------------------
11058 -- Formal_Dimensions --
11059 -----------------------
11061 function Formal_Dimensions return Int is
11062 Num : Int := 0;
11063 Index : Node_Id;
11065 begin
11066 if Nkind (Def) = N_Constrained_Array_Definition then
11067 Index := First (Discrete_Subtype_Definitions (Def));
11068 else
11069 Index := First (Subtype_Marks (Def));
11070 end if;
11072 while Present (Index) loop
11073 Num := Num + 1;
11074 Next_Index (Index);
11075 end loop;
11077 return Num;
11078 end Formal_Dimensions;
11080 -- Start of processing for Validate_Array_Type_Instance
11082 begin
11083 if not Is_Array_Type (Act_T) then
11084 Error_Msg_NE
11085 ("expect array type in instantiation of &", Actual, Gen_T);
11086 Abandon_Instantiation (Actual);
11088 elsif Nkind (Def) = N_Constrained_Array_Definition then
11089 if not (Is_Constrained (Act_T)) then
11090 Error_Msg_NE
11091 ("expect constrained array in instantiation of &",
11092 Actual, Gen_T);
11093 Abandon_Instantiation (Actual);
11094 end if;
11096 else
11097 if Is_Constrained (Act_T) then
11098 Error_Msg_NE
11099 ("expect unconstrained array in instantiation of &",
11100 Actual, Gen_T);
11101 Abandon_Instantiation (Actual);
11102 end if;
11103 end if;
11105 if Formal_Dimensions /= Number_Dimensions (Act_T) then
11106 Error_Msg_NE
11107 ("dimensions of actual do not match formal &", Actual, Gen_T);
11108 Abandon_Instantiation (Actual);
11109 end if;
11111 I1 := First_Index (A_Gen_T);
11112 I2 := First_Index (Act_T);
11113 for J in 1 .. Formal_Dimensions loop
11115 -- If the indexes of the actual were given by a subtype_mark,
11116 -- the index was transformed into a range attribute. Retrieve
11117 -- the original type mark for checking.
11119 if Is_Entity_Name (Original_Node (I2)) then
11120 T2 := Entity (Original_Node (I2));
11121 else
11122 T2 := Etype (I2);
11123 end if;
11125 if not Subtypes_Match
11126 (Find_Actual_Type (Etype (I1), A_Gen_T), T2)
11127 then
11128 Error_Msg_NE
11129 ("index types of actual do not match those of formal &",
11130 Actual, Gen_T);
11131 Abandon_Instantiation (Actual);
11132 end if;
11134 Next_Index (I1);
11135 Next_Index (I2);
11136 end loop;
11138 -- Check matching subtypes. Note that there are complex visibility
11139 -- issues when the generic is a child unit and some aspect of the
11140 -- generic type is declared in a parent unit of the generic. We do
11141 -- the test to handle this special case only after a direct check
11142 -- for static matching has failed. The case where both the component
11143 -- type and the array type are separate formals, and the component
11144 -- type is a private view may also require special checking in
11145 -- Subtypes_Match.
11147 if Subtypes_Match
11148 (Component_Type (A_Gen_T), Component_Type (Act_T))
11149 or else Subtypes_Match
11150 (Find_Actual_Type (Component_Type (A_Gen_T), A_Gen_T),
11151 Component_Type (Act_T))
11152 then
11153 null;
11154 else
11155 Error_Msg_NE
11156 ("component subtype of actual does not match that of formal &",
11157 Actual, Gen_T);
11158 Abandon_Instantiation (Actual);
11159 end if;
11161 if Has_Aliased_Components (A_Gen_T)
11162 and then not Has_Aliased_Components (Act_T)
11163 then
11164 Error_Msg_NE
11165 ("actual must have aliased components to match formal type &",
11166 Actual, Gen_T);
11167 end if;
11168 end Validate_Array_Type_Instance;
11170 -----------------------------------------------
11171 -- Validate_Derived_Interface_Type_Instance --
11172 -----------------------------------------------
11174 procedure Validate_Derived_Interface_Type_Instance is
11175 Par : constant Entity_Id := Entity (Subtype_Indication (Def));
11176 Elmt : Elmt_Id;
11178 begin
11179 -- First apply interface instance checks
11181 Validate_Interface_Type_Instance;
11183 -- Verify that immediate parent interface is an ancestor of
11184 -- the actual.
11186 if Present (Par)
11187 and then not Interface_Present_In_Ancestor (Act_T, Par)
11188 then
11189 Error_Msg_NE
11190 ("interface actual must include progenitor&", Actual, Par);
11191 end if;
11193 -- Now verify that the actual includes all other ancestors of
11194 -- the formal.
11196 Elmt := First_Elmt (Interfaces (A_Gen_T));
11197 while Present (Elmt) loop
11198 if not Interface_Present_In_Ancestor
11199 (Act_T, Get_Instance_Of (Node (Elmt)))
11200 then
11201 Error_Msg_NE
11202 ("interface actual must include progenitor&",
11203 Actual, Node (Elmt));
11204 end if;
11206 Next_Elmt (Elmt);
11207 end loop;
11208 end Validate_Derived_Interface_Type_Instance;
11210 ------------------------------------
11211 -- Validate_Derived_Type_Instance --
11212 ------------------------------------
11214 procedure Validate_Derived_Type_Instance is
11215 Actual_Discr : Entity_Id;
11216 Ancestor_Discr : Entity_Id;
11218 begin
11219 -- If the parent type in the generic declaration is itself a previous
11220 -- formal type, then it is local to the generic and absent from the
11221 -- analyzed generic definition. In that case the ancestor is the
11222 -- instance of the formal (which must have been instantiated
11223 -- previously), unless the ancestor is itself a formal derived type.
11224 -- In this latter case (which is the subject of Corrigendum 8652/0038
11225 -- (AI-202) the ancestor of the formals is the ancestor of its
11226 -- parent. Otherwise, the analyzed generic carries the parent type.
11227 -- If the parent type is defined in a previous formal package, then
11228 -- the scope of that formal package is that of the generic type
11229 -- itself, and it has already been mapped into the corresponding type
11230 -- in the actual package.
11232 -- Common case: parent type defined outside of the generic
11234 if Is_Entity_Name (Subtype_Mark (Def))
11235 and then Present (Entity (Subtype_Mark (Def)))
11236 then
11237 Ancestor := Get_Instance_Of (Entity (Subtype_Mark (Def)));
11239 -- Check whether parent is defined in a previous formal package
11241 elsif
11242 Scope (Scope (Base_Type (Etype (A_Gen_T)))) = Scope (A_Gen_T)
11243 then
11244 Ancestor :=
11245 Get_Instance_Of (Base_Type (Etype (A_Gen_T)));
11247 -- The type may be a local derivation, or a type extension of a
11248 -- previous formal, or of a formal of a parent package.
11250 elsif Is_Derived_Type (Get_Instance_Of (A_Gen_T))
11251 or else
11252 Ekind (Get_Instance_Of (A_Gen_T)) = E_Record_Type_With_Private
11253 then
11254 -- Check whether the parent is another derived formal type in the
11255 -- same generic unit.
11257 if Etype (A_Gen_T) /= A_Gen_T
11258 and then Is_Generic_Type (Etype (A_Gen_T))
11259 and then Scope (Etype (A_Gen_T)) = Scope (A_Gen_T)
11260 and then Etype (Etype (A_Gen_T)) /= Etype (A_Gen_T)
11261 then
11262 -- Locate ancestor of parent from the subtype declaration
11263 -- created for the actual.
11265 declare
11266 Decl : Node_Id;
11268 begin
11269 Decl := First (Actual_Decls);
11270 while Present (Decl) loop
11271 if Nkind (Decl) = N_Subtype_Declaration
11272 and then Chars (Defining_Identifier (Decl)) =
11273 Chars (Etype (A_Gen_T))
11274 then
11275 Ancestor := Generic_Parent_Type (Decl);
11276 exit;
11277 else
11278 Next (Decl);
11279 end if;
11280 end loop;
11281 end;
11283 pragma Assert (Present (Ancestor));
11285 -- The ancestor itself may be a previous formal that has been
11286 -- instantiated.
11288 Ancestor := Get_Instance_Of (Ancestor);
11290 else
11291 Ancestor :=
11292 Get_Instance_Of (Base_Type (Get_Instance_Of (A_Gen_T)));
11293 end if;
11295 -- An unusual case: the actual is a type declared in a parent unit,
11296 -- but is not a formal type so there is no instance_of for it.
11297 -- Retrieve it by analyzing the record extension.
11299 elsif Is_Child_Unit (Scope (A_Gen_T))
11300 and then In_Open_Scopes (Scope (Act_T))
11301 and then Is_Generic_Instance (Scope (Act_T))
11302 then
11303 Analyze (Subtype_Mark (Def));
11304 Ancestor := Entity (Subtype_Mark (Def));
11306 else
11307 Ancestor := Get_Instance_Of (Etype (Base_Type (A_Gen_T)));
11308 end if;
11310 -- If the formal derived type has pragma Preelaborable_Initialization
11311 -- then the actual type must have preelaborable initialization.
11313 if Known_To_Have_Preelab_Init (A_Gen_T)
11314 and then not Has_Preelaborable_Initialization (Act_T)
11315 then
11316 Error_Msg_NE
11317 ("actual for & must have preelaborable initialization",
11318 Actual, Gen_T);
11319 end if;
11321 -- Ada 2005 (AI-251)
11323 if Ada_Version >= Ada_2005 and then Is_Interface (Ancestor) then
11324 if not Interface_Present_In_Ancestor (Act_T, Ancestor) then
11325 Error_Msg_NE
11326 ("(Ada 2005) expected type implementing & in instantiation",
11327 Actual, Ancestor);
11328 end if;
11330 elsif not Is_Ancestor (Base_Type (Ancestor), Act_T) then
11331 Error_Msg_NE
11332 ("expect type derived from & in instantiation",
11333 Actual, First_Subtype (Ancestor));
11334 Abandon_Instantiation (Actual);
11335 end if;
11337 -- Ada 2005 (AI-443): Synchronized formal derived type checks. Note
11338 -- that the formal type declaration has been rewritten as a private
11339 -- extension.
11341 if Ada_Version >= Ada_2005
11342 and then Nkind (Parent (A_Gen_T)) = N_Private_Extension_Declaration
11343 and then Synchronized_Present (Parent (A_Gen_T))
11344 then
11345 -- The actual must be a synchronized tagged type
11347 if not Is_Tagged_Type (Act_T) then
11348 Error_Msg_N
11349 ("actual of synchronized type must be tagged", Actual);
11350 Abandon_Instantiation (Actual);
11352 elsif Nkind (Parent (Act_T)) = N_Full_Type_Declaration
11353 and then Nkind (Type_Definition (Parent (Act_T))) =
11354 N_Derived_Type_Definition
11355 and then not Synchronized_Present (Type_Definition
11356 (Parent (Act_T)))
11357 then
11358 Error_Msg_N
11359 ("actual of synchronized type must be synchronized", Actual);
11360 Abandon_Instantiation (Actual);
11361 end if;
11362 end if;
11364 -- Perform atomic/volatile checks (RM C.6(12)). Note that AI05-0218-1
11365 -- removes the second instance of the phrase "or allow pass by copy".
11367 if Is_Atomic (Act_T) and then not Is_Atomic (Ancestor) then
11368 Error_Msg_N
11369 ("cannot have atomic actual type for non-atomic formal type",
11370 Actual);
11372 elsif Is_Volatile (Act_T) and then not Is_Volatile (Ancestor) then
11373 Error_Msg_N
11374 ("cannot have volatile actual type for non-volatile formal type",
11375 Actual);
11376 end if;
11378 -- It should not be necessary to check for unknown discriminants on
11379 -- Formal, but for some reason Has_Unknown_Discriminants is false for
11380 -- A_Gen_T, so Is_Indefinite_Subtype incorrectly returns False. This
11381 -- needs fixing. ???
11383 if not Is_Indefinite_Subtype (A_Gen_T)
11384 and then not Unknown_Discriminants_Present (Formal)
11385 and then Is_Indefinite_Subtype (Act_T)
11386 then
11387 Error_Msg_N
11388 ("actual subtype must be constrained", Actual);
11389 Abandon_Instantiation (Actual);
11390 end if;
11392 if not Unknown_Discriminants_Present (Formal) then
11393 if Is_Constrained (Ancestor) then
11394 if not Is_Constrained (Act_T) then
11395 Error_Msg_N
11396 ("actual subtype must be constrained", Actual);
11397 Abandon_Instantiation (Actual);
11398 end if;
11400 -- Ancestor is unconstrained, Check if generic formal and actual
11401 -- agree on constrainedness. The check only applies to array types
11402 -- and discriminated types.
11404 elsif Is_Constrained (Act_T) then
11405 if Ekind (Ancestor) = E_Access_Type
11406 or else
11407 (not Is_Constrained (A_Gen_T)
11408 and then Is_Composite_Type (A_Gen_T))
11409 then
11410 Error_Msg_N
11411 ("actual subtype must be unconstrained", Actual);
11412 Abandon_Instantiation (Actual);
11413 end if;
11415 -- A class-wide type is only allowed if the formal has unknown
11416 -- discriminants.
11418 elsif Is_Class_Wide_Type (Act_T)
11419 and then not Has_Unknown_Discriminants (Ancestor)
11420 then
11421 Error_Msg_NE
11422 ("actual for & cannot be a class-wide type", Actual, Gen_T);
11423 Abandon_Instantiation (Actual);
11425 -- Otherwise, the formal and actual must have the same number
11426 -- of discriminants and each discriminant of the actual must
11427 -- correspond to a discriminant of the formal.
11429 elsif Has_Discriminants (Act_T)
11430 and then not Has_Unknown_Discriminants (Act_T)
11431 and then Has_Discriminants (Ancestor)
11432 then
11433 Actual_Discr := First_Discriminant (Act_T);
11434 Ancestor_Discr := First_Discriminant (Ancestor);
11435 while Present (Actual_Discr)
11436 and then Present (Ancestor_Discr)
11437 loop
11438 if Base_Type (Act_T) /= Base_Type (Ancestor) and then
11439 No (Corresponding_Discriminant (Actual_Discr))
11440 then
11441 Error_Msg_NE
11442 ("discriminant & does not correspond " &
11443 "to ancestor discriminant", Actual, Actual_Discr);
11444 Abandon_Instantiation (Actual);
11445 end if;
11447 Next_Discriminant (Actual_Discr);
11448 Next_Discriminant (Ancestor_Discr);
11449 end loop;
11451 if Present (Actual_Discr) or else Present (Ancestor_Discr) then
11452 Error_Msg_NE
11453 ("actual for & must have same number of discriminants",
11454 Actual, Gen_T);
11455 Abandon_Instantiation (Actual);
11456 end if;
11458 -- This case should be caught by the earlier check for
11459 -- constrainedness, but the check here is added for completeness.
11461 elsif Has_Discriminants (Act_T)
11462 and then not Has_Unknown_Discriminants (Act_T)
11463 then
11464 Error_Msg_NE
11465 ("actual for & must not have discriminants", Actual, Gen_T);
11466 Abandon_Instantiation (Actual);
11468 elsif Has_Discriminants (Ancestor) then
11469 Error_Msg_NE
11470 ("actual for & must have known discriminants", Actual, Gen_T);
11471 Abandon_Instantiation (Actual);
11472 end if;
11474 if not Subtypes_Statically_Compatible
11475 (Act_T, Ancestor, Formal_Derived_Matching => True)
11476 then
11477 Error_Msg_N
11478 ("constraint on actual is incompatible with formal", Actual);
11479 Abandon_Instantiation (Actual);
11480 end if;
11481 end if;
11483 -- If the formal and actual types are abstract, check that there
11484 -- are no abstract primitives of the actual type that correspond to
11485 -- nonabstract primitives of the formal type (second sentence of
11486 -- RM95-3.9.3(9)).
11488 if Is_Abstract_Type (A_Gen_T) and then Is_Abstract_Type (Act_T) then
11489 Check_Abstract_Primitives : declare
11490 Gen_Prims : constant Elist_Id :=
11491 Primitive_Operations (A_Gen_T);
11492 Gen_Elmt : Elmt_Id;
11493 Gen_Subp : Entity_Id;
11494 Anc_Subp : Entity_Id;
11495 Anc_Formal : Entity_Id;
11496 Anc_F_Type : Entity_Id;
11498 Act_Prims : constant Elist_Id := Primitive_Operations (Act_T);
11499 Act_Elmt : Elmt_Id;
11500 Act_Subp : Entity_Id;
11501 Act_Formal : Entity_Id;
11502 Act_F_Type : Entity_Id;
11504 Subprograms_Correspond : Boolean;
11506 function Is_Tagged_Ancestor (T1, T2 : Entity_Id) return Boolean;
11507 -- Returns true if T2 is derived directly or indirectly from
11508 -- T1, including derivations from interfaces. T1 and T2 are
11509 -- required to be specific tagged base types.
11511 ------------------------
11512 -- Is_Tagged_Ancestor --
11513 ------------------------
11515 function Is_Tagged_Ancestor (T1, T2 : Entity_Id) return Boolean
11517 Intfc_Elmt : Elmt_Id;
11519 begin
11520 -- The predicate is satisfied if the types are the same
11522 if T1 = T2 then
11523 return True;
11525 -- If we've reached the top of the derivation chain then
11526 -- we know that T1 is not an ancestor of T2.
11528 elsif Etype (T2) = T2 then
11529 return False;
11531 -- Proceed to check T2's immediate parent
11533 elsif Is_Ancestor (T1, Base_Type (Etype (T2))) then
11534 return True;
11536 -- Finally, check to see if T1 is an ancestor of any of T2's
11537 -- progenitors.
11539 else
11540 Intfc_Elmt := First_Elmt (Interfaces (T2));
11541 while Present (Intfc_Elmt) loop
11542 if Is_Ancestor (T1, Node (Intfc_Elmt)) then
11543 return True;
11544 end if;
11546 Next_Elmt (Intfc_Elmt);
11547 end loop;
11548 end if;
11550 return False;
11551 end Is_Tagged_Ancestor;
11553 -- Start of processing for Check_Abstract_Primitives
11555 begin
11556 -- Loop over all of the formal derived type's primitives
11558 Gen_Elmt := First_Elmt (Gen_Prims);
11559 while Present (Gen_Elmt) loop
11560 Gen_Subp := Node (Gen_Elmt);
11562 -- If the primitive of the formal is not abstract, then
11563 -- determine whether there is a corresponding primitive of
11564 -- the actual type that's abstract.
11566 if not Is_Abstract_Subprogram (Gen_Subp) then
11567 Act_Elmt := First_Elmt (Act_Prims);
11568 while Present (Act_Elmt) loop
11569 Act_Subp := Node (Act_Elmt);
11571 -- If we find an abstract primitive of the actual,
11572 -- then we need to test whether it corresponds to the
11573 -- subprogram from which the generic formal primitive
11574 -- is inherited.
11576 if Is_Abstract_Subprogram (Act_Subp) then
11577 Anc_Subp := Alias (Gen_Subp);
11579 -- Test whether we have a corresponding primitive
11580 -- by comparing names, kinds, formal types, and
11581 -- result types.
11583 if Chars (Anc_Subp) = Chars (Act_Subp)
11584 and then Ekind (Anc_Subp) = Ekind (Act_Subp)
11585 then
11586 Anc_Formal := First_Formal (Anc_Subp);
11587 Act_Formal := First_Formal (Act_Subp);
11588 while Present (Anc_Formal)
11589 and then Present (Act_Formal)
11590 loop
11591 Anc_F_Type := Etype (Anc_Formal);
11592 Act_F_Type := Etype (Act_Formal);
11594 if Ekind (Anc_F_Type)
11595 = E_Anonymous_Access_Type
11596 then
11597 Anc_F_Type := Designated_Type (Anc_F_Type);
11599 if Ekind (Act_F_Type)
11600 = E_Anonymous_Access_Type
11601 then
11602 Act_F_Type :=
11603 Designated_Type (Act_F_Type);
11604 else
11605 exit;
11606 end if;
11608 elsif
11609 Ekind (Act_F_Type) = E_Anonymous_Access_Type
11610 then
11611 exit;
11612 end if;
11614 Anc_F_Type := Base_Type (Anc_F_Type);
11615 Act_F_Type := Base_Type (Act_F_Type);
11617 -- If the formal is controlling, then the
11618 -- the type of the actual primitive's formal
11619 -- must be derived directly or indirectly
11620 -- from the type of the ancestor primitive's
11621 -- formal.
11623 if Is_Controlling_Formal (Anc_Formal) then
11624 if not Is_Tagged_Ancestor
11625 (Anc_F_Type, Act_F_Type)
11626 then
11627 exit;
11628 end if;
11630 -- Otherwise the types of the formals must
11631 -- be the same.
11633 elsif Anc_F_Type /= Act_F_Type then
11634 exit;
11635 end if;
11637 Next_Entity (Anc_Formal);
11638 Next_Entity (Act_Formal);
11639 end loop;
11641 -- If we traversed through all of the formals
11642 -- then so far the subprograms correspond, so
11643 -- now check that any result types correspond.
11645 if No (Anc_Formal) and then No (Act_Formal) then
11646 Subprograms_Correspond := True;
11648 if Ekind (Act_Subp) = E_Function then
11649 Anc_F_Type := Etype (Anc_Subp);
11650 Act_F_Type := Etype (Act_Subp);
11652 if Ekind (Anc_F_Type)
11653 = E_Anonymous_Access_Type
11654 then
11655 Anc_F_Type :=
11656 Designated_Type (Anc_F_Type);
11658 if Ekind (Act_F_Type)
11659 = E_Anonymous_Access_Type
11660 then
11661 Act_F_Type :=
11662 Designated_Type (Act_F_Type);
11663 else
11664 Subprograms_Correspond := False;
11665 end if;
11667 elsif
11668 Ekind (Act_F_Type)
11669 = E_Anonymous_Access_Type
11670 then
11671 Subprograms_Correspond := False;
11672 end if;
11674 Anc_F_Type := Base_Type (Anc_F_Type);
11675 Act_F_Type := Base_Type (Act_F_Type);
11677 -- Now either the result types must be
11678 -- the same or, if the result type is
11679 -- controlling, the result type of the
11680 -- actual primitive must descend from the
11681 -- result type of the ancestor primitive.
11683 if Subprograms_Correspond
11684 and then Anc_F_Type /= Act_F_Type
11685 and then
11686 Has_Controlling_Result (Anc_Subp)
11687 and then
11688 not Is_Tagged_Ancestor
11689 (Anc_F_Type, Act_F_Type)
11690 then
11691 Subprograms_Correspond := False;
11692 end if;
11693 end if;
11695 -- Found a matching subprogram belonging to
11696 -- formal ancestor type, so actual subprogram
11697 -- corresponds and this violates 3.9.3(9).
11699 if Subprograms_Correspond then
11700 Error_Msg_NE
11701 ("abstract subprogram & overrides " &
11702 "nonabstract subprogram of ancestor",
11703 Actual,
11704 Act_Subp);
11705 end if;
11706 end if;
11707 end if;
11708 end if;
11710 Next_Elmt (Act_Elmt);
11711 end loop;
11712 end if;
11714 Next_Elmt (Gen_Elmt);
11715 end loop;
11716 end Check_Abstract_Primitives;
11717 end if;
11719 -- Verify that limitedness matches. If parent is a limited
11720 -- interface then the generic formal is not unless declared
11721 -- explicitly so. If not declared limited, the actual cannot be
11722 -- limited (see AI05-0087).
11724 -- Even though this AI is a binding interpretation, we enable the
11725 -- check only in Ada 2012 mode, because this improper construct
11726 -- shows up in user code and in existing B-tests.
11728 if Is_Limited_Type (Act_T)
11729 and then not Is_Limited_Type (A_Gen_T)
11730 and then Ada_Version >= Ada_2012
11731 then
11732 if In_Instance then
11733 null;
11734 else
11735 Error_Msg_NE
11736 ("actual for non-limited & cannot be a limited type", Actual,
11737 Gen_T);
11738 Explain_Limited_Type (Act_T, Actual);
11739 Abandon_Instantiation (Actual);
11740 end if;
11741 end if;
11742 end Validate_Derived_Type_Instance;
11744 ----------------------------------------
11745 -- Validate_Discriminated_Formal_Type --
11746 ----------------------------------------
11748 procedure Validate_Discriminated_Formal_Type is
11749 Formal_Discr : Entity_Id;
11750 Actual_Discr : Entity_Id;
11751 Formal_Subt : Entity_Id;
11753 begin
11754 if Has_Discriminants (A_Gen_T) then
11755 if not Has_Discriminants (Act_T) then
11756 Error_Msg_NE
11757 ("actual for & must have discriminants", Actual, Gen_T);
11758 Abandon_Instantiation (Actual);
11760 elsif Is_Constrained (Act_T) then
11761 Error_Msg_NE
11762 ("actual for & must be unconstrained", Actual, Gen_T);
11763 Abandon_Instantiation (Actual);
11765 else
11766 Formal_Discr := First_Discriminant (A_Gen_T);
11767 Actual_Discr := First_Discriminant (Act_T);
11768 while Formal_Discr /= Empty loop
11769 if Actual_Discr = Empty then
11770 Error_Msg_NE
11771 ("discriminants on actual do not match formal",
11772 Actual, Gen_T);
11773 Abandon_Instantiation (Actual);
11774 end if;
11776 Formal_Subt := Get_Instance_Of (Etype (Formal_Discr));
11778 -- Access discriminants match if designated types do
11780 if Ekind (Base_Type (Formal_Subt)) = E_Anonymous_Access_Type
11781 and then (Ekind (Base_Type (Etype (Actual_Discr)))) =
11782 E_Anonymous_Access_Type
11783 and then
11784 Get_Instance_Of
11785 (Designated_Type (Base_Type (Formal_Subt))) =
11786 Designated_Type (Base_Type (Etype (Actual_Discr)))
11787 then
11788 null;
11790 elsif Base_Type (Formal_Subt) /=
11791 Base_Type (Etype (Actual_Discr))
11792 then
11793 Error_Msg_NE
11794 ("types of actual discriminants must match formal",
11795 Actual, Gen_T);
11796 Abandon_Instantiation (Actual);
11798 elsif not Subtypes_Statically_Match
11799 (Formal_Subt, Etype (Actual_Discr))
11800 and then Ada_Version >= Ada_95
11801 then
11802 Error_Msg_NE
11803 ("subtypes of actual discriminants must match formal",
11804 Actual, Gen_T);
11805 Abandon_Instantiation (Actual);
11806 end if;
11808 Next_Discriminant (Formal_Discr);
11809 Next_Discriminant (Actual_Discr);
11810 end loop;
11812 if Actual_Discr /= Empty then
11813 Error_Msg_NE
11814 ("discriminants on actual do not match formal",
11815 Actual, Gen_T);
11816 Abandon_Instantiation (Actual);
11817 end if;
11818 end if;
11819 end if;
11820 end Validate_Discriminated_Formal_Type;
11822 ---------------------------------------
11823 -- Validate_Incomplete_Type_Instance --
11824 ---------------------------------------
11826 procedure Validate_Incomplete_Type_Instance is
11827 begin
11828 if not Is_Tagged_Type (Act_T)
11829 and then Is_Tagged_Type (A_Gen_T)
11830 then
11831 Error_Msg_NE
11832 ("actual for & must be a tagged type", Actual, Gen_T);
11833 end if;
11835 Validate_Discriminated_Formal_Type;
11836 end Validate_Incomplete_Type_Instance;
11838 --------------------------------------
11839 -- Validate_Interface_Type_Instance --
11840 --------------------------------------
11842 procedure Validate_Interface_Type_Instance is
11843 begin
11844 if not Is_Interface (Act_T) then
11845 Error_Msg_NE
11846 ("actual for formal interface type must be an interface",
11847 Actual, Gen_T);
11849 elsif Is_Limited_Type (Act_T) /= Is_Limited_Type (A_Gen_T)
11850 or else
11851 Is_Task_Interface (A_Gen_T) /= Is_Task_Interface (Act_T)
11852 or else
11853 Is_Protected_Interface (A_Gen_T) /=
11854 Is_Protected_Interface (Act_T)
11855 or else
11856 Is_Synchronized_Interface (A_Gen_T) /=
11857 Is_Synchronized_Interface (Act_T)
11858 then
11859 Error_Msg_NE
11860 ("actual for interface& does not match (RM 12.5.5(4))",
11861 Actual, Gen_T);
11862 end if;
11863 end Validate_Interface_Type_Instance;
11865 ------------------------------------
11866 -- Validate_Private_Type_Instance --
11867 ------------------------------------
11869 procedure Validate_Private_Type_Instance is
11870 begin
11871 if Is_Limited_Type (Act_T)
11872 and then not Is_Limited_Type (A_Gen_T)
11873 then
11874 if In_Instance then
11875 null;
11876 else
11877 Error_Msg_NE
11878 ("actual for non-limited & cannot be a limited type", Actual,
11879 Gen_T);
11880 Explain_Limited_Type (Act_T, Actual);
11881 Abandon_Instantiation (Actual);
11882 end if;
11884 elsif Known_To_Have_Preelab_Init (A_Gen_T)
11885 and then not Has_Preelaborable_Initialization (Act_T)
11886 then
11887 Error_Msg_NE
11888 ("actual for & must have preelaborable initialization", Actual,
11889 Gen_T);
11891 elsif Is_Indefinite_Subtype (Act_T)
11892 and then not Is_Indefinite_Subtype (A_Gen_T)
11893 and then Ada_Version >= Ada_95
11894 then
11895 Error_Msg_NE
11896 ("actual for & must be a definite subtype", Actual, Gen_T);
11898 elsif not Is_Tagged_Type (Act_T)
11899 and then Is_Tagged_Type (A_Gen_T)
11900 then
11901 Error_Msg_NE
11902 ("actual for & must be a tagged type", Actual, Gen_T);
11903 end if;
11905 Validate_Discriminated_Formal_Type;
11906 Ancestor := Gen_T;
11907 end Validate_Private_Type_Instance;
11909 -- Start of processing for Instantiate_Type
11911 begin
11912 if Get_Instance_Of (A_Gen_T) /= A_Gen_T then
11913 Error_Msg_N ("duplicate instantiation of generic type", Actual);
11914 return New_List (Error);
11916 elsif not Is_Entity_Name (Actual)
11917 or else not Is_Type (Entity (Actual))
11918 then
11919 Error_Msg_NE
11920 ("expect valid subtype mark to instantiate &", Actual, Gen_T);
11921 Abandon_Instantiation (Actual);
11923 else
11924 Act_T := Entity (Actual);
11926 -- Ada 2005 (AI-216): An Unchecked_Union subtype shall only be passed
11927 -- as a generic actual parameter if the corresponding formal type
11928 -- does not have a known_discriminant_part, or is a formal derived
11929 -- type that is an Unchecked_Union type.
11931 if Is_Unchecked_Union (Base_Type (Act_T)) then
11932 if not Has_Discriminants (A_Gen_T)
11933 or else
11934 (Is_Derived_Type (A_Gen_T)
11935 and then
11936 Is_Unchecked_Union (A_Gen_T))
11937 then
11938 null;
11939 else
11940 Error_Msg_N ("unchecked union cannot be the actual for a" &
11941 " discriminated formal type", Act_T);
11943 end if;
11944 end if;
11946 -- Deal with fixed/floating restrictions
11948 if Is_Floating_Point_Type (Act_T) then
11949 Check_Restriction (No_Floating_Point, Actual);
11950 elsif Is_Fixed_Point_Type (Act_T) then
11951 Check_Restriction (No_Fixed_Point, Actual);
11952 end if;
11954 -- Deal with error of using incomplete type as generic actual.
11955 -- This includes limited views of a type, even if the non-limited
11956 -- view may be available.
11958 if Ekind (Act_T) = E_Incomplete_Type
11959 or else (Is_Class_Wide_Type (Act_T)
11960 and then
11961 Ekind (Root_Type (Act_T)) = E_Incomplete_Type)
11962 then
11963 -- If the formal is an incomplete type, the actual can be
11964 -- incomplete as well.
11966 if Ekind (A_Gen_T) = E_Incomplete_Type then
11967 null;
11969 elsif Is_Class_Wide_Type (Act_T)
11970 or else No (Full_View (Act_T))
11971 then
11972 Error_Msg_N ("premature use of incomplete type", Actual);
11973 Abandon_Instantiation (Actual);
11974 else
11975 Act_T := Full_View (Act_T);
11976 Set_Entity (Actual, Act_T);
11978 if Has_Private_Component (Act_T) then
11979 Error_Msg_N
11980 ("premature use of type with private component", Actual);
11981 end if;
11982 end if;
11984 -- Deal with error of premature use of private type as generic actual
11986 elsif Is_Private_Type (Act_T)
11987 and then Is_Private_Type (Base_Type (Act_T))
11988 and then not Is_Generic_Type (Act_T)
11989 and then not Is_Derived_Type (Act_T)
11990 and then No (Full_View (Root_Type (Act_T)))
11991 then
11992 -- If the formal is an incomplete type, the actual can be
11993 -- private or incomplete as well.
11995 if Ekind (A_Gen_T) = E_Incomplete_Type then
11996 null;
11997 else
11998 Error_Msg_N ("premature use of private type", Actual);
11999 end if;
12001 elsif Has_Private_Component (Act_T) then
12002 Error_Msg_N
12003 ("premature use of type with private component", Actual);
12004 end if;
12006 Set_Instance_Of (A_Gen_T, Act_T);
12008 -- If the type is generic, the class-wide type may also be used
12010 if Is_Tagged_Type (A_Gen_T)
12011 and then Is_Tagged_Type (Act_T)
12012 and then not Is_Class_Wide_Type (A_Gen_T)
12013 then
12014 Set_Instance_Of (Class_Wide_Type (A_Gen_T),
12015 Class_Wide_Type (Act_T));
12016 end if;
12018 if not Is_Abstract_Type (A_Gen_T)
12019 and then Is_Abstract_Type (Act_T)
12020 then
12021 Error_Msg_N
12022 ("actual of non-abstract formal cannot be abstract", Actual);
12023 end if;
12025 -- A generic scalar type is a first subtype for which we generate
12026 -- an anonymous base type. Indicate that the instance of this base
12027 -- is the base type of the actual.
12029 if Is_Scalar_Type (A_Gen_T) then
12030 Set_Instance_Of (Etype (A_Gen_T), Etype (Act_T));
12031 end if;
12032 end if;
12034 if Error_Posted (Act_T) then
12035 null;
12036 else
12037 case Nkind (Def) is
12038 when N_Formal_Private_Type_Definition =>
12039 Validate_Private_Type_Instance;
12041 when N_Formal_Incomplete_Type_Definition =>
12042 Validate_Incomplete_Type_Instance;
12044 when N_Formal_Derived_Type_Definition =>
12045 Validate_Derived_Type_Instance;
12047 when N_Formal_Discrete_Type_Definition =>
12048 if not Is_Discrete_Type (Act_T) then
12049 Error_Msg_NE
12050 ("expect discrete type in instantiation of&",
12051 Actual, Gen_T);
12052 Abandon_Instantiation (Actual);
12053 end if;
12055 Diagnose_Predicated_Actual;
12057 when N_Formal_Signed_Integer_Type_Definition =>
12058 if not Is_Signed_Integer_Type (Act_T) then
12059 Error_Msg_NE
12060 ("expect signed integer type in instantiation of&",
12061 Actual, Gen_T);
12062 Abandon_Instantiation (Actual);
12063 end if;
12065 Diagnose_Predicated_Actual;
12067 when N_Formal_Modular_Type_Definition =>
12068 if not Is_Modular_Integer_Type (Act_T) then
12069 Error_Msg_NE
12070 ("expect modular type in instantiation of &",
12071 Actual, Gen_T);
12072 Abandon_Instantiation (Actual);
12073 end if;
12075 Diagnose_Predicated_Actual;
12077 when N_Formal_Floating_Point_Definition =>
12078 if not Is_Floating_Point_Type (Act_T) then
12079 Error_Msg_NE
12080 ("expect float type in instantiation of &", Actual, Gen_T);
12081 Abandon_Instantiation (Actual);
12082 end if;
12084 when N_Formal_Ordinary_Fixed_Point_Definition =>
12085 if not Is_Ordinary_Fixed_Point_Type (Act_T) then
12086 Error_Msg_NE
12087 ("expect ordinary fixed point type in instantiation of &",
12088 Actual, Gen_T);
12089 Abandon_Instantiation (Actual);
12090 end if;
12092 when N_Formal_Decimal_Fixed_Point_Definition =>
12093 if not Is_Decimal_Fixed_Point_Type (Act_T) then
12094 Error_Msg_NE
12095 ("expect decimal type in instantiation of &",
12096 Actual, Gen_T);
12097 Abandon_Instantiation (Actual);
12098 end if;
12100 when N_Array_Type_Definition =>
12101 Validate_Array_Type_Instance;
12103 when N_Access_To_Object_Definition =>
12104 Validate_Access_Type_Instance;
12106 when N_Access_Function_Definition |
12107 N_Access_Procedure_Definition =>
12108 Validate_Access_Subprogram_Instance;
12110 when N_Record_Definition =>
12111 Validate_Interface_Type_Instance;
12113 when N_Derived_Type_Definition =>
12114 Validate_Derived_Interface_Type_Instance;
12116 when others =>
12117 raise Program_Error;
12119 end case;
12120 end if;
12122 Subt := New_Copy (Gen_T);
12124 -- Use adjusted sloc of subtype name as the location for other nodes in
12125 -- the subtype declaration.
12127 Loc := Sloc (Subt);
12129 Decl_Node :=
12130 Make_Subtype_Declaration (Loc,
12131 Defining_Identifier => Subt,
12132 Subtype_Indication => New_Occurrence_Of (Act_T, Loc));
12134 if Is_Private_Type (Act_T) then
12135 Set_Has_Private_View (Subtype_Indication (Decl_Node));
12137 elsif Is_Access_Type (Act_T)
12138 and then Is_Private_Type (Designated_Type (Act_T))
12139 then
12140 Set_Has_Private_View (Subtype_Indication (Decl_Node));
12141 end if;
12143 Decl_Nodes := New_List (Decl_Node);
12145 -- Flag actual derived types so their elaboration produces the
12146 -- appropriate renamings for the primitive operations of the ancestor.
12147 -- Flag actual for formal private types as well, to determine whether
12148 -- operations in the private part may override inherited operations.
12149 -- If the formal has an interface list, the ancestor is not the
12150 -- parent, but the analyzed formal that includes the interface
12151 -- operations of all its progenitors.
12153 -- Same treatment for formal private types, so we can check whether the
12154 -- type is tagged limited when validating derivations in the private
12155 -- part. (See AI05-096).
12157 if Nkind (Def) = N_Formal_Derived_Type_Definition then
12158 if Present (Interface_List (Def)) then
12159 Set_Generic_Parent_Type (Decl_Node, A_Gen_T);
12160 else
12161 Set_Generic_Parent_Type (Decl_Node, Ancestor);
12162 end if;
12164 elsif Nkind_In (Def,
12165 N_Formal_Private_Type_Definition,
12166 N_Formal_Incomplete_Type_Definition)
12167 then
12168 Set_Generic_Parent_Type (Decl_Node, A_Gen_T);
12169 end if;
12171 -- If the actual is a synchronized type that implements an interface,
12172 -- the primitive operations are attached to the corresponding record,
12173 -- and we have to treat it as an additional generic actual, so that its
12174 -- primitive operations become visible in the instance. The task or
12175 -- protected type itself does not carry primitive operations.
12177 if Is_Concurrent_Type (Act_T)
12178 and then Is_Tagged_Type (Act_T)
12179 and then Present (Corresponding_Record_Type (Act_T))
12180 and then Present (Ancestor)
12181 and then Is_Interface (Ancestor)
12182 then
12183 declare
12184 Corr_Rec : constant Entity_Id :=
12185 Corresponding_Record_Type (Act_T);
12186 New_Corr : Entity_Id;
12187 Corr_Decl : Node_Id;
12189 begin
12190 New_Corr := Make_Temporary (Loc, 'S');
12191 Corr_Decl :=
12192 Make_Subtype_Declaration (Loc,
12193 Defining_Identifier => New_Corr,
12194 Subtype_Indication =>
12195 New_Occurrence_Of (Corr_Rec, Loc));
12196 Append_To (Decl_Nodes, Corr_Decl);
12198 if Ekind (Act_T) = E_Task_Type then
12199 Set_Ekind (Subt, E_Task_Subtype);
12200 else
12201 Set_Ekind (Subt, E_Protected_Subtype);
12202 end if;
12204 Set_Corresponding_Record_Type (Subt, Corr_Rec);
12205 Set_Generic_Parent_Type (Corr_Decl, Ancestor);
12206 Set_Generic_Parent_Type (Decl_Node, Empty);
12207 end;
12208 end if;
12210 return Decl_Nodes;
12211 end Instantiate_Type;
12213 ---------------------
12214 -- Is_In_Main_Unit --
12215 ---------------------
12217 function Is_In_Main_Unit (N : Node_Id) return Boolean is
12218 Unum : constant Unit_Number_Type := Get_Source_Unit (N);
12219 Current_Unit : Node_Id;
12221 begin
12222 if Unum = Main_Unit then
12223 return True;
12225 -- If the current unit is a subunit then it is either the main unit or
12226 -- is being compiled as part of the main unit.
12228 elsif Nkind (N) = N_Compilation_Unit then
12229 return Nkind (Unit (N)) = N_Subunit;
12230 end if;
12232 Current_Unit := Parent (N);
12233 while Present (Current_Unit)
12234 and then Nkind (Current_Unit) /= N_Compilation_Unit
12235 loop
12236 Current_Unit := Parent (Current_Unit);
12237 end loop;
12239 -- The instantiation node is in the main unit, or else the current node
12240 -- (perhaps as the result of nested instantiations) is in the main unit,
12241 -- or in the declaration of the main unit, which in this last case must
12242 -- be a body.
12244 return Unum = Main_Unit
12245 or else Current_Unit = Cunit (Main_Unit)
12246 or else Current_Unit = Library_Unit (Cunit (Main_Unit))
12247 or else (Present (Library_Unit (Current_Unit))
12248 and then Is_In_Main_Unit (Library_Unit (Current_Unit)));
12249 end Is_In_Main_Unit;
12251 ----------------------------
12252 -- Load_Parent_Of_Generic --
12253 ----------------------------
12255 procedure Load_Parent_Of_Generic
12256 (N : Node_Id;
12257 Spec : Node_Id;
12258 Body_Optional : Boolean := False)
12260 Comp_Unit : constant Node_Id := Cunit (Get_Source_Unit (Spec));
12261 Saved_Style_Check : constant Boolean := Style_Check;
12262 Saved_Warnings : constant Warning_Record := Save_Warnings;
12263 True_Parent : Node_Id;
12264 Inst_Node : Node_Id;
12265 OK : Boolean;
12266 Previous_Instances : constant Elist_Id := New_Elmt_List;
12268 procedure Collect_Previous_Instances (Decls : List_Id);
12269 -- Collect all instantiations in the given list of declarations, that
12270 -- precede the generic that we need to load. If the bodies of these
12271 -- instantiations are available, we must analyze them, to ensure that
12272 -- the public symbols generated are the same when the unit is compiled
12273 -- to generate code, and when it is compiled in the context of a unit
12274 -- that needs a particular nested instance. This process is applied to
12275 -- both package and subprogram instances.
12277 --------------------------------
12278 -- Collect_Previous_Instances --
12279 --------------------------------
12281 procedure Collect_Previous_Instances (Decls : List_Id) is
12282 Decl : Node_Id;
12284 begin
12285 Decl := First (Decls);
12286 while Present (Decl) loop
12287 if Sloc (Decl) >= Sloc (Inst_Node) then
12288 return;
12290 -- If Decl is an instantiation, then record it as requiring
12291 -- instantiation of the corresponding body, except if it is an
12292 -- abbreviated instantiation generated internally for conformance
12293 -- checking purposes only for the case of a formal package
12294 -- declared without a box (see Instantiate_Formal_Package). Such
12295 -- an instantiation does not generate any code (the actual code
12296 -- comes from actual) and thus does not need to be analyzed here.
12297 -- If the instantiation appears with a generic package body it is
12298 -- not analyzed here either.
12300 elsif Nkind (Decl) = N_Package_Instantiation
12301 and then not Is_Internal (Defining_Entity (Decl))
12302 then
12303 Append_Elmt (Decl, Previous_Instances);
12305 -- For a subprogram instantiation, omit instantiations intrinsic
12306 -- operations (Unchecked_Conversions, etc.) that have no bodies.
12308 elsif Nkind_In (Decl, N_Function_Instantiation,
12309 N_Procedure_Instantiation)
12310 and then not Is_Intrinsic_Subprogram (Entity (Name (Decl)))
12311 then
12312 Append_Elmt (Decl, Previous_Instances);
12314 elsif Nkind (Decl) = N_Package_Declaration then
12315 Collect_Previous_Instances
12316 (Visible_Declarations (Specification (Decl)));
12317 Collect_Previous_Instances
12318 (Private_Declarations (Specification (Decl)));
12320 -- Previous non-generic bodies may contain instances as well
12322 elsif Nkind (Decl) = N_Package_Body
12323 and then Ekind (Corresponding_Spec (Decl)) /= E_Generic_Package
12324 then
12325 Collect_Previous_Instances (Declarations (Decl));
12327 elsif Nkind (Decl) = N_Subprogram_Body
12328 and then not Acts_As_Spec (Decl)
12329 and then not Is_Generic_Subprogram (Corresponding_Spec (Decl))
12330 then
12331 Collect_Previous_Instances (Declarations (Decl));
12332 end if;
12334 Next (Decl);
12335 end loop;
12336 end Collect_Previous_Instances;
12338 -- Start of processing for Load_Parent_Of_Generic
12340 begin
12341 if not In_Same_Source_Unit (N, Spec)
12342 or else Nkind (Unit (Comp_Unit)) = N_Package_Declaration
12343 or else (Nkind (Unit (Comp_Unit)) = N_Package_Body
12344 and then not Is_In_Main_Unit (Spec))
12345 then
12346 -- Find body of parent of spec, and analyze it. A special case arises
12347 -- when the parent is an instantiation, that is to say when we are
12348 -- currently instantiating a nested generic. In that case, there is
12349 -- no separate file for the body of the enclosing instance. Instead,
12350 -- the enclosing body must be instantiated as if it were a pending
12351 -- instantiation, in order to produce the body for the nested generic
12352 -- we require now. Note that in that case the generic may be defined
12353 -- in a package body, the instance defined in the same package body,
12354 -- and the original enclosing body may not be in the main unit.
12356 Inst_Node := Empty;
12358 True_Parent := Parent (Spec);
12359 while Present (True_Parent)
12360 and then Nkind (True_Parent) /= N_Compilation_Unit
12361 loop
12362 if Nkind (True_Parent) = N_Package_Declaration
12363 and then
12364 Nkind (Original_Node (True_Parent)) = N_Package_Instantiation
12365 then
12366 -- Parent is a compilation unit that is an instantiation.
12367 -- Instantiation node has been replaced with package decl.
12369 Inst_Node := Original_Node (True_Parent);
12370 exit;
12372 elsif Nkind (True_Parent) = N_Package_Declaration
12373 and then Present (Generic_Parent (Specification (True_Parent)))
12374 and then Nkind (Parent (True_Parent)) /= N_Compilation_Unit
12375 then
12376 -- Parent is an instantiation within another specification.
12377 -- Declaration for instance has been inserted before original
12378 -- instantiation node. A direct link would be preferable?
12380 Inst_Node := Next (True_Parent);
12381 while Present (Inst_Node)
12382 and then Nkind (Inst_Node) /= N_Package_Instantiation
12383 loop
12384 Next (Inst_Node);
12385 end loop;
12387 -- If the instance appears within a generic, and the generic
12388 -- unit is defined within a formal package of the enclosing
12389 -- generic, there is no generic body available, and none
12390 -- needed. A more precise test should be used ???
12392 if No (Inst_Node) then
12393 return;
12394 end if;
12396 exit;
12398 else
12399 True_Parent := Parent (True_Parent);
12400 end if;
12401 end loop;
12403 -- Case where we are currently instantiating a nested generic
12405 if Present (Inst_Node) then
12406 if Nkind (Parent (True_Parent)) = N_Compilation_Unit then
12408 -- Instantiation node and declaration of instantiated package
12409 -- were exchanged when only the declaration was needed.
12410 -- Restore instantiation node before proceeding with body.
12412 Set_Unit (Parent (True_Parent), Inst_Node);
12413 end if;
12415 -- Now complete instantiation of enclosing body, if it appears in
12416 -- some other unit. If it appears in the current unit, the body
12417 -- will have been instantiated already.
12419 if No (Corresponding_Body (Instance_Spec (Inst_Node))) then
12421 -- We need to determine the expander mode to instantiate the
12422 -- enclosing body. Because the generic body we need may use
12423 -- global entities declared in the enclosing package (including
12424 -- aggregates) it is in general necessary to compile this body
12425 -- with expansion enabled, except if we are within a generic
12426 -- package, in which case the usual generic rule applies.
12428 declare
12429 Exp_Status : Boolean := True;
12430 Scop : Entity_Id;
12432 begin
12433 -- Loop through scopes looking for generic package
12435 Scop := Scope (Defining_Entity (Instance_Spec (Inst_Node)));
12436 while Present (Scop)
12437 and then Scop /= Standard_Standard
12438 loop
12439 if Ekind (Scop) = E_Generic_Package then
12440 Exp_Status := False;
12441 exit;
12442 end if;
12444 Scop := Scope (Scop);
12445 end loop;
12447 -- Collect previous instantiations in the unit that contains
12448 -- the desired generic.
12450 if Nkind (Parent (True_Parent)) /= N_Compilation_Unit
12451 and then not Body_Optional
12452 then
12453 declare
12454 Decl : Elmt_Id;
12455 Info : Pending_Body_Info;
12456 Par : Node_Id;
12458 begin
12459 Par := Parent (Inst_Node);
12460 while Present (Par) loop
12461 exit when Nkind (Parent (Par)) = N_Compilation_Unit;
12462 Par := Parent (Par);
12463 end loop;
12465 pragma Assert (Present (Par));
12467 if Nkind (Par) = N_Package_Body then
12468 Collect_Previous_Instances (Declarations (Par));
12470 elsif Nkind (Par) = N_Package_Declaration then
12471 Collect_Previous_Instances
12472 (Visible_Declarations (Specification (Par)));
12473 Collect_Previous_Instances
12474 (Private_Declarations (Specification (Par)));
12476 else
12477 -- Enclosing unit is a subprogram body. In this
12478 -- case all instance bodies are processed in order
12479 -- and there is no need to collect them separately.
12481 null;
12482 end if;
12484 Decl := First_Elmt (Previous_Instances);
12485 while Present (Decl) loop
12486 Info :=
12487 (Inst_Node => Node (Decl),
12488 Act_Decl =>
12489 Instance_Spec (Node (Decl)),
12490 Expander_Status => Exp_Status,
12491 Current_Sem_Unit =>
12492 Get_Code_Unit (Sloc (Node (Decl))),
12493 Scope_Suppress => Scope_Suppress,
12494 Local_Suppress_Stack_Top =>
12495 Local_Suppress_Stack_Top,
12496 Version => Ada_Version,
12497 Version_Pragma => Ada_Version_Pragma,
12498 Warnings => Save_Warnings,
12499 SPARK_Mode => SPARK_Mode,
12500 SPARK_Mode_Pragma => SPARK_Mode_Pragma);
12502 -- Package instance
12505 Nkind (Node (Decl)) = N_Package_Instantiation
12506 then
12507 Instantiate_Package_Body
12508 (Info, Body_Optional => True);
12510 -- Subprogram instance
12512 else
12513 -- The instance_spec is the wrapper package,
12514 -- and the subprogram declaration is the last
12515 -- declaration in the wrapper.
12517 Info.Act_Decl :=
12518 Last
12519 (Visible_Declarations
12520 (Specification (Info.Act_Decl)));
12522 Instantiate_Subprogram_Body
12523 (Info, Body_Optional => True);
12524 end if;
12526 Next_Elmt (Decl);
12527 end loop;
12528 end;
12529 end if;
12531 Instantiate_Package_Body
12532 (Body_Info =>
12533 ((Inst_Node => Inst_Node,
12534 Act_Decl => True_Parent,
12535 Expander_Status => Exp_Status,
12536 Current_Sem_Unit => Get_Code_Unit
12537 (Sloc (Inst_Node)),
12538 Scope_Suppress => Scope_Suppress,
12539 Local_Suppress_Stack_Top => Local_Suppress_Stack_Top,
12540 Version => Ada_Version,
12541 Version_Pragma => Ada_Version_Pragma,
12542 Warnings => Save_Warnings,
12543 SPARK_Mode => SPARK_Mode,
12544 SPARK_Mode_Pragma => SPARK_Mode_Pragma)),
12545 Body_Optional => Body_Optional);
12546 end;
12547 end if;
12549 -- Case where we are not instantiating a nested generic
12551 else
12552 Opt.Style_Check := False;
12553 Expander_Mode_Save_And_Set (True);
12554 Load_Needed_Body (Comp_Unit, OK);
12555 Opt.Style_Check := Saved_Style_Check;
12556 Restore_Warnings (Saved_Warnings);
12557 Expander_Mode_Restore;
12559 if not OK
12560 and then Unit_Requires_Body (Defining_Entity (Spec))
12561 and then not Body_Optional
12562 then
12563 declare
12564 Bname : constant Unit_Name_Type :=
12565 Get_Body_Name (Get_Unit_Name (Unit (Comp_Unit)));
12567 begin
12568 -- In CodePeer mode, the missing body may make the analysis
12569 -- incomplete, but we do not treat it as fatal.
12571 if CodePeer_Mode then
12572 return;
12574 else
12575 Error_Msg_Unit_1 := Bname;
12576 Error_Msg_N ("this instantiation requires$!", N);
12577 Error_Msg_File_1 :=
12578 Get_File_Name (Bname, Subunit => False);
12579 Error_Msg_N ("\but file{ was not found!", N);
12580 raise Unrecoverable_Error;
12581 end if;
12582 end;
12583 end if;
12584 end if;
12585 end if;
12587 -- If loading parent of the generic caused an instantiation circularity,
12588 -- we abandon compilation at this point, because otherwise in some cases
12589 -- we get into trouble with infinite recursions after this point.
12591 if Circularity_Detected then
12592 raise Unrecoverable_Error;
12593 end if;
12594 end Load_Parent_Of_Generic;
12596 ---------------------------------
12597 -- Map_Formal_Package_Entities --
12598 ---------------------------------
12600 procedure Map_Formal_Package_Entities (Form : Entity_Id; Act : Entity_Id) is
12601 E1 : Entity_Id;
12602 E2 : Entity_Id;
12604 begin
12605 Set_Instance_Of (Form, Act);
12607 -- Traverse formal and actual package to map the corresponding entities.
12608 -- We skip over internal entities that may be generated during semantic
12609 -- analysis, and find the matching entities by name, given that they
12610 -- must appear in the same order.
12612 E1 := First_Entity (Form);
12613 E2 := First_Entity (Act);
12614 while Present (E1) and then E1 /= First_Private_Entity (Form) loop
12615 -- Could this test be a single condition??? Seems like it could, and
12616 -- isn't FPE (Form) a constant anyway???
12618 if not Is_Internal (E1)
12619 and then Present (Parent (E1))
12620 and then not Is_Class_Wide_Type (E1)
12621 and then not Is_Internal_Name (Chars (E1))
12622 then
12623 while Present (E2) and then Chars (E2) /= Chars (E1) loop
12624 Next_Entity (E2);
12625 end loop;
12627 if No (E2) then
12628 exit;
12629 else
12630 Set_Instance_Of (E1, E2);
12632 if Is_Type (E1) and then Is_Tagged_Type (E2) then
12633 Set_Instance_Of (Class_Wide_Type (E1), Class_Wide_Type (E2));
12634 end if;
12636 if Is_Constrained (E1) then
12637 Set_Instance_Of (Base_Type (E1), Base_Type (E2));
12638 end if;
12640 if Ekind (E1) = E_Package and then No (Renamed_Object (E1)) then
12641 Map_Formal_Package_Entities (E1, E2);
12642 end if;
12643 end if;
12644 end if;
12646 Next_Entity (E1);
12647 end loop;
12648 end Map_Formal_Package_Entities;
12650 -----------------------
12651 -- Move_Freeze_Nodes --
12652 -----------------------
12654 procedure Move_Freeze_Nodes
12655 (Out_Of : Entity_Id;
12656 After : Node_Id;
12657 L : List_Id)
12659 Decl : Node_Id;
12660 Next_Decl : Node_Id;
12661 Next_Node : Node_Id := After;
12662 Spec : Node_Id;
12664 function Is_Outer_Type (T : Entity_Id) return Boolean;
12665 -- Check whether entity is declared in a scope external to that of the
12666 -- generic unit.
12668 -------------------
12669 -- Is_Outer_Type --
12670 -------------------
12672 function Is_Outer_Type (T : Entity_Id) return Boolean is
12673 Scop : Entity_Id := Scope (T);
12675 begin
12676 if Scope_Depth (Scop) < Scope_Depth (Out_Of) then
12677 return True;
12679 else
12680 while Scop /= Standard_Standard loop
12681 if Scop = Out_Of then
12682 return False;
12683 else
12684 Scop := Scope (Scop);
12685 end if;
12686 end loop;
12688 return True;
12689 end if;
12690 end Is_Outer_Type;
12692 -- Start of processing for Move_Freeze_Nodes
12694 begin
12695 if No (L) then
12696 return;
12697 end if;
12699 -- First remove the freeze nodes that may appear before all other
12700 -- declarations.
12702 Decl := First (L);
12703 while Present (Decl)
12704 and then Nkind (Decl) = N_Freeze_Entity
12705 and then Is_Outer_Type (Entity (Decl))
12706 loop
12707 Decl := Remove_Head (L);
12708 Insert_After (Next_Node, Decl);
12709 Set_Analyzed (Decl, False);
12710 Next_Node := Decl;
12711 Decl := First (L);
12712 end loop;
12714 -- Next scan the list of declarations and remove each freeze node that
12715 -- appears ahead of the current node.
12717 while Present (Decl) loop
12718 while Present (Next (Decl))
12719 and then Nkind (Next (Decl)) = N_Freeze_Entity
12720 and then Is_Outer_Type (Entity (Next (Decl)))
12721 loop
12722 Next_Decl := Remove_Next (Decl);
12723 Insert_After (Next_Node, Next_Decl);
12724 Set_Analyzed (Next_Decl, False);
12725 Next_Node := Next_Decl;
12726 end loop;
12728 -- If the declaration is a nested package or concurrent type, then
12729 -- recurse. Nested generic packages will have been processed from the
12730 -- inside out.
12732 case Nkind (Decl) is
12733 when N_Package_Declaration =>
12734 Spec := Specification (Decl);
12736 when N_Task_Type_Declaration =>
12737 Spec := Task_Definition (Decl);
12739 when N_Protected_Type_Declaration =>
12740 Spec := Protected_Definition (Decl);
12742 when others =>
12743 Spec := Empty;
12744 end case;
12746 if Present (Spec) then
12747 Move_Freeze_Nodes (Out_Of, Next_Node, Visible_Declarations (Spec));
12748 Move_Freeze_Nodes (Out_Of, Next_Node, Private_Declarations (Spec));
12749 end if;
12751 Next (Decl);
12752 end loop;
12753 end Move_Freeze_Nodes;
12755 ----------------
12756 -- Next_Assoc --
12757 ----------------
12759 function Next_Assoc (E : Assoc_Ptr) return Assoc_Ptr is
12760 begin
12761 return Generic_Renamings.Table (E).Next_In_HTable;
12762 end Next_Assoc;
12764 ------------------------
12765 -- Preanalyze_Actuals --
12766 ------------------------
12768 procedure Preanalyze_Actuals (N : Node_Id) is
12769 Assoc : Node_Id;
12770 Act : Node_Id;
12771 Errs : constant Int := Serious_Errors_Detected;
12773 Cur : Entity_Id := Empty;
12774 -- Current homograph of the instance name
12776 Vis : Boolean;
12777 -- Saved visibility status of the current homograph
12779 begin
12780 Assoc := First (Generic_Associations (N));
12782 -- If the instance is a child unit, its name may hide an outer homonym,
12783 -- so make it invisible to perform name resolution on the actuals.
12785 if Nkind (Defining_Unit_Name (N)) = N_Defining_Program_Unit_Name
12786 and then Present
12787 (Current_Entity (Defining_Identifier (Defining_Unit_Name (N))))
12788 then
12789 Cur := Current_Entity (Defining_Identifier (Defining_Unit_Name (N)));
12791 if Is_Compilation_Unit (Cur) then
12792 Vis := Is_Immediately_Visible (Cur);
12793 Set_Is_Immediately_Visible (Cur, False);
12794 else
12795 Cur := Empty;
12796 end if;
12797 end if;
12799 while Present (Assoc) loop
12800 if Nkind (Assoc) /= N_Others_Choice then
12801 Act := Explicit_Generic_Actual_Parameter (Assoc);
12803 -- Within a nested instantiation, a defaulted actual is an empty
12804 -- association, so nothing to analyze. If the subprogram actual
12805 -- is an attribute, analyze prefix only, because actual is not a
12806 -- complete attribute reference.
12808 -- If actual is an allocator, analyze expression only. The full
12809 -- analysis can generate code, and if instance is a compilation
12810 -- unit we have to wait until the package instance is installed
12811 -- to have a proper place to insert this code.
12813 -- String literals may be operators, but at this point we do not
12814 -- know whether the actual is a formal subprogram or a string.
12816 if No (Act) then
12817 null;
12819 elsif Nkind (Act) = N_Attribute_Reference then
12820 Analyze (Prefix (Act));
12822 elsif Nkind (Act) = N_Explicit_Dereference then
12823 Analyze (Prefix (Act));
12825 elsif Nkind (Act) = N_Allocator then
12826 declare
12827 Expr : constant Node_Id := Expression (Act);
12829 begin
12830 if Nkind (Expr) = N_Subtype_Indication then
12831 Analyze (Subtype_Mark (Expr));
12833 -- Analyze separately each discriminant constraint, when
12834 -- given with a named association.
12836 declare
12837 Constr : Node_Id;
12839 begin
12840 Constr := First (Constraints (Constraint (Expr)));
12841 while Present (Constr) loop
12842 if Nkind (Constr) = N_Discriminant_Association then
12843 Analyze (Expression (Constr));
12844 else
12845 Analyze (Constr);
12846 end if;
12848 Next (Constr);
12849 end loop;
12850 end;
12852 else
12853 Analyze (Expr);
12854 end if;
12855 end;
12857 elsif Nkind (Act) /= N_Operator_Symbol then
12858 Analyze (Act);
12859 end if;
12861 -- Ensure that a ghost subprogram does not act as generic actual
12863 if Is_Entity_Name (Act)
12864 and then Is_Ghost_Subprogram (Entity (Act))
12865 then
12866 Error_Msg_N
12867 ("ghost subprogram & cannot act as generic actual", Act);
12868 Abandon_Instantiation (Act);
12870 elsif Errs /= Serious_Errors_Detected then
12872 -- Do a minimal analysis of the generic, to prevent spurious
12873 -- warnings complaining about the generic being unreferenced,
12874 -- before abandoning the instantiation.
12876 Analyze (Name (N));
12878 if Is_Entity_Name (Name (N))
12879 and then Etype (Name (N)) /= Any_Type
12880 then
12881 Generate_Reference (Entity (Name (N)), Name (N));
12882 Set_Is_Instantiated (Entity (Name (N)));
12883 end if;
12885 if Present (Cur) then
12887 -- For the case of a child instance hiding an outer homonym,
12888 -- provide additional warning which might explain the error.
12890 Set_Is_Immediately_Visible (Cur, Vis);
12891 Error_Msg_NE ("& hides outer unit with the same name??",
12892 N, Defining_Unit_Name (N));
12893 end if;
12895 Abandon_Instantiation (Act);
12896 end if;
12897 end if;
12899 Next (Assoc);
12900 end loop;
12902 if Present (Cur) then
12903 Set_Is_Immediately_Visible (Cur, Vis);
12904 end if;
12905 end Preanalyze_Actuals;
12907 -------------------
12908 -- Remove_Parent --
12909 -------------------
12911 procedure Remove_Parent (In_Body : Boolean := False) is
12912 S : Entity_Id := Current_Scope;
12913 -- S is the scope containing the instantiation just completed. The scope
12914 -- stack contains the parent instances of the instantiation, followed by
12915 -- the original S.
12917 Cur_P : Entity_Id;
12918 E : Entity_Id;
12919 P : Entity_Id;
12920 Hidden : Elmt_Id;
12922 begin
12923 -- After child instantiation is complete, remove from scope stack the
12924 -- extra copy of the current scope, and then remove parent instances.
12926 if not In_Body then
12927 Pop_Scope;
12929 while Current_Scope /= S loop
12930 P := Current_Scope;
12931 End_Package_Scope (Current_Scope);
12933 if In_Open_Scopes (P) then
12934 E := First_Entity (P);
12935 while Present (E) loop
12936 Set_Is_Immediately_Visible (E, True);
12937 Next_Entity (E);
12938 end loop;
12940 -- If instantiation is declared in a block, it is the enclosing
12941 -- scope that might be a parent instance. Note that only one
12942 -- block can be involved, because the parent instances have
12943 -- been installed within it.
12945 if Ekind (P) = E_Block then
12946 Cur_P := Scope (P);
12947 else
12948 Cur_P := P;
12949 end if;
12951 if Is_Generic_Instance (Cur_P) and then P /= Current_Scope then
12952 -- We are within an instance of some sibling. Retain
12953 -- visibility of parent, for proper subsequent cleanup, and
12954 -- reinstall private declarations as well.
12956 Set_In_Private_Part (P);
12957 Install_Private_Declarations (P);
12958 end if;
12960 -- If the ultimate parent is a top-level unit recorded in
12961 -- Instance_Parent_Unit, then reset its visibility to what it was
12962 -- before instantiation. (It's not clear what the purpose is of
12963 -- testing whether Scope (P) is In_Open_Scopes, but that test was
12964 -- present before the ultimate parent test was added.???)
12966 elsif not In_Open_Scopes (Scope (P))
12967 or else (P = Instance_Parent_Unit
12968 and then not Parent_Unit_Visible)
12969 then
12970 Set_Is_Immediately_Visible (P, False);
12972 -- If the current scope is itself an instantiation of a generic
12973 -- nested within P, and we are in the private part of body of this
12974 -- instantiation, restore the full views of P, that were removed
12975 -- in End_Package_Scope above. This obscure case can occur when a
12976 -- subunit of a generic contains an instance of a child unit of
12977 -- its generic parent unit.
12979 elsif S = Current_Scope and then Is_Generic_Instance (S) then
12980 declare
12981 Par : constant Entity_Id :=
12982 Generic_Parent (Package_Specification (S));
12983 begin
12984 if Present (Par)
12985 and then P = Scope (Par)
12986 and then (In_Package_Body (S) or else In_Private_Part (S))
12987 then
12988 Set_In_Private_Part (P);
12989 Install_Private_Declarations (P);
12990 end if;
12991 end;
12992 end if;
12993 end loop;
12995 -- Reset visibility of entities in the enclosing scope
12997 Set_Is_Hidden_Open_Scope (Current_Scope, False);
12999 Hidden := First_Elmt (Hidden_Entities);
13000 while Present (Hidden) loop
13001 Set_Is_Immediately_Visible (Node (Hidden), True);
13002 Next_Elmt (Hidden);
13003 end loop;
13005 else
13006 -- Each body is analyzed separately, and there is no context that
13007 -- needs preserving from one body instance to the next, so remove all
13008 -- parent scopes that have been installed.
13010 while Present (S) loop
13011 End_Package_Scope (S);
13012 Set_Is_Immediately_Visible (S, False);
13013 S := Current_Scope;
13014 exit when S = Standard_Standard;
13015 end loop;
13016 end if;
13017 end Remove_Parent;
13019 -----------------
13020 -- Restore_Env --
13021 -----------------
13023 procedure Restore_Env is
13024 Saved : Instance_Env renames Instance_Envs.Table (Instance_Envs.Last);
13026 begin
13027 if No (Current_Instantiated_Parent.Act_Id) then
13028 -- Restore environment after subprogram inlining
13030 Restore_Private_Views (Empty);
13031 end if;
13033 Current_Instantiated_Parent := Saved.Instantiated_Parent;
13034 Exchanged_Views := Saved.Exchanged_Views;
13035 Hidden_Entities := Saved.Hidden_Entities;
13036 Current_Sem_Unit := Saved.Current_Sem_Unit;
13037 Parent_Unit_Visible := Saved.Parent_Unit_Visible;
13038 Instance_Parent_Unit := Saved.Instance_Parent_Unit;
13040 Restore_Opt_Config_Switches (Saved.Switches);
13042 Instance_Envs.Decrement_Last;
13043 end Restore_Env;
13045 ---------------------------
13046 -- Restore_Private_Views --
13047 ---------------------------
13049 procedure Restore_Private_Views
13050 (Pack_Id : Entity_Id;
13051 Is_Package : Boolean := True)
13053 M : Elmt_Id;
13054 E : Entity_Id;
13055 Typ : Entity_Id;
13056 Dep_Elmt : Elmt_Id;
13057 Dep_Typ : Node_Id;
13059 procedure Restore_Nested_Formal (Formal : Entity_Id);
13060 -- Hide the generic formals of formal packages declared with box which
13061 -- were reachable in the current instantiation.
13063 ---------------------------
13064 -- Restore_Nested_Formal --
13065 ---------------------------
13067 procedure Restore_Nested_Formal (Formal : Entity_Id) is
13068 Ent : Entity_Id;
13070 begin
13071 if Present (Renamed_Object (Formal))
13072 and then Denotes_Formal_Package (Renamed_Object (Formal), True)
13073 then
13074 return;
13076 elsif Present (Associated_Formal_Package (Formal)) then
13077 Ent := First_Entity (Formal);
13078 while Present (Ent) loop
13079 exit when Ekind (Ent) = E_Package
13080 and then Renamed_Entity (Ent) = Renamed_Entity (Formal);
13082 Set_Is_Hidden (Ent);
13083 Set_Is_Potentially_Use_Visible (Ent, False);
13085 -- If package, then recurse
13087 if Ekind (Ent) = E_Package then
13088 Restore_Nested_Formal (Ent);
13089 end if;
13091 Next_Entity (Ent);
13092 end loop;
13093 end if;
13094 end Restore_Nested_Formal;
13096 -- Start of processing for Restore_Private_Views
13098 begin
13099 M := First_Elmt (Exchanged_Views);
13100 while Present (M) loop
13101 Typ := Node (M);
13103 -- Subtypes of types whose views have been exchanged, and that are
13104 -- defined within the instance, were not on the Private_Dependents
13105 -- list on entry to the instance, so they have to be exchanged
13106 -- explicitly now, in order to remain consistent with the view of the
13107 -- parent type.
13109 if Ekind_In (Typ, E_Private_Type,
13110 E_Limited_Private_Type,
13111 E_Record_Type_With_Private)
13112 then
13113 Dep_Elmt := First_Elmt (Private_Dependents (Typ));
13114 while Present (Dep_Elmt) loop
13115 Dep_Typ := Node (Dep_Elmt);
13117 if Scope (Dep_Typ) = Pack_Id
13118 and then Present (Full_View (Dep_Typ))
13119 then
13120 Replace_Elmt (Dep_Elmt, Full_View (Dep_Typ));
13121 Exchange_Declarations (Dep_Typ);
13122 end if;
13124 Next_Elmt (Dep_Elmt);
13125 end loop;
13126 end if;
13128 Exchange_Declarations (Node (M));
13129 Next_Elmt (M);
13130 end loop;
13132 if No (Pack_Id) then
13133 return;
13134 end if;
13136 -- Make the generic formal parameters private, and make the formal types
13137 -- into subtypes of the actuals again.
13139 E := First_Entity (Pack_Id);
13140 while Present (E) loop
13141 Set_Is_Hidden (E, True);
13143 if Is_Type (E)
13144 and then Nkind (Parent (E)) = N_Subtype_Declaration
13145 then
13146 -- If the actual for E is itself a generic actual type from
13147 -- an enclosing instance, E is still a generic actual type
13148 -- outside of the current instance. This matter when resolving
13149 -- an overloaded call that may be ambiguous in the enclosing
13150 -- instance, when two of its actuals coincide.
13152 if Is_Entity_Name (Subtype_Indication (Parent (E)))
13153 and then Is_Generic_Actual_Type
13154 (Entity (Subtype_Indication (Parent (E))))
13155 then
13156 null;
13157 else
13158 Set_Is_Generic_Actual_Type (E, False);
13159 end if;
13161 -- An unusual case of aliasing: the actual may also be directly
13162 -- visible in the generic, and be private there, while it is fully
13163 -- visible in the context of the instance. The internal subtype
13164 -- is private in the instance but has full visibility like its
13165 -- parent in the enclosing scope. This enforces the invariant that
13166 -- the privacy status of all private dependents of a type coincide
13167 -- with that of the parent type. This can only happen when a
13168 -- generic child unit is instantiated within a sibling.
13170 if Is_Private_Type (E)
13171 and then not Is_Private_Type (Etype (E))
13172 then
13173 Exchange_Declarations (E);
13174 end if;
13176 elsif Ekind (E) = E_Package then
13178 -- The end of the renaming list is the renaming of the generic
13179 -- package itself. If the instance is a subprogram, all entities
13180 -- in the corresponding package are renamings. If this entity is
13181 -- a formal package, make its own formals private as well. The
13182 -- actual in this case is itself the renaming of an instantiation.
13183 -- If the entity is not a package renaming, it is the entity
13184 -- created to validate formal package actuals: ignore it.
13186 -- If the actual is itself a formal package for the enclosing
13187 -- generic, or the actual for such a formal package, it remains
13188 -- visible on exit from the instance, and therefore nothing needs
13189 -- to be done either, except to keep it accessible.
13191 if Is_Package and then Renamed_Object (E) = Pack_Id then
13192 exit;
13194 elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then
13195 null;
13197 elsif
13198 Denotes_Formal_Package (Renamed_Object (E), True, Pack_Id)
13199 then
13200 Set_Is_Hidden (E, False);
13202 else
13203 declare
13204 Act_P : constant Entity_Id := Renamed_Object (E);
13205 Id : Entity_Id;
13207 begin
13208 Id := First_Entity (Act_P);
13209 while Present (Id)
13210 and then Id /= First_Private_Entity (Act_P)
13211 loop
13212 exit when Ekind (Id) = E_Package
13213 and then Renamed_Object (Id) = Act_P;
13215 Set_Is_Hidden (Id, True);
13216 Set_Is_Potentially_Use_Visible (Id, In_Use (Act_P));
13218 if Ekind (Id) = E_Package then
13219 Restore_Nested_Formal (Id);
13220 end if;
13222 Next_Entity (Id);
13223 end loop;
13224 end;
13225 end if;
13226 end if;
13228 Next_Entity (E);
13229 end loop;
13230 end Restore_Private_Views;
13232 --------------
13233 -- Save_Env --
13234 --------------
13236 procedure Save_Env
13237 (Gen_Unit : Entity_Id;
13238 Act_Unit : Entity_Id)
13240 begin
13241 Init_Env;
13242 Set_Instance_Env (Gen_Unit, Act_Unit);
13243 end Save_Env;
13245 ----------------------------
13246 -- Save_Global_References --
13247 ----------------------------
13249 procedure Save_Global_References (N : Node_Id) is
13250 Gen_Scope : Entity_Id;
13251 E : Entity_Id;
13252 N2 : Node_Id;
13254 function Is_Global (E : Entity_Id) return Boolean;
13255 -- Check whether entity is defined outside of generic unit. Examine the
13256 -- scope of an entity, and the scope of the scope, etc, until we find
13257 -- either Standard, in which case the entity is global, or the generic
13258 -- unit itself, which indicates that the entity is local. If the entity
13259 -- is the generic unit itself, as in the case of a recursive call, or
13260 -- the enclosing generic unit, if different from the current scope, then
13261 -- it is local as well, because it will be replaced at the point of
13262 -- instantiation. On the other hand, if it is a reference to a child
13263 -- unit of a common ancestor, which appears in an instantiation, it is
13264 -- global because it is used to denote a specific compilation unit at
13265 -- the time the instantiations will be analyzed.
13267 procedure Reset_Entity (N : Node_Id);
13268 -- Save semantic information on global entity so that it is not resolved
13269 -- again at instantiation time.
13271 procedure Save_Entity_Descendants (N : Node_Id);
13272 -- Apply Save_Global_References to the two syntactic descendants of
13273 -- non-terminal nodes that carry an Associated_Node and are processed
13274 -- through Reset_Entity. Once the global entity (if any) has been
13275 -- captured together with its type, only two syntactic descendants need
13276 -- to be traversed to complete the processing of the tree rooted at N.
13277 -- This applies to Selected_Components, Expanded_Names, and to Operator
13278 -- nodes. N can also be a character literal, identifier, or operator
13279 -- symbol node, but the call has no effect in these cases.
13281 procedure Save_Global_Defaults (N1, N2 : Node_Id);
13282 -- Default actuals in nested instances must be handled specially
13283 -- because there is no link to them from the original tree. When an
13284 -- actual subprogram is given by a default, we add an explicit generic
13285 -- association for it in the instantiation node. When we save the
13286 -- global references on the name of the instance, we recover the list
13287 -- of generic associations, and add an explicit one to the original
13288 -- generic tree, through which a global actual can be preserved.
13289 -- Similarly, if a child unit is instantiated within a sibling, in the
13290 -- context of the parent, we must preserve the identifier of the parent
13291 -- so that it can be properly resolved in a subsequent instantiation.
13293 procedure Save_Global_Descendant (D : Union_Id);
13294 -- Apply Save_Global_References recursively to the descendents of the
13295 -- current node.
13297 procedure Save_References (N : Node_Id);
13298 -- This is the recursive procedure that does the work, once the
13299 -- enclosing generic scope has been established.
13301 ---------------
13302 -- Is_Global --
13303 ---------------
13305 function Is_Global (E : Entity_Id) return Boolean is
13306 Se : Entity_Id;
13308 function Is_Instance_Node (Decl : Node_Id) return Boolean;
13309 -- Determine whether the parent node of a reference to a child unit
13310 -- denotes an instantiation or a formal package, in which case the
13311 -- reference to the child unit is global, even if it appears within
13312 -- the current scope (e.g. when the instance appears within the body
13313 -- of an ancestor).
13315 ----------------------
13316 -- Is_Instance_Node --
13317 ----------------------
13319 function Is_Instance_Node (Decl : Node_Id) return Boolean is
13320 begin
13321 return Nkind (Decl) in N_Generic_Instantiation
13322 or else
13323 Nkind (Original_Node (Decl)) = N_Formal_Package_Declaration;
13324 end Is_Instance_Node;
13326 -- Start of processing for Is_Global
13328 begin
13329 if E = Gen_Scope then
13330 return False;
13332 elsif E = Standard_Standard then
13333 return True;
13335 elsif Is_Child_Unit (E)
13336 and then (Is_Instance_Node (Parent (N2))
13337 or else (Nkind (Parent (N2)) = N_Expanded_Name
13338 and then N2 = Selector_Name (Parent (N2))
13339 and then
13340 Is_Instance_Node (Parent (Parent (N2)))))
13341 then
13342 return True;
13344 else
13345 Se := Scope (E);
13346 while Se /= Gen_Scope loop
13347 if Se = Standard_Standard then
13348 return True;
13349 else
13350 Se := Scope (Se);
13351 end if;
13352 end loop;
13354 return False;
13355 end if;
13356 end Is_Global;
13358 ------------------
13359 -- Reset_Entity --
13360 ------------------
13362 procedure Reset_Entity (N : Node_Id) is
13364 procedure Set_Global_Type (N : Node_Id; N2 : Node_Id);
13365 -- If the type of N2 is global to the generic unit, save the type in
13366 -- the generic node. Just as we perform name capture for explicit
13367 -- references within the generic, we must capture the global types
13368 -- of local entities because they may participate in resolution in
13369 -- the instance.
13371 function Top_Ancestor (E : Entity_Id) return Entity_Id;
13372 -- Find the ultimate ancestor of the current unit. If it is not a
13373 -- generic unit, then the name of the current unit in the prefix of
13374 -- an expanded name must be replaced with its generic homonym to
13375 -- ensure that it will be properly resolved in an instance.
13377 ---------------------
13378 -- Set_Global_Type --
13379 ---------------------
13381 procedure Set_Global_Type (N : Node_Id; N2 : Node_Id) is
13382 Typ : constant Entity_Id := Etype (N2);
13384 begin
13385 Set_Etype (N, Typ);
13387 if Entity (N) /= N2
13388 and then Has_Private_View (Entity (N))
13389 then
13390 -- If the entity of N is not the associated node, this is a
13391 -- nested generic and it has an associated node as well, whose
13392 -- type is already the full view (see below). Indicate that the
13393 -- original node has a private view.
13395 Set_Has_Private_View (N);
13396 end if;
13398 -- If not a private type, nothing else to do
13400 if not Is_Private_Type (Typ) then
13401 if Is_Array_Type (Typ)
13402 and then Is_Private_Type (Component_Type (Typ))
13403 then
13404 Set_Has_Private_View (N);
13405 end if;
13407 -- If it is a derivation of a private type in a context where no
13408 -- full view is needed, nothing to do either.
13410 elsif No (Full_View (Typ)) and then Typ /= Etype (Typ) then
13411 null;
13413 -- Otherwise mark the type for flipping and use the full view when
13414 -- available.
13416 else
13417 Set_Has_Private_View (N);
13419 if Present (Full_View (Typ)) then
13420 Set_Etype (N2, Full_View (Typ));
13421 end if;
13422 end if;
13423 end Set_Global_Type;
13425 ------------------
13426 -- Top_Ancestor --
13427 ------------------
13429 function Top_Ancestor (E : Entity_Id) return Entity_Id is
13430 Par : Entity_Id;
13432 begin
13433 Par := E;
13434 while Is_Child_Unit (Par) loop
13435 Par := Scope (Par);
13436 end loop;
13438 return Par;
13439 end Top_Ancestor;
13441 -- Start of processing for Reset_Entity
13443 begin
13444 N2 := Get_Associated_Node (N);
13445 E := Entity (N2);
13447 if Present (E) then
13449 -- If the node is an entry call to an entry in an enclosing task,
13450 -- it is rewritten as a selected component. No global entity to
13451 -- preserve in this case, since the expansion will be redone in
13452 -- the instance.
13454 if not Nkind_In (E, N_Defining_Identifier,
13455 N_Defining_Character_Literal,
13456 N_Defining_Operator_Symbol)
13457 then
13458 Set_Associated_Node (N, Empty);
13459 Set_Etype (N, Empty);
13460 return;
13461 end if;
13463 -- If the entity is an itype created as a subtype of an access
13464 -- type with a null exclusion restore source entity for proper
13465 -- visibility. The itype will be created anew in the instance.
13467 if Is_Itype (E)
13468 and then Ekind (E) = E_Access_Subtype
13469 and then Is_Entity_Name (N)
13470 and then Chars (Etype (E)) = Chars (N)
13471 then
13472 E := Etype (E);
13473 Set_Entity (N2, E);
13474 Set_Etype (N2, E);
13475 end if;
13477 if Is_Global (E) then
13479 -- If the entity is a package renaming that is the prefix of
13480 -- an expanded name, it has been rewritten as the renamed
13481 -- package, which is necessary semantically but complicates
13482 -- ASIS tree traversal, so we recover the original entity to
13483 -- expose the renaming. Take into account that the context may
13484 -- be a nested generic, that the original node may itself have
13485 -- an associated node that had better be an entity, and that
13486 -- the current node is still a selected component.
13488 if Ekind (E) = E_Package
13489 and then Nkind (N) = N_Selected_Component
13490 and then Nkind (Parent (N)) = N_Expanded_Name
13491 and then Present (Original_Node (N2))
13492 and then Is_Entity_Name (Original_Node (N2))
13493 and then Present (Entity (Original_Node (N2)))
13494 then
13495 if Is_Global (Entity (Original_Node (N2))) then
13496 N2 := Original_Node (N2);
13497 Set_Associated_Node (N, N2);
13498 Set_Global_Type (N, N2);
13500 else
13501 -- Renaming is local, and will be resolved in instance
13503 Set_Associated_Node (N, Empty);
13504 Set_Etype (N, Empty);
13505 end if;
13507 else
13508 Set_Global_Type (N, N2);
13509 end if;
13511 elsif Nkind (N) = N_Op_Concat
13512 and then Is_Generic_Type (Etype (N2))
13513 and then (Base_Type (Etype (Right_Opnd (N2))) = Etype (N2)
13514 or else
13515 Base_Type (Etype (Left_Opnd (N2))) = Etype (N2))
13516 and then Is_Intrinsic_Subprogram (E)
13517 then
13518 null;
13520 else
13521 -- Entity is local. Mark generic node as unresolved.
13522 -- Note that now it does not have an entity.
13524 Set_Associated_Node (N, Empty);
13525 Set_Etype (N, Empty);
13526 end if;
13528 if Nkind (Parent (N)) in N_Generic_Instantiation
13529 and then N = Name (Parent (N))
13530 then
13531 Save_Global_Defaults (Parent (N), Parent (N2));
13532 end if;
13534 elsif Nkind (Parent (N)) = N_Selected_Component
13535 and then Nkind (Parent (N2)) = N_Expanded_Name
13536 then
13537 if Is_Global (Entity (Parent (N2))) then
13538 Change_Selected_Component_To_Expanded_Name (Parent (N));
13539 Set_Associated_Node (Parent (N), Parent (N2));
13540 Set_Global_Type (Parent (N), Parent (N2));
13541 Save_Entity_Descendants (N);
13543 -- If this is a reference to the current generic entity, replace
13544 -- by the name of the generic homonym of the current package. This
13545 -- is because in an instantiation Par.P.Q will not resolve to the
13546 -- name of the instance, whose enclosing scope is not necessarily
13547 -- Par. We use the generic homonym rather that the name of the
13548 -- generic itself because it may be hidden by a local declaration.
13550 elsif In_Open_Scopes (Entity (Parent (N2)))
13551 and then not
13552 Is_Generic_Unit (Top_Ancestor (Entity (Prefix (Parent (N2)))))
13553 then
13554 if Ekind (Entity (Parent (N2))) = E_Generic_Package then
13555 Rewrite (Parent (N),
13556 Make_Identifier (Sloc (N),
13557 Chars =>
13558 Chars (Generic_Homonym (Entity (Parent (N2))))));
13559 else
13560 Rewrite (Parent (N),
13561 Make_Identifier (Sloc (N),
13562 Chars => Chars (Selector_Name (Parent (N2)))));
13563 end if;
13564 end if;
13566 if Nkind (Parent (Parent (N))) in N_Generic_Instantiation
13567 and then Parent (N) = Name (Parent (Parent (N)))
13568 then
13569 Save_Global_Defaults
13570 (Parent (Parent (N)), Parent (Parent ((N2))));
13571 end if;
13573 -- A selected component may denote a static constant that has been
13574 -- folded. If the static constant is global to the generic, capture
13575 -- its value. Otherwise the folding will happen in any instantiation.
13577 elsif Nkind (Parent (N)) = N_Selected_Component
13578 and then Nkind_In (Parent (N2), N_Integer_Literal, N_Real_Literal)
13579 then
13580 if Present (Entity (Original_Node (Parent (N2))))
13581 and then Is_Global (Entity (Original_Node (Parent (N2))))
13582 then
13583 Rewrite (Parent (N), New_Copy (Parent (N2)));
13584 Set_Analyzed (Parent (N), False);
13586 else
13587 null;
13588 end if;
13590 -- A selected component may be transformed into a parameterless
13591 -- function call. If the called entity is global, rewrite the node
13592 -- appropriately, i.e. as an extended name for the global entity.
13594 elsif Nkind (Parent (N)) = N_Selected_Component
13595 and then Nkind (Parent (N2)) = N_Function_Call
13596 and then N = Selector_Name (Parent (N))
13597 then
13598 if No (Parameter_Associations (Parent (N2))) then
13599 if Is_Global (Entity (Name (Parent (N2)))) then
13600 Change_Selected_Component_To_Expanded_Name (Parent (N));
13601 Set_Associated_Node (Parent (N), Name (Parent (N2)));
13602 Set_Global_Type (Parent (N), Name (Parent (N2)));
13603 Save_Entity_Descendants (N);
13605 else
13606 Set_Is_Prefixed_Call (Parent (N));
13607 Set_Associated_Node (N, Empty);
13608 Set_Etype (N, Empty);
13609 end if;
13611 -- In Ada 2005, X.F may be a call to a primitive operation,
13612 -- rewritten as F (X). This rewriting will be done again in an
13613 -- instance, so keep the original node. Global entities will be
13614 -- captured as for other constructs. Indicate that this must
13615 -- resolve as a call, to prevent accidental overloading in the
13616 -- instance, if both a component and a primitive operation appear
13617 -- as candidates.
13619 else
13620 Set_Is_Prefixed_Call (Parent (N));
13621 end if;
13623 -- Entity is local. Reset in generic unit, so that node is resolved
13624 -- anew at the point of instantiation.
13626 else
13627 Set_Associated_Node (N, Empty);
13628 Set_Etype (N, Empty);
13629 end if;
13630 end Reset_Entity;
13632 -----------------------------
13633 -- Save_Entity_Descendants --
13634 -----------------------------
13636 procedure Save_Entity_Descendants (N : Node_Id) is
13637 begin
13638 case Nkind (N) is
13639 when N_Binary_Op =>
13640 Save_Global_Descendant (Union_Id (Left_Opnd (N)));
13641 Save_Global_Descendant (Union_Id (Right_Opnd (N)));
13643 when N_Unary_Op =>
13644 Save_Global_Descendant (Union_Id (Right_Opnd (N)));
13646 when N_Expanded_Name | N_Selected_Component =>
13647 Save_Global_Descendant (Union_Id (Prefix (N)));
13648 Save_Global_Descendant (Union_Id (Selector_Name (N)));
13650 when N_Identifier | N_Character_Literal | N_Operator_Symbol =>
13651 null;
13653 when others =>
13654 raise Program_Error;
13655 end case;
13656 end Save_Entity_Descendants;
13658 --------------------------
13659 -- Save_Global_Defaults --
13660 --------------------------
13662 procedure Save_Global_Defaults (N1, N2 : Node_Id) is
13663 Loc : constant Source_Ptr := Sloc (N1);
13664 Assoc2 : constant List_Id := Generic_Associations (N2);
13665 Gen_Id : constant Entity_Id := Get_Generic_Entity (N2);
13666 Assoc1 : List_Id;
13667 Act1 : Node_Id;
13668 Act2 : Node_Id;
13669 Def : Node_Id;
13670 Ndec : Node_Id;
13671 Subp : Entity_Id;
13672 Actual : Entity_Id;
13674 begin
13675 Assoc1 := Generic_Associations (N1);
13677 if Present (Assoc1) then
13678 Act1 := First (Assoc1);
13679 else
13680 Act1 := Empty;
13681 Set_Generic_Associations (N1, New_List);
13682 Assoc1 := Generic_Associations (N1);
13683 end if;
13685 if Present (Assoc2) then
13686 Act2 := First (Assoc2);
13687 else
13688 return;
13689 end if;
13691 while Present (Act1) and then Present (Act2) loop
13692 Next (Act1);
13693 Next (Act2);
13694 end loop;
13696 -- Find the associations added for default subprograms
13698 if Present (Act2) then
13699 while Nkind (Act2) /= N_Generic_Association
13700 or else No (Entity (Selector_Name (Act2)))
13701 or else not Is_Overloadable (Entity (Selector_Name (Act2)))
13702 loop
13703 Next (Act2);
13704 end loop;
13706 -- Add a similar association if the default is global. The
13707 -- renaming declaration for the actual has been analyzed, and
13708 -- its alias is the program it renames. Link the actual in the
13709 -- original generic tree with the node in the analyzed tree.
13711 while Present (Act2) loop
13712 Subp := Entity (Selector_Name (Act2));
13713 Def := Explicit_Generic_Actual_Parameter (Act2);
13715 -- Following test is defence against rubbish errors
13717 if No (Alias (Subp)) then
13718 return;
13719 end if;
13721 -- Retrieve the resolved actual from the renaming declaration
13722 -- created for the instantiated formal.
13724 Actual := Entity (Name (Parent (Parent (Subp))));
13725 Set_Entity (Def, Actual);
13726 Set_Etype (Def, Etype (Actual));
13728 if Is_Global (Actual) then
13729 Ndec :=
13730 Make_Generic_Association (Loc,
13731 Selector_Name => New_Occurrence_Of (Subp, Loc),
13732 Explicit_Generic_Actual_Parameter =>
13733 New_Occurrence_Of (Actual, Loc));
13735 Set_Associated_Node
13736 (Explicit_Generic_Actual_Parameter (Ndec), Def);
13738 Append (Ndec, Assoc1);
13740 -- If there are other defaults, add a dummy association in case
13741 -- there are other defaulted formals with the same name.
13743 elsif Present (Next (Act2)) then
13744 Ndec :=
13745 Make_Generic_Association (Loc,
13746 Selector_Name => New_Occurrence_Of (Subp, Loc),
13747 Explicit_Generic_Actual_Parameter => Empty);
13749 Append (Ndec, Assoc1);
13750 end if;
13752 Next (Act2);
13753 end loop;
13754 end if;
13756 if Nkind (Name (N1)) = N_Identifier
13757 and then Is_Child_Unit (Gen_Id)
13758 and then Is_Global (Gen_Id)
13759 and then Is_Generic_Unit (Scope (Gen_Id))
13760 and then In_Open_Scopes (Scope (Gen_Id))
13761 then
13762 -- This is an instantiation of a child unit within a sibling, so
13763 -- that the generic parent is in scope. An eventual instance must
13764 -- occur within the scope of an instance of the parent. Make name
13765 -- in instance into an expanded name, to preserve the identifier
13766 -- of the parent, so it can be resolved subsequently.
13768 Rewrite (Name (N2),
13769 Make_Expanded_Name (Loc,
13770 Chars => Chars (Gen_Id),
13771 Prefix => New_Occurrence_Of (Scope (Gen_Id), Loc),
13772 Selector_Name => New_Occurrence_Of (Gen_Id, Loc)));
13773 Set_Entity (Name (N2), Gen_Id);
13775 Rewrite (Name (N1),
13776 Make_Expanded_Name (Loc,
13777 Chars => Chars (Gen_Id),
13778 Prefix => New_Occurrence_Of (Scope (Gen_Id), Loc),
13779 Selector_Name => New_Occurrence_Of (Gen_Id, Loc)));
13781 Set_Associated_Node (Name (N1), Name (N2));
13782 Set_Associated_Node (Prefix (Name (N1)), Empty);
13783 Set_Associated_Node
13784 (Selector_Name (Name (N1)), Selector_Name (Name (N2)));
13785 Set_Etype (Name (N1), Etype (Gen_Id));
13786 end if;
13788 end Save_Global_Defaults;
13790 ----------------------------
13791 -- Save_Global_Descendant --
13792 ----------------------------
13794 procedure Save_Global_Descendant (D : Union_Id) is
13795 N1 : Node_Id;
13797 begin
13798 if D in Node_Range then
13799 if D = Union_Id (Empty) then
13800 null;
13802 elsif Nkind (Node_Id (D)) /= N_Compilation_Unit then
13803 Save_References (Node_Id (D));
13804 end if;
13806 elsif D in List_Range then
13807 if D = Union_Id (No_List)
13808 or else Is_Empty_List (List_Id (D))
13809 then
13810 null;
13812 else
13813 N1 := First (List_Id (D));
13814 while Present (N1) loop
13815 Save_References (N1);
13816 Next (N1);
13817 end loop;
13818 end if;
13820 -- Element list or other non-node field, nothing to do
13822 else
13823 null;
13824 end if;
13825 end Save_Global_Descendant;
13827 ---------------------
13828 -- Save_References --
13829 ---------------------
13831 -- This is the recursive procedure that does the work once the enclosing
13832 -- generic scope has been established. We have to treat specially a
13833 -- number of node rewritings that are required by semantic processing
13834 -- and which change the kind of nodes in the generic copy: typically
13835 -- constant-folding, replacing an operator node by a string literal, or
13836 -- a selected component by an expanded name. In each of those cases, the
13837 -- transformation is propagated to the generic unit.
13839 procedure Save_References (N : Node_Id) is
13840 Loc : constant Source_Ptr := Sloc (N);
13842 begin
13843 if N = Empty then
13844 null;
13846 elsif Nkind_In (N, N_Character_Literal, N_Operator_Symbol) then
13847 if Nkind (N) = Nkind (Get_Associated_Node (N)) then
13848 Reset_Entity (N);
13850 elsif Nkind (N) = N_Operator_Symbol
13851 and then Nkind (Get_Associated_Node (N)) = N_String_Literal
13852 then
13853 Change_Operator_Symbol_To_String_Literal (N);
13854 end if;
13856 elsif Nkind (N) in N_Op then
13857 if Nkind (N) = Nkind (Get_Associated_Node (N)) then
13858 if Nkind (N) = N_Op_Concat then
13859 Set_Is_Component_Left_Opnd (N,
13860 Is_Component_Left_Opnd (Get_Associated_Node (N)));
13862 Set_Is_Component_Right_Opnd (N,
13863 Is_Component_Right_Opnd (Get_Associated_Node (N)));
13864 end if;
13866 Reset_Entity (N);
13868 else
13869 -- Node may be transformed into call to a user-defined operator
13871 N2 := Get_Associated_Node (N);
13873 if Nkind (N2) = N_Function_Call then
13874 E := Entity (Name (N2));
13876 if Present (E)
13877 and then Is_Global (E)
13878 then
13879 Set_Etype (N, Etype (N2));
13880 else
13881 Set_Associated_Node (N, Empty);
13882 Set_Etype (N, Empty);
13883 end if;
13885 elsif Nkind_In (N2, N_Integer_Literal,
13886 N_Real_Literal,
13887 N_String_Literal)
13888 then
13889 if Present (Original_Node (N2))
13890 and then Nkind (Original_Node (N2)) = Nkind (N)
13891 then
13893 -- Operation was constant-folded. Whenever possible,
13894 -- recover semantic information from unfolded node,
13895 -- for ASIS use.
13897 Set_Associated_Node (N, Original_Node (N2));
13899 if Nkind (N) = N_Op_Concat then
13900 Set_Is_Component_Left_Opnd (N,
13901 Is_Component_Left_Opnd (Get_Associated_Node (N)));
13902 Set_Is_Component_Right_Opnd (N,
13903 Is_Component_Right_Opnd (Get_Associated_Node (N)));
13904 end if;
13906 Reset_Entity (N);
13908 else
13909 -- If original node is already modified, propagate
13910 -- constant-folding to template.
13912 Rewrite (N, New_Copy (N2));
13913 Set_Analyzed (N, False);
13914 end if;
13916 elsif Nkind (N2) = N_Identifier
13917 and then Ekind (Entity (N2)) = E_Enumeration_Literal
13918 then
13919 -- Same if call was folded into a literal, but in this case
13920 -- retain the entity to avoid spurious ambiguities if it is
13921 -- overloaded at the point of instantiation or inlining.
13923 Rewrite (N, New_Copy (N2));
13924 Set_Analyzed (N, False);
13925 end if;
13926 end if;
13928 -- Complete operands check if node has not been constant-folded
13930 if Nkind (N) in N_Op then
13931 Save_Entity_Descendants (N);
13932 end if;
13934 elsif Nkind (N) = N_Identifier then
13935 if Nkind (N) = Nkind (Get_Associated_Node (N)) then
13937 -- If this is a discriminant reference, always save it. It is
13938 -- used in the instance to find the corresponding discriminant
13939 -- positionally rather than by name.
13941 Set_Original_Discriminant
13942 (N, Original_Discriminant (Get_Associated_Node (N)));
13943 Reset_Entity (N);
13945 else
13946 N2 := Get_Associated_Node (N);
13948 if Nkind (N2) = N_Function_Call then
13949 E := Entity (Name (N2));
13951 -- Name resolves to a call to parameterless function. If
13952 -- original entity is global, mark node as resolved.
13954 if Present (E)
13955 and then Is_Global (E)
13956 then
13957 Set_Etype (N, Etype (N2));
13958 else
13959 Set_Associated_Node (N, Empty);
13960 Set_Etype (N, Empty);
13961 end if;
13963 elsif Nkind_In (N2, N_Integer_Literal, N_Real_Literal)
13964 and then Is_Entity_Name (Original_Node (N2))
13965 then
13966 -- Name resolves to named number that is constant-folded,
13967 -- We must preserve the original name for ASIS use, and
13968 -- undo the constant-folding, which will be repeated in
13969 -- each instance.
13971 Set_Associated_Node (N, Original_Node (N2));
13972 Reset_Entity (N);
13974 elsif Nkind (N2) = N_String_Literal then
13976 -- Name resolves to string literal. Perform the same
13977 -- replacement in generic.
13979 Rewrite (N, New_Copy (N2));
13981 elsif Nkind (N2) = N_Explicit_Dereference then
13983 -- An identifier is rewritten as a dereference if it is the
13984 -- prefix in an implicit dereference (call or attribute).
13985 -- The analysis of an instantiation will expand the node
13986 -- again, so we preserve the original tree but link it to
13987 -- the resolved entity in case it is global.
13989 if Is_Entity_Name (Prefix (N2))
13990 and then Present (Entity (Prefix (N2)))
13991 and then Is_Global (Entity (Prefix (N2)))
13992 then
13993 Set_Associated_Node (N, Prefix (N2));
13995 elsif Nkind (Prefix (N2)) = N_Function_Call
13996 and then Is_Global (Entity (Name (Prefix (N2))))
13997 then
13998 Rewrite (N,
13999 Make_Explicit_Dereference (Loc,
14000 Prefix => Make_Function_Call (Loc,
14001 Name =>
14002 New_Occurrence_Of (Entity (Name (Prefix (N2))),
14003 Loc))));
14005 else
14006 Set_Associated_Node (N, Empty);
14007 Set_Etype (N, Empty);
14008 end if;
14010 -- The subtype mark of a nominally unconstrained object is
14011 -- rewritten as a subtype indication using the bounds of the
14012 -- expression. Recover the original subtype mark.
14014 elsif Nkind (N2) = N_Subtype_Indication
14015 and then Is_Entity_Name (Original_Node (N2))
14016 then
14017 Set_Associated_Node (N, Original_Node (N2));
14018 Reset_Entity (N);
14020 else
14021 null;
14022 end if;
14023 end if;
14025 elsif Nkind (N) in N_Entity then
14026 null;
14028 else
14029 declare
14030 Qual : Node_Id := Empty;
14031 Typ : Entity_Id := Empty;
14032 Nam : Node_Id;
14034 use Atree.Unchecked_Access;
14035 -- This code section is part of implementing an untyped tree
14036 -- traversal, so it needs direct access to node fields.
14038 begin
14039 if Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then
14040 N2 := Get_Associated_Node (N);
14042 if No (N2) then
14043 Typ := Empty;
14044 else
14045 Typ := Etype (N2);
14047 -- In an instance within a generic, use the name of the
14048 -- actual and not the original generic parameter. If the
14049 -- actual is global in the current generic it must be
14050 -- preserved for its instantiation.
14052 if Nkind (Parent (Typ)) = N_Subtype_Declaration
14053 and then
14054 Present (Generic_Parent_Type (Parent (Typ)))
14055 then
14056 Typ := Base_Type (Typ);
14057 Set_Etype (N2, Typ);
14058 end if;
14059 end if;
14061 if No (N2)
14062 or else No (Typ)
14063 or else not Is_Global (Typ)
14064 then
14065 Set_Associated_Node (N, Empty);
14067 -- If the aggregate is an actual in a call, it has been
14068 -- resolved in the current context, to some local type.
14069 -- The enclosing call may have been disambiguated by the
14070 -- aggregate, and this disambiguation might fail at
14071 -- instantiation time because the type to which the
14072 -- aggregate did resolve is not preserved. In order to
14073 -- preserve some of this information, we wrap the
14074 -- aggregate in a qualified expression, using the id of
14075 -- its type. For further disambiguation we qualify the
14076 -- type name with its scope (if visible) because both
14077 -- id's will have corresponding entities in an instance.
14078 -- This resolves most of the problems with missing type
14079 -- information on aggregates in instances.
14081 if Nkind (N2) = Nkind (N)
14082 and then Nkind (Parent (N2)) in N_Subprogram_Call
14083 and then Comes_From_Source (Typ)
14084 then
14085 if Is_Immediately_Visible (Scope (Typ)) then
14086 Nam := Make_Selected_Component (Loc,
14087 Prefix =>
14088 Make_Identifier (Loc, Chars (Scope (Typ))),
14089 Selector_Name =>
14090 Make_Identifier (Loc, Chars (Typ)));
14091 else
14092 Nam := Make_Identifier (Loc, Chars (Typ));
14093 end if;
14095 Qual :=
14096 Make_Qualified_Expression (Loc,
14097 Subtype_Mark => Nam,
14098 Expression => Relocate_Node (N));
14099 end if;
14100 end if;
14102 Save_Global_Descendant (Field1 (N));
14103 Save_Global_Descendant (Field2 (N));
14104 Save_Global_Descendant (Field3 (N));
14105 Save_Global_Descendant (Field5 (N));
14107 if Present (Qual) then
14108 Rewrite (N, Qual);
14109 end if;
14111 -- All other cases than aggregates
14113 else
14114 Save_Global_Descendant (Field1 (N));
14115 Save_Global_Descendant (Field2 (N));
14116 Save_Global_Descendant (Field3 (N));
14117 Save_Global_Descendant (Field4 (N));
14118 Save_Global_Descendant (Field5 (N));
14119 end if;
14120 end;
14121 end if;
14123 -- If a node has aspects, references within their expressions must
14124 -- be saved separately, given they are not directly in the tree.
14126 if Has_Aspects (N) then
14127 declare
14128 Aspect : Node_Id;
14130 begin
14131 Aspect := First (Aspect_Specifications (N));
14132 while Present (Aspect) loop
14133 if Present (Expression (Aspect)) then
14134 Save_Global_References (Expression (Aspect));
14135 end if;
14137 Next (Aspect);
14138 end loop;
14139 end;
14140 end if;
14141 end Save_References;
14143 -- Start of processing for Save_Global_References
14145 begin
14146 Gen_Scope := Current_Scope;
14148 -- If the generic unit is a child unit, references to entities in the
14149 -- parent are treated as local, because they will be resolved anew in
14150 -- the context of the instance of the parent.
14152 while Is_Child_Unit (Gen_Scope)
14153 and then Ekind (Scope (Gen_Scope)) = E_Generic_Package
14154 loop
14155 Gen_Scope := Scope (Gen_Scope);
14156 end loop;
14158 Save_References (N);
14159 end Save_Global_References;
14161 --------------------------------------
14162 -- Set_Copied_Sloc_For_Inlined_Body --
14163 --------------------------------------
14165 procedure Set_Copied_Sloc_For_Inlined_Body (N : Node_Id; E : Entity_Id) is
14166 begin
14167 Create_Instantiation_Source (N, E, True, S_Adjustment);
14168 end Set_Copied_Sloc_For_Inlined_Body;
14170 ---------------------
14171 -- Set_Instance_Of --
14172 ---------------------
14174 procedure Set_Instance_Of (A : Entity_Id; B : Entity_Id) is
14175 begin
14176 Generic_Renamings.Table (Generic_Renamings.Last) := (A, B, Assoc_Null);
14177 Generic_Renamings_HTable.Set (Generic_Renamings.Last);
14178 Generic_Renamings.Increment_Last;
14179 end Set_Instance_Of;
14181 --------------------
14182 -- Set_Next_Assoc --
14183 --------------------
14185 procedure Set_Next_Assoc (E : Assoc_Ptr; Next : Assoc_Ptr) is
14186 begin
14187 Generic_Renamings.Table (E).Next_In_HTable := Next;
14188 end Set_Next_Assoc;
14190 -------------------
14191 -- Start_Generic --
14192 -------------------
14194 procedure Start_Generic is
14195 begin
14196 -- ??? More things could be factored out in this routine.
14197 -- Should probably be done at a later stage.
14199 Generic_Flags.Append (Inside_A_Generic);
14200 Inside_A_Generic := True;
14202 Expander_Mode_Save_And_Set (False);
14203 end Start_Generic;
14205 ----------------------
14206 -- Set_Instance_Env --
14207 ----------------------
14209 procedure Set_Instance_Env
14210 (Gen_Unit : Entity_Id;
14211 Act_Unit : Entity_Id)
14213 Assertion_Status : constant Boolean := Assertions_Enabled;
14214 Save_SPARK_Mode : constant SPARK_Mode_Type := SPARK_Mode;
14215 Save_SPARK_Mode_Pragma : constant Node_Id := SPARK_Mode_Pragma;
14217 begin
14218 -- Regardless of the current mode, predefined units are analyzed in the
14219 -- most current Ada mode, and earlier version Ada checks do not apply
14220 -- to predefined units. Nothing needs to be done for non-internal units.
14221 -- These are always analyzed in the current mode.
14223 if Is_Internal_File_Name
14224 (Fname => Unit_File_Name (Get_Source_Unit (Gen_Unit)),
14225 Renamings_Included => True)
14226 then
14227 Set_Opt_Config_Switches (True, Current_Sem_Unit = Main_Unit);
14229 -- In Ada2012 we may want to enable assertions in an instance of a
14230 -- predefined unit, in which case we need to preserve the current
14231 -- setting for the Assertions_Enabled flag. This will become more
14232 -- critical when pre/postconditions are added to predefined units,
14233 -- as is already the case for some numeric libraries.
14235 if Ada_Version >= Ada_2012 then
14236 Assertions_Enabled := Assertion_Status;
14237 end if;
14239 -- SPARK_Mode for an instance is the one applicable at the point of
14240 -- instantiation.
14242 SPARK_Mode := Save_SPARK_Mode;
14243 SPARK_Mode_Pragma := Save_SPARK_Mode_Pragma;
14244 end if;
14246 Current_Instantiated_Parent :=
14247 (Gen_Id => Gen_Unit,
14248 Act_Id => Act_Unit,
14249 Next_In_HTable => Assoc_Null);
14250 end Set_Instance_Env;
14252 -----------------
14253 -- Switch_View --
14254 -----------------
14256 procedure Switch_View (T : Entity_Id) is
14257 BT : constant Entity_Id := Base_Type (T);
14258 Priv_Elmt : Elmt_Id := No_Elmt;
14259 Priv_Sub : Entity_Id;
14261 begin
14262 -- T may be private but its base type may have been exchanged through
14263 -- some other occurrence, in which case there is nothing to switch
14264 -- besides T itself. Note that a private dependent subtype of a private
14265 -- type might not have been switched even if the base type has been,
14266 -- because of the last branch of Check_Private_View (see comment there).
14268 if not Is_Private_Type (BT) then
14269 Prepend_Elmt (Full_View (T), Exchanged_Views);
14270 Exchange_Declarations (T);
14271 return;
14272 end if;
14274 Priv_Elmt := First_Elmt (Private_Dependents (BT));
14276 if Present (Full_View (BT)) then
14277 Prepend_Elmt (Full_View (BT), Exchanged_Views);
14278 Exchange_Declarations (BT);
14279 end if;
14281 while Present (Priv_Elmt) loop
14282 Priv_Sub := (Node (Priv_Elmt));
14284 -- We avoid flipping the subtype if the Etype of its full view is
14285 -- private because this would result in a malformed subtype. This
14286 -- occurs when the Etype of the subtype full view is the full view of
14287 -- the base type (and since the base types were just switched, the
14288 -- subtype is pointing to the wrong view). This is currently the case
14289 -- for tagged record types, access types (maybe more?) and needs to
14290 -- be resolved. ???
14292 if Present (Full_View (Priv_Sub))
14293 and then not Is_Private_Type (Etype (Full_View (Priv_Sub)))
14294 then
14295 Prepend_Elmt (Full_View (Priv_Sub), Exchanged_Views);
14296 Exchange_Declarations (Priv_Sub);
14297 end if;
14299 Next_Elmt (Priv_Elmt);
14300 end loop;
14301 end Switch_View;
14303 -----------------
14304 -- True_Parent --
14305 -----------------
14307 function True_Parent (N : Node_Id) return Node_Id is
14308 begin
14309 if Nkind (Parent (N)) = N_Subunit then
14310 return Parent (Corresponding_Stub (Parent (N)));
14311 else
14312 return Parent (N);
14313 end if;
14314 end True_Parent;
14316 -----------------------------
14317 -- Valid_Default_Attribute --
14318 -----------------------------
14320 procedure Valid_Default_Attribute (Nam : Entity_Id; Def : Node_Id) is
14321 Attr_Id : constant Attribute_Id :=
14322 Get_Attribute_Id (Attribute_Name (Def));
14323 T : constant Entity_Id := Entity (Prefix (Def));
14324 Is_Fun : constant Boolean := (Ekind (Nam) = E_Function);
14325 F : Entity_Id;
14326 Num_F : Int;
14327 OK : Boolean;
14329 begin
14330 if No (T)
14331 or else T = Any_Id
14332 then
14333 return;
14334 end if;
14336 Num_F := 0;
14337 F := First_Formal (Nam);
14338 while Present (F) loop
14339 Num_F := Num_F + 1;
14340 Next_Formal (F);
14341 end loop;
14343 case Attr_Id is
14344 when Attribute_Adjacent | Attribute_Ceiling | Attribute_Copy_Sign |
14345 Attribute_Floor | Attribute_Fraction | Attribute_Machine |
14346 Attribute_Model | Attribute_Remainder | Attribute_Rounding |
14347 Attribute_Unbiased_Rounding =>
14348 OK := Is_Fun
14349 and then Num_F = 1
14350 and then Is_Floating_Point_Type (T);
14352 when Attribute_Image | Attribute_Pred | Attribute_Succ |
14353 Attribute_Value | Attribute_Wide_Image |
14354 Attribute_Wide_Value =>
14355 OK := (Is_Fun and then Num_F = 1 and then Is_Scalar_Type (T));
14357 when Attribute_Max | Attribute_Min =>
14358 OK := (Is_Fun and then Num_F = 2 and then Is_Scalar_Type (T));
14360 when Attribute_Input =>
14361 OK := (Is_Fun and then Num_F = 1);
14363 when Attribute_Output | Attribute_Read | Attribute_Write =>
14364 OK := (not Is_Fun and then Num_F = 2);
14366 when others =>
14367 OK := False;
14368 end case;
14370 if not OK then
14371 Error_Msg_N ("attribute reference has wrong profile for subprogram",
14372 Def);
14373 end if;
14374 end Valid_Default_Attribute;
14376 end Sem_Ch12;