1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
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 Fname; use Fname;
33 with Fname.UF; use Fname.UF;
34 with Freeze; use Freeze;
36 with Itypes; use Itypes;
38 with Lib.Load; use Lib.Load;
39 with Lib.Xref; use Lib.Xref;
40 with Nlists; use Nlists;
41 with Namet; use Namet;
42 with Nmake; use Nmake;
44 with Rident; use Rident;
45 with Restrict; use Restrict;
46 with Rtsfind; use Rtsfind;
48 with Sem_Aux; use Sem_Aux;
49 with Sem_Cat; use Sem_Cat;
50 with Sem_Ch3; use Sem_Ch3;
51 with Sem_Ch6; use Sem_Ch6;
52 with Sem_Ch7; use Sem_Ch7;
53 with Sem_Ch8; use Sem_Ch8;
54 with Sem_Ch10; use Sem_Ch10;
55 with Sem_Ch13; use Sem_Ch13;
56 with Sem_Disp; use Sem_Disp;
57 with Sem_Elab; use Sem_Elab;
58 with Sem_Elim; use Sem_Elim;
59 with Sem_Eval; use Sem_Eval;
60 with Sem_Res; use Sem_Res;
61 with Sem_Type; use Sem_Type;
62 with Sem_Util; use Sem_Util;
63 with Sem_Warn; use Sem_Warn;
64 with Stand; use Stand;
65 with Sinfo; use Sinfo;
66 with Sinfo.CN; use Sinfo.CN;
67 with Sinput; use Sinput;
68 with Sinput.L; use Sinput.L;
69 with Snames; use Snames;
70 with Stringt; use Stringt;
71 with Uname; use Uname;
73 with Tbuild; use Tbuild;
74 with Uintp; use Uintp;
75 with Urealp; use Urealp;
79 package body Sem_Ch12 is
81 ----------------------------------------------------------
82 -- Implementation of Generic Analysis and Instantiation --
83 ----------------------------------------------------------
85 -- GNAT implements generics by macro expansion. No attempt is made to share
86 -- generic instantiations (for now). Analysis of a generic definition does
87 -- not perform any expansion action, but the expander must be called on the
88 -- tree for each instantiation, because the expansion may of course depend
89 -- on the generic actuals. All of this is best achieved as follows:
91 -- a) Semantic analysis of a generic unit is performed on a copy of the
92 -- tree for the generic unit. All tree modifications that follow analysis
93 -- do not affect the original tree. Links are kept between the original
94 -- tree and the copy, in order to recognize non-local references within
95 -- the generic, and propagate them to each instance (recall that name
96 -- resolution is done on the generic declaration: generics are not really
97 -- macros!). This is summarized in the following diagram:
99 -- .-----------. .----------.
100 -- | semantic |<--------------| generic |
102 -- | |==============>| |
103 -- |___________| global |__________|
114 -- b) Each instantiation copies the original tree, and inserts into it a
115 -- series of declarations that describe the mapping between generic formals
116 -- and actuals. For example, a generic In OUT parameter is an object
117 -- renaming of the corresponding actual, etc. Generic IN parameters are
118 -- constant declarations.
120 -- c) In order to give the right visibility for these renamings, we use
121 -- a different scheme for package and subprogram instantiations. For
122 -- packages, the list of renamings is inserted into the package
123 -- specification, before the visible declarations of the package. The
124 -- renamings are analyzed before any of the text of the instance, and are
125 -- thus visible at the right place. Furthermore, outside of the instance,
126 -- the generic parameters are visible and denote their corresponding
129 -- For subprograms, we create a container package to hold the renamings
130 -- and the subprogram instance itself. Analysis of the package makes the
131 -- renaming declarations visible to the subprogram. After analyzing the
132 -- package, the defining entity for the subprogram is touched-up so that
133 -- it appears declared in the current scope, and not inside the container
136 -- If the instantiation is a compilation unit, the container package is
137 -- given the same name as the subprogram instance. This ensures that
138 -- the elaboration procedure called by the binder, using the compilation
139 -- unit name, calls in fact the elaboration procedure for the package.
141 -- Not surprisingly, private types complicate this approach. By saving in
142 -- the original generic object the non-local references, we guarantee that
143 -- the proper entities are referenced at the point of instantiation.
144 -- However, for private types, this by itself does not insure that the
145 -- proper VIEW of the entity is used (the full type may be visible at the
146 -- point of generic definition, but not at instantiation, or vice-versa).
147 -- In order to reference the proper view, we special-case any reference
148 -- to private types in the generic object, by saving both views, one in
149 -- the generic and one in the semantic copy. At time of instantiation, we
150 -- check whether the two views are consistent, and exchange declarations if
151 -- necessary, in order to restore the correct visibility. Similarly, if
152 -- the instance view is private when the generic view was not, we perform
153 -- the exchange. After completing the instantiation, we restore the
154 -- current visibility. The flag Has_Private_View marks identifiers in the
155 -- the generic unit that require checking.
157 -- Visibility within nested generic units requires special handling.
158 -- Consider the following scheme:
160 -- type Global is ... -- outside of generic unit.
164 -- type Semi_Global is ... -- global to inner.
167 -- procedure inner (X1 : Global; X2 : Semi_Global);
169 -- procedure in2 is new inner (...); -- 4
172 -- package New_Outer is new Outer (...); -- 2
173 -- procedure New_Inner is new New_Outer.Inner (...); -- 3
175 -- The semantic analysis of Outer captures all occurrences of Global.
176 -- The semantic analysis of Inner (at 1) captures both occurrences of
177 -- Global and Semi_Global.
179 -- At point 2 (instantiation of Outer), we also produce a generic copy
180 -- of Inner, even though Inner is, at that point, not being instantiated.
181 -- (This is just part of the semantic analysis of New_Outer).
183 -- Critically, references to Global within Inner must be preserved, while
184 -- references to Semi_Global should not preserved, because they must now
185 -- resolve to an entity within New_Outer. To distinguish between these, we
186 -- use a global variable, Current_Instantiated_Parent, which is set when
187 -- performing a generic copy during instantiation (at 2). This variable is
188 -- used when performing a generic copy that is not an instantiation, but
189 -- that is nested within one, as the occurrence of 1 within 2. The analysis
190 -- of a nested generic only preserves references that are global to the
191 -- enclosing Current_Instantiated_Parent. We use the Scope_Depth value to
192 -- determine whether a reference is external to the given parent.
194 -- The instantiation at point 3 requires no special treatment. The method
195 -- works as well for further nestings of generic units, but of course the
196 -- variable Current_Instantiated_Parent must be stacked because nested
197 -- instantiations can occur, e.g. the occurrence of 4 within 2.
199 -- The instantiation of package and subprogram bodies is handled in a
200 -- similar manner, except that it is delayed until after semantic
201 -- analysis is complete. In this fashion complex cross-dependencies
202 -- between several package declarations and bodies containing generics
203 -- can be compiled which otherwise would diagnose spurious circularities.
205 -- For example, it is possible to compile two packages A and B that
206 -- have the following structure:
208 -- package A is package B is
209 -- generic ... generic ...
210 -- package G_A is package G_B is
213 -- package body A is package body B is
214 -- package N_B is new G_B (..) package N_A is new G_A (..)
216 -- The table Pending_Instantiations in package Inline is used to keep
217 -- track of body instantiations that are delayed in this manner. Inline
218 -- handles the actual calls to do the body instantiations. This activity
219 -- is part of Inline, since the processing occurs at the same point, and
220 -- for essentially the same reason, as the handling of inlined routines.
222 ----------------------------------------------
223 -- Detection of Instantiation Circularities --
224 ----------------------------------------------
226 -- If we have a chain of instantiations that is circular, this is static
227 -- error which must be detected at compile time. The detection of these
228 -- circularities is carried out at the point that we insert a generic
229 -- instance spec or body. If there is a circularity, then the analysis of
230 -- the offending spec or body will eventually result in trying to load the
231 -- same unit again, and we detect this problem as we analyze the package
232 -- instantiation for the second time.
234 -- At least in some cases after we have detected the circularity, we get
235 -- into trouble if we try to keep going. The following flag is set if a
236 -- circularity is detected, and used to abandon compilation after the
237 -- messages have been posted.
239 Circularity_Detected : Boolean := False;
240 -- This should really be reset on encountering a new main unit, but in
241 -- practice we are not using multiple main units so it is not critical.
243 -------------------------------------------------
244 -- Formal packages and partial parametrization --
245 -------------------------------------------------
247 -- When compiling a generic, a formal package is a local instantiation. If
248 -- declared with a box, its generic formals are visible in the enclosing
249 -- generic. If declared with a partial list of actuals, those actuals that
250 -- are defaulted (covered by an Others clause, or given an explicit box
251 -- initialization) are also visible in the enclosing generic, while those
252 -- that have a corresponding actual are not.
254 -- In our source model of instantiation, the same visibility must be
255 -- present in the spec and body of an instance: the names of the formals
256 -- that are defaulted must be made visible within the instance, and made
257 -- invisible (hidden) after the instantiation is complete, so that they
258 -- are not accessible outside of the instance.
260 -- In a generic, a formal package is treated like a special instantiation.
261 -- Our Ada95 compiler handled formals with and without box in different
262 -- ways. With partial parametrization, we use a single model for both.
263 -- We create a package declaration that consists of the specification of
264 -- the generic package, and a set of declarations that map the actuals
265 -- into local renamings, just as we do for bona fide instantiations. For
266 -- defaulted parameters and formals with a box, we copy directly the
267 -- declarations of the formal into this local package. The result is a
268 -- a package whose visible declarations may include generic formals. This
269 -- package is only used for type checking and visibility analysis, and
270 -- never reaches the back-end, so it can freely violate the placement
271 -- rules for generic formal declarations.
273 -- The list of declarations (renamings and copies of formals) is built
274 -- by Analyze_Associations, just as for regular instantiations.
276 -- At the point of instantiation, conformance checking must be applied only
277 -- to those parameters that were specified in the formal. We perform this
278 -- checking by creating another internal instantiation, this one including
279 -- only the renamings and the formals (the rest of the package spec is not
280 -- relevant to conformance checking). We can then traverse two lists: the
281 -- list of actuals in the instance that corresponds to the formal package,
282 -- and the list of actuals produced for this bogus instantiation. We apply
283 -- the conformance rules to those actuals that are not defaulted (i.e.
284 -- which still appear as generic formals.
286 -- When we compile an instance body we must make the right parameters
287 -- visible again. The predicate Is_Generic_Formal indicates which of the
288 -- formals should have its Is_Hidden flag reset.
290 -----------------------
291 -- Local subprograms --
292 -----------------------
294 procedure Abandon_Instantiation (N : Node_Id);
295 pragma No_Return (Abandon_Instantiation);
296 -- Posts an error message "instantiation abandoned" at the indicated node
297 -- and then raises the exception Instantiation_Error to do it.
299 procedure Analyze_Formal_Array_Type
300 (T : in out Entity_Id;
302 -- A formal array type is treated like an array type declaration, and
303 -- invokes Array_Type_Declaration (sem_ch3) whose first parameter is
304 -- in-out, because in the case of an anonymous type the entity is
305 -- actually created in the procedure.
307 -- The following procedures treat other kinds of formal parameters
309 procedure Analyze_Formal_Derived_Interface_Type
314 procedure Analyze_Formal_Derived_Type
319 procedure Analyze_Formal_Interface_Type
324 -- The following subprograms create abbreviated declarations for formal
325 -- scalar types. We introduce an anonymous base of the proper class for
326 -- each of them, and define the formals as constrained first subtypes of
327 -- their bases. The bounds are expressions that are non-static in the
330 procedure Analyze_Formal_Decimal_Fixed_Point_Type
331 (T : Entity_Id; Def : Node_Id);
332 procedure Analyze_Formal_Discrete_Type (T : Entity_Id; Def : Node_Id);
333 procedure Analyze_Formal_Floating_Type (T : Entity_Id; Def : Node_Id);
334 procedure Analyze_Formal_Signed_Integer_Type (T : Entity_Id; Def : Node_Id);
335 procedure Analyze_Formal_Modular_Type (T : Entity_Id; Def : Node_Id);
336 procedure Analyze_Formal_Ordinary_Fixed_Point_Type
337 (T : Entity_Id; Def : Node_Id);
339 procedure Analyze_Formal_Private_Type
343 -- Creates a new private type, which does not require completion
345 procedure Analyze_Generic_Formal_Part (N : Node_Id);
347 procedure Analyze_Generic_Access_Type (T : Entity_Id; Def : Node_Id);
348 -- Create a new access type with the given designated type
350 function Analyze_Associations
353 F_Copy : List_Id) return List_Id;
354 -- At instantiation time, build the list of associations between formals
355 -- and actuals. Each association becomes a renaming declaration for the
356 -- formal entity. F_Copy is the analyzed list of formals in the generic
357 -- copy. It is used to apply legality checks to the actuals. I_Node is the
358 -- instantiation node itself.
360 procedure Analyze_Subprogram_Instantiation
364 procedure Build_Instance_Compilation_Unit_Nodes
368 -- This procedure is used in the case where the generic instance of a
369 -- subprogram body or package body is a library unit. In this case, the
370 -- original library unit node for the generic instantiation must be
371 -- replaced by the resulting generic body, and a link made to a new
372 -- compilation unit node for the generic declaration. The argument N is
373 -- the original generic instantiation. Act_Body and Act_Decl are the body
374 -- and declaration of the instance (either package body and declaration
375 -- nodes or subprogram body and declaration nodes depending on the case).
376 -- On return, the node N has been rewritten with the actual body.
378 procedure Check_Access_Definition (N : Node_Id);
379 -- Subsidiary routine to null exclusion processing. Perform an assertion
380 -- check on Ada version and the presence of an access definition in N.
382 procedure Check_Formal_Packages (P_Id : Entity_Id);
383 -- Apply the following to all formal packages in generic associations
385 procedure Check_Formal_Package_Instance
386 (Formal_Pack : Entity_Id;
387 Actual_Pack : Entity_Id);
388 -- Verify that the actuals of the actual instance match the actuals of
389 -- the template for a formal package that is not declared with a box.
391 procedure Check_Forward_Instantiation (Decl : Node_Id);
392 -- If the generic is a local entity and the corresponding body has not
393 -- been seen yet, flag enclosing packages to indicate that it will be
394 -- elaborated after the generic body. Subprograms declared in the same
395 -- package cannot be inlined by the front-end because front-end inlining
396 -- requires a strict linear order of elaboration.
398 procedure Check_Hidden_Child_Unit
400 Gen_Unit : Entity_Id;
401 Act_Decl_Id : Entity_Id);
402 -- If the generic unit is an implicit child instance within a parent
403 -- instance, we need to make an explicit test that it is not hidden by
404 -- a child instance of the same name and parent.
406 procedure Check_Generic_Actuals
407 (Instance : Entity_Id;
408 Is_Formal_Box : Boolean);
409 -- Similar to previous one. Check the actuals in the instantiation,
410 -- whose views can change between the point of instantiation and the point
411 -- of instantiation of the body. In addition, mark the generic renamings
412 -- as generic actuals, so that they are not compatible with other actuals.
413 -- Recurse on an actual that is a formal package whose declaration has
416 function Contains_Instance_Of
419 N : Node_Id) return Boolean;
420 -- Inner is instantiated within the generic Outer. Check whether Inner
421 -- directly or indirectly contains an instance of Outer or of one of its
422 -- parents, in the case of a subunit. Each generic unit holds a list of
423 -- the entities instantiated within (at any depth). This procedure
424 -- determines whether the set of such lists contains a cycle, i.e. an
425 -- illegal circular instantiation.
427 function Denotes_Formal_Package
429 On_Exit : Boolean := False;
430 Instance : Entity_Id := Empty) return Boolean;
431 -- Returns True if E is a formal package of an enclosing generic, or
432 -- the actual for such a formal in an enclosing instantiation. If such
433 -- a package is used as a formal in an nested generic, or as an actual
434 -- in a nested instantiation, the visibility of ITS formals should not
435 -- be modified. When called from within Restore_Private_Views, the flag
436 -- On_Exit is true, to indicate that the search for a possible enclosing
437 -- instance should ignore the current one. In that case Instance denotes
438 -- the declaration for which this is an actual. This declaration may be
439 -- an instantiation in the source, or the internal instantiation that
440 -- corresponds to the actual for a formal package.
442 function Find_Actual_Type
444 Gen_Type : Entity_Id) return Entity_Id;
445 -- When validating the actual types of a child instance, check whether
446 -- the formal is a formal type of the parent unit, and retrieve the current
447 -- actual for it. Typ is the entity in the analyzed formal type declaration
448 -- (component or index type of an array type, or designated type of an
449 -- access formal) and Gen_Type is the enclosing analyzed formal array
450 -- or access type. The desired actual may be a formal of a parent, or may
451 -- be declared in a formal package of a parent. In both cases it is a
452 -- generic actual type because it appears within a visible instance.
453 -- Finally, it may be declared in a parent unit without being a formal
454 -- of that unit, in which case it must be retrieved by visibility.
455 -- Ambiguities may still arise if two homonyms are declared in two formal
456 -- packages, and the prefix of the formal type may be needed to resolve
457 -- the ambiguity in the instance ???
459 function In_Same_Declarative_Part
461 Inst : Node_Id) return Boolean;
462 -- True if the instantiation Inst and the given freeze_node F_Node appear
463 -- within the same declarative part, ignoring subunits, but with no inter-
464 -- vening subprograms or concurrent units. If true, the freeze node
465 -- of the instance can be placed after the freeze node of the parent,
466 -- which it itself an instance.
468 function In_Main_Context (E : Entity_Id) return Boolean;
469 -- Check whether an instantiation is in the context of the main unit.
470 -- Used to determine whether its body should be elaborated to allow
471 -- front-end inlining.
473 procedure Set_Instance_Env
474 (Gen_Unit : Entity_Id;
475 Act_Unit : Entity_Id);
476 -- Save current instance on saved environment, to be used to determine
477 -- the global status of entities in nested instances. Part of Save_Env.
478 -- called after verifying that the generic unit is legal for the instance,
479 -- The procedure also examines whether the generic unit is a predefined
480 -- unit, in order to set configuration switches accordingly. As a result
481 -- the procedure must be called after analyzing and freezing the actuals.
483 procedure Set_Instance_Of (A : Entity_Id; B : Entity_Id);
484 -- Associate analyzed generic parameter with corresponding
485 -- instance. Used for semantic checks at instantiation time.
487 function Has_Been_Exchanged (E : Entity_Id) return Boolean;
488 -- Traverse the Exchanged_Views list to see if a type was private
489 -- and has already been flipped during this phase of instantiation.
491 procedure Hide_Current_Scope;
492 -- When instantiating a generic child unit, the parent context must be
493 -- present, but the instance and all entities that may be generated
494 -- must be inserted in the current scope. We leave the current scope
495 -- on the stack, but make its entities invisible to avoid visibility
496 -- problems. This is reversed at the end of the instantiation. This is
497 -- not done for the instantiation of the bodies, which only require the
498 -- instances of the generic parents to be in scope.
500 procedure Install_Body
505 -- If the instantiation happens textually before the body of the generic,
506 -- the instantiation of the body must be analyzed after the generic body,
507 -- and not at the point of instantiation. Such early instantiations can
508 -- happen if the generic and the instance appear in a package declaration
509 -- because the generic body can only appear in the corresponding package
510 -- body. Early instantiations can also appear if generic, instance and
511 -- body are all in the declarative part of a subprogram or entry. Entities
512 -- of packages that are early instantiations are delayed, and their freeze
513 -- node appears after the generic body.
515 procedure Insert_After_Last_Decl (N : Node_Id; F_Node : Node_Id);
516 -- Insert freeze node at the end of the declarative part that includes the
517 -- instance node N. If N is in the visible part of an enclosing package
518 -- declaration, the freeze node has to be inserted at the end of the
519 -- private declarations, if any.
521 procedure Freeze_Subprogram_Body
522 (Inst_Node : Node_Id;
524 Pack_Id : Entity_Id);
525 -- The generic body may appear textually after the instance, including
526 -- in the proper body of a stub, or within a different package instance.
527 -- Given that the instance can only be elaborated after the generic, we
528 -- place freeze_nodes for the instance and/or for packages that may enclose
529 -- the instance and the generic, so that the back-end can establish the
530 -- proper order of elaboration.
533 -- Establish environment for subsequent instantiation. Separated from
534 -- Save_Env because data-structures for visibility handling must be
535 -- initialized before call to Check_Generic_Child_Unit.
537 procedure Install_Formal_Packages (Par : Entity_Id);
538 -- Install the visible part of any formal of the parent that is a formal
539 -- package. Note that for the case of a formal package with a box, this
540 -- includes the formal part of the formal package (12.7(10/2)).
542 procedure Install_Parent (P : Entity_Id; In_Body : Boolean := False);
543 -- When compiling an instance of a child unit the parent (which is
544 -- itself an instance) is an enclosing scope that must be made
545 -- immediately visible. This procedure is also used to install the non-
546 -- generic parent of a generic child unit when compiling its body, so
547 -- that full views of types in the parent are made visible.
549 procedure Remove_Parent (In_Body : Boolean := False);
550 -- Reverse effect after instantiation of child is complete
552 procedure Inline_Instance_Body
554 Gen_Unit : Entity_Id;
556 -- If front-end inlining is requested, instantiate the package body,
557 -- and preserve the visibility of its compilation unit, to insure
558 -- that successive instantiations succeed.
560 -- The functions Instantiate_XXX perform various legality checks and build
561 -- the declarations for instantiated generic parameters. In all of these
562 -- Formal is the entity in the generic unit, Actual is the entity of
563 -- expression in the generic associations, and Analyzed_Formal is the
564 -- formal in the generic copy, which contains the semantic information to
565 -- be used to validate the actual.
567 function Instantiate_Object
570 Analyzed_Formal : Node_Id) return List_Id;
572 function Instantiate_Type
575 Analyzed_Formal : Node_Id;
576 Actual_Decls : List_Id) return List_Id;
578 function Instantiate_Formal_Subprogram
581 Analyzed_Formal : Node_Id) return Node_Id;
583 function Instantiate_Formal_Package
586 Analyzed_Formal : Node_Id) return List_Id;
587 -- If the formal package is declared with a box, special visibility rules
588 -- apply to its formals: they are in the visible part of the package. This
589 -- is true in the declarative region of the formal package, that is to say
590 -- in the enclosing generic or instantiation. For an instantiation, the
591 -- parameters of the formal package are made visible in an explicit step.
592 -- Furthermore, if the actual has a visible USE clause, these formals must
593 -- be made potentially use-visible as well. On exit from the enclosing
594 -- instantiation, the reverse must be done.
596 -- For a formal package declared without a box, there are conformance rules
597 -- that apply to the actuals in the generic declaration and the actuals of
598 -- the actual package in the enclosing instantiation. The simplest way to
599 -- apply these rules is to repeat the instantiation of the formal package
600 -- in the context of the enclosing instance, and compare the generic
601 -- associations of this instantiation with those of the actual package.
602 -- This internal instantiation only needs to contain the renamings of the
603 -- formals: the visible and private declarations themselves need not be
606 -- In Ada 2005, the formal package may be only partially parameterized.
607 -- In that case the visibility step must make visible those actuals whose
608 -- corresponding formals were given with a box. A final complication
609 -- involves inherited operations from formal derived types, which must
610 -- be visible if the type is.
612 function Is_In_Main_Unit (N : Node_Id) return Boolean;
613 -- Test if given node is in the main unit
615 procedure Load_Parent_Of_Generic
618 Body_Optional : Boolean := False);
619 -- If the generic appears in a separate non-generic library unit, load the
620 -- corresponding body to retrieve the body of the generic. N is the node
621 -- for the generic instantiation, Spec is the generic package declaration.
623 -- Body_Optional is a flag that indicates that the body is being loaded to
624 -- ensure that temporaries are generated consistently when there are other
625 -- instances in the current declarative part that precede the one being
626 -- loaded. In that case a missing body is acceptable.
628 procedure Inherit_Context (Gen_Decl : Node_Id; Inst : Node_Id);
629 -- Add the context clause of the unit containing a generic unit to a
630 -- compilation unit that is, or contains, an instantiation.
632 function Get_Associated_Node (N : Node_Id) return Node_Id;
633 -- In order to propagate semantic information back from the analyzed copy
634 -- to the original generic, we maintain links between selected nodes in the
635 -- generic and their corresponding copies. At the end of generic analysis,
636 -- the routine Save_Global_References traverses the generic tree, examines
637 -- the semantic information, and preserves the links to those nodes that
638 -- contain global information. At instantiation, the information from the
639 -- associated node is placed on the new copy, so that name resolution is
642 -- Three kinds of source nodes have associated nodes:
644 -- a) those that can reference (denote) entities, that is identifiers,
645 -- character literals, expanded_names, operator symbols, operators,
646 -- and attribute reference nodes. These nodes have an Entity field
647 -- and are the set of nodes that are in N_Has_Entity.
649 -- b) aggregates (N_Aggregate and N_Extension_Aggregate)
651 -- c) selected components (N_Selected_Component)
653 -- For the first class, the associated node preserves the entity if it is
654 -- global. If the generic contains nested instantiations, the associated
655 -- node itself has been recopied, and a chain of them must be followed.
657 -- For aggregates, the associated node allows retrieval of the type, which
658 -- may otherwise not appear in the generic. The view of this type may be
659 -- different between generic and instantiation, and the full view can be
660 -- installed before the instantiation is analyzed. For aggregates of type
661 -- extensions, the same view exchange may have to be performed for some of
662 -- the ancestor types, if their view is private at the point of
665 -- Nodes that are selected components in the parse tree may be rewritten
666 -- as expanded names after resolution, and must be treated as potential
667 -- entity holders, which is why they also have an Associated_Node.
669 -- Nodes that do not come from source, such as freeze nodes, do not appear
670 -- in the generic tree, and need not have an associated node.
672 -- The associated node is stored in the Associated_Node field. Note that
673 -- this field overlaps Entity, which is fine, because the whole point is
674 -- that we don't need or want the normal Entity field in this situation.
676 procedure Map_Formal_Package_Entities (Form : Entity_Id; Act : Entity_Id);
677 -- Within the generic part, entities in the formal package are
678 -- visible. To validate subsequent type declarations, indicate
679 -- the correspondence between the entities in the analyzed formal,
680 -- and the entities in the actual package. There are three packages
681 -- involved in the instantiation of a formal package: the parent
682 -- generic P1 which appears in the generic declaration, the fake
683 -- instantiation P2 which appears in the analyzed generic, and whose
684 -- visible entities may be used in subsequent formals, and the actual
685 -- P3 in the instance. To validate subsequent formals, me indicate
686 -- that the entities in P2 are mapped into those of P3. The mapping of
687 -- entities has to be done recursively for nested packages.
689 procedure Move_Freeze_Nodes
693 -- Freeze nodes can be generated in the analysis of a generic unit, but
694 -- will not be seen by the back-end. It is necessary to move those nodes
695 -- to the enclosing scope if they freeze an outer entity. We place them
696 -- at the end of the enclosing generic package, which is semantically
699 procedure Preanalyze_Actuals (N : Node_Id);
700 -- Analyze actuals to perform name resolution. Full resolution is done
701 -- later, when the expected types are known, but names have to be captured
702 -- before installing parents of generics, that are not visible for the
703 -- actuals themselves.
705 procedure Valid_Default_Attribute (Nam : Entity_Id; Def : Node_Id);
706 -- Verify that an attribute that appears as the default for a formal
707 -- subprogram is a function or procedure with the correct profile.
709 -------------------------------------------
710 -- Data Structures for Generic Renamings --
711 -------------------------------------------
713 -- The map Generic_Renamings associates generic entities with their
714 -- corresponding actuals. Currently used to validate type instances. It
715 -- will eventually be used for all generic parameters to eliminate the
716 -- need for overload resolution in the instance.
718 type Assoc_Ptr is new Int;
720 Assoc_Null : constant Assoc_Ptr := -1;
725 Next_In_HTable : Assoc_Ptr;
728 package Generic_Renamings is new Table.Table
729 (Table_Component_Type => Assoc,
730 Table_Index_Type => Assoc_Ptr,
731 Table_Low_Bound => 0,
733 Table_Increment => 100,
734 Table_Name => "Generic_Renamings");
736 -- Variable to hold enclosing instantiation. When the environment is
737 -- saved for a subprogram inlining, the corresponding Act_Id is empty.
739 Current_Instantiated_Parent : Assoc := (Empty, Empty, Assoc_Null);
741 -- Hash table for associations
743 HTable_Size : constant := 37;
744 type HTable_Range is range 0 .. HTable_Size - 1;
746 procedure Set_Next_Assoc (E : Assoc_Ptr; Next : Assoc_Ptr);
747 function Next_Assoc (E : Assoc_Ptr) return Assoc_Ptr;
748 function Get_Gen_Id (E : Assoc_Ptr) return Entity_Id;
749 function Hash (F : Entity_Id) return HTable_Range;
751 package Generic_Renamings_HTable is new GNAT.HTable.Static_HTable (
752 Header_Num => HTable_Range,
754 Elmt_Ptr => Assoc_Ptr,
755 Null_Ptr => Assoc_Null,
756 Set_Next => Set_Next_Assoc,
759 Get_Key => Get_Gen_Id,
763 Exchanged_Views : Elist_Id;
764 -- This list holds the private views that have been exchanged during
765 -- instantiation to restore the visibility of the generic declaration.
766 -- (see comments above). After instantiation, the current visibility is
767 -- reestablished by means of a traversal of this list.
769 Hidden_Entities : Elist_Id;
770 -- This list holds the entities of the current scope that are removed
771 -- from immediate visibility when instantiating a child unit. Their
772 -- visibility is restored in Remove_Parent.
774 -- Because instantiations can be recursive, the following must be saved
775 -- on entry and restored on exit from an instantiation (spec or body).
776 -- This is done by the two procedures Save_Env and Restore_Env. For
777 -- package and subprogram instantiations (but not for the body instances)
778 -- the action of Save_Env is done in two steps: Init_Env is called before
779 -- Check_Generic_Child_Unit, because setting the parent instances requires
780 -- that the visibility data structures be properly initialized. Once the
781 -- generic is unit is validated, Set_Instance_Env completes Save_Env.
783 Parent_Unit_Visible : Boolean := False;
784 -- Parent_Unit_Visible is used when the generic is a child unit, and
785 -- indicates whether the ultimate parent of the generic is visible in the
786 -- instantiation environment. It is used to reset the visibility of the
787 -- parent at the end of the instantiation (see Remove_Parent).
789 Instance_Parent_Unit : Entity_Id := Empty;
790 -- This records the ultimate parent unit of an instance of a generic
791 -- child unit and is used in conjunction with Parent_Unit_Visible to
792 -- indicate the unit to which the Parent_Unit_Visible flag corresponds.
794 type Instance_Env is record
795 Instantiated_Parent : Assoc;
796 Exchanged_Views : Elist_Id;
797 Hidden_Entities : Elist_Id;
798 Current_Sem_Unit : Unit_Number_Type;
799 Parent_Unit_Visible : Boolean := False;
800 Instance_Parent_Unit : Entity_Id := Empty;
801 Switches : Config_Switches_Type;
804 package Instance_Envs is new Table.Table (
805 Table_Component_Type => Instance_Env,
806 Table_Index_Type => Int,
807 Table_Low_Bound => 0,
809 Table_Increment => 100,
810 Table_Name => "Instance_Envs");
812 procedure Restore_Private_Views
813 (Pack_Id : Entity_Id;
814 Is_Package : Boolean := True);
815 -- Restore the private views of external types, and unmark the generic
816 -- renamings of actuals, so that they become compatible subtypes again.
817 -- For subprograms, Pack_Id is the package constructed to hold the
820 procedure Switch_View (T : Entity_Id);
821 -- Switch the partial and full views of a type and its private
822 -- dependents (i.e. its subtypes and derived types).
824 ------------------------------------
825 -- Structures for Error Reporting --
826 ------------------------------------
828 Instantiation_Node : Node_Id;
829 -- Used by subprograms that validate instantiation of formal parameters
830 -- where there might be no actual on which to place the error message.
831 -- Also used to locate the instantiation node for generic subunits.
833 Instantiation_Error : exception;
834 -- When there is a semantic error in the generic parameter matching,
835 -- there is no point in continuing the instantiation, because the
836 -- number of cascaded errors is unpredictable. This exception aborts
837 -- the instantiation process altogether.
839 S_Adjustment : Sloc_Adjustment;
840 -- Offset created for each node in an instantiation, in order to keep
841 -- track of the source position of the instantiation in each of its nodes.
842 -- A subsequent semantic error or warning on a construct of the instance
843 -- points to both places: the original generic node, and the point of
844 -- instantiation. See Sinput and Sinput.L for additional details.
846 ------------------------------------------------------------
847 -- Data structure for keeping track when inside a Generic --
848 ------------------------------------------------------------
850 -- The following table is used to save values of the Inside_A_Generic
851 -- flag (see spec of Sem) when they are saved by Start_Generic.
853 package Generic_Flags is new Table.Table (
854 Table_Component_Type => Boolean,
855 Table_Index_Type => Int,
856 Table_Low_Bound => 0,
858 Table_Increment => 200,
859 Table_Name => "Generic_Flags");
861 ---------------------------
862 -- Abandon_Instantiation --
863 ---------------------------
865 procedure Abandon_Instantiation (N : Node_Id) is
867 Error_Msg_N ("\instantiation abandoned!", N);
868 raise Instantiation_Error;
869 end Abandon_Instantiation;
871 --------------------------
872 -- Analyze_Associations --
873 --------------------------
875 function Analyze_Associations
878 F_Copy : List_Id) return List_Id
881 Actual_Types : constant Elist_Id := New_Elmt_List;
882 Assoc : constant List_Id := New_List;
883 Default_Actuals : constant Elist_Id := New_Elmt_List;
884 Gen_Unit : constant Entity_Id :=
885 Defining_Entity (Parent (F_Copy));
890 Next_Formal : Node_Id;
891 Temp_Formal : Node_Id;
892 Analyzed_Formal : Node_Id;
895 First_Named : Node_Id := Empty;
897 Default_Formals : constant List_Id := New_List;
898 -- If an Others_Choice is present, some of the formals may be defaulted.
899 -- To simplify the treatment of visibility in an instance, we introduce
900 -- individual defaults for each such formal. These defaults are
901 -- appended to the list of associations and replace the Others_Choice.
903 Found_Assoc : Node_Id;
904 -- Association for the current formal being match. Empty if there are
905 -- no remaining actuals, or if there is no named association with the
906 -- name of the formal.
908 Is_Named_Assoc : Boolean;
909 Num_Matched : Int := 0;
910 Num_Actuals : Int := 0;
912 Others_Present : Boolean := False;
913 -- In Ada 2005, indicates partial parametrization of a formal
914 -- package. As usual an other association must be last in the list.
916 function Matching_Actual
918 A_F : Entity_Id) return Node_Id;
919 -- Find actual that corresponds to a given a formal parameter. If the
920 -- actuals are positional, return the next one, if any. If the actuals
921 -- are named, scan the parameter associations to find the right one.
922 -- A_F is the corresponding entity in the analyzed generic,which is
923 -- placed on the selector name for ASIS use.
925 -- In Ada 2005, a named association may be given with a box, in which
926 -- case Matching_Actual sets Found_Assoc to the generic association,
927 -- but return Empty for the actual itself. In this case the code below
928 -- creates a corresponding declaration for the formal.
930 function Partial_Parametrization return Boolean;
931 -- Ada 2005: if no match is found for a given formal, check if the
932 -- association for it includes a box, or whether the associations
933 -- include an Others clause.
935 procedure Process_Default (F : Entity_Id);
936 -- Add a copy of the declaration of generic formal F to the list of
937 -- associations, and add an explicit box association for F if there
938 -- is none yet, and the default comes from an Others_Choice.
940 procedure Set_Analyzed_Formal;
941 -- Find the node in the generic copy that corresponds to a given formal.
942 -- The semantic information on this node is used to perform legality
943 -- checks on the actuals. Because semantic analysis can introduce some
944 -- anonymous entities or modify the declaration node itself, the
945 -- correspondence between the two lists is not one-one. In addition to
946 -- anonymous types, the presence a formal equality will introduce an
947 -- implicit declaration for the corresponding inequality.
949 ---------------------
950 -- Matching_Actual --
951 ---------------------
953 function Matching_Actual
955 A_F : Entity_Id) return Node_Id
961 Is_Named_Assoc := False;
963 -- End of list of purely positional parameters
965 if No (Actual) or else Nkind (Actual) = N_Others_Choice then
966 Found_Assoc := Empty;
969 -- Case of positional parameter corresponding to current formal
971 elsif No (Selector_Name (Actual)) then
972 Found_Assoc := Actual;
973 Act := Explicit_Generic_Actual_Parameter (Actual);
974 Num_Matched := Num_Matched + 1;
977 -- Otherwise scan list of named actuals to find the one with the
978 -- desired name. All remaining actuals have explicit names.
981 Is_Named_Assoc := True;
982 Found_Assoc := Empty;
986 while Present (Actual) loop
987 if Chars (Selector_Name (Actual)) = Chars (F) then
988 Set_Entity (Selector_Name (Actual), A_F);
989 Set_Etype (Selector_Name (Actual), Etype (A_F));
990 Generate_Reference (A_F, Selector_Name (Actual));
991 Found_Assoc := Actual;
992 Act := Explicit_Generic_Actual_Parameter (Actual);
993 Num_Matched := Num_Matched + 1;
1001 -- Reset for subsequent searches. In most cases the named
1002 -- associations are in order. If they are not, we reorder them
1003 -- to avoid scanning twice the same actual. This is not just a
1004 -- question of efficiency: there may be multiple defaults with
1005 -- boxes that have the same name. In a nested instantiation we
1006 -- insert actuals for those defaults, and cannot rely on their
1007 -- names to disambiguate them.
1009 if Actual = First_Named then
1012 elsif Present (Actual) then
1013 Insert_Before (First_Named, Remove_Next (Prev));
1016 Actual := First_Named;
1019 if Is_Entity_Name (Act) and then Present (Entity (Act)) then
1020 Set_Used_As_Generic_Actual (Entity (Act));
1024 end Matching_Actual;
1026 -----------------------------
1027 -- Partial_Parametrization --
1028 -----------------------------
1030 function Partial_Parametrization return Boolean is
1032 return Others_Present
1033 or else (Present (Found_Assoc) and then Box_Present (Found_Assoc));
1034 end Partial_Parametrization;
1036 ---------------------
1037 -- Process_Default --
1038 ---------------------
1040 procedure Process_Default (F : Entity_Id) is
1041 Loc : constant Source_Ptr := Sloc (I_Node);
1042 F_Id : constant Entity_Id := Defining_Entity (F);
1048 -- Append copy of formal declaration to associations, and create new
1049 -- defining identifier for it.
1051 Decl := New_Copy_Tree (F);
1052 Id := Make_Defining_Identifier (Sloc (F_Id), Chars (F_Id));
1054 if Nkind (F) in N_Formal_Subprogram_Declaration then
1055 Set_Defining_Unit_Name (Specification (Decl), Id);
1058 Set_Defining_Identifier (Decl, Id);
1061 Append (Decl, Assoc);
1063 if No (Found_Assoc) then
1065 Make_Generic_Association (Loc,
1066 Selector_Name => New_Occurrence_Of (Id, Loc),
1067 Explicit_Generic_Actual_Parameter => Empty);
1068 Set_Box_Present (Default);
1069 Append (Default, Default_Formals);
1071 end Process_Default;
1073 -------------------------
1074 -- Set_Analyzed_Formal --
1075 -------------------------
1077 procedure Set_Analyzed_Formal is
1081 while Present (Analyzed_Formal) loop
1082 Kind := Nkind (Analyzed_Formal);
1084 case Nkind (Formal) is
1086 when N_Formal_Subprogram_Declaration =>
1087 exit when Kind in N_Formal_Subprogram_Declaration
1090 (Defining_Unit_Name (Specification (Formal))) =
1092 (Defining_Unit_Name (Specification (Analyzed_Formal)));
1094 when N_Formal_Package_Declaration =>
1095 exit when Nkind_In (Kind, N_Formal_Package_Declaration,
1096 N_Generic_Package_Declaration,
1097 N_Package_Declaration);
1099 when N_Use_Package_Clause | N_Use_Type_Clause => exit;
1103 -- Skip freeze nodes, and nodes inserted to replace
1104 -- unrecognized pragmas.
1107 Kind not in N_Formal_Subprogram_Declaration
1108 and then not Nkind_In (Kind, N_Subprogram_Declaration,
1112 and then Chars (Defining_Identifier (Formal)) =
1113 Chars (Defining_Identifier (Analyzed_Formal));
1116 Next (Analyzed_Formal);
1118 end Set_Analyzed_Formal;
1120 -- Start of processing for Analyze_Associations
1123 Actuals := Generic_Associations (I_Node);
1125 if Present (Actuals) then
1127 -- Check for an Others choice, indicating a partial parametrization
1128 -- for a formal package.
1130 Actual := First (Actuals);
1131 while Present (Actual) loop
1132 if Nkind (Actual) = N_Others_Choice then
1133 Others_Present := True;
1135 if Present (Next (Actual)) then
1136 Error_Msg_N ("others must be last association", Actual);
1139 -- This subprogram is used both for formal packages and for
1140 -- instantiations. For the latter, associations must all be
1143 if Nkind (I_Node) /= N_Formal_Package_Declaration
1144 and then Comes_From_Source (I_Node)
1147 ("others association not allowed in an instance",
1151 -- In any case, nothing to do after the others association
1155 elsif Box_Present (Actual)
1156 and then Comes_From_Source (I_Node)
1157 and then Nkind (I_Node) /= N_Formal_Package_Declaration
1160 ("box association not allowed in an instance", Actual);
1166 -- If named associations are present, save first named association
1167 -- (it may of course be Empty) to facilitate subsequent name search.
1169 First_Named := First (Actuals);
1170 while Present (First_Named)
1171 and then Nkind (First_Named) /= N_Others_Choice
1172 and then No (Selector_Name (First_Named))
1174 Num_Actuals := Num_Actuals + 1;
1179 Named := First_Named;
1180 while Present (Named) loop
1181 if Nkind (Named) /= N_Others_Choice
1182 and then No (Selector_Name (Named))
1184 Error_Msg_N ("invalid positional actual after named one", Named);
1185 Abandon_Instantiation (Named);
1188 -- A named association may lack an actual parameter, if it was
1189 -- introduced for a default subprogram that turns out to be local
1190 -- to the outer instantiation.
1192 if Nkind (Named) /= N_Others_Choice
1193 and then Present (Explicit_Generic_Actual_Parameter (Named))
1195 Num_Actuals := Num_Actuals + 1;
1201 if Present (Formals) then
1202 Formal := First_Non_Pragma (Formals);
1203 Analyzed_Formal := First_Non_Pragma (F_Copy);
1205 if Present (Actuals) then
1206 Actual := First (Actuals);
1208 -- All formals should have default values
1214 while Present (Formal) loop
1215 Set_Analyzed_Formal;
1216 Next_Formal := Next_Non_Pragma (Formal);
1218 case Nkind (Formal) is
1219 when N_Formal_Object_Declaration =>
1222 Defining_Identifier (Formal),
1223 Defining_Identifier (Analyzed_Formal));
1225 if No (Match) and then Partial_Parametrization then
1226 Process_Default (Formal);
1229 (Instantiate_Object (Formal, Match, Analyzed_Formal),
1233 when N_Formal_Type_Declaration =>
1236 Defining_Identifier (Formal),
1237 Defining_Identifier (Analyzed_Formal));
1240 if Partial_Parametrization then
1241 Process_Default (Formal);
1244 Error_Msg_Sloc := Sloc (Gen_Unit);
1248 Defining_Identifier (Formal));
1249 Error_Msg_NE ("\in instantiation of & declared#",
1250 Instantiation_Node, Gen_Unit);
1251 Abandon_Instantiation (Instantiation_Node);
1258 (Formal, Match, Analyzed_Formal, Assoc),
1261 -- An instantiation is a freeze point for the actuals,
1262 -- unless this is a rewritten formal package.
1264 if Nkind (I_Node) /= N_Formal_Package_Declaration then
1265 Append_Elmt (Entity (Match), Actual_Types);
1269 -- A remote access-to-class-wide type must not be an
1270 -- actual parameter for a generic formal of an access
1271 -- type (E.2.2 (17)).
1273 if Nkind (Analyzed_Formal) = N_Formal_Type_Declaration
1275 Nkind (Formal_Type_Definition (Analyzed_Formal)) =
1276 N_Access_To_Object_Definition
1278 Validate_Remote_Access_To_Class_Wide_Type (Match);
1281 when N_Formal_Subprogram_Declaration =>
1284 Defining_Unit_Name (Specification (Formal)),
1285 Defining_Unit_Name (Specification (Analyzed_Formal)));
1287 -- If the formal subprogram has the same name as another
1288 -- formal subprogram of the generic, then a named
1289 -- association is illegal (12.3(9)). Exclude named
1290 -- associations that are generated for a nested instance.
1293 and then Is_Named_Assoc
1294 and then Comes_From_Source (Found_Assoc)
1296 Temp_Formal := First (Formals);
1297 while Present (Temp_Formal) loop
1298 if Nkind (Temp_Formal) in
1299 N_Formal_Subprogram_Declaration
1300 and then Temp_Formal /= Formal
1302 Chars (Selector_Name (Found_Assoc)) =
1303 Chars (Defining_Unit_Name
1304 (Specification (Temp_Formal)))
1307 ("name not allowed for overloaded formal",
1309 Abandon_Instantiation (Instantiation_Node);
1316 -- If there is no corresponding actual, this may be case of
1317 -- partial parametrization, or else the formal has a default
1321 and then Partial_Parametrization
1323 Process_Default (Formal);
1326 Instantiate_Formal_Subprogram
1327 (Formal, Match, Analyzed_Formal));
1330 -- If this is a nested generic, preserve default for later
1334 and then Box_Present (Formal)
1337 (Defining_Unit_Name (Specification (Last (Assoc))),
1341 when N_Formal_Package_Declaration =>
1344 Defining_Identifier (Formal),
1345 Defining_Identifier (Original_Node (Analyzed_Formal)));
1348 if Partial_Parametrization then
1349 Process_Default (Formal);
1352 Error_Msg_Sloc := Sloc (Gen_Unit);
1355 Instantiation_Node, Defining_Identifier (Formal));
1356 Error_Msg_NE ("\in instantiation of & declared#",
1357 Instantiation_Node, Gen_Unit);
1359 Abandon_Instantiation (Instantiation_Node);
1365 (Instantiate_Formal_Package
1366 (Formal, Match, Analyzed_Formal),
1370 -- For use type and use package appearing in the generic part,
1371 -- we have already copied them, so we can just move them where
1372 -- they belong (we mustn't recopy them since this would mess up
1373 -- the Sloc values).
1375 when N_Use_Package_Clause |
1376 N_Use_Type_Clause =>
1377 if Nkind (Original_Node (I_Node)) =
1378 N_Formal_Package_Declaration
1380 Append (New_Copy_Tree (Formal), Assoc);
1383 Append (Formal, Assoc);
1387 raise Program_Error;
1391 Formal := Next_Formal;
1392 Next_Non_Pragma (Analyzed_Formal);
1395 if Num_Actuals > Num_Matched then
1396 Error_Msg_Sloc := Sloc (Gen_Unit);
1398 if Present (Selector_Name (Actual)) then
1400 ("unmatched actual&",
1401 Actual, Selector_Name (Actual));
1402 Error_Msg_NE ("\in instantiation of& declared#",
1406 ("unmatched actual in instantiation of& declared#",
1411 elsif Present (Actuals) then
1413 ("too many actuals in generic instantiation", Instantiation_Node);
1417 Elmt : Elmt_Id := First_Elmt (Actual_Types);
1419 while Present (Elmt) loop
1420 Freeze_Before (I_Node, Node (Elmt));
1425 -- If there are default subprograms, normalize the tree by adding
1426 -- explicit associations for them. This is required if the instance
1427 -- appears within a generic.
1435 Elmt := First_Elmt (Default_Actuals);
1436 while Present (Elmt) loop
1437 if No (Actuals) then
1438 Actuals := New_List;
1439 Set_Generic_Associations (I_Node, Actuals);
1442 Subp := Node (Elmt);
1444 Make_Generic_Association (Sloc (Subp),
1445 Selector_Name => New_Occurrence_Of (Subp, Sloc (Subp)),
1446 Explicit_Generic_Actual_Parameter =>
1447 New_Occurrence_Of (Subp, Sloc (Subp)));
1448 Mark_Rewrite_Insertion (New_D);
1449 Append_To (Actuals, New_D);
1454 -- If this is a formal package, normalize the parameter list by adding
1455 -- explicit box associations for the formals that are covered by an
1458 if not Is_Empty_List (Default_Formals) then
1459 Append_List (Default_Formals, Formals);
1463 end Analyze_Associations;
1465 -------------------------------
1466 -- Analyze_Formal_Array_Type --
1467 -------------------------------
1469 procedure Analyze_Formal_Array_Type
1470 (T : in out Entity_Id;
1476 -- Treated like a non-generic array declaration, with additional
1481 if Nkind (Def) = N_Constrained_Array_Definition then
1482 DSS := First (Discrete_Subtype_Definitions (Def));
1483 while Present (DSS) loop
1484 if Nkind_In (DSS, N_Subtype_Indication,
1486 N_Attribute_Reference)
1488 Error_Msg_N ("only a subtype mark is allowed in a formal", DSS);
1495 Array_Type_Declaration (T, Def);
1496 Set_Is_Generic_Type (Base_Type (T));
1498 if Ekind (Component_Type (T)) = E_Incomplete_Type
1499 and then No (Full_View (Component_Type (T)))
1501 Error_Msg_N ("premature usage of incomplete type", Def);
1503 -- Check that range constraint is not allowed on the component type
1504 -- of a generic formal array type (AARM 12.5.3(3))
1506 elsif Is_Internal (Component_Type (T))
1507 and then Present (Subtype_Indication (Component_Definition (Def)))
1508 and then Nkind (Original_Node
1509 (Subtype_Indication (Component_Definition (Def)))) =
1510 N_Subtype_Indication
1513 ("in a formal, a subtype indication can only be "
1514 & "a subtype mark (RM 12.5.3(3))",
1515 Subtype_Indication (Component_Definition (Def)));
1518 end Analyze_Formal_Array_Type;
1520 ---------------------------------------------
1521 -- Analyze_Formal_Decimal_Fixed_Point_Type --
1522 ---------------------------------------------
1524 -- As for other generic types, we create a valid type representation with
1525 -- legal but arbitrary attributes, whose values are never considered
1526 -- static. For all scalar types we introduce an anonymous base type, with
1527 -- the same attributes. We choose the corresponding integer type to be
1528 -- Standard_Integer.
1530 procedure Analyze_Formal_Decimal_Fixed_Point_Type
1534 Loc : constant Source_Ptr := Sloc (Def);
1535 Base : constant Entity_Id :=
1537 (E_Decimal_Fixed_Point_Type,
1538 Current_Scope, Sloc (Def), 'G');
1539 Int_Base : constant Entity_Id := Standard_Integer;
1540 Delta_Val : constant Ureal := Ureal_1;
1541 Digs_Val : constant Uint := Uint_6;
1546 Set_Etype (Base, Base);
1547 Set_Size_Info (Base, Int_Base);
1548 Set_RM_Size (Base, RM_Size (Int_Base));
1549 Set_First_Rep_Item (Base, First_Rep_Item (Int_Base));
1550 Set_Digits_Value (Base, Digs_Val);
1551 Set_Delta_Value (Base, Delta_Val);
1552 Set_Small_Value (Base, Delta_Val);
1553 Set_Scalar_Range (Base,
1555 Low_Bound => Make_Real_Literal (Loc, Ureal_1),
1556 High_Bound => Make_Real_Literal (Loc, Ureal_1)));
1558 Set_Is_Generic_Type (Base);
1559 Set_Parent (Base, Parent (Def));
1561 Set_Ekind (T, E_Decimal_Fixed_Point_Subtype);
1562 Set_Etype (T, Base);
1563 Set_Size_Info (T, Int_Base);
1564 Set_RM_Size (T, RM_Size (Int_Base));
1565 Set_First_Rep_Item (T, First_Rep_Item (Int_Base));
1566 Set_Digits_Value (T, Digs_Val);
1567 Set_Delta_Value (T, Delta_Val);
1568 Set_Small_Value (T, Delta_Val);
1569 Set_Scalar_Range (T, Scalar_Range (Base));
1570 Set_Is_Constrained (T);
1572 Check_Restriction (No_Fixed_Point, Def);
1573 end Analyze_Formal_Decimal_Fixed_Point_Type;
1575 -------------------------------------------
1576 -- Analyze_Formal_Derived_Interface_Type --
1577 -------------------------------------------
1579 procedure Analyze_Formal_Derived_Interface_Type
1584 Loc : constant Source_Ptr := Sloc (Def);
1587 -- Rewrite as a type declaration of a derived type. This ensures that
1588 -- the interface list and primitive operations are properly captured.
1591 Make_Full_Type_Declaration (Loc,
1592 Defining_Identifier => T,
1593 Type_Definition => Def));
1595 Set_Is_Generic_Type (T);
1596 end Analyze_Formal_Derived_Interface_Type;
1598 ---------------------------------
1599 -- Analyze_Formal_Derived_Type --
1600 ---------------------------------
1602 procedure Analyze_Formal_Derived_Type
1607 Loc : constant Source_Ptr := Sloc (Def);
1608 Unk_Disc : constant Boolean := Unknown_Discriminants_Present (N);
1612 Set_Is_Generic_Type (T);
1614 if Private_Present (Def) then
1616 Make_Private_Extension_Declaration (Loc,
1617 Defining_Identifier => T,
1618 Discriminant_Specifications => Discriminant_Specifications (N),
1619 Unknown_Discriminants_Present => Unk_Disc,
1620 Subtype_Indication => Subtype_Mark (Def),
1621 Interface_List => Interface_List (Def));
1623 Set_Abstract_Present (New_N, Abstract_Present (Def));
1624 Set_Limited_Present (New_N, Limited_Present (Def));
1625 Set_Synchronized_Present (New_N, Synchronized_Present (Def));
1629 Make_Full_Type_Declaration (Loc,
1630 Defining_Identifier => T,
1631 Discriminant_Specifications =>
1632 Discriminant_Specifications (Parent (T)),
1634 Make_Derived_Type_Definition (Loc,
1635 Subtype_Indication => Subtype_Mark (Def)));
1637 Set_Abstract_Present
1638 (Type_Definition (New_N), Abstract_Present (Def));
1640 (Type_Definition (New_N), Limited_Present (Def));
1647 if not Is_Composite_Type (T) then
1649 ("unknown discriminants not allowed for elementary types", N);
1651 Set_Has_Unknown_Discriminants (T);
1652 Set_Is_Constrained (T, False);
1656 -- If the parent type has a known size, so does the formal, which makes
1657 -- legal representation clauses that involve the formal.
1659 Set_Size_Known_At_Compile_Time
1660 (T, Size_Known_At_Compile_Time (Entity (Subtype_Mark (Def))));
1661 end Analyze_Formal_Derived_Type;
1663 ----------------------------------
1664 -- Analyze_Formal_Discrete_Type --
1665 ----------------------------------
1667 -- The operations defined for a discrete types are those of an enumeration
1668 -- type. The size is set to an arbitrary value, for use in analyzing the
1671 procedure Analyze_Formal_Discrete_Type (T : Entity_Id; Def : Node_Id) is
1672 Loc : constant Source_Ptr := Sloc (Def);
1676 Base : constant Entity_Id :=
1678 (E_Floating_Point_Type, Current_Scope, Sloc (Def), 'G');
1681 Set_Ekind (T, E_Enumeration_Subtype);
1682 Set_Etype (T, Base);
1685 Set_Is_Generic_Type (T);
1686 Set_Is_Constrained (T);
1688 -- For semantic analysis, the bounds of the type must be set to some
1689 -- non-static value. The simplest is to create attribute nodes for those
1690 -- bounds, that refer to the type itself. These bounds are never
1691 -- analyzed but serve as place-holders.
1694 Make_Attribute_Reference (Loc,
1695 Attribute_Name => Name_First,
1696 Prefix => New_Reference_To (T, Loc));
1700 Make_Attribute_Reference (Loc,
1701 Attribute_Name => Name_Last,
1702 Prefix => New_Reference_To (T, Loc));
1705 Set_Scalar_Range (T,
1710 Set_Ekind (Base, E_Enumeration_Type);
1711 Set_Etype (Base, Base);
1712 Init_Size (Base, 8);
1713 Init_Alignment (Base);
1714 Set_Is_Generic_Type (Base);
1715 Set_Scalar_Range (Base, Scalar_Range (T));
1716 Set_Parent (Base, Parent (Def));
1717 end Analyze_Formal_Discrete_Type;
1719 ----------------------------------
1720 -- Analyze_Formal_Floating_Type --
1721 ---------------------------------
1723 procedure Analyze_Formal_Floating_Type (T : Entity_Id; Def : Node_Id) is
1724 Base : constant Entity_Id :=
1726 (E_Floating_Point_Type, Current_Scope, Sloc (Def), 'G');
1729 -- The various semantic attributes are taken from the predefined type
1730 -- Float, just so that all of them are initialized. Their values are
1731 -- never used because no constant folding or expansion takes place in
1732 -- the generic itself.
1735 Set_Ekind (T, E_Floating_Point_Subtype);
1736 Set_Etype (T, Base);
1737 Set_Size_Info (T, (Standard_Float));
1738 Set_RM_Size (T, RM_Size (Standard_Float));
1739 Set_Digits_Value (T, Digits_Value (Standard_Float));
1740 Set_Scalar_Range (T, Scalar_Range (Standard_Float));
1741 Set_Is_Constrained (T);
1743 Set_Is_Generic_Type (Base);
1744 Set_Etype (Base, Base);
1745 Set_Size_Info (Base, (Standard_Float));
1746 Set_RM_Size (Base, RM_Size (Standard_Float));
1747 Set_Digits_Value (Base, Digits_Value (Standard_Float));
1748 Set_Scalar_Range (Base, Scalar_Range (Standard_Float));
1749 Set_Parent (Base, Parent (Def));
1751 Check_Restriction (No_Floating_Point, Def);
1752 end Analyze_Formal_Floating_Type;
1754 -----------------------------------
1755 -- Analyze_Formal_Interface_Type;--
1756 -----------------------------------
1758 procedure Analyze_Formal_Interface_Type
1763 Loc : constant Source_Ptr := Sloc (N);
1768 Make_Full_Type_Declaration (Loc,
1769 Defining_Identifier => T,
1770 Type_Definition => Def);
1774 Set_Is_Generic_Type (T);
1775 end Analyze_Formal_Interface_Type;
1777 ---------------------------------
1778 -- Analyze_Formal_Modular_Type --
1779 ---------------------------------
1781 procedure Analyze_Formal_Modular_Type (T : Entity_Id; Def : Node_Id) is
1783 -- Apart from their entity kind, generic modular types are treated like
1784 -- signed integer types, and have the same attributes.
1786 Analyze_Formal_Signed_Integer_Type (T, Def);
1787 Set_Ekind (T, E_Modular_Integer_Subtype);
1788 Set_Ekind (Etype (T), E_Modular_Integer_Type);
1790 end Analyze_Formal_Modular_Type;
1792 ---------------------------------------
1793 -- Analyze_Formal_Object_Declaration --
1794 ---------------------------------------
1796 procedure Analyze_Formal_Object_Declaration (N : Node_Id) is
1797 E : constant Node_Id := Default_Expression (N);
1798 Id : constant Node_Id := Defining_Identifier (N);
1805 -- Determine the mode of the formal object
1807 if Out_Present (N) then
1808 K := E_Generic_In_Out_Parameter;
1810 if not In_Present (N) then
1811 Error_Msg_N ("formal generic objects cannot have mode OUT", N);
1815 K := E_Generic_In_Parameter;
1818 if Present (Subtype_Mark (N)) then
1819 Find_Type (Subtype_Mark (N));
1820 T := Entity (Subtype_Mark (N));
1822 -- Verify that there is no redundant null exclusion
1824 if Null_Exclusion_Present (N) then
1825 if not Is_Access_Type (T) then
1827 ("null exclusion can only apply to an access type", N);
1829 elsif Can_Never_Be_Null (T) then
1831 ("`NOT NULL` not allowed (& already excludes null)",
1836 -- Ada 2005 (AI-423): Formal object with an access definition
1839 Check_Access_Definition (N);
1840 T := Access_Definition
1842 N => Access_Definition (N));
1845 if Ekind (T) = E_Incomplete_Type then
1847 Error_Node : Node_Id;
1850 if Present (Subtype_Mark (N)) then
1851 Error_Node := Subtype_Mark (N);
1853 Check_Access_Definition (N);
1854 Error_Node := Access_Definition (N);
1857 Error_Msg_N ("premature usage of incomplete type", Error_Node);
1861 if K = E_Generic_In_Parameter then
1863 -- Ada 2005 (AI-287): Limited aggregates allowed in generic formals
1865 if Ada_Version < Ada_2005 and then Is_Limited_Type (T) then
1867 ("generic formal of mode IN must not be of limited type", N);
1868 Explain_Limited_Type (T, N);
1871 if Is_Abstract_Type (T) then
1873 ("generic formal of mode IN must not be of abstract type", N);
1877 Preanalyze_Spec_Expression (E, T);
1879 if Is_Limited_Type (T) and then not OK_For_Limited_Init (T, E) then
1881 ("initialization not allowed for limited types", E);
1882 Explain_Limited_Type (T, E);
1889 -- Case of generic IN OUT parameter
1892 -- If the formal has an unconstrained type, construct its actual
1893 -- subtype, as is done for subprogram formals. In this fashion, all
1894 -- its uses can refer to specific bounds.
1899 if (Is_Array_Type (T)
1900 and then not Is_Constrained (T))
1902 (Ekind (T) = E_Record_Type
1903 and then Has_Discriminants (T))
1906 Non_Freezing_Ref : constant Node_Id :=
1907 New_Reference_To (Id, Sloc (Id));
1911 -- Make sure the actual subtype doesn't generate bogus freezing
1913 Set_Must_Not_Freeze (Non_Freezing_Ref);
1914 Decl := Build_Actual_Subtype (T, Non_Freezing_Ref);
1915 Insert_Before_And_Analyze (N, Decl);
1916 Set_Actual_Subtype (Id, Defining_Identifier (Decl));
1919 Set_Actual_Subtype (Id, T);
1924 ("initialization not allowed for `IN OUT` formals", N);
1928 if Has_Aspects (N) then
1929 Analyze_Aspect_Specifications (N, Id);
1931 end Analyze_Formal_Object_Declaration;
1933 ----------------------------------------------
1934 -- Analyze_Formal_Ordinary_Fixed_Point_Type --
1935 ----------------------------------------------
1937 procedure Analyze_Formal_Ordinary_Fixed_Point_Type
1941 Loc : constant Source_Ptr := Sloc (Def);
1942 Base : constant Entity_Id :=
1944 (E_Ordinary_Fixed_Point_Type, Current_Scope, Sloc (Def), 'G');
1946 -- The semantic attributes are set for completeness only, their values
1947 -- will never be used, since all properties of the type are non-static.
1950 Set_Ekind (T, E_Ordinary_Fixed_Point_Subtype);
1951 Set_Etype (T, Base);
1952 Set_Size_Info (T, Standard_Integer);
1953 Set_RM_Size (T, RM_Size (Standard_Integer));
1954 Set_Small_Value (T, Ureal_1);
1955 Set_Delta_Value (T, Ureal_1);
1956 Set_Scalar_Range (T,
1958 Low_Bound => Make_Real_Literal (Loc, Ureal_1),
1959 High_Bound => Make_Real_Literal (Loc, Ureal_1)));
1960 Set_Is_Constrained (T);
1962 Set_Is_Generic_Type (Base);
1963 Set_Etype (Base, Base);
1964 Set_Size_Info (Base, Standard_Integer);
1965 Set_RM_Size (Base, RM_Size (Standard_Integer));
1966 Set_Small_Value (Base, Ureal_1);
1967 Set_Delta_Value (Base, Ureal_1);
1968 Set_Scalar_Range (Base, Scalar_Range (T));
1969 Set_Parent (Base, Parent (Def));
1971 Check_Restriction (No_Fixed_Point, Def);
1972 end Analyze_Formal_Ordinary_Fixed_Point_Type;
1974 ----------------------------------------
1975 -- Analyze_Formal_Package_Declaration --
1976 ----------------------------------------
1978 procedure Analyze_Formal_Package_Declaration (N : Node_Id) is
1979 Loc : constant Source_Ptr := Sloc (N);
1980 Pack_Id : constant Entity_Id := Defining_Identifier (N);
1982 Gen_Id : constant Node_Id := Name (N);
1984 Gen_Unit : Entity_Id;
1986 Parent_Installed : Boolean := False;
1988 Parent_Instance : Entity_Id;
1989 Renaming_In_Par : Entity_Id;
1990 No_Associations : Boolean := False;
1992 function Build_Local_Package return Node_Id;
1993 -- The formal package is rewritten so that its parameters are replaced
1994 -- with corresponding declarations. For parameters with bona fide
1995 -- associations these declarations are created by Analyze_Associations
1996 -- as for a regular instantiation. For boxed parameters, we preserve
1997 -- the formal declarations and analyze them, in order to introduce
1998 -- entities of the right kind in the environment of the formal.
2000 -------------------------
2001 -- Build_Local_Package --
2002 -------------------------
2004 function Build_Local_Package return Node_Id is
2006 Pack_Decl : Node_Id;
2009 -- Within the formal, the name of the generic package is a renaming
2010 -- of the formal (as for a regular instantiation).
2013 Make_Package_Declaration (Loc,
2016 (Specification (Original_Node (Gen_Decl)),
2017 Empty, Instantiating => True));
2019 Renaming := Make_Package_Renaming_Declaration (Loc,
2020 Defining_Unit_Name =>
2021 Make_Defining_Identifier (Loc, Chars (Gen_Unit)),
2022 Name => New_Occurrence_Of (Formal, Loc));
2024 if Nkind (Gen_Id) = N_Identifier
2025 and then Chars (Gen_Id) = Chars (Pack_Id)
2028 ("& is hidden within declaration of instance", Gen_Id, Gen_Unit);
2031 -- If the formal is declared with a box, or with an others choice,
2032 -- create corresponding declarations for all entities in the formal
2033 -- part, so that names with the proper types are available in the
2034 -- specification of the formal package.
2036 -- On the other hand, if there are no associations, then all the
2037 -- formals must have defaults, and this will be checked by the
2038 -- call to Analyze_Associations.
2041 or else Nkind (First (Generic_Associations (N))) = N_Others_Choice
2044 Formal_Decl : Node_Id;
2047 -- TBA : for a formal package, need to recurse ???
2052 (Generic_Formal_Declarations (Original_Node (Gen_Decl)));
2053 while Present (Formal_Decl) loop
2055 (Decls, Copy_Generic_Node (Formal_Decl, Empty, True));
2060 -- If generic associations are present, use Analyze_Associations to
2061 -- create the proper renaming declarations.
2065 Act_Tree : constant Node_Id :=
2067 (Original_Node (Gen_Decl), Empty,
2068 Instantiating => True);
2071 Generic_Renamings.Set_Last (0);
2072 Generic_Renamings_HTable.Reset;
2073 Instantiation_Node := N;
2076 Analyze_Associations
2078 Generic_Formal_Declarations (Act_Tree),
2079 Generic_Formal_Declarations (Gen_Decl));
2083 Append (Renaming, To => Decls);
2085 -- Add generated declarations ahead of local declarations in
2088 if No (Visible_Declarations (Specification (Pack_Decl))) then
2089 Set_Visible_Declarations (Specification (Pack_Decl), Decls);
2092 (First (Visible_Declarations (Specification (Pack_Decl))),
2097 end Build_Local_Package;
2099 -- Start of processing for Analyze_Formal_Package
2102 Text_IO_Kludge (Gen_Id);
2105 Check_Generic_Child_Unit (Gen_Id, Parent_Installed);
2106 Gen_Unit := Entity (Gen_Id);
2108 -- Check for a formal package that is a package renaming
2110 if Present (Renamed_Object (Gen_Unit)) then
2112 -- Indicate that unit is used, before replacing it with renamed
2113 -- entity for use below.
2115 if In_Extended_Main_Source_Unit (N) then
2116 Set_Is_Instantiated (Gen_Unit);
2117 Generate_Reference (Gen_Unit, N);
2120 Gen_Unit := Renamed_Object (Gen_Unit);
2123 if Ekind (Gen_Unit) /= E_Generic_Package then
2124 Error_Msg_N ("expect generic package name", Gen_Id);
2128 elsif Gen_Unit = Current_Scope then
2130 ("generic package cannot be used as a formal package of itself",
2135 elsif In_Open_Scopes (Gen_Unit) then
2136 if Is_Compilation_Unit (Gen_Unit)
2137 and then Is_Child_Unit (Current_Scope)
2139 -- Special-case the error when the formal is a parent, and
2140 -- continue analysis to minimize cascaded errors.
2143 ("generic parent cannot be used as formal package "
2144 & "of a child unit",
2149 ("generic package cannot be used as a formal package "
2158 or else No (Generic_Associations (N))
2159 or else Nkind (First (Generic_Associations (N))) = N_Others_Choice
2161 No_Associations := True;
2164 -- If there are no generic associations, the generic parameters appear
2165 -- as local entities and are instantiated like them. We copy the generic
2166 -- package declaration as if it were an instantiation, and analyze it
2167 -- like a regular package, except that we treat the formals as
2168 -- additional visible components.
2170 Gen_Decl := Unit_Declaration_Node (Gen_Unit);
2172 if In_Extended_Main_Source_Unit (N) then
2173 Set_Is_Instantiated (Gen_Unit);
2174 Generate_Reference (Gen_Unit, N);
2177 Formal := New_Copy (Pack_Id);
2178 Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment);
2181 -- Make local generic without formals. The formals will be replaced
2182 -- with internal declarations.
2184 New_N := Build_Local_Package;
2186 -- If there are errors in the parameter list, Analyze_Associations
2187 -- raises Instantiation_Error. Patch the declaration to prevent
2188 -- further exception propagation.
2191 when Instantiation_Error =>
2193 Enter_Name (Formal);
2194 Set_Ekind (Formal, E_Variable);
2195 Set_Etype (Formal, Any_Type);
2197 if Parent_Installed then
2205 Set_Defining_Unit_Name (Specification (New_N), Formal);
2206 Set_Generic_Parent (Specification (N), Gen_Unit);
2207 Set_Instance_Env (Gen_Unit, Formal);
2208 Set_Is_Generic_Instance (Formal);
2210 Enter_Name (Formal);
2211 Set_Ekind (Formal, E_Package);
2212 Set_Etype (Formal, Standard_Void_Type);
2213 Set_Inner_Instances (Formal, New_Elmt_List);
2214 Push_Scope (Formal);
2216 if Is_Child_Unit (Gen_Unit)
2217 and then Parent_Installed
2219 -- Similarly, we have to make the name of the formal visible in the
2220 -- parent instance, to resolve properly fully qualified names that
2221 -- may appear in the generic unit. The parent instance has been
2222 -- placed on the scope stack ahead of the current scope.
2224 Parent_Instance := Scope_Stack.Table (Scope_Stack.Last - 1).Entity;
2227 Make_Defining_Identifier (Loc, Chars (Gen_Unit));
2228 Set_Ekind (Renaming_In_Par, E_Package);
2229 Set_Etype (Renaming_In_Par, Standard_Void_Type);
2230 Set_Scope (Renaming_In_Par, Parent_Instance);
2231 Set_Parent (Renaming_In_Par, Parent (Formal));
2232 Set_Renamed_Object (Renaming_In_Par, Formal);
2233 Append_Entity (Renaming_In_Par, Parent_Instance);
2236 Analyze (Specification (N));
2238 -- The formals for which associations are provided are not visible
2239 -- outside of the formal package. The others are still declared by a
2240 -- formal parameter declaration.
2242 if not No_Associations then
2247 E := First_Entity (Formal);
2248 while Present (E) loop
2249 exit when Ekind (E) = E_Package
2250 and then Renamed_Entity (E) = Formal;
2252 if not Is_Generic_Formal (E) then
2261 End_Package_Scope (Formal);
2263 if Parent_Installed then
2269 -- Inside the generic unit, the formal package is a regular package, but
2270 -- no body is needed for it. Note that after instantiation, the defining
2271 -- unit name we need is in the new tree and not in the original (see
2272 -- Package_Instantiation). A generic formal package is an instance, and
2273 -- can be used as an actual for an inner instance.
2275 Set_Has_Completion (Formal, True);
2277 -- Add semantic information to the original defining identifier.
2280 Set_Ekind (Pack_Id, E_Package);
2281 Set_Etype (Pack_Id, Standard_Void_Type);
2282 Set_Scope (Pack_Id, Scope (Formal));
2283 Set_Has_Completion (Pack_Id, True);
2286 if Has_Aspects (N) then
2287 Analyze_Aspect_Specifications (N, Pack_Id);
2289 end Analyze_Formal_Package_Declaration;
2291 ---------------------------------
2292 -- Analyze_Formal_Private_Type --
2293 ---------------------------------
2295 procedure Analyze_Formal_Private_Type
2301 New_Private_Type (N, T, Def);
2303 -- Set the size to an arbitrary but legal value
2305 Set_Size_Info (T, Standard_Integer);
2306 Set_RM_Size (T, RM_Size (Standard_Integer));
2307 end Analyze_Formal_Private_Type;
2309 ----------------------------------------
2310 -- Analyze_Formal_Signed_Integer_Type --
2311 ----------------------------------------
2313 procedure Analyze_Formal_Signed_Integer_Type
2317 Base : constant Entity_Id :=
2319 (E_Signed_Integer_Type, Current_Scope, Sloc (Def), 'G');
2324 Set_Ekind (T, E_Signed_Integer_Subtype);
2325 Set_Etype (T, Base);
2326 Set_Size_Info (T, Standard_Integer);
2327 Set_RM_Size (T, RM_Size (Standard_Integer));
2328 Set_Scalar_Range (T, Scalar_Range (Standard_Integer));
2329 Set_Is_Constrained (T);
2331 Set_Is_Generic_Type (Base);
2332 Set_Size_Info (Base, Standard_Integer);
2333 Set_RM_Size (Base, RM_Size (Standard_Integer));
2334 Set_Etype (Base, Base);
2335 Set_Scalar_Range (Base, Scalar_Range (Standard_Integer));
2336 Set_Parent (Base, Parent (Def));
2337 end Analyze_Formal_Signed_Integer_Type;
2339 -------------------------------------------
2340 -- Analyze_Formal_Subprogram_Declaration --
2341 -------------------------------------------
2343 procedure Analyze_Formal_Subprogram_Declaration (N : Node_Id) is
2344 Spec : constant Node_Id := Specification (N);
2345 Def : constant Node_Id := Default_Name (N);
2346 Nam : constant Entity_Id := Defining_Unit_Name (Spec);
2354 if Nkind (Nam) = N_Defining_Program_Unit_Name then
2355 Error_Msg_N ("name of formal subprogram must be a direct name", Nam);
2359 Analyze_Subprogram_Declaration (N);
2360 Set_Is_Formal_Subprogram (Nam);
2361 Set_Has_Completion (Nam);
2363 if Nkind (N) = N_Formal_Abstract_Subprogram_Declaration then
2364 Set_Is_Abstract_Subprogram (Nam);
2365 Set_Is_Dispatching_Operation (Nam);
2368 Ctrl_Type : constant Entity_Id := Find_Dispatching_Type (Nam);
2370 if No (Ctrl_Type) then
2372 ("abstract formal subprogram must have a controlling type",
2375 Check_Controlling_Formals (Ctrl_Type, Nam);
2380 -- Default name is resolved at the point of instantiation
2382 if Box_Present (N) then
2385 -- Else default is bound at the point of generic declaration
2387 elsif Present (Def) then
2388 if Nkind (Def) = N_Operator_Symbol then
2389 Find_Direct_Name (Def);
2391 elsif Nkind (Def) /= N_Attribute_Reference then
2395 -- For an attribute reference, analyze the prefix and verify
2396 -- that it has the proper profile for the subprogram.
2398 Analyze (Prefix (Def));
2399 Valid_Default_Attribute (Nam, Def);
2403 -- Default name may be overloaded, in which case the interpretation
2404 -- with the correct profile must be selected, as for a renaming.
2405 -- If the definition is an indexed component, it must denote a
2406 -- member of an entry family. If it is a selected component, it
2407 -- can be a protected operation.
2409 if Etype (Def) = Any_Type then
2412 elsif Nkind (Def) = N_Selected_Component then
2413 if not Is_Overloadable (Entity (Selector_Name (Def))) then
2414 Error_Msg_N ("expect valid subprogram name as default", Def);
2417 elsif Nkind (Def) = N_Indexed_Component then
2418 if Is_Entity_Name (Prefix (Def)) then
2419 if Ekind (Entity (Prefix (Def))) /= E_Entry_Family then
2420 Error_Msg_N ("expect valid subprogram name as default", Def);
2423 elsif Nkind (Prefix (Def)) = N_Selected_Component then
2424 if Ekind (Entity (Selector_Name (Prefix (Def)))) /=
2427 Error_Msg_N ("expect valid subprogram name as default", Def);
2431 Error_Msg_N ("expect valid subprogram name as default", Def);
2435 elsif Nkind (Def) = N_Character_Literal then
2437 -- Needs some type checks: subprogram should be parameterless???
2439 Resolve (Def, (Etype (Nam)));
2441 elsif not Is_Entity_Name (Def)
2442 or else not Is_Overloadable (Entity (Def))
2444 Error_Msg_N ("expect valid subprogram name as default", Def);
2447 elsif not Is_Overloaded (Def) then
2448 Subp := Entity (Def);
2451 Error_Msg_N ("premature usage of formal subprogram", Def);
2453 elsif not Entity_Matches_Spec (Subp, Nam) then
2454 Error_Msg_N ("no visible entity matches specification", Def);
2457 -- More than one interpretation, so disambiguate as for a renaming
2462 I1 : Interp_Index := 0;
2468 Get_First_Interp (Def, I, It);
2469 while Present (It.Nam) loop
2470 if Entity_Matches_Spec (It.Nam, Nam) then
2471 if Subp /= Any_Id then
2472 It1 := Disambiguate (Def, I1, I, Etype (Subp));
2474 if It1 = No_Interp then
2475 Error_Msg_N ("ambiguous default subprogram", Def);
2488 Get_Next_Interp (I, It);
2492 if Subp /= Any_Id then
2493 Set_Entity (Def, Subp);
2496 Error_Msg_N ("premature usage of formal subprogram", Def);
2498 elsif Ekind (Subp) /= E_Operator then
2499 Check_Mode_Conformant (Subp, Nam);
2503 Error_Msg_N ("no visible subprogram matches specification", N);
2509 if Has_Aspects (N) then
2510 Analyze_Aspect_Specifications (N, Nam);
2513 end Analyze_Formal_Subprogram_Declaration;
2515 -------------------------------------
2516 -- Analyze_Formal_Type_Declaration --
2517 -------------------------------------
2519 procedure Analyze_Formal_Type_Declaration (N : Node_Id) is
2520 Def : constant Node_Id := Formal_Type_Definition (N);
2524 T := Defining_Identifier (N);
2526 if Present (Discriminant_Specifications (N))
2527 and then Nkind (Def) /= N_Formal_Private_Type_Definition
2530 ("discriminants not allowed for this formal type", T);
2533 -- Enter the new name, and branch to specific routine
2536 when N_Formal_Private_Type_Definition =>
2537 Analyze_Formal_Private_Type (N, T, Def);
2539 when N_Formal_Derived_Type_Definition =>
2540 Analyze_Formal_Derived_Type (N, T, Def);
2542 when N_Formal_Discrete_Type_Definition =>
2543 Analyze_Formal_Discrete_Type (T, Def);
2545 when N_Formal_Signed_Integer_Type_Definition =>
2546 Analyze_Formal_Signed_Integer_Type (T, Def);
2548 when N_Formal_Modular_Type_Definition =>
2549 Analyze_Formal_Modular_Type (T, Def);
2551 when N_Formal_Floating_Point_Definition =>
2552 Analyze_Formal_Floating_Type (T, Def);
2554 when N_Formal_Ordinary_Fixed_Point_Definition =>
2555 Analyze_Formal_Ordinary_Fixed_Point_Type (T, Def);
2557 when N_Formal_Decimal_Fixed_Point_Definition =>
2558 Analyze_Formal_Decimal_Fixed_Point_Type (T, Def);
2560 when N_Array_Type_Definition =>
2561 Analyze_Formal_Array_Type (T, Def);
2563 when N_Access_To_Object_Definition |
2564 N_Access_Function_Definition |
2565 N_Access_Procedure_Definition =>
2566 Analyze_Generic_Access_Type (T, Def);
2568 -- Ada 2005: a interface declaration is encoded as an abstract
2569 -- record declaration or a abstract type derivation.
2571 when N_Record_Definition =>
2572 Analyze_Formal_Interface_Type (N, T, Def);
2574 when N_Derived_Type_Definition =>
2575 Analyze_Formal_Derived_Interface_Type (N, T, Def);
2581 raise Program_Error;
2585 Set_Is_Generic_Type (T);
2587 if Has_Aspects (N) then
2588 Analyze_Aspect_Specifications (N, T);
2590 end Analyze_Formal_Type_Declaration;
2592 ------------------------------------
2593 -- Analyze_Function_Instantiation --
2594 ------------------------------------
2596 procedure Analyze_Function_Instantiation (N : Node_Id) is
2598 Analyze_Subprogram_Instantiation (N, E_Function);
2599 end Analyze_Function_Instantiation;
2601 ---------------------------------
2602 -- Analyze_Generic_Access_Type --
2603 ---------------------------------
2605 procedure Analyze_Generic_Access_Type (T : Entity_Id; Def : Node_Id) is
2609 if Nkind (Def) = N_Access_To_Object_Definition then
2610 Access_Type_Declaration (T, Def);
2612 if Is_Incomplete_Or_Private_Type (Designated_Type (T))
2613 and then No (Full_View (Designated_Type (T)))
2614 and then not Is_Generic_Type (Designated_Type (T))
2616 Error_Msg_N ("premature usage of incomplete type", Def);
2618 elsif not Is_Entity_Name (Subtype_Indication (Def)) then
2620 ("only a subtype mark is allowed in a formal", Def);
2624 Access_Subprogram_Declaration (T, Def);
2626 end Analyze_Generic_Access_Type;
2628 ---------------------------------
2629 -- Analyze_Generic_Formal_Part --
2630 ---------------------------------
2632 procedure Analyze_Generic_Formal_Part (N : Node_Id) is
2633 Gen_Parm_Decl : Node_Id;
2636 -- The generic formals are processed in the scope of the generic unit,
2637 -- where they are immediately visible. The scope is installed by the
2640 Gen_Parm_Decl := First (Generic_Formal_Declarations (N));
2642 while Present (Gen_Parm_Decl) loop
2643 Analyze (Gen_Parm_Decl);
2644 Next (Gen_Parm_Decl);
2647 Generate_Reference_To_Generic_Formals (Current_Scope);
2648 end Analyze_Generic_Formal_Part;
2650 ------------------------------------------
2651 -- Analyze_Generic_Package_Declaration --
2652 ------------------------------------------
2654 procedure Analyze_Generic_Package_Declaration (N : Node_Id) is
2655 Loc : constant Source_Ptr := Sloc (N);
2658 Save_Parent : Node_Id;
2660 Decls : constant List_Id :=
2661 Visible_Declarations (Specification (N));
2665 -- We introduce a renaming of the enclosing package, to have a usable
2666 -- entity as the prefix of an expanded name for a local entity of the
2667 -- form Par.P.Q, where P is the generic package. This is because a local
2668 -- entity named P may hide it, so that the usual visibility rules in
2669 -- the instance will not resolve properly.
2672 Make_Package_Renaming_Declaration (Loc,
2673 Defining_Unit_Name =>
2674 Make_Defining_Identifier (Loc,
2675 Chars => New_External_Name (Chars (Defining_Entity (N)), "GH")),
2676 Name => Make_Identifier (Loc, Chars (Defining_Entity (N))));
2678 if Present (Decls) then
2679 Decl := First (Decls);
2680 while Present (Decl)
2681 and then Nkind (Decl) = N_Pragma
2686 if Present (Decl) then
2687 Insert_Before (Decl, Renaming);
2689 Append (Renaming, Visible_Declarations (Specification (N)));
2693 Set_Visible_Declarations (Specification (N), New_List (Renaming));
2696 -- Create copy of generic unit, and save for instantiation. If the unit
2697 -- is a child unit, do not copy the specifications for the parent, which
2698 -- are not part of the generic tree.
2700 Save_Parent := Parent_Spec (N);
2701 Set_Parent_Spec (N, Empty);
2703 New_N := Copy_Generic_Node (N, Empty, Instantiating => False);
2704 Set_Parent_Spec (New_N, Save_Parent);
2706 Id := Defining_Entity (N);
2707 Generate_Definition (Id);
2709 -- Expansion is not applied to generic units
2714 Set_Ekind (Id, E_Generic_Package);
2715 Set_Etype (Id, Standard_Void_Type);
2717 Enter_Generic_Scope (Id);
2718 Set_Inner_Instances (Id, New_Elmt_List);
2720 Set_Categorization_From_Pragmas (N);
2721 Set_Is_Pure (Id, Is_Pure (Current_Scope));
2723 -- Link the declaration of the generic homonym in the generic copy to
2724 -- the package it renames, so that it is always resolved properly.
2726 Set_Generic_Homonym (Id, Defining_Unit_Name (Renaming));
2727 Set_Entity (Associated_Node (Name (Renaming)), Id);
2729 -- For a library unit, we have reconstructed the entity for the unit,
2730 -- and must reset it in the library tables.
2732 if Nkind (Parent (N)) = N_Compilation_Unit then
2733 Set_Cunit_Entity (Current_Sem_Unit, Id);
2736 Analyze_Generic_Formal_Part (N);
2738 -- After processing the generic formals, analysis proceeds as for a
2739 -- non-generic package.
2741 Analyze (Specification (N));
2743 Validate_Categorization_Dependency (N, Id);
2747 End_Package_Scope (Id);
2748 Exit_Generic_Scope (Id);
2750 if Nkind (Parent (N)) /= N_Compilation_Unit then
2751 Move_Freeze_Nodes (Id, N, Visible_Declarations (Specification (N)));
2752 Move_Freeze_Nodes (Id, N, Private_Declarations (Specification (N)));
2753 Move_Freeze_Nodes (Id, N, Generic_Formal_Declarations (N));
2756 Set_Body_Required (Parent (N), Unit_Requires_Body (Id));
2757 Validate_RT_RAT_Component (N);
2759 -- If this is a spec without a body, check that generic parameters
2762 if not Body_Required (Parent (N)) then
2763 Check_References (Id);
2767 if Has_Aspects (N) then
2768 Analyze_Aspect_Specifications (N, Id);
2770 end Analyze_Generic_Package_Declaration;
2772 --------------------------------------------
2773 -- Analyze_Generic_Subprogram_Declaration --
2774 --------------------------------------------
2776 procedure Analyze_Generic_Subprogram_Declaration (N : Node_Id) is
2781 Result_Type : Entity_Id;
2782 Save_Parent : Node_Id;
2786 -- Create copy of generic unit, and save for instantiation. If the unit
2787 -- is a child unit, do not copy the specifications for the parent, which
2788 -- are not part of the generic tree.
2790 Save_Parent := Parent_Spec (N);
2791 Set_Parent_Spec (N, Empty);
2793 New_N := Copy_Generic_Node (N, Empty, Instantiating => False);
2794 Set_Parent_Spec (New_N, Save_Parent);
2797 Spec := Specification (N);
2798 Id := Defining_Entity (Spec);
2799 Generate_Definition (Id);
2801 if Nkind (Id) = N_Defining_Operator_Symbol then
2803 ("operator symbol not allowed for generic subprogram", Id);
2810 Set_Scope_Depth_Value (Id, Scope_Depth (Current_Scope) + 1);
2812 Enter_Generic_Scope (Id);
2813 Set_Inner_Instances (Id, New_Elmt_List);
2814 Set_Is_Pure (Id, Is_Pure (Current_Scope));
2816 Analyze_Generic_Formal_Part (N);
2818 Formals := Parameter_Specifications (Spec);
2820 if Present (Formals) then
2821 Process_Formals (Formals, Spec);
2824 if Nkind (Spec) = N_Function_Specification then
2825 Set_Ekind (Id, E_Generic_Function);
2827 if Nkind (Result_Definition (Spec)) = N_Access_Definition then
2828 Result_Type := Access_Definition (Spec, Result_Definition (Spec));
2829 Set_Etype (Id, Result_Type);
2831 -- Check restriction imposed by AI05-073: a generic function
2832 -- cannot return an abstract type or an access to such.
2834 -- This is a binding interpretation should it apply to earlier
2835 -- versions of Ada as well as Ada 2012???
2837 if Is_Abstract_Type (Designated_Type (Result_Type))
2838 and then Ada_Version >= Ada_2012
2840 Error_Msg_N ("generic function cannot have an access result"
2841 & " that designates an abstract type", Spec);
2845 Find_Type (Result_Definition (Spec));
2846 Typ := Entity (Result_Definition (Spec));
2848 if Is_Abstract_Type (Typ)
2849 and then Ada_Version >= Ada_2012
2852 ("generic function cannot have abstract result type", Spec);
2855 -- If a null exclusion is imposed on the result type, then create
2856 -- a null-excluding itype (an access subtype) and use it as the
2857 -- function's Etype.
2859 if Is_Access_Type (Typ)
2860 and then Null_Exclusion_Present (Spec)
2863 Create_Null_Excluding_Itype
2865 Related_Nod => Spec,
2866 Scope_Id => Defining_Unit_Name (Spec)));
2868 Set_Etype (Id, Typ);
2873 Set_Ekind (Id, E_Generic_Procedure);
2874 Set_Etype (Id, Standard_Void_Type);
2877 -- For a library unit, we have reconstructed the entity for the unit,
2878 -- and must reset it in the library tables. We also make sure that
2879 -- Body_Required is set properly in the original compilation unit node.
2881 if Nkind (Parent (N)) = N_Compilation_Unit then
2882 Set_Cunit_Entity (Current_Sem_Unit, Id);
2883 Set_Body_Required (Parent (N), Unit_Requires_Body (Id));
2886 Set_Categorization_From_Pragmas (N);
2887 Validate_Categorization_Dependency (N, Id);
2889 Save_Global_References (Original_Node (N));
2893 Exit_Generic_Scope (Id);
2894 Generate_Reference_To_Formals (Id);
2896 List_Inherited_Pre_Post_Aspects (Id);
2898 if Has_Aspects (N) then
2899 Analyze_Aspect_Specifications (N, Id);
2901 end Analyze_Generic_Subprogram_Declaration;
2903 -----------------------------------
2904 -- Analyze_Package_Instantiation --
2905 -----------------------------------
2907 procedure Analyze_Package_Instantiation (N : Node_Id) is
2908 Loc : constant Source_Ptr := Sloc (N);
2909 Gen_Id : constant Node_Id := Name (N);
2912 Act_Decl_Name : Node_Id;
2913 Act_Decl_Id : Entity_Id;
2918 Gen_Unit : Entity_Id;
2920 Is_Actual_Pack : constant Boolean :=
2921 Is_Internal (Defining_Entity (N));
2923 Env_Installed : Boolean := False;
2924 Parent_Installed : Boolean := False;
2925 Renaming_List : List_Id;
2926 Unit_Renaming : Node_Id;
2927 Needs_Body : Boolean;
2928 Inline_Now : Boolean := False;
2930 procedure Delay_Descriptors (E : Entity_Id);
2931 -- Delay generation of subprogram descriptors for given entity
2933 function Might_Inline_Subp return Boolean;
2934 -- If inlining is active and the generic contains inlined subprograms,
2935 -- we instantiate the body. This may cause superfluous instantiations,
2936 -- but it is simpler than detecting the need for the body at the point
2937 -- of inlining, when the context of the instance is not available.
2939 -----------------------
2940 -- Delay_Descriptors --
2941 -----------------------
2943 procedure Delay_Descriptors (E : Entity_Id) is
2945 if not Delay_Subprogram_Descriptors (E) then
2946 Set_Delay_Subprogram_Descriptors (E);
2947 Pending_Descriptor.Append (E);
2949 end Delay_Descriptors;
2951 -----------------------
2952 -- Might_Inline_Subp --
2953 -----------------------
2955 function Might_Inline_Subp return Boolean is
2959 if not Inline_Processing_Required then
2963 E := First_Entity (Gen_Unit);
2964 while Present (E) loop
2965 if Is_Subprogram (E)
2966 and then Is_Inlined (E)
2976 end Might_Inline_Subp;
2978 -- Start of processing for Analyze_Package_Instantiation
2981 -- Very first thing: apply the special kludge for Text_IO processing
2982 -- in case we are instantiating one of the children of [Wide_]Text_IO.
2984 Text_IO_Kludge (Name (N));
2986 -- Make node global for error reporting
2988 Instantiation_Node := N;
2990 -- Case of instantiation of a generic package
2992 if Nkind (N) = N_Package_Instantiation then
2993 Act_Decl_Id := New_Copy (Defining_Entity (N));
2994 Set_Comes_From_Source (Act_Decl_Id, True);
2996 if Nkind (Defining_Unit_Name (N)) = N_Defining_Program_Unit_Name then
2998 Make_Defining_Program_Unit_Name (Loc,
2999 Name => New_Copy_Tree (Name (Defining_Unit_Name (N))),
3000 Defining_Identifier => Act_Decl_Id);
3002 Act_Decl_Name := Act_Decl_Id;
3005 -- Case of instantiation of a formal package
3008 Act_Decl_Id := Defining_Identifier (N);
3009 Act_Decl_Name := Act_Decl_Id;
3012 Generate_Definition (Act_Decl_Id);
3013 Preanalyze_Actuals (N);
3016 Env_Installed := True;
3018 -- Reset renaming map for formal types. The mapping is established
3019 -- when analyzing the generic associations, but some mappings are
3020 -- inherited from formal packages of parent units, and these are
3021 -- constructed when the parents are installed.
3023 Generic_Renamings.Set_Last (0);
3024 Generic_Renamings_HTable.Reset;
3026 Check_Generic_Child_Unit (Gen_Id, Parent_Installed);
3027 Gen_Unit := Entity (Gen_Id);
3029 -- Verify that it is the name of a generic package
3031 -- A visibility glitch: if the instance is a child unit and the generic
3032 -- is the generic unit of a parent instance (i.e. both the parent and
3033 -- the child units are instances of the same package) the name now
3034 -- denotes the renaming within the parent, not the intended generic
3035 -- unit. See if there is a homonym that is the desired generic. The
3036 -- renaming declaration must be visible inside the instance of the
3037 -- child, but not when analyzing the name in the instantiation itself.
3039 if Ekind (Gen_Unit) = E_Package
3040 and then Present (Renamed_Entity (Gen_Unit))
3041 and then In_Open_Scopes (Renamed_Entity (Gen_Unit))
3042 and then Is_Generic_Instance (Renamed_Entity (Gen_Unit))
3043 and then Present (Homonym (Gen_Unit))
3045 Gen_Unit := Homonym (Gen_Unit);
3048 if Etype (Gen_Unit) = Any_Type then
3052 elsif Ekind (Gen_Unit) /= E_Generic_Package then
3054 -- Ada 2005 (AI-50217): Cannot use instance in limited with_clause
3056 if From_With_Type (Gen_Unit) then
3058 ("cannot instantiate a limited withed package", Gen_Id);
3061 ("expect name of generic package in instantiation", Gen_Id);
3068 if In_Extended_Main_Source_Unit (N) then
3069 Set_Is_Instantiated (Gen_Unit);
3070 Generate_Reference (Gen_Unit, N);
3072 if Present (Renamed_Object (Gen_Unit)) then
3073 Set_Is_Instantiated (Renamed_Object (Gen_Unit));
3074 Generate_Reference (Renamed_Object (Gen_Unit), N);
3078 if Nkind (Gen_Id) = N_Identifier
3079 and then Chars (Gen_Unit) = Chars (Defining_Entity (N))
3082 ("& is hidden within declaration of instance", Gen_Id, Gen_Unit);
3084 elsif Nkind (Gen_Id) = N_Expanded_Name
3085 and then Is_Child_Unit (Gen_Unit)
3086 and then Nkind (Prefix (Gen_Id)) = N_Identifier
3087 and then Chars (Act_Decl_Id) = Chars (Prefix (Gen_Id))
3090 ("& is hidden within declaration of instance ", Prefix (Gen_Id));
3093 Set_Entity (Gen_Id, Gen_Unit);
3095 -- If generic is a renaming, get original generic unit
3097 if Present (Renamed_Object (Gen_Unit))
3098 and then Ekind (Renamed_Object (Gen_Unit)) = E_Generic_Package
3100 Gen_Unit := Renamed_Object (Gen_Unit);
3103 -- Verify that there are no circular instantiations
3105 if In_Open_Scopes (Gen_Unit) then
3106 Error_Msg_NE ("instantiation of & within itself", N, Gen_Unit);
3110 elsif Contains_Instance_Of (Gen_Unit, Current_Scope, Gen_Id) then
3111 Error_Msg_Node_2 := Current_Scope;
3113 ("circular Instantiation: & instantiated in &!", N, Gen_Unit);
3114 Circularity_Detected := True;
3119 Gen_Decl := Unit_Declaration_Node (Gen_Unit);
3121 -- Initialize renamings map, for error checking, and the list that
3122 -- holds private entities whose views have changed between generic
3123 -- definition and instantiation. If this is the instance created to
3124 -- validate an actual package, the instantiation environment is that
3125 -- of the enclosing instance.
3127 Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment);
3129 -- Copy original generic tree, to produce text for instantiation
3133 (Original_Node (Gen_Decl), Empty, Instantiating => True);
3135 Act_Spec := Specification (Act_Tree);
3137 -- If this is the instance created to validate an actual package,
3138 -- only the formals matter, do not examine the package spec itself.
3140 if Is_Actual_Pack then
3141 Set_Visible_Declarations (Act_Spec, New_List);
3142 Set_Private_Declarations (Act_Spec, New_List);
3146 Analyze_Associations
3148 Generic_Formal_Declarations (Act_Tree),
3149 Generic_Formal_Declarations (Gen_Decl));
3151 Set_Instance_Env (Gen_Unit, Act_Decl_Id);
3152 Set_Defining_Unit_Name (Act_Spec, Act_Decl_Name);
3153 Set_Is_Generic_Instance (Act_Decl_Id);
3155 Set_Generic_Parent (Act_Spec, Gen_Unit);
3157 -- References to the generic in its own declaration or its body are
3158 -- references to the instance. Add a renaming declaration for the
3159 -- generic unit itself. This declaration, as well as the renaming
3160 -- declarations for the generic formals, must remain private to the
3161 -- unit: the formals, because this is the language semantics, and
3162 -- the unit because its use is an artifact of the implementation.
3165 Make_Package_Renaming_Declaration (Loc,
3166 Defining_Unit_Name =>
3167 Make_Defining_Identifier (Loc, Chars (Gen_Unit)),
3168 Name => New_Reference_To (Act_Decl_Id, Loc));
3170 Append (Unit_Renaming, Renaming_List);
3172 -- The renaming declarations are the first local declarations of
3175 if Is_Non_Empty_List (Visible_Declarations (Act_Spec)) then
3177 (First (Visible_Declarations (Act_Spec)), Renaming_List);
3179 Set_Visible_Declarations (Act_Spec, Renaming_List);
3183 Make_Package_Declaration (Loc,
3184 Specification => Act_Spec);
3186 -- Save the instantiation node, for subsequent instantiation of the
3187 -- body, if there is one and we are generating code for the current
3188 -- unit. Mark the unit as having a body, to avoid a premature error
3191 -- We instantiate the body if we are generating code, if we are
3192 -- generating cross-reference information, or if we are building
3193 -- trees for ASIS use.
3196 Enclosing_Body_Present : Boolean := False;
3197 -- If the generic unit is not a compilation unit, then a body may
3198 -- be present in its parent even if none is required. We create a
3199 -- tentative pending instantiation for the body, which will be
3200 -- discarded if none is actually present.
3205 if Scope (Gen_Unit) /= Standard_Standard
3206 and then not Is_Child_Unit (Gen_Unit)
3208 Scop := Scope (Gen_Unit);
3210 while Present (Scop)
3211 and then Scop /= Standard_Standard
3213 if Unit_Requires_Body (Scop) then
3214 Enclosing_Body_Present := True;
3217 elsif In_Open_Scopes (Scop)
3218 and then In_Package_Body (Scop)
3220 Enclosing_Body_Present := True;
3224 exit when Is_Compilation_Unit (Scop);
3225 Scop := Scope (Scop);
3229 -- If front-end inlining is enabled, and this is a unit for which
3230 -- code will be generated, we instantiate the body at once.
3232 -- This is done if the instance is not the main unit, and if the
3233 -- generic is not a child unit of another generic, to avoid scope
3234 -- problems and the reinstallation of parent instances.
3237 and then (not Is_Child_Unit (Gen_Unit)
3238 or else not Is_Generic_Unit (Scope (Gen_Unit)))
3239 and then Might_Inline_Subp
3240 and then not Is_Actual_Pack
3242 if Front_End_Inlining
3243 and then (Is_In_Main_Unit (N)
3244 or else In_Main_Context (Current_Scope))
3245 and then Nkind (Parent (N)) /= N_Compilation_Unit
3249 -- In configurable_run_time mode we force the inlining of
3250 -- predefined subprograms marked Inline_Always, to minimize
3251 -- the use of the run-time library.
3253 elsif Is_Predefined_File_Name
3254 (Unit_File_Name (Get_Source_Unit (Gen_Decl)))
3255 and then Configurable_Run_Time_Mode
3256 and then Nkind (Parent (N)) /= N_Compilation_Unit
3261 -- If the current scope is itself an instance within a child
3262 -- unit, there will be duplications in the scope stack, and the
3263 -- unstacking mechanism in Inline_Instance_Body will fail.
3264 -- This loses some rare cases of optimization, and might be
3265 -- improved some day, if we can find a proper abstraction for
3266 -- "the complete compilation context" that can be saved and
3269 if Is_Generic_Instance (Current_Scope) then
3271 Curr_Unit : constant Entity_Id :=
3272 Cunit_Entity (Current_Sem_Unit);
3274 if Curr_Unit /= Current_Scope
3275 and then Is_Child_Unit (Curr_Unit)
3277 Inline_Now := False;
3284 (Unit_Requires_Body (Gen_Unit)
3285 or else Enclosing_Body_Present
3286 or else Present (Corresponding_Body (Gen_Decl)))
3287 and then (Is_In_Main_Unit (N)
3288 or else Might_Inline_Subp)
3289 and then not Is_Actual_Pack
3290 and then not Inline_Now
3291 and then (Operating_Mode = Generate_Code
3292 or else (Operating_Mode = Check_Semantics
3293 and then ASIS_Mode));
3295 -- If front_end_inlining is enabled, do not instantiate body if
3296 -- within a generic context.
3298 if (Front_End_Inlining
3299 and then not Expander_Active)
3300 or else Is_Generic_Unit (Cunit_Entity (Main_Unit))
3302 Needs_Body := False;
3305 -- If the current context is generic, and the package being
3306 -- instantiated is declared within a formal package, there is no
3307 -- body to instantiate until the enclosing generic is instantiated
3308 -- and there is an actual for the formal package. If the formal
3309 -- package has parameters, we build a regular package instance for
3310 -- it, that precedes the original formal package declaration.
3312 if In_Open_Scopes (Scope (Scope (Gen_Unit))) then
3314 Decl : constant Node_Id :=
3316 (Unit_Declaration_Node (Scope (Gen_Unit)));
3318 if Nkind (Decl) = N_Formal_Package_Declaration
3319 or else (Nkind (Decl) = N_Package_Declaration
3320 and then Is_List_Member (Decl)
3321 and then Present (Next (Decl))
3323 Nkind (Next (Decl)) =
3324 N_Formal_Package_Declaration)
3326 Needs_Body := False;
3332 -- If we are generating calling stubs, we never need a body for an
3333 -- instantiation from source. However normal processing occurs for
3334 -- any generic instantiation appearing in generated code, since we
3335 -- do not generate stubs in that case.
3337 if Distribution_Stub_Mode = Generate_Caller_Stub_Body
3338 and then Comes_From_Source (N)
3340 Needs_Body := False;
3345 -- Here is a defence against a ludicrous number of instantiations
3346 -- caused by a circular set of instantiation attempts.
3348 if Pending_Instantiations.Last >
3349 Hostparm.Max_Instantiations
3351 Error_Msg_N ("too many instantiations", N);
3352 raise Unrecoverable_Error;
3355 -- Indicate that the enclosing scopes contain an instantiation,
3356 -- and that cleanup actions should be delayed until after the
3357 -- instance body is expanded.
3359 Check_Forward_Instantiation (Gen_Decl);
3360 if Nkind (N) = N_Package_Instantiation then
3362 Enclosing_Master : Entity_Id;
3365 -- Loop to search enclosing masters
3367 Enclosing_Master := Current_Scope;
3368 Scope_Loop : while Enclosing_Master /= Standard_Standard loop
3369 if Ekind (Enclosing_Master) = E_Package then
3370 if Is_Compilation_Unit (Enclosing_Master) then
3371 if In_Package_Body (Enclosing_Master) then
3373 (Body_Entity (Enclosing_Master));
3382 Enclosing_Master := Scope (Enclosing_Master);
3385 elsif Ekind (Enclosing_Master) = E_Generic_Package then
3386 Enclosing_Master := Scope (Enclosing_Master);
3388 elsif Is_Generic_Subprogram (Enclosing_Master)
3389 or else Ekind (Enclosing_Master) = E_Void
3391 -- Cleanup actions will eventually be performed on the
3392 -- enclosing instance, if any. Enclosing scope is void
3393 -- in the formal part of a generic subprogram.
3398 if Ekind (Enclosing_Master) = E_Entry
3400 Ekind (Scope (Enclosing_Master)) = E_Protected_Type
3402 if not Expander_Active then
3406 Protected_Body_Subprogram (Enclosing_Master);
3410 Set_Delay_Cleanups (Enclosing_Master);
3412 while Ekind (Enclosing_Master) = E_Block loop
3413 Enclosing_Master := Scope (Enclosing_Master);
3416 if Is_Subprogram (Enclosing_Master) then
3417 Delay_Descriptors (Enclosing_Master);
3419 elsif Is_Task_Type (Enclosing_Master) then
3421 TBP : constant Node_Id :=
3422 Get_Task_Body_Procedure
3425 if Present (TBP) then
3426 Delay_Descriptors (TBP);
3427 Set_Delay_Cleanups (TBP);
3434 end loop Scope_Loop;
3437 -- Make entry in table
3439 Pending_Instantiations.Append
3441 Act_Decl => Act_Decl,
3442 Expander_Status => Expander_Active,
3443 Current_Sem_Unit => Current_Sem_Unit,
3444 Scope_Suppress => Scope_Suppress,
3445 Local_Suppress_Stack_Top => Local_Suppress_Stack_Top,
3446 Version => Ada_Version));
3450 Set_Categorization_From_Pragmas (Act_Decl);
3452 if Parent_Installed then
3456 Set_Instance_Spec (N, Act_Decl);
3458 -- If not a compilation unit, insert the package declaration before
3459 -- the original instantiation node.
3461 if Nkind (Parent (N)) /= N_Compilation_Unit then
3462 Mark_Rewrite_Insertion (Act_Decl);
3463 Insert_Before (N, Act_Decl);
3466 -- For an instantiation that is a compilation unit, place declaration
3467 -- on current node so context is complete for analysis (including
3468 -- nested instantiations). If this is the main unit, the declaration
3469 -- eventually replaces the instantiation node. If the instance body
3470 -- is created later, it replaces the instance node, and the
3471 -- declaration is attached to it (see
3472 -- Build_Instance_Compilation_Unit_Nodes).
3475 if Cunit_Entity (Current_Sem_Unit) = Defining_Entity (N) then
3477 -- The entity for the current unit is the newly created one,
3478 -- and all semantic information is attached to it.
3480 Set_Cunit_Entity (Current_Sem_Unit, Act_Decl_Id);
3482 -- If this is the main unit, replace the main entity as well
3484 if Current_Sem_Unit = Main_Unit then
3485 Main_Unit_Entity := Act_Decl_Id;
3489 Set_Unit (Parent (N), Act_Decl);
3490 Set_Parent_Spec (Act_Decl, Parent_Spec (N));
3491 Set_Package_Instantiation (Act_Decl_Id, N);
3493 Set_Unit (Parent (N), N);
3494 Set_Body_Required (Parent (N), False);
3496 -- We never need elaboration checks on instantiations, since by
3497 -- definition, the body instantiation is elaborated at the same
3498 -- time as the spec instantiation.
3500 Set_Suppress_Elaboration_Warnings (Act_Decl_Id);
3501 Set_Kill_Elaboration_Checks (Act_Decl_Id);
3504 Check_Elab_Instantiation (N);
3506 if ABE_Is_Certain (N) and then Needs_Body then
3507 Pending_Instantiations.Decrement_Last;
3510 Check_Hidden_Child_Unit (N, Gen_Unit, Act_Decl_Id);
3512 Set_First_Private_Entity (Defining_Unit_Name (Unit_Renaming),
3513 First_Private_Entity (Act_Decl_Id));
3515 -- If the instantiation will receive a body, the unit will be
3516 -- transformed into a package body, and receive its own elaboration
3517 -- entity. Otherwise, the nature of the unit is now a package
3520 if Nkind (Parent (N)) = N_Compilation_Unit
3521 and then not Needs_Body
3523 Rewrite (N, Act_Decl);
3526 if Present (Corresponding_Body (Gen_Decl))
3527 or else Unit_Requires_Body (Gen_Unit)
3529 Set_Has_Completion (Act_Decl_Id);
3532 Check_Formal_Packages (Act_Decl_Id);
3534 Restore_Private_Views (Act_Decl_Id);
3536 Inherit_Context (Gen_Decl, N);
3538 if Parent_Installed then
3543 Env_Installed := False;
3546 Validate_Categorization_Dependency (N, Act_Decl_Id);
3548 -- There used to be a check here to prevent instantiations in local
3549 -- contexts if the No_Local_Allocators restriction was active. This
3550 -- check was removed by a binding interpretation in AI-95-00130/07,
3551 -- but we retain the code for documentation purposes.
3553 -- if Ekind (Act_Decl_Id) /= E_Void
3554 -- and then not Is_Library_Level_Entity (Act_Decl_Id)
3556 -- Check_Restriction (No_Local_Allocators, N);
3560 Inline_Instance_Body (N, Gen_Unit, Act_Decl);
3563 -- The following is a tree patch for ASIS: ASIS needs separate nodes to
3564 -- be used as defining identifiers for a formal package and for the
3565 -- corresponding expanded package.
3567 if Nkind (N) = N_Formal_Package_Declaration then
3568 Act_Decl_Id := New_Copy (Defining_Entity (N));
3569 Set_Comes_From_Source (Act_Decl_Id, True);
3570 Set_Is_Generic_Instance (Act_Decl_Id, False);
3571 Set_Defining_Identifier (N, Act_Decl_Id);
3575 if Has_Aspects (N) then
3576 Analyze_Aspect_Specifications (N, Act_Decl_Id);
3580 when Instantiation_Error =>
3581 if Parent_Installed then
3585 if Env_Installed then
3588 end Analyze_Package_Instantiation;
3590 --------------------------
3591 -- Inline_Instance_Body --
3592 --------------------------
3594 procedure Inline_Instance_Body
3596 Gen_Unit : Entity_Id;
3600 Gen_Comp : constant Entity_Id :=
3601 Cunit_Entity (Get_Source_Unit (Gen_Unit));
3602 Curr_Comp : constant Node_Id := Cunit (Current_Sem_Unit);
3603 Curr_Scope : Entity_Id := Empty;
3604 Curr_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
3605 Removed : Boolean := False;
3606 Num_Scopes : Int := 0;
3608 Scope_Stack_Depth : constant Int :=
3609 Scope_Stack.Last - Scope_Stack.First + 1;
3611 Use_Clauses : array (1 .. Scope_Stack_Depth) of Node_Id;
3612 Instances : array (1 .. Scope_Stack_Depth) of Entity_Id;
3613 Inner_Scopes : array (1 .. Scope_Stack_Depth) of Entity_Id;
3614 Num_Inner : Int := 0;
3615 N_Instances : Int := 0;
3619 -- Case of generic unit defined in another unit. We must remove the
3620 -- complete context of the current unit to install that of the generic.
3622 if Gen_Comp /= Cunit_Entity (Current_Sem_Unit) then
3624 -- Add some comments for the following two loops ???
3627 while Present (S) and then S /= Standard_Standard loop
3629 Num_Scopes := Num_Scopes + 1;
3631 Use_Clauses (Num_Scopes) :=
3633 (Scope_Stack.Last - Num_Scopes + 1).
3635 End_Use_Clauses (Use_Clauses (Num_Scopes));
3637 exit when Scope_Stack.Last - Num_Scopes + 1 = Scope_Stack.First
3638 or else Scope_Stack.Table
3639 (Scope_Stack.Last - Num_Scopes).Entity
3643 exit when Is_Generic_Instance (S)
3644 and then (In_Package_Body (S)
3645 or else Ekind (S) = E_Procedure
3646 or else Ekind (S) = E_Function);
3650 Vis := Is_Immediately_Visible (Gen_Comp);
3652 -- Find and save all enclosing instances
3657 and then S /= Standard_Standard
3659 if Is_Generic_Instance (S) then
3660 N_Instances := N_Instances + 1;
3661 Instances (N_Instances) := S;
3663 exit when In_Package_Body (S);
3669 -- Remove context of current compilation unit, unless we are within a
3670 -- nested package instantiation, in which case the context has been
3671 -- removed previously.
3673 -- If current scope is the body of a child unit, remove context of
3674 -- spec as well. If an enclosing scope is an instance body, the
3675 -- context has already been removed, but the entities in the body
3676 -- must be made invisible as well.
3681 and then S /= Standard_Standard
3683 if Is_Generic_Instance (S)
3684 and then (In_Package_Body (S)
3685 or else Ekind (S) = E_Procedure
3686 or else Ekind (S) = E_Function)
3688 -- We still have to remove the entities of the enclosing
3689 -- instance from direct visibility.
3694 E := First_Entity (S);
3695 while Present (E) loop
3696 Set_Is_Immediately_Visible (E, False);
3705 or else (Ekind (Curr_Unit) = E_Package_Body
3706 and then S = Spec_Entity (Curr_Unit))
3707 or else (Ekind (Curr_Unit) = E_Subprogram_Body
3710 (Unit_Declaration_Node (Curr_Unit)))
3714 -- Remove entities in current scopes from visibility, so that
3715 -- instance body is compiled in a clean environment.
3717 Save_Scope_Stack (Handle_Use => False);
3719 if Is_Child_Unit (S) then
3721 -- Remove child unit from stack, as well as inner scopes.
3722 -- Removing the context of a child unit removes parent units
3725 while Current_Scope /= S loop
3726 Num_Inner := Num_Inner + 1;
3727 Inner_Scopes (Num_Inner) := Current_Scope;
3732 Remove_Context (Curr_Comp);
3736 Remove_Context (Curr_Comp);
3739 if Ekind (Curr_Unit) = E_Package_Body then
3740 Remove_Context (Library_Unit (Curr_Comp));
3746 pragma Assert (Num_Inner < Num_Scopes);
3748 Push_Scope (Standard_Standard);
3749 Scope_Stack.Table (Scope_Stack.Last).Is_Active_Stack_Base := True;
3750 Instantiate_Package_Body
3753 Act_Decl => Act_Decl,
3754 Expander_Status => Expander_Active,
3755 Current_Sem_Unit => Current_Sem_Unit,
3756 Scope_Suppress => Scope_Suppress,
3757 Local_Suppress_Stack_Top => Local_Suppress_Stack_Top,
3758 Version => Ada_Version)),
3759 Inlined_Body => True);
3765 Set_Is_Immediately_Visible (Gen_Comp, Vis);
3767 -- Reset Generic_Instance flag so that use clauses can be installed
3768 -- in the proper order. (See Use_One_Package for effect of enclosing
3769 -- instances on processing of use clauses).
3771 for J in 1 .. N_Instances loop
3772 Set_Is_Generic_Instance (Instances (J), False);
3776 Install_Context (Curr_Comp);
3778 if Present (Curr_Scope)
3779 and then Is_Child_Unit (Curr_Scope)
3781 Push_Scope (Curr_Scope);
3782 Set_Is_Immediately_Visible (Curr_Scope);
3784 -- Finally, restore inner scopes as well
3786 for J in reverse 1 .. Num_Inner loop
3787 Push_Scope (Inner_Scopes (J));
3791 Restore_Scope_Stack (Handle_Use => False);
3793 if Present (Curr_Scope)
3795 (In_Private_Part (Curr_Scope)
3796 or else In_Package_Body (Curr_Scope))
3798 -- Install private declaration of ancestor units, which are
3799 -- currently available. Restore_Scope_Stack and Install_Context
3800 -- only install the visible part of parents.
3805 Par := Scope (Curr_Scope);
3806 while (Present (Par))
3807 and then Par /= Standard_Standard
3809 Install_Private_Declarations (Par);
3816 -- Restore use clauses. For a child unit, use clauses in the parents
3817 -- are restored when installing the context, so only those in inner
3818 -- scopes (and those local to the child unit itself) need to be
3819 -- installed explicitly.
3821 if Is_Child_Unit (Curr_Unit)
3824 for J in reverse 1 .. Num_Inner + 1 loop
3825 Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause :=
3827 Install_Use_Clauses (Use_Clauses (J));
3831 for J in reverse 1 .. Num_Scopes loop
3832 Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause :=
3834 Install_Use_Clauses (Use_Clauses (J));
3838 -- Restore status of instances. If one of them is a body, make
3839 -- its local entities visible again.
3846 for J in 1 .. N_Instances loop
3847 Inst := Instances (J);
3848 Set_Is_Generic_Instance (Inst, True);
3850 if In_Package_Body (Inst)
3851 or else Ekind (S) = E_Procedure
3852 or else Ekind (S) = E_Function
3854 E := First_Entity (Instances (J));
3855 while Present (E) loop
3856 Set_Is_Immediately_Visible (E);
3863 -- If generic unit is in current unit, current context is correct
3866 Instantiate_Package_Body
3869 Act_Decl => Act_Decl,
3870 Expander_Status => Expander_Active,
3871 Current_Sem_Unit => Current_Sem_Unit,
3872 Scope_Suppress => Scope_Suppress,
3873 Local_Suppress_Stack_Top => Local_Suppress_Stack_Top,
3874 Version => Ada_Version)),
3875 Inlined_Body => True);
3877 end Inline_Instance_Body;
3879 -------------------------------------
3880 -- Analyze_Procedure_Instantiation --
3881 -------------------------------------
3883 procedure Analyze_Procedure_Instantiation (N : Node_Id) is
3885 Analyze_Subprogram_Instantiation (N, E_Procedure);
3886 end Analyze_Procedure_Instantiation;
3888 -----------------------------------
3889 -- Need_Subprogram_Instance_Body --
3890 -----------------------------------
3892 function Need_Subprogram_Instance_Body
3894 Subp : Entity_Id) return Boolean
3897 if (Is_In_Main_Unit (N)
3898 or else Is_Inlined (Subp)
3899 or else Is_Inlined (Alias (Subp)))
3900 and then (Operating_Mode = Generate_Code
3901 or else (Operating_Mode = Check_Semantics
3902 and then ASIS_Mode))
3903 and then (Expander_Active or else ASIS_Mode)
3904 and then not ABE_Is_Certain (N)
3905 and then not Is_Eliminated (Subp)
3907 Pending_Instantiations.Append
3909 Act_Decl => Unit_Declaration_Node (Subp),
3910 Expander_Status => Expander_Active,
3911 Current_Sem_Unit => Current_Sem_Unit,
3912 Scope_Suppress => Scope_Suppress,
3913 Local_Suppress_Stack_Top => Local_Suppress_Stack_Top,
3914 Version => Ada_Version));
3919 end Need_Subprogram_Instance_Body;
3921 --------------------------------------
3922 -- Analyze_Subprogram_Instantiation --
3923 --------------------------------------
3925 procedure Analyze_Subprogram_Instantiation
3929 Loc : constant Source_Ptr := Sloc (N);
3930 Gen_Id : constant Node_Id := Name (N);
3932 Anon_Id : constant Entity_Id :=
3933 Make_Defining_Identifier (Sloc (Defining_Entity (N)),
3934 Chars => New_External_Name
3935 (Chars (Defining_Entity (N)), 'R'));
3937 Act_Decl_Id : Entity_Id;
3942 Env_Installed : Boolean := False;
3943 Gen_Unit : Entity_Id;
3945 Pack_Id : Entity_Id;
3946 Parent_Installed : Boolean := False;
3947 Renaming_List : List_Id;
3949 procedure Analyze_Instance_And_Renamings;
3950 -- The instance must be analyzed in a context that includes the mappings
3951 -- of generic parameters into actuals. We create a package declaration
3952 -- for this purpose, and a subprogram with an internal name within the
3953 -- package. The subprogram instance is simply an alias for the internal
3954 -- subprogram, declared in the current scope.
3956 ------------------------------------
3957 -- Analyze_Instance_And_Renamings --
3958 ------------------------------------
3960 procedure Analyze_Instance_And_Renamings is
3961 Def_Ent : constant Entity_Id := Defining_Entity (N);
3962 Pack_Decl : Node_Id;
3965 if Nkind (Parent (N)) = N_Compilation_Unit then
3967 -- For the case of a compilation unit, the container package has
3968 -- the same name as the instantiation, to insure that the binder
3969 -- calls the elaboration procedure with the right name. Copy the
3970 -- entity of the instance, which may have compilation level flags
3971 -- (e.g. Is_Child_Unit) set.
3973 Pack_Id := New_Copy (Def_Ent);
3976 -- Otherwise we use the name of the instantiation concatenated
3977 -- with its source position to ensure uniqueness if there are
3978 -- several instantiations with the same name.
3981 Make_Defining_Identifier (Loc,
3982 Chars => New_External_Name
3983 (Related_Id => Chars (Def_Ent),
3985 Suffix_Index => Source_Offset (Sloc (Def_Ent))));
3988 Pack_Decl := Make_Package_Declaration (Loc,
3989 Specification => Make_Package_Specification (Loc,
3990 Defining_Unit_Name => Pack_Id,
3991 Visible_Declarations => Renaming_List,
3992 End_Label => Empty));
3994 Set_Instance_Spec (N, Pack_Decl);
3995 Set_Is_Generic_Instance (Pack_Id);
3996 Set_Debug_Info_Needed (Pack_Id);
3998 -- Case of not a compilation unit
4000 if Nkind (Parent (N)) /= N_Compilation_Unit then
4001 Mark_Rewrite_Insertion (Pack_Decl);
4002 Insert_Before (N, Pack_Decl);
4003 Set_Has_Completion (Pack_Id);
4005 -- Case of an instantiation that is a compilation unit
4007 -- Place declaration on current node so context is complete for
4008 -- analysis (including nested instantiations), and for use in a
4009 -- context_clause (see Analyze_With_Clause).
4012 Set_Unit (Parent (N), Pack_Decl);
4013 Set_Parent_Spec (Pack_Decl, Parent_Spec (N));
4016 Analyze (Pack_Decl);
4017 Check_Formal_Packages (Pack_Id);
4018 Set_Is_Generic_Instance (Pack_Id, False);
4020 -- Why do we clear Is_Generic_Instance??? We set it 20 lines
4023 -- Body of the enclosing package is supplied when instantiating the
4024 -- subprogram body, after semantic analysis is completed.
4026 if Nkind (Parent (N)) = N_Compilation_Unit then
4028 -- Remove package itself from visibility, so it does not
4029 -- conflict with subprogram.
4031 Set_Name_Entity_Id (Chars (Pack_Id), Homonym (Pack_Id));
4033 -- Set name and scope of internal subprogram so that the proper
4034 -- external name will be generated. The proper scope is the scope
4035 -- of the wrapper package. We need to generate debugging info for
4036 -- the internal subprogram, so set flag accordingly.
4038 Set_Chars (Anon_Id, Chars (Defining_Entity (N)));
4039 Set_Scope (Anon_Id, Scope (Pack_Id));
4041 -- Mark wrapper package as referenced, to avoid spurious warnings
4042 -- if the instantiation appears in various with_ clauses of
4043 -- subunits of the main unit.
4045 Set_Referenced (Pack_Id);
4048 Set_Is_Generic_Instance (Anon_Id);
4049 Set_Debug_Info_Needed (Anon_Id);
4050 Act_Decl_Id := New_Copy (Anon_Id);
4052 Set_Parent (Act_Decl_Id, Parent (Anon_Id));
4053 Set_Chars (Act_Decl_Id, Chars (Defining_Entity (N)));
4054 Set_Sloc (Act_Decl_Id, Sloc (Defining_Entity (N)));
4055 Set_Comes_From_Source (Act_Decl_Id, True);
4057 -- The signature may involve types that are not frozen yet, but the
4058 -- subprogram will be frozen at the point the wrapper package is
4059 -- frozen, so it does not need its own freeze node. In fact, if one
4060 -- is created, it might conflict with the freezing actions from the
4063 Set_Has_Delayed_Freeze (Anon_Id, False);
4065 -- If the instance is a child unit, mark the Id accordingly. Mark
4066 -- the anonymous entity as well, which is the real subprogram and
4067 -- which is used when the instance appears in a context clause.
4068 -- Similarly, propagate the Is_Eliminated flag to handle properly
4069 -- nested eliminated subprograms.
4071 Set_Is_Child_Unit (Act_Decl_Id, Is_Child_Unit (Defining_Entity (N)));
4072 Set_Is_Child_Unit (Anon_Id, Is_Child_Unit (Defining_Entity (N)));
4073 New_Overloaded_Entity (Act_Decl_Id);
4074 Check_Eliminated (Act_Decl_Id);
4075 Set_Is_Eliminated (Anon_Id, Is_Eliminated (Act_Decl_Id));
4077 -- In compilation unit case, kill elaboration checks on the
4078 -- instantiation, since they are never needed -- the body is
4079 -- instantiated at the same point as the spec.
4081 if Nkind (Parent (N)) = N_Compilation_Unit then
4082 Set_Suppress_Elaboration_Warnings (Act_Decl_Id);
4083 Set_Kill_Elaboration_Checks (Act_Decl_Id);
4084 Set_Is_Compilation_Unit (Anon_Id);
4086 Set_Cunit_Entity (Current_Sem_Unit, Pack_Id);
4089 -- The instance is not a freezing point for the new subprogram
4091 Set_Is_Frozen (Act_Decl_Id, False);
4093 if Nkind (Defining_Entity (N)) = N_Defining_Operator_Symbol then
4094 Valid_Operator_Definition (Act_Decl_Id);
4097 Set_Alias (Act_Decl_Id, Anon_Id);
4098 Set_Parent (Act_Decl_Id, Parent (Anon_Id));
4099 Set_Has_Completion (Act_Decl_Id);
4100 Set_Related_Instance (Pack_Id, Act_Decl_Id);
4102 if Nkind (Parent (N)) = N_Compilation_Unit then
4103 Set_Body_Required (Parent (N), False);
4105 end Analyze_Instance_And_Renamings;
4107 -- Start of processing for Analyze_Subprogram_Instantiation
4110 -- Very first thing: apply the special kludge for Text_IO processing
4111 -- in case we are instantiating one of the children of [Wide_]Text_IO.
4112 -- Of course such an instantiation is bogus (these are packages, not
4113 -- subprograms), but we get a better error message if we do this.
4115 Text_IO_Kludge (Gen_Id);
4117 -- Make node global for error reporting
4119 Instantiation_Node := N;
4120 Preanalyze_Actuals (N);
4123 Env_Installed := True;
4124 Check_Generic_Child_Unit (Gen_Id, Parent_Installed);
4125 Gen_Unit := Entity (Gen_Id);
4127 Generate_Reference (Gen_Unit, Gen_Id);
4129 if Nkind (Gen_Id) = N_Identifier
4130 and then Chars (Gen_Unit) = Chars (Defining_Entity (N))
4133 ("& is hidden within declaration of instance", Gen_Id, Gen_Unit);
4136 if Etype (Gen_Unit) = Any_Type then
4141 -- Verify that it is a generic subprogram of the right kind, and that
4142 -- it does not lead to a circular instantiation.
4144 if not Ekind_In (Gen_Unit, E_Generic_Procedure, E_Generic_Function) then
4145 Error_Msg_N ("expect generic subprogram in instantiation", Gen_Id);
4147 elsif In_Open_Scopes (Gen_Unit) then
4148 Error_Msg_NE ("instantiation of & within itself", N, Gen_Unit);
4150 elsif K = E_Procedure
4151 and then Ekind (Gen_Unit) /= E_Generic_Procedure
4153 if Ekind (Gen_Unit) = E_Generic_Function then
4155 ("cannot instantiate generic function as procedure", Gen_Id);
4158 ("expect name of generic procedure in instantiation", Gen_Id);
4161 elsif K = E_Function
4162 and then Ekind (Gen_Unit) /= E_Generic_Function
4164 if Ekind (Gen_Unit) = E_Generic_Procedure then
4166 ("cannot instantiate generic procedure as function", Gen_Id);
4169 ("expect name of generic function in instantiation", Gen_Id);
4173 Set_Entity (Gen_Id, Gen_Unit);
4174 Set_Is_Instantiated (Gen_Unit);
4176 if In_Extended_Main_Source_Unit (N) then
4177 Generate_Reference (Gen_Unit, N);
4180 -- If renaming, get original unit
4182 if Present (Renamed_Object (Gen_Unit))
4183 and then (Ekind (Renamed_Object (Gen_Unit)) = E_Generic_Procedure
4185 Ekind (Renamed_Object (Gen_Unit)) = E_Generic_Function)
4187 Gen_Unit := Renamed_Object (Gen_Unit);
4188 Set_Is_Instantiated (Gen_Unit);
4189 Generate_Reference (Gen_Unit, N);
4192 if Contains_Instance_Of (Gen_Unit, Current_Scope, Gen_Id) then
4193 Error_Msg_Node_2 := Current_Scope;
4195 ("circular Instantiation: & instantiated in &!", N, Gen_Unit);
4196 Circularity_Detected := True;
4200 Gen_Decl := Unit_Declaration_Node (Gen_Unit);
4202 -- Initialize renamings map, for error checking
4204 Generic_Renamings.Set_Last (0);
4205 Generic_Renamings_HTable.Reset;
4207 Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment);
4209 -- Copy original generic tree, to produce text for instantiation
4213 (Original_Node (Gen_Decl), Empty, Instantiating => True);
4215 -- Inherit overriding indicator from instance node
4217 Act_Spec := Specification (Act_Tree);
4218 Set_Must_Override (Act_Spec, Must_Override (N));
4219 Set_Must_Not_Override (Act_Spec, Must_Not_Override (N));
4222 Analyze_Associations
4224 Generic_Formal_Declarations (Act_Tree),
4225 Generic_Formal_Declarations (Gen_Decl));
4227 -- The subprogram itself cannot contain a nested instance, so the
4228 -- current parent is left empty.
4230 Set_Instance_Env (Gen_Unit, Empty);
4232 -- Build the subprogram declaration, which does not appear in the
4233 -- generic template, and give it a sloc consistent with that of the
4236 Set_Defining_Unit_Name (Act_Spec, Anon_Id);
4237 Set_Generic_Parent (Act_Spec, Gen_Unit);
4239 Make_Subprogram_Declaration (Sloc (Act_Spec),
4240 Specification => Act_Spec);
4242 Set_Categorization_From_Pragmas (Act_Decl);
4244 if Parent_Installed then
4248 Append (Act_Decl, Renaming_List);
4249 Analyze_Instance_And_Renamings;
4251 -- If the generic is marked Import (Intrinsic), then so is the
4252 -- instance. This indicates that there is no body to instantiate. If
4253 -- generic is marked inline, so it the instance, and the anonymous
4254 -- subprogram it renames. If inlined, or else if inlining is enabled
4255 -- for the compilation, we generate the instance body even if it is
4256 -- not within the main unit.
4258 -- Any other pragmas might also be inherited ???
4260 if Is_Intrinsic_Subprogram (Gen_Unit) then
4261 Set_Is_Intrinsic_Subprogram (Anon_Id);
4262 Set_Is_Intrinsic_Subprogram (Act_Decl_Id);
4264 if Chars (Gen_Unit) = Name_Unchecked_Conversion then
4265 Validate_Unchecked_Conversion (N, Act_Decl_Id);
4269 Generate_Definition (Act_Decl_Id);
4271 Set_Is_Inlined (Act_Decl_Id, Is_Inlined (Gen_Unit));
4272 Set_Is_Inlined (Anon_Id, Is_Inlined (Gen_Unit));
4274 if not Is_Intrinsic_Subprogram (Gen_Unit) then
4275 Check_Elab_Instantiation (N);
4278 if Is_Dispatching_Operation (Act_Decl_Id)
4279 and then Ada_Version >= Ada_2005
4285 Formal := First_Formal (Act_Decl_Id);
4286 while Present (Formal) loop
4287 if Ekind (Etype (Formal)) = E_Anonymous_Access_Type
4288 and then Is_Controlling_Formal (Formal)
4289 and then not Can_Never_Be_Null (Formal)
4291 Error_Msg_NE ("access parameter& is controlling,",
4294 ("\corresponding parameter of & must be"
4295 & " explicitly null-excluding", N, Gen_Id);
4298 Next_Formal (Formal);
4303 Check_Hidden_Child_Unit (N, Gen_Unit, Act_Decl_Id);
4305 -- Subject to change, pending on if other pragmas are inherited ???
4307 Validate_Categorization_Dependency (N, Act_Decl_Id);
4309 if not Is_Intrinsic_Subprogram (Act_Decl_Id) then
4310 Inherit_Context (Gen_Decl, N);
4312 Restore_Private_Views (Pack_Id, False);
4314 -- If the context requires a full instantiation, mark node for
4315 -- subsequent construction of the body.
4317 if Need_Subprogram_Instance_Body (N, Act_Decl_Id) then
4319 Check_Forward_Instantiation (Gen_Decl);
4321 -- The wrapper package is always delayed, because it does not
4322 -- constitute a freeze point, but to insure that the freeze
4323 -- node is placed properly, it is created directly when
4324 -- instantiating the body (otherwise the freeze node might
4325 -- appear to early for nested instantiations).
4327 elsif Nkind (Parent (N)) = N_Compilation_Unit then
4329 -- For ASIS purposes, indicate that the wrapper package has
4330 -- replaced the instantiation node.
4332 Rewrite (N, Unit (Parent (N)));
4333 Set_Unit (Parent (N), N);
4336 elsif Nkind (Parent (N)) = N_Compilation_Unit then
4338 -- Replace instance node for library-level instantiations of
4339 -- intrinsic subprograms, for ASIS use.
4341 Rewrite (N, Unit (Parent (N)));
4342 Set_Unit (Parent (N), N);
4345 if Parent_Installed then
4350 Env_Installed := False;
4351 Generic_Renamings.Set_Last (0);
4352 Generic_Renamings_HTable.Reset;
4356 if Has_Aspects (N) then
4357 Analyze_Aspect_Specifications (N, Act_Decl_Id);
4361 when Instantiation_Error =>
4362 if Parent_Installed then
4366 if Env_Installed then
4369 end Analyze_Subprogram_Instantiation;
4371 -------------------------
4372 -- Get_Associated_Node --
4373 -------------------------
4375 function Get_Associated_Node (N : Node_Id) return Node_Id is
4379 Assoc := Associated_Node (N);
4381 if Nkind (Assoc) /= Nkind (N) then
4384 elsif Nkind_In (Assoc, N_Aggregate, N_Extension_Aggregate) then
4388 -- If the node is part of an inner generic, it may itself have been
4389 -- remapped into a further generic copy. Associated_Node is otherwise
4390 -- used for the entity of the node, and will be of a different node
4391 -- kind, or else N has been rewritten as a literal or function call.
4393 while Present (Associated_Node (Assoc))
4394 and then Nkind (Associated_Node (Assoc)) = Nkind (Assoc)
4396 Assoc := Associated_Node (Assoc);
4399 -- Follow and additional link in case the final node was rewritten.
4400 -- This can only happen with nested generic units.
4402 if (Nkind (Assoc) = N_Identifier or else Nkind (Assoc) in N_Op)
4403 and then Present (Associated_Node (Assoc))
4404 and then (Nkind_In (Associated_Node (Assoc), N_Function_Call,
4405 N_Explicit_Dereference,
4410 Assoc := Associated_Node (Assoc);
4415 end Get_Associated_Node;
4417 -------------------------------------------
4418 -- Build_Instance_Compilation_Unit_Nodes --
4419 -------------------------------------------
4421 procedure Build_Instance_Compilation_Unit_Nodes
4426 Decl_Cunit : Node_Id;
4427 Body_Cunit : Node_Id;
4429 New_Main : constant Entity_Id := Defining_Entity (Act_Decl);
4430 Old_Main : constant Entity_Id := Cunit_Entity (Main_Unit);
4433 -- A new compilation unit node is built for the instance declaration
4436 Make_Compilation_Unit (Sloc (N),
4437 Context_Items => Empty_List,
4440 Make_Compilation_Unit_Aux (Sloc (N)));
4442 Set_Parent_Spec (Act_Decl, Parent_Spec (N));
4444 -- The new compilation unit is linked to its body, but both share the
4445 -- same file, so we do not set Body_Required on the new unit so as not
4446 -- to create a spurious dependency on a non-existent body in the ali.
4447 -- This simplifies CodePeer unit traversal.
4449 -- We use the original instantiation compilation unit as the resulting
4450 -- compilation unit of the instance, since this is the main unit.
4452 Rewrite (N, Act_Body);
4453 Body_Cunit := Parent (N);
4455 -- The two compilation unit nodes are linked by the Library_Unit field
4457 Set_Library_Unit (Decl_Cunit, Body_Cunit);
4458 Set_Library_Unit (Body_Cunit, Decl_Cunit);
4460 -- Preserve the private nature of the package if needed
4462 Set_Private_Present (Decl_Cunit, Private_Present (Body_Cunit));
4464 -- If the instance is not the main unit, its context, categorization
4465 -- and elaboration entity are not relevant to the compilation.
4467 if Body_Cunit /= Cunit (Main_Unit) then
4468 Make_Instance_Unit (Body_Cunit, In_Main => False);
4472 -- The context clause items on the instantiation, which are now attached
4473 -- to the body compilation unit (since the body overwrote the original
4474 -- instantiation node), semantically belong on the spec, so copy them
4475 -- there. It's harmless to leave them on the body as well. In fact one
4476 -- could argue that they belong in both places.
4478 Citem := First (Context_Items (Body_Cunit));
4479 while Present (Citem) loop
4480 Append (New_Copy (Citem), Context_Items (Decl_Cunit));
4484 -- Propagate categorization flags on packages, so that they appear in
4485 -- the ali file for the spec of the unit.
4487 if Ekind (New_Main) = E_Package then
4488 Set_Is_Pure (Old_Main, Is_Pure (New_Main));
4489 Set_Is_Preelaborated (Old_Main, Is_Preelaborated (New_Main));
4490 Set_Is_Remote_Types (Old_Main, Is_Remote_Types (New_Main));
4491 Set_Is_Shared_Passive (Old_Main, Is_Shared_Passive (New_Main));
4492 Set_Is_Remote_Call_Interface
4493 (Old_Main, Is_Remote_Call_Interface (New_Main));
4496 -- Make entry in Units table, so that binder can generate call to
4497 -- elaboration procedure for body, if any.
4499 Make_Instance_Unit (Body_Cunit, In_Main => True);
4500 Main_Unit_Entity := New_Main;
4501 Set_Cunit_Entity (Main_Unit, Main_Unit_Entity);
4503 -- Build elaboration entity, since the instance may certainly generate
4504 -- elaboration code requiring a flag for protection.
4506 Build_Elaboration_Entity (Decl_Cunit, New_Main);
4507 end Build_Instance_Compilation_Unit_Nodes;
4509 -----------------------------
4510 -- Check_Access_Definition --
4511 -----------------------------
4513 procedure Check_Access_Definition (N : Node_Id) is
4516 (Ada_Version >= Ada_2005
4517 and then Present (Access_Definition (N)));
4519 end Check_Access_Definition;
4521 -----------------------------------
4522 -- Check_Formal_Package_Instance --
4523 -----------------------------------
4525 -- If the formal has specific parameters, they must match those of the
4526 -- actual. Both of them are instances, and the renaming declarations for
4527 -- their formal parameters appear in the same order in both. The analyzed
4528 -- formal has been analyzed in the context of the current instance.
4530 procedure Check_Formal_Package_Instance
4531 (Formal_Pack : Entity_Id;
4532 Actual_Pack : Entity_Id)
4534 E1 : Entity_Id := First_Entity (Actual_Pack);
4535 E2 : Entity_Id := First_Entity (Formal_Pack);
4540 procedure Check_Mismatch (B : Boolean);
4541 -- Common error routine for mismatch between the parameters of the
4542 -- actual instance and those of the formal package.
4544 function Same_Instantiated_Constant (E1, E2 : Entity_Id) return Boolean;
4545 -- The formal may come from a nested formal package, and the actual may
4546 -- have been constant-folded. To determine whether the two denote the
4547 -- same entity we may have to traverse several definitions to recover
4548 -- the ultimate entity that they refer to.
4550 function Same_Instantiated_Variable (E1, E2 : Entity_Id) return Boolean;
4551 -- Similarly, if the formal comes from a nested formal package, the
4552 -- actual may designate the formal through multiple renamings, which
4553 -- have to be followed to determine the original variable in question.
4555 --------------------
4556 -- Check_Mismatch --
4557 --------------------
4559 procedure Check_Mismatch (B : Boolean) is
4560 Kind : constant Node_Kind := Nkind (Parent (E2));
4563 if Kind = N_Formal_Type_Declaration then
4566 elsif Nkind_In (Kind, N_Formal_Object_Declaration,
4567 N_Formal_Package_Declaration)
4568 or else Kind in N_Formal_Subprogram_Declaration
4574 ("actual for & in actual instance does not match formal",
4575 Parent (Actual_Pack), E1);
4579 --------------------------------
4580 -- Same_Instantiated_Constant --
4581 --------------------------------
4583 function Same_Instantiated_Constant
4584 (E1, E2 : Entity_Id) return Boolean
4590 while Present (Ent) loop
4594 elsif Ekind (Ent) /= E_Constant then
4597 elsif Is_Entity_Name (Constant_Value (Ent)) then
4598 if Entity (Constant_Value (Ent)) = E1 then
4601 Ent := Entity (Constant_Value (Ent));
4604 -- The actual may be a constant that has been folded. Recover
4607 elsif Is_Entity_Name (Original_Node (Constant_Value (Ent))) then
4608 Ent := Entity (Original_Node (Constant_Value (Ent)));
4615 end Same_Instantiated_Constant;
4617 --------------------------------
4618 -- Same_Instantiated_Variable --
4619 --------------------------------
4621 function Same_Instantiated_Variable
4622 (E1, E2 : Entity_Id) return Boolean
4624 function Original_Entity (E : Entity_Id) return Entity_Id;
4625 -- Follow chain of renamings to the ultimate ancestor
4627 ---------------------
4628 -- Original_Entity --
4629 ---------------------
4631 function Original_Entity (E : Entity_Id) return Entity_Id is
4636 while Nkind (Parent (Orig)) = N_Object_Renaming_Declaration
4637 and then Present (Renamed_Object (Orig))
4638 and then Is_Entity_Name (Renamed_Object (Orig))
4640 Orig := Entity (Renamed_Object (Orig));
4644 end Original_Entity;
4646 -- Start of processing for Same_Instantiated_Variable
4649 return Ekind (E1) = Ekind (E2)
4650 and then Original_Entity (E1) = Original_Entity (E2);
4651 end Same_Instantiated_Variable;
4653 -- Start of processing for Check_Formal_Package_Instance
4657 and then Present (E2)
4659 exit when Ekind (E1) = E_Package
4660 and then Renamed_Entity (E1) = Renamed_Entity (Actual_Pack);
4662 -- If the formal is the renaming of the formal package, this
4663 -- is the end of its formal part, which may occur before the
4664 -- end of the formal part in the actual in the presence of
4665 -- defaulted parameters in the formal package.
4667 exit when Nkind (Parent (E2)) = N_Package_Renaming_Declaration
4668 and then Renamed_Entity (E2) = Scope (E2);
4670 -- The analysis of the actual may generate additional internal
4671 -- entities. If the formal is defaulted, there is no corresponding
4672 -- analysis and the internal entities must be skipped, until we
4673 -- find corresponding entities again.
4675 if Comes_From_Source (E2)
4676 and then not Comes_From_Source (E1)
4677 and then Chars (E1) /= Chars (E2)
4680 and then Chars (E1) /= Chars (E2)
4689 -- If the formal entity comes from a formal declaration, it was
4690 -- defaulted in the formal package, and no check is needed on it.
4692 elsif Nkind (Parent (E2)) = N_Formal_Object_Declaration then
4695 elsif Is_Type (E1) then
4697 -- Subtypes must statically match. E1, E2 are the local entities
4698 -- that are subtypes of the actuals. Itypes generated for other
4699 -- parameters need not be checked, the check will be performed
4700 -- on the parameters themselves.
4702 -- If E2 is a formal type declaration, it is a defaulted parameter
4703 -- and needs no checking.
4705 if not Is_Itype (E1)
4706 and then not Is_Itype (E2)
4710 or else Etype (E1) /= Etype (E2)
4711 or else not Subtypes_Statically_Match (E1, E2));
4714 elsif Ekind (E1) = E_Constant then
4716 -- IN parameters must denote the same static value, or the same
4717 -- constant, or the literal null.
4719 Expr1 := Expression (Parent (E1));
4721 if Ekind (E2) /= E_Constant then
4722 Check_Mismatch (True);
4725 Expr2 := Expression (Parent (E2));
4728 if Is_Static_Expression (Expr1) then
4730 if not Is_Static_Expression (Expr2) then
4731 Check_Mismatch (True);
4733 elsif Is_Discrete_Type (Etype (E1)) then
4735 V1 : constant Uint := Expr_Value (Expr1);
4736 V2 : constant Uint := Expr_Value (Expr2);
4738 Check_Mismatch (V1 /= V2);
4741 elsif Is_Real_Type (Etype (E1)) then
4743 V1 : constant Ureal := Expr_Value_R (Expr1);
4744 V2 : constant Ureal := Expr_Value_R (Expr2);
4746 Check_Mismatch (V1 /= V2);
4749 elsif Is_String_Type (Etype (E1))
4750 and then Nkind (Expr1) = N_String_Literal
4752 if Nkind (Expr2) /= N_String_Literal then
4753 Check_Mismatch (True);
4756 (not String_Equal (Strval (Expr1), Strval (Expr2)));
4760 elsif Is_Entity_Name (Expr1) then
4761 if Is_Entity_Name (Expr2) then
4762 if Entity (Expr1) = Entity (Expr2) then
4766 (not Same_Instantiated_Constant
4767 (Entity (Expr1), Entity (Expr2)));
4770 Check_Mismatch (True);
4773 elsif Is_Entity_Name (Original_Node (Expr1))
4774 and then Is_Entity_Name (Expr2)
4776 Same_Instantiated_Constant
4777 (Entity (Original_Node (Expr1)), Entity (Expr2))
4781 elsif Nkind (Expr1) = N_Null then
4782 Check_Mismatch (Nkind (Expr1) /= N_Null);
4785 Check_Mismatch (True);
4788 elsif Ekind (E1) = E_Variable then
4789 Check_Mismatch (not Same_Instantiated_Variable (E1, E2));
4791 elsif Ekind (E1) = E_Package then
4793 (Ekind (E1) /= Ekind (E2)
4794 or else Renamed_Object (E1) /= Renamed_Object (E2));
4796 elsif Is_Overloadable (E1) then
4798 -- Verify that the actual subprograms match. Note that actuals
4799 -- that are attributes are rewritten as subprograms. If the
4800 -- subprogram in the formal package is defaulted, no check is
4801 -- needed. Note that this can only happen in Ada 2005 when the
4802 -- formal package can be partially parameterized.
4804 if Nkind (Unit_Declaration_Node (E1)) =
4805 N_Subprogram_Renaming_Declaration
4806 and then From_Default (Unit_Declaration_Node (E1))
4812 (Ekind (E2) /= Ekind (E1) or else (Alias (E1)) /= Alias (E2));
4816 raise Program_Error;
4823 end Check_Formal_Package_Instance;
4825 ---------------------------
4826 -- Check_Formal_Packages --
4827 ---------------------------
4829 procedure Check_Formal_Packages (P_Id : Entity_Id) is
4831 Formal_P : Entity_Id;
4834 -- Iterate through the declarations in the instance, looking for package
4835 -- renaming declarations that denote instances of formal packages. Stop
4836 -- when we find the renaming of the current package itself. The
4837 -- declaration for a formal package without a box is followed by an
4838 -- internal entity that repeats the instantiation.
4840 E := First_Entity (P_Id);
4841 while Present (E) loop
4842 if Ekind (E) = E_Package then
4843 if Renamed_Object (E) = P_Id then
4846 elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then
4849 elsif not Box_Present (Parent (Associated_Formal_Package (E))) then
4850 Formal_P := Next_Entity (E);
4851 Check_Formal_Package_Instance (Formal_P, E);
4853 -- After checking, remove the internal validating package. It
4854 -- is only needed for semantic checks, and as it may contain
4855 -- generic formal declarations it should not reach gigi.
4857 Remove (Unit_Declaration_Node (Formal_P));
4863 end Check_Formal_Packages;
4865 ---------------------------------
4866 -- Check_Forward_Instantiation --
4867 ---------------------------------
4869 procedure Check_Forward_Instantiation (Decl : Node_Id) is
4871 Gen_Comp : Entity_Id := Cunit_Entity (Get_Source_Unit (Decl));
4874 -- The instantiation appears before the generic body if we are in the
4875 -- scope of the unit containing the generic, either in its spec or in
4876 -- the package body, and before the generic body.
4878 if Ekind (Gen_Comp) = E_Package_Body then
4879 Gen_Comp := Spec_Entity (Gen_Comp);
4882 if In_Open_Scopes (Gen_Comp)
4883 and then No (Corresponding_Body (Decl))
4888 and then not Is_Compilation_Unit (S)
4889 and then not Is_Child_Unit (S)
4891 if Ekind (S) = E_Package then
4892 Set_Has_Forward_Instantiation (S);
4898 end Check_Forward_Instantiation;
4900 ---------------------------
4901 -- Check_Generic_Actuals --
4902 ---------------------------
4904 -- The visibility of the actuals may be different between the point of
4905 -- generic instantiation and the instantiation of the body.
4907 procedure Check_Generic_Actuals
4908 (Instance : Entity_Id;
4909 Is_Formal_Box : Boolean)
4914 function Denotes_Previous_Actual (Typ : Entity_Id) return Boolean;
4915 -- For a formal that is an array type, the component type is often a
4916 -- previous formal in the same unit. The privacy status of the component
4917 -- type will have been examined earlier in the traversal of the
4918 -- corresponding actuals, and this status should not be modified for the
4919 -- array type itself.
4921 -- To detect this case we have to rescan the list of formals, which
4922 -- is usually short enough to ignore the resulting inefficiency.
4924 -----------------------------
4925 -- Denotes_Previous_Actual --
4926 -----------------------------
4928 function Denotes_Previous_Actual (Typ : Entity_Id) return Boolean is
4932 Prev := First_Entity (Instance);
4933 while Present (Prev) loop
4935 and then Nkind (Parent (Prev)) = N_Subtype_Declaration
4936 and then Is_Entity_Name (Subtype_Indication (Parent (Prev)))
4937 and then Entity (Subtype_Indication (Parent (Prev))) = Typ
4950 end Denotes_Previous_Actual;
4952 -- Start of processing for Check_Generic_Actuals
4955 E := First_Entity (Instance);
4956 while Present (E) loop
4958 and then Nkind (Parent (E)) = N_Subtype_Declaration
4959 and then Scope (Etype (E)) /= Instance
4960 and then Is_Entity_Name (Subtype_Indication (Parent (E)))
4962 if Is_Array_Type (E)
4963 and then Denotes_Previous_Actual (Component_Type (E))
4967 Check_Private_View (Subtype_Indication (Parent (E)));
4970 Set_Is_Generic_Actual_Type (E, True);
4971 Set_Is_Hidden (E, False);
4972 Set_Is_Potentially_Use_Visible (E,
4975 -- We constructed the generic actual type as a subtype of the
4976 -- supplied type. This means that it normally would not inherit
4977 -- subtype specific attributes of the actual, which is wrong for
4978 -- the generic case.
4980 Astype := Ancestor_Subtype (E);
4984 -- This can happen when E is an itype that is the full view of
4985 -- a private type completed, e.g. with a constrained array. In
4986 -- that case, use the first subtype, which will carry size
4987 -- information. The base type itself is unconstrained and will
4990 Astype := First_Subtype (E);
4993 Set_Size_Info (E, (Astype));
4994 Set_RM_Size (E, RM_Size (Astype));
4995 Set_First_Rep_Item (E, First_Rep_Item (Astype));
4997 if Is_Discrete_Or_Fixed_Point_Type (E) then
4998 Set_RM_Size (E, RM_Size (Astype));
5000 -- In nested instances, the base type of an access actual
5001 -- may itself be private, and need to be exchanged.
5003 elsif Is_Access_Type (E)
5004 and then Is_Private_Type (Etype (E))
5007 (New_Occurrence_Of (Etype (E), Sloc (Instance)));
5010 elsif Ekind (E) = E_Package then
5012 -- If this is the renaming for the current instance, we're done.
5013 -- Otherwise it is a formal package. If the corresponding formal
5014 -- was declared with a box, the (instantiations of the) generic
5015 -- formal part are also visible. Otherwise, ignore the entity
5016 -- created to validate the actuals.
5018 if Renamed_Object (E) = Instance then
5021 elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then
5024 -- The visibility of a formal of an enclosing generic is already
5027 elsif Denotes_Formal_Package (E) then
5030 elsif Present (Associated_Formal_Package (E))
5031 and then not Is_Generic_Formal (E)
5033 if Box_Present (Parent (Associated_Formal_Package (E))) then
5034 Check_Generic_Actuals (Renamed_Object (E), True);
5037 Check_Generic_Actuals (Renamed_Object (E), False);
5040 Set_Is_Hidden (E, False);
5043 -- If this is a subprogram instance (in a wrapper package) the
5044 -- actual is fully visible.
5046 elsif Is_Wrapper_Package (Instance) then
5047 Set_Is_Hidden (E, False);
5049 -- If the formal package is declared with a box, or if the formal
5050 -- parameter is defaulted, it is visible in the body.
5053 or else Is_Visible_Formal (E)
5055 Set_Is_Hidden (E, False);
5058 if Ekind (E) = E_Constant then
5060 -- If the type of the actual is a private type declared in the
5061 -- enclosing scope of the generic unit, the body of the generic
5062 -- sees the full view of the type (because it has to appear in
5063 -- the corresponding package body). If the type is private now,
5064 -- exchange views to restore the proper visiblity in the instance.
5067 Typ : constant Entity_Id := Base_Type (Etype (E));
5068 -- The type of the actual
5073 Parent_Scope : Entity_Id;
5074 -- The enclosing scope of the generic unit
5077 if Is_Wrapper_Package (Instance) then
5081 (Unit_Declaration_Node
5082 (Related_Instance (Instance))));
5086 (Specification (Unit_Declaration_Node (Instance)));
5089 Parent_Scope := Scope (Gen_Id);
5091 -- The exchange is only needed if the generic is defined
5092 -- within a package which is not a common ancestor of the
5093 -- scope of the instance, and is not already in scope.
5095 if Is_Private_Type (Typ)
5096 and then Scope (Typ) = Parent_Scope
5097 and then Scope (Instance) /= Parent_Scope
5098 and then Ekind (Parent_Scope) = E_Package
5099 and then not Is_Child_Unit (Gen_Id)
5103 -- If the type of the entity is a subtype, it may also
5104 -- have to be made visible, together with the base type
5105 -- of its full view, after exchange.
5107 if Is_Private_Type (Etype (E)) then
5108 Switch_View (Etype (E));
5109 Switch_View (Base_Type (Etype (E)));
5117 end Check_Generic_Actuals;
5119 ------------------------------
5120 -- Check_Generic_Child_Unit --
5121 ------------------------------
5123 procedure Check_Generic_Child_Unit
5125 Parent_Installed : in out Boolean)
5127 Loc : constant Source_Ptr := Sloc (Gen_Id);
5128 Gen_Par : Entity_Id := Empty;
5130 Inst_Par : Entity_Id;
5133 function Find_Generic_Child
5135 Id : Node_Id) return Entity_Id;
5136 -- Search generic parent for possible child unit with the given name
5138 function In_Enclosing_Instance return Boolean;
5139 -- Within an instance of the parent, the child unit may be denoted
5140 -- by a simple name, or an abbreviated expanded name. Examine enclosing
5141 -- scopes to locate a possible parent instantiation.
5143 ------------------------
5144 -- Find_Generic_Child --
5145 ------------------------
5147 function Find_Generic_Child
5149 Id : Node_Id) return Entity_Id
5154 -- If entity of name is already set, instance has already been
5155 -- resolved, e.g. in an enclosing instantiation.
5157 if Present (Entity (Id)) then
5158 if Scope (Entity (Id)) = Scop then
5165 E := First_Entity (Scop);
5166 while Present (E) loop
5167 if Chars (E) = Chars (Id)
5168 and then Is_Child_Unit (E)
5170 if Is_Child_Unit (E)
5171 and then not Is_Visible_Child_Unit (E)
5174 ("generic child unit& is not visible", Gen_Id, E);
5186 end Find_Generic_Child;
5188 ---------------------------
5189 -- In_Enclosing_Instance --
5190 ---------------------------
5192 function In_Enclosing_Instance return Boolean is
5193 Enclosing_Instance : Node_Id;
5194 Instance_Decl : Node_Id;
5197 -- We do not inline any call that contains instantiations, except
5198 -- for instantiations of Unchecked_Conversion, so if we are within
5199 -- an inlined body the current instance does not require parents.
5201 if In_Inlined_Body then
5202 pragma Assert (Chars (Gen_Id) = Name_Unchecked_Conversion);
5206 -- Loop to check enclosing scopes
5208 Enclosing_Instance := Current_Scope;
5209 while Present (Enclosing_Instance) loop
5210 Instance_Decl := Unit_Declaration_Node (Enclosing_Instance);
5212 if Ekind (Enclosing_Instance) = E_Package
5213 and then Is_Generic_Instance (Enclosing_Instance)
5215 (Generic_Parent (Specification (Instance_Decl)))
5217 -- Check whether the generic we are looking for is a child of
5220 E := Find_Generic_Child
5221 (Generic_Parent (Specification (Instance_Decl)), Gen_Id);
5222 exit when Present (E);
5228 Enclosing_Instance := Scope (Enclosing_Instance);
5240 Make_Expanded_Name (Loc,
5242 Prefix => New_Occurrence_Of (Enclosing_Instance, Loc),
5243 Selector_Name => New_Occurrence_Of (E, Loc)));
5245 Set_Entity (Gen_Id, E);
5246 Set_Etype (Gen_Id, Etype (E));
5247 Parent_Installed := False; -- Already in scope.
5250 end In_Enclosing_Instance;
5252 -- Start of processing for Check_Generic_Child_Unit
5255 -- If the name of the generic is given by a selected component, it may
5256 -- be the name of a generic child unit, and the prefix is the name of an
5257 -- instance of the parent, in which case the child unit must be visible.
5258 -- If this instance is not in scope, it must be placed there and removed
5259 -- after instantiation, because what is being instantiated is not the
5260 -- original child, but the corresponding child present in the instance
5263 -- If the child is instantiated within the parent, it can be given by
5264 -- a simple name. In this case the instance is already in scope, but
5265 -- the child generic must be recovered from the generic parent as well.
5267 if Nkind (Gen_Id) = N_Selected_Component then
5268 S := Selector_Name (Gen_Id);
5269 Analyze (Prefix (Gen_Id));
5270 Inst_Par := Entity (Prefix (Gen_Id));
5272 if Ekind (Inst_Par) = E_Package
5273 and then Present (Renamed_Object (Inst_Par))
5275 Inst_Par := Renamed_Object (Inst_Par);
5278 if Ekind (Inst_Par) = E_Package then
5279 if Nkind (Parent (Inst_Par)) = N_Package_Specification then
5280 Gen_Par := Generic_Parent (Parent (Inst_Par));
5282 elsif Nkind (Parent (Inst_Par)) = N_Defining_Program_Unit_Name
5284 Nkind (Parent (Parent (Inst_Par))) = N_Package_Specification
5286 Gen_Par := Generic_Parent (Parent (Parent (Inst_Par)));
5289 elsif Ekind (Inst_Par) = E_Generic_Package
5290 and then Nkind (Parent (Gen_Id)) = N_Formal_Package_Declaration
5292 -- A formal package may be a real child package, and not the
5293 -- implicit instance within a parent. In this case the child is
5294 -- not visible and has to be retrieved explicitly as well.
5296 Gen_Par := Inst_Par;
5299 if Present (Gen_Par) then
5301 -- The prefix denotes an instantiation. The entity itself may be a
5302 -- nested generic, or a child unit.
5304 E := Find_Generic_Child (Gen_Par, S);
5307 Change_Selected_Component_To_Expanded_Name (Gen_Id);
5308 Set_Entity (Gen_Id, E);
5309 Set_Etype (Gen_Id, Etype (E));
5311 Set_Etype (S, Etype (E));
5313 -- Indicate that this is a reference to the parent
5315 if In_Extended_Main_Source_Unit (Gen_Id) then
5316 Set_Is_Instantiated (Inst_Par);
5319 -- A common mistake is to replicate the naming scheme of a
5320 -- hierarchy by instantiating a generic child directly, rather
5321 -- than the implicit child in a parent instance:
5323 -- generic .. package Gpar is ..
5324 -- generic .. package Gpar.Child is ..
5325 -- package Par is new Gpar ();
5328 -- package Par.Child is new Gpar.Child ();
5329 -- rather than Par.Child
5331 -- In this case the instantiation is within Par, which is an
5332 -- instance, but Gpar does not denote Par because we are not IN
5333 -- the instance of Gpar, so this is illegal. The test below
5334 -- recognizes this particular case.
5336 if Is_Child_Unit (E)
5337 and then not Comes_From_Source (Entity (Prefix (Gen_Id)))
5338 and then (not In_Instance
5339 or else Nkind (Parent (Parent (Gen_Id))) =
5343 ("prefix of generic child unit must be instance of parent",
5347 if not In_Open_Scopes (Inst_Par)
5348 and then Nkind (Parent (Gen_Id)) not in
5349 N_Generic_Renaming_Declaration
5351 Install_Parent (Inst_Par);
5352 Parent_Installed := True;
5354 elsif In_Open_Scopes (Inst_Par) then
5356 -- If the parent is already installed, install the actuals
5357 -- for its formal packages. This is necessary when the
5358 -- child instance is a child of the parent instance:
5359 -- in this case, the parent is placed on the scope stack
5360 -- but the formal packages are not made visible.
5362 Install_Formal_Packages (Inst_Par);
5366 -- If the generic parent does not contain an entity that
5367 -- corresponds to the selector, the instance doesn't either.
5368 -- Analyzing the node will yield the appropriate error message.
5369 -- If the entity is not a child unit, then it is an inner
5370 -- generic in the parent.
5378 if Is_Child_Unit (Entity (Gen_Id))
5380 Nkind (Parent (Gen_Id)) not in N_Generic_Renaming_Declaration
5381 and then not In_Open_Scopes (Inst_Par)
5383 Install_Parent (Inst_Par);
5384 Parent_Installed := True;
5386 -- The generic unit may be the renaming of the implicit child
5387 -- present in an instance. In that case the parent instance is
5388 -- obtained from the name of the renamed entity.
5390 elsif Ekind (Entity (Gen_Id)) = E_Generic_Package
5391 and then Present (Renamed_Entity (Entity (Gen_Id)))
5392 and then Is_Child_Unit (Renamed_Entity (Entity (Gen_Id)))
5395 Renamed_Package : constant Node_Id :=
5396 Name (Parent (Entity (Gen_Id)));
5398 if Nkind (Renamed_Package) = N_Expanded_Name then
5399 Inst_Par := Entity (Prefix (Renamed_Package));
5400 Install_Parent (Inst_Par);
5401 Parent_Installed := True;
5407 elsif Nkind (Gen_Id) = N_Expanded_Name then
5409 -- Entity already present, analyze prefix, whose meaning may be
5410 -- an instance in the current context. If it is an instance of
5411 -- a relative within another, the proper parent may still have
5412 -- to be installed, if they are not of the same generation.
5414 Analyze (Prefix (Gen_Id));
5416 -- In the unlikely case that a local declaration hides the name
5417 -- of the parent package, locate it on the homonym chain. If the
5418 -- context is an instance of the parent, the renaming entity is
5421 Inst_Par := Entity (Prefix (Gen_Id));
5422 while Present (Inst_Par)
5423 and then not Is_Package_Or_Generic_Package (Inst_Par)
5425 Inst_Par := Homonym (Inst_Par);
5428 pragma Assert (Present (Inst_Par));
5429 Set_Entity (Prefix (Gen_Id), Inst_Par);
5431 if In_Enclosing_Instance then
5434 elsif Present (Entity (Gen_Id))
5435 and then Is_Child_Unit (Entity (Gen_Id))
5436 and then not In_Open_Scopes (Inst_Par)
5438 Install_Parent (Inst_Par);
5439 Parent_Installed := True;
5442 elsif In_Enclosing_Instance then
5444 -- The child unit is found in some enclosing scope
5451 -- If this is the renaming of the implicit child in a parent
5452 -- instance, recover the parent name and install it.
5454 if Is_Entity_Name (Gen_Id) then
5455 E := Entity (Gen_Id);
5457 if Is_Generic_Unit (E)
5458 and then Nkind (Parent (E)) in N_Generic_Renaming_Declaration
5459 and then Is_Child_Unit (Renamed_Object (E))
5460 and then Is_Generic_Unit (Scope (Renamed_Object (E)))
5461 and then Nkind (Name (Parent (E))) = N_Expanded_Name
5464 New_Copy_Tree (Name (Parent (E))));
5465 Inst_Par := Entity (Prefix (Gen_Id));
5467 if not In_Open_Scopes (Inst_Par) then
5468 Install_Parent (Inst_Par);
5469 Parent_Installed := True;
5472 -- If it is a child unit of a non-generic parent, it may be
5473 -- use-visible and given by a direct name. Install parent as
5476 elsif Is_Generic_Unit (E)
5477 and then Is_Child_Unit (E)
5479 Nkind (Parent (Gen_Id)) not in N_Generic_Renaming_Declaration
5480 and then not Is_Generic_Unit (Scope (E))
5482 if not In_Open_Scopes (Scope (E)) then
5483 Install_Parent (Scope (E));
5484 Parent_Installed := True;
5489 end Check_Generic_Child_Unit;
5491 -----------------------------
5492 -- Check_Hidden_Child_Unit --
5493 -----------------------------
5495 procedure Check_Hidden_Child_Unit
5497 Gen_Unit : Entity_Id;
5498 Act_Decl_Id : Entity_Id)
5500 Gen_Id : constant Node_Id := Name (N);
5503 if Is_Child_Unit (Gen_Unit)
5504 and then Is_Child_Unit (Act_Decl_Id)
5505 and then Nkind (Gen_Id) = N_Expanded_Name
5506 and then Entity (Prefix (Gen_Id)) = Scope (Act_Decl_Id)
5507 and then Chars (Gen_Unit) = Chars (Act_Decl_Id)
5509 Error_Msg_Node_2 := Scope (Act_Decl_Id);
5511 ("generic unit & is implicitly declared in &",
5512 Defining_Unit_Name (N), Gen_Unit);
5513 Error_Msg_N ("\instance must have different name",
5514 Defining_Unit_Name (N));
5516 end Check_Hidden_Child_Unit;
5518 ------------------------
5519 -- Check_Private_View --
5520 ------------------------
5522 procedure Check_Private_View (N : Node_Id) is
5523 T : constant Entity_Id := Etype (N);
5527 -- Exchange views if the type was not private in the generic but is
5528 -- private at the point of instantiation. Do not exchange views if
5529 -- the scope of the type is in scope. This can happen if both generic
5530 -- and instance are sibling units, or if type is defined in a parent.
5531 -- In this case the visibility of the type will be correct for all
5535 BT := Base_Type (T);
5537 if Is_Private_Type (T)
5538 and then not Has_Private_View (N)
5539 and then Present (Full_View (T))
5540 and then not In_Open_Scopes (Scope (T))
5542 -- In the generic, the full type was visible. Save the private
5543 -- entity, for subsequent exchange.
5547 elsif Has_Private_View (N)
5548 and then not Is_Private_Type (T)
5549 and then not Has_Been_Exchanged (T)
5550 and then Etype (Get_Associated_Node (N)) /= T
5552 -- Only the private declaration was visible in the generic. If
5553 -- the type appears in a subtype declaration, the subtype in the
5554 -- instance must have a view compatible with that of its parent,
5555 -- which must be exchanged (see corresponding code in Restore_
5556 -- Private_Views). Otherwise, if the type is defined in a parent
5557 -- unit, leave full visibility within instance, which is safe.
5559 if In_Open_Scopes (Scope (Base_Type (T)))
5560 and then not Is_Private_Type (Base_Type (T))
5561 and then Comes_From_Source (Base_Type (T))
5565 elsif Nkind (Parent (N)) = N_Subtype_Declaration
5566 or else not In_Private_Part (Scope (Base_Type (T)))
5568 Prepend_Elmt (T, Exchanged_Views);
5569 Exchange_Declarations (Etype (Get_Associated_Node (N)));
5572 -- For composite types with inconsistent representation exchange
5573 -- component types accordingly.
5575 elsif Is_Access_Type (T)
5576 and then Is_Private_Type (Designated_Type (T))
5577 and then not Has_Private_View (N)
5578 and then Present (Full_View (Designated_Type (T)))
5580 Switch_View (Designated_Type (T));
5582 elsif Is_Array_Type (T) then
5583 if Is_Private_Type (Component_Type (T))
5584 and then not Has_Private_View (N)
5585 and then Present (Full_View (Component_Type (T)))
5587 Switch_View (Component_Type (T));
5590 -- The normal exchange mechanism relies on the setting of a
5591 -- flag on the reference in the generic. However, an additional
5592 -- mechanism is needed for types that are not explicitly mentioned
5593 -- in the generic, but may be needed in expanded code in the
5594 -- instance. This includes component types of arrays and
5595 -- designated types of access types. This processing must also
5596 -- include the index types of arrays which we take care of here.
5603 Indx := First_Index (T);
5604 Typ := Base_Type (Etype (Indx));
5605 while Present (Indx) loop
5606 if Is_Private_Type (Typ)
5607 and then Present (Full_View (Typ))
5616 elsif Is_Private_Type (T)
5617 and then Present (Full_View (T))
5618 and then Is_Array_Type (Full_View (T))
5619 and then Is_Private_Type (Component_Type (Full_View (T)))
5623 -- Finally, a non-private subtype may have a private base type, which
5624 -- must be exchanged for consistency. This can happen when a package
5625 -- body is instantiated, when the scope stack is empty but in fact
5626 -- the subtype and the base type are declared in an enclosing scope.
5628 -- Note that in this case we introduce an inconsistency in the view
5629 -- set, because we switch the base type BT, but there could be some
5630 -- private dependent subtypes of BT which remain unswitched. Such
5631 -- subtypes might need to be switched at a later point (see specific
5632 -- provision for that case in Switch_View).
5634 elsif not Is_Private_Type (T)
5635 and then not Has_Private_View (N)
5636 and then Is_Private_Type (BT)
5637 and then Present (Full_View (BT))
5638 and then not Is_Generic_Type (BT)
5639 and then not In_Open_Scopes (BT)
5641 Prepend_Elmt (Full_View (BT), Exchanged_Views);
5642 Exchange_Declarations (BT);
5645 end Check_Private_View;
5647 --------------------------
5648 -- Contains_Instance_Of --
5649 --------------------------
5651 function Contains_Instance_Of
5654 N : Node_Id) return Boolean
5662 -- Verify that there are no circular instantiations. We check whether
5663 -- the unit contains an instance of the current scope or some enclosing
5664 -- scope (in case one of the instances appears in a subunit). Longer
5665 -- circularities involving subunits might seem too pathological to
5666 -- consider, but they were not too pathological for the authors of
5667 -- DEC bc30vsq, so we loop over all enclosing scopes, and mark all
5668 -- enclosing generic scopes as containing an instance.
5671 -- Within a generic subprogram body, the scope is not generic, to
5672 -- allow for recursive subprograms. Use the declaration to determine
5673 -- whether this is a generic unit.
5675 if Ekind (Scop) = E_Generic_Package
5676 or else (Is_Subprogram (Scop)
5677 and then Nkind (Unit_Declaration_Node (Scop)) =
5678 N_Generic_Subprogram_Declaration)
5680 Elmt := First_Elmt (Inner_Instances (Inner));
5682 while Present (Elmt) loop
5683 if Node (Elmt) = Scop then
5684 Error_Msg_Node_2 := Inner;
5686 ("circular Instantiation: & instantiated within &!",
5690 elsif Node (Elmt) = Inner then
5693 elsif Contains_Instance_Of (Node (Elmt), Scop, N) then
5694 Error_Msg_Node_2 := Inner;
5696 ("circular Instantiation: & instantiated within &!",
5704 -- Indicate that Inner is being instantiated within Scop
5706 Append_Elmt (Inner, Inner_Instances (Scop));
5709 if Scop = Standard_Standard then
5712 Scop := Scope (Scop);
5717 end Contains_Instance_Of;
5719 -----------------------
5720 -- Copy_Generic_Node --
5721 -----------------------
5723 function Copy_Generic_Node
5725 Parent_Id : Node_Id;
5726 Instantiating : Boolean) return Node_Id
5731 function Copy_Generic_Descendant (D : Union_Id) return Union_Id;
5732 -- Check the given value of one of the Fields referenced by the
5733 -- current node to determine whether to copy it recursively. The
5734 -- field may hold a Node_Id, a List_Id, or an Elist_Id, or a plain
5735 -- value (Sloc, Uint, Char) in which case it need not be copied.
5737 procedure Copy_Descendants;
5738 -- Common utility for various nodes
5740 function Copy_Generic_Elist (E : Elist_Id) return Elist_Id;
5741 -- Make copy of element list
5743 function Copy_Generic_List
5745 Parent_Id : Node_Id) return List_Id;
5746 -- Apply Copy_Node recursively to the members of a node list
5748 function In_Defining_Unit_Name (Nam : Node_Id) return Boolean;
5749 -- True if an identifier is part of the defining program unit name
5750 -- of a child unit. The entity of such an identifier must be kept
5751 -- (for ASIS use) even though as the name of an enclosing generic
5752 -- it would otherwise not be preserved in the generic tree.
5754 ----------------------
5755 -- Copy_Descendants --
5756 ----------------------
5758 procedure Copy_Descendants is
5760 use Atree.Unchecked_Access;
5761 -- This code section is part of the implementation of an untyped
5762 -- tree traversal, so it needs direct access to node fields.
5765 Set_Field1 (New_N, Copy_Generic_Descendant (Field1 (N)));
5766 Set_Field2 (New_N, Copy_Generic_Descendant (Field2 (N)));
5767 Set_Field3 (New_N, Copy_Generic_Descendant (Field3 (N)));
5768 Set_Field4 (New_N, Copy_Generic_Descendant (Field4 (N)));
5769 Set_Field5 (New_N, Copy_Generic_Descendant (Field5 (N)));
5770 end Copy_Descendants;
5772 -----------------------------
5773 -- Copy_Generic_Descendant --
5774 -----------------------------
5776 function Copy_Generic_Descendant (D : Union_Id) return Union_Id is
5778 if D = Union_Id (Empty) then
5781 elsif D in Node_Range then
5783 (Copy_Generic_Node (Node_Id (D), New_N, Instantiating));
5785 elsif D in List_Range then
5786 return Union_Id (Copy_Generic_List (List_Id (D), New_N));
5788 elsif D in Elist_Range then
5789 return Union_Id (Copy_Generic_Elist (Elist_Id (D)));
5791 -- Nothing else is copyable (e.g. Uint values), return as is
5796 end Copy_Generic_Descendant;
5798 ------------------------
5799 -- Copy_Generic_Elist --
5800 ------------------------
5802 function Copy_Generic_Elist (E : Elist_Id) return Elist_Id is
5809 M := First_Elmt (E);
5810 while Present (M) loop
5812 (Copy_Generic_Node (Node (M), Empty, Instantiating), L);
5821 end Copy_Generic_Elist;
5823 -----------------------
5824 -- Copy_Generic_List --
5825 -----------------------
5827 function Copy_Generic_List
5829 Parent_Id : Node_Id) return List_Id
5837 Set_Parent (New_L, Parent_Id);
5840 while Present (N) loop
5841 Append (Copy_Generic_Node (N, Empty, Instantiating), New_L);
5850 end Copy_Generic_List;
5852 ---------------------------
5853 -- In_Defining_Unit_Name --
5854 ---------------------------
5856 function In_Defining_Unit_Name (Nam : Node_Id) return Boolean is
5858 return Present (Parent (Nam))
5859 and then (Nkind (Parent (Nam)) = N_Defining_Program_Unit_Name
5861 (Nkind (Parent (Nam)) = N_Expanded_Name
5862 and then In_Defining_Unit_Name (Parent (Nam))));
5863 end In_Defining_Unit_Name;
5865 -- Start of processing for Copy_Generic_Node
5872 New_N := New_Copy (N);
5874 -- Copy aspects if present
5876 if Has_Aspects (N) then
5877 Set_Has_Aspects (New_N, False);
5878 Set_Aspect_Specifications
5879 (New_N, Copy_Generic_List (Aspect_Specifications (N), Parent_Id));
5882 if Instantiating then
5883 Adjust_Instantiation_Sloc (New_N, S_Adjustment);
5886 if not Is_List_Member (N) then
5887 Set_Parent (New_N, Parent_Id);
5890 -- If defining identifier, then all fields have been copied already
5892 if Nkind (New_N) in N_Entity then
5895 -- Special casing for identifiers and other entity names and operators
5897 elsif Nkind_In (New_N, N_Identifier,
5898 N_Character_Literal,
5901 or else Nkind (New_N) in N_Op
5903 if not Instantiating then
5905 -- Link both nodes in order to assign subsequently the entity of
5906 -- the copy to the original node, in case this is a global
5909 Set_Associated_Node (N, New_N);
5911 -- If we are within an instantiation, this is a nested generic
5912 -- that has already been analyzed at the point of definition. We
5913 -- must preserve references that were global to the enclosing
5914 -- parent at that point. Other occurrences, whether global or
5915 -- local to the current generic, must be resolved anew, so we
5916 -- reset the entity in the generic copy. A global reference has a
5917 -- smaller depth than the parent, or else the same depth in case
5918 -- both are distinct compilation units.
5919 -- A child unit is implicitly declared within the enclosing parent
5920 -- but is in fact global to it, and must be preserved.
5922 -- It is also possible for Current_Instantiated_Parent to be
5923 -- defined, and for this not to be a nested generic, namely if the
5924 -- unit is loaded through Rtsfind. In that case, the entity of
5925 -- New_N is only a link to the associated node, and not a defining
5928 -- The entities for parent units in the defining_program_unit of a
5929 -- generic child unit are established when the context of the unit
5930 -- is first analyzed, before the generic copy is made. They are
5931 -- preserved in the copy for use in ASIS queries.
5933 Ent := Entity (New_N);
5935 if No (Current_Instantiated_Parent.Gen_Id) then
5937 or else Nkind (Ent) /= N_Defining_Identifier
5938 or else not In_Defining_Unit_Name (N)
5940 Set_Associated_Node (New_N, Empty);
5945 not Nkind_In (Ent, N_Defining_Identifier,
5946 N_Defining_Character_Literal,
5947 N_Defining_Operator_Symbol)
5948 or else No (Scope (Ent))
5950 (Scope (Ent) = Current_Instantiated_Parent.Gen_Id
5951 and then not Is_Child_Unit (Ent))
5953 (Scope_Depth (Scope (Ent)) >
5954 Scope_Depth (Current_Instantiated_Parent.Gen_Id)
5956 Get_Source_Unit (Ent) =
5957 Get_Source_Unit (Current_Instantiated_Parent.Gen_Id))
5959 Set_Associated_Node (New_N, Empty);
5962 -- Case of instantiating identifier or some other name or operator
5965 -- If the associated node is still defined, the entity in it is
5966 -- global, and must be copied to the instance. If this copy is
5967 -- being made for a body to inline, it is applied to an
5968 -- instantiated tree, and the entity is already present and must
5969 -- be also preserved.
5972 Assoc : constant Node_Id := Get_Associated_Node (N);
5975 if Present (Assoc) then
5976 if Nkind (Assoc) = Nkind (N) then
5977 Set_Entity (New_N, Entity (Assoc));
5978 Check_Private_View (N);
5980 elsif Nkind (Assoc) = N_Function_Call then
5981 Set_Entity (New_N, Entity (Name (Assoc)));
5983 elsif Nkind_In (Assoc, N_Defining_Identifier,
5984 N_Defining_Character_Literal,
5985 N_Defining_Operator_Symbol)
5986 and then Expander_Active
5988 -- Inlining case: we are copying a tree that contains
5989 -- global entities, which are preserved in the copy to be
5990 -- used for subsequent inlining.
5995 Set_Entity (New_N, Empty);
6001 -- For expanded name, we must copy the Prefix and Selector_Name
6003 if Nkind (N) = N_Expanded_Name then
6005 (New_N, Copy_Generic_Node (Prefix (N), New_N, Instantiating));
6007 Set_Selector_Name (New_N,
6008 Copy_Generic_Node (Selector_Name (N), New_N, Instantiating));
6010 -- For operators, we must copy the right operand
6012 elsif Nkind (N) in N_Op then
6013 Set_Right_Opnd (New_N,
6014 Copy_Generic_Node (Right_Opnd (N), New_N, Instantiating));
6016 -- And for binary operators, the left operand as well
6018 if Nkind (N) in N_Binary_Op then
6019 Set_Left_Opnd (New_N,
6020 Copy_Generic_Node (Left_Opnd (N), New_N, Instantiating));
6024 -- Special casing for stubs
6026 elsif Nkind (N) in N_Body_Stub then
6028 -- In any case, we must copy the specification or defining
6029 -- identifier as appropriate.
6031 if Nkind (N) = N_Subprogram_Body_Stub then
6032 Set_Specification (New_N,
6033 Copy_Generic_Node (Specification (N), New_N, Instantiating));
6036 Set_Defining_Identifier (New_N,
6038 (Defining_Identifier (N), New_N, Instantiating));
6041 -- If we are not instantiating, then this is where we load and
6042 -- analyze subunits, i.e. at the point where the stub occurs. A
6043 -- more permissive system might defer this analysis to the point
6044 -- of instantiation, but this seems to complicated for now.
6046 if not Instantiating then
6048 Subunit_Name : constant Unit_Name_Type := Get_Unit_Name (N);
6050 Unum : Unit_Number_Type;
6054 -- Make sure that, if it is a subunit of the main unit that is
6055 -- preprocessed and if -gnateG is specified, the preprocessed
6056 -- file will be written.
6058 Lib.Analysing_Subunit_Of_Main :=
6059 Lib.In_Extended_Main_Source_Unit (N);
6062 (Load_Name => Subunit_Name,
6066 Lib.Analysing_Subunit_Of_Main := False;
6068 -- If the proper body is not found, a warning message will be
6069 -- emitted when analyzing the stub, or later at the point
6070 -- of instantiation. Here we just leave the stub as is.
6072 if Unum = No_Unit then
6073 Subunits_Missing := True;
6074 goto Subunit_Not_Found;
6077 Subunit := Cunit (Unum);
6079 if Nkind (Unit (Subunit)) /= N_Subunit then
6081 ("found child unit instead of expected SEPARATE subunit",
6083 Error_Msg_Sloc := Sloc (N);
6084 Error_Msg_N ("\to complete stub #", Subunit);
6085 goto Subunit_Not_Found;
6088 -- We must create a generic copy of the subunit, in order to
6089 -- perform semantic analysis on it, and we must replace the
6090 -- stub in the original generic unit with the subunit, in order
6091 -- to preserve non-local references within.
6093 -- Only the proper body needs to be copied. Library_Unit and
6094 -- context clause are simply inherited by the generic copy.
6095 -- Note that the copy (which may be recursive if there are
6096 -- nested subunits) must be done first, before attaching it to
6097 -- the enclosing generic.
6101 (Proper_Body (Unit (Subunit)),
6102 Empty, Instantiating => False);
6104 -- Now place the original proper body in the original generic
6105 -- unit. This is a body, not a compilation unit.
6107 Rewrite (N, Proper_Body (Unit (Subunit)));
6108 Set_Is_Compilation_Unit (Defining_Entity (N), False);
6109 Set_Was_Originally_Stub (N);
6111 -- Finally replace the body of the subunit with its copy, and
6112 -- make this new subunit into the library unit of the generic
6113 -- copy, which does not have stubs any longer.
6115 Set_Proper_Body (Unit (Subunit), New_Body);
6116 Set_Library_Unit (New_N, Subunit);
6117 Inherit_Context (Unit (Subunit), N);
6120 -- If we are instantiating, this must be an error case, since
6121 -- otherwise we would have replaced the stub node by the proper body
6122 -- that corresponds. So just ignore it in the copy (i.e. we have
6123 -- copied it, and that is good enough).
6129 <<Subunit_Not_Found>> null;
6131 -- If the node is a compilation unit, it is the subunit of a stub, which
6132 -- has been loaded already (see code below). In this case, the library
6133 -- unit field of N points to the parent unit (which is a compilation
6134 -- unit) and need not (and cannot!) be copied.
6136 -- When the proper body of the stub is analyzed, the library_unit link
6137 -- is used to establish the proper context (see sem_ch10).
6139 -- The other fields of a compilation unit are copied as usual
6141 elsif Nkind (N) = N_Compilation_Unit then
6143 -- This code can only be executed when not instantiating, because in
6144 -- the copy made for an instantiation, the compilation unit node has
6145 -- disappeared at the point that a stub is replaced by its proper
6148 pragma Assert (not Instantiating);
6150 Set_Context_Items (New_N,
6151 Copy_Generic_List (Context_Items (N), New_N));
6154 Copy_Generic_Node (Unit (N), New_N, False));
6156 Set_First_Inlined_Subprogram (New_N,
6158 (First_Inlined_Subprogram (N), New_N, False));
6160 Set_Aux_Decls_Node (New_N,
6161 Copy_Generic_Node (Aux_Decls_Node (N), New_N, False));
6163 -- For an assignment node, the assignment is known to be semantically
6164 -- legal if we are instantiating the template. This avoids incorrect
6165 -- diagnostics in generated code.
6167 elsif Nkind (N) = N_Assignment_Statement then
6169 -- Copy name and expression fields in usual manner
6172 Copy_Generic_Node (Name (N), New_N, Instantiating));
6174 Set_Expression (New_N,
6175 Copy_Generic_Node (Expression (N), New_N, Instantiating));
6177 if Instantiating then
6178 Set_Assignment_OK (Name (New_N), True);
6181 elsif Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then
6182 if not Instantiating then
6183 Set_Associated_Node (N, New_N);
6186 if Present (Get_Associated_Node (N))
6187 and then Nkind (Get_Associated_Node (N)) = Nkind (N)
6189 -- In the generic the aggregate has some composite type. If at
6190 -- the point of instantiation the type has a private view,
6191 -- install the full view (and that of its ancestors, if any).
6194 T : Entity_Id := (Etype (Get_Associated_Node (New_N)));
6199 and then Is_Private_Type (T)
6205 and then Is_Tagged_Type (T)
6206 and then Is_Derived_Type (T)
6208 Rt := Root_Type (T);
6213 if Is_Private_Type (T) then
6224 -- Do not copy the associated node, which points to
6225 -- the generic copy of the aggregate.
6228 use Atree.Unchecked_Access;
6229 -- This code section is part of the implementation of an untyped
6230 -- tree traversal, so it needs direct access to node fields.
6233 Set_Field1 (New_N, Copy_Generic_Descendant (Field1 (N)));
6234 Set_Field2 (New_N, Copy_Generic_Descendant (Field2 (N)));
6235 Set_Field3 (New_N, Copy_Generic_Descendant (Field3 (N)));
6236 Set_Field5 (New_N, Copy_Generic_Descendant (Field5 (N)));
6239 -- Allocators do not have an identifier denoting the access type,
6240 -- so we must locate it through the expression to check whether
6241 -- the views are consistent.
6243 elsif Nkind (N) = N_Allocator
6244 and then Nkind (Expression (N)) = N_Qualified_Expression
6245 and then Is_Entity_Name (Subtype_Mark (Expression (N)))
6246 and then Instantiating
6249 T : constant Node_Id :=
6250 Get_Associated_Node (Subtype_Mark (Expression (N)));
6256 -- Retrieve the allocator node in the generic copy
6258 Acc_T := Etype (Parent (Parent (T)));
6260 and then Is_Private_Type (Acc_T)
6262 Switch_View (Acc_T);
6269 -- For a proper body, we must catch the case of a proper body that
6270 -- replaces a stub. This represents the point at which a separate
6271 -- compilation unit, and hence template file, may be referenced, so we
6272 -- must make a new source instantiation entry for the template of the
6273 -- subunit, and ensure that all nodes in the subunit are adjusted using
6274 -- this new source instantiation entry.
6276 elsif Nkind (N) in N_Proper_Body then
6278 Save_Adjustment : constant Sloc_Adjustment := S_Adjustment;
6281 if Instantiating and then Was_Originally_Stub (N) then
6282 Create_Instantiation_Source
6283 (Instantiation_Node,
6284 Defining_Entity (N),
6289 -- Now copy the fields of the proper body, using the new
6290 -- adjustment factor if one was needed as per test above.
6294 -- Restore the original adjustment factor in case changed
6296 S_Adjustment := Save_Adjustment;
6299 -- Don't copy Ident or Comment pragmas, since the comment belongs to the
6300 -- generic unit, not to the instantiating unit.
6302 elsif Nkind (N) = N_Pragma
6303 and then Instantiating
6306 Prag_Id : constant Pragma_Id := Get_Pragma_Id (N);
6308 if Prag_Id = Pragma_Ident
6309 or else Prag_Id = Pragma_Comment
6311 New_N := Make_Null_Statement (Sloc (N));
6317 elsif Nkind_In (N, N_Integer_Literal, N_Real_Literal) then
6319 -- No descendant fields need traversing
6323 elsif Nkind (N) = N_String_Literal
6324 and then Present (Etype (N))
6325 and then Instantiating
6327 -- If the string is declared in an outer scope, the string_literal
6328 -- subtype created for it may have the wrong scope. We force the
6329 -- reanalysis of the constant to generate a new itype in the proper
6332 Set_Etype (New_N, Empty);
6333 Set_Analyzed (New_N, False);
6335 -- For the remaining nodes, copy their descendants recursively
6341 and then Nkind (N) = N_Subprogram_Body
6343 Set_Generic_Parent (Specification (New_N), N);
6348 end Copy_Generic_Node;
6350 ----------------------------
6351 -- Denotes_Formal_Package --
6352 ----------------------------
6354 function Denotes_Formal_Package
6356 On_Exit : Boolean := False;
6357 Instance : Entity_Id := Empty) return Boolean
6360 Scop : constant Entity_Id := Scope (Pack);
6363 function Is_Actual_Of_Previous_Formal (P : Entity_Id) return Boolean;
6364 -- The package in question may be an actual for a previous formal
6365 -- package P of the current instance, so examine its actuals as well.
6366 -- This must be recursive over other formal packages.
6368 ----------------------------------
6369 -- Is_Actual_Of_Previous_Formal --
6370 ----------------------------------
6372 function Is_Actual_Of_Previous_Formal (P : Entity_Id) return Boolean is
6376 E1 := First_Entity (P);
6377 while Present (E1) and then E1 /= Instance loop
6378 if Ekind (E1) = E_Package
6379 and then Nkind (Parent (E1)) = N_Package_Renaming_Declaration
6381 if Renamed_Object (E1) = Pack then
6385 or else Renamed_Object (E1) = P
6389 elsif Is_Actual_Of_Previous_Formal (E1) then
6398 end Is_Actual_Of_Previous_Formal;
6400 -- Start of processing for Denotes_Formal_Package
6406 (Instance_Envs.Last).Instantiated_Parent.Act_Id;
6408 Par := Current_Instantiated_Parent.Act_Id;
6411 if Ekind (Scop) = E_Generic_Package
6412 or else Nkind (Unit_Declaration_Node (Scop)) =
6413 N_Generic_Subprogram_Declaration
6417 elsif Nkind (Original_Node (Unit_Declaration_Node (Pack))) =
6418 N_Formal_Package_Declaration
6426 -- Check whether this package is associated with a formal package of
6427 -- the enclosing instantiation. Iterate over the list of renamings.
6429 E := First_Entity (Par);
6430 while Present (E) loop
6431 if Ekind (E) /= E_Package
6432 or else Nkind (Parent (E)) /= N_Package_Renaming_Declaration
6436 elsif Renamed_Object (E) = Par then
6439 elsif Renamed_Object (E) = Pack then
6442 elsif Is_Actual_Of_Previous_Formal (E) then
6452 end Denotes_Formal_Package;
6458 procedure End_Generic is
6460 -- ??? More things could be factored out in this routine. Should
6461 -- probably be done at a later stage.
6463 Inside_A_Generic := Generic_Flags.Table (Generic_Flags.Last);
6464 Generic_Flags.Decrement_Last;
6466 Expander_Mode_Restore;
6469 ----------------------
6470 -- Find_Actual_Type --
6471 ----------------------
6473 function Find_Actual_Type
6475 Gen_Type : Entity_Id) return Entity_Id
6477 Gen_Scope : constant Entity_Id := Scope (Gen_Type);
6481 -- Special processing only applies to child units
6483 if not Is_Child_Unit (Gen_Scope) then
6484 return Get_Instance_Of (Typ);
6486 -- If designated or component type is itself a formal of the child unit,
6487 -- its instance is available.
6489 elsif Scope (Typ) = Gen_Scope then
6490 return Get_Instance_Of (Typ);
6492 -- If the array or access type is not declared in the parent unit,
6493 -- no special processing needed.
6495 elsif not Is_Generic_Type (Typ)
6496 and then Scope (Gen_Scope) /= Scope (Typ)
6498 return Get_Instance_Of (Typ);
6500 -- Otherwise, retrieve designated or component type by visibility
6503 T := Current_Entity (Typ);
6504 while Present (T) loop
6505 if In_Open_Scopes (Scope (T)) then
6508 elsif Is_Generic_Actual_Type (T) then
6517 end Find_Actual_Type;
6519 ----------------------------
6520 -- Freeze_Subprogram_Body --
6521 ----------------------------
6523 procedure Freeze_Subprogram_Body
6524 (Inst_Node : Node_Id;
6526 Pack_Id : Entity_Id)
6529 Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node);
6530 Par : constant Entity_Id := Scope (Gen_Unit);
6535 function Earlier (N1, N2 : Node_Id) return Boolean;
6536 -- Yields True if N1 and N2 appear in the same compilation unit,
6537 -- ignoring subunits, and if N1 is to the left of N2 in a left-to-right
6538 -- traversal of the tree for the unit.
6540 function Enclosing_Body (N : Node_Id) return Node_Id;
6541 -- Find innermost package body that encloses the given node, and which
6542 -- is not a compilation unit. Freeze nodes for the instance, or for its
6543 -- enclosing body, may be inserted after the enclosing_body of the
6546 function Package_Freeze_Node (B : Node_Id) return Node_Id;
6547 -- Find entity for given package body, and locate or create a freeze
6550 function True_Parent (N : Node_Id) return Node_Id;
6551 -- For a subunit, return parent of corresponding stub
6557 function Earlier (N1, N2 : Node_Id) return Boolean is
6563 procedure Find_Depth (P : in out Node_Id; D : in out Integer);
6564 -- Find distance from given node to enclosing compilation unit
6570 procedure Find_Depth (P : in out Node_Id; D : in out Integer) is
6573 and then Nkind (P) /= N_Compilation_Unit
6575 P := True_Parent (P);
6580 -- Start of processing for Earlier
6583 Find_Depth (P1, D1);
6584 Find_Depth (P2, D2);
6594 P1 := True_Parent (P1);
6599 P2 := True_Parent (P2);
6603 -- At this point P1 and P2 are at the same distance from the root.
6604 -- We examine their parents until we find a common declarative
6605 -- list, at which point we can establish their relative placement
6606 -- by comparing their ultimate slocs. If we reach the root,
6607 -- N1 and N2 do not descend from the same declarative list (e.g.
6608 -- one is nested in the declarative part and the other is in a block
6609 -- in the statement part) and the earlier one is already frozen.
6611 while not Is_List_Member (P1)
6612 or else not Is_List_Member (P2)
6613 or else List_Containing (P1) /= List_Containing (P2)
6615 P1 := True_Parent (P1);
6616 P2 := True_Parent (P2);
6618 if Nkind (Parent (P1)) = N_Subunit then
6619 P1 := Corresponding_Stub (Parent (P1));
6622 if Nkind (Parent (P2)) = N_Subunit then
6623 P2 := Corresponding_Stub (Parent (P2));
6632 Top_Level_Location (Sloc (P1)) < Top_Level_Location (Sloc (P2));
6635 --------------------
6636 -- Enclosing_Body --
6637 --------------------
6639 function Enclosing_Body (N : Node_Id) return Node_Id is
6640 P : Node_Id := Parent (N);
6644 and then Nkind (Parent (P)) /= N_Compilation_Unit
6646 if Nkind (P) = N_Package_Body then
6648 if Nkind (Parent (P)) = N_Subunit then
6649 return Corresponding_Stub (Parent (P));
6655 P := True_Parent (P);
6661 -------------------------
6662 -- Package_Freeze_Node --
6663 -------------------------
6665 function Package_Freeze_Node (B : Node_Id) return Node_Id is
6669 if Nkind (B) = N_Package_Body then
6670 Id := Corresponding_Spec (B);
6672 else pragma Assert (Nkind (B) = N_Package_Body_Stub);
6673 Id := Corresponding_Spec (Proper_Body (Unit (Library_Unit (B))));
6676 Ensure_Freeze_Node (Id);
6677 return Freeze_Node (Id);
6678 end Package_Freeze_Node;
6684 function True_Parent (N : Node_Id) return Node_Id is
6686 if Nkind (Parent (N)) = N_Subunit then
6687 return Parent (Corresponding_Stub (Parent (N)));
6693 -- Start of processing of Freeze_Subprogram_Body
6696 -- If the instance and the generic body appear within the same unit, and
6697 -- the instance precedes the generic, the freeze node for the instance
6698 -- must appear after that of the generic. If the generic is nested
6699 -- within another instance I2, then current instance must be frozen
6700 -- after I2. In both cases, the freeze nodes are those of enclosing
6701 -- packages. Otherwise, the freeze node is placed at the end of the
6702 -- current declarative part.
6704 Enc_G := Enclosing_Body (Gen_Body);
6705 Enc_I := Enclosing_Body (Inst_Node);
6706 Ensure_Freeze_Node (Pack_Id);
6707 F_Node := Freeze_Node (Pack_Id);
6709 if Is_Generic_Instance (Par)
6710 and then Present (Freeze_Node (Par))
6712 In_Same_Declarative_Part (Freeze_Node (Par), Inst_Node)
6714 if ABE_Is_Certain (Get_Package_Instantiation_Node (Par)) then
6716 -- The parent was a premature instantiation. Insert freeze node at
6717 -- the end the current declarative part.
6719 Insert_After_Last_Decl (Inst_Node, F_Node);
6722 Insert_After (Freeze_Node (Par), F_Node);
6725 -- The body enclosing the instance should be frozen after the body that
6726 -- includes the generic, because the body of the instance may make
6727 -- references to entities therein. If the two are not in the same
6728 -- declarative part, or if the one enclosing the instance is frozen
6729 -- already, freeze the instance at the end of the current declarative
6732 elsif Is_Generic_Instance (Par)
6733 and then Present (Freeze_Node (Par))
6734 and then Present (Enc_I)
6736 if In_Same_Declarative_Part (Freeze_Node (Par), Enc_I)
6738 (Nkind (Enc_I) = N_Package_Body
6740 In_Same_Declarative_Part (Freeze_Node (Par), Parent (Enc_I)))
6742 -- The enclosing package may contain several instances. Rather
6743 -- than computing the earliest point at which to insert its
6744 -- freeze node, we place it at the end of the declarative part
6745 -- of the parent of the generic.
6747 Insert_After_Last_Decl
6748 (Freeze_Node (Par), Package_Freeze_Node (Enc_I));
6751 Insert_After_Last_Decl (Inst_Node, F_Node);
6753 elsif Present (Enc_G)
6754 and then Present (Enc_I)
6755 and then Enc_G /= Enc_I
6756 and then Earlier (Inst_Node, Gen_Body)
6758 if Nkind (Enc_G) = N_Package_Body then
6759 E_G_Id := Corresponding_Spec (Enc_G);
6760 else pragma Assert (Nkind (Enc_G) = N_Package_Body_Stub);
6762 Corresponding_Spec (Proper_Body (Unit (Library_Unit (Enc_G))));
6765 -- Freeze package that encloses instance, and place node after
6766 -- package that encloses generic. If enclosing package is already
6767 -- frozen we have to assume it is at the proper place. This may be
6768 -- a potential ABE that requires dynamic checking. Do not add a
6769 -- freeze node if the package that encloses the generic is inside
6770 -- the body that encloses the instance, because the freeze node
6771 -- would be in the wrong scope. Additional contortions needed if
6772 -- the bodies are within a subunit.
6775 Enclosing_Body : Node_Id;
6778 if Nkind (Enc_I) = N_Package_Body_Stub then
6779 Enclosing_Body := Proper_Body (Unit (Library_Unit (Enc_I)));
6781 Enclosing_Body := Enc_I;
6784 if Parent (List_Containing (Enc_G)) /= Enclosing_Body then
6785 Insert_After_Last_Decl (Enc_G, Package_Freeze_Node (Enc_I));
6789 -- Freeze enclosing subunit before instance
6791 Ensure_Freeze_Node (E_G_Id);
6793 if not Is_List_Member (Freeze_Node (E_G_Id)) then
6794 Insert_After (Enc_G, Freeze_Node (E_G_Id));
6797 Insert_After_Last_Decl (Inst_Node, F_Node);
6800 -- If none of the above, insert freeze node at the end of the current
6801 -- declarative part.
6803 Insert_After_Last_Decl (Inst_Node, F_Node);
6805 end Freeze_Subprogram_Body;
6811 function Get_Gen_Id (E : Assoc_Ptr) return Entity_Id is
6813 return Generic_Renamings.Table (E).Gen_Id;
6816 ---------------------
6817 -- Get_Instance_Of --
6818 ---------------------
6820 function Get_Instance_Of (A : Entity_Id) return Entity_Id is
6821 Res : constant Assoc_Ptr := Generic_Renamings_HTable.Get (A);
6824 if Res /= Assoc_Null then
6825 return Generic_Renamings.Table (Res).Act_Id;
6827 -- On exit, entity is not instantiated: not a generic parameter, or
6828 -- else parameter of an inner generic unit.
6832 end Get_Instance_Of;
6834 ------------------------------------
6835 -- Get_Package_Instantiation_Node --
6836 ------------------------------------
6838 function Get_Package_Instantiation_Node (A : Entity_Id) return Node_Id is
6839 Decl : Node_Id := Unit_Declaration_Node (A);
6843 -- If the Package_Instantiation attribute has been set on the package
6844 -- entity, then use it directly when it (or its Original_Node) refers
6845 -- to an N_Package_Instantiation node. In principle it should be
6846 -- possible to have this field set in all cases, which should be
6847 -- investigated, and would allow this function to be significantly
6850 if Present (Package_Instantiation (A)) then
6851 if Nkind (Package_Instantiation (A)) = N_Package_Instantiation then
6852 return Package_Instantiation (A);
6854 elsif Nkind (Original_Node (Package_Instantiation (A))) =
6855 N_Package_Instantiation
6857 return Original_Node (Package_Instantiation (A));
6861 -- If the instantiation is a compilation unit that does not need body
6862 -- then the instantiation node has been rewritten as a package
6863 -- declaration for the instance, and we return the original node.
6865 -- If it is a compilation unit and the instance node has not been
6866 -- rewritten, then it is still the unit of the compilation. Finally, if
6867 -- a body is present, this is a parent of the main unit whose body has
6868 -- been compiled for inlining purposes, and the instantiation node has
6869 -- been rewritten with the instance body.
6871 -- Otherwise the instantiation node appears after the declaration. If
6872 -- the entity is a formal package, the declaration may have been
6873 -- rewritten as a generic declaration (in the case of a formal with box)
6874 -- or left as a formal package declaration if it has actuals, and is
6875 -- found with a forward search.
6877 if Nkind (Parent (Decl)) = N_Compilation_Unit then
6878 if Nkind (Decl) = N_Package_Declaration
6879 and then Present (Corresponding_Body (Decl))
6881 Decl := Unit_Declaration_Node (Corresponding_Body (Decl));
6884 if Nkind (Original_Node (Decl)) = N_Package_Instantiation then
6885 return Original_Node (Decl);
6887 return Unit (Parent (Decl));
6890 elsif Nkind (Decl) = N_Package_Declaration
6891 and then Nkind (Original_Node (Decl)) = N_Formal_Package_Declaration
6893 return Original_Node (Decl);
6896 Inst := Next (Decl);
6897 while not Nkind_In (Inst, N_Package_Instantiation,
6898 N_Formal_Package_Declaration)
6905 end Get_Package_Instantiation_Node;
6907 ------------------------
6908 -- Has_Been_Exchanged --
6909 ------------------------
6911 function Has_Been_Exchanged (E : Entity_Id) return Boolean is
6915 Next := First_Elmt (Exchanged_Views);
6916 while Present (Next) loop
6917 if Full_View (Node (Next)) = E then
6925 end Has_Been_Exchanged;
6931 function Hash (F : Entity_Id) return HTable_Range is
6933 return HTable_Range (F mod HTable_Size);
6936 ------------------------
6937 -- Hide_Current_Scope --
6938 ------------------------
6940 procedure Hide_Current_Scope is
6941 C : constant Entity_Id := Current_Scope;
6945 Set_Is_Hidden_Open_Scope (C);
6947 E := First_Entity (C);
6948 while Present (E) loop
6949 if Is_Immediately_Visible (E) then
6950 Set_Is_Immediately_Visible (E, False);
6951 Append_Elmt (E, Hidden_Entities);
6957 -- Make the scope name invisible as well. This is necessary, but might
6958 -- conflict with calls to Rtsfind later on, in case the scope is a
6959 -- predefined one. There is no clean solution to this problem, so for
6960 -- now we depend on the user not redefining Standard itself in one of
6961 -- the parent units.
6963 if Is_Immediately_Visible (C)
6964 and then C /= Standard_Standard
6966 Set_Is_Immediately_Visible (C, False);
6967 Append_Elmt (C, Hidden_Entities);
6970 end Hide_Current_Scope;
6976 procedure Init_Env is
6977 Saved : Instance_Env;
6980 Saved.Instantiated_Parent := Current_Instantiated_Parent;
6981 Saved.Exchanged_Views := Exchanged_Views;
6982 Saved.Hidden_Entities := Hidden_Entities;
6983 Saved.Current_Sem_Unit := Current_Sem_Unit;
6984 Saved.Parent_Unit_Visible := Parent_Unit_Visible;
6985 Saved.Instance_Parent_Unit := Instance_Parent_Unit;
6987 -- Save configuration switches. These may be reset if the unit is a
6988 -- predefined unit, and the current mode is not Ada 2005.
6990 Save_Opt_Config_Switches (Saved.Switches);
6992 Instance_Envs.Append (Saved);
6994 Exchanged_Views := New_Elmt_List;
6995 Hidden_Entities := New_Elmt_List;
6997 -- Make dummy entry for Instantiated parent. If generic unit is legal,
6998 -- this is set properly in Set_Instance_Env.
7000 Current_Instantiated_Parent :=
7001 (Current_Scope, Current_Scope, Assoc_Null);
7004 ------------------------------
7005 -- In_Same_Declarative_Part --
7006 ------------------------------
7008 function In_Same_Declarative_Part
7010 Inst : Node_Id) return Boolean
7012 Decls : constant Node_Id := Parent (F_Node);
7013 Nod : Node_Id := Parent (Inst);
7016 while Present (Nod) loop
7020 elsif Nkind_In (Nod, N_Subprogram_Body,
7028 elsif Nkind (Nod) = N_Subunit then
7029 Nod := Corresponding_Stub (Nod);
7031 elsif Nkind (Nod) = N_Compilation_Unit then
7035 Nod := Parent (Nod);
7040 end In_Same_Declarative_Part;
7042 ---------------------
7043 -- In_Main_Context --
7044 ---------------------
7046 function In_Main_Context (E : Entity_Id) return Boolean is
7052 if not Is_Compilation_Unit (E)
7053 or else Ekind (E) /= E_Package
7054 or else In_Private_Part (E)
7059 Context := Context_Items (Cunit (Main_Unit));
7061 Clause := First (Context);
7062 while Present (Clause) loop
7063 if Nkind (Clause) = N_With_Clause then
7064 Nam := Name (Clause);
7066 -- If the current scope is part of the context of the main unit,
7067 -- analysis of the corresponding with_clause is not complete, and
7068 -- the entity is not set. We use the Chars field directly, which
7069 -- might produce false positives in rare cases, but guarantees
7070 -- that we produce all the instance bodies we will need.
7072 if (Is_Entity_Name (Nam)
7073 and then Chars (Nam) = Chars (E))
7074 or else (Nkind (Nam) = N_Selected_Component
7075 and then Chars (Selector_Name (Nam)) = Chars (E))
7085 end In_Main_Context;
7087 ---------------------
7088 -- Inherit_Context --
7089 ---------------------
7091 procedure Inherit_Context (Gen_Decl : Node_Id; Inst : Node_Id) is
7092 Current_Context : List_Id;
7093 Current_Unit : Node_Id;
7098 if Nkind (Parent (Gen_Decl)) = N_Compilation_Unit then
7100 -- The inherited context is attached to the enclosing compilation
7101 -- unit. This is either the main unit, or the declaration for the
7102 -- main unit (in case the instantiation appears within the package
7103 -- declaration and the main unit is its body).
7105 Current_Unit := Parent (Inst);
7106 while Present (Current_Unit)
7107 and then Nkind (Current_Unit) /= N_Compilation_Unit
7109 Current_Unit := Parent (Current_Unit);
7112 Current_Context := Context_Items (Current_Unit);
7114 Item := First (Context_Items (Parent (Gen_Decl)));
7115 while Present (Item) loop
7116 if Nkind (Item) = N_With_Clause then
7118 -- Take care to prevent direct cyclic with's, which can happen
7119 -- if the generic body with's the current unit. Such a case
7120 -- would result in binder errors (or run-time errors if the
7121 -- -gnatE switch is in effect), but we want to prevent it here,
7122 -- because Sem.Walk_Library_Items doesn't like cycles. Note
7123 -- that we don't bother to detect indirect cycles.
7125 if Library_Unit (Item) /= Current_Unit then
7126 New_I := New_Copy (Item);
7127 Set_Implicit_With (New_I, True);
7128 Append (New_I, Current_Context);
7135 end Inherit_Context;
7141 procedure Initialize is
7143 Generic_Renamings.Init;
7146 Generic_Renamings_HTable.Reset;
7147 Circularity_Detected := False;
7148 Exchanged_Views := No_Elist;
7149 Hidden_Entities := No_Elist;
7152 ----------------------------
7153 -- Insert_After_Last_Decl --
7154 ----------------------------
7156 procedure Insert_After_Last_Decl (N : Node_Id; F_Node : Node_Id) is
7157 L : List_Id := List_Containing (N);
7158 P : constant Node_Id := Parent (L);
7161 if not Is_List_Member (F_Node) then
7162 if Nkind (P) = N_Package_Specification
7163 and then L = Visible_Declarations (P)
7164 and then Present (Private_Declarations (P))
7165 and then not Is_Empty_List (Private_Declarations (P))
7167 L := Private_Declarations (P);
7170 Insert_After (Last (L), F_Node);
7172 end Insert_After_Last_Decl;
7178 procedure Install_Body
7179 (Act_Body : Node_Id;
7184 Act_Id : constant Entity_Id := Corresponding_Spec (Act_Body);
7185 Act_Unit : constant Node_Id := Unit (Cunit (Get_Source_Unit (N)));
7186 Gen_Id : constant Entity_Id := Corresponding_Spec (Gen_Body);
7187 Par : constant Entity_Id := Scope (Gen_Id);
7188 Gen_Unit : constant Node_Id :=
7189 Unit (Cunit (Get_Source_Unit (Gen_Decl)));
7190 Orig_Body : Node_Id := Gen_Body;
7192 Body_Unit : Node_Id;
7194 Must_Delay : Boolean;
7196 function Enclosing_Subp (Id : Entity_Id) return Entity_Id;
7197 -- Find subprogram (if any) that encloses instance and/or generic body
7199 function True_Sloc (N : Node_Id) return Source_Ptr;
7200 -- If the instance is nested inside a generic unit, the Sloc of the
7201 -- instance indicates the place of the original definition, not the
7202 -- point of the current enclosing instance. Pending a better usage of
7203 -- Slocs to indicate instantiation places, we determine the place of
7204 -- origin of a node by finding the maximum sloc of any ancestor node.
7205 -- Why is this not equivalent to Top_Level_Location ???
7207 --------------------
7208 -- Enclosing_Subp --
7209 --------------------
7211 function Enclosing_Subp (Id : Entity_Id) return Entity_Id is
7212 Scop : Entity_Id := Scope (Id);
7215 while Scop /= Standard_Standard
7216 and then not Is_Overloadable (Scop)
7218 Scop := Scope (Scop);
7228 function True_Sloc (N : Node_Id) return Source_Ptr is
7235 while Present (N1) and then N1 /= Act_Unit loop
7236 if Sloc (N1) > Res then
7246 -- Start of processing for Install_Body
7250 -- If the body is a subunit, the freeze point is the corresponding
7251 -- stub in the current compilation, not the subunit itself.
7253 if Nkind (Parent (Gen_Body)) = N_Subunit then
7254 Orig_Body := Corresponding_Stub (Parent (Gen_Body));
7256 Orig_Body := Gen_Body;
7259 Body_Unit := Unit (Cunit (Get_Source_Unit (Orig_Body)));
7261 -- If the instantiation and the generic definition appear in the same
7262 -- package declaration, this is an early instantiation. If they appear
7263 -- in the same declarative part, it is an early instantiation only if
7264 -- the generic body appears textually later, and the generic body is
7265 -- also in the main unit.
7267 -- If instance is nested within a subprogram, and the generic body is
7268 -- not, the instance is delayed because the enclosing body is. If
7269 -- instance and body are within the same scope, or the same sub-
7270 -- program body, indicate explicitly that the instance is delayed.
7273 (Gen_Unit = Act_Unit
7274 and then (Nkind_In (Gen_Unit, N_Package_Declaration,
7275 N_Generic_Package_Declaration)
7276 or else (Gen_Unit = Body_Unit
7277 and then True_Sloc (N) < Sloc (Orig_Body)))
7278 and then Is_In_Main_Unit (Gen_Unit)
7279 and then (Scope (Act_Id) = Scope (Gen_Id)
7281 Enclosing_Subp (Act_Id) = Enclosing_Subp (Gen_Id)));
7283 -- If this is an early instantiation, the freeze node is placed after
7284 -- the generic body. Otherwise, if the generic appears in an instance,
7285 -- we cannot freeze the current instance until the outer one is frozen.
7286 -- This is only relevant if the current instance is nested within some
7287 -- inner scope not itself within the outer instance. If this scope is
7288 -- a package body in the same declarative part as the outer instance,
7289 -- then that body needs to be frozen after the outer instance. Finally,
7290 -- if no delay is needed, we place the freeze node at the end of the
7291 -- current declarative part.
7293 if Expander_Active then
7294 Ensure_Freeze_Node (Act_Id);
7295 F_Node := Freeze_Node (Act_Id);
7298 Insert_After (Orig_Body, F_Node);
7300 elsif Is_Generic_Instance (Par)
7301 and then Present (Freeze_Node (Par))
7302 and then Scope (Act_Id) /= Par
7304 -- Freeze instance of inner generic after instance of enclosing
7307 if In_Same_Declarative_Part (Freeze_Node (Par), N) then
7308 Insert_After (Freeze_Node (Par), F_Node);
7310 -- Freeze package enclosing instance of inner generic after
7311 -- instance of enclosing generic.
7313 elsif Nkind (Parent (N)) = N_Package_Body
7314 and then In_Same_Declarative_Part (Freeze_Node (Par), Parent (N))
7318 Enclosing : constant Entity_Id :=
7319 Corresponding_Spec (Parent (N));
7322 Insert_After_Last_Decl (N, F_Node);
7323 Ensure_Freeze_Node (Enclosing);
7325 if not Is_List_Member (Freeze_Node (Enclosing)) then
7326 Insert_After (Freeze_Node (Par), Freeze_Node (Enclosing));
7331 Insert_After_Last_Decl (N, F_Node);
7335 Insert_After_Last_Decl (N, F_Node);
7339 Set_Is_Frozen (Act_Id);
7340 Insert_Before (N, Act_Body);
7341 Mark_Rewrite_Insertion (Act_Body);
7344 -----------------------------
7345 -- Install_Formal_Packages --
7346 -----------------------------
7348 procedure Install_Formal_Packages (Par : Entity_Id) is
7351 Gen_E : Entity_Id := Empty;
7354 E := First_Entity (Par);
7356 -- In we are installing an instance parent, locate the formal packages
7357 -- of its generic parent.
7359 if Is_Generic_Instance (Par) then
7360 Gen := Generic_Parent (Specification (Unit_Declaration_Node (Par)));
7361 Gen_E := First_Entity (Gen);
7364 while Present (E) loop
7365 if Ekind (E) = E_Package
7366 and then Nkind (Parent (E)) = N_Package_Renaming_Declaration
7368 -- If this is the renaming for the parent instance, done
7370 if Renamed_Object (E) = Par then
7373 -- The visibility of a formal of an enclosing generic is already
7376 elsif Denotes_Formal_Package (E) then
7379 elsif Present (Associated_Formal_Package (E)) then
7380 Check_Generic_Actuals (Renamed_Object (E), True);
7381 Set_Is_Hidden (E, False);
7383 -- Find formal package in generic unit that corresponds to
7384 -- (instance of) formal package in instance.
7386 while Present (Gen_E) and then Chars (Gen_E) /= Chars (E) loop
7387 Next_Entity (Gen_E);
7390 if Present (Gen_E) then
7391 Map_Formal_Package_Entities (Gen_E, E);
7397 if Present (Gen_E) then
7398 Next_Entity (Gen_E);
7401 end Install_Formal_Packages;
7403 --------------------
7404 -- Install_Parent --
7405 --------------------
7407 procedure Install_Parent (P : Entity_Id; In_Body : Boolean := False) is
7408 Ancestors : constant Elist_Id := New_Elmt_List;
7409 S : constant Entity_Id := Current_Scope;
7410 Inst_Par : Entity_Id;
7411 First_Par : Entity_Id;
7412 Inst_Node : Node_Id;
7413 Gen_Par : Entity_Id;
7414 First_Gen : Entity_Id;
7417 procedure Install_Noninstance_Specs (Par : Entity_Id);
7418 -- Install the scopes of noninstance parent units ending with Par
7420 procedure Install_Spec (Par : Entity_Id);
7421 -- The child unit is within the declarative part of the parent, so
7422 -- the declarations within the parent are immediately visible.
7424 -------------------------------
7425 -- Install_Noninstance_Specs --
7426 -------------------------------
7428 procedure Install_Noninstance_Specs (Par : Entity_Id) is
7431 and then Par /= Standard_Standard
7432 and then not In_Open_Scopes (Par)
7434 Install_Noninstance_Specs (Scope (Par));
7437 end Install_Noninstance_Specs;
7443 procedure Install_Spec (Par : Entity_Id) is
7444 Spec : constant Node_Id :=
7445 Specification (Unit_Declaration_Node (Par));
7448 -- If this parent of the child instance is a top-level unit,
7449 -- then record the unit and its visibility for later resetting
7450 -- in Remove_Parent. We exclude units that are generic instances,
7451 -- as we only want to record this information for the ultimate
7452 -- top-level noninstance parent (is that always correct???).
7454 if Scope (Par) = Standard_Standard
7455 and then not Is_Generic_Instance (Par)
7457 Parent_Unit_Visible := Is_Immediately_Visible (Par);
7458 Instance_Parent_Unit := Par;
7461 -- Open the parent scope and make it and its declarations visible.
7462 -- If this point is not within a body, then only the visible
7463 -- declarations should be made visible, and installation of the
7464 -- private declarations is deferred until the appropriate point
7465 -- within analysis of the spec being instantiated (see the handling
7466 -- of parent visibility in Analyze_Package_Specification). This is
7467 -- relaxed in the case where the parent unit is Ada.Tags, to avoid
7468 -- private view problems that occur when compiling instantiations of
7469 -- a generic child of that package (Generic_Dispatching_Constructor).
7470 -- If the instance freezes a tagged type, inlinings of operations
7471 -- from Ada.Tags may need the full view of type Tag. If inlining took
7472 -- proper account of establishing visibility of inlined subprograms'
7473 -- parents then it should be possible to remove this
7474 -- special check. ???
7477 Set_Is_Immediately_Visible (Par);
7478 Install_Visible_Declarations (Par);
7479 Set_Use (Visible_Declarations (Spec));
7481 if In_Body or else Is_RTU (Par, Ada_Tags) then
7482 Install_Private_Declarations (Par);
7483 Set_Use (Private_Declarations (Spec));
7487 -- Start of processing for Install_Parent
7490 -- We need to install the parent instance to compile the instantiation
7491 -- of the child, but the child instance must appear in the current
7492 -- scope. Given that we cannot place the parent above the current scope
7493 -- in the scope stack, we duplicate the current scope and unstack both
7494 -- after the instantiation is complete.
7496 -- If the parent is itself the instantiation of a child unit, we must
7497 -- also stack the instantiation of its parent, and so on. Each such
7498 -- ancestor is the prefix of the name in a prior instantiation.
7500 -- If this is a nested instance, the parent unit itself resolves to
7501 -- a renaming of the parent instance, whose declaration we need.
7503 -- Finally, the parent may be a generic (not an instance) when the
7504 -- child unit appears as a formal package.
7508 if Present (Renamed_Entity (Inst_Par)) then
7509 Inst_Par := Renamed_Entity (Inst_Par);
7512 First_Par := Inst_Par;
7515 Generic_Parent (Specification (Unit_Declaration_Node (Inst_Par)));
7517 First_Gen := Gen_Par;
7519 while Present (Gen_Par)
7520 and then Is_Child_Unit (Gen_Par)
7522 -- Load grandparent instance as well
7524 Inst_Node := Get_Package_Instantiation_Node (Inst_Par);
7526 if Nkind (Name (Inst_Node)) = N_Expanded_Name then
7527 Inst_Par := Entity (Prefix (Name (Inst_Node)));
7529 if Present (Renamed_Entity (Inst_Par)) then
7530 Inst_Par := Renamed_Entity (Inst_Par);
7535 (Specification (Unit_Declaration_Node (Inst_Par)));
7537 if Present (Gen_Par) then
7538 Prepend_Elmt (Inst_Par, Ancestors);
7541 -- Parent is not the name of an instantiation
7543 Install_Noninstance_Specs (Inst_Par);
7555 if Present (First_Gen) then
7556 Append_Elmt (First_Par, Ancestors);
7559 Install_Noninstance_Specs (First_Par);
7562 if not Is_Empty_Elmt_List (Ancestors) then
7563 Elmt := First_Elmt (Ancestors);
7565 while Present (Elmt) loop
7566 Install_Spec (Node (Elmt));
7567 Install_Formal_Packages (Node (Elmt));
7578 --------------------------------
7579 -- Instantiate_Formal_Package --
7580 --------------------------------
7582 function Instantiate_Formal_Package
7585 Analyzed_Formal : Node_Id) return List_Id
7587 Loc : constant Source_Ptr := Sloc (Actual);
7588 Actual_Pack : Entity_Id;
7589 Formal_Pack : Entity_Id;
7590 Gen_Parent : Entity_Id;
7593 Parent_Spec : Node_Id;
7595 procedure Find_Matching_Actual
7597 Act : in out Entity_Id);
7598 -- We need to associate each formal entity in the formal package
7599 -- with the corresponding entity in the actual package. The actual
7600 -- package has been analyzed and possibly expanded, and as a result
7601 -- there is no one-to-one correspondence between the two lists (for
7602 -- example, the actual may include subtypes, itypes, and inherited
7603 -- primitive operations, interspersed among the renaming declarations
7604 -- for the actuals) . We retrieve the corresponding actual by name
7605 -- because each actual has the same name as the formal, and they do
7606 -- appear in the same order.
7608 function Get_Formal_Entity (N : Node_Id) return Entity_Id;
7609 -- Retrieve entity of defining entity of generic formal parameter.
7610 -- Only the declarations of formals need to be considered when
7611 -- linking them to actuals, but the declarative list may include
7612 -- internal entities generated during analysis, and those are ignored.
7614 procedure Match_Formal_Entity
7615 (Formal_Node : Node_Id;
7616 Formal_Ent : Entity_Id;
7617 Actual_Ent : Entity_Id);
7618 -- Associates the formal entity with the actual. In the case
7619 -- where Formal_Ent is a formal package, this procedure iterates
7620 -- through all of its formals and enters associations between the
7621 -- actuals occurring in the formal package's corresponding actual
7622 -- package (given by Actual_Ent) and the formal package's formal
7623 -- parameters. This procedure recurses if any of the parameters is
7624 -- itself a package.
7626 function Is_Instance_Of
7627 (Act_Spec : Entity_Id;
7628 Gen_Anc : Entity_Id) return Boolean;
7629 -- The actual can be an instantiation of a generic within another
7630 -- instance, in which case there is no direct link from it to the
7631 -- original generic ancestor. In that case, we recognize that the
7632 -- ultimate ancestor is the same by examining names and scopes.
7634 procedure Process_Nested_Formal (Formal : Entity_Id);
7635 -- If the current formal is declared with a box, its own formals are
7636 -- visible in the instance, as they were in the generic, and their
7637 -- Hidden flag must be reset. If some of these formals are themselves
7638 -- packages declared with a box, the processing must be recursive.
7640 --------------------------
7641 -- Find_Matching_Actual --
7642 --------------------------
7644 procedure Find_Matching_Actual
7646 Act : in out Entity_Id)
7648 Formal_Ent : Entity_Id;
7651 case Nkind (Original_Node (F)) is
7652 when N_Formal_Object_Declaration |
7653 N_Formal_Type_Declaration =>
7654 Formal_Ent := Defining_Identifier (F);
7656 while Chars (Act) /= Chars (Formal_Ent) loop
7660 when N_Formal_Subprogram_Declaration |
7661 N_Formal_Package_Declaration |
7662 N_Package_Declaration |
7663 N_Generic_Package_Declaration =>
7664 Formal_Ent := Defining_Entity (F);
7666 while Chars (Act) /= Chars (Formal_Ent) loop
7671 raise Program_Error;
7673 end Find_Matching_Actual;
7675 -------------------------
7676 -- Match_Formal_Entity --
7677 -------------------------
7679 procedure Match_Formal_Entity
7680 (Formal_Node : Node_Id;
7681 Formal_Ent : Entity_Id;
7682 Actual_Ent : Entity_Id)
7684 Act_Pkg : Entity_Id;
7687 Set_Instance_Of (Formal_Ent, Actual_Ent);
7689 if Ekind (Actual_Ent) = E_Package then
7691 -- Record associations for each parameter
7693 Act_Pkg := Actual_Ent;
7696 A_Ent : Entity_Id := First_Entity (Act_Pkg);
7705 -- Retrieve the actual given in the formal package declaration
7707 Actual := Entity (Name (Original_Node (Formal_Node)));
7709 -- The actual in the formal package declaration may be a
7710 -- renamed generic package, in which case we want to retrieve
7711 -- the original generic in order to traverse its formal part.
7713 if Present (Renamed_Entity (Actual)) then
7714 Gen_Decl := Unit_Declaration_Node (Renamed_Entity (Actual));
7716 Gen_Decl := Unit_Declaration_Node (Actual);
7719 Formals := Generic_Formal_Declarations (Gen_Decl);
7721 if Present (Formals) then
7722 F_Node := First_Non_Pragma (Formals);
7727 while Present (A_Ent)
7728 and then Present (F_Node)
7729 and then A_Ent /= First_Private_Entity (Act_Pkg)
7731 F_Ent := Get_Formal_Entity (F_Node);
7733 if Present (F_Ent) then
7735 -- This is a formal of the original package. Record
7736 -- association and recurse.
7738 Find_Matching_Actual (F_Node, A_Ent);
7739 Match_Formal_Entity (F_Node, F_Ent, A_Ent);
7740 Next_Entity (A_Ent);
7743 Next_Non_Pragma (F_Node);
7747 end Match_Formal_Entity;
7749 -----------------------
7750 -- Get_Formal_Entity --
7751 -----------------------
7753 function Get_Formal_Entity (N : Node_Id) return Entity_Id is
7754 Kind : constant Node_Kind := Nkind (Original_Node (N));
7757 when N_Formal_Object_Declaration =>
7758 return Defining_Identifier (N);
7760 when N_Formal_Type_Declaration =>
7761 return Defining_Identifier (N);
7763 when N_Formal_Subprogram_Declaration =>
7764 return Defining_Unit_Name (Specification (N));
7766 when N_Formal_Package_Declaration =>
7767 return Defining_Identifier (Original_Node (N));
7769 when N_Generic_Package_Declaration =>
7770 return Defining_Identifier (Original_Node (N));
7772 -- All other declarations are introduced by semantic analysis and
7773 -- have no match in the actual.
7778 end Get_Formal_Entity;
7780 --------------------
7781 -- Is_Instance_Of --
7782 --------------------
7784 function Is_Instance_Of
7785 (Act_Spec : Entity_Id;
7786 Gen_Anc : Entity_Id) return Boolean
7788 Gen_Par : constant Entity_Id := Generic_Parent (Act_Spec);
7791 if No (Gen_Par) then
7794 -- Simplest case: the generic parent of the actual is the formal
7796 elsif Gen_Par = Gen_Anc then
7799 elsif Chars (Gen_Par) /= Chars (Gen_Anc) then
7802 -- The actual may be obtained through several instantiations. Its
7803 -- scope must itself be an instance of a generic declared in the
7804 -- same scope as the formal. Any other case is detected above.
7806 elsif not Is_Generic_Instance (Scope (Gen_Par)) then
7810 return Generic_Parent (Parent (Scope (Gen_Par))) = Scope (Gen_Anc);
7814 ---------------------------
7815 -- Process_Nested_Formal --
7816 ---------------------------
7818 procedure Process_Nested_Formal (Formal : Entity_Id) is
7822 if Present (Associated_Formal_Package (Formal))
7823 and then Box_Present (Parent (Associated_Formal_Package (Formal)))
7825 Ent := First_Entity (Formal);
7826 while Present (Ent) loop
7827 Set_Is_Hidden (Ent, False);
7828 Set_Is_Visible_Formal (Ent);
7829 Set_Is_Potentially_Use_Visible
7830 (Ent, Is_Potentially_Use_Visible (Formal));
7832 if Ekind (Ent) = E_Package then
7833 exit when Renamed_Entity (Ent) = Renamed_Entity (Formal);
7834 Process_Nested_Formal (Ent);
7840 end Process_Nested_Formal;
7842 -- Start of processing for Instantiate_Formal_Package
7847 if not Is_Entity_Name (Actual)
7848 or else Ekind (Entity (Actual)) /= E_Package
7851 ("expect package instance to instantiate formal", Actual);
7852 Abandon_Instantiation (Actual);
7853 raise Program_Error;
7856 Actual_Pack := Entity (Actual);
7857 Set_Is_Instantiated (Actual_Pack);
7859 -- The actual may be a renamed package, or an outer generic formal
7860 -- package whose instantiation is converted into a renaming.
7862 if Present (Renamed_Object (Actual_Pack)) then
7863 Actual_Pack := Renamed_Object (Actual_Pack);
7866 if Nkind (Analyzed_Formal) = N_Formal_Package_Declaration then
7867 Gen_Parent := Get_Instance_Of (Entity (Name (Analyzed_Formal)));
7868 Formal_Pack := Defining_Identifier (Analyzed_Formal);
7871 Generic_Parent (Specification (Analyzed_Formal));
7873 Defining_Unit_Name (Specification (Analyzed_Formal));
7876 if Nkind (Parent (Actual_Pack)) = N_Defining_Program_Unit_Name then
7877 Parent_Spec := Specification (Unit_Declaration_Node (Actual_Pack));
7879 Parent_Spec := Parent (Actual_Pack);
7882 if Gen_Parent = Any_Id then
7884 ("previous error in declaration of formal package", Actual);
7885 Abandon_Instantiation (Actual);
7888 Is_Instance_Of (Parent_Spec, Get_Instance_Of (Gen_Parent))
7894 ("actual parameter must be instance of&", Actual, Gen_Parent);
7895 Abandon_Instantiation (Actual);
7898 Set_Instance_Of (Defining_Identifier (Formal), Actual_Pack);
7899 Map_Formal_Package_Entities (Formal_Pack, Actual_Pack);
7902 Make_Package_Renaming_Declaration (Loc,
7903 Defining_Unit_Name => New_Copy (Defining_Identifier (Formal)),
7904 Name => New_Reference_To (Actual_Pack, Loc));
7906 Set_Associated_Formal_Package (Defining_Unit_Name (Nod),
7907 Defining_Identifier (Formal));
7908 Decls := New_List (Nod);
7910 -- If the formal F has a box, then the generic declarations are
7911 -- visible in the generic G. In an instance of G, the corresponding
7912 -- entities in the actual for F (which are the actuals for the
7913 -- instantiation of the generic that F denotes) must also be made
7914 -- visible for analysis of the current instance. On exit from the
7915 -- current instance, those entities are made private again. If the
7916 -- actual is currently in use, these entities are also use-visible.
7918 -- The loop through the actual entities also steps through the formal
7919 -- entities and enters associations from formals to actuals into the
7920 -- renaming map. This is necessary to properly handle checking of
7921 -- actual parameter associations for later formals that depend on
7922 -- actuals declared in the formal package.
7924 -- In Ada 2005, partial parametrization requires that we make visible
7925 -- the actuals corresponding to formals that were defaulted in the
7926 -- formal package. There formals are identified because they remain
7927 -- formal generics within the formal package, rather than being
7928 -- renamings of the actuals supplied.
7931 Gen_Decl : constant Node_Id :=
7932 Unit_Declaration_Node (Gen_Parent);
7933 Formals : constant List_Id :=
7934 Generic_Formal_Declarations (Gen_Decl);
7936 Actual_Ent : Entity_Id;
7937 Actual_Of_Formal : Node_Id;
7938 Formal_Node : Node_Id;
7939 Formal_Ent : Entity_Id;
7942 if Present (Formals) then
7943 Formal_Node := First_Non_Pragma (Formals);
7945 Formal_Node := Empty;
7948 Actual_Ent := First_Entity (Actual_Pack);
7950 First (Visible_Declarations (Specification (Analyzed_Formal)));
7951 while Present (Actual_Ent)
7952 and then Actual_Ent /= First_Private_Entity (Actual_Pack)
7954 if Present (Formal_Node) then
7955 Formal_Ent := Get_Formal_Entity (Formal_Node);
7957 if Present (Formal_Ent) then
7958 Find_Matching_Actual (Formal_Node, Actual_Ent);
7960 (Formal_Node, Formal_Ent, Actual_Ent);
7962 -- We iterate at the same time over the actuals of the
7963 -- local package created for the formal, to determine
7964 -- which one of the formals of the original generic were
7965 -- defaulted in the formal. The corresponding actual
7966 -- entities are visible in the enclosing instance.
7968 if Box_Present (Formal)
7970 (Present (Actual_Of_Formal)
7973 (Get_Formal_Entity (Actual_Of_Formal)))
7975 Set_Is_Hidden (Actual_Ent, False);
7976 Set_Is_Visible_Formal (Actual_Ent);
7977 Set_Is_Potentially_Use_Visible
7978 (Actual_Ent, In_Use (Actual_Pack));
7980 if Ekind (Actual_Ent) = E_Package then
7981 Process_Nested_Formal (Actual_Ent);
7985 Set_Is_Hidden (Actual_Ent);
7986 Set_Is_Potentially_Use_Visible (Actual_Ent, False);
7990 Next_Non_Pragma (Formal_Node);
7991 Next (Actual_Of_Formal);
7994 -- No further formals to match, but the generic part may
7995 -- contain inherited operation that are not hidden in the
7996 -- enclosing instance.
7998 Next_Entity (Actual_Ent);
8002 -- Inherited subprograms generated by formal derived types are
8003 -- also visible if the types are.
8005 Actual_Ent := First_Entity (Actual_Pack);
8006 while Present (Actual_Ent)
8007 and then Actual_Ent /= First_Private_Entity (Actual_Pack)
8009 if Is_Overloadable (Actual_Ent)
8011 Nkind (Parent (Actual_Ent)) = N_Subtype_Declaration
8013 not Is_Hidden (Defining_Identifier (Parent (Actual_Ent)))
8015 Set_Is_Hidden (Actual_Ent, False);
8016 Set_Is_Potentially_Use_Visible
8017 (Actual_Ent, In_Use (Actual_Pack));
8020 Next_Entity (Actual_Ent);
8024 -- If the formal is not declared with a box, reanalyze it as an
8025 -- abbreviated instantiation, to verify the matching rules of 12.7.
8026 -- The actual checks are performed after the generic associations
8027 -- have been analyzed, to guarantee the same visibility for this
8028 -- instantiation and for the actuals.
8030 -- In Ada 2005, the generic associations for the formal can include
8031 -- defaulted parameters. These are ignored during check. This
8032 -- internal instantiation is removed from the tree after conformance
8033 -- checking, because it contains formal declarations for those
8034 -- defaulted parameters, and those should not reach the back-end.
8036 if not Box_Present (Formal) then
8038 I_Pack : constant Entity_Id :=
8039 Make_Temporary (Sloc (Actual), 'P');
8042 Set_Is_Internal (I_Pack);
8045 Make_Package_Instantiation (Sloc (Actual),
8046 Defining_Unit_Name => I_Pack,
8049 (Get_Instance_Of (Gen_Parent), Sloc (Actual)),
8050 Generic_Associations =>
8051 Generic_Associations (Formal)));
8057 end Instantiate_Formal_Package;
8059 -----------------------------------
8060 -- Instantiate_Formal_Subprogram --
8061 -----------------------------------
8063 function Instantiate_Formal_Subprogram
8066 Analyzed_Formal : Node_Id) return Node_Id
8069 Formal_Sub : constant Entity_Id :=
8070 Defining_Unit_Name (Specification (Formal));
8071 Analyzed_S : constant Entity_Id :=
8072 Defining_Unit_Name (Specification (Analyzed_Formal));
8073 Decl_Node : Node_Id;
8077 function From_Parent_Scope (Subp : Entity_Id) return Boolean;
8078 -- If the generic is a child unit, the parent has been installed on the
8079 -- scope stack, but a default subprogram cannot resolve to something on
8080 -- the parent because that parent is not really part of the visible
8081 -- context (it is there to resolve explicit local entities). If the
8082 -- default has resolved in this way, we remove the entity from
8083 -- immediate visibility and analyze the node again to emit an error
8084 -- message or find another visible candidate.
8086 procedure Valid_Actual_Subprogram (Act : Node_Id);
8087 -- Perform legality check and raise exception on failure
8089 -----------------------
8090 -- From_Parent_Scope --
8091 -----------------------
8093 function From_Parent_Scope (Subp : Entity_Id) return Boolean is
8094 Gen_Scope : Node_Id;
8097 Gen_Scope := Scope (Analyzed_S);
8098 while Present (Gen_Scope)
8099 and then Is_Child_Unit (Gen_Scope)
8101 if Scope (Subp) = Scope (Gen_Scope) then
8105 Gen_Scope := Scope (Gen_Scope);
8109 end From_Parent_Scope;
8111 -----------------------------
8112 -- Valid_Actual_Subprogram --
8113 -----------------------------
8115 procedure Valid_Actual_Subprogram (Act : Node_Id) is
8119 if Is_Entity_Name (Act) then
8120 Act_E := Entity (Act);
8122 elsif Nkind (Act) = N_Selected_Component
8123 and then Is_Entity_Name (Selector_Name (Act))
8125 Act_E := Entity (Selector_Name (Act));
8131 if (Present (Act_E) and then Is_Overloadable (Act_E))
8132 or else Nkind_In (Act, N_Attribute_Reference,
8133 N_Indexed_Component,
8134 N_Character_Literal,
8135 N_Explicit_Dereference)
8141 ("expect subprogram or entry name in instantiation of&",
8142 Instantiation_Node, Formal_Sub);
8143 Abandon_Instantiation (Instantiation_Node);
8145 end Valid_Actual_Subprogram;
8147 -- Start of processing for Instantiate_Formal_Subprogram
8150 New_Spec := New_Copy_Tree (Specification (Formal));
8152 -- The tree copy has created the proper instantiation sloc for the
8153 -- new specification. Use this location for all other constructed
8156 Loc := Sloc (Defining_Unit_Name (New_Spec));
8158 -- Create new entity for the actual (New_Copy_Tree does not)
8160 Set_Defining_Unit_Name
8161 (New_Spec, Make_Defining_Identifier (Loc, Chars (Formal_Sub)));
8163 -- Create new entities for the each of the formals in the
8164 -- specification of the renaming declaration built for the actual.
8166 if Present (Parameter_Specifications (New_Spec)) then
8170 F := First (Parameter_Specifications (New_Spec));
8171 while Present (F) loop
8172 Set_Defining_Identifier (F,
8173 Make_Defining_Identifier (Sloc (F),
8174 Chars => Chars (Defining_Identifier (F))));
8180 -- Find entity of actual. If the actual is an attribute reference, it
8181 -- cannot be resolved here (its formal is missing) but is handled
8182 -- instead in Attribute_Renaming. If the actual is overloaded, it is
8183 -- fully resolved subsequently, when the renaming declaration for the
8184 -- formal is analyzed. If it is an explicit dereference, resolve the
8185 -- prefix but not the actual itself, to prevent interpretation as call.
8187 if Present (Actual) then
8188 Loc := Sloc (Actual);
8189 Set_Sloc (New_Spec, Loc);
8191 if Nkind (Actual) = N_Operator_Symbol then
8192 Find_Direct_Name (Actual);
8194 elsif Nkind (Actual) = N_Explicit_Dereference then
8195 Analyze (Prefix (Actual));
8197 elsif Nkind (Actual) /= N_Attribute_Reference then
8201 Valid_Actual_Subprogram (Actual);
8204 elsif Present (Default_Name (Formal)) then
8205 if not Nkind_In (Default_Name (Formal), N_Attribute_Reference,
8206 N_Selected_Component,
8207 N_Indexed_Component,
8208 N_Character_Literal)
8209 and then Present (Entity (Default_Name (Formal)))
8211 Nam := New_Occurrence_Of (Entity (Default_Name (Formal)), Loc);
8213 Nam := New_Copy (Default_Name (Formal));
8214 Set_Sloc (Nam, Loc);
8217 elsif Box_Present (Formal) then
8219 -- Actual is resolved at the point of instantiation. Create an
8220 -- identifier or operator with the same name as the formal.
8222 if Nkind (Formal_Sub) = N_Defining_Operator_Symbol then
8223 Nam := Make_Operator_Symbol (Loc,
8224 Chars => Chars (Formal_Sub),
8225 Strval => No_String);
8227 Nam := Make_Identifier (Loc, Chars (Formal_Sub));
8230 elsif Nkind (Specification (Formal)) = N_Procedure_Specification
8231 and then Null_Present (Specification (Formal))
8233 -- Generate null body for procedure, for use in the instance
8236 Make_Subprogram_Body (Loc,
8237 Specification => New_Spec,
8238 Declarations => New_List,
8239 Handled_Statement_Sequence =>
8240 Make_Handled_Sequence_Of_Statements (Loc,
8241 Statements => New_List (Make_Null_Statement (Loc))));
8243 Set_Is_Intrinsic_Subprogram (Defining_Unit_Name (New_Spec));
8247 Error_Msg_Sloc := Sloc (Scope (Analyzed_S));
8249 ("missing actual&", Instantiation_Node, Formal_Sub);
8251 ("\in instantiation of & declared#",
8252 Instantiation_Node, Scope (Analyzed_S));
8253 Abandon_Instantiation (Instantiation_Node);
8257 Make_Subprogram_Renaming_Declaration (Loc,
8258 Specification => New_Spec,
8261 -- If we do not have an actual and the formal specified <> then set to
8262 -- get proper default.
8264 if No (Actual) and then Box_Present (Formal) then
8265 Set_From_Default (Decl_Node);
8268 -- Gather possible interpretations for the actual before analyzing the
8269 -- instance. If overloaded, it will be resolved when analyzing the
8270 -- renaming declaration.
8272 if Box_Present (Formal)
8273 and then No (Actual)
8277 if Is_Child_Unit (Scope (Analyzed_S))
8278 and then Present (Entity (Nam))
8280 if not Is_Overloaded (Nam) then
8282 if From_Parent_Scope (Entity (Nam)) then
8283 Set_Is_Immediately_Visible (Entity (Nam), False);
8284 Set_Entity (Nam, Empty);
8285 Set_Etype (Nam, Empty);
8289 Set_Is_Immediately_Visible (Entity (Nam));
8298 Get_First_Interp (Nam, I, It);
8300 while Present (It.Nam) loop
8301 if From_Parent_Scope (It.Nam) then
8305 Get_Next_Interp (I, It);
8312 -- The generic instantiation freezes the actual. This can only be done
8313 -- once the actual is resolved, in the analysis of the renaming
8314 -- declaration. To make the formal subprogram entity available, we set
8315 -- Corresponding_Formal_Spec to point to the formal subprogram entity.
8316 -- This is also needed in Analyze_Subprogram_Renaming for the processing
8317 -- of formal abstract subprograms.
8319 Set_Corresponding_Formal_Spec (Decl_Node, Analyzed_S);
8321 -- We cannot analyze the renaming declaration, and thus find the actual,
8322 -- until all the actuals are assembled in the instance. For subsequent
8323 -- checks of other actuals, indicate the node that will hold the
8324 -- instance of this formal.
8326 Set_Instance_Of (Analyzed_S, Nam);
8328 if Nkind (Actual) = N_Selected_Component
8329 and then Is_Task_Type (Etype (Prefix (Actual)))
8330 and then not Is_Frozen (Etype (Prefix (Actual)))
8332 -- The renaming declaration will create a body, which must appear
8333 -- outside of the instantiation, We move the renaming declaration
8334 -- out of the instance, and create an additional renaming inside,
8335 -- to prevent freezing anomalies.
8338 Anon_Id : constant Entity_Id := Make_Temporary (Loc, 'E');
8341 Set_Defining_Unit_Name (New_Spec, Anon_Id);
8342 Insert_Before (Instantiation_Node, Decl_Node);
8343 Analyze (Decl_Node);
8345 -- Now create renaming within the instance
8348 Make_Subprogram_Renaming_Declaration (Loc,
8349 Specification => New_Copy_Tree (New_Spec),
8350 Name => New_Occurrence_Of (Anon_Id, Loc));
8352 Set_Defining_Unit_Name (Specification (Decl_Node),
8353 Make_Defining_Identifier (Loc, Chars (Formal_Sub)));
8358 end Instantiate_Formal_Subprogram;
8360 ------------------------
8361 -- Instantiate_Object --
8362 ------------------------
8364 function Instantiate_Object
8367 Analyzed_Formal : Node_Id) return List_Id
8369 Gen_Obj : constant Entity_Id := Defining_Identifier (Formal);
8370 A_Gen_Obj : constant Entity_Id :=
8371 Defining_Identifier (Analyzed_Formal);
8372 Acc_Def : Node_Id := Empty;
8373 Act_Assoc : constant Node_Id := Parent (Actual);
8374 Actual_Decl : Node_Id := Empty;
8375 Decl_Node : Node_Id;
8378 List : constant List_Id := New_List;
8379 Loc : constant Source_Ptr := Sloc (Actual);
8380 Orig_Ftyp : constant Entity_Id := Etype (A_Gen_Obj);
8381 Subt_Decl : Node_Id := Empty;
8382 Subt_Mark : Node_Id := Empty;
8385 if Present (Subtype_Mark (Formal)) then
8386 Subt_Mark := Subtype_Mark (Formal);
8388 Check_Access_Definition (Formal);
8389 Acc_Def := Access_Definition (Formal);
8392 -- Sloc for error message on missing actual
8394 Error_Msg_Sloc := Sloc (Scope (A_Gen_Obj));
8396 if Get_Instance_Of (Gen_Obj) /= Gen_Obj then
8397 Error_Msg_N ("duplicate instantiation of generic parameter", Actual);
8400 Set_Parent (List, Parent (Actual));
8404 if Out_Present (Formal) then
8406 -- An IN OUT generic actual must be a name. The instantiation is a
8407 -- renaming declaration. The actual is the name being renamed. We
8408 -- use the actual directly, rather than a copy, because it is not
8409 -- used further in the list of actuals, and because a copy or a use
8410 -- of relocate_node is incorrect if the instance is nested within a
8411 -- generic. In order to simplify ASIS searches, the Generic_Parent
8412 -- field links the declaration to the generic association.
8417 Instantiation_Node, Gen_Obj);
8419 ("\in instantiation of & declared#",
8420 Instantiation_Node, Scope (A_Gen_Obj));
8421 Abandon_Instantiation (Instantiation_Node);
8424 if Present (Subt_Mark) then
8426 Make_Object_Renaming_Declaration (Loc,
8427 Defining_Identifier => New_Copy (Gen_Obj),
8428 Subtype_Mark => New_Copy_Tree (Subt_Mark),
8431 else pragma Assert (Present (Acc_Def));
8433 Make_Object_Renaming_Declaration (Loc,
8434 Defining_Identifier => New_Copy (Gen_Obj),
8435 Access_Definition => New_Copy_Tree (Acc_Def),
8439 Set_Corresponding_Generic_Association (Decl_Node, Act_Assoc);
8441 -- The analysis of the actual may produce insert_action nodes, so
8442 -- the declaration must have a context in which to attach them.
8444 Append (Decl_Node, List);
8447 -- Return if the analysis of the actual reported some error
8449 if Etype (Actual) = Any_Type then
8453 -- This check is performed here because Analyze_Object_Renaming will
8454 -- not check it when Comes_From_Source is False. Note though that the
8455 -- check for the actual being the name of an object will be performed
8456 -- in Analyze_Object_Renaming.
8458 if Is_Object_Reference (Actual)
8459 and then Is_Dependent_Component_Of_Mutable_Object (Actual)
8462 ("illegal discriminant-dependent component for in out parameter",
8466 -- The actual has to be resolved in order to check that it is a
8467 -- variable (due to cases such as F (1), where F returns access to an
8468 -- array, and for overloaded prefixes).
8470 Ftyp := Get_Instance_Of (Etype (A_Gen_Obj));
8472 -- If the type of the formal is not itself a formal, and the
8473 -- current unit is a child unit, the formal type must be declared
8474 -- in a parent, and must be retrieved by visibility.
8477 and then Is_Generic_Unit (Scope (Ftyp))
8478 and then Is_Child_Unit (Scope (A_Gen_Obj))
8481 Temp : constant Node_Id :=
8482 New_Copy_Tree (Subtype_Mark (Analyzed_Formal));
8484 Set_Entity (Temp, Empty);
8486 Ftyp := Entity (Temp);
8490 if Is_Private_Type (Ftyp)
8491 and then not Is_Private_Type (Etype (Actual))
8492 and then (Base_Type (Full_View (Ftyp)) = Base_Type (Etype (Actual))
8493 or else Base_Type (Etype (Actual)) = Ftyp)
8495 -- If the actual has the type of the full view of the formal, or
8496 -- else a non-private subtype of the formal, then the visibility
8497 -- of the formal type has changed. Add to the actuals a subtype
8498 -- declaration that will force the exchange of views in the body
8499 -- of the instance as well.
8502 Make_Subtype_Declaration (Loc,
8503 Defining_Identifier => Make_Temporary (Loc, 'P'),
8504 Subtype_Indication => New_Occurrence_Of (Ftyp, Loc));
8506 Prepend (Subt_Decl, List);
8508 Prepend_Elmt (Full_View (Ftyp), Exchanged_Views);
8509 Exchange_Declarations (Ftyp);
8512 Resolve (Actual, Ftyp);
8514 if not Denotes_Variable (Actual) then
8516 ("actual for& must be a variable", Actual, Gen_Obj);
8518 elsif Base_Type (Ftyp) /= Base_Type (Etype (Actual)) then
8520 -- Ada 2005 (AI-423): For a generic formal object of mode in out,
8521 -- the type of the actual shall resolve to a specific anonymous
8524 if Ada_Version < Ada_2005
8526 Ekind (Base_Type (Ftyp)) /=
8527 E_Anonymous_Access_Type
8529 Ekind (Base_Type (Etype (Actual))) /=
8530 E_Anonymous_Access_Type
8532 Error_Msg_NE ("type of actual does not match type of&",
8537 Note_Possible_Modification (Actual, Sure => True);
8539 -- Check for instantiation of atomic/volatile actual for
8540 -- non-atomic/volatile formal (RM C.6 (12)).
8542 if Is_Atomic_Object (Actual)
8543 and then not Is_Atomic (Orig_Ftyp)
8546 ("cannot instantiate non-atomic formal object " &
8547 "with atomic actual", Actual);
8549 elsif Is_Volatile_Object (Actual)
8550 and then not Is_Volatile (Orig_Ftyp)
8553 ("cannot instantiate non-volatile formal object " &
8554 "with volatile actual", Actual);
8557 -- Formal in-parameter
8560 -- The instantiation of a generic formal in-parameter is constant
8561 -- declaration. The actual is the expression for that declaration.
8563 if Present (Actual) then
8564 if Present (Subt_Mark) then
8566 else pragma Assert (Present (Acc_Def));
8571 Make_Object_Declaration (Loc,
8572 Defining_Identifier => New_Copy (Gen_Obj),
8573 Constant_Present => True,
8574 Null_Exclusion_Present => Null_Exclusion_Present (Formal),
8575 Object_Definition => New_Copy_Tree (Def),
8576 Expression => Actual);
8578 Set_Corresponding_Generic_Association (Decl_Node, Act_Assoc);
8580 -- A generic formal object of a tagged type is defined to be
8581 -- aliased so the new constant must also be treated as aliased.
8583 if Is_Tagged_Type (Etype (A_Gen_Obj)) then
8584 Set_Aliased_Present (Decl_Node);
8587 Append (Decl_Node, List);
8589 -- No need to repeat (pre-)analysis of some expression nodes
8590 -- already handled in Preanalyze_Actuals.
8592 if Nkind (Actual) /= N_Allocator then
8595 -- Return if the analysis of the actual reported some error
8597 if Etype (Actual) = Any_Type then
8603 Formal_Type : constant Entity_Id := Etype (A_Gen_Obj);
8607 Typ := Get_Instance_Of (Formal_Type);
8609 Freeze_Before (Instantiation_Node, Typ);
8611 -- If the actual is an aggregate, perform name resolution on
8612 -- its components (the analysis of an aggregate does not do it)
8613 -- to capture local names that may be hidden if the generic is
8616 if Nkind (Actual) = N_Aggregate then
8617 Preanalyze_And_Resolve (Actual, Typ);
8620 if Is_Limited_Type (Typ)
8621 and then not OK_For_Limited_Init (Typ, Actual)
8624 ("initialization not allowed for limited types", Actual);
8625 Explain_Limited_Type (Typ, Actual);
8629 elsif Present (Default_Expression (Formal)) then
8631 -- Use default to construct declaration
8633 if Present (Subt_Mark) then
8635 else pragma Assert (Present (Acc_Def));
8640 Make_Object_Declaration (Sloc (Formal),
8641 Defining_Identifier => New_Copy (Gen_Obj),
8642 Constant_Present => True,
8643 Null_Exclusion_Present => Null_Exclusion_Present (Formal),
8644 Object_Definition => New_Copy (Def),
8645 Expression => New_Copy_Tree
8646 (Default_Expression (Formal)));
8648 Append (Decl_Node, List);
8649 Set_Analyzed (Expression (Decl_Node), False);
8654 Instantiation_Node, Gen_Obj);
8655 Error_Msg_NE ("\in instantiation of & declared#",
8656 Instantiation_Node, Scope (A_Gen_Obj));
8658 if Is_Scalar_Type (Etype (A_Gen_Obj)) then
8660 -- Create dummy constant declaration so that instance can be
8661 -- analyzed, to minimize cascaded visibility errors.
8663 if Present (Subt_Mark) then
8665 else pragma Assert (Present (Acc_Def));
8670 Make_Object_Declaration (Loc,
8671 Defining_Identifier => New_Copy (Gen_Obj),
8672 Constant_Present => True,
8673 Null_Exclusion_Present => Null_Exclusion_Present (Formal),
8674 Object_Definition => New_Copy (Def),
8676 Make_Attribute_Reference (Sloc (Gen_Obj),
8677 Attribute_Name => Name_First,
8678 Prefix => New_Copy (Def)));
8680 Append (Decl_Node, List);
8683 Abandon_Instantiation (Instantiation_Node);
8688 if Nkind (Actual) in N_Has_Entity then
8689 Actual_Decl := Parent (Entity (Actual));
8692 -- Ada 2005 (AI-423): For a formal object declaration with a null
8693 -- exclusion or an access definition that has a null exclusion: If the
8694 -- actual matching the formal object declaration denotes a generic
8695 -- formal object of another generic unit G, and the instantiation
8696 -- containing the actual occurs within the body of G or within the body
8697 -- of a generic unit declared within the declarative region of G, then
8698 -- the declaration of the formal object of G must have a null exclusion.
8699 -- Otherwise, the subtype of the actual matching the formal object
8700 -- declaration shall exclude null.
8702 if Ada_Version >= Ada_2005
8703 and then Present (Actual_Decl)
8705 Nkind_In (Actual_Decl, N_Formal_Object_Declaration,
8706 N_Object_Declaration)
8707 and then Nkind (Analyzed_Formal) = N_Formal_Object_Declaration
8708 and then not Has_Null_Exclusion (Actual_Decl)
8709 and then Has_Null_Exclusion (Analyzed_Formal)
8711 Error_Msg_Sloc := Sloc (Analyzed_Formal);
8713 ("actual must exclude null to match generic formal#", Actual);
8717 end Instantiate_Object;
8719 ------------------------------
8720 -- Instantiate_Package_Body --
8721 ------------------------------
8723 procedure Instantiate_Package_Body
8724 (Body_Info : Pending_Body_Info;
8725 Inlined_Body : Boolean := False;
8726 Body_Optional : Boolean := False)
8728 Act_Decl : constant Node_Id := Body_Info.Act_Decl;
8729 Inst_Node : constant Node_Id := Body_Info.Inst_Node;
8730 Loc : constant Source_Ptr := Sloc (Inst_Node);
8732 Gen_Id : constant Node_Id := Name (Inst_Node);
8733 Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node);
8734 Gen_Decl : constant Node_Id := Unit_Declaration_Node (Gen_Unit);
8735 Act_Spec : constant Node_Id := Specification (Act_Decl);
8736 Act_Decl_Id : constant Entity_Id := Defining_Entity (Act_Spec);
8738 Act_Body_Name : Node_Id;
8740 Gen_Body_Id : Node_Id;
8742 Act_Body_Id : Entity_Id;
8744 Parent_Installed : Boolean := False;
8745 Save_Style_Check : constant Boolean := Style_Check;
8747 Par_Ent : Entity_Id := Empty;
8748 Par_Vis : Boolean := False;
8751 Gen_Body_Id := Corresponding_Body (Gen_Decl);
8753 -- The instance body may already have been processed, as the parent of
8754 -- another instance that is inlined (Load_Parent_Of_Generic).
8756 if Present (Corresponding_Body (Instance_Spec (Inst_Node))) then
8760 Expander_Mode_Save_And_Set (Body_Info.Expander_Status);
8762 -- Re-establish the state of information on which checks are suppressed.
8763 -- This information was set in Body_Info at the point of instantiation,
8764 -- and now we restore it so that the instance is compiled using the
8765 -- check status at the instantiation (RM 11.5 (7.2/2), AI95-00224-01).
8767 Local_Suppress_Stack_Top := Body_Info.Local_Suppress_Stack_Top;
8768 Scope_Suppress := Body_Info.Scope_Suppress;
8769 Opt.Ada_Version := Body_Info.Version;
8771 if No (Gen_Body_Id) then
8772 Load_Parent_Of_Generic
8773 (Inst_Node, Specification (Gen_Decl), Body_Optional);
8774 Gen_Body_Id := Corresponding_Body (Gen_Decl);
8777 -- Establish global variable for sloc adjustment and for error recovery
8779 Instantiation_Node := Inst_Node;
8781 if Present (Gen_Body_Id) then
8782 Save_Env (Gen_Unit, Act_Decl_Id);
8783 Style_Check := False;
8784 Current_Sem_Unit := Body_Info.Current_Sem_Unit;
8786 Gen_Body := Unit_Declaration_Node (Gen_Body_Id);
8788 Create_Instantiation_Source
8789 (Inst_Node, Gen_Body_Id, False, S_Adjustment);
8793 (Original_Node (Gen_Body), Empty, Instantiating => True);
8795 -- Build new name (possibly qualified) for body declaration
8797 Act_Body_Id := New_Copy (Act_Decl_Id);
8799 -- Some attributes of spec entity are not inherited by body entity
8801 Set_Handler_Records (Act_Body_Id, No_List);
8803 if Nkind (Defining_Unit_Name (Act_Spec)) =
8804 N_Defining_Program_Unit_Name
8807 Make_Defining_Program_Unit_Name (Loc,
8808 Name => New_Copy_Tree (Name (Defining_Unit_Name (Act_Spec))),
8809 Defining_Identifier => Act_Body_Id);
8811 Act_Body_Name := Act_Body_Id;
8814 Set_Defining_Unit_Name (Act_Body, Act_Body_Name);
8816 Set_Corresponding_Spec (Act_Body, Act_Decl_Id);
8817 Check_Generic_Actuals (Act_Decl_Id, False);
8819 -- If it is a child unit, make the parent instance (which is an
8820 -- instance of the parent of the generic) visible. The parent
8821 -- instance is the prefix of the name of the generic unit.
8823 if Ekind (Scope (Gen_Unit)) = E_Generic_Package
8824 and then Nkind (Gen_Id) = N_Expanded_Name
8826 Par_Ent := Entity (Prefix (Gen_Id));
8827 Par_Vis := Is_Immediately_Visible (Par_Ent);
8828 Install_Parent (Par_Ent, In_Body => True);
8829 Parent_Installed := True;
8831 elsif Is_Child_Unit (Gen_Unit) then
8832 Par_Ent := Scope (Gen_Unit);
8833 Par_Vis := Is_Immediately_Visible (Par_Ent);
8834 Install_Parent (Par_Ent, In_Body => True);
8835 Parent_Installed := True;
8838 -- If the instantiation is a library unit, and this is the main unit,
8839 -- then build the resulting compilation unit nodes for the instance.
8840 -- If this is a compilation unit but it is not the main unit, then it
8841 -- is the body of a unit in the context, that is being compiled
8842 -- because it is encloses some inlined unit or another generic unit
8843 -- being instantiated. In that case, this body is not part of the
8844 -- current compilation, and is not attached to the tree, but its
8845 -- parent must be set for analysis.
8847 if Nkind (Parent (Inst_Node)) = N_Compilation_Unit then
8849 -- Replace instance node with body of instance, and create new
8850 -- node for corresponding instance declaration.
8852 Build_Instance_Compilation_Unit_Nodes
8853 (Inst_Node, Act_Body, Act_Decl);
8854 Analyze (Inst_Node);
8856 if Parent (Inst_Node) = Cunit (Main_Unit) then
8858 -- If the instance is a child unit itself, then set the scope
8859 -- of the expanded body to be the parent of the instantiation
8860 -- (ensuring that the fully qualified name will be generated
8861 -- for the elaboration subprogram).
8863 if Nkind (Defining_Unit_Name (Act_Spec)) =
8864 N_Defining_Program_Unit_Name
8867 (Defining_Entity (Inst_Node), Scope (Act_Decl_Id));
8871 -- Case where instantiation is not a library unit
8874 -- If this is an early instantiation, i.e. appears textually
8875 -- before the corresponding body and must be elaborated first,
8876 -- indicate that the body instance is to be delayed.
8878 Install_Body (Act_Body, Inst_Node, Gen_Body, Gen_Decl);
8880 -- Now analyze the body. We turn off all checks if this is an
8881 -- internal unit, since there is no reason to have checks on for
8882 -- any predefined run-time library code. All such code is designed
8883 -- to be compiled with checks off.
8885 -- Note that we do NOT apply this criterion to children of GNAT
8886 -- (or on VMS, children of DEC). The latter units must suppress
8887 -- checks explicitly if this is needed.
8889 if Is_Predefined_File_Name
8890 (Unit_File_Name (Get_Source_Unit (Gen_Decl)))
8892 Analyze (Act_Body, Suppress => All_Checks);
8898 Inherit_Context (Gen_Body, Inst_Node);
8900 -- Remove the parent instances if they have been placed on the scope
8901 -- stack to compile the body.
8903 if Parent_Installed then
8904 Remove_Parent (In_Body => True);
8906 -- Restore the previous visibility of the parent
8908 Set_Is_Immediately_Visible (Par_Ent, Par_Vis);
8911 Restore_Private_Views (Act_Decl_Id);
8913 -- Remove the current unit from visibility if this is an instance
8914 -- that is not elaborated on the fly for inlining purposes.
8916 if not Inlined_Body then
8917 Set_Is_Immediately_Visible (Act_Decl_Id, False);
8921 Style_Check := Save_Style_Check;
8923 -- If we have no body, and the unit requires a body, then complain. This
8924 -- complaint is suppressed if we have detected other errors (since a
8925 -- common reason for missing the body is that it had errors).
8926 -- In CodePeer mode, a warning has been emitted already, no need for
8927 -- further messages.
8929 elsif Unit_Requires_Body (Gen_Unit)
8930 and then not Body_Optional
8932 if CodePeer_Mode then
8935 elsif Serious_Errors_Detected = 0 then
8937 ("cannot find body of generic package &", Inst_Node, Gen_Unit);
8939 -- Don't attempt to perform any cleanup actions if some other error
8940 -- was already detected, since this can cause blowups.
8946 -- Case of package that does not need a body
8949 -- If the instantiation of the declaration is a library unit, rewrite
8950 -- the original package instantiation as a package declaration in the
8951 -- compilation unit node.
8953 if Nkind (Parent (Inst_Node)) = N_Compilation_Unit then
8954 Set_Parent_Spec (Act_Decl, Parent_Spec (Inst_Node));
8955 Rewrite (Inst_Node, Act_Decl);
8957 -- Generate elaboration entity, in case spec has elaboration code.
8958 -- This cannot be done when the instance is analyzed, because it
8959 -- is not known yet whether the body exists.
8961 Set_Elaboration_Entity_Required (Act_Decl_Id, False);
8962 Build_Elaboration_Entity (Parent (Inst_Node), Act_Decl_Id);
8964 -- If the instantiation is not a library unit, then append the
8965 -- declaration to the list of implicitly generated entities, unless
8966 -- it is already a list member which means that it was already
8969 elsif not Is_List_Member (Act_Decl) then
8970 Mark_Rewrite_Insertion (Act_Decl);
8971 Insert_Before (Inst_Node, Act_Decl);
8975 Expander_Mode_Restore;
8976 end Instantiate_Package_Body;
8978 ---------------------------------
8979 -- Instantiate_Subprogram_Body --
8980 ---------------------------------
8982 procedure Instantiate_Subprogram_Body
8983 (Body_Info : Pending_Body_Info;
8984 Body_Optional : Boolean := False)
8986 Act_Decl : constant Node_Id := Body_Info.Act_Decl;
8987 Inst_Node : constant Node_Id := Body_Info.Inst_Node;
8988 Loc : constant Source_Ptr := Sloc (Inst_Node);
8989 Gen_Id : constant Node_Id := Name (Inst_Node);
8990 Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node);
8991 Gen_Decl : constant Node_Id := Unit_Declaration_Node (Gen_Unit);
8992 Anon_Id : constant Entity_Id :=
8993 Defining_Unit_Name (Specification (Act_Decl));
8994 Pack_Id : constant Entity_Id :=
8995 Defining_Unit_Name (Parent (Act_Decl));
8998 Gen_Body_Id : Node_Id;
9000 Pack_Body : Node_Id;
9001 Prev_Formal : Entity_Id;
9003 Unit_Renaming : Node_Id;
9005 Parent_Installed : Boolean := False;
9006 Save_Style_Check : constant Boolean := Style_Check;
9008 Par_Ent : Entity_Id := Empty;
9009 Par_Vis : Boolean := False;
9012 Gen_Body_Id := Corresponding_Body (Gen_Decl);
9014 -- Subprogram body may have been created already because of an inline
9015 -- pragma, or because of multiple elaborations of the enclosing package
9016 -- when several instances of the subprogram appear in the main unit.
9018 if Present (Corresponding_Body (Act_Decl)) then
9022 Expander_Mode_Save_And_Set (Body_Info.Expander_Status);
9024 -- Re-establish the state of information on which checks are suppressed.
9025 -- This information was set in Body_Info at the point of instantiation,
9026 -- and now we restore it so that the instance is compiled using the
9027 -- check status at the instantiation (RM 11.5 (7.2/2), AI95-00224-01).
9029 Local_Suppress_Stack_Top := Body_Info.Local_Suppress_Stack_Top;
9030 Scope_Suppress := Body_Info.Scope_Suppress;
9031 Opt.Ada_Version := Body_Info.Version;
9033 if No (Gen_Body_Id) then
9035 -- For imported generic subprogram, no body to compile, complete
9036 -- the spec entity appropriately.
9038 if Is_Imported (Gen_Unit) then
9039 Set_Is_Imported (Anon_Id);
9040 Set_First_Rep_Item (Anon_Id, First_Rep_Item (Gen_Unit));
9041 Set_Interface_Name (Anon_Id, Interface_Name (Gen_Unit));
9042 Set_Convention (Anon_Id, Convention (Gen_Unit));
9043 Set_Has_Completion (Anon_Id);
9046 -- For other cases, compile the body
9049 Load_Parent_Of_Generic
9050 (Inst_Node, Specification (Gen_Decl), Body_Optional);
9051 Gen_Body_Id := Corresponding_Body (Gen_Decl);
9055 Instantiation_Node := Inst_Node;
9057 if Present (Gen_Body_Id) then
9058 Gen_Body := Unit_Declaration_Node (Gen_Body_Id);
9060 if Nkind (Gen_Body) = N_Subprogram_Body_Stub then
9062 -- Either body is not present, or context is non-expanding, as
9063 -- when compiling a subunit. Mark the instance as completed, and
9064 -- diagnose a missing body when needed.
9067 and then Operating_Mode = Generate_Code
9070 ("missing proper body for instantiation", Gen_Body);
9073 Set_Has_Completion (Anon_Id);
9077 Save_Env (Gen_Unit, Anon_Id);
9078 Style_Check := False;
9079 Current_Sem_Unit := Body_Info.Current_Sem_Unit;
9080 Create_Instantiation_Source
9088 (Original_Node (Gen_Body), Empty, Instantiating => True);
9090 -- Create proper defining name for the body, to correspond to
9091 -- the one in the spec.
9093 Set_Defining_Unit_Name (Specification (Act_Body),
9094 Make_Defining_Identifier
9095 (Sloc (Defining_Entity (Inst_Node)), Chars (Anon_Id)));
9096 Set_Corresponding_Spec (Act_Body, Anon_Id);
9097 Set_Has_Completion (Anon_Id);
9098 Check_Generic_Actuals (Pack_Id, False);
9100 -- Generate a reference to link the visible subprogram instance to
9101 -- the generic body, which for navigation purposes is the only
9102 -- available source for the instance.
9105 (Related_Instance (Pack_Id),
9106 Gen_Body_Id, 'b', Set_Ref => False, Force => True);
9108 -- If it is a child unit, make the parent instance (which is an
9109 -- instance of the parent of the generic) visible. The parent
9110 -- instance is the prefix of the name of the generic unit.
9112 if Ekind (Scope (Gen_Unit)) = E_Generic_Package
9113 and then Nkind (Gen_Id) = N_Expanded_Name
9115 Par_Ent := Entity (Prefix (Gen_Id));
9116 Par_Vis := Is_Immediately_Visible (Par_Ent);
9117 Install_Parent (Par_Ent, In_Body => True);
9118 Parent_Installed := True;
9120 elsif Is_Child_Unit (Gen_Unit) then
9121 Par_Ent := Scope (Gen_Unit);
9122 Par_Vis := Is_Immediately_Visible (Par_Ent);
9123 Install_Parent (Par_Ent, In_Body => True);
9124 Parent_Installed := True;
9127 -- Inside its body, a reference to the generic unit is a reference
9128 -- to the instance. The corresponding renaming is the first
9129 -- declaration in the body.
9132 Make_Subprogram_Renaming_Declaration (Loc,
9135 Specification (Original_Node (Gen_Body)),
9137 Instantiating => True),
9138 Name => New_Occurrence_Of (Anon_Id, Loc));
9140 -- If there is a formal subprogram with the same name as the unit
9141 -- itself, do not add this renaming declaration. This is a temporary
9142 -- fix for one ACVC test. ???
9144 Prev_Formal := First_Entity (Pack_Id);
9145 while Present (Prev_Formal) loop
9146 if Chars (Prev_Formal) = Chars (Gen_Unit)
9147 and then Is_Overloadable (Prev_Formal)
9152 Next_Entity (Prev_Formal);
9155 if Present (Prev_Formal) then
9156 Decls := New_List (Act_Body);
9158 Decls := New_List (Unit_Renaming, Act_Body);
9161 -- The subprogram body is placed in the body of a dummy package body,
9162 -- whose spec contains the subprogram declaration as well as the
9163 -- renaming declarations for the generic parameters.
9165 Pack_Body := Make_Package_Body (Loc,
9166 Defining_Unit_Name => New_Copy (Pack_Id),
9167 Declarations => Decls);
9169 Set_Corresponding_Spec (Pack_Body, Pack_Id);
9171 -- If the instantiation is a library unit, then build resulting
9172 -- compilation unit nodes for the instance. The declaration of
9173 -- the enclosing package is the grandparent of the subprogram
9174 -- declaration. First replace the instantiation node as the unit
9175 -- of the corresponding compilation.
9177 if Nkind (Parent (Inst_Node)) = N_Compilation_Unit then
9178 if Parent (Inst_Node) = Cunit (Main_Unit) then
9179 Set_Unit (Parent (Inst_Node), Inst_Node);
9180 Build_Instance_Compilation_Unit_Nodes
9181 (Inst_Node, Pack_Body, Parent (Parent (Act_Decl)));
9182 Analyze (Inst_Node);
9184 Set_Parent (Pack_Body, Parent (Inst_Node));
9185 Analyze (Pack_Body);
9189 Insert_Before (Inst_Node, Pack_Body);
9190 Mark_Rewrite_Insertion (Pack_Body);
9191 Analyze (Pack_Body);
9193 if Expander_Active then
9194 Freeze_Subprogram_Body (Inst_Node, Gen_Body, Pack_Id);
9198 Inherit_Context (Gen_Body, Inst_Node);
9200 Restore_Private_Views (Pack_Id, False);
9202 if Parent_Installed then
9203 Remove_Parent (In_Body => True);
9205 -- Restore the previous visibility of the parent
9207 Set_Is_Immediately_Visible (Par_Ent, Par_Vis);
9211 Style_Check := Save_Style_Check;
9213 -- Body not found. Error was emitted already. If there were no previous
9214 -- errors, this may be an instance whose scope is a premature instance.
9215 -- In that case we must insure that the (legal) program does raise
9216 -- program error if executed. We generate a subprogram body for this
9217 -- purpose. See DEC ac30vso.
9219 -- Should not reference proprietary DEC tests in comments ???
9221 elsif Serious_Errors_Detected = 0
9222 and then Nkind (Parent (Inst_Node)) /= N_Compilation_Unit
9224 if Body_Optional then
9227 elsif Ekind (Anon_Id) = E_Procedure then
9229 Make_Subprogram_Body (Loc,
9231 Make_Procedure_Specification (Loc,
9232 Defining_Unit_Name =>
9233 Make_Defining_Identifier (Loc, Chars (Anon_Id)),
9234 Parameter_Specifications =>
9236 (Parameter_Specifications (Parent (Anon_Id)))),
9238 Declarations => Empty_List,
9239 Handled_Statement_Sequence =>
9240 Make_Handled_Sequence_Of_Statements (Loc,
9243 Make_Raise_Program_Error (Loc,
9245 PE_Access_Before_Elaboration))));
9249 Make_Raise_Program_Error (Loc,
9250 Reason => PE_Access_Before_Elaboration);
9252 Set_Etype (Ret_Expr, (Etype (Anon_Id)));
9253 Set_Analyzed (Ret_Expr);
9256 Make_Subprogram_Body (Loc,
9258 Make_Function_Specification (Loc,
9259 Defining_Unit_Name =>
9260 Make_Defining_Identifier (Loc, Chars (Anon_Id)),
9261 Parameter_Specifications =>
9263 (Parameter_Specifications (Parent (Anon_Id))),
9264 Result_Definition =>
9265 New_Occurrence_Of (Etype (Anon_Id), Loc)),
9267 Declarations => Empty_List,
9268 Handled_Statement_Sequence =>
9269 Make_Handled_Sequence_Of_Statements (Loc,
9272 (Make_Simple_Return_Statement (Loc, Ret_Expr))));
9275 Pack_Body := Make_Package_Body (Loc,
9276 Defining_Unit_Name => New_Copy (Pack_Id),
9277 Declarations => New_List (Act_Body));
9279 Insert_After (Inst_Node, Pack_Body);
9280 Set_Corresponding_Spec (Pack_Body, Pack_Id);
9281 Analyze (Pack_Body);
9284 Expander_Mode_Restore;
9285 end Instantiate_Subprogram_Body;
9287 ----------------------
9288 -- Instantiate_Type --
9289 ----------------------
9291 function Instantiate_Type
9294 Analyzed_Formal : Node_Id;
9295 Actual_Decls : List_Id) return List_Id
9297 Gen_T : constant Entity_Id := Defining_Identifier (Formal);
9298 A_Gen_T : constant Entity_Id :=
9299 Defining_Identifier (Analyzed_Formal);
9300 Ancestor : Entity_Id := Empty;
9301 Def : constant Node_Id := Formal_Type_Definition (Formal);
9303 Decl_Node : Node_Id;
9304 Decl_Nodes : List_Id;
9308 procedure Validate_Array_Type_Instance;
9309 procedure Validate_Access_Subprogram_Instance;
9310 procedure Validate_Access_Type_Instance;
9311 procedure Validate_Derived_Type_Instance;
9312 procedure Validate_Derived_Interface_Type_Instance;
9313 procedure Validate_Interface_Type_Instance;
9314 procedure Validate_Private_Type_Instance;
9315 -- These procedures perform validation tests for the named case
9317 function Subtypes_Match (Gen_T, Act_T : Entity_Id) return Boolean;
9318 -- Check that base types are the same and that the subtypes match
9319 -- statically. Used in several of the above.
9321 --------------------
9322 -- Subtypes_Match --
9323 --------------------
9325 function Subtypes_Match (Gen_T, Act_T : Entity_Id) return Boolean is
9326 T : constant Entity_Id := Get_Instance_Of (Gen_T);
9329 return (Base_Type (T) = Base_Type (Act_T)
9330 and then Subtypes_Statically_Match (T, Act_T))
9332 or else (Is_Class_Wide_Type (Gen_T)
9333 and then Is_Class_Wide_Type (Act_T)
9336 (Get_Instance_Of (Root_Type (Gen_T)),
9340 ((Ekind (Gen_T) = E_Anonymous_Access_Subprogram_Type
9341 or else Ekind (Gen_T) = E_Anonymous_Access_Type)
9342 and then Ekind (Act_T) = Ekind (Gen_T)
9344 Subtypes_Statically_Match
9345 (Designated_Type (Gen_T), Designated_Type (Act_T)));
9348 -----------------------------------------
9349 -- Validate_Access_Subprogram_Instance --
9350 -----------------------------------------
9352 procedure Validate_Access_Subprogram_Instance is
9354 if not Is_Access_Type (Act_T)
9355 or else Ekind (Designated_Type (Act_T)) /= E_Subprogram_Type
9358 ("expect access type in instantiation of &", Actual, Gen_T);
9359 Abandon_Instantiation (Actual);
9362 Check_Mode_Conformant
9363 (Designated_Type (Act_T),
9364 Designated_Type (A_Gen_T),
9368 if Ekind (Base_Type (Act_T)) = E_Access_Protected_Subprogram_Type then
9369 if Ekind (A_Gen_T) = E_Access_Subprogram_Type then
9371 ("protected access type not allowed for formal &",
9375 elsif Ekind (A_Gen_T) = E_Access_Protected_Subprogram_Type then
9377 ("expect protected access type for formal &",
9380 end Validate_Access_Subprogram_Instance;
9382 -----------------------------------
9383 -- Validate_Access_Type_Instance --
9384 -----------------------------------
9386 procedure Validate_Access_Type_Instance is
9387 Desig_Type : constant Entity_Id :=
9388 Find_Actual_Type (Designated_Type (A_Gen_T), A_Gen_T);
9389 Desig_Act : Entity_Id;
9392 if not Is_Access_Type (Act_T) then
9394 ("expect access type in instantiation of &", Actual, Gen_T);
9395 Abandon_Instantiation (Actual);
9398 if Is_Access_Constant (A_Gen_T) then
9399 if not Is_Access_Constant (Act_T) then
9401 ("actual type must be access-to-constant type", Actual);
9402 Abandon_Instantiation (Actual);
9405 if Is_Access_Constant (Act_T) then
9407 ("actual type must be access-to-variable type", Actual);
9408 Abandon_Instantiation (Actual);
9410 elsif Ekind (A_Gen_T) = E_General_Access_Type
9411 and then Ekind (Base_Type (Act_T)) /= E_General_Access_Type
9413 Error_Msg_N -- CODEFIX
9414 ("actual must be general access type!", Actual);
9415 Error_Msg_NE -- CODEFIX
9416 ("add ALL to }!", Actual, Act_T);
9417 Abandon_Instantiation (Actual);
9421 -- The designated subtypes, that is to say the subtypes introduced
9422 -- by an access type declaration (and not by a subtype declaration)
9425 Desig_Act := Designated_Type (Base_Type (Act_T));
9427 -- The designated type may have been introduced through a limited_
9428 -- with clause, in which case retrieve the non-limited view. This
9429 -- applies to incomplete types as well as to class-wide types.
9431 if From_With_Type (Desig_Act) then
9432 Desig_Act := Available_View (Desig_Act);
9435 if not Subtypes_Match
9436 (Desig_Type, Desig_Act) then
9438 ("designated type of actual does not match that of formal &",
9440 Abandon_Instantiation (Actual);
9442 elsif Is_Access_Type (Designated_Type (Act_T))
9443 and then Is_Constrained (Designated_Type (Designated_Type (Act_T)))
9445 Is_Constrained (Designated_Type (Desig_Type))
9448 ("designated type of actual does not match that of formal &",
9450 Abandon_Instantiation (Actual);
9453 -- Ada 2005: null-exclusion indicators of the two types must agree
9455 if Can_Never_Be_Null (A_Gen_T) /= Can_Never_Be_Null (Act_T) then
9457 ("non null exclusion of actual and formal & do not match",
9460 end Validate_Access_Type_Instance;
9462 ----------------------------------
9463 -- Validate_Array_Type_Instance --
9464 ----------------------------------
9466 procedure Validate_Array_Type_Instance is
9471 function Formal_Dimensions return Int;
9472 -- Count number of dimensions in array type formal
9474 -----------------------
9475 -- Formal_Dimensions --
9476 -----------------------
9478 function Formal_Dimensions return Int is
9483 if Nkind (Def) = N_Constrained_Array_Definition then
9484 Index := First (Discrete_Subtype_Definitions (Def));
9486 Index := First (Subtype_Marks (Def));
9489 while Present (Index) loop
9495 end Formal_Dimensions;
9497 -- Start of processing for Validate_Array_Type_Instance
9500 if not Is_Array_Type (Act_T) then
9502 ("expect array type in instantiation of &", Actual, Gen_T);
9503 Abandon_Instantiation (Actual);
9505 elsif Nkind (Def) = N_Constrained_Array_Definition then
9506 if not (Is_Constrained (Act_T)) then
9508 ("expect constrained array in instantiation of &",
9510 Abandon_Instantiation (Actual);
9514 if Is_Constrained (Act_T) then
9516 ("expect unconstrained array in instantiation of &",
9518 Abandon_Instantiation (Actual);
9522 if Formal_Dimensions /= Number_Dimensions (Act_T) then
9524 ("dimensions of actual do not match formal &", Actual, Gen_T);
9525 Abandon_Instantiation (Actual);
9528 I1 := First_Index (A_Gen_T);
9529 I2 := First_Index (Act_T);
9530 for J in 1 .. Formal_Dimensions loop
9532 -- If the indexes of the actual were given by a subtype_mark,
9533 -- the index was transformed into a range attribute. Retrieve
9534 -- the original type mark for checking.
9536 if Is_Entity_Name (Original_Node (I2)) then
9537 T2 := Entity (Original_Node (I2));
9542 if not Subtypes_Match
9543 (Find_Actual_Type (Etype (I1), A_Gen_T), T2)
9546 ("index types of actual do not match those of formal &",
9548 Abandon_Instantiation (Actual);
9555 -- Check matching subtypes. Note that there are complex visibility
9556 -- issues when the generic is a child unit and some aspect of the
9557 -- generic type is declared in a parent unit of the generic. We do
9558 -- the test to handle this special case only after a direct check
9559 -- for static matching has failed.
9562 (Component_Type (A_Gen_T), Component_Type (Act_T))
9563 or else Subtypes_Match
9564 (Find_Actual_Type (Component_Type (A_Gen_T), A_Gen_T),
9565 Component_Type (Act_T))
9570 ("component subtype of actual does not match that of formal &",
9572 Abandon_Instantiation (Actual);
9575 if Has_Aliased_Components (A_Gen_T)
9576 and then not Has_Aliased_Components (Act_T)
9579 ("actual must have aliased components to match formal type &",
9582 end Validate_Array_Type_Instance;
9584 -----------------------------------------------
9585 -- Validate_Derived_Interface_Type_Instance --
9586 -----------------------------------------------
9588 procedure Validate_Derived_Interface_Type_Instance is
9589 Par : constant Entity_Id := Entity (Subtype_Indication (Def));
9593 -- First apply interface instance checks
9595 Validate_Interface_Type_Instance;
9597 -- Verify that immediate parent interface is an ancestor of
9601 and then not Interface_Present_In_Ancestor (Act_T, Par)
9604 ("interface actual must include progenitor&", Actual, Par);
9607 -- Now verify that the actual includes all other ancestors of
9610 Elmt := First_Elmt (Interfaces (A_Gen_T));
9611 while Present (Elmt) loop
9612 if not Interface_Present_In_Ancestor
9613 (Act_T, Get_Instance_Of (Node (Elmt)))
9616 ("interface actual must include progenitor&",
9617 Actual, Node (Elmt));
9622 end Validate_Derived_Interface_Type_Instance;
9624 ------------------------------------
9625 -- Validate_Derived_Type_Instance --
9626 ------------------------------------
9628 procedure Validate_Derived_Type_Instance is
9629 Actual_Discr : Entity_Id;
9630 Ancestor_Discr : Entity_Id;
9633 -- If the parent type in the generic declaration is itself a previous
9634 -- formal type, then it is local to the generic and absent from the
9635 -- analyzed generic definition. In that case the ancestor is the
9636 -- instance of the formal (which must have been instantiated
9637 -- previously), unless the ancestor is itself a formal derived type.
9638 -- In this latter case (which is the subject of Corrigendum 8652/0038
9639 -- (AI-202) the ancestor of the formals is the ancestor of its
9640 -- parent. Otherwise, the analyzed generic carries the parent type.
9641 -- If the parent type is defined in a previous formal package, then
9642 -- the scope of that formal package is that of the generic type
9643 -- itself, and it has already been mapped into the corresponding type
9644 -- in the actual package.
9646 -- Common case: parent type defined outside of the generic
9648 if Is_Entity_Name (Subtype_Mark (Def))
9649 and then Present (Entity (Subtype_Mark (Def)))
9651 Ancestor := Get_Instance_Of (Entity (Subtype_Mark (Def)));
9653 -- Check whether parent is defined in a previous formal package
9656 Scope (Scope (Base_Type (Etype (A_Gen_T)))) = Scope (A_Gen_T)
9659 Get_Instance_Of (Base_Type (Etype (A_Gen_T)));
9661 -- The type may be a local derivation, or a type extension of a
9662 -- previous formal, or of a formal of a parent package.
9664 elsif Is_Derived_Type (Get_Instance_Of (A_Gen_T))
9666 Ekind (Get_Instance_Of (A_Gen_T)) = E_Record_Type_With_Private
9668 -- Check whether the parent is another derived formal type in the
9669 -- same generic unit.
9671 if Etype (A_Gen_T) /= A_Gen_T
9672 and then Is_Generic_Type (Etype (A_Gen_T))
9673 and then Scope (Etype (A_Gen_T)) = Scope (A_Gen_T)
9674 and then Etype (Etype (A_Gen_T)) /= Etype (A_Gen_T)
9676 -- Locate ancestor of parent from the subtype declaration
9677 -- created for the actual.
9683 Decl := First (Actual_Decls);
9684 while Present (Decl) loop
9685 if Nkind (Decl) = N_Subtype_Declaration
9686 and then Chars (Defining_Identifier (Decl)) =
9687 Chars (Etype (A_Gen_T))
9689 Ancestor := Generic_Parent_Type (Decl);
9697 pragma Assert (Present (Ancestor));
9701 Get_Instance_Of (Base_Type (Get_Instance_Of (A_Gen_T)));
9705 Ancestor := Get_Instance_Of (Etype (Base_Type (A_Gen_T)));
9708 -- If the formal derived type has pragma Preelaborable_Initialization
9709 -- then the actual type must have preelaborable initialization.
9711 if Known_To_Have_Preelab_Init (A_Gen_T)
9712 and then not Has_Preelaborable_Initialization (Act_T)
9715 ("actual for & must have preelaborable initialization",
9719 -- Ada 2005 (AI-251)
9721 if Ada_Version >= Ada_2005
9722 and then Is_Interface (Ancestor)
9724 if not Interface_Present_In_Ancestor (Act_T, Ancestor) then
9726 ("(Ada 2005) expected type implementing & in instantiation",
9730 elsif not Is_Ancestor (Base_Type (Ancestor), Act_T) then
9732 ("expect type derived from & in instantiation",
9733 Actual, First_Subtype (Ancestor));
9734 Abandon_Instantiation (Actual);
9737 -- Ada 2005 (AI-443): Synchronized formal derived type checks. Note
9738 -- that the formal type declaration has been rewritten as a private
9741 if Ada_Version >= Ada_2005
9742 and then Nkind (Parent (A_Gen_T)) = N_Private_Extension_Declaration
9743 and then Synchronized_Present (Parent (A_Gen_T))
9745 -- The actual must be a synchronized tagged type
9747 if not Is_Tagged_Type (Act_T) then
9749 ("actual of synchronized type must be tagged", Actual);
9750 Abandon_Instantiation (Actual);
9752 elsif Nkind (Parent (Act_T)) = N_Full_Type_Declaration
9753 and then Nkind (Type_Definition (Parent (Act_T))) =
9754 N_Derived_Type_Definition
9755 and then not Synchronized_Present (Type_Definition
9759 ("actual of synchronized type must be synchronized", Actual);
9760 Abandon_Instantiation (Actual);
9764 -- Perform atomic/volatile checks (RM C.6(12))
9766 if Is_Atomic (Act_T) and then not Is_Atomic (Ancestor) then
9768 ("cannot have atomic actual type for non-atomic formal type",
9771 elsif Is_Volatile (Act_T)
9772 and then not Is_Volatile (Ancestor)
9773 and then Is_By_Reference_Type (Ancestor)
9776 ("cannot have volatile actual type for non-volatile formal type",
9780 -- It should not be necessary to check for unknown discriminants on
9781 -- Formal, but for some reason Has_Unknown_Discriminants is false for
9782 -- A_Gen_T, so Is_Indefinite_Subtype incorrectly returns False. This
9783 -- needs fixing. ???
9785 if not Is_Indefinite_Subtype (A_Gen_T)
9786 and then not Unknown_Discriminants_Present (Formal)
9787 and then Is_Indefinite_Subtype (Act_T)
9790 ("actual subtype must be constrained", Actual);
9791 Abandon_Instantiation (Actual);
9794 if not Unknown_Discriminants_Present (Formal) then
9795 if Is_Constrained (Ancestor) then
9796 if not Is_Constrained (Act_T) then
9798 ("actual subtype must be constrained", Actual);
9799 Abandon_Instantiation (Actual);
9802 -- Ancestor is unconstrained, Check if generic formal and actual
9803 -- agree on constrainedness. The check only applies to array types
9804 -- and discriminated types.
9806 elsif Is_Constrained (Act_T) then
9807 if Ekind (Ancestor) = E_Access_Type
9809 (not Is_Constrained (A_Gen_T)
9810 and then Is_Composite_Type (A_Gen_T))
9813 ("actual subtype must be unconstrained", Actual);
9814 Abandon_Instantiation (Actual);
9817 -- A class-wide type is only allowed if the formal has unknown
9820 elsif Is_Class_Wide_Type (Act_T)
9821 and then not Has_Unknown_Discriminants (Ancestor)
9824 ("actual for & cannot be a class-wide type", Actual, Gen_T);
9825 Abandon_Instantiation (Actual);
9827 -- Otherwise, the formal and actual shall have the same number
9828 -- of discriminants and each discriminant of the actual must
9829 -- correspond to a discriminant of the formal.
9831 elsif Has_Discriminants (Act_T)
9832 and then not Has_Unknown_Discriminants (Act_T)
9833 and then Has_Discriminants (Ancestor)
9835 Actual_Discr := First_Discriminant (Act_T);
9836 Ancestor_Discr := First_Discriminant (Ancestor);
9837 while Present (Actual_Discr)
9838 and then Present (Ancestor_Discr)
9840 if Base_Type (Act_T) /= Base_Type (Ancestor) and then
9841 No (Corresponding_Discriminant (Actual_Discr))
9844 ("discriminant & does not correspond " &
9845 "to ancestor discriminant", Actual, Actual_Discr);
9846 Abandon_Instantiation (Actual);
9849 Next_Discriminant (Actual_Discr);
9850 Next_Discriminant (Ancestor_Discr);
9853 if Present (Actual_Discr) or else Present (Ancestor_Discr) then
9855 ("actual for & must have same number of discriminants",
9857 Abandon_Instantiation (Actual);
9860 -- This case should be caught by the earlier check for
9861 -- constrainedness, but the check here is added for completeness.
9863 elsif Has_Discriminants (Act_T)
9864 and then not Has_Unknown_Discriminants (Act_T)
9867 ("actual for & must not have discriminants", Actual, Gen_T);
9868 Abandon_Instantiation (Actual);
9870 elsif Has_Discriminants (Ancestor) then
9872 ("actual for & must have known discriminants", Actual, Gen_T);
9873 Abandon_Instantiation (Actual);
9876 if not Subtypes_Statically_Compatible (Act_T, Ancestor) then
9878 ("constraint on actual is incompatible with formal", Actual);
9879 Abandon_Instantiation (Actual);
9883 -- If the formal and actual types are abstract, check that there
9884 -- are no abstract primitives of the actual type that correspond to
9885 -- nonabstract primitives of the formal type (second sentence of
9888 if Is_Abstract_Type (A_Gen_T) and then Is_Abstract_Type (Act_T) then
9889 Check_Abstract_Primitives : declare
9890 Gen_Prims : constant Elist_Id :=
9891 Primitive_Operations (A_Gen_T);
9893 Gen_Subp : Entity_Id;
9894 Anc_Subp : Entity_Id;
9895 Anc_Formal : Entity_Id;
9896 Anc_F_Type : Entity_Id;
9898 Act_Prims : constant Elist_Id := Primitive_Operations (Act_T);
9900 Act_Subp : Entity_Id;
9901 Act_Formal : Entity_Id;
9902 Act_F_Type : Entity_Id;
9904 Subprograms_Correspond : Boolean;
9906 function Is_Tagged_Ancestor (T1, T2 : Entity_Id) return Boolean;
9907 -- Returns true if T2 is derived directly or indirectly from
9908 -- T1, including derivations from interfaces. T1 and T2 are
9909 -- required to be specific tagged base types.
9911 ------------------------
9912 -- Is_Tagged_Ancestor --
9913 ------------------------
9915 function Is_Tagged_Ancestor (T1, T2 : Entity_Id) return Boolean
9917 Intfc_Elmt : Elmt_Id;
9920 -- The predicate is satisfied if the types are the same
9925 -- If we've reached the top of the derivation chain then
9926 -- we know that T1 is not an ancestor of T2.
9928 elsif Etype (T2) = T2 then
9931 -- Proceed to check T2's immediate parent
9933 elsif Is_Ancestor (T1, Base_Type (Etype (T2))) then
9936 -- Finally, check to see if T1 is an ancestor of any of T2's
9940 Intfc_Elmt := First_Elmt (Interfaces (T2));
9941 while Present (Intfc_Elmt) loop
9942 if Is_Ancestor (T1, Node (Intfc_Elmt)) then
9946 Next_Elmt (Intfc_Elmt);
9951 end Is_Tagged_Ancestor;
9953 -- Start of processing for Check_Abstract_Primitives
9956 -- Loop over all of the formal derived type's primitives
9958 Gen_Elmt := First_Elmt (Gen_Prims);
9959 while Present (Gen_Elmt) loop
9960 Gen_Subp := Node (Gen_Elmt);
9962 -- If the primitive of the formal is not abstract, then
9963 -- determine whether there is a corresponding primitive of
9964 -- the actual type that's abstract.
9966 if not Is_Abstract_Subprogram (Gen_Subp) then
9967 Act_Elmt := First_Elmt (Act_Prims);
9968 while Present (Act_Elmt) loop
9969 Act_Subp := Node (Act_Elmt);
9971 -- If we find an abstract primitive of the actual,
9972 -- then we need to test whether it corresponds to the
9973 -- subprogram from which the generic formal primitive
9976 if Is_Abstract_Subprogram (Act_Subp) then
9977 Anc_Subp := Alias (Gen_Subp);
9979 -- Test whether we have a corresponding primitive
9980 -- by comparing names, kinds, formal types, and
9983 if Chars (Anc_Subp) = Chars (Act_Subp)
9984 and then Ekind (Anc_Subp) = Ekind (Act_Subp)
9986 Anc_Formal := First_Formal (Anc_Subp);
9987 Act_Formal := First_Formal (Act_Subp);
9988 while Present (Anc_Formal)
9989 and then Present (Act_Formal)
9991 Anc_F_Type := Etype (Anc_Formal);
9992 Act_F_Type := Etype (Act_Formal);
9994 if Ekind (Anc_F_Type)
9995 = E_Anonymous_Access_Type
9997 Anc_F_Type := Designated_Type (Anc_F_Type);
9999 if Ekind (Act_F_Type)
10000 = E_Anonymous_Access_Type
10003 Designated_Type (Act_F_Type);
10009 Ekind (Act_F_Type) = E_Anonymous_Access_Type
10014 Anc_F_Type := Base_Type (Anc_F_Type);
10015 Act_F_Type := Base_Type (Act_F_Type);
10017 -- If the formal is controlling, then the
10018 -- the type of the actual primitive's formal
10019 -- must be derived directly or indirectly
10020 -- from the type of the ancestor primitive's
10023 if Is_Controlling_Formal (Anc_Formal) then
10024 if not Is_Tagged_Ancestor
10025 (Anc_F_Type, Act_F_Type)
10030 -- Otherwise the types of the formals must
10033 elsif Anc_F_Type /= Act_F_Type then
10037 Next_Entity (Anc_Formal);
10038 Next_Entity (Act_Formal);
10041 -- If we traversed through all of the formals
10042 -- then so far the subprograms correspond, so
10043 -- now check that any result types correspond.
10045 if No (Anc_Formal) and then No (Act_Formal) then
10046 Subprograms_Correspond := True;
10048 if Ekind (Act_Subp) = E_Function then
10049 Anc_F_Type := Etype (Anc_Subp);
10050 Act_F_Type := Etype (Act_Subp);
10052 if Ekind (Anc_F_Type)
10053 = E_Anonymous_Access_Type
10056 Designated_Type (Anc_F_Type);
10058 if Ekind (Act_F_Type)
10059 = E_Anonymous_Access_Type
10062 Designated_Type (Act_F_Type);
10064 Subprograms_Correspond := False;
10069 = E_Anonymous_Access_Type
10071 Subprograms_Correspond := False;
10074 Anc_F_Type := Base_Type (Anc_F_Type);
10075 Act_F_Type := Base_Type (Act_F_Type);
10077 -- Now either the result types must be
10078 -- the same or, if the result type is
10079 -- controlling, the result type of the
10080 -- actual primitive must descend from the
10081 -- result type of the ancestor primitive.
10083 if Subprograms_Correspond
10084 and then Anc_F_Type /= Act_F_Type
10086 Has_Controlling_Result (Anc_Subp)
10088 not Is_Tagged_Ancestor
10089 (Anc_F_Type, Act_F_Type)
10091 Subprograms_Correspond := False;
10095 -- Found a matching subprogram belonging to
10096 -- formal ancestor type, so actual subprogram
10097 -- corresponds and this violates 3.9.3(9).
10099 if Subprograms_Correspond then
10101 ("abstract subprogram & overrides " &
10102 "nonabstract subprogram of ancestor",
10110 Next_Elmt (Act_Elmt);
10114 Next_Elmt (Gen_Elmt);
10116 end Check_Abstract_Primitives;
10119 -- Verify that limitedness matches. If parent is a limited
10120 -- interface then the generic formal is not unless declared
10121 -- explicitly so. If not declared limited, the actual cannot be
10122 -- limited (see AI05-0087).
10124 -- Even though this AI is a binding interpretation, we enable the
10125 -- check only in Ada 2012 mode, because this improper construct
10126 -- shows up in user code and in existing B-tests.
10128 if Is_Limited_Type (Act_T)
10129 and then not Is_Limited_Type (A_Gen_T)
10130 and then Ada_Version >= Ada_2012
10133 ("actual for non-limited & cannot be a limited type", Actual,
10135 Explain_Limited_Type (Act_T, Actual);
10136 Abandon_Instantiation (Actual);
10138 end Validate_Derived_Type_Instance;
10140 --------------------------------------
10141 -- Validate_Interface_Type_Instance --
10142 --------------------------------------
10144 procedure Validate_Interface_Type_Instance is
10146 if not Is_Interface (Act_T) then
10148 ("actual for formal interface type must be an interface",
10151 elsif Is_Limited_Type (Act_T) /= Is_Limited_Type (A_Gen_T)
10153 Is_Task_Interface (A_Gen_T) /= Is_Task_Interface (Act_T)
10155 Is_Protected_Interface (A_Gen_T) /=
10156 Is_Protected_Interface (Act_T)
10158 Is_Synchronized_Interface (A_Gen_T) /=
10159 Is_Synchronized_Interface (Act_T)
10162 ("actual for interface& does not match (RM 12.5.5(4))",
10165 end Validate_Interface_Type_Instance;
10167 ------------------------------------
10168 -- Validate_Private_Type_Instance --
10169 ------------------------------------
10171 procedure Validate_Private_Type_Instance is
10172 Formal_Discr : Entity_Id;
10173 Actual_Discr : Entity_Id;
10174 Formal_Subt : Entity_Id;
10177 if Is_Limited_Type (Act_T)
10178 and then not Is_Limited_Type (A_Gen_T)
10181 ("actual for non-limited & cannot be a limited type", Actual,
10183 Explain_Limited_Type (Act_T, Actual);
10184 Abandon_Instantiation (Actual);
10186 elsif Known_To_Have_Preelab_Init (A_Gen_T)
10187 and then not Has_Preelaborable_Initialization (Act_T)
10190 ("actual for & must have preelaborable initialization", Actual,
10193 elsif Is_Indefinite_Subtype (Act_T)
10194 and then not Is_Indefinite_Subtype (A_Gen_T)
10195 and then Ada_Version >= Ada_95
10198 ("actual for & must be a definite subtype", Actual, Gen_T);
10200 elsif not Is_Tagged_Type (Act_T)
10201 and then Is_Tagged_Type (A_Gen_T)
10204 ("actual for & must be a tagged type", Actual, Gen_T);
10206 elsif Has_Discriminants (A_Gen_T) then
10207 if not Has_Discriminants (Act_T) then
10209 ("actual for & must have discriminants", Actual, Gen_T);
10210 Abandon_Instantiation (Actual);
10212 elsif Is_Constrained (Act_T) then
10214 ("actual for & must be unconstrained", Actual, Gen_T);
10215 Abandon_Instantiation (Actual);
10218 Formal_Discr := First_Discriminant (A_Gen_T);
10219 Actual_Discr := First_Discriminant (Act_T);
10220 while Formal_Discr /= Empty loop
10221 if Actual_Discr = Empty then
10223 ("discriminants on actual do not match formal",
10225 Abandon_Instantiation (Actual);
10228 Formal_Subt := Get_Instance_Of (Etype (Formal_Discr));
10230 -- Access discriminants match if designated types do
10232 if Ekind (Base_Type (Formal_Subt)) = E_Anonymous_Access_Type
10233 and then (Ekind (Base_Type (Etype (Actual_Discr)))) =
10234 E_Anonymous_Access_Type
10237 (Designated_Type (Base_Type (Formal_Subt))) =
10238 Designated_Type (Base_Type (Etype (Actual_Discr)))
10242 elsif Base_Type (Formal_Subt) /=
10243 Base_Type (Etype (Actual_Discr))
10246 ("types of actual discriminants must match formal",
10248 Abandon_Instantiation (Actual);
10250 elsif not Subtypes_Statically_Match
10251 (Formal_Subt, Etype (Actual_Discr))
10252 and then Ada_Version >= Ada_95
10255 ("subtypes of actual discriminants must match formal",
10257 Abandon_Instantiation (Actual);
10260 Next_Discriminant (Formal_Discr);
10261 Next_Discriminant (Actual_Discr);
10264 if Actual_Discr /= Empty then
10266 ("discriminants on actual do not match formal",
10268 Abandon_Instantiation (Actual);
10275 end Validate_Private_Type_Instance;
10277 -- Start of processing for Instantiate_Type
10280 if Get_Instance_Of (A_Gen_T) /= A_Gen_T then
10281 Error_Msg_N ("duplicate instantiation of generic type", Actual);
10282 return New_List (Error);
10284 elsif not Is_Entity_Name (Actual)
10285 or else not Is_Type (Entity (Actual))
10288 ("expect valid subtype mark to instantiate &", Actual, Gen_T);
10289 Abandon_Instantiation (Actual);
10292 Act_T := Entity (Actual);
10294 -- Ada 2005 (AI-216): An Unchecked_Union subtype shall only be passed
10295 -- as a generic actual parameter if the corresponding formal type
10296 -- does not have a known_discriminant_part, or is a formal derived
10297 -- type that is an Unchecked_Union type.
10299 if Is_Unchecked_Union (Base_Type (Act_T)) then
10300 if not Has_Discriminants (A_Gen_T)
10302 (Is_Derived_Type (A_Gen_T)
10304 Is_Unchecked_Union (A_Gen_T))
10308 Error_Msg_N ("Unchecked_Union cannot be the actual for a" &
10309 " discriminated formal type", Act_T);
10314 -- Deal with fixed/floating restrictions
10316 if Is_Floating_Point_Type (Act_T) then
10317 Check_Restriction (No_Floating_Point, Actual);
10318 elsif Is_Fixed_Point_Type (Act_T) then
10319 Check_Restriction (No_Fixed_Point, Actual);
10322 -- Deal with error of using incomplete type as generic actual.
10323 -- This includes limited views of a type, even if the non-limited
10324 -- view may be available.
10326 if Ekind (Act_T) = E_Incomplete_Type
10327 or else (Is_Class_Wide_Type (Act_T)
10329 Ekind (Root_Type (Act_T)) = E_Incomplete_Type)
10331 if Is_Class_Wide_Type (Act_T)
10332 or else No (Full_View (Act_T))
10334 Error_Msg_N ("premature use of incomplete type", Actual);
10335 Abandon_Instantiation (Actual);
10337 Act_T := Full_View (Act_T);
10338 Set_Entity (Actual, Act_T);
10340 if Has_Private_Component (Act_T) then
10342 ("premature use of type with private component", Actual);
10346 -- Deal with error of premature use of private type as generic actual
10348 elsif Is_Private_Type (Act_T)
10349 and then Is_Private_Type (Base_Type (Act_T))
10350 and then not Is_Generic_Type (Act_T)
10351 and then not Is_Derived_Type (Act_T)
10352 and then No (Full_View (Root_Type (Act_T)))
10354 Error_Msg_N ("premature use of private type", Actual);
10356 elsif Has_Private_Component (Act_T) then
10358 ("premature use of type with private component", Actual);
10361 Set_Instance_Of (A_Gen_T, Act_T);
10363 -- If the type is generic, the class-wide type may also be used
10365 if Is_Tagged_Type (A_Gen_T)
10366 and then Is_Tagged_Type (Act_T)
10367 and then not Is_Class_Wide_Type (A_Gen_T)
10369 Set_Instance_Of (Class_Wide_Type (A_Gen_T),
10370 Class_Wide_Type (Act_T));
10373 if not Is_Abstract_Type (A_Gen_T)
10374 and then Is_Abstract_Type (Act_T)
10377 ("actual of non-abstract formal cannot be abstract", Actual);
10380 -- A generic scalar type is a first subtype for which we generate
10381 -- an anonymous base type. Indicate that the instance of this base
10382 -- is the base type of the actual.
10384 if Is_Scalar_Type (A_Gen_T) then
10385 Set_Instance_Of (Etype (A_Gen_T), Etype (Act_T));
10389 if Error_Posted (Act_T) then
10392 case Nkind (Def) is
10393 when N_Formal_Private_Type_Definition =>
10394 Validate_Private_Type_Instance;
10396 when N_Formal_Derived_Type_Definition =>
10397 Validate_Derived_Type_Instance;
10399 when N_Formal_Discrete_Type_Definition =>
10400 if not Is_Discrete_Type (Act_T) then
10402 ("expect discrete type in instantiation of&",
10404 Abandon_Instantiation (Actual);
10407 when N_Formal_Signed_Integer_Type_Definition =>
10408 if not Is_Signed_Integer_Type (Act_T) then
10410 ("expect signed integer type in instantiation of&",
10412 Abandon_Instantiation (Actual);
10415 when N_Formal_Modular_Type_Definition =>
10416 if not Is_Modular_Integer_Type (Act_T) then
10418 ("expect modular type in instantiation of &",
10420 Abandon_Instantiation (Actual);
10423 when N_Formal_Floating_Point_Definition =>
10424 if not Is_Floating_Point_Type (Act_T) then
10426 ("expect float type in instantiation of &", Actual, Gen_T);
10427 Abandon_Instantiation (Actual);
10430 when N_Formal_Ordinary_Fixed_Point_Definition =>
10431 if not Is_Ordinary_Fixed_Point_Type (Act_T) then
10433 ("expect ordinary fixed point type in instantiation of &",
10435 Abandon_Instantiation (Actual);
10438 when N_Formal_Decimal_Fixed_Point_Definition =>
10439 if not Is_Decimal_Fixed_Point_Type (Act_T) then
10441 ("expect decimal type in instantiation of &",
10443 Abandon_Instantiation (Actual);
10446 when N_Array_Type_Definition =>
10447 Validate_Array_Type_Instance;
10449 when N_Access_To_Object_Definition =>
10450 Validate_Access_Type_Instance;
10452 when N_Access_Function_Definition |
10453 N_Access_Procedure_Definition =>
10454 Validate_Access_Subprogram_Instance;
10456 when N_Record_Definition =>
10457 Validate_Interface_Type_Instance;
10459 when N_Derived_Type_Definition =>
10460 Validate_Derived_Interface_Type_Instance;
10463 raise Program_Error;
10468 Subt := New_Copy (Gen_T);
10470 -- Use adjusted sloc of subtype name as the location for other nodes in
10471 -- the subtype declaration.
10473 Loc := Sloc (Subt);
10476 Make_Subtype_Declaration (Loc,
10477 Defining_Identifier => Subt,
10478 Subtype_Indication => New_Reference_To (Act_T, Loc));
10480 if Is_Private_Type (Act_T) then
10481 Set_Has_Private_View (Subtype_Indication (Decl_Node));
10483 elsif Is_Access_Type (Act_T)
10484 and then Is_Private_Type (Designated_Type (Act_T))
10486 Set_Has_Private_View (Subtype_Indication (Decl_Node));
10489 Decl_Nodes := New_List (Decl_Node);
10491 -- Flag actual derived types so their elaboration produces the
10492 -- appropriate renamings for the primitive operations of the ancestor.
10493 -- Flag actual for formal private types as well, to determine whether
10494 -- operations in the private part may override inherited operations.
10495 -- If the formal has an interface list, the ancestor is not the
10496 -- parent, but the analyzed formal that includes the interface
10497 -- operations of all its progenitors.
10499 -- Same treatment for formal private types, so we can check whether the
10500 -- type is tagged limited when validating derivations in the private
10501 -- part. (See AI05-096).
10503 if Nkind (Def) = N_Formal_Derived_Type_Definition then
10504 if Present (Interface_List (Def)) then
10505 Set_Generic_Parent_Type (Decl_Node, A_Gen_T);
10507 Set_Generic_Parent_Type (Decl_Node, Ancestor);
10510 elsif Nkind (Def) = N_Formal_Private_Type_Definition then
10511 Set_Generic_Parent_Type (Decl_Node, A_Gen_T);
10514 -- If the actual is a synchronized type that implements an interface,
10515 -- the primitive operations are attached to the corresponding record,
10516 -- and we have to treat it as an additional generic actual, so that its
10517 -- primitive operations become visible in the instance. The task or
10518 -- protected type itself does not carry primitive operations.
10520 if Is_Concurrent_Type (Act_T)
10521 and then Is_Tagged_Type (Act_T)
10522 and then Present (Corresponding_Record_Type (Act_T))
10523 and then Present (Ancestor)
10524 and then Is_Interface (Ancestor)
10527 Corr_Rec : constant Entity_Id :=
10528 Corresponding_Record_Type (Act_T);
10529 New_Corr : Entity_Id;
10530 Corr_Decl : Node_Id;
10533 New_Corr := Make_Temporary (Loc, 'S');
10535 Make_Subtype_Declaration (Loc,
10536 Defining_Identifier => New_Corr,
10537 Subtype_Indication =>
10538 New_Reference_To (Corr_Rec, Loc));
10539 Append_To (Decl_Nodes, Corr_Decl);
10541 if Ekind (Act_T) = E_Task_Type then
10542 Set_Ekind (Subt, E_Task_Subtype);
10544 Set_Ekind (Subt, E_Protected_Subtype);
10547 Set_Corresponding_Record_Type (Subt, Corr_Rec);
10548 Set_Generic_Parent_Type (Corr_Decl, Ancestor);
10549 Set_Generic_Parent_Type (Decl_Node, Empty);
10554 end Instantiate_Type;
10556 ---------------------
10557 -- Is_In_Main_Unit --
10558 ---------------------
10560 function Is_In_Main_Unit (N : Node_Id) return Boolean is
10561 Unum : constant Unit_Number_Type := Get_Source_Unit (N);
10562 Current_Unit : Node_Id;
10565 if Unum = Main_Unit then
10568 -- If the current unit is a subunit then it is either the main unit or
10569 -- is being compiled as part of the main unit.
10571 elsif Nkind (N) = N_Compilation_Unit then
10572 return Nkind (Unit (N)) = N_Subunit;
10575 Current_Unit := Parent (N);
10576 while Present (Current_Unit)
10577 and then Nkind (Current_Unit) /= N_Compilation_Unit
10579 Current_Unit := Parent (Current_Unit);
10582 -- The instantiation node is in the main unit, or else the current node
10583 -- (perhaps as the result of nested instantiations) is in the main unit,
10584 -- or in the declaration of the main unit, which in this last case must
10587 return Unum = Main_Unit
10588 or else Current_Unit = Cunit (Main_Unit)
10589 or else Current_Unit = Library_Unit (Cunit (Main_Unit))
10590 or else (Present (Library_Unit (Current_Unit))
10591 and then Is_In_Main_Unit (Library_Unit (Current_Unit)));
10592 end Is_In_Main_Unit;
10594 ----------------------------
10595 -- Load_Parent_Of_Generic --
10596 ----------------------------
10598 procedure Load_Parent_Of_Generic
10601 Body_Optional : Boolean := False)
10603 Comp_Unit : constant Node_Id := Cunit (Get_Source_Unit (Spec));
10604 Save_Style_Check : constant Boolean := Style_Check;
10605 True_Parent : Node_Id;
10606 Inst_Node : Node_Id;
10608 Previous_Instances : constant Elist_Id := New_Elmt_List;
10610 procedure Collect_Previous_Instances (Decls : List_Id);
10611 -- Collect all instantiations in the given list of declarations, that
10612 -- precede the generic that we need to load. If the bodies of these
10613 -- instantiations are available, we must analyze them, to ensure that
10614 -- the public symbols generated are the same when the unit is compiled
10615 -- to generate code, and when it is compiled in the context of a unit
10616 -- that needs a particular nested instance. This process is applied to
10617 -- both package and subprogram instances.
10619 --------------------------------
10620 -- Collect_Previous_Instances --
10621 --------------------------------
10623 procedure Collect_Previous_Instances (Decls : List_Id) is
10627 Decl := First (Decls);
10628 while Present (Decl) loop
10629 if Sloc (Decl) >= Sloc (Inst_Node) then
10632 -- If Decl is an instantiation, then record it as requiring
10633 -- instantiation of the corresponding body, except if it is an
10634 -- abbreviated instantiation generated internally for conformance
10635 -- checking purposes only for the case of a formal package
10636 -- declared without a box (see Instantiate_Formal_Package). Such
10637 -- an instantiation does not generate any code (the actual code
10638 -- comes from actual) and thus does not need to be analyzed here.
10639 -- If the instantiation appears with a generic package body it is
10640 -- not analyzed here either.
10642 elsif Nkind (Decl) = N_Package_Instantiation
10643 and then not Is_Internal (Defining_Entity (Decl))
10645 Append_Elmt (Decl, Previous_Instances);
10647 -- For a subprogram instantiation, omit instantiations intrinsic
10648 -- operations (Unchecked_Conversions, etc.) that have no bodies.
10650 elsif Nkind_In (Decl, N_Function_Instantiation,
10651 N_Procedure_Instantiation)
10652 and then not Is_Intrinsic_Subprogram (Entity (Name (Decl)))
10654 Append_Elmt (Decl, Previous_Instances);
10656 elsif Nkind (Decl) = N_Package_Declaration then
10657 Collect_Previous_Instances
10658 (Visible_Declarations (Specification (Decl)));
10659 Collect_Previous_Instances
10660 (Private_Declarations (Specification (Decl)));
10662 -- Previous non-generic bodies may contain instances as well
10664 elsif Nkind (Decl) = N_Package_Body
10665 and then Ekind (Corresponding_Spec (Decl)) /= E_Generic_Package
10667 Collect_Previous_Instances (Declarations (Decl));
10669 elsif Nkind (Decl) = N_Subprogram_Body
10670 and then not Acts_As_Spec (Decl)
10671 and then not Is_Generic_Subprogram (Corresponding_Spec (Decl))
10673 Collect_Previous_Instances (Declarations (Decl));
10678 end Collect_Previous_Instances;
10680 -- Start of processing for Load_Parent_Of_Generic
10683 if not In_Same_Source_Unit (N, Spec)
10684 or else Nkind (Unit (Comp_Unit)) = N_Package_Declaration
10685 or else (Nkind (Unit (Comp_Unit)) = N_Package_Body
10686 and then not Is_In_Main_Unit (Spec))
10688 -- Find body of parent of spec, and analyze it. A special case arises
10689 -- when the parent is an instantiation, that is to say when we are
10690 -- currently instantiating a nested generic. In that case, there is
10691 -- no separate file for the body of the enclosing instance. Instead,
10692 -- the enclosing body must be instantiated as if it were a pending
10693 -- instantiation, in order to produce the body for the nested generic
10694 -- we require now. Note that in that case the generic may be defined
10695 -- in a package body, the instance defined in the same package body,
10696 -- and the original enclosing body may not be in the main unit.
10698 Inst_Node := Empty;
10700 True_Parent := Parent (Spec);
10701 while Present (True_Parent)
10702 and then Nkind (True_Parent) /= N_Compilation_Unit
10704 if Nkind (True_Parent) = N_Package_Declaration
10706 Nkind (Original_Node (True_Parent)) = N_Package_Instantiation
10708 -- Parent is a compilation unit that is an instantiation.
10709 -- Instantiation node has been replaced with package decl.
10711 Inst_Node := Original_Node (True_Parent);
10714 elsif Nkind (True_Parent) = N_Package_Declaration
10715 and then Present (Generic_Parent (Specification (True_Parent)))
10716 and then Nkind (Parent (True_Parent)) /= N_Compilation_Unit
10718 -- Parent is an instantiation within another specification.
10719 -- Declaration for instance has been inserted before original
10720 -- instantiation node. A direct link would be preferable?
10722 Inst_Node := Next (True_Parent);
10723 while Present (Inst_Node)
10724 and then Nkind (Inst_Node) /= N_Package_Instantiation
10729 -- If the instance appears within a generic, and the generic
10730 -- unit is defined within a formal package of the enclosing
10731 -- generic, there is no generic body available, and none
10732 -- needed. A more precise test should be used ???
10734 if No (Inst_Node) then
10741 True_Parent := Parent (True_Parent);
10745 -- Case where we are currently instantiating a nested generic
10747 if Present (Inst_Node) then
10748 if Nkind (Parent (True_Parent)) = N_Compilation_Unit then
10750 -- Instantiation node and declaration of instantiated package
10751 -- were exchanged when only the declaration was needed.
10752 -- Restore instantiation node before proceeding with body.
10754 Set_Unit (Parent (True_Parent), Inst_Node);
10757 -- Now complete instantiation of enclosing body, if it appears in
10758 -- some other unit. If it appears in the current unit, the body
10759 -- will have been instantiated already.
10761 if No (Corresponding_Body (Instance_Spec (Inst_Node))) then
10763 -- We need to determine the expander mode to instantiate the
10764 -- enclosing body. Because the generic body we need may use
10765 -- global entities declared in the enclosing package (including
10766 -- aggregates) it is in general necessary to compile this body
10767 -- with expansion enabled, except if we are within a generic
10768 -- package, in which case the usual generic rule applies.
10771 Exp_Status : Boolean := True;
10775 -- Loop through scopes looking for generic package
10777 Scop := Scope (Defining_Entity (Instance_Spec (Inst_Node)));
10778 while Present (Scop)
10779 and then Scop /= Standard_Standard
10781 if Ekind (Scop) = E_Generic_Package then
10782 Exp_Status := False;
10786 Scop := Scope (Scop);
10789 -- Collect previous instantiations in the unit that contains
10790 -- the desired generic.
10792 if Nkind (Parent (True_Parent)) /= N_Compilation_Unit
10793 and then not Body_Optional
10797 Info : Pending_Body_Info;
10801 Par := Parent (Inst_Node);
10802 while Present (Par) loop
10803 exit when Nkind (Parent (Par)) = N_Compilation_Unit;
10804 Par := Parent (Par);
10807 pragma Assert (Present (Par));
10809 if Nkind (Par) = N_Package_Body then
10810 Collect_Previous_Instances (Declarations (Par));
10812 elsif Nkind (Par) = N_Package_Declaration then
10813 Collect_Previous_Instances
10814 (Visible_Declarations (Specification (Par)));
10815 Collect_Previous_Instances
10816 (Private_Declarations (Specification (Par)));
10819 -- Enclosing unit is a subprogram body. In this
10820 -- case all instance bodies are processed in order
10821 -- and there is no need to collect them separately.
10826 Decl := First_Elmt (Previous_Instances);
10827 while Present (Decl) loop
10829 (Inst_Node => Node (Decl),
10831 Instance_Spec (Node (Decl)),
10832 Expander_Status => Exp_Status,
10833 Current_Sem_Unit =>
10834 Get_Code_Unit (Sloc (Node (Decl))),
10835 Scope_Suppress => Scope_Suppress,
10836 Local_Suppress_Stack_Top =>
10837 Local_Suppress_Stack_Top,
10838 Version => Ada_Version);
10840 -- Package instance
10843 Nkind (Node (Decl)) = N_Package_Instantiation
10845 Instantiate_Package_Body
10846 (Info, Body_Optional => True);
10848 -- Subprogram instance
10851 -- The instance_spec is the wrapper package,
10852 -- and the subprogram declaration is the last
10853 -- declaration in the wrapper.
10857 (Visible_Declarations
10858 (Specification (Info.Act_Decl)));
10860 Instantiate_Subprogram_Body
10861 (Info, Body_Optional => True);
10869 Instantiate_Package_Body
10871 ((Inst_Node => Inst_Node,
10872 Act_Decl => True_Parent,
10873 Expander_Status => Exp_Status,
10874 Current_Sem_Unit =>
10875 Get_Code_Unit (Sloc (Inst_Node)),
10876 Scope_Suppress => Scope_Suppress,
10877 Local_Suppress_Stack_Top =>
10878 Local_Suppress_Stack_Top,
10879 Version => Ada_Version)),
10880 Body_Optional => Body_Optional);
10884 -- Case where we are not instantiating a nested generic
10887 Opt.Style_Check := False;
10888 Expander_Mode_Save_And_Set (True);
10889 Load_Needed_Body (Comp_Unit, OK);
10890 Opt.Style_Check := Save_Style_Check;
10891 Expander_Mode_Restore;
10894 and then Unit_Requires_Body (Defining_Entity (Spec))
10895 and then not Body_Optional
10898 Bname : constant Unit_Name_Type :=
10899 Get_Body_Name (Get_Unit_Name (Unit (Comp_Unit)));
10902 -- In CodePeer mode, the missing body may make the analysis
10903 -- incomplete, but we do not treat it as fatal.
10905 if CodePeer_Mode then
10909 Error_Msg_Unit_1 := Bname;
10910 Error_Msg_N ("this instantiation requires$!", N);
10911 Error_Msg_File_1 :=
10912 Get_File_Name (Bname, Subunit => False);
10913 Error_Msg_N ("\but file{ was not found!", N);
10914 raise Unrecoverable_Error;
10921 -- If loading parent of the generic caused an instantiation circularity,
10922 -- we abandon compilation at this point, because otherwise in some cases
10923 -- we get into trouble with infinite recursions after this point.
10925 if Circularity_Detected then
10926 raise Unrecoverable_Error;
10928 end Load_Parent_Of_Generic;
10930 ---------------------------------
10931 -- Map_Formal_Package_Entities --
10932 ---------------------------------
10934 procedure Map_Formal_Package_Entities (Form : Entity_Id; Act : Entity_Id) is
10939 Set_Instance_Of (Form, Act);
10941 -- Traverse formal and actual package to map the corresponding entities.
10942 -- We skip over internal entities that may be generated during semantic
10943 -- analysis, and find the matching entities by name, given that they
10944 -- must appear in the same order.
10946 E1 := First_Entity (Form);
10947 E2 := First_Entity (Act);
10948 while Present (E1) and then E1 /= First_Private_Entity (Form) loop
10949 -- Could this test be a single condition???
10950 -- Seems like it could, and isn't FPE (Form) a constant anyway???
10952 if not Is_Internal (E1)
10953 and then Present (Parent (E1))
10954 and then not Is_Class_Wide_Type (E1)
10955 and then not Is_Internal_Name (Chars (E1))
10957 while Present (E2) and then Chars (E2) /= Chars (E1) loop
10964 Set_Instance_Of (E1, E2);
10966 if Is_Type (E1) and then Is_Tagged_Type (E2) then
10967 Set_Instance_Of (Class_Wide_Type (E1), Class_Wide_Type (E2));
10970 if Is_Constrained (E1) then
10971 Set_Instance_Of (Base_Type (E1), Base_Type (E2));
10974 if Ekind (E1) = E_Package and then No (Renamed_Object (E1)) then
10975 Map_Formal_Package_Entities (E1, E2);
10982 end Map_Formal_Package_Entities;
10984 -----------------------
10985 -- Move_Freeze_Nodes --
10986 -----------------------
10988 procedure Move_Freeze_Nodes
10989 (Out_Of : Entity_Id;
10994 Next_Decl : Node_Id;
10995 Next_Node : Node_Id := After;
10998 function Is_Outer_Type (T : Entity_Id) return Boolean;
10999 -- Check whether entity is declared in a scope external to that of the
11002 -------------------
11003 -- Is_Outer_Type --
11004 -------------------
11006 function Is_Outer_Type (T : Entity_Id) return Boolean is
11007 Scop : Entity_Id := Scope (T);
11010 if Scope_Depth (Scop) < Scope_Depth (Out_Of) then
11014 while Scop /= Standard_Standard loop
11015 if Scop = Out_Of then
11018 Scop := Scope (Scop);
11026 -- Start of processing for Move_Freeze_Nodes
11033 -- First remove the freeze nodes that may appear before all other
11037 while Present (Decl)
11038 and then Nkind (Decl) = N_Freeze_Entity
11039 and then Is_Outer_Type (Entity (Decl))
11041 Decl := Remove_Head (L);
11042 Insert_After (Next_Node, Decl);
11043 Set_Analyzed (Decl, False);
11048 -- Next scan the list of declarations and remove each freeze node that
11049 -- appears ahead of the current node.
11051 while Present (Decl) loop
11052 while Present (Next (Decl))
11053 and then Nkind (Next (Decl)) = N_Freeze_Entity
11054 and then Is_Outer_Type (Entity (Next (Decl)))
11056 Next_Decl := Remove_Next (Decl);
11057 Insert_After (Next_Node, Next_Decl);
11058 Set_Analyzed (Next_Decl, False);
11059 Next_Node := Next_Decl;
11062 -- If the declaration is a nested package or concurrent type, then
11063 -- recurse. Nested generic packages will have been processed from the
11066 case Nkind (Decl) is
11067 when N_Package_Declaration =>
11068 Spec := Specification (Decl);
11070 when N_Task_Type_Declaration =>
11071 Spec := Task_Definition (Decl);
11073 when N_Protected_Type_Declaration =>
11074 Spec := Protected_Definition (Decl);
11080 if Present (Spec) then
11081 Move_Freeze_Nodes (Out_Of, Next_Node, Visible_Declarations (Spec));
11082 Move_Freeze_Nodes (Out_Of, Next_Node, Private_Declarations (Spec));
11087 end Move_Freeze_Nodes;
11093 function Next_Assoc (E : Assoc_Ptr) return Assoc_Ptr is
11095 return Generic_Renamings.Table (E).Next_In_HTable;
11098 ------------------------
11099 -- Preanalyze_Actuals --
11100 ------------------------
11102 procedure Preanalyze_Actuals (N : Node_Id) is
11105 Errs : constant Int := Serious_Errors_Detected;
11107 Cur : Entity_Id := Empty;
11108 -- Current homograph of the instance name
11111 -- Saved visibility status of the current homograph
11114 Assoc := First (Generic_Associations (N));
11116 -- If the instance is a child unit, its name may hide an outer homonym,
11117 -- so make it invisible to perform name resolution on the actuals.
11119 if Nkind (Defining_Unit_Name (N)) = N_Defining_Program_Unit_Name
11121 (Current_Entity (Defining_Identifier (Defining_Unit_Name (N))))
11123 Cur := Current_Entity (Defining_Identifier (Defining_Unit_Name (N)));
11125 if Is_Compilation_Unit (Cur) then
11126 Vis := Is_Immediately_Visible (Cur);
11127 Set_Is_Immediately_Visible (Cur, False);
11133 while Present (Assoc) loop
11134 if Nkind (Assoc) /= N_Others_Choice then
11135 Act := Explicit_Generic_Actual_Parameter (Assoc);
11137 -- Within a nested instantiation, a defaulted actual is an empty
11138 -- association, so nothing to analyze. If the subprogram actual
11139 -- is an attribute, analyze prefix only, because actual is not a
11140 -- complete attribute reference.
11142 -- If actual is an allocator, analyze expression only. The full
11143 -- analysis can generate code, and if instance is a compilation
11144 -- unit we have to wait until the package instance is installed
11145 -- to have a proper place to insert this code.
11147 -- String literals may be operators, but at this point we do not
11148 -- know whether the actual is a formal subprogram or a string.
11153 elsif Nkind (Act) = N_Attribute_Reference then
11154 Analyze (Prefix (Act));
11156 elsif Nkind (Act) = N_Explicit_Dereference then
11157 Analyze (Prefix (Act));
11159 elsif Nkind (Act) = N_Allocator then
11161 Expr : constant Node_Id := Expression (Act);
11164 if Nkind (Expr) = N_Subtype_Indication then
11165 Analyze (Subtype_Mark (Expr));
11167 -- Analyze separately each discriminant constraint, when
11168 -- given with a named association.
11174 Constr := First (Constraints (Constraint (Expr)));
11175 while Present (Constr) loop
11176 if Nkind (Constr) = N_Discriminant_Association then
11177 Analyze (Expression (Constr));
11191 elsif Nkind (Act) /= N_Operator_Symbol then
11195 if Errs /= Serious_Errors_Detected then
11197 -- Do a minimal analysis of the generic, to prevent spurious
11198 -- warnings complaining about the generic being unreferenced,
11199 -- before abandoning the instantiation.
11201 Analyze (Name (N));
11203 if Is_Entity_Name (Name (N))
11204 and then Etype (Name (N)) /= Any_Type
11206 Generate_Reference (Entity (Name (N)), Name (N));
11207 Set_Is_Instantiated (Entity (Name (N)));
11210 if Present (Cur) then
11212 -- For the case of a child instance hiding an outer homonym,
11213 -- provide additional warning which might explain the error.
11215 Set_Is_Immediately_Visible (Cur, Vis);
11216 Error_Msg_NE ("& hides outer unit with the same name?",
11217 N, Defining_Unit_Name (N));
11220 Abandon_Instantiation (Act);
11227 if Present (Cur) then
11228 Set_Is_Immediately_Visible (Cur, Vis);
11230 end Preanalyze_Actuals;
11232 -------------------
11233 -- Remove_Parent --
11234 -------------------
11236 procedure Remove_Parent (In_Body : Boolean := False) is
11237 S : Entity_Id := Current_Scope;
11238 -- S is the scope containing the instantiation just completed. The scope
11239 -- stack contains the parent instances of the instantiation, followed by
11248 -- After child instantiation is complete, remove from scope stack the
11249 -- extra copy of the current scope, and then remove parent instances.
11251 if not In_Body then
11254 while Current_Scope /= S loop
11255 P := Current_Scope;
11256 End_Package_Scope (Current_Scope);
11258 if In_Open_Scopes (P) then
11259 E := First_Entity (P);
11260 while Present (E) loop
11261 Set_Is_Immediately_Visible (E, True);
11265 -- If instantiation is declared in a block, it is the enclosing
11266 -- scope that might be a parent instance. Note that only one
11267 -- block can be involved, because the parent instances have
11268 -- been installed within it.
11270 if Ekind (P) = E_Block then
11271 Cur_P := Scope (P);
11276 if Is_Generic_Instance (Cur_P) and then P /= Current_Scope then
11277 -- We are within an instance of some sibling. Retain
11278 -- visibility of parent, for proper subsequent cleanup, and
11279 -- reinstall private declarations as well.
11281 Set_In_Private_Part (P);
11282 Install_Private_Declarations (P);
11285 -- If the ultimate parent is a top-level unit recorded in
11286 -- Instance_Parent_Unit, then reset its visibility to what it was
11287 -- before instantiation. (It's not clear what the purpose is of
11288 -- testing whether Scope (P) is In_Open_Scopes, but that test was
11289 -- present before the ultimate parent test was added.???)
11291 elsif not In_Open_Scopes (Scope (P))
11292 or else (P = Instance_Parent_Unit
11293 and then not Parent_Unit_Visible)
11295 Set_Is_Immediately_Visible (P, False);
11297 -- If the current scope is itself an instantiation of a generic
11298 -- nested within P, and we are in the private part of body of this
11299 -- instantiation, restore the full views of P, that were removed
11300 -- in End_Package_Scope above. This obscure case can occur when a
11301 -- subunit of a generic contains an instance of a child unit of
11302 -- its generic parent unit.
11304 elsif S = Current_Scope and then Is_Generic_Instance (S) then
11306 Par : constant Entity_Id :=
11308 (Specification (Unit_Declaration_Node (S)));
11311 and then P = Scope (Par)
11312 and then (In_Package_Body (S) or else In_Private_Part (S))
11314 Set_In_Private_Part (P);
11315 Install_Private_Declarations (P);
11321 -- Reset visibility of entities in the enclosing scope
11323 Set_Is_Hidden_Open_Scope (Current_Scope, False);
11325 Hidden := First_Elmt (Hidden_Entities);
11326 while Present (Hidden) loop
11327 Set_Is_Immediately_Visible (Node (Hidden), True);
11328 Next_Elmt (Hidden);
11332 -- Each body is analyzed separately, and there is no context that
11333 -- needs preserving from one body instance to the next, so remove all
11334 -- parent scopes that have been installed.
11336 while Present (S) loop
11337 End_Package_Scope (S);
11338 Set_Is_Immediately_Visible (S, False);
11339 S := Current_Scope;
11340 exit when S = Standard_Standard;
11349 procedure Restore_Env is
11350 Saved : Instance_Env renames Instance_Envs.Table (Instance_Envs.Last);
11353 if No (Current_Instantiated_Parent.Act_Id) then
11354 -- Restore environment after subprogram inlining
11356 Restore_Private_Views (Empty);
11359 Current_Instantiated_Parent := Saved.Instantiated_Parent;
11360 Exchanged_Views := Saved.Exchanged_Views;
11361 Hidden_Entities := Saved.Hidden_Entities;
11362 Current_Sem_Unit := Saved.Current_Sem_Unit;
11363 Parent_Unit_Visible := Saved.Parent_Unit_Visible;
11364 Instance_Parent_Unit := Saved.Instance_Parent_Unit;
11366 Restore_Opt_Config_Switches (Saved.Switches);
11368 Instance_Envs.Decrement_Last;
11371 ---------------------------
11372 -- Restore_Private_Views --
11373 ---------------------------
11375 procedure Restore_Private_Views
11376 (Pack_Id : Entity_Id;
11377 Is_Package : Boolean := True)
11382 Dep_Elmt : Elmt_Id;
11385 procedure Restore_Nested_Formal (Formal : Entity_Id);
11386 -- Hide the generic formals of formal packages declared with box which
11387 -- were reachable in the current instantiation.
11389 ---------------------------
11390 -- Restore_Nested_Formal --
11391 ---------------------------
11393 procedure Restore_Nested_Formal (Formal : Entity_Id) is
11397 if Present (Renamed_Object (Formal))
11398 and then Denotes_Formal_Package (Renamed_Object (Formal), True)
11402 elsif Present (Associated_Formal_Package (Formal)) then
11403 Ent := First_Entity (Formal);
11404 while Present (Ent) loop
11405 exit when Ekind (Ent) = E_Package
11406 and then Renamed_Entity (Ent) = Renamed_Entity (Formal);
11408 Set_Is_Hidden (Ent);
11409 Set_Is_Potentially_Use_Visible (Ent, False);
11411 -- If package, then recurse
11413 if Ekind (Ent) = E_Package then
11414 Restore_Nested_Formal (Ent);
11420 end Restore_Nested_Formal;
11422 -- Start of processing for Restore_Private_Views
11425 M := First_Elmt (Exchanged_Views);
11426 while Present (M) loop
11429 -- Subtypes of types whose views have been exchanged, and that are
11430 -- defined within the instance, were not on the Private_Dependents
11431 -- list on entry to the instance, so they have to be exchanged
11432 -- explicitly now, in order to remain consistent with the view of the
11435 if Ekind_In (Typ, E_Private_Type,
11436 E_Limited_Private_Type,
11437 E_Record_Type_With_Private)
11439 Dep_Elmt := First_Elmt (Private_Dependents (Typ));
11440 while Present (Dep_Elmt) loop
11441 Dep_Typ := Node (Dep_Elmt);
11443 if Scope (Dep_Typ) = Pack_Id
11444 and then Present (Full_View (Dep_Typ))
11446 Replace_Elmt (Dep_Elmt, Full_View (Dep_Typ));
11447 Exchange_Declarations (Dep_Typ);
11450 Next_Elmt (Dep_Elmt);
11454 Exchange_Declarations (Node (M));
11458 if No (Pack_Id) then
11462 -- Make the generic formal parameters private, and make the formal types
11463 -- into subtypes of the actuals again.
11465 E := First_Entity (Pack_Id);
11466 while Present (E) loop
11467 Set_Is_Hidden (E, True);
11470 and then Nkind (Parent (E)) = N_Subtype_Declaration
11472 Set_Is_Generic_Actual_Type (E, False);
11474 -- An unusual case of aliasing: the actual may also be directly
11475 -- visible in the generic, and be private there, while it is fully
11476 -- visible in the context of the instance. The internal subtype
11477 -- is private in the instance but has full visibility like its
11478 -- parent in the enclosing scope. This enforces the invariant that
11479 -- the privacy status of all private dependents of a type coincide
11480 -- with that of the parent type. This can only happen when a
11481 -- generic child unit is instantiated within a sibling.
11483 if Is_Private_Type (E)
11484 and then not Is_Private_Type (Etype (E))
11486 Exchange_Declarations (E);
11489 elsif Ekind (E) = E_Package then
11491 -- The end of the renaming list is the renaming of the generic
11492 -- package itself. If the instance is a subprogram, all entities
11493 -- in the corresponding package are renamings. If this entity is
11494 -- a formal package, make its own formals private as well. The
11495 -- actual in this case is itself the renaming of an instantiation.
11496 -- If the entity is not a package renaming, it is the entity
11497 -- created to validate formal package actuals: ignore it.
11499 -- If the actual is itself a formal package for the enclosing
11500 -- generic, or the actual for such a formal package, it remains
11501 -- visible on exit from the instance, and therefore nothing needs
11502 -- to be done either, except to keep it accessible.
11504 if Is_Package and then Renamed_Object (E) = Pack_Id then
11507 elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then
11511 Denotes_Formal_Package (Renamed_Object (E), True, Pack_Id)
11513 Set_Is_Hidden (E, False);
11517 Act_P : constant Entity_Id := Renamed_Object (E);
11521 Id := First_Entity (Act_P);
11523 and then Id /= First_Private_Entity (Act_P)
11525 exit when Ekind (Id) = E_Package
11526 and then Renamed_Object (Id) = Act_P;
11528 Set_Is_Hidden (Id, True);
11529 Set_Is_Potentially_Use_Visible (Id, In_Use (Act_P));
11531 if Ekind (Id) = E_Package then
11532 Restore_Nested_Formal (Id);
11543 end Restore_Private_Views;
11550 (Gen_Unit : Entity_Id;
11551 Act_Unit : Entity_Id)
11555 Set_Instance_Env (Gen_Unit, Act_Unit);
11558 ----------------------------
11559 -- Save_Global_References --
11560 ----------------------------
11562 procedure Save_Global_References (N : Node_Id) is
11563 Gen_Scope : Entity_Id;
11567 function Is_Global (E : Entity_Id) return Boolean;
11568 -- Check whether entity is defined outside of generic unit. Examine the
11569 -- scope of an entity, and the scope of the scope, etc, until we find
11570 -- either Standard, in which case the entity is global, or the generic
11571 -- unit itself, which indicates that the entity is local. If the entity
11572 -- is the generic unit itself, as in the case of a recursive call, or
11573 -- the enclosing generic unit, if different from the current scope, then
11574 -- it is local as well, because it will be replaced at the point of
11575 -- instantiation. On the other hand, if it is a reference to a child
11576 -- unit of a common ancestor, which appears in an instantiation, it is
11577 -- global because it is used to denote a specific compilation unit at
11578 -- the time the instantiations will be analyzed.
11580 procedure Reset_Entity (N : Node_Id);
11581 -- Save semantic information on global entity so that it is not resolved
11582 -- again at instantiation time.
11584 procedure Save_Entity_Descendants (N : Node_Id);
11585 -- Apply Save_Global_References to the two syntactic descendants of
11586 -- non-terminal nodes that carry an Associated_Node and are processed
11587 -- through Reset_Entity. Once the global entity (if any) has been
11588 -- captured together with its type, only two syntactic descendants need
11589 -- to be traversed to complete the processing of the tree rooted at N.
11590 -- This applies to Selected_Components, Expanded_Names, and to Operator
11591 -- nodes. N can also be a character literal, identifier, or operator
11592 -- symbol node, but the call has no effect in these cases.
11594 procedure Save_Global_Defaults (N1, N2 : Node_Id);
11595 -- Default actuals in nested instances must be handled specially
11596 -- because there is no link to them from the original tree. When an
11597 -- actual subprogram is given by a default, we add an explicit generic
11598 -- association for it in the instantiation node. When we save the
11599 -- global references on the name of the instance, we recover the list
11600 -- of generic associations, and add an explicit one to the original
11601 -- generic tree, through which a global actual can be preserved.
11602 -- Similarly, if a child unit is instantiated within a sibling, in the
11603 -- context of the parent, we must preserve the identifier of the parent
11604 -- so that it can be properly resolved in a subsequent instantiation.
11606 procedure Save_Global_Descendant (D : Union_Id);
11607 -- Apply Save_Global_References recursively to the descendents of the
11610 procedure Save_References (N : Node_Id);
11611 -- This is the recursive procedure that does the work, once the
11612 -- enclosing generic scope has been established.
11618 function Is_Global (E : Entity_Id) return Boolean is
11621 function Is_Instance_Node (Decl : Node_Id) return Boolean;
11622 -- Determine whether the parent node of a reference to a child unit
11623 -- denotes an instantiation or a formal package, in which case the
11624 -- reference to the child unit is global, even if it appears within
11625 -- the current scope (e.g. when the instance appears within the body
11626 -- of an ancestor).
11628 ----------------------
11629 -- Is_Instance_Node --
11630 ----------------------
11632 function Is_Instance_Node (Decl : Node_Id) return Boolean is
11634 return Nkind (Decl) in N_Generic_Instantiation
11636 Nkind (Original_Node (Decl)) = N_Formal_Package_Declaration;
11637 end Is_Instance_Node;
11639 -- Start of processing for Is_Global
11642 if E = Gen_Scope then
11645 elsif E = Standard_Standard then
11648 elsif Is_Child_Unit (E)
11649 and then (Is_Instance_Node (Parent (N2))
11650 or else (Nkind (Parent (N2)) = N_Expanded_Name
11651 and then N2 = Selector_Name (Parent (N2))
11653 Is_Instance_Node (Parent (Parent (N2)))))
11659 while Se /= Gen_Scope loop
11660 if Se = Standard_Standard then
11675 procedure Reset_Entity (N : Node_Id) is
11677 procedure Set_Global_Type (N : Node_Id; N2 : Node_Id);
11678 -- If the type of N2 is global to the generic unit. Save the type in
11679 -- the generic node.
11680 -- What does this comment mean???
11682 function Top_Ancestor (E : Entity_Id) return Entity_Id;
11683 -- Find the ultimate ancestor of the current unit. If it is not a
11684 -- generic unit, then the name of the current unit in the prefix of
11685 -- an expanded name must be replaced with its generic homonym to
11686 -- ensure that it will be properly resolved in an instance.
11688 ---------------------
11689 -- Set_Global_Type --
11690 ---------------------
11692 procedure Set_Global_Type (N : Node_Id; N2 : Node_Id) is
11693 Typ : constant Entity_Id := Etype (N2);
11696 Set_Etype (N, Typ);
11698 if Entity (N) /= N2
11699 and then Has_Private_View (Entity (N))
11701 -- If the entity of N is not the associated node, this is a
11702 -- nested generic and it has an associated node as well, whose
11703 -- type is already the full view (see below). Indicate that the
11704 -- original node has a private view.
11706 Set_Has_Private_View (N);
11709 -- If not a private type, nothing else to do
11711 if not Is_Private_Type (Typ) then
11712 if Is_Array_Type (Typ)
11713 and then Is_Private_Type (Component_Type (Typ))
11715 Set_Has_Private_View (N);
11718 -- If it is a derivation of a private type in a context where no
11719 -- full view is needed, nothing to do either.
11721 elsif No (Full_View (Typ)) and then Typ /= Etype (Typ) then
11724 -- Otherwise mark the type for flipping and use the full view when
11728 Set_Has_Private_View (N);
11730 if Present (Full_View (Typ)) then
11731 Set_Etype (N2, Full_View (Typ));
11734 end Set_Global_Type;
11740 function Top_Ancestor (E : Entity_Id) return Entity_Id is
11745 while Is_Child_Unit (Par) loop
11746 Par := Scope (Par);
11752 -- Start of processing for Reset_Entity
11755 N2 := Get_Associated_Node (N);
11758 -- If the entity is an itype created as a subtype of an access type
11759 -- with a null exclusion restore source entity for proper visibility.
11760 -- The itype will be created anew in the instance.
11762 if Present (E) then
11764 and then Ekind (E) = E_Access_Subtype
11765 and then Is_Entity_Name (N)
11766 and then Chars (Etype (E)) = Chars (N)
11769 Set_Entity (N2, E);
11773 if Is_Global (E) then
11774 Set_Global_Type (N, N2);
11776 elsif Nkind (N) = N_Op_Concat
11777 and then Is_Generic_Type (Etype (N2))
11778 and then (Base_Type (Etype (Right_Opnd (N2))) = Etype (N2)
11780 Base_Type (Etype (Left_Opnd (N2))) = Etype (N2))
11781 and then Is_Intrinsic_Subprogram (E)
11786 -- Entity is local. Mark generic node as unresolved.
11787 -- Note that now it does not have an entity.
11789 Set_Associated_Node (N, Empty);
11790 Set_Etype (N, Empty);
11793 if Nkind (Parent (N)) in N_Generic_Instantiation
11794 and then N = Name (Parent (N))
11796 Save_Global_Defaults (Parent (N), Parent (N2));
11799 elsif Nkind (Parent (N)) = N_Selected_Component
11800 and then Nkind (Parent (N2)) = N_Expanded_Name
11802 if Is_Global (Entity (Parent (N2))) then
11803 Change_Selected_Component_To_Expanded_Name (Parent (N));
11804 Set_Associated_Node (Parent (N), Parent (N2));
11805 Set_Global_Type (Parent (N), Parent (N2));
11806 Save_Entity_Descendants (N);
11808 -- If this is a reference to the current generic entity, replace
11809 -- by the name of the generic homonym of the current package. This
11810 -- is because in an instantiation Par.P.Q will not resolve to the
11811 -- name of the instance, whose enclosing scope is not necessarily
11812 -- Par. We use the generic homonym rather that the name of the
11813 -- generic itself because it may be hidden by a local declaration.
11815 elsif In_Open_Scopes (Entity (Parent (N2)))
11817 Is_Generic_Unit (Top_Ancestor (Entity (Prefix (Parent (N2)))))
11819 if Ekind (Entity (Parent (N2))) = E_Generic_Package then
11820 Rewrite (Parent (N),
11821 Make_Identifier (Sloc (N),
11823 Chars (Generic_Homonym (Entity (Parent (N2))))));
11825 Rewrite (Parent (N),
11826 Make_Identifier (Sloc (N),
11827 Chars => Chars (Selector_Name (Parent (N2)))));
11831 if Nkind (Parent (Parent (N))) in N_Generic_Instantiation
11832 and then Parent (N) = Name (Parent (Parent (N)))
11834 Save_Global_Defaults
11835 (Parent (Parent (N)), Parent (Parent ((N2))));
11838 -- A selected component may denote a static constant that has been
11839 -- folded. If the static constant is global to the generic, capture
11840 -- its value. Otherwise the folding will happen in any instantiation.
11842 elsif Nkind (Parent (N)) = N_Selected_Component
11843 and then Nkind_In (Parent (N2), N_Integer_Literal, N_Real_Literal)
11845 if Present (Entity (Original_Node (Parent (N2))))
11846 and then Is_Global (Entity (Original_Node (Parent (N2))))
11848 Rewrite (Parent (N), New_Copy (Parent (N2)));
11849 Set_Analyzed (Parent (N), False);
11855 -- A selected component may be transformed into a parameterless
11856 -- function call. If the called entity is global, rewrite the node
11857 -- appropriately, i.e. as an extended name for the global entity.
11859 elsif Nkind (Parent (N)) = N_Selected_Component
11860 and then Nkind (Parent (N2)) = N_Function_Call
11861 and then N = Selector_Name (Parent (N))
11863 if No (Parameter_Associations (Parent (N2))) then
11864 if Is_Global (Entity (Name (Parent (N2)))) then
11865 Change_Selected_Component_To_Expanded_Name (Parent (N));
11866 Set_Associated_Node (Parent (N), Name (Parent (N2)));
11867 Set_Global_Type (Parent (N), Name (Parent (N2)));
11868 Save_Entity_Descendants (N);
11871 Set_Associated_Node (N, Empty);
11872 Set_Etype (N, Empty);
11875 -- In Ada 2005, X.F may be a call to a primitive operation,
11876 -- rewritten as F (X). This rewriting will be done again in an
11877 -- instance, so keep the original node. Global entities will be
11878 -- captured as for other constructs.
11884 -- Entity is local. Reset in generic unit, so that node is resolved
11885 -- anew at the point of instantiation.
11888 Set_Associated_Node (N, Empty);
11889 Set_Etype (N, Empty);
11893 -----------------------------
11894 -- Save_Entity_Descendants --
11895 -----------------------------
11897 procedure Save_Entity_Descendants (N : Node_Id) is
11900 when N_Binary_Op =>
11901 Save_Global_Descendant (Union_Id (Left_Opnd (N)));
11902 Save_Global_Descendant (Union_Id (Right_Opnd (N)));
11905 Save_Global_Descendant (Union_Id (Right_Opnd (N)));
11907 when N_Expanded_Name | N_Selected_Component =>
11908 Save_Global_Descendant (Union_Id (Prefix (N)));
11909 Save_Global_Descendant (Union_Id (Selector_Name (N)));
11911 when N_Identifier | N_Character_Literal | N_Operator_Symbol =>
11915 raise Program_Error;
11917 end Save_Entity_Descendants;
11919 --------------------------
11920 -- Save_Global_Defaults --
11921 --------------------------
11923 procedure Save_Global_Defaults (N1, N2 : Node_Id) is
11924 Loc : constant Source_Ptr := Sloc (N1);
11925 Assoc2 : constant List_Id := Generic_Associations (N2);
11926 Gen_Id : constant Entity_Id := Get_Generic_Entity (N2);
11933 Actual : Entity_Id;
11936 Assoc1 := Generic_Associations (N1);
11938 if Present (Assoc1) then
11939 Act1 := First (Assoc1);
11942 Set_Generic_Associations (N1, New_List);
11943 Assoc1 := Generic_Associations (N1);
11946 if Present (Assoc2) then
11947 Act2 := First (Assoc2);
11952 while Present (Act1) and then Present (Act2) loop
11957 -- Find the associations added for default subprograms
11959 if Present (Act2) then
11960 while Nkind (Act2) /= N_Generic_Association
11961 or else No (Entity (Selector_Name (Act2)))
11962 or else not Is_Overloadable (Entity (Selector_Name (Act2)))
11967 -- Add a similar association if the default is global. The
11968 -- renaming declaration for the actual has been analyzed, and
11969 -- its alias is the program it renames. Link the actual in the
11970 -- original generic tree with the node in the analyzed tree.
11972 while Present (Act2) loop
11973 Subp := Entity (Selector_Name (Act2));
11974 Def := Explicit_Generic_Actual_Parameter (Act2);
11976 -- Following test is defence against rubbish errors
11978 if No (Alias (Subp)) then
11982 -- Retrieve the resolved actual from the renaming declaration
11983 -- created for the instantiated formal.
11985 Actual := Entity (Name (Parent (Parent (Subp))));
11986 Set_Entity (Def, Actual);
11987 Set_Etype (Def, Etype (Actual));
11989 if Is_Global (Actual) then
11991 Make_Generic_Association (Loc,
11992 Selector_Name => New_Occurrence_Of (Subp, Loc),
11993 Explicit_Generic_Actual_Parameter =>
11994 New_Occurrence_Of (Actual, Loc));
11996 Set_Associated_Node
11997 (Explicit_Generic_Actual_Parameter (Ndec), Def);
11999 Append (Ndec, Assoc1);
12001 -- If there are other defaults, add a dummy association in case
12002 -- there are other defaulted formals with the same name.
12004 elsif Present (Next (Act2)) then
12006 Make_Generic_Association (Loc,
12007 Selector_Name => New_Occurrence_Of (Subp, Loc),
12008 Explicit_Generic_Actual_Parameter => Empty);
12010 Append (Ndec, Assoc1);
12017 if Nkind (Name (N1)) = N_Identifier
12018 and then Is_Child_Unit (Gen_Id)
12019 and then Is_Global (Gen_Id)
12020 and then Is_Generic_Unit (Scope (Gen_Id))
12021 and then In_Open_Scopes (Scope (Gen_Id))
12023 -- This is an instantiation of a child unit within a sibling, so
12024 -- that the generic parent is in scope. An eventual instance must
12025 -- occur within the scope of an instance of the parent. Make name
12026 -- in instance into an expanded name, to preserve the identifier
12027 -- of the parent, so it can be resolved subsequently.
12029 Rewrite (Name (N2),
12030 Make_Expanded_Name (Loc,
12031 Chars => Chars (Gen_Id),
12032 Prefix => New_Occurrence_Of (Scope (Gen_Id), Loc),
12033 Selector_Name => New_Occurrence_Of (Gen_Id, Loc)));
12034 Set_Entity (Name (N2), Gen_Id);
12036 Rewrite (Name (N1),
12037 Make_Expanded_Name (Loc,
12038 Chars => Chars (Gen_Id),
12039 Prefix => New_Occurrence_Of (Scope (Gen_Id), Loc),
12040 Selector_Name => New_Occurrence_Of (Gen_Id, Loc)));
12042 Set_Associated_Node (Name (N1), Name (N2));
12043 Set_Associated_Node (Prefix (Name (N1)), Empty);
12044 Set_Associated_Node
12045 (Selector_Name (Name (N1)), Selector_Name (Name (N2)));
12046 Set_Etype (Name (N1), Etype (Gen_Id));
12049 end Save_Global_Defaults;
12051 ----------------------------
12052 -- Save_Global_Descendant --
12053 ----------------------------
12055 procedure Save_Global_Descendant (D : Union_Id) is
12059 if D in Node_Range then
12060 if D = Union_Id (Empty) then
12063 elsif Nkind (Node_Id (D)) /= N_Compilation_Unit then
12064 Save_References (Node_Id (D));
12067 elsif D in List_Range then
12068 if D = Union_Id (No_List)
12069 or else Is_Empty_List (List_Id (D))
12074 N1 := First (List_Id (D));
12075 while Present (N1) loop
12076 Save_References (N1);
12081 -- Element list or other non-node field, nothing to do
12086 end Save_Global_Descendant;
12088 ---------------------
12089 -- Save_References --
12090 ---------------------
12092 -- This is the recursive procedure that does the work once the enclosing
12093 -- generic scope has been established. We have to treat specially a
12094 -- number of node rewritings that are required by semantic processing
12095 -- and which change the kind of nodes in the generic copy: typically
12096 -- constant-folding, replacing an operator node by a string literal, or
12097 -- a selected component by an expanded name. In each of those cases, the
12098 -- transformation is propagated to the generic unit.
12100 procedure Save_References (N : Node_Id) is
12101 Loc : constant Source_Ptr := Sloc (N);
12107 elsif Nkind_In (N, N_Character_Literal, N_Operator_Symbol) then
12108 if Nkind (N) = Nkind (Get_Associated_Node (N)) then
12111 elsif Nkind (N) = N_Operator_Symbol
12112 and then Nkind (Get_Associated_Node (N)) = N_String_Literal
12114 Change_Operator_Symbol_To_String_Literal (N);
12117 elsif Nkind (N) in N_Op then
12118 if Nkind (N) = Nkind (Get_Associated_Node (N)) then
12119 if Nkind (N) = N_Op_Concat then
12120 Set_Is_Component_Left_Opnd (N,
12121 Is_Component_Left_Opnd (Get_Associated_Node (N)));
12123 Set_Is_Component_Right_Opnd (N,
12124 Is_Component_Right_Opnd (Get_Associated_Node (N)));
12130 -- Node may be transformed into call to a user-defined operator
12132 N2 := Get_Associated_Node (N);
12134 if Nkind (N2) = N_Function_Call then
12135 E := Entity (Name (N2));
12138 and then Is_Global (E)
12140 Set_Etype (N, Etype (N2));
12142 Set_Associated_Node (N, Empty);
12143 Set_Etype (N, Empty);
12146 elsif Nkind_In (N2, N_Integer_Literal,
12150 if Present (Original_Node (N2))
12151 and then Nkind (Original_Node (N2)) = Nkind (N)
12154 -- Operation was constant-folded. Whenever possible,
12155 -- recover semantic information from unfolded node,
12158 Set_Associated_Node (N, Original_Node (N2));
12160 if Nkind (N) = N_Op_Concat then
12161 Set_Is_Component_Left_Opnd (N,
12162 Is_Component_Left_Opnd (Get_Associated_Node (N)));
12163 Set_Is_Component_Right_Opnd (N,
12164 Is_Component_Right_Opnd (Get_Associated_Node (N)));
12170 -- If original node is already modified, propagate
12171 -- constant-folding to template.
12173 Rewrite (N, New_Copy (N2));
12174 Set_Analyzed (N, False);
12177 elsif Nkind (N2) = N_Identifier
12178 and then Ekind (Entity (N2)) = E_Enumeration_Literal
12180 -- Same if call was folded into a literal, but in this case
12181 -- retain the entity to avoid spurious ambiguities if it is
12182 -- overloaded at the point of instantiation or inlining.
12184 Rewrite (N, New_Copy (N2));
12185 Set_Analyzed (N, False);
12189 -- Complete operands check if node has not been constant-folded
12191 if Nkind (N) in N_Op then
12192 Save_Entity_Descendants (N);
12195 elsif Nkind (N) = N_Identifier then
12196 if Nkind (N) = Nkind (Get_Associated_Node (N)) then
12198 -- If this is a discriminant reference, always save it. It is
12199 -- used in the instance to find the corresponding discriminant
12200 -- positionally rather than by name.
12202 Set_Original_Discriminant
12203 (N, Original_Discriminant (Get_Associated_Node (N)));
12207 N2 := Get_Associated_Node (N);
12209 if Nkind (N2) = N_Function_Call then
12210 E := Entity (Name (N2));
12212 -- Name resolves to a call to parameterless function. If
12213 -- original entity is global, mark node as resolved.
12216 and then Is_Global (E)
12218 Set_Etype (N, Etype (N2));
12220 Set_Associated_Node (N, Empty);
12221 Set_Etype (N, Empty);
12224 elsif Nkind_In (N2, N_Integer_Literal, N_Real_Literal)
12225 and then Is_Entity_Name (Original_Node (N2))
12227 -- Name resolves to named number that is constant-folded,
12228 -- We must preserve the original name for ASIS use, and
12229 -- undo the constant-folding, which will be repeated in
12232 Set_Associated_Node (N, Original_Node (N2));
12235 elsif Nkind (N2) = N_String_Literal then
12237 -- Name resolves to string literal. Perform the same
12238 -- replacement in generic.
12240 Rewrite (N, New_Copy (N2));
12242 elsif Nkind (N2) = N_Explicit_Dereference then
12244 -- An identifier is rewritten as a dereference if it is the
12245 -- prefix in an implicit dereference (call or attribute).
12246 -- The analysis of an instantiation will expand the node
12247 -- again, so we preserve the original tree but link it to
12248 -- the resolved entity in case it is global.
12250 if Is_Entity_Name (Prefix (N2))
12251 and then Present (Entity (Prefix (N2)))
12252 and then Is_Global (Entity (Prefix (N2)))
12254 Set_Associated_Node (N, Prefix (N2));
12256 elsif Nkind (Prefix (N2)) = N_Function_Call
12257 and then Is_Global (Entity (Name (Prefix (N2))))
12260 Make_Explicit_Dereference (Loc,
12261 Prefix => Make_Function_Call (Loc,
12263 New_Occurrence_Of (Entity (Name (Prefix (N2))),
12267 Set_Associated_Node (N, Empty);
12268 Set_Etype (N, Empty);
12271 -- The subtype mark of a nominally unconstrained object is
12272 -- rewritten as a subtype indication using the bounds of the
12273 -- expression. Recover the original subtype mark.
12275 elsif Nkind (N2) = N_Subtype_Indication
12276 and then Is_Entity_Name (Original_Node (N2))
12278 Set_Associated_Node (N, Original_Node (N2));
12286 elsif Nkind (N) in N_Entity then
12291 Qual : Node_Id := Empty;
12292 Typ : Entity_Id := Empty;
12295 use Atree.Unchecked_Access;
12296 -- This code section is part of implementing an untyped tree
12297 -- traversal, so it needs direct access to node fields.
12300 if Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then
12301 N2 := Get_Associated_Node (N);
12308 -- In an instance within a generic, use the name of the
12309 -- actual and not the original generic parameter. If the
12310 -- actual is global in the current generic it must be
12311 -- preserved for its instantiation.
12313 if Nkind (Parent (Typ)) = N_Subtype_Declaration
12315 Present (Generic_Parent_Type (Parent (Typ)))
12317 Typ := Base_Type (Typ);
12318 Set_Etype (N2, Typ);
12324 or else not Is_Global (Typ)
12326 Set_Associated_Node (N, Empty);
12328 -- If the aggregate is an actual in a call, it has been
12329 -- resolved in the current context, to some local type.
12330 -- The enclosing call may have been disambiguated by the
12331 -- aggregate, and this disambiguation might fail at
12332 -- instantiation time because the type to which the
12333 -- aggregate did resolve is not preserved. In order to
12334 -- preserve some of this information, we wrap the
12335 -- aggregate in a qualified expression, using the id of
12336 -- its type. For further disambiguation we qualify the
12337 -- type name with its scope (if visible) because both
12338 -- id's will have corresponding entities in an instance.
12339 -- This resolves most of the problems with missing type
12340 -- information on aggregates in instances.
12342 if Nkind (N2) = Nkind (N)
12344 Nkind_In (Parent (N2), N_Procedure_Call_Statement,
12346 and then Comes_From_Source (Typ)
12348 if Is_Immediately_Visible (Scope (Typ)) then
12349 Nam := Make_Selected_Component (Loc,
12351 Make_Identifier (Loc, Chars (Scope (Typ))),
12353 Make_Identifier (Loc, Chars (Typ)));
12355 Nam := Make_Identifier (Loc, Chars (Typ));
12359 Make_Qualified_Expression (Loc,
12360 Subtype_Mark => Nam,
12361 Expression => Relocate_Node (N));
12365 Save_Global_Descendant (Field1 (N));
12366 Save_Global_Descendant (Field2 (N));
12367 Save_Global_Descendant (Field3 (N));
12368 Save_Global_Descendant (Field5 (N));
12370 if Present (Qual) then
12374 -- All other cases than aggregates
12377 -- For pragmas, we propagate the Enabled status for the
12378 -- relevant pragmas to the original generic tree. This was
12379 -- originally needed for SCO generation. It is no longer
12380 -- needed there (since we use the Sloc value in calls to
12381 -- Set_SCO_Pragma_Enabled), but it seems a generally good
12382 -- idea to have this flag set properly.
12384 if Nkind (N) = N_Pragma
12386 (Pragma_Name (N) = Name_Assert or else
12387 Pragma_Name (N) = Name_Check or else
12388 Pragma_Name (N) = Name_Precondition or else
12389 Pragma_Name (N) = Name_Postcondition)
12390 and then Present (Associated_Node (Pragma_Identifier (N)))
12392 Set_Pragma_Enabled (N,
12394 (Parent (Associated_Node (Pragma_Identifier (N)))));
12397 Save_Global_Descendant (Field1 (N));
12398 Save_Global_Descendant (Field2 (N));
12399 Save_Global_Descendant (Field3 (N));
12400 Save_Global_Descendant (Field4 (N));
12401 Save_Global_Descendant (Field5 (N));
12405 end Save_References;
12407 -- Start of processing for Save_Global_References
12410 Gen_Scope := Current_Scope;
12412 -- If the generic unit is a child unit, references to entities in the
12413 -- parent are treated as local, because they will be resolved anew in
12414 -- the context of the instance of the parent.
12416 while Is_Child_Unit (Gen_Scope)
12417 and then Ekind (Scope (Gen_Scope)) = E_Generic_Package
12419 Gen_Scope := Scope (Gen_Scope);
12422 Save_References (N);
12423 end Save_Global_References;
12425 --------------------------------------
12426 -- Set_Copied_Sloc_For_Inlined_Body --
12427 --------------------------------------
12429 procedure Set_Copied_Sloc_For_Inlined_Body (N : Node_Id; E : Entity_Id) is
12431 Create_Instantiation_Source (N, E, True, S_Adjustment);
12432 end Set_Copied_Sloc_For_Inlined_Body;
12434 ---------------------
12435 -- Set_Instance_Of --
12436 ---------------------
12438 procedure Set_Instance_Of (A : Entity_Id; B : Entity_Id) is
12440 Generic_Renamings.Table (Generic_Renamings.Last) := (A, B, Assoc_Null);
12441 Generic_Renamings_HTable.Set (Generic_Renamings.Last);
12442 Generic_Renamings.Increment_Last;
12443 end Set_Instance_Of;
12445 --------------------
12446 -- Set_Next_Assoc --
12447 --------------------
12449 procedure Set_Next_Assoc (E : Assoc_Ptr; Next : Assoc_Ptr) is
12451 Generic_Renamings.Table (E).Next_In_HTable := Next;
12452 end Set_Next_Assoc;
12454 -------------------
12455 -- Start_Generic --
12456 -------------------
12458 procedure Start_Generic is
12460 -- ??? More things could be factored out in this routine.
12461 -- Should probably be done at a later stage.
12463 Generic_Flags.Append (Inside_A_Generic);
12464 Inside_A_Generic := True;
12466 Expander_Mode_Save_And_Set (False);
12469 ----------------------
12470 -- Set_Instance_Env --
12471 ----------------------
12473 procedure Set_Instance_Env
12474 (Gen_Unit : Entity_Id;
12475 Act_Unit : Entity_Id)
12478 -- Regardless of the current mode, predefined units are analyzed in the
12479 -- most current Ada mode, and earlier version Ada checks do not apply
12480 -- to predefined units. Nothing needs to be done for non-internal units.
12481 -- These are always analyzed in the current mode.
12483 if Is_Internal_File_Name
12484 (Fname => Unit_File_Name (Get_Source_Unit (Gen_Unit)),
12485 Renamings_Included => True)
12487 Set_Opt_Config_Switches (True, Current_Sem_Unit = Main_Unit);
12490 Current_Instantiated_Parent :=
12491 (Gen_Id => Gen_Unit,
12492 Act_Id => Act_Unit,
12493 Next_In_HTable => Assoc_Null);
12494 end Set_Instance_Env;
12500 procedure Switch_View (T : Entity_Id) is
12501 BT : constant Entity_Id := Base_Type (T);
12502 Priv_Elmt : Elmt_Id := No_Elmt;
12503 Priv_Sub : Entity_Id;
12506 -- T may be private but its base type may have been exchanged through
12507 -- some other occurrence, in which case there is nothing to switch
12508 -- besides T itself. Note that a private dependent subtype of a private
12509 -- type might not have been switched even if the base type has been,
12510 -- because of the last branch of Check_Private_View (see comment there).
12512 if not Is_Private_Type (BT) then
12513 Prepend_Elmt (Full_View (T), Exchanged_Views);
12514 Exchange_Declarations (T);
12518 Priv_Elmt := First_Elmt (Private_Dependents (BT));
12520 if Present (Full_View (BT)) then
12521 Prepend_Elmt (Full_View (BT), Exchanged_Views);
12522 Exchange_Declarations (BT);
12525 while Present (Priv_Elmt) loop
12526 Priv_Sub := (Node (Priv_Elmt));
12528 -- We avoid flipping the subtype if the Etype of its full view is
12529 -- private because this would result in a malformed subtype. This
12530 -- occurs when the Etype of the subtype full view is the full view of
12531 -- the base type (and since the base types were just switched, the
12532 -- subtype is pointing to the wrong view). This is currently the case
12533 -- for tagged record types, access types (maybe more?) and needs to
12534 -- be resolved. ???
12536 if Present (Full_View (Priv_Sub))
12537 and then not Is_Private_Type (Etype (Full_View (Priv_Sub)))
12539 Prepend_Elmt (Full_View (Priv_Sub), Exchanged_Views);
12540 Exchange_Declarations (Priv_Sub);
12543 Next_Elmt (Priv_Elmt);
12547 -----------------------------
12548 -- Valid_Default_Attribute --
12549 -----------------------------
12551 procedure Valid_Default_Attribute (Nam : Entity_Id; Def : Node_Id) is
12552 Attr_Id : constant Attribute_Id :=
12553 Get_Attribute_Id (Attribute_Name (Def));
12554 T : constant Entity_Id := Entity (Prefix (Def));
12555 Is_Fun : constant Boolean := (Ekind (Nam) = E_Function);
12568 F := First_Formal (Nam);
12569 while Present (F) loop
12570 Num_F := Num_F + 1;
12575 when Attribute_Adjacent | Attribute_Ceiling | Attribute_Copy_Sign |
12576 Attribute_Floor | Attribute_Fraction | Attribute_Machine |
12577 Attribute_Model | Attribute_Remainder | Attribute_Rounding |
12578 Attribute_Unbiased_Rounding =>
12581 and then Is_Floating_Point_Type (T);
12583 when Attribute_Image | Attribute_Pred | Attribute_Succ |
12584 Attribute_Value | Attribute_Wide_Image |
12585 Attribute_Wide_Value =>
12586 OK := (Is_Fun and then Num_F = 1 and then Is_Scalar_Type (T));
12588 when Attribute_Max | Attribute_Min =>
12589 OK := (Is_Fun and then Num_F = 2 and then Is_Scalar_Type (T));
12591 when Attribute_Input =>
12592 OK := (Is_Fun and then Num_F = 1);
12594 when Attribute_Output | Attribute_Read | Attribute_Write =>
12595 OK := (not Is_Fun and then Num_F = 2);
12602 Error_Msg_N ("attribute reference has wrong profile for subprogram",
12605 end Valid_Default_Attribute;