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 => 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 Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N));
1929 end Analyze_Formal_Object_Declaration;
1931 ----------------------------------------------
1932 -- Analyze_Formal_Ordinary_Fixed_Point_Type --
1933 ----------------------------------------------
1935 procedure Analyze_Formal_Ordinary_Fixed_Point_Type
1939 Loc : constant Source_Ptr := Sloc (Def);
1940 Base : constant Entity_Id :=
1942 (E_Ordinary_Fixed_Point_Type, Current_Scope, Sloc (Def), 'G');
1944 -- The semantic attributes are set for completeness only, their values
1945 -- will never be used, since all properties of the type are non-static.
1948 Set_Ekind (T, E_Ordinary_Fixed_Point_Subtype);
1949 Set_Etype (T, Base);
1950 Set_Size_Info (T, Standard_Integer);
1951 Set_RM_Size (T, RM_Size (Standard_Integer));
1952 Set_Small_Value (T, Ureal_1);
1953 Set_Delta_Value (T, Ureal_1);
1954 Set_Scalar_Range (T,
1956 Low_Bound => Make_Real_Literal (Loc, Ureal_1),
1957 High_Bound => Make_Real_Literal (Loc, Ureal_1)));
1958 Set_Is_Constrained (T);
1960 Set_Is_Generic_Type (Base);
1961 Set_Etype (Base, Base);
1962 Set_Size_Info (Base, Standard_Integer);
1963 Set_RM_Size (Base, RM_Size (Standard_Integer));
1964 Set_Small_Value (Base, Ureal_1);
1965 Set_Delta_Value (Base, Ureal_1);
1966 Set_Scalar_Range (Base, Scalar_Range (T));
1967 Set_Parent (Base, Parent (Def));
1969 Check_Restriction (No_Fixed_Point, Def);
1970 end Analyze_Formal_Ordinary_Fixed_Point_Type;
1972 ----------------------------------------
1973 -- Analyze_Formal_Package_Declaration --
1974 ----------------------------------------
1976 procedure Analyze_Formal_Package_Declaration (N : Node_Id) is
1977 Loc : constant Source_Ptr := Sloc (N);
1978 Pack_Id : constant Entity_Id := Defining_Identifier (N);
1980 Gen_Id : constant Node_Id := Name (N);
1982 Gen_Unit : Entity_Id;
1984 Parent_Installed : Boolean := False;
1986 Parent_Instance : Entity_Id;
1987 Renaming_In_Par : Entity_Id;
1988 No_Associations : Boolean := False;
1990 function Build_Local_Package return Node_Id;
1991 -- The formal package is rewritten so that its parameters are replaced
1992 -- with corresponding declarations. For parameters with bona fide
1993 -- associations these declarations are created by Analyze_Associations
1994 -- as for a regular instantiation. For boxed parameters, we preserve
1995 -- the formal declarations and analyze them, in order to introduce
1996 -- entities of the right kind in the environment of the formal.
1998 -------------------------
1999 -- Build_Local_Package --
2000 -------------------------
2002 function Build_Local_Package return Node_Id is
2004 Pack_Decl : Node_Id;
2007 -- Within the formal, the name of the generic package is a renaming
2008 -- of the formal (as for a regular instantiation).
2011 Make_Package_Declaration (Loc,
2014 (Specification (Original_Node (Gen_Decl)),
2015 Empty, Instantiating => True));
2017 Renaming := Make_Package_Renaming_Declaration (Loc,
2018 Defining_Unit_Name =>
2019 Make_Defining_Identifier (Loc, Chars (Gen_Unit)),
2020 Name => New_Occurrence_Of (Formal, Loc));
2022 if Nkind (Gen_Id) = N_Identifier
2023 and then Chars (Gen_Id) = Chars (Pack_Id)
2026 ("& is hidden within declaration of instance", Gen_Id, Gen_Unit);
2029 -- If the formal is declared with a box, or with an others choice,
2030 -- create corresponding declarations for all entities in the formal
2031 -- part, so that names with the proper types are available in the
2032 -- specification of the formal package.
2034 -- On the other hand, if there are no associations, then all the
2035 -- formals must have defaults, and this will be checked by the
2036 -- call to Analyze_Associations.
2039 or else Nkind (First (Generic_Associations (N))) = N_Others_Choice
2042 Formal_Decl : Node_Id;
2045 -- TBA : for a formal package, need to recurse ???
2050 (Generic_Formal_Declarations (Original_Node (Gen_Decl)));
2051 while Present (Formal_Decl) loop
2053 (Decls, Copy_Generic_Node (Formal_Decl, Empty, True));
2058 -- If generic associations are present, use Analyze_Associations to
2059 -- create the proper renaming declarations.
2063 Act_Tree : constant Node_Id :=
2065 (Original_Node (Gen_Decl), Empty,
2066 Instantiating => True);
2069 Generic_Renamings.Set_Last (0);
2070 Generic_Renamings_HTable.Reset;
2071 Instantiation_Node := N;
2074 Analyze_Associations
2076 Generic_Formal_Declarations (Act_Tree),
2077 Generic_Formal_Declarations (Gen_Decl));
2081 Append (Renaming, To => Decls);
2083 -- Add generated declarations ahead of local declarations in
2086 if No (Visible_Declarations (Specification (Pack_Decl))) then
2087 Set_Visible_Declarations (Specification (Pack_Decl), Decls);
2090 (First (Visible_Declarations (Specification (Pack_Decl))),
2095 end Build_Local_Package;
2097 -- Start of processing for Analyze_Formal_Package
2100 Text_IO_Kludge (Gen_Id);
2103 Check_Generic_Child_Unit (Gen_Id, Parent_Installed);
2104 Gen_Unit := Entity (Gen_Id);
2106 -- Check for a formal package that is a package renaming
2108 if Present (Renamed_Object (Gen_Unit)) then
2110 -- Indicate that unit is used, before replacing it with renamed
2111 -- entity for use below.
2113 if In_Extended_Main_Source_Unit (N) then
2114 Set_Is_Instantiated (Gen_Unit);
2115 Generate_Reference (Gen_Unit, N);
2118 Gen_Unit := Renamed_Object (Gen_Unit);
2121 if Ekind (Gen_Unit) /= E_Generic_Package then
2122 Error_Msg_N ("expect generic package name", Gen_Id);
2126 elsif Gen_Unit = Current_Scope then
2128 ("generic package cannot be used as a formal package of itself",
2133 elsif In_Open_Scopes (Gen_Unit) then
2134 if Is_Compilation_Unit (Gen_Unit)
2135 and then Is_Child_Unit (Current_Scope)
2137 -- Special-case the error when the formal is a parent, and
2138 -- continue analysis to minimize cascaded errors.
2141 ("generic parent cannot be used as formal package "
2142 & "of a child unit",
2147 ("generic package cannot be used as a formal package "
2156 or else No (Generic_Associations (N))
2157 or else Nkind (First (Generic_Associations (N))) = N_Others_Choice
2159 No_Associations := True;
2162 -- If there are no generic associations, the generic parameters appear
2163 -- as local entities and are instantiated like them. We copy the generic
2164 -- package declaration as if it were an instantiation, and analyze it
2165 -- like a regular package, except that we treat the formals as
2166 -- additional visible components.
2168 Gen_Decl := Unit_Declaration_Node (Gen_Unit);
2170 if In_Extended_Main_Source_Unit (N) then
2171 Set_Is_Instantiated (Gen_Unit);
2172 Generate_Reference (Gen_Unit, N);
2175 Formal := New_Copy (Pack_Id);
2176 Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment);
2179 -- Make local generic without formals. The formals will be replaced
2180 -- with internal declarations.
2182 New_N := Build_Local_Package;
2184 -- If there are errors in the parameter list, Analyze_Associations
2185 -- raises Instantiation_Error. Patch the declaration to prevent
2186 -- further exception propagation.
2189 when Instantiation_Error =>
2191 Enter_Name (Formal);
2192 Set_Ekind (Formal, E_Variable);
2193 Set_Etype (Formal, Any_Type);
2195 if Parent_Installed then
2203 Set_Defining_Unit_Name (Specification (New_N), Formal);
2204 Set_Generic_Parent (Specification (N), Gen_Unit);
2205 Set_Instance_Env (Gen_Unit, Formal);
2206 Set_Is_Generic_Instance (Formal);
2208 Enter_Name (Formal);
2209 Set_Ekind (Formal, E_Package);
2210 Set_Etype (Formal, Standard_Void_Type);
2211 Set_Inner_Instances (Formal, New_Elmt_List);
2212 Push_Scope (Formal);
2214 if Is_Child_Unit (Gen_Unit)
2215 and then Parent_Installed
2217 -- Similarly, we have to make the name of the formal visible in the
2218 -- parent instance, to resolve properly fully qualified names that
2219 -- may appear in the generic unit. The parent instance has been
2220 -- placed on the scope stack ahead of the current scope.
2222 Parent_Instance := Scope_Stack.Table (Scope_Stack.Last - 1).Entity;
2225 Make_Defining_Identifier (Loc, Chars (Gen_Unit));
2226 Set_Ekind (Renaming_In_Par, E_Package);
2227 Set_Etype (Renaming_In_Par, Standard_Void_Type);
2228 Set_Scope (Renaming_In_Par, Parent_Instance);
2229 Set_Parent (Renaming_In_Par, Parent (Formal));
2230 Set_Renamed_Object (Renaming_In_Par, Formal);
2231 Append_Entity (Renaming_In_Par, Parent_Instance);
2234 Analyze (Specification (N));
2236 -- The formals for which associations are provided are not visible
2237 -- outside of the formal package. The others are still declared by a
2238 -- formal parameter declaration.
2240 if not No_Associations then
2245 E := First_Entity (Formal);
2246 while Present (E) loop
2247 exit when Ekind (E) = E_Package
2248 and then Renamed_Entity (E) = Formal;
2250 if not Is_Generic_Formal (E) then
2259 End_Package_Scope (Formal);
2261 if Parent_Installed then
2267 -- Inside the generic unit, the formal package is a regular package, but
2268 -- no body is needed for it. Note that after instantiation, the defining
2269 -- unit name we need is in the new tree and not in the original (see
2270 -- Package_Instantiation). A generic formal package is an instance, and
2271 -- can be used as an actual for an inner instance.
2273 Set_Has_Completion (Formal, True);
2275 -- Add semantic information to the original defining identifier.
2278 Set_Ekind (Pack_Id, E_Package);
2279 Set_Etype (Pack_Id, Standard_Void_Type);
2280 Set_Scope (Pack_Id, Scope (Formal));
2281 Set_Has_Completion (Pack_Id, True);
2284 Analyze_Aspect_Specifications (N, Pack_Id, Aspect_Specifications (N));
2285 end Analyze_Formal_Package_Declaration;
2287 ---------------------------------
2288 -- Analyze_Formal_Private_Type --
2289 ---------------------------------
2291 procedure Analyze_Formal_Private_Type
2297 New_Private_Type (N, T, Def);
2299 -- Set the size to an arbitrary but legal value
2301 Set_Size_Info (T, Standard_Integer);
2302 Set_RM_Size (T, RM_Size (Standard_Integer));
2303 end Analyze_Formal_Private_Type;
2305 ----------------------------------------
2306 -- Analyze_Formal_Signed_Integer_Type --
2307 ----------------------------------------
2309 procedure Analyze_Formal_Signed_Integer_Type
2313 Base : constant Entity_Id :=
2315 (E_Signed_Integer_Type, Current_Scope, Sloc (Def), 'G');
2320 Set_Ekind (T, E_Signed_Integer_Subtype);
2321 Set_Etype (T, Base);
2322 Set_Size_Info (T, Standard_Integer);
2323 Set_RM_Size (T, RM_Size (Standard_Integer));
2324 Set_Scalar_Range (T, Scalar_Range (Standard_Integer));
2325 Set_Is_Constrained (T);
2327 Set_Is_Generic_Type (Base);
2328 Set_Size_Info (Base, Standard_Integer);
2329 Set_RM_Size (Base, RM_Size (Standard_Integer));
2330 Set_Etype (Base, Base);
2331 Set_Scalar_Range (Base, Scalar_Range (Standard_Integer));
2332 Set_Parent (Base, Parent (Def));
2333 end Analyze_Formal_Signed_Integer_Type;
2335 -------------------------------------------
2336 -- Analyze_Formal_Subprogram_Declaration --
2337 -------------------------------------------
2339 procedure Analyze_Formal_Subprogram_Declaration (N : Node_Id) is
2340 Spec : constant Node_Id := Specification (N);
2341 Def : constant Node_Id := Default_Name (N);
2342 Nam : constant Entity_Id := Defining_Unit_Name (Spec);
2350 if Nkind (Nam) = N_Defining_Program_Unit_Name then
2351 Error_Msg_N ("name of formal subprogram must be a direct name", Nam);
2355 Analyze_Subprogram_Declaration (N);
2356 Set_Is_Formal_Subprogram (Nam);
2357 Set_Has_Completion (Nam);
2359 if Nkind (N) = N_Formal_Abstract_Subprogram_Declaration then
2360 Set_Is_Abstract_Subprogram (Nam);
2361 Set_Is_Dispatching_Operation (Nam);
2364 Ctrl_Type : constant Entity_Id := Find_Dispatching_Type (Nam);
2366 if No (Ctrl_Type) then
2368 ("abstract formal subprogram must have a controlling type",
2371 Check_Controlling_Formals (Ctrl_Type, Nam);
2376 -- Default name is resolved at the point of instantiation
2378 if Box_Present (N) then
2381 -- Else default is bound at the point of generic declaration
2383 elsif Present (Def) then
2384 if Nkind (Def) = N_Operator_Symbol then
2385 Find_Direct_Name (Def);
2387 elsif Nkind (Def) /= N_Attribute_Reference then
2391 -- For an attribute reference, analyze the prefix and verify
2392 -- that it has the proper profile for the subprogram.
2394 Analyze (Prefix (Def));
2395 Valid_Default_Attribute (Nam, Def);
2399 -- Default name may be overloaded, in which case the interpretation
2400 -- with the correct profile must be selected, as for a renaming.
2401 -- If the definition is an indexed component, it must denote a
2402 -- member of an entry family. If it is a selected component, it
2403 -- can be a protected operation.
2405 if Etype (Def) = Any_Type then
2408 elsif Nkind (Def) = N_Selected_Component then
2409 if not Is_Overloadable (Entity (Selector_Name (Def))) then
2410 Error_Msg_N ("expect valid subprogram name as default", Def);
2413 elsif Nkind (Def) = N_Indexed_Component then
2414 if Is_Entity_Name (Prefix (Def)) then
2415 if Ekind (Entity (Prefix (Def))) /= E_Entry_Family then
2416 Error_Msg_N ("expect valid subprogram name as default", Def);
2419 elsif Nkind (Prefix (Def)) = N_Selected_Component then
2420 if Ekind (Entity (Selector_Name (Prefix (Def)))) /=
2423 Error_Msg_N ("expect valid subprogram name as default", Def);
2427 Error_Msg_N ("expect valid subprogram name as default", Def);
2431 elsif Nkind (Def) = N_Character_Literal then
2433 -- Needs some type checks: subprogram should be parameterless???
2435 Resolve (Def, (Etype (Nam)));
2437 elsif not Is_Entity_Name (Def)
2438 or else not Is_Overloadable (Entity (Def))
2440 Error_Msg_N ("expect valid subprogram name as default", Def);
2443 elsif not Is_Overloaded (Def) then
2444 Subp := Entity (Def);
2447 Error_Msg_N ("premature usage of formal subprogram", Def);
2449 elsif not Entity_Matches_Spec (Subp, Nam) then
2450 Error_Msg_N ("no visible entity matches specification", Def);
2453 -- More than one interpretation, so disambiguate as for a renaming
2458 I1 : Interp_Index := 0;
2464 Get_First_Interp (Def, I, It);
2465 while Present (It.Nam) loop
2466 if Entity_Matches_Spec (It.Nam, Nam) then
2467 if Subp /= Any_Id then
2468 It1 := Disambiguate (Def, I1, I, Etype (Subp));
2470 if It1 = No_Interp then
2471 Error_Msg_N ("ambiguous default subprogram", Def);
2484 Get_Next_Interp (I, It);
2488 if Subp /= Any_Id then
2489 Set_Entity (Def, Subp);
2492 Error_Msg_N ("premature usage of formal subprogram", Def);
2494 elsif Ekind (Subp) /= E_Operator then
2495 Check_Mode_Conformant (Subp, Nam);
2499 Error_Msg_N ("no visible subprogram matches specification", N);
2505 Analyze_Aspect_Specifications (N, Nam, Aspect_Specifications (N));
2506 end Analyze_Formal_Subprogram_Declaration;
2508 -------------------------------------
2509 -- Analyze_Formal_Type_Declaration --
2510 -------------------------------------
2512 procedure Analyze_Formal_Type_Declaration (N : Node_Id) is
2513 Def : constant Node_Id := Formal_Type_Definition (N);
2517 T := Defining_Identifier (N);
2519 if Present (Discriminant_Specifications (N))
2520 and then Nkind (Def) /= N_Formal_Private_Type_Definition
2523 ("discriminants not allowed for this formal type", T);
2526 -- Enter the new name, and branch to specific routine
2529 when N_Formal_Private_Type_Definition =>
2530 Analyze_Formal_Private_Type (N, T, Def);
2532 when N_Formal_Derived_Type_Definition =>
2533 Analyze_Formal_Derived_Type (N, T, Def);
2535 when N_Formal_Discrete_Type_Definition =>
2536 Analyze_Formal_Discrete_Type (T, Def);
2538 when N_Formal_Signed_Integer_Type_Definition =>
2539 Analyze_Formal_Signed_Integer_Type (T, Def);
2541 when N_Formal_Modular_Type_Definition =>
2542 Analyze_Formal_Modular_Type (T, Def);
2544 when N_Formal_Floating_Point_Definition =>
2545 Analyze_Formal_Floating_Type (T, Def);
2547 when N_Formal_Ordinary_Fixed_Point_Definition =>
2548 Analyze_Formal_Ordinary_Fixed_Point_Type (T, Def);
2550 when N_Formal_Decimal_Fixed_Point_Definition =>
2551 Analyze_Formal_Decimal_Fixed_Point_Type (T, Def);
2553 when N_Array_Type_Definition =>
2554 Analyze_Formal_Array_Type (T, Def);
2556 when N_Access_To_Object_Definition |
2557 N_Access_Function_Definition |
2558 N_Access_Procedure_Definition =>
2559 Analyze_Generic_Access_Type (T, Def);
2561 -- Ada 2005: a interface declaration is encoded as an abstract
2562 -- record declaration or a abstract type derivation.
2564 when N_Record_Definition =>
2565 Analyze_Formal_Interface_Type (N, T, Def);
2567 when N_Derived_Type_Definition =>
2568 Analyze_Formal_Derived_Interface_Type (N, T, Def);
2574 raise Program_Error;
2578 Set_Is_Generic_Type (T);
2579 Analyze_Aspect_Specifications (N, T, Aspect_Specifications (N));
2580 end Analyze_Formal_Type_Declaration;
2582 ------------------------------------
2583 -- Analyze_Function_Instantiation --
2584 ------------------------------------
2586 procedure Analyze_Function_Instantiation (N : Node_Id) is
2588 Analyze_Subprogram_Instantiation (N, E_Function);
2589 end Analyze_Function_Instantiation;
2591 ---------------------------------
2592 -- Analyze_Generic_Access_Type --
2593 ---------------------------------
2595 procedure Analyze_Generic_Access_Type (T : Entity_Id; Def : Node_Id) is
2599 if Nkind (Def) = N_Access_To_Object_Definition then
2600 Access_Type_Declaration (T, Def);
2602 if Is_Incomplete_Or_Private_Type (Designated_Type (T))
2603 and then No (Full_View (Designated_Type (T)))
2604 and then not Is_Generic_Type (Designated_Type (T))
2606 Error_Msg_N ("premature usage of incomplete type", Def);
2608 elsif not Is_Entity_Name (Subtype_Indication (Def)) then
2610 ("only a subtype mark is allowed in a formal", Def);
2614 Access_Subprogram_Declaration (T, Def);
2616 end Analyze_Generic_Access_Type;
2618 ---------------------------------
2619 -- Analyze_Generic_Formal_Part --
2620 ---------------------------------
2622 procedure Analyze_Generic_Formal_Part (N : Node_Id) is
2623 Gen_Parm_Decl : Node_Id;
2626 -- The generic formals are processed in the scope of the generic unit,
2627 -- where they are immediately visible. The scope is installed by the
2630 Gen_Parm_Decl := First (Generic_Formal_Declarations (N));
2632 while Present (Gen_Parm_Decl) loop
2633 Analyze (Gen_Parm_Decl);
2634 Next (Gen_Parm_Decl);
2637 Generate_Reference_To_Generic_Formals (Current_Scope);
2638 end Analyze_Generic_Formal_Part;
2640 ------------------------------------------
2641 -- Analyze_Generic_Package_Declaration --
2642 ------------------------------------------
2644 procedure Analyze_Generic_Package_Declaration (N : Node_Id) is
2645 Loc : constant Source_Ptr := Sloc (N);
2648 Save_Parent : Node_Id;
2650 Decls : constant List_Id :=
2651 Visible_Declarations (Specification (N));
2655 -- We introduce a renaming of the enclosing package, to have a usable
2656 -- entity as the prefix of an expanded name for a local entity of the
2657 -- form Par.P.Q, where P is the generic package. This is because a local
2658 -- entity named P may hide it, so that the usual visibility rules in
2659 -- the instance will not resolve properly.
2662 Make_Package_Renaming_Declaration (Loc,
2663 Defining_Unit_Name =>
2664 Make_Defining_Identifier (Loc,
2665 Chars => New_External_Name (Chars (Defining_Entity (N)), "GH")),
2666 Name => Make_Identifier (Loc, Chars (Defining_Entity (N))));
2668 if Present (Decls) then
2669 Decl := First (Decls);
2670 while Present (Decl)
2671 and then Nkind (Decl) = N_Pragma
2676 if Present (Decl) then
2677 Insert_Before (Decl, Renaming);
2679 Append (Renaming, Visible_Declarations (Specification (N)));
2683 Set_Visible_Declarations (Specification (N), New_List (Renaming));
2686 -- Create copy of generic unit, and save for instantiation. If the unit
2687 -- is a child unit, do not copy the specifications for the parent, which
2688 -- are not part of the generic tree.
2690 Save_Parent := Parent_Spec (N);
2691 Set_Parent_Spec (N, Empty);
2693 New_N := Copy_Generic_Node (N, Empty, Instantiating => False);
2694 Set_Parent_Spec (New_N, Save_Parent);
2696 Id := Defining_Entity (N);
2697 Generate_Definition (Id);
2699 -- Expansion is not applied to generic units
2704 Set_Ekind (Id, E_Generic_Package);
2705 Set_Etype (Id, Standard_Void_Type);
2707 Enter_Generic_Scope (Id);
2708 Set_Inner_Instances (Id, New_Elmt_List);
2710 Set_Categorization_From_Pragmas (N);
2711 Set_Is_Pure (Id, Is_Pure (Current_Scope));
2713 -- Link the declaration of the generic homonym in the generic copy to
2714 -- the package it renames, so that it is always resolved properly.
2716 Set_Generic_Homonym (Id, Defining_Unit_Name (Renaming));
2717 Set_Entity (Associated_Node (Name (Renaming)), Id);
2719 -- For a library unit, we have reconstructed the entity for the unit,
2720 -- and must reset it in the library tables.
2722 if Nkind (Parent (N)) = N_Compilation_Unit then
2723 Set_Cunit_Entity (Current_Sem_Unit, Id);
2726 Analyze_Generic_Formal_Part (N);
2728 -- After processing the generic formals, analysis proceeds as for a
2729 -- non-generic package.
2731 Analyze (Specification (N));
2733 Validate_Categorization_Dependency (N, Id);
2737 End_Package_Scope (Id);
2738 Exit_Generic_Scope (Id);
2740 if Nkind (Parent (N)) /= N_Compilation_Unit then
2741 Move_Freeze_Nodes (Id, N, Visible_Declarations (Specification (N)));
2742 Move_Freeze_Nodes (Id, N, Private_Declarations (Specification (N)));
2743 Move_Freeze_Nodes (Id, N, Generic_Formal_Declarations (N));
2746 Set_Body_Required (Parent (N), Unit_Requires_Body (Id));
2747 Validate_RT_RAT_Component (N);
2749 -- If this is a spec without a body, check that generic parameters
2752 if not Body_Required (Parent (N)) then
2753 Check_References (Id);
2757 Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N));
2758 end Analyze_Generic_Package_Declaration;
2760 --------------------------------------------
2761 -- Analyze_Generic_Subprogram_Declaration --
2762 --------------------------------------------
2764 procedure Analyze_Generic_Subprogram_Declaration (N : Node_Id) is
2769 Result_Type : Entity_Id;
2770 Save_Parent : Node_Id;
2774 -- Create copy of generic unit, and save for instantiation. If the unit
2775 -- is a child unit, do not copy the specifications for the parent, which
2776 -- are not part of the generic tree.
2778 Save_Parent := Parent_Spec (N);
2779 Set_Parent_Spec (N, Empty);
2781 New_N := Copy_Generic_Node (N, Empty, Instantiating => False);
2782 Set_Parent_Spec (New_N, Save_Parent);
2785 Spec := Specification (N);
2786 Id := Defining_Entity (Spec);
2787 Generate_Definition (Id);
2789 if Nkind (Id) = N_Defining_Operator_Symbol then
2791 ("operator symbol not allowed for generic subprogram", Id);
2798 Set_Scope_Depth_Value (Id, Scope_Depth (Current_Scope) + 1);
2800 Enter_Generic_Scope (Id);
2801 Set_Inner_Instances (Id, New_Elmt_List);
2802 Set_Is_Pure (Id, Is_Pure (Current_Scope));
2804 Analyze_Generic_Formal_Part (N);
2806 Formals := Parameter_Specifications (Spec);
2808 if Present (Formals) then
2809 Process_Formals (Formals, Spec);
2812 if Nkind (Spec) = N_Function_Specification then
2813 Set_Ekind (Id, E_Generic_Function);
2815 if Nkind (Result_Definition (Spec)) = N_Access_Definition then
2816 Result_Type := Access_Definition (Spec, Result_Definition (Spec));
2817 Set_Etype (Id, Result_Type);
2819 -- Check restriction imposed by AI05-073: a generic function
2820 -- cannot return an abstract type or an access to such.
2822 -- This is a binding interpreration should it apply to earlier
2823 -- versions of Ada as well as Ada 2012???
2825 if Is_Abstract_Type (Designated_Type (Result_Type))
2826 and then Ada_Version >= Ada_2012
2828 Error_Msg_N ("generic function cannot have an access result"
2829 & " that designates an abstract type", Spec);
2833 Find_Type (Result_Definition (Spec));
2834 Typ := Entity (Result_Definition (Spec));
2836 if Is_Abstract_Type (Typ)
2837 and then Ada_Version >= Ada_2012
2840 ("generic function cannot have abstract result type", Spec);
2843 -- If a null exclusion is imposed on the result type, then create
2844 -- a null-excluding itype (an access subtype) and use it as the
2845 -- function's Etype.
2847 if Is_Access_Type (Typ)
2848 and then Null_Exclusion_Present (Spec)
2851 Create_Null_Excluding_Itype
2853 Related_Nod => Spec,
2854 Scope_Id => Defining_Unit_Name (Spec)));
2856 Set_Etype (Id, Typ);
2861 Set_Ekind (Id, E_Generic_Procedure);
2862 Set_Etype (Id, Standard_Void_Type);
2865 -- For a library unit, we have reconstructed the entity for the unit,
2866 -- and must reset it in the library tables. We also make sure that
2867 -- Body_Required is set properly in the original compilation unit node.
2869 if Nkind (Parent (N)) = N_Compilation_Unit then
2870 Set_Cunit_Entity (Current_Sem_Unit, Id);
2871 Set_Body_Required (Parent (N), Unit_Requires_Body (Id));
2874 Set_Categorization_From_Pragmas (N);
2875 Validate_Categorization_Dependency (N, Id);
2877 Save_Global_References (Original_Node (N));
2881 Exit_Generic_Scope (Id);
2882 Generate_Reference_To_Formals (Id);
2884 List_Inherited_Pre_Post_Aspects (Id);
2885 Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N));
2886 end Analyze_Generic_Subprogram_Declaration;
2888 -----------------------------------
2889 -- Analyze_Package_Instantiation --
2890 -----------------------------------
2892 procedure Analyze_Package_Instantiation (N : Node_Id) is
2893 Loc : constant Source_Ptr := Sloc (N);
2894 Gen_Id : constant Node_Id := Name (N);
2897 Act_Decl_Name : Node_Id;
2898 Act_Decl_Id : Entity_Id;
2903 Gen_Unit : Entity_Id;
2905 Is_Actual_Pack : constant Boolean :=
2906 Is_Internal (Defining_Entity (N));
2908 Env_Installed : Boolean := False;
2909 Parent_Installed : Boolean := False;
2910 Renaming_List : List_Id;
2911 Unit_Renaming : Node_Id;
2912 Needs_Body : Boolean;
2913 Inline_Now : Boolean := False;
2915 procedure Delay_Descriptors (E : Entity_Id);
2916 -- Delay generation of subprogram descriptors for given entity
2918 function Might_Inline_Subp return Boolean;
2919 -- If inlining is active and the generic contains inlined subprograms,
2920 -- we instantiate the body. This may cause superfluous instantiations,
2921 -- but it is simpler than detecting the need for the body at the point
2922 -- of inlining, when the context of the instance is not available.
2924 -----------------------
2925 -- Delay_Descriptors --
2926 -----------------------
2928 procedure Delay_Descriptors (E : Entity_Id) is
2930 if not Delay_Subprogram_Descriptors (E) then
2931 Set_Delay_Subprogram_Descriptors (E);
2932 Pending_Descriptor.Append (E);
2934 end Delay_Descriptors;
2936 -----------------------
2937 -- Might_Inline_Subp --
2938 -----------------------
2940 function Might_Inline_Subp return Boolean is
2944 if not Inline_Processing_Required then
2948 E := First_Entity (Gen_Unit);
2949 while Present (E) loop
2950 if Is_Subprogram (E)
2951 and then Is_Inlined (E)
2961 end Might_Inline_Subp;
2963 -- Start of processing for Analyze_Package_Instantiation
2966 -- Very first thing: apply the special kludge for Text_IO processing
2967 -- in case we are instantiating one of the children of [Wide_]Text_IO.
2969 Text_IO_Kludge (Name (N));
2971 -- Make node global for error reporting
2973 Instantiation_Node := N;
2975 -- Case of instantiation of a generic package
2977 if Nkind (N) = N_Package_Instantiation then
2978 Act_Decl_Id := New_Copy (Defining_Entity (N));
2979 Set_Comes_From_Source (Act_Decl_Id, True);
2981 if Nkind (Defining_Unit_Name (N)) = N_Defining_Program_Unit_Name then
2983 Make_Defining_Program_Unit_Name (Loc,
2984 Name => New_Copy_Tree (Name (Defining_Unit_Name (N))),
2985 Defining_Identifier => Act_Decl_Id);
2987 Act_Decl_Name := Act_Decl_Id;
2990 -- Case of instantiation of a formal package
2993 Act_Decl_Id := Defining_Identifier (N);
2994 Act_Decl_Name := Act_Decl_Id;
2997 Generate_Definition (Act_Decl_Id);
2998 Preanalyze_Actuals (N);
3001 Env_Installed := True;
3003 -- Reset renaming map for formal types. The mapping is established
3004 -- when analyzing the generic associations, but some mappings are
3005 -- inherited from formal packages of parent units, and these are
3006 -- constructed when the parents are installed.
3008 Generic_Renamings.Set_Last (0);
3009 Generic_Renamings_HTable.Reset;
3011 Check_Generic_Child_Unit (Gen_Id, Parent_Installed);
3012 Gen_Unit := Entity (Gen_Id);
3014 -- Verify that it is the name of a generic package
3016 -- A visibility glitch: if the instance is a child unit and the generic
3017 -- is the generic unit of a parent instance (i.e. both the parent and
3018 -- the child units are instances of the same package) the name now
3019 -- denotes the renaming within the parent, not the intended generic
3020 -- unit. See if there is a homonym that is the desired generic. The
3021 -- renaming declaration must be visible inside the instance of the
3022 -- child, but not when analyzing the name in the instantiation itself.
3024 if Ekind (Gen_Unit) = E_Package
3025 and then Present (Renamed_Entity (Gen_Unit))
3026 and then In_Open_Scopes (Renamed_Entity (Gen_Unit))
3027 and then Is_Generic_Instance (Renamed_Entity (Gen_Unit))
3028 and then Present (Homonym (Gen_Unit))
3030 Gen_Unit := Homonym (Gen_Unit);
3033 if Etype (Gen_Unit) = Any_Type then
3037 elsif Ekind (Gen_Unit) /= E_Generic_Package then
3039 -- Ada 2005 (AI-50217): Cannot use instance in limited with_clause
3041 if From_With_Type (Gen_Unit) then
3043 ("cannot instantiate a limited withed package", Gen_Id);
3046 ("expect name of generic package in instantiation", Gen_Id);
3053 if In_Extended_Main_Source_Unit (N) then
3054 Set_Is_Instantiated (Gen_Unit);
3055 Generate_Reference (Gen_Unit, N);
3057 if Present (Renamed_Object (Gen_Unit)) then
3058 Set_Is_Instantiated (Renamed_Object (Gen_Unit));
3059 Generate_Reference (Renamed_Object (Gen_Unit), N);
3063 if Nkind (Gen_Id) = N_Identifier
3064 and then Chars (Gen_Unit) = Chars (Defining_Entity (N))
3067 ("& is hidden within declaration of instance", Gen_Id, Gen_Unit);
3069 elsif Nkind (Gen_Id) = N_Expanded_Name
3070 and then Is_Child_Unit (Gen_Unit)
3071 and then Nkind (Prefix (Gen_Id)) = N_Identifier
3072 and then Chars (Act_Decl_Id) = Chars (Prefix (Gen_Id))
3075 ("& is hidden within declaration of instance ", Prefix (Gen_Id));
3078 Set_Entity (Gen_Id, Gen_Unit);
3080 -- If generic is a renaming, get original generic unit
3082 if Present (Renamed_Object (Gen_Unit))
3083 and then Ekind (Renamed_Object (Gen_Unit)) = E_Generic_Package
3085 Gen_Unit := Renamed_Object (Gen_Unit);
3088 -- Verify that there are no circular instantiations
3090 if In_Open_Scopes (Gen_Unit) then
3091 Error_Msg_NE ("instantiation of & within itself", N, Gen_Unit);
3095 elsif Contains_Instance_Of (Gen_Unit, Current_Scope, Gen_Id) then
3096 Error_Msg_Node_2 := Current_Scope;
3098 ("circular Instantiation: & instantiated in &!", N, Gen_Unit);
3099 Circularity_Detected := True;
3104 Gen_Decl := Unit_Declaration_Node (Gen_Unit);
3106 -- Initialize renamings map, for error checking, and the list that
3107 -- holds private entities whose views have changed between generic
3108 -- definition and instantiation. If this is the instance created to
3109 -- validate an actual package, the instantiation environment is that
3110 -- of the enclosing instance.
3112 Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment);
3114 -- Copy original generic tree, to produce text for instantiation
3118 (Original_Node (Gen_Decl), Empty, Instantiating => True);
3120 Act_Spec := Specification (Act_Tree);
3122 -- If this is the instance created to validate an actual package,
3123 -- only the formals matter, do not examine the package spec itself.
3125 if Is_Actual_Pack then
3126 Set_Visible_Declarations (Act_Spec, New_List);
3127 Set_Private_Declarations (Act_Spec, New_List);
3131 Analyze_Associations
3133 Generic_Formal_Declarations (Act_Tree),
3134 Generic_Formal_Declarations (Gen_Decl));
3136 Set_Instance_Env (Gen_Unit, Act_Decl_Id);
3137 Set_Defining_Unit_Name (Act_Spec, Act_Decl_Name);
3138 Set_Is_Generic_Instance (Act_Decl_Id);
3140 Set_Generic_Parent (Act_Spec, Gen_Unit);
3142 -- References to the generic in its own declaration or its body are
3143 -- references to the instance. Add a renaming declaration for the
3144 -- generic unit itself. This declaration, as well as the renaming
3145 -- declarations for the generic formals, must remain private to the
3146 -- unit: the formals, because this is the language semantics, and
3147 -- the unit because its use is an artifact of the implementation.
3150 Make_Package_Renaming_Declaration (Loc,
3151 Defining_Unit_Name =>
3152 Make_Defining_Identifier (Loc, Chars (Gen_Unit)),
3153 Name => New_Reference_To (Act_Decl_Id, Loc));
3155 Append (Unit_Renaming, Renaming_List);
3157 -- The renaming declarations are the first local declarations of
3160 if Is_Non_Empty_List (Visible_Declarations (Act_Spec)) then
3162 (First (Visible_Declarations (Act_Spec)), Renaming_List);
3164 Set_Visible_Declarations (Act_Spec, Renaming_List);
3168 Make_Package_Declaration (Loc,
3169 Specification => Act_Spec);
3171 -- Save the instantiation node, for subsequent instantiation of the
3172 -- body, if there is one and we are generating code for the current
3173 -- unit. Mark the unit as having a body, to avoid a premature error
3176 -- We instantiate the body if we are generating code, if we are
3177 -- generating cross-reference information, or if we are building
3178 -- trees for ASIS use.
3181 Enclosing_Body_Present : Boolean := False;
3182 -- If the generic unit is not a compilation unit, then a body may
3183 -- be present in its parent even if none is required. We create a
3184 -- tentative pending instantiation for the body, which will be
3185 -- discarded if none is actually present.
3190 if Scope (Gen_Unit) /= Standard_Standard
3191 and then not Is_Child_Unit (Gen_Unit)
3193 Scop := Scope (Gen_Unit);
3195 while Present (Scop)
3196 and then Scop /= Standard_Standard
3198 if Unit_Requires_Body (Scop) then
3199 Enclosing_Body_Present := True;
3202 elsif In_Open_Scopes (Scop)
3203 and then In_Package_Body (Scop)
3205 Enclosing_Body_Present := True;
3209 exit when Is_Compilation_Unit (Scop);
3210 Scop := Scope (Scop);
3214 -- If front-end inlining is enabled, and this is a unit for which
3215 -- code will be generated, we instantiate the body at once.
3217 -- This is done if the instance is not the main unit, and if the
3218 -- generic is not a child unit of another generic, to avoid scope
3219 -- problems and the reinstallation of parent instances.
3222 and then (not Is_Child_Unit (Gen_Unit)
3223 or else not Is_Generic_Unit (Scope (Gen_Unit)))
3224 and then Might_Inline_Subp
3225 and then not Is_Actual_Pack
3227 if Front_End_Inlining
3228 and then (Is_In_Main_Unit (N)
3229 or else In_Main_Context (Current_Scope))
3230 and then Nkind (Parent (N)) /= N_Compilation_Unit
3234 -- In configurable_run_time mode we force the inlining of
3235 -- predefined subprograms marked Inline_Always, to minimize
3236 -- the use of the run-time library.
3238 elsif Is_Predefined_File_Name
3239 (Unit_File_Name (Get_Source_Unit (Gen_Decl)))
3240 and then Configurable_Run_Time_Mode
3241 and then Nkind (Parent (N)) /= N_Compilation_Unit
3246 -- If the current scope is itself an instance within a child
3247 -- unit, there will be duplications in the scope stack, and the
3248 -- unstacking mechanism in Inline_Instance_Body will fail.
3249 -- This loses some rare cases of optimization, and might be
3250 -- improved some day, if we can find a proper abstraction for
3251 -- "the complete compilation context" that can be saved and
3254 if Is_Generic_Instance (Current_Scope) then
3256 Curr_Unit : constant Entity_Id :=
3257 Cunit_Entity (Current_Sem_Unit);
3259 if Curr_Unit /= Current_Scope
3260 and then Is_Child_Unit (Curr_Unit)
3262 Inline_Now := False;
3269 (Unit_Requires_Body (Gen_Unit)
3270 or else Enclosing_Body_Present
3271 or else Present (Corresponding_Body (Gen_Decl)))
3272 and then (Is_In_Main_Unit (N)
3273 or else Might_Inline_Subp)
3274 and then not Is_Actual_Pack
3275 and then not Inline_Now
3276 and then (Operating_Mode = Generate_Code
3277 or else (Operating_Mode = Check_Semantics
3278 and then ASIS_Mode));
3280 -- If front_end_inlining is enabled, do not instantiate body if
3281 -- within a generic context.
3283 if (Front_End_Inlining
3284 and then not Expander_Active)
3285 or else Is_Generic_Unit (Cunit_Entity (Main_Unit))
3287 Needs_Body := False;
3290 -- If the current context is generic, and the package being
3291 -- instantiated is declared within a formal package, there is no
3292 -- body to instantiate until the enclosing generic is instantiated
3293 -- and there is an actual for the formal package. If the formal
3294 -- package has parameters, we build a regular package instance for
3295 -- it, that precedes the original formal package declaration.
3297 if In_Open_Scopes (Scope (Scope (Gen_Unit))) then
3299 Decl : constant Node_Id :=
3301 (Unit_Declaration_Node (Scope (Gen_Unit)));
3303 if Nkind (Decl) = N_Formal_Package_Declaration
3304 or else (Nkind (Decl) = N_Package_Declaration
3305 and then Is_List_Member (Decl)
3306 and then Present (Next (Decl))
3308 Nkind (Next (Decl)) =
3309 N_Formal_Package_Declaration)
3311 Needs_Body := False;
3317 -- If we are generating the calling stubs from the instantiation of
3318 -- a generic RCI package, we will not use the body of the generic
3321 if Distribution_Stub_Mode = Generate_Caller_Stub_Body
3322 and then Is_Compilation_Unit (Defining_Entity (N))
3324 Needs_Body := False;
3329 -- Here is a defence against a ludicrous number of instantiations
3330 -- caused by a circular set of instantiation attempts.
3332 if Pending_Instantiations.Last >
3333 Hostparm.Max_Instantiations
3335 Error_Msg_N ("too many instantiations", N);
3336 raise Unrecoverable_Error;
3339 -- Indicate that the enclosing scopes contain an instantiation,
3340 -- and that cleanup actions should be delayed until after the
3341 -- instance body is expanded.
3343 Check_Forward_Instantiation (Gen_Decl);
3344 if Nkind (N) = N_Package_Instantiation then
3346 Enclosing_Master : Entity_Id;
3349 -- Loop to search enclosing masters
3351 Enclosing_Master := Current_Scope;
3352 Scope_Loop : while Enclosing_Master /= Standard_Standard loop
3353 if Ekind (Enclosing_Master) = E_Package then
3354 if Is_Compilation_Unit (Enclosing_Master) then
3355 if In_Package_Body (Enclosing_Master) then
3357 (Body_Entity (Enclosing_Master));
3366 Enclosing_Master := Scope (Enclosing_Master);
3369 elsif Ekind (Enclosing_Master) = E_Generic_Package then
3370 Enclosing_Master := Scope (Enclosing_Master);
3372 elsif Is_Generic_Subprogram (Enclosing_Master)
3373 or else Ekind (Enclosing_Master) = E_Void
3375 -- Cleanup actions will eventually be performed on the
3376 -- enclosing instance, if any. Enclosing scope is void
3377 -- in the formal part of a generic subprogram.
3382 if Ekind (Enclosing_Master) = E_Entry
3384 Ekind (Scope (Enclosing_Master)) = E_Protected_Type
3386 if not Expander_Active then
3390 Protected_Body_Subprogram (Enclosing_Master);
3394 Set_Delay_Cleanups (Enclosing_Master);
3396 while Ekind (Enclosing_Master) = E_Block loop
3397 Enclosing_Master := Scope (Enclosing_Master);
3400 if Is_Subprogram (Enclosing_Master) then
3401 Delay_Descriptors (Enclosing_Master);
3403 elsif Is_Task_Type (Enclosing_Master) then
3405 TBP : constant Node_Id :=
3406 Get_Task_Body_Procedure
3409 if Present (TBP) then
3410 Delay_Descriptors (TBP);
3411 Set_Delay_Cleanups (TBP);
3418 end loop Scope_Loop;
3421 -- Make entry in table
3423 Pending_Instantiations.Append
3425 Act_Decl => Act_Decl,
3426 Expander_Status => Expander_Active,
3427 Current_Sem_Unit => Current_Sem_Unit,
3428 Scope_Suppress => Scope_Suppress,
3429 Local_Suppress_Stack_Top => Local_Suppress_Stack_Top,
3430 Version => Ada_Version));
3434 Set_Categorization_From_Pragmas (Act_Decl);
3436 if Parent_Installed then
3440 Set_Instance_Spec (N, Act_Decl);
3442 -- If not a compilation unit, insert the package declaration before
3443 -- the original instantiation node.
3445 if Nkind (Parent (N)) /= N_Compilation_Unit then
3446 Mark_Rewrite_Insertion (Act_Decl);
3447 Insert_Before (N, Act_Decl);
3450 -- For an instantiation that is a compilation unit, place declaration
3451 -- on current node so context is complete for analysis (including
3452 -- nested instantiations). If this is the main unit, the declaration
3453 -- eventually replaces the instantiation node. If the instance body
3454 -- is created later, it replaces the instance node, and the
3455 -- declaration is attached to it (see
3456 -- Build_Instance_Compilation_Unit_Nodes).
3459 if Cunit_Entity (Current_Sem_Unit) = Defining_Entity (N) then
3461 -- The entity for the current unit is the newly created one,
3462 -- and all semantic information is attached to it.
3464 Set_Cunit_Entity (Current_Sem_Unit, Act_Decl_Id);
3466 -- If this is the main unit, replace the main entity as well
3468 if Current_Sem_Unit = Main_Unit then
3469 Main_Unit_Entity := Act_Decl_Id;
3473 Set_Unit (Parent (N), Act_Decl);
3474 Set_Parent_Spec (Act_Decl, Parent_Spec (N));
3475 Set_Package_Instantiation (Act_Decl_Id, N);
3477 Set_Unit (Parent (N), N);
3478 Set_Body_Required (Parent (N), False);
3480 -- We never need elaboration checks on instantiations, since by
3481 -- definition, the body instantiation is elaborated at the same
3482 -- time as the spec instantiation.
3484 Set_Suppress_Elaboration_Warnings (Act_Decl_Id);
3485 Set_Kill_Elaboration_Checks (Act_Decl_Id);
3488 Check_Elab_Instantiation (N);
3490 if ABE_Is_Certain (N) and then Needs_Body then
3491 Pending_Instantiations.Decrement_Last;
3494 Check_Hidden_Child_Unit (N, Gen_Unit, Act_Decl_Id);
3496 Set_First_Private_Entity (Defining_Unit_Name (Unit_Renaming),
3497 First_Private_Entity (Act_Decl_Id));
3499 -- If the instantiation will receive a body, the unit will be
3500 -- transformed into a package body, and receive its own elaboration
3501 -- entity. Otherwise, the nature of the unit is now a package
3504 if Nkind (Parent (N)) = N_Compilation_Unit
3505 and then not Needs_Body
3507 Rewrite (N, Act_Decl);
3510 if Present (Corresponding_Body (Gen_Decl))
3511 or else Unit_Requires_Body (Gen_Unit)
3513 Set_Has_Completion (Act_Decl_Id);
3516 Check_Formal_Packages (Act_Decl_Id);
3518 Restore_Private_Views (Act_Decl_Id);
3520 Inherit_Context (Gen_Decl, N);
3522 if Parent_Installed then
3527 Env_Installed := False;
3530 Validate_Categorization_Dependency (N, Act_Decl_Id);
3532 -- There used to be a check here to prevent instantiations in local
3533 -- contexts if the No_Local_Allocators restriction was active. This
3534 -- check was removed by a binding interpretation in AI-95-00130/07,
3535 -- but we retain the code for documentation purposes.
3537 -- if Ekind (Act_Decl_Id) /= E_Void
3538 -- and then not Is_Library_Level_Entity (Act_Decl_Id)
3540 -- Check_Restriction (No_Local_Allocators, N);
3544 Inline_Instance_Body (N, Gen_Unit, Act_Decl);
3547 -- The following is a tree patch for ASIS: ASIS needs separate nodes to
3548 -- be used as defining identifiers for a formal package and for the
3549 -- corresponding expanded package.
3551 if Nkind (N) = N_Formal_Package_Declaration then
3552 Act_Decl_Id := New_Copy (Defining_Entity (N));
3553 Set_Comes_From_Source (Act_Decl_Id, True);
3554 Set_Is_Generic_Instance (Act_Decl_Id, False);
3555 Set_Defining_Identifier (N, Act_Decl_Id);
3559 Analyze_Aspect_Specifications
3560 (N, Act_Decl_Id, Aspect_Specifications (N));
3563 when Instantiation_Error =>
3564 if Parent_Installed then
3568 if Env_Installed then
3571 end Analyze_Package_Instantiation;
3573 --------------------------
3574 -- Inline_Instance_Body --
3575 --------------------------
3577 procedure Inline_Instance_Body
3579 Gen_Unit : Entity_Id;
3583 Gen_Comp : constant Entity_Id :=
3584 Cunit_Entity (Get_Source_Unit (Gen_Unit));
3585 Curr_Comp : constant Node_Id := Cunit (Current_Sem_Unit);
3586 Curr_Scope : Entity_Id := Empty;
3587 Curr_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
3588 Removed : Boolean := False;
3589 Num_Scopes : Int := 0;
3591 Scope_Stack_Depth : constant Int :=
3592 Scope_Stack.Last - Scope_Stack.First + 1;
3594 Use_Clauses : array (1 .. Scope_Stack_Depth) of Node_Id;
3595 Instances : array (1 .. Scope_Stack_Depth) of Entity_Id;
3596 Inner_Scopes : array (1 .. Scope_Stack_Depth) of Entity_Id;
3597 Num_Inner : Int := 0;
3598 N_Instances : Int := 0;
3602 -- Case of generic unit defined in another unit. We must remove the
3603 -- complete context of the current unit to install that of the generic.
3605 if Gen_Comp /= Cunit_Entity (Current_Sem_Unit) then
3607 -- Add some comments for the following two loops ???
3610 while Present (S) and then S /= Standard_Standard loop
3612 Num_Scopes := Num_Scopes + 1;
3614 Use_Clauses (Num_Scopes) :=
3616 (Scope_Stack.Last - Num_Scopes + 1).
3618 End_Use_Clauses (Use_Clauses (Num_Scopes));
3620 exit when Scope_Stack.Last - Num_Scopes + 1 = Scope_Stack.First
3621 or else Scope_Stack.Table
3622 (Scope_Stack.Last - Num_Scopes).Entity
3626 exit when Is_Generic_Instance (S)
3627 and then (In_Package_Body (S)
3628 or else Ekind (S) = E_Procedure
3629 or else Ekind (S) = E_Function);
3633 Vis := Is_Immediately_Visible (Gen_Comp);
3635 -- Find and save all enclosing instances
3640 and then S /= Standard_Standard
3642 if Is_Generic_Instance (S) then
3643 N_Instances := N_Instances + 1;
3644 Instances (N_Instances) := S;
3646 exit when In_Package_Body (S);
3652 -- Remove context of current compilation unit, unless we are within a
3653 -- nested package instantiation, in which case the context has been
3654 -- removed previously.
3656 -- If current scope is the body of a child unit, remove context of
3657 -- spec as well. If an enclosing scope is an instance body, the
3658 -- context has already been removed, but the entities in the body
3659 -- must be made invisible as well.
3664 and then S /= Standard_Standard
3666 if Is_Generic_Instance (S)
3667 and then (In_Package_Body (S)
3668 or else Ekind (S) = E_Procedure
3669 or else Ekind (S) = E_Function)
3671 -- We still have to remove the entities of the enclosing
3672 -- instance from direct visibility.
3677 E := First_Entity (S);
3678 while Present (E) loop
3679 Set_Is_Immediately_Visible (E, False);
3688 or else (Ekind (Curr_Unit) = E_Package_Body
3689 and then S = Spec_Entity (Curr_Unit))
3690 or else (Ekind (Curr_Unit) = E_Subprogram_Body
3693 (Unit_Declaration_Node (Curr_Unit)))
3697 -- Remove entities in current scopes from visibility, so that
3698 -- instance body is compiled in a clean environment.
3700 Save_Scope_Stack (Handle_Use => False);
3702 if Is_Child_Unit (S) then
3704 -- Remove child unit from stack, as well as inner scopes.
3705 -- Removing the context of a child unit removes parent units
3708 while Current_Scope /= S loop
3709 Num_Inner := Num_Inner + 1;
3710 Inner_Scopes (Num_Inner) := Current_Scope;
3715 Remove_Context (Curr_Comp);
3719 Remove_Context (Curr_Comp);
3722 if Ekind (Curr_Unit) = E_Package_Body then
3723 Remove_Context (Library_Unit (Curr_Comp));
3729 pragma Assert (Num_Inner < Num_Scopes);
3731 Push_Scope (Standard_Standard);
3732 Scope_Stack.Table (Scope_Stack.Last).Is_Active_Stack_Base := True;
3733 Instantiate_Package_Body
3736 Act_Decl => Act_Decl,
3737 Expander_Status => Expander_Active,
3738 Current_Sem_Unit => Current_Sem_Unit,
3739 Scope_Suppress => Scope_Suppress,
3740 Local_Suppress_Stack_Top => Local_Suppress_Stack_Top,
3741 Version => Ada_Version)),
3742 Inlined_Body => True);
3748 Set_Is_Immediately_Visible (Gen_Comp, Vis);
3750 -- Reset Generic_Instance flag so that use clauses can be installed
3751 -- in the proper order. (See Use_One_Package for effect of enclosing
3752 -- instances on processing of use clauses).
3754 for J in 1 .. N_Instances loop
3755 Set_Is_Generic_Instance (Instances (J), False);
3759 Install_Context (Curr_Comp);
3761 if Present (Curr_Scope)
3762 and then Is_Child_Unit (Curr_Scope)
3764 Push_Scope (Curr_Scope);
3765 Set_Is_Immediately_Visible (Curr_Scope);
3767 -- Finally, restore inner scopes as well
3769 for J in reverse 1 .. Num_Inner loop
3770 Push_Scope (Inner_Scopes (J));
3774 Restore_Scope_Stack (Handle_Use => False);
3776 if Present (Curr_Scope)
3778 (In_Private_Part (Curr_Scope)
3779 or else In_Package_Body (Curr_Scope))
3781 -- Install private declaration of ancestor units, which are
3782 -- currently available. Restore_Scope_Stack and Install_Context
3783 -- only install the visible part of parents.
3788 Par := Scope (Curr_Scope);
3789 while (Present (Par))
3790 and then Par /= Standard_Standard
3792 Install_Private_Declarations (Par);
3799 -- Restore use clauses. For a child unit, use clauses in the parents
3800 -- are restored when installing the context, so only those in inner
3801 -- scopes (and those local to the child unit itself) need to be
3802 -- installed explicitly.
3804 if Is_Child_Unit (Curr_Unit)
3807 for J in reverse 1 .. Num_Inner + 1 loop
3808 Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause :=
3810 Install_Use_Clauses (Use_Clauses (J));
3814 for J in reverse 1 .. Num_Scopes loop
3815 Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause :=
3817 Install_Use_Clauses (Use_Clauses (J));
3821 -- Restore status of instances. If one of them is a body, make
3822 -- its local entities visible again.
3829 for J in 1 .. N_Instances loop
3830 Inst := Instances (J);
3831 Set_Is_Generic_Instance (Inst, True);
3833 if In_Package_Body (Inst)
3834 or else Ekind (S) = E_Procedure
3835 or else Ekind (S) = E_Function
3837 E := First_Entity (Instances (J));
3838 while Present (E) loop
3839 Set_Is_Immediately_Visible (E);
3846 -- If generic unit is in current unit, current context is correct
3849 Instantiate_Package_Body
3852 Act_Decl => Act_Decl,
3853 Expander_Status => Expander_Active,
3854 Current_Sem_Unit => Current_Sem_Unit,
3855 Scope_Suppress => Scope_Suppress,
3856 Local_Suppress_Stack_Top => Local_Suppress_Stack_Top,
3857 Version => Ada_Version)),
3858 Inlined_Body => True);
3860 end Inline_Instance_Body;
3862 -------------------------------------
3863 -- Analyze_Procedure_Instantiation --
3864 -------------------------------------
3866 procedure Analyze_Procedure_Instantiation (N : Node_Id) is
3868 Analyze_Subprogram_Instantiation (N, E_Procedure);
3869 end Analyze_Procedure_Instantiation;
3871 -----------------------------------
3872 -- Need_Subprogram_Instance_Body --
3873 -----------------------------------
3875 function Need_Subprogram_Instance_Body
3877 Subp : Entity_Id) return Boolean
3880 if (Is_In_Main_Unit (N)
3881 or else Is_Inlined (Subp)
3882 or else Is_Inlined (Alias (Subp)))
3883 and then (Operating_Mode = Generate_Code
3884 or else (Operating_Mode = Check_Semantics
3885 and then ASIS_Mode))
3886 and then (Expander_Active or else ASIS_Mode)
3887 and then not ABE_Is_Certain (N)
3888 and then not Is_Eliminated (Subp)
3890 Pending_Instantiations.Append
3892 Act_Decl => Unit_Declaration_Node (Subp),
3893 Expander_Status => Expander_Active,
3894 Current_Sem_Unit => Current_Sem_Unit,
3895 Scope_Suppress => Scope_Suppress,
3896 Local_Suppress_Stack_Top => Local_Suppress_Stack_Top,
3897 Version => Ada_Version));
3902 end Need_Subprogram_Instance_Body;
3904 --------------------------------------
3905 -- Analyze_Subprogram_Instantiation --
3906 --------------------------------------
3908 procedure Analyze_Subprogram_Instantiation
3912 Loc : constant Source_Ptr := Sloc (N);
3913 Gen_Id : constant Node_Id := Name (N);
3915 Anon_Id : constant Entity_Id :=
3916 Make_Defining_Identifier (Sloc (Defining_Entity (N)),
3917 Chars => New_External_Name
3918 (Chars (Defining_Entity (N)), 'R'));
3920 Act_Decl_Id : Entity_Id;
3925 Env_Installed : Boolean := False;
3926 Gen_Unit : Entity_Id;
3928 Pack_Id : Entity_Id;
3929 Parent_Installed : Boolean := False;
3930 Renaming_List : List_Id;
3932 procedure Analyze_Instance_And_Renamings;
3933 -- The instance must be analyzed in a context that includes the mappings
3934 -- of generic parameters into actuals. We create a package declaration
3935 -- for this purpose, and a subprogram with an internal name within the
3936 -- package. The subprogram instance is simply an alias for the internal
3937 -- subprogram, declared in the current scope.
3939 ------------------------------------
3940 -- Analyze_Instance_And_Renamings --
3941 ------------------------------------
3943 procedure Analyze_Instance_And_Renamings is
3944 Def_Ent : constant Entity_Id := Defining_Entity (N);
3945 Pack_Decl : Node_Id;
3948 if Nkind (Parent (N)) = N_Compilation_Unit then
3950 -- For the case of a compilation unit, the container package has
3951 -- the same name as the instantiation, to insure that the binder
3952 -- calls the elaboration procedure with the right name. Copy the
3953 -- entity of the instance, which may have compilation level flags
3954 -- (e.g. Is_Child_Unit) set.
3956 Pack_Id := New_Copy (Def_Ent);
3959 -- Otherwise we use the name of the instantiation concatenated
3960 -- with its source position to ensure uniqueness if there are
3961 -- several instantiations with the same name.
3964 Make_Defining_Identifier (Loc,
3965 Chars => New_External_Name
3966 (Related_Id => Chars (Def_Ent),
3968 Suffix_Index => Source_Offset (Sloc (Def_Ent))));
3971 Pack_Decl := Make_Package_Declaration (Loc,
3972 Specification => Make_Package_Specification (Loc,
3973 Defining_Unit_Name => Pack_Id,
3974 Visible_Declarations => Renaming_List,
3975 End_Label => Empty));
3977 Set_Instance_Spec (N, Pack_Decl);
3978 Set_Is_Generic_Instance (Pack_Id);
3979 Set_Debug_Info_Needed (Pack_Id);
3981 -- Case of not a compilation unit
3983 if Nkind (Parent (N)) /= N_Compilation_Unit then
3984 Mark_Rewrite_Insertion (Pack_Decl);
3985 Insert_Before (N, Pack_Decl);
3986 Set_Has_Completion (Pack_Id);
3988 -- Case of an instantiation that is a compilation unit
3990 -- Place declaration on current node so context is complete for
3991 -- analysis (including nested instantiations), and for use in a
3992 -- context_clause (see Analyze_With_Clause).
3995 Set_Unit (Parent (N), Pack_Decl);
3996 Set_Parent_Spec (Pack_Decl, Parent_Spec (N));
3999 Analyze (Pack_Decl);
4000 Check_Formal_Packages (Pack_Id);
4001 Set_Is_Generic_Instance (Pack_Id, False);
4003 -- Body of the enclosing package is supplied when instantiating the
4004 -- subprogram body, after semantic analysis is completed.
4006 if Nkind (Parent (N)) = N_Compilation_Unit then
4008 -- Remove package itself from visibility, so it does not
4009 -- conflict with subprogram.
4011 Set_Name_Entity_Id (Chars (Pack_Id), Homonym (Pack_Id));
4013 -- Set name and scope of internal subprogram so that the proper
4014 -- external name will be generated. The proper scope is the scope
4015 -- of the wrapper package. We need to generate debugging info for
4016 -- the internal subprogram, so set flag accordingly.
4018 Set_Chars (Anon_Id, Chars (Defining_Entity (N)));
4019 Set_Scope (Anon_Id, Scope (Pack_Id));
4021 -- Mark wrapper package as referenced, to avoid spurious warnings
4022 -- if the instantiation appears in various with_ clauses of
4023 -- subunits of the main unit.
4025 Set_Referenced (Pack_Id);
4028 Set_Is_Generic_Instance (Anon_Id);
4029 Set_Debug_Info_Needed (Anon_Id);
4030 Act_Decl_Id := New_Copy (Anon_Id);
4032 Set_Parent (Act_Decl_Id, Parent (Anon_Id));
4033 Set_Chars (Act_Decl_Id, Chars (Defining_Entity (N)));
4034 Set_Sloc (Act_Decl_Id, Sloc (Defining_Entity (N)));
4035 Set_Comes_From_Source (Act_Decl_Id, True);
4037 -- The signature may involve types that are not frozen yet, but the
4038 -- subprogram will be frozen at the point the wrapper package is
4039 -- frozen, so it does not need its own freeze node. In fact, if one
4040 -- is created, it might conflict with the freezing actions from the
4043 Set_Has_Delayed_Freeze (Anon_Id, False);
4045 -- If the instance is a child unit, mark the Id accordingly. Mark
4046 -- the anonymous entity as well, which is the real subprogram and
4047 -- which is used when the instance appears in a context clause.
4048 -- Similarly, propagate the Is_Eliminated flag to handle properly
4049 -- nested eliminated subprograms.
4051 Set_Is_Child_Unit (Act_Decl_Id, Is_Child_Unit (Defining_Entity (N)));
4052 Set_Is_Child_Unit (Anon_Id, Is_Child_Unit (Defining_Entity (N)));
4053 New_Overloaded_Entity (Act_Decl_Id);
4054 Check_Eliminated (Act_Decl_Id);
4055 Set_Is_Eliminated (Anon_Id, Is_Eliminated (Act_Decl_Id));
4057 -- In compilation unit case, kill elaboration checks on the
4058 -- instantiation, since they are never needed -- the body is
4059 -- instantiated at the same point as the spec.
4061 if Nkind (Parent (N)) = N_Compilation_Unit then
4062 Set_Suppress_Elaboration_Warnings (Act_Decl_Id);
4063 Set_Kill_Elaboration_Checks (Act_Decl_Id);
4064 Set_Is_Compilation_Unit (Anon_Id);
4066 Set_Cunit_Entity (Current_Sem_Unit, Pack_Id);
4069 -- The instance is not a freezing point for the new subprogram
4071 Set_Is_Frozen (Act_Decl_Id, False);
4073 if Nkind (Defining_Entity (N)) = N_Defining_Operator_Symbol then
4074 Valid_Operator_Definition (Act_Decl_Id);
4077 Set_Alias (Act_Decl_Id, Anon_Id);
4078 Set_Parent (Act_Decl_Id, Parent (Anon_Id));
4079 Set_Has_Completion (Act_Decl_Id);
4080 Set_Related_Instance (Pack_Id, Act_Decl_Id);
4082 if Nkind (Parent (N)) = N_Compilation_Unit then
4083 Set_Body_Required (Parent (N), False);
4085 end Analyze_Instance_And_Renamings;
4087 -- Start of processing for Analyze_Subprogram_Instantiation
4090 -- Very first thing: apply the special kludge for Text_IO processing
4091 -- in case we are instantiating one of the children of [Wide_]Text_IO.
4092 -- Of course such an instantiation is bogus (these are packages, not
4093 -- subprograms), but we get a better error message if we do this.
4095 Text_IO_Kludge (Gen_Id);
4097 -- Make node global for error reporting
4099 Instantiation_Node := N;
4100 Preanalyze_Actuals (N);
4103 Env_Installed := True;
4104 Check_Generic_Child_Unit (Gen_Id, Parent_Installed);
4105 Gen_Unit := Entity (Gen_Id);
4107 Generate_Reference (Gen_Unit, Gen_Id);
4109 if Nkind (Gen_Id) = N_Identifier
4110 and then Chars (Gen_Unit) = Chars (Defining_Entity (N))
4113 ("& is hidden within declaration of instance", Gen_Id, Gen_Unit);
4116 if Etype (Gen_Unit) = Any_Type then
4121 -- Verify that it is a generic subprogram of the right kind, and that
4122 -- it does not lead to a circular instantiation.
4124 if not Ekind_In (Gen_Unit, E_Generic_Procedure, E_Generic_Function) then
4125 Error_Msg_N ("expect generic subprogram in instantiation", Gen_Id);
4127 elsif In_Open_Scopes (Gen_Unit) then
4128 Error_Msg_NE ("instantiation of & within itself", N, Gen_Unit);
4130 elsif K = E_Procedure
4131 and then Ekind (Gen_Unit) /= E_Generic_Procedure
4133 if Ekind (Gen_Unit) = E_Generic_Function then
4135 ("cannot instantiate generic function as procedure", Gen_Id);
4138 ("expect name of generic procedure in instantiation", Gen_Id);
4141 elsif K = E_Function
4142 and then Ekind (Gen_Unit) /= E_Generic_Function
4144 if Ekind (Gen_Unit) = E_Generic_Procedure then
4146 ("cannot instantiate generic procedure as function", Gen_Id);
4149 ("expect name of generic function in instantiation", Gen_Id);
4153 Set_Entity (Gen_Id, Gen_Unit);
4154 Set_Is_Instantiated (Gen_Unit);
4156 if In_Extended_Main_Source_Unit (N) then
4157 Generate_Reference (Gen_Unit, N);
4160 -- If renaming, get original unit
4162 if Present (Renamed_Object (Gen_Unit))
4163 and then (Ekind (Renamed_Object (Gen_Unit)) = E_Generic_Procedure
4165 Ekind (Renamed_Object (Gen_Unit)) = E_Generic_Function)
4167 Gen_Unit := Renamed_Object (Gen_Unit);
4168 Set_Is_Instantiated (Gen_Unit);
4169 Generate_Reference (Gen_Unit, N);
4172 if Contains_Instance_Of (Gen_Unit, Current_Scope, Gen_Id) then
4173 Error_Msg_Node_2 := Current_Scope;
4175 ("circular Instantiation: & instantiated in &!", N, Gen_Unit);
4176 Circularity_Detected := True;
4180 Gen_Decl := Unit_Declaration_Node (Gen_Unit);
4182 -- Initialize renamings map, for error checking
4184 Generic_Renamings.Set_Last (0);
4185 Generic_Renamings_HTable.Reset;
4187 Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment);
4189 -- Copy original generic tree, to produce text for instantiation
4193 (Original_Node (Gen_Decl), Empty, Instantiating => True);
4195 -- Inherit overriding indicator from instance node
4197 Act_Spec := Specification (Act_Tree);
4198 Set_Must_Override (Act_Spec, Must_Override (N));
4199 Set_Must_Not_Override (Act_Spec, Must_Not_Override (N));
4202 Analyze_Associations
4204 Generic_Formal_Declarations (Act_Tree),
4205 Generic_Formal_Declarations (Gen_Decl));
4207 -- The subprogram itself cannot contain a nested instance, so the
4208 -- current parent is left empty.
4210 Set_Instance_Env (Gen_Unit, Empty);
4212 -- Build the subprogram declaration, which does not appear in the
4213 -- generic template, and give it a sloc consistent with that of the
4216 Set_Defining_Unit_Name (Act_Spec, Anon_Id);
4217 Set_Generic_Parent (Act_Spec, Gen_Unit);
4219 Make_Subprogram_Declaration (Sloc (Act_Spec),
4220 Specification => Act_Spec);
4222 Set_Categorization_From_Pragmas (Act_Decl);
4224 if Parent_Installed then
4228 Append (Act_Decl, Renaming_List);
4229 Analyze_Instance_And_Renamings;
4231 -- If the generic is marked Import (Intrinsic), then so is the
4232 -- instance. This indicates that there is no body to instantiate. If
4233 -- generic is marked inline, so it the instance, and the anonymous
4234 -- subprogram it renames. If inlined, or else if inlining is enabled
4235 -- for the compilation, we generate the instance body even if it is
4236 -- not within the main unit.
4238 -- Any other pragmas might also be inherited ???
4240 if Is_Intrinsic_Subprogram (Gen_Unit) then
4241 Set_Is_Intrinsic_Subprogram (Anon_Id);
4242 Set_Is_Intrinsic_Subprogram (Act_Decl_Id);
4244 if Chars (Gen_Unit) = Name_Unchecked_Conversion then
4245 Validate_Unchecked_Conversion (N, Act_Decl_Id);
4249 Generate_Definition (Act_Decl_Id);
4251 Set_Is_Inlined (Act_Decl_Id, Is_Inlined (Gen_Unit));
4252 Set_Is_Inlined (Anon_Id, Is_Inlined (Gen_Unit));
4254 if not Is_Intrinsic_Subprogram (Gen_Unit) then
4255 Check_Elab_Instantiation (N);
4258 if Is_Dispatching_Operation (Act_Decl_Id)
4259 and then Ada_Version >= Ada_2005
4265 Formal := First_Formal (Act_Decl_Id);
4266 while Present (Formal) loop
4267 if Ekind (Etype (Formal)) = E_Anonymous_Access_Type
4268 and then Is_Controlling_Formal (Formal)
4269 and then not Can_Never_Be_Null (Formal)
4271 Error_Msg_NE ("access parameter& is controlling,",
4274 ("\corresponding parameter of & must be"
4275 & " explicitly null-excluding", N, Gen_Id);
4278 Next_Formal (Formal);
4283 Check_Hidden_Child_Unit (N, Gen_Unit, Act_Decl_Id);
4285 -- Subject to change, pending on if other pragmas are inherited ???
4287 Validate_Categorization_Dependency (N, Act_Decl_Id);
4289 if not Is_Intrinsic_Subprogram (Act_Decl_Id) then
4290 Inherit_Context (Gen_Decl, N);
4292 Restore_Private_Views (Pack_Id, False);
4294 -- If the context requires a full instantiation, mark node for
4295 -- subsequent construction of the body.
4297 if Need_Subprogram_Instance_Body (N, Act_Decl_Id) then
4299 Check_Forward_Instantiation (Gen_Decl);
4301 -- The wrapper package is always delayed, because it does not
4302 -- constitute a freeze point, but to insure that the freeze
4303 -- node is placed properly, it is created directly when
4304 -- instantiating the body (otherwise the freeze node might
4305 -- appear to early for nested instantiations).
4307 elsif Nkind (Parent (N)) = N_Compilation_Unit then
4309 -- For ASIS purposes, indicate that the wrapper package has
4310 -- replaced the instantiation node.
4312 Rewrite (N, Unit (Parent (N)));
4313 Set_Unit (Parent (N), N);
4316 elsif Nkind (Parent (N)) = N_Compilation_Unit then
4318 -- Replace instance node for library-level instantiations of
4319 -- intrinsic subprograms, for ASIS use.
4321 Rewrite (N, Unit (Parent (N)));
4322 Set_Unit (Parent (N), N);
4325 if Parent_Installed then
4330 Env_Installed := False;
4331 Generic_Renamings.Set_Last (0);
4332 Generic_Renamings_HTable.Reset;
4336 Analyze_Aspect_Specifications
4337 (N, Act_Decl_Id, Aspect_Specifications (N));
4340 when Instantiation_Error =>
4341 if Parent_Installed then
4345 if Env_Installed then
4348 end Analyze_Subprogram_Instantiation;
4350 -------------------------
4351 -- Get_Associated_Node --
4352 -------------------------
4354 function Get_Associated_Node (N : Node_Id) return Node_Id is
4358 Assoc := Associated_Node (N);
4360 if Nkind (Assoc) /= Nkind (N) then
4363 elsif Nkind_In (Assoc, N_Aggregate, N_Extension_Aggregate) then
4367 -- If the node is part of an inner generic, it may itself have been
4368 -- remapped into a further generic copy. Associated_Node is otherwise
4369 -- used for the entity of the node, and will be of a different node
4370 -- kind, or else N has been rewritten as a literal or function call.
4372 while Present (Associated_Node (Assoc))
4373 and then Nkind (Associated_Node (Assoc)) = Nkind (Assoc)
4375 Assoc := Associated_Node (Assoc);
4378 -- Follow and additional link in case the final node was rewritten.
4379 -- This can only happen with nested generic units.
4381 if (Nkind (Assoc) = N_Identifier or else Nkind (Assoc) in N_Op)
4382 and then Present (Associated_Node (Assoc))
4383 and then (Nkind_In (Associated_Node (Assoc), N_Function_Call,
4384 N_Explicit_Dereference,
4389 Assoc := Associated_Node (Assoc);
4394 end Get_Associated_Node;
4396 -------------------------------------------
4397 -- Build_Instance_Compilation_Unit_Nodes --
4398 -------------------------------------------
4400 procedure Build_Instance_Compilation_Unit_Nodes
4405 Decl_Cunit : Node_Id;
4406 Body_Cunit : Node_Id;
4408 New_Main : constant Entity_Id := Defining_Entity (Act_Decl);
4409 Old_Main : constant Entity_Id := Cunit_Entity (Main_Unit);
4412 -- A new compilation unit node is built for the instance declaration
4415 Make_Compilation_Unit (Sloc (N),
4416 Context_Items => Empty_List,
4419 Make_Compilation_Unit_Aux (Sloc (N)));
4421 Set_Parent_Spec (Act_Decl, Parent_Spec (N));
4423 -- The new compilation unit is linked to its body, but both share the
4424 -- same file, so we do not set Body_Required on the new unit so as not
4425 -- to create a spurious dependency on a non-existent body in the ali.
4426 -- This simplifies CodePeer unit traversal.
4428 -- We use the original instantiation compilation unit as the resulting
4429 -- compilation unit of the instance, since this is the main unit.
4431 Rewrite (N, Act_Body);
4432 Body_Cunit := Parent (N);
4434 -- The two compilation unit nodes are linked by the Library_Unit field
4436 Set_Library_Unit (Decl_Cunit, Body_Cunit);
4437 Set_Library_Unit (Body_Cunit, Decl_Cunit);
4439 -- Preserve the private nature of the package if needed
4441 Set_Private_Present (Decl_Cunit, Private_Present (Body_Cunit));
4443 -- If the instance is not the main unit, its context, categorization
4444 -- and elaboration entity are not relevant to the compilation.
4446 if Body_Cunit /= Cunit (Main_Unit) then
4447 Make_Instance_Unit (Body_Cunit, In_Main => False);
4451 -- The context clause items on the instantiation, which are now attached
4452 -- to the body compilation unit (since the body overwrote the original
4453 -- instantiation node), semantically belong on the spec, so copy them
4454 -- there. It's harmless to leave them on the body as well. In fact one
4455 -- could argue that they belong in both places.
4457 Citem := First (Context_Items (Body_Cunit));
4458 while Present (Citem) loop
4459 Append (New_Copy (Citem), Context_Items (Decl_Cunit));
4463 -- Propagate categorization flags on packages, so that they appear in
4464 -- the ali file for the spec of the unit.
4466 if Ekind (New_Main) = E_Package then
4467 Set_Is_Pure (Old_Main, Is_Pure (New_Main));
4468 Set_Is_Preelaborated (Old_Main, Is_Preelaborated (New_Main));
4469 Set_Is_Remote_Types (Old_Main, Is_Remote_Types (New_Main));
4470 Set_Is_Shared_Passive (Old_Main, Is_Shared_Passive (New_Main));
4471 Set_Is_Remote_Call_Interface
4472 (Old_Main, Is_Remote_Call_Interface (New_Main));
4475 -- Make entry in Units table, so that binder can generate call to
4476 -- elaboration procedure for body, if any.
4478 Make_Instance_Unit (Body_Cunit, In_Main => True);
4479 Main_Unit_Entity := New_Main;
4480 Set_Cunit_Entity (Main_Unit, Main_Unit_Entity);
4482 -- Build elaboration entity, since the instance may certainly generate
4483 -- elaboration code requiring a flag for protection.
4485 Build_Elaboration_Entity (Decl_Cunit, New_Main);
4486 end Build_Instance_Compilation_Unit_Nodes;
4488 -----------------------------
4489 -- Check_Access_Definition --
4490 -----------------------------
4492 procedure Check_Access_Definition (N : Node_Id) is
4495 (Ada_Version >= Ada_2005
4496 and then Present (Access_Definition (N)));
4498 end Check_Access_Definition;
4500 -----------------------------------
4501 -- Check_Formal_Package_Instance --
4502 -----------------------------------
4504 -- If the formal has specific parameters, they must match those of the
4505 -- actual. Both of them are instances, and the renaming declarations for
4506 -- their formal parameters appear in the same order in both. The analyzed
4507 -- formal has been analyzed in the context of the current instance.
4509 procedure Check_Formal_Package_Instance
4510 (Formal_Pack : Entity_Id;
4511 Actual_Pack : Entity_Id)
4513 E1 : Entity_Id := First_Entity (Actual_Pack);
4514 E2 : Entity_Id := First_Entity (Formal_Pack);
4519 procedure Check_Mismatch (B : Boolean);
4520 -- Common error routine for mismatch between the parameters of the
4521 -- actual instance and those of the formal package.
4523 function Same_Instantiated_Constant (E1, E2 : Entity_Id) return Boolean;
4524 -- The formal may come from a nested formal package, and the actual may
4525 -- have been constant-folded. To determine whether the two denote the
4526 -- same entity we may have to traverse several definitions to recover
4527 -- the ultimate entity that they refer to.
4529 function Same_Instantiated_Variable (E1, E2 : Entity_Id) return Boolean;
4530 -- Similarly, if the formal comes from a nested formal package, the
4531 -- actual may designate the formal through multiple renamings, which
4532 -- have to be followed to determine the original variable in question.
4534 --------------------
4535 -- Check_Mismatch --
4536 --------------------
4538 procedure Check_Mismatch (B : Boolean) is
4539 Kind : constant Node_Kind := Nkind (Parent (E2));
4542 if Kind = N_Formal_Type_Declaration then
4545 elsif Nkind_In (Kind, N_Formal_Object_Declaration,
4546 N_Formal_Package_Declaration)
4547 or else Kind in N_Formal_Subprogram_Declaration
4553 ("actual for & in actual instance does not match formal",
4554 Parent (Actual_Pack), E1);
4558 --------------------------------
4559 -- Same_Instantiated_Constant --
4560 --------------------------------
4562 function Same_Instantiated_Constant
4563 (E1, E2 : Entity_Id) return Boolean
4569 while Present (Ent) loop
4573 elsif Ekind (Ent) /= E_Constant then
4576 elsif Is_Entity_Name (Constant_Value (Ent)) then
4577 if Entity (Constant_Value (Ent)) = E1 then
4580 Ent := Entity (Constant_Value (Ent));
4583 -- The actual may be a constant that has been folded. Recover
4586 elsif Is_Entity_Name (Original_Node (Constant_Value (Ent))) then
4587 Ent := Entity (Original_Node (Constant_Value (Ent)));
4594 end Same_Instantiated_Constant;
4596 --------------------------------
4597 -- Same_Instantiated_Variable --
4598 --------------------------------
4600 function Same_Instantiated_Variable
4601 (E1, E2 : Entity_Id) return Boolean
4603 function Original_Entity (E : Entity_Id) return Entity_Id;
4604 -- Follow chain of renamings to the ultimate ancestor
4606 ---------------------
4607 -- Original_Entity --
4608 ---------------------
4610 function Original_Entity (E : Entity_Id) return Entity_Id is
4615 while Nkind (Parent (Orig)) = N_Object_Renaming_Declaration
4616 and then Present (Renamed_Object (Orig))
4617 and then Is_Entity_Name (Renamed_Object (Orig))
4619 Orig := Entity (Renamed_Object (Orig));
4623 end Original_Entity;
4625 -- Start of processing for Same_Instantiated_Variable
4628 return Ekind (E1) = Ekind (E2)
4629 and then Original_Entity (E1) = Original_Entity (E2);
4630 end Same_Instantiated_Variable;
4632 -- Start of processing for Check_Formal_Package_Instance
4636 and then Present (E2)
4638 exit when Ekind (E1) = E_Package
4639 and then Renamed_Entity (E1) = Renamed_Entity (Actual_Pack);
4641 -- If the formal is the renaming of the formal package, this
4642 -- is the end of its formal part, which may occur before the
4643 -- end of the formal part in the actual in the presence of
4644 -- defaulted parameters in the formal package.
4646 exit when Nkind (Parent (E2)) = N_Package_Renaming_Declaration
4647 and then Renamed_Entity (E2) = Scope (E2);
4649 -- The analysis of the actual may generate additional internal
4650 -- entities. If the formal is defaulted, there is no corresponding
4651 -- analysis and the internal entities must be skipped, until we
4652 -- find corresponding entities again.
4654 if Comes_From_Source (E2)
4655 and then not Comes_From_Source (E1)
4656 and then Chars (E1) /= Chars (E2)
4659 and then Chars (E1) /= Chars (E2)
4668 -- If the formal entity comes from a formal declaration, it was
4669 -- defaulted in the formal package, and no check is needed on it.
4671 elsif Nkind (Parent (E2)) = N_Formal_Object_Declaration then
4674 elsif Is_Type (E1) then
4676 -- Subtypes must statically match. E1, E2 are the local entities
4677 -- that are subtypes of the actuals. Itypes generated for other
4678 -- parameters need not be checked, the check will be performed
4679 -- on the parameters themselves.
4681 -- If E2 is a formal type declaration, it is a defaulted parameter
4682 -- and needs no checking.
4684 if not Is_Itype (E1)
4685 and then not Is_Itype (E2)
4689 or else Etype (E1) /= Etype (E2)
4690 or else not Subtypes_Statically_Match (E1, E2));
4693 elsif Ekind (E1) = E_Constant then
4695 -- IN parameters must denote the same static value, or the same
4696 -- constant, or the literal null.
4698 Expr1 := Expression (Parent (E1));
4700 if Ekind (E2) /= E_Constant then
4701 Check_Mismatch (True);
4704 Expr2 := Expression (Parent (E2));
4707 if Is_Static_Expression (Expr1) then
4709 if not Is_Static_Expression (Expr2) then
4710 Check_Mismatch (True);
4712 elsif Is_Discrete_Type (Etype (E1)) then
4714 V1 : constant Uint := Expr_Value (Expr1);
4715 V2 : constant Uint := Expr_Value (Expr2);
4717 Check_Mismatch (V1 /= V2);
4720 elsif Is_Real_Type (Etype (E1)) then
4722 V1 : constant Ureal := Expr_Value_R (Expr1);
4723 V2 : constant Ureal := Expr_Value_R (Expr2);
4725 Check_Mismatch (V1 /= V2);
4728 elsif Is_String_Type (Etype (E1))
4729 and then Nkind (Expr1) = N_String_Literal
4731 if Nkind (Expr2) /= N_String_Literal then
4732 Check_Mismatch (True);
4735 (not String_Equal (Strval (Expr1), Strval (Expr2)));
4739 elsif Is_Entity_Name (Expr1) then
4740 if Is_Entity_Name (Expr2) then
4741 if Entity (Expr1) = Entity (Expr2) then
4745 (not Same_Instantiated_Constant
4746 (Entity (Expr1), Entity (Expr2)));
4749 Check_Mismatch (True);
4752 elsif Is_Entity_Name (Original_Node (Expr1))
4753 and then Is_Entity_Name (Expr2)
4755 Same_Instantiated_Constant
4756 (Entity (Original_Node (Expr1)), Entity (Expr2))
4760 elsif Nkind (Expr1) = N_Null then
4761 Check_Mismatch (Nkind (Expr1) /= N_Null);
4764 Check_Mismatch (True);
4767 elsif Ekind (E1) = E_Variable then
4768 Check_Mismatch (not Same_Instantiated_Variable (E1, E2));
4770 elsif Ekind (E1) = E_Package then
4772 (Ekind (E1) /= Ekind (E2)
4773 or else Renamed_Object (E1) /= Renamed_Object (E2));
4775 elsif Is_Overloadable (E1) then
4777 -- Verify that the actual subprograms match. Note that actuals
4778 -- that are attributes are rewritten as subprograms. If the
4779 -- subprogram in the formal package is defaulted, no check is
4780 -- needed. Note that this can only happen in Ada 2005 when the
4781 -- formal package can be partially parameterized.
4783 if Nkind (Unit_Declaration_Node (E1)) =
4784 N_Subprogram_Renaming_Declaration
4785 and then From_Default (Unit_Declaration_Node (E1))
4791 (Ekind (E2) /= Ekind (E1) or else (Alias (E1)) /= Alias (E2));
4795 raise Program_Error;
4802 end Check_Formal_Package_Instance;
4804 ---------------------------
4805 -- Check_Formal_Packages --
4806 ---------------------------
4808 procedure Check_Formal_Packages (P_Id : Entity_Id) is
4810 Formal_P : Entity_Id;
4813 -- Iterate through the declarations in the instance, looking for package
4814 -- renaming declarations that denote instances of formal packages. Stop
4815 -- when we find the renaming of the current package itself. The
4816 -- declaration for a formal package without a box is followed by an
4817 -- internal entity that repeats the instantiation.
4819 E := First_Entity (P_Id);
4820 while Present (E) loop
4821 if Ekind (E) = E_Package then
4822 if Renamed_Object (E) = P_Id then
4825 elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then
4828 elsif not Box_Present (Parent (Associated_Formal_Package (E))) then
4829 Formal_P := Next_Entity (E);
4830 Check_Formal_Package_Instance (Formal_P, E);
4832 -- After checking, remove the internal validating package. It
4833 -- is only needed for semantic checks, and as it may contain
4834 -- generic formal declarations it should not reach gigi.
4836 Remove (Unit_Declaration_Node (Formal_P));
4842 end Check_Formal_Packages;
4844 ---------------------------------
4845 -- Check_Forward_Instantiation --
4846 ---------------------------------
4848 procedure Check_Forward_Instantiation (Decl : Node_Id) is
4850 Gen_Comp : Entity_Id := Cunit_Entity (Get_Source_Unit (Decl));
4853 -- The instantiation appears before the generic body if we are in the
4854 -- scope of the unit containing the generic, either in its spec or in
4855 -- the package body, and before the generic body.
4857 if Ekind (Gen_Comp) = E_Package_Body then
4858 Gen_Comp := Spec_Entity (Gen_Comp);
4861 if In_Open_Scopes (Gen_Comp)
4862 and then No (Corresponding_Body (Decl))
4867 and then not Is_Compilation_Unit (S)
4868 and then not Is_Child_Unit (S)
4870 if Ekind (S) = E_Package then
4871 Set_Has_Forward_Instantiation (S);
4877 end Check_Forward_Instantiation;
4879 ---------------------------
4880 -- Check_Generic_Actuals --
4881 ---------------------------
4883 -- The visibility of the actuals may be different between the point of
4884 -- generic instantiation and the instantiation of the body.
4886 procedure Check_Generic_Actuals
4887 (Instance : Entity_Id;
4888 Is_Formal_Box : Boolean)
4893 function Denotes_Previous_Actual (Typ : Entity_Id) return Boolean;
4894 -- For a formal that is an array type, the component type is often a
4895 -- previous formal in the same unit. The privacy status of the component
4896 -- type will have been examined earlier in the traversal of the
4897 -- corresponding actuals, and this status should not be modified for the
4898 -- array type itself.
4900 -- To detect this case we have to rescan the list of formals, which
4901 -- is usually short enough to ignore the resulting inefficiency.
4903 -----------------------------
4904 -- Denotes_Previous_Actual --
4905 -----------------------------
4907 function Denotes_Previous_Actual (Typ : Entity_Id) return Boolean is
4911 Prev := First_Entity (Instance);
4912 while Present (Prev) loop
4914 and then Nkind (Parent (Prev)) = N_Subtype_Declaration
4915 and then Is_Entity_Name (Subtype_Indication (Parent (Prev)))
4916 and then Entity (Subtype_Indication (Parent (Prev))) = Typ
4929 end Denotes_Previous_Actual;
4931 -- Start of processing for Check_Generic_Actuals
4934 E := First_Entity (Instance);
4935 while Present (E) loop
4937 and then Nkind (Parent (E)) = N_Subtype_Declaration
4938 and then Scope (Etype (E)) /= Instance
4939 and then Is_Entity_Name (Subtype_Indication (Parent (E)))
4941 if Is_Array_Type (E)
4942 and then Denotes_Previous_Actual (Component_Type (E))
4946 Check_Private_View (Subtype_Indication (Parent (E)));
4948 Set_Is_Generic_Actual_Type (E, True);
4949 Set_Is_Hidden (E, False);
4950 Set_Is_Potentially_Use_Visible (E,
4953 -- We constructed the generic actual type as a subtype of the
4954 -- supplied type. This means that it normally would not inherit
4955 -- subtype specific attributes of the actual, which is wrong for
4956 -- the generic case.
4958 Astype := Ancestor_Subtype (E);
4962 -- This can happen when E is an itype that is the full view of
4963 -- a private type completed, e.g. with a constrained array. In
4964 -- that case, use the first subtype, which will carry size
4965 -- information. The base type itself is unconstrained and will
4968 Astype := First_Subtype (E);
4971 Set_Size_Info (E, (Astype));
4972 Set_RM_Size (E, RM_Size (Astype));
4973 Set_First_Rep_Item (E, First_Rep_Item (Astype));
4975 if Is_Discrete_Or_Fixed_Point_Type (E) then
4976 Set_RM_Size (E, RM_Size (Astype));
4978 -- In nested instances, the base type of an access actual
4979 -- may itself be private, and need to be exchanged.
4981 elsif Is_Access_Type (E)
4982 and then Is_Private_Type (Etype (E))
4985 (New_Occurrence_Of (Etype (E), Sloc (Instance)));
4988 elsif Ekind (E) = E_Package then
4990 -- If this is the renaming for the current instance, we're done.
4991 -- Otherwise it is a formal package. If the corresponding formal
4992 -- was declared with a box, the (instantiations of the) generic
4993 -- formal part are also visible. Otherwise, ignore the entity
4994 -- created to validate the actuals.
4996 if Renamed_Object (E) = Instance then
4999 elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then
5002 -- The visibility of a formal of an enclosing generic is already
5005 elsif Denotes_Formal_Package (E) then
5008 elsif Present (Associated_Formal_Package (E))
5009 and then not Is_Generic_Formal (E)
5011 if Box_Present (Parent (Associated_Formal_Package (E))) then
5012 Check_Generic_Actuals (Renamed_Object (E), True);
5015 Check_Generic_Actuals (Renamed_Object (E), False);
5018 Set_Is_Hidden (E, False);
5021 -- If this is a subprogram instance (in a wrapper package) the
5022 -- actual is fully visible.
5024 elsif Is_Wrapper_Package (Instance) then
5025 Set_Is_Hidden (E, False);
5027 -- If the formal package is declared with a box, or if the formal
5028 -- parameter is defaulted, it is visible in the body.
5031 or else Is_Visible_Formal (E)
5033 Set_Is_Hidden (E, False);
5038 end Check_Generic_Actuals;
5040 ------------------------------
5041 -- Check_Generic_Child_Unit --
5042 ------------------------------
5044 procedure Check_Generic_Child_Unit
5046 Parent_Installed : in out Boolean)
5048 Loc : constant Source_Ptr := Sloc (Gen_Id);
5049 Gen_Par : Entity_Id := Empty;
5051 Inst_Par : Entity_Id;
5054 function Find_Generic_Child
5056 Id : Node_Id) return Entity_Id;
5057 -- Search generic parent for possible child unit with the given name
5059 function In_Enclosing_Instance return Boolean;
5060 -- Within an instance of the parent, the child unit may be denoted
5061 -- by a simple name, or an abbreviated expanded name. Examine enclosing
5062 -- scopes to locate a possible parent instantiation.
5064 ------------------------
5065 -- Find_Generic_Child --
5066 ------------------------
5068 function Find_Generic_Child
5070 Id : Node_Id) return Entity_Id
5075 -- If entity of name is already set, instance has already been
5076 -- resolved, e.g. in an enclosing instantiation.
5078 if Present (Entity (Id)) then
5079 if Scope (Entity (Id)) = Scop then
5086 E := First_Entity (Scop);
5087 while Present (E) loop
5088 if Chars (E) = Chars (Id)
5089 and then Is_Child_Unit (E)
5091 if Is_Child_Unit (E)
5092 and then not Is_Visible_Child_Unit (E)
5095 ("generic child unit& is not visible", Gen_Id, E);
5107 end Find_Generic_Child;
5109 ---------------------------
5110 -- In_Enclosing_Instance --
5111 ---------------------------
5113 function In_Enclosing_Instance return Boolean is
5114 Enclosing_Instance : Node_Id;
5115 Instance_Decl : Node_Id;
5118 -- We do not inline any call that contains instantiations, except
5119 -- for instantiations of Unchecked_Conversion, so if we are within
5120 -- an inlined body the current instance does not require parents.
5122 if In_Inlined_Body then
5123 pragma Assert (Chars (Gen_Id) = Name_Unchecked_Conversion);
5127 -- Loop to check enclosing scopes
5129 Enclosing_Instance := Current_Scope;
5130 while Present (Enclosing_Instance) loop
5131 Instance_Decl := Unit_Declaration_Node (Enclosing_Instance);
5133 if Ekind (Enclosing_Instance) = E_Package
5134 and then Is_Generic_Instance (Enclosing_Instance)
5136 (Generic_Parent (Specification (Instance_Decl)))
5138 -- Check whether the generic we are looking for is a child of
5141 E := Find_Generic_Child
5142 (Generic_Parent (Specification (Instance_Decl)), Gen_Id);
5143 exit when Present (E);
5149 Enclosing_Instance := Scope (Enclosing_Instance);
5161 Make_Expanded_Name (Loc,
5163 Prefix => New_Occurrence_Of (Enclosing_Instance, Loc),
5164 Selector_Name => New_Occurrence_Of (E, Loc)));
5166 Set_Entity (Gen_Id, E);
5167 Set_Etype (Gen_Id, Etype (E));
5168 Parent_Installed := False; -- Already in scope.
5171 end In_Enclosing_Instance;
5173 -- Start of processing for Check_Generic_Child_Unit
5176 -- If the name of the generic is given by a selected component, it may
5177 -- be the name of a generic child unit, and the prefix is the name of an
5178 -- instance of the parent, in which case the child unit must be visible.
5179 -- If this instance is not in scope, it must be placed there and removed
5180 -- after instantiation, because what is being instantiated is not the
5181 -- original child, but the corresponding child present in the instance
5184 -- If the child is instantiated within the parent, it can be given by
5185 -- a simple name. In this case the instance is already in scope, but
5186 -- the child generic must be recovered from the generic parent as well.
5188 if Nkind (Gen_Id) = N_Selected_Component then
5189 S := Selector_Name (Gen_Id);
5190 Analyze (Prefix (Gen_Id));
5191 Inst_Par := Entity (Prefix (Gen_Id));
5193 if Ekind (Inst_Par) = E_Package
5194 and then Present (Renamed_Object (Inst_Par))
5196 Inst_Par := Renamed_Object (Inst_Par);
5199 if Ekind (Inst_Par) = E_Package then
5200 if Nkind (Parent (Inst_Par)) = N_Package_Specification then
5201 Gen_Par := Generic_Parent (Parent (Inst_Par));
5203 elsif Nkind (Parent (Inst_Par)) = N_Defining_Program_Unit_Name
5205 Nkind (Parent (Parent (Inst_Par))) = N_Package_Specification
5207 Gen_Par := Generic_Parent (Parent (Parent (Inst_Par)));
5210 elsif Ekind (Inst_Par) = E_Generic_Package
5211 and then Nkind (Parent (Gen_Id)) = N_Formal_Package_Declaration
5213 -- A formal package may be a real child package, and not the
5214 -- implicit instance within a parent. In this case the child is
5215 -- not visible and has to be retrieved explicitly as well.
5217 Gen_Par := Inst_Par;
5220 if Present (Gen_Par) then
5222 -- The prefix denotes an instantiation. The entity itself may be a
5223 -- nested generic, or a child unit.
5225 E := Find_Generic_Child (Gen_Par, S);
5228 Change_Selected_Component_To_Expanded_Name (Gen_Id);
5229 Set_Entity (Gen_Id, E);
5230 Set_Etype (Gen_Id, Etype (E));
5232 Set_Etype (S, Etype (E));
5234 -- Indicate that this is a reference to the parent
5236 if In_Extended_Main_Source_Unit (Gen_Id) then
5237 Set_Is_Instantiated (Inst_Par);
5240 -- A common mistake is to replicate the naming scheme of a
5241 -- hierarchy by instantiating a generic child directly, rather
5242 -- than the implicit child in a parent instance:
5244 -- generic .. package Gpar is ..
5245 -- generic .. package Gpar.Child is ..
5246 -- package Par is new Gpar ();
5249 -- package Par.Child is new Gpar.Child ();
5250 -- rather than Par.Child
5252 -- In this case the instantiation is within Par, which is an
5253 -- instance, but Gpar does not denote Par because we are not IN
5254 -- the instance of Gpar, so this is illegal. The test below
5255 -- recognizes this particular case.
5257 if Is_Child_Unit (E)
5258 and then not Comes_From_Source (Entity (Prefix (Gen_Id)))
5259 and then (not In_Instance
5260 or else Nkind (Parent (Parent (Gen_Id))) =
5264 ("prefix of generic child unit must be instance of parent",
5268 if not In_Open_Scopes (Inst_Par)
5269 and then Nkind (Parent (Gen_Id)) not in
5270 N_Generic_Renaming_Declaration
5272 Install_Parent (Inst_Par);
5273 Parent_Installed := True;
5275 elsif In_Open_Scopes (Inst_Par) then
5277 -- If the parent is already installed, install the actuals
5278 -- for its formal packages. This is necessary when the
5279 -- child instance is a child of the parent instance:
5280 -- in this case, the parent is placed on the scope stack
5281 -- but the formal packages are not made visible.
5283 Install_Formal_Packages (Inst_Par);
5287 -- If the generic parent does not contain an entity that
5288 -- corresponds to the selector, the instance doesn't either.
5289 -- Analyzing the node will yield the appropriate error message.
5290 -- If the entity is not a child unit, then it is an inner
5291 -- generic in the parent.
5299 if Is_Child_Unit (Entity (Gen_Id))
5301 Nkind (Parent (Gen_Id)) not in N_Generic_Renaming_Declaration
5302 and then not In_Open_Scopes (Inst_Par)
5304 Install_Parent (Inst_Par);
5305 Parent_Installed := True;
5307 -- The generic unit may be the renaming of the implicit child
5308 -- present in an instance. In that case the parent instance is
5309 -- obtained from the name of the renamed entity.
5311 elsif Ekind (Entity (Gen_Id)) = E_Generic_Package
5312 and then Present (Renamed_Entity (Entity (Gen_Id)))
5313 and then Is_Child_Unit (Renamed_Entity (Entity (Gen_Id)))
5316 Renamed_Package : constant Node_Id :=
5317 Name (Parent (Entity (Gen_Id)));
5319 if Nkind (Renamed_Package) = N_Expanded_Name then
5320 Inst_Par := Entity (Prefix (Renamed_Package));
5321 Install_Parent (Inst_Par);
5322 Parent_Installed := True;
5328 elsif Nkind (Gen_Id) = N_Expanded_Name then
5330 -- Entity already present, analyze prefix, whose meaning may be
5331 -- an instance in the current context. If it is an instance of
5332 -- a relative within another, the proper parent may still have
5333 -- to be installed, if they are not of the same generation.
5335 Analyze (Prefix (Gen_Id));
5337 -- In the unlikely case that a local declaration hides the name
5338 -- of the parent package, locate it on the homonym chain. If the
5339 -- context is an instance of the parent, the renaming entity is
5342 Inst_Par := Entity (Prefix (Gen_Id));
5343 while Present (Inst_Par)
5344 and then not Is_Package_Or_Generic_Package (Inst_Par)
5346 Inst_Par := Homonym (Inst_Par);
5349 pragma Assert (Present (Inst_Par));
5350 Set_Entity (Prefix (Gen_Id), Inst_Par);
5352 if In_Enclosing_Instance then
5355 elsif Present (Entity (Gen_Id))
5356 and then Is_Child_Unit (Entity (Gen_Id))
5357 and then not In_Open_Scopes (Inst_Par)
5359 Install_Parent (Inst_Par);
5360 Parent_Installed := True;
5363 elsif In_Enclosing_Instance then
5365 -- The child unit is found in some enclosing scope
5372 -- If this is the renaming of the implicit child in a parent
5373 -- instance, recover the parent name and install it.
5375 if Is_Entity_Name (Gen_Id) then
5376 E := Entity (Gen_Id);
5378 if Is_Generic_Unit (E)
5379 and then Nkind (Parent (E)) in N_Generic_Renaming_Declaration
5380 and then Is_Child_Unit (Renamed_Object (E))
5381 and then Is_Generic_Unit (Scope (Renamed_Object (E)))
5382 and then Nkind (Name (Parent (E))) = N_Expanded_Name
5385 New_Copy_Tree (Name (Parent (E))));
5386 Inst_Par := Entity (Prefix (Gen_Id));
5388 if not In_Open_Scopes (Inst_Par) then
5389 Install_Parent (Inst_Par);
5390 Parent_Installed := True;
5393 -- If it is a child unit of a non-generic parent, it may be
5394 -- use-visible and given by a direct name. Install parent as
5397 elsif Is_Generic_Unit (E)
5398 and then Is_Child_Unit (E)
5400 Nkind (Parent (Gen_Id)) not in N_Generic_Renaming_Declaration
5401 and then not Is_Generic_Unit (Scope (E))
5403 if not In_Open_Scopes (Scope (E)) then
5404 Install_Parent (Scope (E));
5405 Parent_Installed := True;
5410 end Check_Generic_Child_Unit;
5412 -----------------------------
5413 -- Check_Hidden_Child_Unit --
5414 -----------------------------
5416 procedure Check_Hidden_Child_Unit
5418 Gen_Unit : Entity_Id;
5419 Act_Decl_Id : Entity_Id)
5421 Gen_Id : constant Node_Id := Name (N);
5424 if Is_Child_Unit (Gen_Unit)
5425 and then Is_Child_Unit (Act_Decl_Id)
5426 and then Nkind (Gen_Id) = N_Expanded_Name
5427 and then Entity (Prefix (Gen_Id)) = Scope (Act_Decl_Id)
5428 and then Chars (Gen_Unit) = Chars (Act_Decl_Id)
5430 Error_Msg_Node_2 := Scope (Act_Decl_Id);
5432 ("generic unit & is implicitly declared in &",
5433 Defining_Unit_Name (N), Gen_Unit);
5434 Error_Msg_N ("\instance must have different name",
5435 Defining_Unit_Name (N));
5437 end Check_Hidden_Child_Unit;
5439 ------------------------
5440 -- Check_Private_View --
5441 ------------------------
5443 procedure Check_Private_View (N : Node_Id) is
5444 T : constant Entity_Id := Etype (N);
5448 -- Exchange views if the type was not private in the generic but is
5449 -- private at the point of instantiation. Do not exchange views if
5450 -- the scope of the type is in scope. This can happen if both generic
5451 -- and instance are sibling units, or if type is defined in a parent.
5452 -- In this case the visibility of the type will be correct for all
5456 BT := Base_Type (T);
5458 if Is_Private_Type (T)
5459 and then not Has_Private_View (N)
5460 and then Present (Full_View (T))
5461 and then not In_Open_Scopes (Scope (T))
5463 -- In the generic, the full type was visible. Save the private
5464 -- entity, for subsequent exchange.
5468 elsif Has_Private_View (N)
5469 and then not Is_Private_Type (T)
5470 and then not Has_Been_Exchanged (T)
5471 and then Etype (Get_Associated_Node (N)) /= T
5473 -- Only the private declaration was visible in the generic. If
5474 -- the type appears in a subtype declaration, the subtype in the
5475 -- instance must have a view compatible with that of its parent,
5476 -- which must be exchanged (see corresponding code in Restore_
5477 -- Private_Views). Otherwise, if the type is defined in a parent
5478 -- unit, leave full visibility within instance, which is safe.
5480 if In_Open_Scopes (Scope (Base_Type (T)))
5481 and then not Is_Private_Type (Base_Type (T))
5482 and then Comes_From_Source (Base_Type (T))
5486 elsif Nkind (Parent (N)) = N_Subtype_Declaration
5487 or else not In_Private_Part (Scope (Base_Type (T)))
5489 Prepend_Elmt (T, Exchanged_Views);
5490 Exchange_Declarations (Etype (Get_Associated_Node (N)));
5493 -- For composite types with inconsistent representation exchange
5494 -- component types accordingly.
5496 elsif Is_Access_Type (T)
5497 and then Is_Private_Type (Designated_Type (T))
5498 and then not Has_Private_View (N)
5499 and then Present (Full_View (Designated_Type (T)))
5501 Switch_View (Designated_Type (T));
5503 elsif Is_Array_Type (T) then
5504 if Is_Private_Type (Component_Type (T))
5505 and then not Has_Private_View (N)
5506 and then Present (Full_View (Component_Type (T)))
5508 Switch_View (Component_Type (T));
5511 -- The normal exchange mechanism relies on the setting of a
5512 -- flag on the reference in the generic. However, an additional
5513 -- mechanism is needed for types that are not explicitly mentioned
5514 -- in the generic, but may be needed in expanded code in the
5515 -- instance. This includes component types of arrays and
5516 -- designated types of access types. This processing must also
5517 -- include the index types of arrays which we take care of here.
5524 Indx := First_Index (T);
5525 Typ := Base_Type (Etype (Indx));
5526 while Present (Indx) loop
5527 if Is_Private_Type (Typ)
5528 and then Present (Full_View (Typ))
5537 elsif Is_Private_Type (T)
5538 and then Present (Full_View (T))
5539 and then Is_Array_Type (Full_View (T))
5540 and then Is_Private_Type (Component_Type (Full_View (T)))
5544 -- Finally, a non-private subtype may have a private base type, which
5545 -- must be exchanged for consistency. This can happen when a package
5546 -- body is instantiated, when the scope stack is empty but in fact
5547 -- the subtype and the base type are declared in an enclosing scope.
5549 -- Note that in this case we introduce an inconsistency in the view
5550 -- set, because we switch the base type BT, but there could be some
5551 -- private dependent subtypes of BT which remain unswitched. Such
5552 -- subtypes might need to be switched at a later point (see specific
5553 -- provision for that case in Switch_View).
5555 elsif not Is_Private_Type (T)
5556 and then not Has_Private_View (N)
5557 and then Is_Private_Type (BT)
5558 and then Present (Full_View (BT))
5559 and then not Is_Generic_Type (BT)
5560 and then not In_Open_Scopes (BT)
5562 Prepend_Elmt (Full_View (BT), Exchanged_Views);
5563 Exchange_Declarations (BT);
5566 end Check_Private_View;
5568 --------------------------
5569 -- Contains_Instance_Of --
5570 --------------------------
5572 function Contains_Instance_Of
5575 N : Node_Id) return Boolean
5583 -- Verify that there are no circular instantiations. We check whether
5584 -- the unit contains an instance of the current scope or some enclosing
5585 -- scope (in case one of the instances appears in a subunit). Longer
5586 -- circularities involving subunits might seem too pathological to
5587 -- consider, but they were not too pathological for the authors of
5588 -- DEC bc30vsq, so we loop over all enclosing scopes, and mark all
5589 -- enclosing generic scopes as containing an instance.
5592 -- Within a generic subprogram body, the scope is not generic, to
5593 -- allow for recursive subprograms. Use the declaration to determine
5594 -- whether this is a generic unit.
5596 if Ekind (Scop) = E_Generic_Package
5597 or else (Is_Subprogram (Scop)
5598 and then Nkind (Unit_Declaration_Node (Scop)) =
5599 N_Generic_Subprogram_Declaration)
5601 Elmt := First_Elmt (Inner_Instances (Inner));
5603 while Present (Elmt) loop
5604 if Node (Elmt) = Scop then
5605 Error_Msg_Node_2 := Inner;
5607 ("circular Instantiation: & instantiated within &!",
5611 elsif Node (Elmt) = Inner then
5614 elsif Contains_Instance_Of (Node (Elmt), Scop, N) then
5615 Error_Msg_Node_2 := Inner;
5617 ("circular Instantiation: & instantiated within &!",
5625 -- Indicate that Inner is being instantiated within Scop
5627 Append_Elmt (Inner, Inner_Instances (Scop));
5630 if Scop = Standard_Standard then
5633 Scop := Scope (Scop);
5638 end Contains_Instance_Of;
5640 -----------------------
5641 -- Copy_Generic_Node --
5642 -----------------------
5644 function Copy_Generic_Node
5646 Parent_Id : Node_Id;
5647 Instantiating : Boolean) return Node_Id
5652 function Copy_Generic_Descendant (D : Union_Id) return Union_Id;
5653 -- Check the given value of one of the Fields referenced by the
5654 -- current node to determine whether to copy it recursively. The
5655 -- field may hold a Node_Id, a List_Id, or an Elist_Id, or a plain
5656 -- value (Sloc, Uint, Char) in which case it need not be copied.
5658 procedure Copy_Descendants;
5659 -- Common utility for various nodes
5661 function Copy_Generic_Elist (E : Elist_Id) return Elist_Id;
5662 -- Make copy of element list
5664 function Copy_Generic_List
5666 Parent_Id : Node_Id) return List_Id;
5667 -- Apply Copy_Node recursively to the members of a node list
5669 function In_Defining_Unit_Name (Nam : Node_Id) return Boolean;
5670 -- True if an identifier is part of the defining program unit name
5671 -- of a child unit. The entity of such an identifier must be kept
5672 -- (for ASIS use) even though as the name of an enclosing generic
5673 -- it would otherwise not be preserved in the generic tree.
5675 ----------------------
5676 -- Copy_Descendants --
5677 ----------------------
5679 procedure Copy_Descendants is
5681 use Atree.Unchecked_Access;
5682 -- This code section is part of the implementation of an untyped
5683 -- tree traversal, so it needs direct access to node fields.
5686 Set_Field1 (New_N, Copy_Generic_Descendant (Field1 (N)));
5687 Set_Field2 (New_N, Copy_Generic_Descendant (Field2 (N)));
5688 Set_Field3 (New_N, Copy_Generic_Descendant (Field3 (N)));
5689 Set_Field4 (New_N, Copy_Generic_Descendant (Field4 (N)));
5690 Set_Field5 (New_N, Copy_Generic_Descendant (Field5 (N)));
5691 end Copy_Descendants;
5693 -----------------------------
5694 -- Copy_Generic_Descendant --
5695 -----------------------------
5697 function Copy_Generic_Descendant (D : Union_Id) return Union_Id is
5699 if D = Union_Id (Empty) then
5702 elsif D in Node_Range then
5704 (Copy_Generic_Node (Node_Id (D), New_N, Instantiating));
5706 elsif D in List_Range then
5707 return Union_Id (Copy_Generic_List (List_Id (D), New_N));
5709 elsif D in Elist_Range then
5710 return Union_Id (Copy_Generic_Elist (Elist_Id (D)));
5712 -- Nothing else is copyable (e.g. Uint values), return as is
5717 end Copy_Generic_Descendant;
5719 ------------------------
5720 -- Copy_Generic_Elist --
5721 ------------------------
5723 function Copy_Generic_Elist (E : Elist_Id) return Elist_Id is
5730 M := First_Elmt (E);
5731 while Present (M) loop
5733 (Copy_Generic_Node (Node (M), Empty, Instantiating), L);
5742 end Copy_Generic_Elist;
5744 -----------------------
5745 -- Copy_Generic_List --
5746 -----------------------
5748 function Copy_Generic_List
5750 Parent_Id : Node_Id) return List_Id
5758 Set_Parent (New_L, Parent_Id);
5761 while Present (N) loop
5762 Append (Copy_Generic_Node (N, Empty, Instantiating), New_L);
5771 end Copy_Generic_List;
5773 ---------------------------
5774 -- In_Defining_Unit_Name --
5775 ---------------------------
5777 function In_Defining_Unit_Name (Nam : Node_Id) return Boolean is
5779 return Present (Parent (Nam))
5780 and then (Nkind (Parent (Nam)) = N_Defining_Program_Unit_Name
5782 (Nkind (Parent (Nam)) = N_Expanded_Name
5783 and then In_Defining_Unit_Name (Parent (Nam))));
5784 end In_Defining_Unit_Name;
5786 -- Start of processing for Copy_Generic_Node
5793 New_N := New_Copy (N);
5795 -- Copy aspects if present
5797 if Has_Aspects (N) then
5798 Set_Has_Aspects (New_N, False);
5799 Set_Aspect_Specifications
5800 (New_N, Copy_Generic_List (Aspect_Specifications (N), Parent_Id));
5803 if Instantiating then
5804 Adjust_Instantiation_Sloc (New_N, S_Adjustment);
5807 if not Is_List_Member (N) then
5808 Set_Parent (New_N, Parent_Id);
5811 -- If defining identifier, then all fields have been copied already
5813 if Nkind (New_N) in N_Entity then
5816 -- Special casing for identifiers and other entity names and operators
5818 elsif Nkind_In (New_N, N_Identifier,
5819 N_Character_Literal,
5822 or else Nkind (New_N) in N_Op
5824 if not Instantiating then
5826 -- Link both nodes in order to assign subsequently the entity of
5827 -- the copy to the original node, in case this is a global
5830 Set_Associated_Node (N, New_N);
5832 -- If we are within an instantiation, this is a nested generic
5833 -- that has already been analyzed at the point of definition. We
5834 -- must preserve references that were global to the enclosing
5835 -- parent at that point. Other occurrences, whether global or
5836 -- local to the current generic, must be resolved anew, so we
5837 -- reset the entity in the generic copy. A global reference has a
5838 -- smaller depth than the parent, or else the same depth in case
5839 -- both are distinct compilation units.
5840 -- A child unit is implicitly declared within the enclosing parent
5841 -- but is in fact global to it, and must be preserved.
5843 -- It is also possible for Current_Instantiated_Parent to be
5844 -- defined, and for this not to be a nested generic, namely if the
5845 -- unit is loaded through Rtsfind. In that case, the entity of
5846 -- New_N is only a link to the associated node, and not a defining
5849 -- The entities for parent units in the defining_program_unit of a
5850 -- generic child unit are established when the context of the unit
5851 -- is first analyzed, before the generic copy is made. They are
5852 -- preserved in the copy for use in ASIS queries.
5854 Ent := Entity (New_N);
5856 if No (Current_Instantiated_Parent.Gen_Id) then
5858 or else Nkind (Ent) /= N_Defining_Identifier
5859 or else not In_Defining_Unit_Name (N)
5861 Set_Associated_Node (New_N, Empty);
5866 not Nkind_In (Ent, N_Defining_Identifier,
5867 N_Defining_Character_Literal,
5868 N_Defining_Operator_Symbol)
5869 or else No (Scope (Ent))
5871 (Scope (Ent) = Current_Instantiated_Parent.Gen_Id
5872 and then not Is_Child_Unit (Ent))
5874 (Scope_Depth (Scope (Ent)) >
5875 Scope_Depth (Current_Instantiated_Parent.Gen_Id)
5877 Get_Source_Unit (Ent) =
5878 Get_Source_Unit (Current_Instantiated_Parent.Gen_Id))
5880 Set_Associated_Node (New_N, Empty);
5883 -- Case of instantiating identifier or some other name or operator
5886 -- If the associated node is still defined, the entity in it is
5887 -- global, and must be copied to the instance. If this copy is
5888 -- being made for a body to inline, it is applied to an
5889 -- instantiated tree, and the entity is already present and must
5890 -- be also preserved.
5893 Assoc : constant Node_Id := Get_Associated_Node (N);
5896 if Present (Assoc) then
5897 if Nkind (Assoc) = Nkind (N) then
5898 Set_Entity (New_N, Entity (Assoc));
5899 Check_Private_View (N);
5901 elsif Nkind (Assoc) = N_Function_Call then
5902 Set_Entity (New_N, Entity (Name (Assoc)));
5904 elsif Nkind_In (Assoc, N_Defining_Identifier,
5905 N_Defining_Character_Literal,
5906 N_Defining_Operator_Symbol)
5907 and then Expander_Active
5909 -- Inlining case: we are copying a tree that contains
5910 -- global entities, which are preserved in the copy to be
5911 -- used for subsequent inlining.
5916 Set_Entity (New_N, Empty);
5922 -- For expanded name, we must copy the Prefix and Selector_Name
5924 if Nkind (N) = N_Expanded_Name then
5926 (New_N, Copy_Generic_Node (Prefix (N), New_N, Instantiating));
5928 Set_Selector_Name (New_N,
5929 Copy_Generic_Node (Selector_Name (N), New_N, Instantiating));
5931 -- For operators, we must copy the right operand
5933 elsif Nkind (N) in N_Op then
5934 Set_Right_Opnd (New_N,
5935 Copy_Generic_Node (Right_Opnd (N), New_N, Instantiating));
5937 -- And for binary operators, the left operand as well
5939 if Nkind (N) in N_Binary_Op then
5940 Set_Left_Opnd (New_N,
5941 Copy_Generic_Node (Left_Opnd (N), New_N, Instantiating));
5945 -- Special casing for stubs
5947 elsif Nkind (N) in N_Body_Stub then
5949 -- In any case, we must copy the specification or defining
5950 -- identifier as appropriate.
5952 if Nkind (N) = N_Subprogram_Body_Stub then
5953 Set_Specification (New_N,
5954 Copy_Generic_Node (Specification (N), New_N, Instantiating));
5957 Set_Defining_Identifier (New_N,
5959 (Defining_Identifier (N), New_N, Instantiating));
5962 -- If we are not instantiating, then this is where we load and
5963 -- analyze subunits, i.e. at the point where the stub occurs. A
5964 -- more permissive system might defer this analysis to the point
5965 -- of instantiation, but this seems to complicated for now.
5967 if not Instantiating then
5969 Subunit_Name : constant Unit_Name_Type := Get_Unit_Name (N);
5971 Unum : Unit_Number_Type;
5975 -- Make sure that, if it is a subunit of the main unit that is
5976 -- preprocessed and if -gnateG is specified, the preprocessed
5977 -- file will be written.
5979 Lib.Analysing_Subunit_Of_Main :=
5980 Lib.In_Extended_Main_Source_Unit (N);
5983 (Load_Name => Subunit_Name,
5987 Lib.Analysing_Subunit_Of_Main := False;
5989 -- If the proper body is not found, a warning message will be
5990 -- emitted when analyzing the stub, or later at the point
5991 -- of instantiation. Here we just leave the stub as is.
5993 if Unum = No_Unit then
5994 Subunits_Missing := True;
5995 goto Subunit_Not_Found;
5998 Subunit := Cunit (Unum);
6000 if Nkind (Unit (Subunit)) /= N_Subunit then
6002 ("found child unit instead of expected SEPARATE subunit",
6004 Error_Msg_Sloc := Sloc (N);
6005 Error_Msg_N ("\to complete stub #", Subunit);
6006 goto Subunit_Not_Found;
6009 -- We must create a generic copy of the subunit, in order to
6010 -- perform semantic analysis on it, and we must replace the
6011 -- stub in the original generic unit with the subunit, in order
6012 -- to preserve non-local references within.
6014 -- Only the proper body needs to be copied. Library_Unit and
6015 -- context clause are simply inherited by the generic copy.
6016 -- Note that the copy (which may be recursive if there are
6017 -- nested subunits) must be done first, before attaching it to
6018 -- the enclosing generic.
6022 (Proper_Body (Unit (Subunit)),
6023 Empty, Instantiating => False);
6025 -- Now place the original proper body in the original generic
6026 -- unit. This is a body, not a compilation unit.
6028 Rewrite (N, Proper_Body (Unit (Subunit)));
6029 Set_Is_Compilation_Unit (Defining_Entity (N), False);
6030 Set_Was_Originally_Stub (N);
6032 -- Finally replace the body of the subunit with its copy, and
6033 -- make this new subunit into the library unit of the generic
6034 -- copy, which does not have stubs any longer.
6036 Set_Proper_Body (Unit (Subunit), New_Body);
6037 Set_Library_Unit (New_N, Subunit);
6038 Inherit_Context (Unit (Subunit), N);
6041 -- If we are instantiating, this must be an error case, since
6042 -- otherwise we would have replaced the stub node by the proper body
6043 -- that corresponds. So just ignore it in the copy (i.e. we have
6044 -- copied it, and that is good enough).
6050 <<Subunit_Not_Found>> null;
6052 -- If the node is a compilation unit, it is the subunit of a stub, which
6053 -- has been loaded already (see code below). In this case, the library
6054 -- unit field of N points to the parent unit (which is a compilation
6055 -- unit) and need not (and cannot!) be copied.
6057 -- When the proper body of the stub is analyzed, the library_unit link
6058 -- is used to establish the proper context (see sem_ch10).
6060 -- The other fields of a compilation unit are copied as usual
6062 elsif Nkind (N) = N_Compilation_Unit then
6064 -- This code can only be executed when not instantiating, because in
6065 -- the copy made for an instantiation, the compilation unit node has
6066 -- disappeared at the point that a stub is replaced by its proper
6069 pragma Assert (not Instantiating);
6071 Set_Context_Items (New_N,
6072 Copy_Generic_List (Context_Items (N), New_N));
6075 Copy_Generic_Node (Unit (N), New_N, False));
6077 Set_First_Inlined_Subprogram (New_N,
6079 (First_Inlined_Subprogram (N), New_N, False));
6081 Set_Aux_Decls_Node (New_N,
6082 Copy_Generic_Node (Aux_Decls_Node (N), New_N, False));
6084 -- For an assignment node, the assignment is known to be semantically
6085 -- legal if we are instantiating the template. This avoids incorrect
6086 -- diagnostics in generated code.
6088 elsif Nkind (N) = N_Assignment_Statement then
6090 -- Copy name and expression fields in usual manner
6093 Copy_Generic_Node (Name (N), New_N, Instantiating));
6095 Set_Expression (New_N,
6096 Copy_Generic_Node (Expression (N), New_N, Instantiating));
6098 if Instantiating then
6099 Set_Assignment_OK (Name (New_N), True);
6102 elsif Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then
6103 if not Instantiating then
6104 Set_Associated_Node (N, New_N);
6107 if Present (Get_Associated_Node (N))
6108 and then Nkind (Get_Associated_Node (N)) = Nkind (N)
6110 -- In the generic the aggregate has some composite type. If at
6111 -- the point of instantiation the type has a private view,
6112 -- install the full view (and that of its ancestors, if any).
6115 T : Entity_Id := (Etype (Get_Associated_Node (New_N)));
6120 and then Is_Private_Type (T)
6126 and then Is_Tagged_Type (T)
6127 and then Is_Derived_Type (T)
6129 Rt := Root_Type (T);
6134 if Is_Private_Type (T) then
6145 -- Do not copy the associated node, which points to
6146 -- the generic copy of the aggregate.
6149 use Atree.Unchecked_Access;
6150 -- This code section is part of the implementation of an untyped
6151 -- tree traversal, so it needs direct access to node fields.
6154 Set_Field1 (New_N, Copy_Generic_Descendant (Field1 (N)));
6155 Set_Field2 (New_N, Copy_Generic_Descendant (Field2 (N)));
6156 Set_Field3 (New_N, Copy_Generic_Descendant (Field3 (N)));
6157 Set_Field5 (New_N, Copy_Generic_Descendant (Field5 (N)));
6160 -- Allocators do not have an identifier denoting the access type,
6161 -- so we must locate it through the expression to check whether
6162 -- the views are consistent.
6164 elsif Nkind (N) = N_Allocator
6165 and then Nkind (Expression (N)) = N_Qualified_Expression
6166 and then Is_Entity_Name (Subtype_Mark (Expression (N)))
6167 and then Instantiating
6170 T : constant Node_Id :=
6171 Get_Associated_Node (Subtype_Mark (Expression (N)));
6177 -- Retrieve the allocator node in the generic copy
6179 Acc_T := Etype (Parent (Parent (T)));
6181 and then Is_Private_Type (Acc_T)
6183 Switch_View (Acc_T);
6190 -- For a proper body, we must catch the case of a proper body that
6191 -- replaces a stub. This represents the point at which a separate
6192 -- compilation unit, and hence template file, may be referenced, so we
6193 -- must make a new source instantiation entry for the template of the
6194 -- subunit, and ensure that all nodes in the subunit are adjusted using
6195 -- this new source instantiation entry.
6197 elsif Nkind (N) in N_Proper_Body then
6199 Save_Adjustment : constant Sloc_Adjustment := S_Adjustment;
6202 if Instantiating and then Was_Originally_Stub (N) then
6203 Create_Instantiation_Source
6204 (Instantiation_Node,
6205 Defining_Entity (N),
6210 -- Now copy the fields of the proper body, using the new
6211 -- adjustment factor if one was needed as per test above.
6215 -- Restore the original adjustment factor in case changed
6217 S_Adjustment := Save_Adjustment;
6220 -- Don't copy Ident or Comment pragmas, since the comment belongs to the
6221 -- generic unit, not to the instantiating unit.
6223 elsif Nkind (N) = N_Pragma
6224 and then Instantiating
6227 Prag_Id : constant Pragma_Id := Get_Pragma_Id (N);
6229 if Prag_Id = Pragma_Ident
6230 or else Prag_Id = Pragma_Comment
6232 New_N := Make_Null_Statement (Sloc (N));
6238 elsif Nkind_In (N, N_Integer_Literal, N_Real_Literal) then
6240 -- No descendant fields need traversing
6244 elsif Nkind (N) = N_String_Literal
6245 and then Present (Etype (N))
6246 and then Instantiating
6248 -- If the string is declared in an outer scope, the string_literal
6249 -- subtype created for it may have the wrong scope. We force the
6250 -- reanalysis of the constant to generate a new itype in the proper
6253 Set_Etype (New_N, Empty);
6254 Set_Analyzed (New_N, False);
6256 -- For the remaining nodes, copy their descendants recursively
6262 and then Nkind (N) = N_Subprogram_Body
6264 Set_Generic_Parent (Specification (New_N), N);
6269 end Copy_Generic_Node;
6271 ----------------------------
6272 -- Denotes_Formal_Package --
6273 ----------------------------
6275 function Denotes_Formal_Package
6277 On_Exit : Boolean := False;
6278 Instance : Entity_Id := Empty) return Boolean
6281 Scop : constant Entity_Id := Scope (Pack);
6284 function Is_Actual_Of_Previous_Formal (P : Entity_Id) return Boolean;
6285 -- The package in question may be an actual for a previous formal
6286 -- package P of the current instance, so examine its actuals as well.
6287 -- This must be recursive over other formal packages.
6289 ----------------------------------
6290 -- Is_Actual_Of_Previous_Formal --
6291 ----------------------------------
6293 function Is_Actual_Of_Previous_Formal (P : Entity_Id) return Boolean is
6297 E1 := First_Entity (P);
6298 while Present (E1) and then E1 /= Instance loop
6299 if Ekind (E1) = E_Package
6300 and then Nkind (Parent (E1)) = N_Package_Renaming_Declaration
6302 if Renamed_Object (E1) = Pack then
6306 or else Renamed_Object (E1) = P
6310 elsif Is_Actual_Of_Previous_Formal (E1) then
6319 end Is_Actual_Of_Previous_Formal;
6321 -- Start of processing for Denotes_Formal_Package
6327 (Instance_Envs.Last).Instantiated_Parent.Act_Id;
6329 Par := Current_Instantiated_Parent.Act_Id;
6332 if Ekind (Scop) = E_Generic_Package
6333 or else Nkind (Unit_Declaration_Node (Scop)) =
6334 N_Generic_Subprogram_Declaration
6338 elsif Nkind (Original_Node (Unit_Declaration_Node (Pack))) =
6339 N_Formal_Package_Declaration
6347 -- Check whether this package is associated with a formal package of
6348 -- the enclosing instantiation. Iterate over the list of renamings.
6350 E := First_Entity (Par);
6351 while Present (E) loop
6352 if Ekind (E) /= E_Package
6353 or else Nkind (Parent (E)) /= N_Package_Renaming_Declaration
6357 elsif Renamed_Object (E) = Par then
6360 elsif Renamed_Object (E) = Pack then
6363 elsif Is_Actual_Of_Previous_Formal (E) then
6373 end Denotes_Formal_Package;
6379 procedure End_Generic is
6381 -- ??? More things could be factored out in this routine. Should
6382 -- probably be done at a later stage.
6384 Inside_A_Generic := Generic_Flags.Table (Generic_Flags.Last);
6385 Generic_Flags.Decrement_Last;
6387 Expander_Mode_Restore;
6390 ----------------------
6391 -- Find_Actual_Type --
6392 ----------------------
6394 function Find_Actual_Type
6396 Gen_Type : Entity_Id) return Entity_Id
6398 Gen_Scope : constant Entity_Id := Scope (Gen_Type);
6402 -- Special processing only applies to child units
6404 if not Is_Child_Unit (Gen_Scope) then
6405 return Get_Instance_Of (Typ);
6407 -- If designated or component type is itself a formal of the child unit,
6408 -- its instance is available.
6410 elsif Scope (Typ) = Gen_Scope then
6411 return Get_Instance_Of (Typ);
6413 -- If the array or access type is not declared in the parent unit,
6414 -- no special processing needed.
6416 elsif not Is_Generic_Type (Typ)
6417 and then Scope (Gen_Scope) /= Scope (Typ)
6419 return Get_Instance_Of (Typ);
6421 -- Otherwise, retrieve designated or component type by visibility
6424 T := Current_Entity (Typ);
6425 while Present (T) loop
6426 if In_Open_Scopes (Scope (T)) then
6429 elsif Is_Generic_Actual_Type (T) then
6438 end Find_Actual_Type;
6440 ----------------------------
6441 -- Freeze_Subprogram_Body --
6442 ----------------------------
6444 procedure Freeze_Subprogram_Body
6445 (Inst_Node : Node_Id;
6447 Pack_Id : Entity_Id)
6450 Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node);
6451 Par : constant Entity_Id := Scope (Gen_Unit);
6456 function Earlier (N1, N2 : Node_Id) return Boolean;
6457 -- Yields True if N1 and N2 appear in the same compilation unit,
6458 -- ignoring subunits, and if N1 is to the left of N2 in a left-to-right
6459 -- traversal of the tree for the unit.
6461 function Enclosing_Body (N : Node_Id) return Node_Id;
6462 -- Find innermost package body that encloses the given node, and which
6463 -- is not a compilation unit. Freeze nodes for the instance, or for its
6464 -- enclosing body, may be inserted after the enclosing_body of the
6467 function Package_Freeze_Node (B : Node_Id) return Node_Id;
6468 -- Find entity for given package body, and locate or create a freeze
6471 function True_Parent (N : Node_Id) return Node_Id;
6472 -- For a subunit, return parent of corresponding stub
6478 function Earlier (N1, N2 : Node_Id) return Boolean is
6484 procedure Find_Depth (P : in out Node_Id; D : in out Integer);
6485 -- Find distance from given node to enclosing compilation unit
6491 procedure Find_Depth (P : in out Node_Id; D : in out Integer) is
6494 and then Nkind (P) /= N_Compilation_Unit
6496 P := True_Parent (P);
6501 -- Start of processing for Earlier
6504 Find_Depth (P1, D1);
6505 Find_Depth (P2, D2);
6515 P1 := True_Parent (P1);
6520 P2 := True_Parent (P2);
6524 -- At this point P1 and P2 are at the same distance from the root.
6525 -- We examine their parents until we find a common declarative
6526 -- list, at which point we can establish their relative placement
6527 -- by comparing their ultimate slocs. If we reach the root,
6528 -- N1 and N2 do not descend from the same declarative list (e.g.
6529 -- one is nested in the declarative part and the other is in a block
6530 -- in the statement part) and the earlier one is already frozen.
6532 while not Is_List_Member (P1)
6533 or else not Is_List_Member (P2)
6534 or else List_Containing (P1) /= List_Containing (P2)
6536 P1 := True_Parent (P1);
6537 P2 := True_Parent (P2);
6539 if Nkind (Parent (P1)) = N_Subunit then
6540 P1 := Corresponding_Stub (Parent (P1));
6543 if Nkind (Parent (P2)) = N_Subunit then
6544 P2 := Corresponding_Stub (Parent (P2));
6553 Top_Level_Location (Sloc (P1)) < Top_Level_Location (Sloc (P2));
6556 --------------------
6557 -- Enclosing_Body --
6558 --------------------
6560 function Enclosing_Body (N : Node_Id) return Node_Id is
6561 P : Node_Id := Parent (N);
6565 and then Nkind (Parent (P)) /= N_Compilation_Unit
6567 if Nkind (P) = N_Package_Body then
6569 if Nkind (Parent (P)) = N_Subunit then
6570 return Corresponding_Stub (Parent (P));
6576 P := True_Parent (P);
6582 -------------------------
6583 -- Package_Freeze_Node --
6584 -------------------------
6586 function Package_Freeze_Node (B : Node_Id) return Node_Id is
6590 if Nkind (B) = N_Package_Body then
6591 Id := Corresponding_Spec (B);
6593 else pragma Assert (Nkind (B) = N_Package_Body_Stub);
6594 Id := Corresponding_Spec (Proper_Body (Unit (Library_Unit (B))));
6597 Ensure_Freeze_Node (Id);
6598 return Freeze_Node (Id);
6599 end Package_Freeze_Node;
6605 function True_Parent (N : Node_Id) return Node_Id is
6607 if Nkind (Parent (N)) = N_Subunit then
6608 return Parent (Corresponding_Stub (Parent (N)));
6614 -- Start of processing of Freeze_Subprogram_Body
6617 -- If the instance and the generic body appear within the same unit, and
6618 -- the instance precedes the generic, the freeze node for the instance
6619 -- must appear after that of the generic. If the generic is nested
6620 -- within another instance I2, then current instance must be frozen
6621 -- after I2. In both cases, the freeze nodes are those of enclosing
6622 -- packages. Otherwise, the freeze node is placed at the end of the
6623 -- current declarative part.
6625 Enc_G := Enclosing_Body (Gen_Body);
6626 Enc_I := Enclosing_Body (Inst_Node);
6627 Ensure_Freeze_Node (Pack_Id);
6628 F_Node := Freeze_Node (Pack_Id);
6630 if Is_Generic_Instance (Par)
6631 and then Present (Freeze_Node (Par))
6633 In_Same_Declarative_Part (Freeze_Node (Par), Inst_Node)
6635 if ABE_Is_Certain (Get_Package_Instantiation_Node (Par)) then
6637 -- The parent was a premature instantiation. Insert freeze node at
6638 -- the end the current declarative part.
6640 Insert_After_Last_Decl (Inst_Node, F_Node);
6643 Insert_After (Freeze_Node (Par), F_Node);
6646 -- The body enclosing the instance should be frozen after the body that
6647 -- includes the generic, because the body of the instance may make
6648 -- references to entities therein. If the two are not in the same
6649 -- declarative part, or if the one enclosing the instance is frozen
6650 -- already, freeze the instance at the end of the current declarative
6653 elsif Is_Generic_Instance (Par)
6654 and then Present (Freeze_Node (Par))
6655 and then Present (Enc_I)
6657 if In_Same_Declarative_Part (Freeze_Node (Par), Enc_I)
6659 (Nkind (Enc_I) = N_Package_Body
6661 In_Same_Declarative_Part (Freeze_Node (Par), Parent (Enc_I)))
6663 -- The enclosing package may contain several instances. Rather
6664 -- than computing the earliest point at which to insert its
6665 -- freeze node, we place it at the end of the declarative part
6666 -- of the parent of the generic.
6668 Insert_After_Last_Decl
6669 (Freeze_Node (Par), Package_Freeze_Node (Enc_I));
6672 Insert_After_Last_Decl (Inst_Node, F_Node);
6674 elsif Present (Enc_G)
6675 and then Present (Enc_I)
6676 and then Enc_G /= Enc_I
6677 and then Earlier (Inst_Node, Gen_Body)
6679 if Nkind (Enc_G) = N_Package_Body then
6680 E_G_Id := Corresponding_Spec (Enc_G);
6681 else pragma Assert (Nkind (Enc_G) = N_Package_Body_Stub);
6683 Corresponding_Spec (Proper_Body (Unit (Library_Unit (Enc_G))));
6686 -- Freeze package that encloses instance, and place node after
6687 -- package that encloses generic. If enclosing package is already
6688 -- frozen we have to assume it is at the proper place. This may be
6689 -- a potential ABE that requires dynamic checking. Do not add a
6690 -- freeze node if the package that encloses the generic is inside
6691 -- the body that encloses the instance, because the freeze node
6692 -- would be in the wrong scope. Additional contortions needed if
6693 -- the bodies are within a subunit.
6696 Enclosing_Body : Node_Id;
6699 if Nkind (Enc_I) = N_Package_Body_Stub then
6700 Enclosing_Body := Proper_Body (Unit (Library_Unit (Enc_I)));
6702 Enclosing_Body := Enc_I;
6705 if Parent (List_Containing (Enc_G)) /= Enclosing_Body then
6706 Insert_After_Last_Decl (Enc_G, Package_Freeze_Node (Enc_I));
6710 -- Freeze enclosing subunit before instance
6712 Ensure_Freeze_Node (E_G_Id);
6714 if not Is_List_Member (Freeze_Node (E_G_Id)) then
6715 Insert_After (Enc_G, Freeze_Node (E_G_Id));
6718 Insert_After_Last_Decl (Inst_Node, F_Node);
6721 -- If none of the above, insert freeze node at the end of the current
6722 -- declarative part.
6724 Insert_After_Last_Decl (Inst_Node, F_Node);
6726 end Freeze_Subprogram_Body;
6732 function Get_Gen_Id (E : Assoc_Ptr) return Entity_Id is
6734 return Generic_Renamings.Table (E).Gen_Id;
6737 ---------------------
6738 -- Get_Instance_Of --
6739 ---------------------
6741 function Get_Instance_Of (A : Entity_Id) return Entity_Id is
6742 Res : constant Assoc_Ptr := Generic_Renamings_HTable.Get (A);
6745 if Res /= Assoc_Null then
6746 return Generic_Renamings.Table (Res).Act_Id;
6748 -- On exit, entity is not instantiated: not a generic parameter, or
6749 -- else parameter of an inner generic unit.
6753 end Get_Instance_Of;
6755 ------------------------------------
6756 -- Get_Package_Instantiation_Node --
6757 ------------------------------------
6759 function Get_Package_Instantiation_Node (A : Entity_Id) return Node_Id is
6760 Decl : Node_Id := Unit_Declaration_Node (A);
6764 -- If the Package_Instantiation attribute has been set on the package
6765 -- entity, then use it directly when it (or its Original_Node) refers
6766 -- to an N_Package_Instantiation node. In principle it should be
6767 -- possible to have this field set in all cases, which should be
6768 -- investigated, and would allow this function to be significantly
6771 if Present (Package_Instantiation (A)) then
6772 if Nkind (Package_Instantiation (A)) = N_Package_Instantiation then
6773 return Package_Instantiation (A);
6775 elsif Nkind (Original_Node (Package_Instantiation (A))) =
6776 N_Package_Instantiation
6778 return Original_Node (Package_Instantiation (A));
6782 -- If the instantiation is a compilation unit that does not need body
6783 -- then the instantiation node has been rewritten as a package
6784 -- declaration for the instance, and we return the original node.
6786 -- If it is a compilation unit and the instance node has not been
6787 -- rewritten, then it is still the unit of the compilation. Finally, if
6788 -- a body is present, this is a parent of the main unit whose body has
6789 -- been compiled for inlining purposes, and the instantiation node has
6790 -- been rewritten with the instance body.
6792 -- Otherwise the instantiation node appears after the declaration. If
6793 -- the entity is a formal package, the declaration may have been
6794 -- rewritten as a generic declaration (in the case of a formal with box)
6795 -- or left as a formal package declaration if it has actuals, and is
6796 -- found with a forward search.
6798 if Nkind (Parent (Decl)) = N_Compilation_Unit then
6799 if Nkind (Decl) = N_Package_Declaration
6800 and then Present (Corresponding_Body (Decl))
6802 Decl := Unit_Declaration_Node (Corresponding_Body (Decl));
6805 if Nkind (Original_Node (Decl)) = N_Package_Instantiation then
6806 return Original_Node (Decl);
6808 return Unit (Parent (Decl));
6811 elsif Nkind (Decl) = N_Package_Declaration
6812 and then Nkind (Original_Node (Decl)) = N_Formal_Package_Declaration
6814 return Original_Node (Decl);
6817 Inst := Next (Decl);
6818 while not Nkind_In (Inst, N_Package_Instantiation,
6819 N_Formal_Package_Declaration)
6826 end Get_Package_Instantiation_Node;
6828 ------------------------
6829 -- Has_Been_Exchanged --
6830 ------------------------
6832 function Has_Been_Exchanged (E : Entity_Id) return Boolean is
6836 Next := First_Elmt (Exchanged_Views);
6837 while Present (Next) loop
6838 if Full_View (Node (Next)) = E then
6846 end Has_Been_Exchanged;
6852 function Hash (F : Entity_Id) return HTable_Range is
6854 return HTable_Range (F mod HTable_Size);
6857 ------------------------
6858 -- Hide_Current_Scope --
6859 ------------------------
6861 procedure Hide_Current_Scope is
6862 C : constant Entity_Id := Current_Scope;
6866 Set_Is_Hidden_Open_Scope (C);
6868 E := First_Entity (C);
6869 while Present (E) loop
6870 if Is_Immediately_Visible (E) then
6871 Set_Is_Immediately_Visible (E, False);
6872 Append_Elmt (E, Hidden_Entities);
6878 -- Make the scope name invisible as well. This is necessary, but might
6879 -- conflict with calls to Rtsfind later on, in case the scope is a
6880 -- predefined one. There is no clean solution to this problem, so for
6881 -- now we depend on the user not redefining Standard itself in one of
6882 -- the parent units.
6884 if Is_Immediately_Visible (C)
6885 and then C /= Standard_Standard
6887 Set_Is_Immediately_Visible (C, False);
6888 Append_Elmt (C, Hidden_Entities);
6891 end Hide_Current_Scope;
6897 procedure Init_Env is
6898 Saved : Instance_Env;
6901 Saved.Instantiated_Parent := Current_Instantiated_Parent;
6902 Saved.Exchanged_Views := Exchanged_Views;
6903 Saved.Hidden_Entities := Hidden_Entities;
6904 Saved.Current_Sem_Unit := Current_Sem_Unit;
6905 Saved.Parent_Unit_Visible := Parent_Unit_Visible;
6906 Saved.Instance_Parent_Unit := Instance_Parent_Unit;
6908 -- Save configuration switches. These may be reset if the unit is a
6909 -- predefined unit, and the current mode is not Ada 2005.
6911 Save_Opt_Config_Switches (Saved.Switches);
6913 Instance_Envs.Append (Saved);
6915 Exchanged_Views := New_Elmt_List;
6916 Hidden_Entities := New_Elmt_List;
6918 -- Make dummy entry for Instantiated parent. If generic unit is legal,
6919 -- this is set properly in Set_Instance_Env.
6921 Current_Instantiated_Parent :=
6922 (Current_Scope, Current_Scope, Assoc_Null);
6925 ------------------------------
6926 -- In_Same_Declarative_Part --
6927 ------------------------------
6929 function In_Same_Declarative_Part
6931 Inst : Node_Id) return Boolean
6933 Decls : constant Node_Id := Parent (F_Node);
6934 Nod : Node_Id := Parent (Inst);
6937 while Present (Nod) loop
6941 elsif Nkind_In (Nod, N_Subprogram_Body,
6949 elsif Nkind (Nod) = N_Subunit then
6950 Nod := Corresponding_Stub (Nod);
6952 elsif Nkind (Nod) = N_Compilation_Unit then
6956 Nod := Parent (Nod);
6961 end In_Same_Declarative_Part;
6963 ---------------------
6964 -- In_Main_Context --
6965 ---------------------
6967 function In_Main_Context (E : Entity_Id) return Boolean is
6973 if not Is_Compilation_Unit (E)
6974 or else Ekind (E) /= E_Package
6975 or else In_Private_Part (E)
6980 Context := Context_Items (Cunit (Main_Unit));
6982 Clause := First (Context);
6983 while Present (Clause) loop
6984 if Nkind (Clause) = N_With_Clause then
6985 Nam := Name (Clause);
6987 -- If the current scope is part of the context of the main unit,
6988 -- analysis of the corresponding with_clause is not complete, and
6989 -- the entity is not set. We use the Chars field directly, which
6990 -- might produce false positives in rare cases, but guarantees
6991 -- that we produce all the instance bodies we will need.
6993 if (Is_Entity_Name (Nam)
6994 and then Chars (Nam) = Chars (E))
6995 or else (Nkind (Nam) = N_Selected_Component
6996 and then Chars (Selector_Name (Nam)) = Chars (E))
7006 end In_Main_Context;
7008 ---------------------
7009 -- Inherit_Context --
7010 ---------------------
7012 procedure Inherit_Context (Gen_Decl : Node_Id; Inst : Node_Id) is
7013 Current_Context : List_Id;
7014 Current_Unit : Node_Id;
7019 if Nkind (Parent (Gen_Decl)) = N_Compilation_Unit then
7021 -- The inherited context is attached to the enclosing compilation
7022 -- unit. This is either the main unit, or the declaration for the
7023 -- main unit (in case the instantiation appears within the package
7024 -- declaration and the main unit is its body).
7026 Current_Unit := Parent (Inst);
7027 while Present (Current_Unit)
7028 and then Nkind (Current_Unit) /= N_Compilation_Unit
7030 Current_Unit := Parent (Current_Unit);
7033 Current_Context := Context_Items (Current_Unit);
7035 Item := First (Context_Items (Parent (Gen_Decl)));
7036 while Present (Item) loop
7037 if Nkind (Item) = N_With_Clause then
7039 -- Take care to prevent direct cyclic with's, which can happen
7040 -- if the generic body with's the current unit. Such a case
7041 -- would result in binder errors (or run-time errors if the
7042 -- -gnatE switch is in effect), but we want to prevent it here,
7043 -- because Sem.Walk_Library_Items doesn't like cycles. Note
7044 -- that we don't bother to detect indirect cycles.
7046 if Library_Unit (Item) /= Current_Unit then
7047 New_I := New_Copy (Item);
7048 Set_Implicit_With (New_I, True);
7049 Append (New_I, Current_Context);
7056 end Inherit_Context;
7062 procedure Initialize is
7064 Generic_Renamings.Init;
7067 Generic_Renamings_HTable.Reset;
7068 Circularity_Detected := False;
7069 Exchanged_Views := No_Elist;
7070 Hidden_Entities := No_Elist;
7073 ----------------------------
7074 -- Insert_After_Last_Decl --
7075 ----------------------------
7077 procedure Insert_After_Last_Decl (N : Node_Id; F_Node : Node_Id) is
7078 L : List_Id := List_Containing (N);
7079 P : constant Node_Id := Parent (L);
7082 if not Is_List_Member (F_Node) then
7083 if Nkind (P) = N_Package_Specification
7084 and then L = Visible_Declarations (P)
7085 and then Present (Private_Declarations (P))
7086 and then not Is_Empty_List (Private_Declarations (P))
7088 L := Private_Declarations (P);
7091 Insert_After (Last (L), F_Node);
7093 end Insert_After_Last_Decl;
7099 procedure Install_Body
7100 (Act_Body : Node_Id;
7105 Act_Id : constant Entity_Id := Corresponding_Spec (Act_Body);
7106 Act_Unit : constant Node_Id := Unit (Cunit (Get_Source_Unit (N)));
7107 Gen_Id : constant Entity_Id := Corresponding_Spec (Gen_Body);
7108 Par : constant Entity_Id := Scope (Gen_Id);
7109 Gen_Unit : constant Node_Id :=
7110 Unit (Cunit (Get_Source_Unit (Gen_Decl)));
7111 Orig_Body : Node_Id := Gen_Body;
7113 Body_Unit : Node_Id;
7115 Must_Delay : Boolean;
7117 function Enclosing_Subp (Id : Entity_Id) return Entity_Id;
7118 -- Find subprogram (if any) that encloses instance and/or generic body
7120 function True_Sloc (N : Node_Id) return Source_Ptr;
7121 -- If the instance is nested inside a generic unit, the Sloc of the
7122 -- instance indicates the place of the original definition, not the
7123 -- point of the current enclosing instance. Pending a better usage of
7124 -- Slocs to indicate instantiation places, we determine the place of
7125 -- origin of a node by finding the maximum sloc of any ancestor node.
7126 -- Why is this not equivalent to Top_Level_Location ???
7128 --------------------
7129 -- Enclosing_Subp --
7130 --------------------
7132 function Enclosing_Subp (Id : Entity_Id) return Entity_Id is
7133 Scop : Entity_Id := Scope (Id);
7136 while Scop /= Standard_Standard
7137 and then not Is_Overloadable (Scop)
7139 Scop := Scope (Scop);
7149 function True_Sloc (N : Node_Id) return Source_Ptr is
7156 while Present (N1) and then N1 /= Act_Unit loop
7157 if Sloc (N1) > Res then
7167 -- Start of processing for Install_Body
7171 -- If the body is a subunit, the freeze point is the corresponding
7172 -- stub in the current compilation, not the subunit itself.
7174 if Nkind (Parent (Gen_Body)) = N_Subunit then
7175 Orig_Body := Corresponding_Stub (Parent (Gen_Body));
7177 Orig_Body := Gen_Body;
7180 Body_Unit := Unit (Cunit (Get_Source_Unit (Orig_Body)));
7182 -- If the instantiation and the generic definition appear in the same
7183 -- package declaration, this is an early instantiation. If they appear
7184 -- in the same declarative part, it is an early instantiation only if
7185 -- the generic body appears textually later, and the generic body is
7186 -- also in the main unit.
7188 -- If instance is nested within a subprogram, and the generic body is
7189 -- not, the instance is delayed because the enclosing body is. If
7190 -- instance and body are within the same scope, or the same sub-
7191 -- program body, indicate explicitly that the instance is delayed.
7194 (Gen_Unit = Act_Unit
7195 and then (Nkind_In (Gen_Unit, N_Package_Declaration,
7196 N_Generic_Package_Declaration)
7197 or else (Gen_Unit = Body_Unit
7198 and then True_Sloc (N) < Sloc (Orig_Body)))
7199 and then Is_In_Main_Unit (Gen_Unit)
7200 and then (Scope (Act_Id) = Scope (Gen_Id)
7202 Enclosing_Subp (Act_Id) = Enclosing_Subp (Gen_Id)));
7204 -- If this is an early instantiation, the freeze node is placed after
7205 -- the generic body. Otherwise, if the generic appears in an instance,
7206 -- we cannot freeze the current instance until the outer one is frozen.
7207 -- This is only relevant if the current instance is nested within some
7208 -- inner scope not itself within the outer instance. If this scope is
7209 -- a package body in the same declarative part as the outer instance,
7210 -- then that body needs to be frozen after the outer instance. Finally,
7211 -- if no delay is needed, we place the freeze node at the end of the
7212 -- current declarative part.
7214 if Expander_Active then
7215 Ensure_Freeze_Node (Act_Id);
7216 F_Node := Freeze_Node (Act_Id);
7219 Insert_After (Orig_Body, F_Node);
7221 elsif Is_Generic_Instance (Par)
7222 and then Present (Freeze_Node (Par))
7223 and then Scope (Act_Id) /= Par
7225 -- Freeze instance of inner generic after instance of enclosing
7228 if In_Same_Declarative_Part (Freeze_Node (Par), N) then
7229 Insert_After (Freeze_Node (Par), F_Node);
7231 -- Freeze package enclosing instance of inner generic after
7232 -- instance of enclosing generic.
7234 elsif Nkind (Parent (N)) = N_Package_Body
7235 and then In_Same_Declarative_Part (Freeze_Node (Par), Parent (N))
7239 Enclosing : constant Entity_Id :=
7240 Corresponding_Spec (Parent (N));
7243 Insert_After_Last_Decl (N, F_Node);
7244 Ensure_Freeze_Node (Enclosing);
7246 if not Is_List_Member (Freeze_Node (Enclosing)) then
7247 Insert_After (Freeze_Node (Par), Freeze_Node (Enclosing));
7252 Insert_After_Last_Decl (N, F_Node);
7256 Insert_After_Last_Decl (N, F_Node);
7260 Set_Is_Frozen (Act_Id);
7261 Insert_Before (N, Act_Body);
7262 Mark_Rewrite_Insertion (Act_Body);
7265 -----------------------------
7266 -- Install_Formal_Packages --
7267 -----------------------------
7269 procedure Install_Formal_Packages (Par : Entity_Id) is
7272 Gen_E : Entity_Id := Empty;
7275 E := First_Entity (Par);
7277 -- In we are installing an instance parent, locate the formal packages
7278 -- of its generic parent.
7280 if Is_Generic_Instance (Par) then
7281 Gen := Generic_Parent (Specification (Unit_Declaration_Node (Par)));
7282 Gen_E := First_Entity (Gen);
7285 while Present (E) loop
7286 if Ekind (E) = E_Package
7287 and then Nkind (Parent (E)) = N_Package_Renaming_Declaration
7289 -- If this is the renaming for the parent instance, done
7291 if Renamed_Object (E) = Par then
7294 -- The visibility of a formal of an enclosing generic is already
7297 elsif Denotes_Formal_Package (E) then
7300 elsif Present (Associated_Formal_Package (E)) then
7301 Check_Generic_Actuals (Renamed_Object (E), True);
7302 Set_Is_Hidden (E, False);
7304 -- Find formal package in generic unit that corresponds to
7305 -- (instance of) formal package in instance.
7307 while Present (Gen_E) and then Chars (Gen_E) /= Chars (E) loop
7308 Next_Entity (Gen_E);
7311 if Present (Gen_E) then
7312 Map_Formal_Package_Entities (Gen_E, E);
7318 if Present (Gen_E) then
7319 Next_Entity (Gen_E);
7322 end Install_Formal_Packages;
7324 --------------------
7325 -- Install_Parent --
7326 --------------------
7328 procedure Install_Parent (P : Entity_Id; In_Body : Boolean := False) is
7329 Ancestors : constant Elist_Id := New_Elmt_List;
7330 S : constant Entity_Id := Current_Scope;
7331 Inst_Par : Entity_Id;
7332 First_Par : Entity_Id;
7333 Inst_Node : Node_Id;
7334 Gen_Par : Entity_Id;
7335 First_Gen : Entity_Id;
7338 procedure Install_Noninstance_Specs (Par : Entity_Id);
7339 -- Install the scopes of noninstance parent units ending with Par
7341 procedure Install_Spec (Par : Entity_Id);
7342 -- The child unit is within the declarative part of the parent, so
7343 -- the declarations within the parent are immediately visible.
7345 -------------------------------
7346 -- Install_Noninstance_Specs --
7347 -------------------------------
7349 procedure Install_Noninstance_Specs (Par : Entity_Id) is
7352 and then Par /= Standard_Standard
7353 and then not In_Open_Scopes (Par)
7355 Install_Noninstance_Specs (Scope (Par));
7358 end Install_Noninstance_Specs;
7364 procedure Install_Spec (Par : Entity_Id) is
7365 Spec : constant Node_Id :=
7366 Specification (Unit_Declaration_Node (Par));
7369 -- If this parent of the child instance is a top-level unit,
7370 -- then record the unit and its visibility for later resetting
7371 -- in Remove_Parent. We exclude units that are generic instances,
7372 -- as we only want to record this information for the ultimate
7373 -- top-level noninstance parent (is that always correct???).
7375 if Scope (Par) = Standard_Standard
7376 and then not Is_Generic_Instance (Par)
7378 Parent_Unit_Visible := Is_Immediately_Visible (Par);
7379 Instance_Parent_Unit := Par;
7382 -- Open the parent scope and make it and its declarations visible.
7383 -- If this point is not within a body, then only the visible
7384 -- declarations should be made visible, and installation of the
7385 -- private declarations is deferred until the appropriate point
7386 -- within analysis of the spec being instantiated (see the handling
7387 -- of parent visibility in Analyze_Package_Specification). This is
7388 -- relaxed in the case where the parent unit is Ada.Tags, to avoid
7389 -- private view problems that occur when compiling instantiations of
7390 -- a generic child of that package (Generic_Dispatching_Constructor).
7391 -- If the instance freezes a tagged type, inlinings of operations
7392 -- from Ada.Tags may need the full view of type Tag. If inlining took
7393 -- proper account of establishing visibility of inlined subprograms'
7394 -- parents then it should be possible to remove this
7395 -- special check. ???
7398 Set_Is_Immediately_Visible (Par);
7399 Install_Visible_Declarations (Par);
7400 Set_Use (Visible_Declarations (Spec));
7402 if In_Body or else Is_RTU (Par, Ada_Tags) then
7403 Install_Private_Declarations (Par);
7404 Set_Use (Private_Declarations (Spec));
7408 -- Start of processing for Install_Parent
7411 -- We need to install the parent instance to compile the instantiation
7412 -- of the child, but the child instance must appear in the current
7413 -- scope. Given that we cannot place the parent above the current scope
7414 -- in the scope stack, we duplicate the current scope and unstack both
7415 -- after the instantiation is complete.
7417 -- If the parent is itself the instantiation of a child unit, we must
7418 -- also stack the instantiation of its parent, and so on. Each such
7419 -- ancestor is the prefix of the name in a prior instantiation.
7421 -- If this is a nested instance, the parent unit itself resolves to
7422 -- a renaming of the parent instance, whose declaration we need.
7424 -- Finally, the parent may be a generic (not an instance) when the
7425 -- child unit appears as a formal package.
7429 if Present (Renamed_Entity (Inst_Par)) then
7430 Inst_Par := Renamed_Entity (Inst_Par);
7433 First_Par := Inst_Par;
7436 Generic_Parent (Specification (Unit_Declaration_Node (Inst_Par)));
7438 First_Gen := Gen_Par;
7440 while Present (Gen_Par)
7441 and then Is_Child_Unit (Gen_Par)
7443 -- Load grandparent instance as well
7445 Inst_Node := Get_Package_Instantiation_Node (Inst_Par);
7447 if Nkind (Name (Inst_Node)) = N_Expanded_Name then
7448 Inst_Par := Entity (Prefix (Name (Inst_Node)));
7450 if Present (Renamed_Entity (Inst_Par)) then
7451 Inst_Par := Renamed_Entity (Inst_Par);
7456 (Specification (Unit_Declaration_Node (Inst_Par)));
7458 if Present (Gen_Par) then
7459 Prepend_Elmt (Inst_Par, Ancestors);
7462 -- Parent is not the name of an instantiation
7464 Install_Noninstance_Specs (Inst_Par);
7476 if Present (First_Gen) then
7477 Append_Elmt (First_Par, Ancestors);
7480 Install_Noninstance_Specs (First_Par);
7483 if not Is_Empty_Elmt_List (Ancestors) then
7484 Elmt := First_Elmt (Ancestors);
7486 while Present (Elmt) loop
7487 Install_Spec (Node (Elmt));
7488 Install_Formal_Packages (Node (Elmt));
7499 --------------------------------
7500 -- Instantiate_Formal_Package --
7501 --------------------------------
7503 function Instantiate_Formal_Package
7506 Analyzed_Formal : Node_Id) return List_Id
7508 Loc : constant Source_Ptr := Sloc (Actual);
7509 Actual_Pack : Entity_Id;
7510 Formal_Pack : Entity_Id;
7511 Gen_Parent : Entity_Id;
7514 Parent_Spec : Node_Id;
7516 procedure Find_Matching_Actual
7518 Act : in out Entity_Id);
7519 -- We need to associate each formal entity in the formal package
7520 -- with the corresponding entity in the actual package. The actual
7521 -- package has been analyzed and possibly expanded, and as a result
7522 -- there is no one-to-one correspondence between the two lists (for
7523 -- example, the actual may include subtypes, itypes, and inherited
7524 -- primitive operations, interspersed among the renaming declarations
7525 -- for the actuals) . We retrieve the corresponding actual by name
7526 -- because each actual has the same name as the formal, and they do
7527 -- appear in the same order.
7529 function Get_Formal_Entity (N : Node_Id) return Entity_Id;
7530 -- Retrieve entity of defining entity of generic formal parameter.
7531 -- Only the declarations of formals need to be considered when
7532 -- linking them to actuals, but the declarative list may include
7533 -- internal entities generated during analysis, and those are ignored.
7535 procedure Match_Formal_Entity
7536 (Formal_Node : Node_Id;
7537 Formal_Ent : Entity_Id;
7538 Actual_Ent : Entity_Id);
7539 -- Associates the formal entity with the actual. In the case
7540 -- where Formal_Ent is a formal package, this procedure iterates
7541 -- through all of its formals and enters associations between the
7542 -- actuals occurring in the formal package's corresponding actual
7543 -- package (given by Actual_Ent) and the formal package's formal
7544 -- parameters. This procedure recurses if any of the parameters is
7545 -- itself a package.
7547 function Is_Instance_Of
7548 (Act_Spec : Entity_Id;
7549 Gen_Anc : Entity_Id) return Boolean;
7550 -- The actual can be an instantiation of a generic within another
7551 -- instance, in which case there is no direct link from it to the
7552 -- original generic ancestor. In that case, we recognize that the
7553 -- ultimate ancestor is the same by examining names and scopes.
7555 procedure Process_Nested_Formal (Formal : Entity_Id);
7556 -- If the current formal is declared with a box, its own formals are
7557 -- visible in the instance, as they were in the generic, and their
7558 -- Hidden flag must be reset. If some of these formals are themselves
7559 -- packages declared with a box, the processing must be recursive.
7561 --------------------------
7562 -- Find_Matching_Actual --
7563 --------------------------
7565 procedure Find_Matching_Actual
7567 Act : in out Entity_Id)
7569 Formal_Ent : Entity_Id;
7572 case Nkind (Original_Node (F)) is
7573 when N_Formal_Object_Declaration |
7574 N_Formal_Type_Declaration =>
7575 Formal_Ent := Defining_Identifier (F);
7577 while Chars (Act) /= Chars (Formal_Ent) loop
7581 when N_Formal_Subprogram_Declaration |
7582 N_Formal_Package_Declaration |
7583 N_Package_Declaration |
7584 N_Generic_Package_Declaration =>
7585 Formal_Ent := Defining_Entity (F);
7587 while Chars (Act) /= Chars (Formal_Ent) loop
7592 raise Program_Error;
7594 end Find_Matching_Actual;
7596 -------------------------
7597 -- Match_Formal_Entity --
7598 -------------------------
7600 procedure Match_Formal_Entity
7601 (Formal_Node : Node_Id;
7602 Formal_Ent : Entity_Id;
7603 Actual_Ent : Entity_Id)
7605 Act_Pkg : Entity_Id;
7608 Set_Instance_Of (Formal_Ent, Actual_Ent);
7610 if Ekind (Actual_Ent) = E_Package then
7612 -- Record associations for each parameter
7614 Act_Pkg := Actual_Ent;
7617 A_Ent : Entity_Id := First_Entity (Act_Pkg);
7626 -- Retrieve the actual given in the formal package declaration
7628 Actual := Entity (Name (Original_Node (Formal_Node)));
7630 -- The actual in the formal package declaration may be a
7631 -- renamed generic package, in which case we want to retrieve
7632 -- the original generic in order to traverse its formal part.
7634 if Present (Renamed_Entity (Actual)) then
7635 Gen_Decl := Unit_Declaration_Node (Renamed_Entity (Actual));
7637 Gen_Decl := Unit_Declaration_Node (Actual);
7640 Formals := Generic_Formal_Declarations (Gen_Decl);
7642 if Present (Formals) then
7643 F_Node := First_Non_Pragma (Formals);
7648 while Present (A_Ent)
7649 and then Present (F_Node)
7650 and then A_Ent /= First_Private_Entity (Act_Pkg)
7652 F_Ent := Get_Formal_Entity (F_Node);
7654 if Present (F_Ent) then
7656 -- This is a formal of the original package. Record
7657 -- association and recurse.
7659 Find_Matching_Actual (F_Node, A_Ent);
7660 Match_Formal_Entity (F_Node, F_Ent, A_Ent);
7661 Next_Entity (A_Ent);
7664 Next_Non_Pragma (F_Node);
7668 end Match_Formal_Entity;
7670 -----------------------
7671 -- Get_Formal_Entity --
7672 -----------------------
7674 function Get_Formal_Entity (N : Node_Id) return Entity_Id is
7675 Kind : constant Node_Kind := Nkind (Original_Node (N));
7678 when N_Formal_Object_Declaration =>
7679 return Defining_Identifier (N);
7681 when N_Formal_Type_Declaration =>
7682 return Defining_Identifier (N);
7684 when N_Formal_Subprogram_Declaration =>
7685 return Defining_Unit_Name (Specification (N));
7687 when N_Formal_Package_Declaration =>
7688 return Defining_Identifier (Original_Node (N));
7690 when N_Generic_Package_Declaration =>
7691 return Defining_Identifier (Original_Node (N));
7693 -- All other declarations are introduced by semantic analysis and
7694 -- have no match in the actual.
7699 end Get_Formal_Entity;
7701 --------------------
7702 -- Is_Instance_Of --
7703 --------------------
7705 function Is_Instance_Of
7706 (Act_Spec : Entity_Id;
7707 Gen_Anc : Entity_Id) return Boolean
7709 Gen_Par : constant Entity_Id := Generic_Parent (Act_Spec);
7712 if No (Gen_Par) then
7715 -- Simplest case: the generic parent of the actual is the formal
7717 elsif Gen_Par = Gen_Anc then
7720 elsif Chars (Gen_Par) /= Chars (Gen_Anc) then
7723 -- The actual may be obtained through several instantiations. Its
7724 -- scope must itself be an instance of a generic declared in the
7725 -- same scope as the formal. Any other case is detected above.
7727 elsif not Is_Generic_Instance (Scope (Gen_Par)) then
7731 return Generic_Parent (Parent (Scope (Gen_Par))) = Scope (Gen_Anc);
7735 ---------------------------
7736 -- Process_Nested_Formal --
7737 ---------------------------
7739 procedure Process_Nested_Formal (Formal : Entity_Id) is
7743 if Present (Associated_Formal_Package (Formal))
7744 and then Box_Present (Parent (Associated_Formal_Package (Formal)))
7746 Ent := First_Entity (Formal);
7747 while Present (Ent) loop
7748 Set_Is_Hidden (Ent, False);
7749 Set_Is_Visible_Formal (Ent);
7750 Set_Is_Potentially_Use_Visible
7751 (Ent, Is_Potentially_Use_Visible (Formal));
7753 if Ekind (Ent) = E_Package then
7754 exit when Renamed_Entity (Ent) = Renamed_Entity (Formal);
7755 Process_Nested_Formal (Ent);
7761 end Process_Nested_Formal;
7763 -- Start of processing for Instantiate_Formal_Package
7768 if not Is_Entity_Name (Actual)
7769 or else Ekind (Entity (Actual)) /= E_Package
7772 ("expect package instance to instantiate formal", Actual);
7773 Abandon_Instantiation (Actual);
7774 raise Program_Error;
7777 Actual_Pack := Entity (Actual);
7778 Set_Is_Instantiated (Actual_Pack);
7780 -- The actual may be a renamed package, or an outer generic formal
7781 -- package whose instantiation is converted into a renaming.
7783 if Present (Renamed_Object (Actual_Pack)) then
7784 Actual_Pack := Renamed_Object (Actual_Pack);
7787 if Nkind (Analyzed_Formal) = N_Formal_Package_Declaration then
7788 Gen_Parent := Get_Instance_Of (Entity (Name (Analyzed_Formal)));
7789 Formal_Pack := Defining_Identifier (Analyzed_Formal);
7792 Generic_Parent (Specification (Analyzed_Formal));
7794 Defining_Unit_Name (Specification (Analyzed_Formal));
7797 if Nkind (Parent (Actual_Pack)) = N_Defining_Program_Unit_Name then
7798 Parent_Spec := Specification (Unit_Declaration_Node (Actual_Pack));
7800 Parent_Spec := Parent (Actual_Pack);
7803 if Gen_Parent = Any_Id then
7805 ("previous error in declaration of formal package", Actual);
7806 Abandon_Instantiation (Actual);
7809 Is_Instance_Of (Parent_Spec, Get_Instance_Of (Gen_Parent))
7815 ("actual parameter must be instance of&", Actual, Gen_Parent);
7816 Abandon_Instantiation (Actual);
7819 Set_Instance_Of (Defining_Identifier (Formal), Actual_Pack);
7820 Map_Formal_Package_Entities (Formal_Pack, Actual_Pack);
7823 Make_Package_Renaming_Declaration (Loc,
7824 Defining_Unit_Name => New_Copy (Defining_Identifier (Formal)),
7825 Name => New_Reference_To (Actual_Pack, Loc));
7827 Set_Associated_Formal_Package (Defining_Unit_Name (Nod),
7828 Defining_Identifier (Formal));
7829 Decls := New_List (Nod);
7831 -- If the formal F has a box, then the generic declarations are
7832 -- visible in the generic G. In an instance of G, the corresponding
7833 -- entities in the actual for F (which are the actuals for the
7834 -- instantiation of the generic that F denotes) must also be made
7835 -- visible for analysis of the current instance. On exit from the
7836 -- current instance, those entities are made private again. If the
7837 -- actual is currently in use, these entities are also use-visible.
7839 -- The loop through the actual entities also steps through the formal
7840 -- entities and enters associations from formals to actuals into the
7841 -- renaming map. This is necessary to properly handle checking of
7842 -- actual parameter associations for later formals that depend on
7843 -- actuals declared in the formal package.
7845 -- In Ada 2005, partial parametrization requires that we make visible
7846 -- the actuals corresponding to formals that were defaulted in the
7847 -- formal package. There formals are identified because they remain
7848 -- formal generics within the formal package, rather than being
7849 -- renamings of the actuals supplied.
7852 Gen_Decl : constant Node_Id :=
7853 Unit_Declaration_Node (Gen_Parent);
7854 Formals : constant List_Id :=
7855 Generic_Formal_Declarations (Gen_Decl);
7857 Actual_Ent : Entity_Id;
7858 Actual_Of_Formal : Node_Id;
7859 Formal_Node : Node_Id;
7860 Formal_Ent : Entity_Id;
7863 if Present (Formals) then
7864 Formal_Node := First_Non_Pragma (Formals);
7866 Formal_Node := Empty;
7869 Actual_Ent := First_Entity (Actual_Pack);
7871 First (Visible_Declarations (Specification (Analyzed_Formal)));
7872 while Present (Actual_Ent)
7873 and then Actual_Ent /= First_Private_Entity (Actual_Pack)
7875 if Present (Formal_Node) then
7876 Formal_Ent := Get_Formal_Entity (Formal_Node);
7878 if Present (Formal_Ent) then
7879 Find_Matching_Actual (Formal_Node, Actual_Ent);
7881 (Formal_Node, Formal_Ent, Actual_Ent);
7883 -- We iterate at the same time over the actuals of the
7884 -- local package created for the formal, to determine
7885 -- which one of the formals of the original generic were
7886 -- defaulted in the formal. The corresponding actual
7887 -- entities are visible in the enclosing instance.
7889 if Box_Present (Formal)
7891 (Present (Actual_Of_Formal)
7894 (Get_Formal_Entity (Actual_Of_Formal)))
7896 Set_Is_Hidden (Actual_Ent, False);
7897 Set_Is_Visible_Formal (Actual_Ent);
7898 Set_Is_Potentially_Use_Visible
7899 (Actual_Ent, In_Use (Actual_Pack));
7901 if Ekind (Actual_Ent) = E_Package then
7902 Process_Nested_Formal (Actual_Ent);
7906 Set_Is_Hidden (Actual_Ent);
7907 Set_Is_Potentially_Use_Visible (Actual_Ent, False);
7911 Next_Non_Pragma (Formal_Node);
7912 Next (Actual_Of_Formal);
7915 -- No further formals to match, but the generic part may
7916 -- contain inherited operation that are not hidden in the
7917 -- enclosing instance.
7919 Next_Entity (Actual_Ent);
7923 -- Inherited subprograms generated by formal derived types are
7924 -- also visible if the types are.
7926 Actual_Ent := First_Entity (Actual_Pack);
7927 while Present (Actual_Ent)
7928 and then Actual_Ent /= First_Private_Entity (Actual_Pack)
7930 if Is_Overloadable (Actual_Ent)
7932 Nkind (Parent (Actual_Ent)) = N_Subtype_Declaration
7934 not Is_Hidden (Defining_Identifier (Parent (Actual_Ent)))
7936 Set_Is_Hidden (Actual_Ent, False);
7937 Set_Is_Potentially_Use_Visible
7938 (Actual_Ent, In_Use (Actual_Pack));
7941 Next_Entity (Actual_Ent);
7945 -- If the formal is not declared with a box, reanalyze it as an
7946 -- abbreviated instantiation, to verify the matching rules of 12.7.
7947 -- The actual checks are performed after the generic associations
7948 -- have been analyzed, to guarantee the same visibility for this
7949 -- instantiation and for the actuals.
7951 -- In Ada 2005, the generic associations for the formal can include
7952 -- defaulted parameters. These are ignored during check. This
7953 -- internal instantiation is removed from the tree after conformance
7954 -- checking, because it contains formal declarations for those
7955 -- defaulted parameters, and those should not reach the back-end.
7957 if not Box_Present (Formal) then
7959 I_Pack : constant Entity_Id :=
7960 Make_Temporary (Sloc (Actual), 'P');
7963 Set_Is_Internal (I_Pack);
7966 Make_Package_Instantiation (Sloc (Actual),
7967 Defining_Unit_Name => I_Pack,
7970 (Get_Instance_Of (Gen_Parent), Sloc (Actual)),
7971 Generic_Associations =>
7972 Generic_Associations (Formal)));
7978 end Instantiate_Formal_Package;
7980 -----------------------------------
7981 -- Instantiate_Formal_Subprogram --
7982 -----------------------------------
7984 function Instantiate_Formal_Subprogram
7987 Analyzed_Formal : Node_Id) return Node_Id
7990 Formal_Sub : constant Entity_Id :=
7991 Defining_Unit_Name (Specification (Formal));
7992 Analyzed_S : constant Entity_Id :=
7993 Defining_Unit_Name (Specification (Analyzed_Formal));
7994 Decl_Node : Node_Id;
7998 function From_Parent_Scope (Subp : Entity_Id) return Boolean;
7999 -- If the generic is a child unit, the parent has been installed on the
8000 -- scope stack, but a default subprogram cannot resolve to something on
8001 -- the parent because that parent is not really part of the visible
8002 -- context (it is there to resolve explicit local entities). If the
8003 -- default has resolved in this way, we remove the entity from
8004 -- immediate visibility and analyze the node again to emit an error
8005 -- message or find another visible candidate.
8007 procedure Valid_Actual_Subprogram (Act : Node_Id);
8008 -- Perform legality check and raise exception on failure
8010 -----------------------
8011 -- From_Parent_Scope --
8012 -----------------------
8014 function From_Parent_Scope (Subp : Entity_Id) return Boolean is
8015 Gen_Scope : Node_Id;
8018 Gen_Scope := Scope (Analyzed_S);
8019 while Present (Gen_Scope)
8020 and then Is_Child_Unit (Gen_Scope)
8022 if Scope (Subp) = Scope (Gen_Scope) then
8026 Gen_Scope := Scope (Gen_Scope);
8030 end From_Parent_Scope;
8032 -----------------------------
8033 -- Valid_Actual_Subprogram --
8034 -----------------------------
8036 procedure Valid_Actual_Subprogram (Act : Node_Id) is
8040 if Is_Entity_Name (Act) then
8041 Act_E := Entity (Act);
8043 elsif Nkind (Act) = N_Selected_Component
8044 and then Is_Entity_Name (Selector_Name (Act))
8046 Act_E := Entity (Selector_Name (Act));
8052 if (Present (Act_E) and then Is_Overloadable (Act_E))
8053 or else Nkind_In (Act, N_Attribute_Reference,
8054 N_Indexed_Component,
8055 N_Character_Literal,
8056 N_Explicit_Dereference)
8062 ("expect subprogram or entry name in instantiation of&",
8063 Instantiation_Node, Formal_Sub);
8064 Abandon_Instantiation (Instantiation_Node);
8066 end Valid_Actual_Subprogram;
8068 -- Start of processing for Instantiate_Formal_Subprogram
8071 New_Spec := New_Copy_Tree (Specification (Formal));
8073 -- The tree copy has created the proper instantiation sloc for the
8074 -- new specification. Use this location for all other constructed
8077 Loc := Sloc (Defining_Unit_Name (New_Spec));
8079 -- Create new entity for the actual (New_Copy_Tree does not)
8081 Set_Defining_Unit_Name
8082 (New_Spec, Make_Defining_Identifier (Loc, Chars (Formal_Sub)));
8084 -- Create new entities for the each of the formals in the
8085 -- specification of the renaming declaration built for the actual.
8087 if Present (Parameter_Specifications (New_Spec)) then
8091 F := First (Parameter_Specifications (New_Spec));
8092 while Present (F) loop
8093 Set_Defining_Identifier (F,
8094 Make_Defining_Identifier (Sloc (F),
8095 Chars => Chars (Defining_Identifier (F))));
8101 -- Find entity of actual. If the actual is an attribute reference, it
8102 -- cannot be resolved here (its formal is missing) but is handled
8103 -- instead in Attribute_Renaming. If the actual is overloaded, it is
8104 -- fully resolved subsequently, when the renaming declaration for the
8105 -- formal is analyzed. If it is an explicit dereference, resolve the
8106 -- prefix but not the actual itself, to prevent interpretation as call.
8108 if Present (Actual) then
8109 Loc := Sloc (Actual);
8110 Set_Sloc (New_Spec, Loc);
8112 if Nkind (Actual) = N_Operator_Symbol then
8113 Find_Direct_Name (Actual);
8115 elsif Nkind (Actual) = N_Explicit_Dereference then
8116 Analyze (Prefix (Actual));
8118 elsif Nkind (Actual) /= N_Attribute_Reference then
8122 Valid_Actual_Subprogram (Actual);
8125 elsif Present (Default_Name (Formal)) then
8126 if not Nkind_In (Default_Name (Formal), N_Attribute_Reference,
8127 N_Selected_Component,
8128 N_Indexed_Component,
8129 N_Character_Literal)
8130 and then Present (Entity (Default_Name (Formal)))
8132 Nam := New_Occurrence_Of (Entity (Default_Name (Formal)), Loc);
8134 Nam := New_Copy (Default_Name (Formal));
8135 Set_Sloc (Nam, Loc);
8138 elsif Box_Present (Formal) then
8140 -- Actual is resolved at the point of instantiation. Create an
8141 -- identifier or operator with the same name as the formal.
8143 if Nkind (Formal_Sub) = N_Defining_Operator_Symbol then
8144 Nam := Make_Operator_Symbol (Loc,
8145 Chars => Chars (Formal_Sub),
8146 Strval => No_String);
8148 Nam := Make_Identifier (Loc, Chars (Formal_Sub));
8151 elsif Nkind (Specification (Formal)) = N_Procedure_Specification
8152 and then Null_Present (Specification (Formal))
8154 -- Generate null body for procedure, for use in the instance
8157 Make_Subprogram_Body (Loc,
8158 Specification => New_Spec,
8159 Declarations => New_List,
8160 Handled_Statement_Sequence =>
8161 Make_Handled_Sequence_Of_Statements (Loc,
8162 Statements => New_List (Make_Null_Statement (Loc))));
8164 Set_Is_Intrinsic_Subprogram (Defining_Unit_Name (New_Spec));
8168 Error_Msg_Sloc := Sloc (Scope (Analyzed_S));
8170 ("missing actual&", Instantiation_Node, Formal_Sub);
8172 ("\in instantiation of & declared#",
8173 Instantiation_Node, Scope (Analyzed_S));
8174 Abandon_Instantiation (Instantiation_Node);
8178 Make_Subprogram_Renaming_Declaration (Loc,
8179 Specification => New_Spec,
8182 -- If we do not have an actual and the formal specified <> then set to
8183 -- get proper default.
8185 if No (Actual) and then Box_Present (Formal) then
8186 Set_From_Default (Decl_Node);
8189 -- Gather possible interpretations for the actual before analyzing the
8190 -- instance. If overloaded, it will be resolved when analyzing the
8191 -- renaming declaration.
8193 if Box_Present (Formal)
8194 and then No (Actual)
8198 if Is_Child_Unit (Scope (Analyzed_S))
8199 and then Present (Entity (Nam))
8201 if not Is_Overloaded (Nam) then
8203 if From_Parent_Scope (Entity (Nam)) then
8204 Set_Is_Immediately_Visible (Entity (Nam), False);
8205 Set_Entity (Nam, Empty);
8206 Set_Etype (Nam, Empty);
8210 Set_Is_Immediately_Visible (Entity (Nam));
8219 Get_First_Interp (Nam, I, It);
8221 while Present (It.Nam) loop
8222 if From_Parent_Scope (It.Nam) then
8226 Get_Next_Interp (I, It);
8233 -- The generic instantiation freezes the actual. This can only be done
8234 -- once the actual is resolved, in the analysis of the renaming
8235 -- declaration. To make the formal subprogram entity available, we set
8236 -- Corresponding_Formal_Spec to point to the formal subprogram entity.
8237 -- This is also needed in Analyze_Subprogram_Renaming for the processing
8238 -- of formal abstract subprograms.
8240 Set_Corresponding_Formal_Spec (Decl_Node, Analyzed_S);
8242 -- We cannot analyze the renaming declaration, and thus find the actual,
8243 -- until all the actuals are assembled in the instance. For subsequent
8244 -- checks of other actuals, indicate the node that will hold the
8245 -- instance of this formal.
8247 Set_Instance_Of (Analyzed_S, Nam);
8249 if Nkind (Actual) = N_Selected_Component
8250 and then Is_Task_Type (Etype (Prefix (Actual)))
8251 and then not Is_Frozen (Etype (Prefix (Actual)))
8253 -- The renaming declaration will create a body, which must appear
8254 -- outside of the instantiation, We move the renaming declaration
8255 -- out of the instance, and create an additional renaming inside,
8256 -- to prevent freezing anomalies.
8259 Anon_Id : constant Entity_Id := Make_Temporary (Loc, 'E');
8262 Set_Defining_Unit_Name (New_Spec, Anon_Id);
8263 Insert_Before (Instantiation_Node, Decl_Node);
8264 Analyze (Decl_Node);
8266 -- Now create renaming within the instance
8269 Make_Subprogram_Renaming_Declaration (Loc,
8270 Specification => New_Copy_Tree (New_Spec),
8271 Name => New_Occurrence_Of (Anon_Id, Loc));
8273 Set_Defining_Unit_Name (Specification (Decl_Node),
8274 Make_Defining_Identifier (Loc, Chars (Formal_Sub)));
8279 end Instantiate_Formal_Subprogram;
8281 ------------------------
8282 -- Instantiate_Object --
8283 ------------------------
8285 function Instantiate_Object
8288 Analyzed_Formal : Node_Id) return List_Id
8290 Gen_Obj : constant Entity_Id := Defining_Identifier (Formal);
8291 A_Gen_Obj : constant Entity_Id :=
8292 Defining_Identifier (Analyzed_Formal);
8293 Acc_Def : Node_Id := Empty;
8294 Act_Assoc : constant Node_Id := Parent (Actual);
8295 Actual_Decl : Node_Id := Empty;
8296 Decl_Node : Node_Id;
8299 List : constant List_Id := New_List;
8300 Loc : constant Source_Ptr := Sloc (Actual);
8301 Orig_Ftyp : constant Entity_Id := Etype (A_Gen_Obj);
8302 Subt_Decl : Node_Id := Empty;
8303 Subt_Mark : Node_Id := Empty;
8306 if Present (Subtype_Mark (Formal)) then
8307 Subt_Mark := Subtype_Mark (Formal);
8309 Check_Access_Definition (Formal);
8310 Acc_Def := Access_Definition (Formal);
8313 -- Sloc for error message on missing actual
8315 Error_Msg_Sloc := Sloc (Scope (A_Gen_Obj));
8317 if Get_Instance_Of (Gen_Obj) /= Gen_Obj then
8318 Error_Msg_N ("duplicate instantiation of generic parameter", Actual);
8321 Set_Parent (List, Parent (Actual));
8325 if Out_Present (Formal) then
8327 -- An IN OUT generic actual must be a name. The instantiation is a
8328 -- renaming declaration. The actual is the name being renamed. We
8329 -- use the actual directly, rather than a copy, because it is not
8330 -- used further in the list of actuals, and because a copy or a use
8331 -- of relocate_node is incorrect if the instance is nested within a
8332 -- generic. In order to simplify ASIS searches, the Generic_Parent
8333 -- field links the declaration to the generic association.
8338 Instantiation_Node, Gen_Obj);
8340 ("\in instantiation of & declared#",
8341 Instantiation_Node, Scope (A_Gen_Obj));
8342 Abandon_Instantiation (Instantiation_Node);
8345 if Present (Subt_Mark) then
8347 Make_Object_Renaming_Declaration (Loc,
8348 Defining_Identifier => New_Copy (Gen_Obj),
8349 Subtype_Mark => New_Copy_Tree (Subt_Mark),
8352 else pragma Assert (Present (Acc_Def));
8354 Make_Object_Renaming_Declaration (Loc,
8355 Defining_Identifier => New_Copy (Gen_Obj),
8356 Access_Definition => New_Copy_Tree (Acc_Def),
8360 Set_Corresponding_Generic_Association (Decl_Node, Act_Assoc);
8362 -- The analysis of the actual may produce insert_action nodes, so
8363 -- the declaration must have a context in which to attach them.
8365 Append (Decl_Node, List);
8368 -- Return if the analysis of the actual reported some error
8370 if Etype (Actual) = Any_Type then
8374 -- This check is performed here because Analyze_Object_Renaming will
8375 -- not check it when Comes_From_Source is False. Note though that the
8376 -- check for the actual being the name of an object will be performed
8377 -- in Analyze_Object_Renaming.
8379 if Is_Object_Reference (Actual)
8380 and then Is_Dependent_Component_Of_Mutable_Object (Actual)
8383 ("illegal discriminant-dependent component for in out parameter",
8387 -- The actual has to be resolved in order to check that it is a
8388 -- variable (due to cases such as F (1), where F returns access to an
8389 -- array, and for overloaded prefixes).
8391 Ftyp := Get_Instance_Of (Etype (A_Gen_Obj));
8393 -- If the type of the formal is not itself a formal, and the
8394 -- current unit is a child unit, the formal type must be declared
8395 -- in a parent, and must be retrieved by visibility.
8398 and then Is_Generic_Unit (Scope (Ftyp))
8399 and then Is_Child_Unit (Scope (A_Gen_Obj))
8402 Temp : constant Node_Id :=
8403 New_Copy_Tree (Subtype_Mark (Analyzed_Formal));
8405 Set_Entity (Temp, Empty);
8407 Ftyp := Entity (Temp);
8411 if Is_Private_Type (Ftyp)
8412 and then not Is_Private_Type (Etype (Actual))
8413 and then (Base_Type (Full_View (Ftyp)) = Base_Type (Etype (Actual))
8414 or else Base_Type (Etype (Actual)) = Ftyp)
8416 -- If the actual has the type of the full view of the formal, or
8417 -- else a non-private subtype of the formal, then the visibility
8418 -- of the formal type has changed. Add to the actuals a subtype
8419 -- declaration that will force the exchange of views in the body
8420 -- of the instance as well.
8423 Make_Subtype_Declaration (Loc,
8424 Defining_Identifier => Make_Temporary (Loc, 'P'),
8425 Subtype_Indication => New_Occurrence_Of (Ftyp, Loc));
8427 Prepend (Subt_Decl, List);
8429 Prepend_Elmt (Full_View (Ftyp), Exchanged_Views);
8430 Exchange_Declarations (Ftyp);
8433 Resolve (Actual, Ftyp);
8435 if not Denotes_Variable (Actual) then
8437 ("actual for& must be a variable", Actual, Gen_Obj);
8439 elsif Base_Type (Ftyp) /= Base_Type (Etype (Actual)) then
8441 -- Ada 2005 (AI-423): For a generic formal object of mode in out,
8442 -- the type of the actual shall resolve to a specific anonymous
8445 if Ada_Version < Ada_2005
8447 Ekind (Base_Type (Ftyp)) /=
8448 E_Anonymous_Access_Type
8450 Ekind (Base_Type (Etype (Actual))) /=
8451 E_Anonymous_Access_Type
8453 Error_Msg_NE ("type of actual does not match type of&",
8458 Note_Possible_Modification (Actual, Sure => True);
8460 -- Check for instantiation of atomic/volatile actual for
8461 -- non-atomic/volatile formal (RM C.6 (12)).
8463 if Is_Atomic_Object (Actual)
8464 and then not Is_Atomic (Orig_Ftyp)
8467 ("cannot instantiate non-atomic formal object " &
8468 "with atomic actual", Actual);
8470 elsif Is_Volatile_Object (Actual)
8471 and then not Is_Volatile (Orig_Ftyp)
8474 ("cannot instantiate non-volatile formal object " &
8475 "with volatile actual", Actual);
8478 -- Formal in-parameter
8481 -- The instantiation of a generic formal in-parameter is constant
8482 -- declaration. The actual is the expression for that declaration.
8484 if Present (Actual) then
8485 if Present (Subt_Mark) then
8487 else pragma Assert (Present (Acc_Def));
8492 Make_Object_Declaration (Loc,
8493 Defining_Identifier => New_Copy (Gen_Obj),
8494 Constant_Present => True,
8495 Null_Exclusion_Present => Null_Exclusion_Present (Formal),
8496 Object_Definition => New_Copy_Tree (Def),
8497 Expression => Actual);
8499 Set_Corresponding_Generic_Association (Decl_Node, Act_Assoc);
8501 -- A generic formal object of a tagged type is defined to be
8502 -- aliased so the new constant must also be treated as aliased.
8504 if Is_Tagged_Type (Etype (A_Gen_Obj)) then
8505 Set_Aliased_Present (Decl_Node);
8508 Append (Decl_Node, List);
8510 -- No need to repeat (pre-)analysis of some expression nodes
8511 -- already handled in Preanalyze_Actuals.
8513 if Nkind (Actual) /= N_Allocator then
8516 -- Return if the analysis of the actual reported some error
8518 if Etype (Actual) = Any_Type then
8524 Formal_Type : constant Entity_Id := Etype (A_Gen_Obj);
8528 Typ := Get_Instance_Of (Formal_Type);
8530 Freeze_Before (Instantiation_Node, Typ);
8532 -- If the actual is an aggregate, perform name resolution on
8533 -- its components (the analysis of an aggregate does not do it)
8534 -- to capture local names that may be hidden if the generic is
8537 if Nkind (Actual) = N_Aggregate then
8538 Preanalyze_And_Resolve (Actual, Typ);
8541 if Is_Limited_Type (Typ)
8542 and then not OK_For_Limited_Init (Typ, Actual)
8545 ("initialization not allowed for limited types", Actual);
8546 Explain_Limited_Type (Typ, Actual);
8550 elsif Present (Default_Expression (Formal)) then
8552 -- Use default to construct declaration
8554 if Present (Subt_Mark) then
8556 else pragma Assert (Present (Acc_Def));
8561 Make_Object_Declaration (Sloc (Formal),
8562 Defining_Identifier => New_Copy (Gen_Obj),
8563 Constant_Present => True,
8564 Null_Exclusion_Present => Null_Exclusion_Present (Formal),
8565 Object_Definition => New_Copy (Def),
8566 Expression => New_Copy_Tree
8567 (Default_Expression (Formal)));
8569 Append (Decl_Node, List);
8570 Set_Analyzed (Expression (Decl_Node), False);
8575 Instantiation_Node, Gen_Obj);
8576 Error_Msg_NE ("\in instantiation of & declared#",
8577 Instantiation_Node, Scope (A_Gen_Obj));
8579 if Is_Scalar_Type (Etype (A_Gen_Obj)) then
8581 -- Create dummy constant declaration so that instance can be
8582 -- analyzed, to minimize cascaded visibility errors.
8584 if Present (Subt_Mark) then
8586 else pragma Assert (Present (Acc_Def));
8591 Make_Object_Declaration (Loc,
8592 Defining_Identifier => New_Copy (Gen_Obj),
8593 Constant_Present => True,
8594 Null_Exclusion_Present => Null_Exclusion_Present (Formal),
8595 Object_Definition => New_Copy (Def),
8597 Make_Attribute_Reference (Sloc (Gen_Obj),
8598 Attribute_Name => Name_First,
8599 Prefix => New_Copy (Def)));
8601 Append (Decl_Node, List);
8604 Abandon_Instantiation (Instantiation_Node);
8609 if Nkind (Actual) in N_Has_Entity then
8610 Actual_Decl := Parent (Entity (Actual));
8613 -- Ada 2005 (AI-423): For a formal object declaration with a null
8614 -- exclusion or an access definition that has a null exclusion: If the
8615 -- actual matching the formal object declaration denotes a generic
8616 -- formal object of another generic unit G, and the instantiation
8617 -- containing the actual occurs within the body of G or within the body
8618 -- of a generic unit declared within the declarative region of G, then
8619 -- the declaration of the formal object of G must have a null exclusion.
8620 -- Otherwise, the subtype of the actual matching the formal object
8621 -- declaration shall exclude null.
8623 if Ada_Version >= Ada_2005
8624 and then Present (Actual_Decl)
8626 Nkind_In (Actual_Decl, N_Formal_Object_Declaration,
8627 N_Object_Declaration)
8628 and then Nkind (Analyzed_Formal) = N_Formal_Object_Declaration
8629 and then not Has_Null_Exclusion (Actual_Decl)
8630 and then Has_Null_Exclusion (Analyzed_Formal)
8632 Error_Msg_Sloc := Sloc (Analyzed_Formal);
8634 ("actual must exclude null to match generic formal#", Actual);
8638 end Instantiate_Object;
8640 ------------------------------
8641 -- Instantiate_Package_Body --
8642 ------------------------------
8644 procedure Instantiate_Package_Body
8645 (Body_Info : Pending_Body_Info;
8646 Inlined_Body : Boolean := False;
8647 Body_Optional : Boolean := False)
8649 Act_Decl : constant Node_Id := Body_Info.Act_Decl;
8650 Inst_Node : constant Node_Id := Body_Info.Inst_Node;
8651 Loc : constant Source_Ptr := Sloc (Inst_Node);
8653 Gen_Id : constant Node_Id := Name (Inst_Node);
8654 Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node);
8655 Gen_Decl : constant Node_Id := Unit_Declaration_Node (Gen_Unit);
8656 Act_Spec : constant Node_Id := Specification (Act_Decl);
8657 Act_Decl_Id : constant Entity_Id := Defining_Entity (Act_Spec);
8659 Act_Body_Name : Node_Id;
8661 Gen_Body_Id : Node_Id;
8663 Act_Body_Id : Entity_Id;
8665 Parent_Installed : Boolean := False;
8666 Save_Style_Check : constant Boolean := Style_Check;
8668 Par_Ent : Entity_Id := Empty;
8669 Par_Vis : Boolean := False;
8672 Gen_Body_Id := Corresponding_Body (Gen_Decl);
8674 -- The instance body may already have been processed, as the parent of
8675 -- another instance that is inlined (Load_Parent_Of_Generic).
8677 if Present (Corresponding_Body (Instance_Spec (Inst_Node))) then
8681 Expander_Mode_Save_And_Set (Body_Info.Expander_Status);
8683 -- Re-establish the state of information on which checks are suppressed.
8684 -- This information was set in Body_Info at the point of instantiation,
8685 -- and now we restore it so that the instance is compiled using the
8686 -- check status at the instantiation (RM 11.5 (7.2/2), AI95-00224-01).
8688 Local_Suppress_Stack_Top := Body_Info.Local_Suppress_Stack_Top;
8689 Scope_Suppress := Body_Info.Scope_Suppress;
8690 Opt.Ada_Version := Body_Info.Version;
8692 if No (Gen_Body_Id) then
8693 Load_Parent_Of_Generic
8694 (Inst_Node, Specification (Gen_Decl), Body_Optional);
8695 Gen_Body_Id := Corresponding_Body (Gen_Decl);
8698 -- Establish global variable for sloc adjustment and for error recovery
8700 Instantiation_Node := Inst_Node;
8702 if Present (Gen_Body_Id) then
8703 Save_Env (Gen_Unit, Act_Decl_Id);
8704 Style_Check := False;
8705 Current_Sem_Unit := Body_Info.Current_Sem_Unit;
8707 Gen_Body := Unit_Declaration_Node (Gen_Body_Id);
8709 Create_Instantiation_Source
8710 (Inst_Node, Gen_Body_Id, False, S_Adjustment);
8714 (Original_Node (Gen_Body), Empty, Instantiating => True);
8716 -- Build new name (possibly qualified) for body declaration
8718 Act_Body_Id := New_Copy (Act_Decl_Id);
8720 -- Some attributes of spec entity are not inherited by body entity
8722 Set_Handler_Records (Act_Body_Id, No_List);
8724 if Nkind (Defining_Unit_Name (Act_Spec)) =
8725 N_Defining_Program_Unit_Name
8728 Make_Defining_Program_Unit_Name (Loc,
8729 Name => New_Copy_Tree (Name (Defining_Unit_Name (Act_Spec))),
8730 Defining_Identifier => Act_Body_Id);
8732 Act_Body_Name := Act_Body_Id;
8735 Set_Defining_Unit_Name (Act_Body, Act_Body_Name);
8737 Set_Corresponding_Spec (Act_Body, Act_Decl_Id);
8738 Check_Generic_Actuals (Act_Decl_Id, False);
8740 -- If it is a child unit, make the parent instance (which is an
8741 -- instance of the parent of the generic) visible. The parent
8742 -- instance is the prefix of the name of the generic unit.
8744 if Ekind (Scope (Gen_Unit)) = E_Generic_Package
8745 and then Nkind (Gen_Id) = N_Expanded_Name
8747 Par_Ent := Entity (Prefix (Gen_Id));
8748 Par_Vis := Is_Immediately_Visible (Par_Ent);
8749 Install_Parent (Par_Ent, In_Body => True);
8750 Parent_Installed := True;
8752 elsif Is_Child_Unit (Gen_Unit) then
8753 Par_Ent := Scope (Gen_Unit);
8754 Par_Vis := Is_Immediately_Visible (Par_Ent);
8755 Install_Parent (Par_Ent, In_Body => True);
8756 Parent_Installed := True;
8759 -- If the instantiation is a library unit, and this is the main unit,
8760 -- then build the resulting compilation unit nodes for the instance.
8761 -- If this is a compilation unit but it is not the main unit, then it
8762 -- is the body of a unit in the context, that is being compiled
8763 -- because it is encloses some inlined unit or another generic unit
8764 -- being instantiated. In that case, this body is not part of the
8765 -- current compilation, and is not attached to the tree, but its
8766 -- parent must be set for analysis.
8768 if Nkind (Parent (Inst_Node)) = N_Compilation_Unit then
8770 -- Replace instance node with body of instance, and create new
8771 -- node for corresponding instance declaration.
8773 Build_Instance_Compilation_Unit_Nodes
8774 (Inst_Node, Act_Body, Act_Decl);
8775 Analyze (Inst_Node);
8777 if Parent (Inst_Node) = Cunit (Main_Unit) then
8779 -- If the instance is a child unit itself, then set the scope
8780 -- of the expanded body to be the parent of the instantiation
8781 -- (ensuring that the fully qualified name will be generated
8782 -- for the elaboration subprogram).
8784 if Nkind (Defining_Unit_Name (Act_Spec)) =
8785 N_Defining_Program_Unit_Name
8788 (Defining_Entity (Inst_Node), Scope (Act_Decl_Id));
8792 -- Case where instantiation is not a library unit
8795 -- If this is an early instantiation, i.e. appears textually
8796 -- before the corresponding body and must be elaborated first,
8797 -- indicate that the body instance is to be delayed.
8799 Install_Body (Act_Body, Inst_Node, Gen_Body, Gen_Decl);
8801 -- Now analyze the body. We turn off all checks if this is an
8802 -- internal unit, since there is no reason to have checks on for
8803 -- any predefined run-time library code. All such code is designed
8804 -- to be compiled with checks off.
8806 -- Note that we do NOT apply this criterion to children of GNAT
8807 -- (or on VMS, children of DEC). The latter units must suppress
8808 -- checks explicitly if this is needed.
8810 if Is_Predefined_File_Name
8811 (Unit_File_Name (Get_Source_Unit (Gen_Decl)))
8813 Analyze (Act_Body, Suppress => All_Checks);
8819 Inherit_Context (Gen_Body, Inst_Node);
8821 -- Remove the parent instances if they have been placed on the scope
8822 -- stack to compile the body.
8824 if Parent_Installed then
8825 Remove_Parent (In_Body => True);
8827 -- Restore the previous visibility of the parent
8829 Set_Is_Immediately_Visible (Par_Ent, Par_Vis);
8832 Restore_Private_Views (Act_Decl_Id);
8834 -- Remove the current unit from visibility if this is an instance
8835 -- that is not elaborated on the fly for inlining purposes.
8837 if not Inlined_Body then
8838 Set_Is_Immediately_Visible (Act_Decl_Id, False);
8842 Style_Check := Save_Style_Check;
8844 -- If we have no body, and the unit requires a body, then complain. This
8845 -- complaint is suppressed if we have detected other errors (since a
8846 -- common reason for missing the body is that it had errors).
8847 -- In CodePeer mode, a warning has been emitted already, no need for
8848 -- further messages.
8850 elsif Unit_Requires_Body (Gen_Unit)
8851 and then not Body_Optional
8853 if CodePeer_Mode then
8856 elsif Serious_Errors_Detected = 0 then
8858 ("cannot find body of generic package &", Inst_Node, Gen_Unit);
8860 -- Don't attempt to perform any cleanup actions if some other error
8861 -- was already detected, since this can cause blowups.
8867 -- Case of package that does not need a body
8870 -- If the instantiation of the declaration is a library unit, rewrite
8871 -- the original package instantiation as a package declaration in the
8872 -- compilation unit node.
8874 if Nkind (Parent (Inst_Node)) = N_Compilation_Unit then
8875 Set_Parent_Spec (Act_Decl, Parent_Spec (Inst_Node));
8876 Rewrite (Inst_Node, Act_Decl);
8878 -- Generate elaboration entity, in case spec has elaboration code.
8879 -- This cannot be done when the instance is analyzed, because it
8880 -- is not known yet whether the body exists.
8882 Set_Elaboration_Entity_Required (Act_Decl_Id, False);
8883 Build_Elaboration_Entity (Parent (Inst_Node), Act_Decl_Id);
8885 -- If the instantiation is not a library unit, then append the
8886 -- declaration to the list of implicitly generated entities, unless
8887 -- it is already a list member which means that it was already
8890 elsif not Is_List_Member (Act_Decl) then
8891 Mark_Rewrite_Insertion (Act_Decl);
8892 Insert_Before (Inst_Node, Act_Decl);
8896 Expander_Mode_Restore;
8897 end Instantiate_Package_Body;
8899 ---------------------------------
8900 -- Instantiate_Subprogram_Body --
8901 ---------------------------------
8903 procedure Instantiate_Subprogram_Body
8904 (Body_Info : Pending_Body_Info;
8905 Body_Optional : Boolean := False)
8907 Act_Decl : constant Node_Id := Body_Info.Act_Decl;
8908 Inst_Node : constant Node_Id := Body_Info.Inst_Node;
8909 Loc : constant Source_Ptr := Sloc (Inst_Node);
8910 Gen_Id : constant Node_Id := Name (Inst_Node);
8911 Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node);
8912 Gen_Decl : constant Node_Id := Unit_Declaration_Node (Gen_Unit);
8913 Anon_Id : constant Entity_Id :=
8914 Defining_Unit_Name (Specification (Act_Decl));
8915 Pack_Id : constant Entity_Id :=
8916 Defining_Unit_Name (Parent (Act_Decl));
8919 Gen_Body_Id : Node_Id;
8921 Pack_Body : Node_Id;
8922 Prev_Formal : Entity_Id;
8924 Unit_Renaming : Node_Id;
8926 Parent_Installed : Boolean := False;
8927 Save_Style_Check : constant Boolean := Style_Check;
8929 Par_Ent : Entity_Id := Empty;
8930 Par_Vis : Boolean := False;
8933 Gen_Body_Id := Corresponding_Body (Gen_Decl);
8935 -- Subprogram body may have been created already because of an inline
8936 -- pragma, or because of multiple elaborations of the enclosing package
8937 -- when several instances of the subprogram appear in the main unit.
8939 if Present (Corresponding_Body (Act_Decl)) then
8943 Expander_Mode_Save_And_Set (Body_Info.Expander_Status);
8945 -- Re-establish the state of information on which checks are suppressed.
8946 -- This information was set in Body_Info at the point of instantiation,
8947 -- and now we restore it so that the instance is compiled using the
8948 -- check status at the instantiation (RM 11.5 (7.2/2), AI95-00224-01).
8950 Local_Suppress_Stack_Top := Body_Info.Local_Suppress_Stack_Top;
8951 Scope_Suppress := Body_Info.Scope_Suppress;
8952 Opt.Ada_Version := Body_Info.Version;
8954 if No (Gen_Body_Id) then
8956 -- For imported generic subprogram, no body to compile, complete
8957 -- the spec entity appropriately.
8959 if Is_Imported (Gen_Unit) then
8960 Set_Is_Imported (Anon_Id);
8961 Set_First_Rep_Item (Anon_Id, First_Rep_Item (Gen_Unit));
8962 Set_Interface_Name (Anon_Id, Interface_Name (Gen_Unit));
8963 Set_Convention (Anon_Id, Convention (Gen_Unit));
8964 Set_Has_Completion (Anon_Id);
8967 -- For other cases, compile the body
8970 Load_Parent_Of_Generic
8971 (Inst_Node, Specification (Gen_Decl), Body_Optional);
8972 Gen_Body_Id := Corresponding_Body (Gen_Decl);
8976 Instantiation_Node := Inst_Node;
8978 if Present (Gen_Body_Id) then
8979 Gen_Body := Unit_Declaration_Node (Gen_Body_Id);
8981 if Nkind (Gen_Body) = N_Subprogram_Body_Stub then
8983 -- Either body is not present, or context is non-expanding, as
8984 -- when compiling a subunit. Mark the instance as completed, and
8985 -- diagnose a missing body when needed.
8988 and then Operating_Mode = Generate_Code
8991 ("missing proper body for instantiation", Gen_Body);
8994 Set_Has_Completion (Anon_Id);
8998 Save_Env (Gen_Unit, Anon_Id);
8999 Style_Check := False;
9000 Current_Sem_Unit := Body_Info.Current_Sem_Unit;
9001 Create_Instantiation_Source
9009 (Original_Node (Gen_Body), Empty, Instantiating => True);
9011 -- Create proper defining name for the body, to correspond to
9012 -- the one in the spec.
9014 Set_Defining_Unit_Name (Specification (Act_Body),
9015 Make_Defining_Identifier
9016 (Sloc (Defining_Entity (Inst_Node)), Chars (Anon_Id)));
9017 Set_Corresponding_Spec (Act_Body, Anon_Id);
9018 Set_Has_Completion (Anon_Id);
9019 Check_Generic_Actuals (Pack_Id, False);
9021 -- Generate a reference to link the visible subprogram instance to
9022 -- the generic body, which for navigation purposes is the only
9023 -- available source for the instance.
9026 (Related_Instance (Pack_Id),
9027 Gen_Body_Id, 'b', Set_Ref => False, Force => True);
9029 -- If it is a child unit, make the parent instance (which is an
9030 -- instance of the parent of the generic) visible. The parent
9031 -- instance is the prefix of the name of the generic unit.
9033 if Ekind (Scope (Gen_Unit)) = E_Generic_Package
9034 and then Nkind (Gen_Id) = N_Expanded_Name
9036 Par_Ent := Entity (Prefix (Gen_Id));
9037 Par_Vis := Is_Immediately_Visible (Par_Ent);
9038 Install_Parent (Par_Ent, In_Body => True);
9039 Parent_Installed := True;
9041 elsif Is_Child_Unit (Gen_Unit) then
9042 Par_Ent := Scope (Gen_Unit);
9043 Par_Vis := Is_Immediately_Visible (Par_Ent);
9044 Install_Parent (Par_Ent, In_Body => True);
9045 Parent_Installed := True;
9048 -- Inside its body, a reference to the generic unit is a reference
9049 -- to the instance. The corresponding renaming is the first
9050 -- declaration in the body.
9053 Make_Subprogram_Renaming_Declaration (Loc,
9056 Specification (Original_Node (Gen_Body)),
9058 Instantiating => True),
9059 Name => New_Occurrence_Of (Anon_Id, Loc));
9061 -- If there is a formal subprogram with the same name as the unit
9062 -- itself, do not add this renaming declaration. This is a temporary
9063 -- fix for one ACVC test. ???
9065 Prev_Formal := First_Entity (Pack_Id);
9066 while Present (Prev_Formal) loop
9067 if Chars (Prev_Formal) = Chars (Gen_Unit)
9068 and then Is_Overloadable (Prev_Formal)
9073 Next_Entity (Prev_Formal);
9076 if Present (Prev_Formal) then
9077 Decls := New_List (Act_Body);
9079 Decls := New_List (Unit_Renaming, Act_Body);
9082 -- The subprogram body is placed in the body of a dummy package body,
9083 -- whose spec contains the subprogram declaration as well as the
9084 -- renaming declarations for the generic parameters.
9086 Pack_Body := Make_Package_Body (Loc,
9087 Defining_Unit_Name => New_Copy (Pack_Id),
9088 Declarations => Decls);
9090 Set_Corresponding_Spec (Pack_Body, Pack_Id);
9092 -- If the instantiation is a library unit, then build resulting
9093 -- compilation unit nodes for the instance. The declaration of
9094 -- the enclosing package is the grandparent of the subprogram
9095 -- declaration. First replace the instantiation node as the unit
9096 -- of the corresponding compilation.
9098 if Nkind (Parent (Inst_Node)) = N_Compilation_Unit then
9099 if Parent (Inst_Node) = Cunit (Main_Unit) then
9100 Set_Unit (Parent (Inst_Node), Inst_Node);
9101 Build_Instance_Compilation_Unit_Nodes
9102 (Inst_Node, Pack_Body, Parent (Parent (Act_Decl)));
9103 Analyze (Inst_Node);
9105 Set_Parent (Pack_Body, Parent (Inst_Node));
9106 Analyze (Pack_Body);
9110 Insert_Before (Inst_Node, Pack_Body);
9111 Mark_Rewrite_Insertion (Pack_Body);
9112 Analyze (Pack_Body);
9114 if Expander_Active then
9115 Freeze_Subprogram_Body (Inst_Node, Gen_Body, Pack_Id);
9119 Inherit_Context (Gen_Body, Inst_Node);
9121 Restore_Private_Views (Pack_Id, False);
9123 if Parent_Installed then
9124 Remove_Parent (In_Body => True);
9126 -- Restore the previous visibility of the parent
9128 Set_Is_Immediately_Visible (Par_Ent, Par_Vis);
9132 Style_Check := Save_Style_Check;
9134 -- Body not found. Error was emitted already. If there were no previous
9135 -- errors, this may be an instance whose scope is a premature instance.
9136 -- In that case we must insure that the (legal) program does raise
9137 -- program error if executed. We generate a subprogram body for this
9138 -- purpose. See DEC ac30vso.
9140 -- Should not reference proprietary DEC tests in comments ???
9142 elsif Serious_Errors_Detected = 0
9143 and then Nkind (Parent (Inst_Node)) /= N_Compilation_Unit
9145 if Body_Optional then
9148 elsif Ekind (Anon_Id) = E_Procedure then
9150 Make_Subprogram_Body (Loc,
9152 Make_Procedure_Specification (Loc,
9153 Defining_Unit_Name =>
9154 Make_Defining_Identifier (Loc, Chars (Anon_Id)),
9155 Parameter_Specifications =>
9157 (Parameter_Specifications (Parent (Anon_Id)))),
9159 Declarations => Empty_List,
9160 Handled_Statement_Sequence =>
9161 Make_Handled_Sequence_Of_Statements (Loc,
9164 Make_Raise_Program_Error (Loc,
9166 PE_Access_Before_Elaboration))));
9170 Make_Raise_Program_Error (Loc,
9171 Reason => PE_Access_Before_Elaboration);
9173 Set_Etype (Ret_Expr, (Etype (Anon_Id)));
9174 Set_Analyzed (Ret_Expr);
9177 Make_Subprogram_Body (Loc,
9179 Make_Function_Specification (Loc,
9180 Defining_Unit_Name =>
9181 Make_Defining_Identifier (Loc, Chars (Anon_Id)),
9182 Parameter_Specifications =>
9184 (Parameter_Specifications (Parent (Anon_Id))),
9185 Result_Definition =>
9186 New_Occurrence_Of (Etype (Anon_Id), Loc)),
9188 Declarations => Empty_List,
9189 Handled_Statement_Sequence =>
9190 Make_Handled_Sequence_Of_Statements (Loc,
9193 (Make_Simple_Return_Statement (Loc, Ret_Expr))));
9196 Pack_Body := Make_Package_Body (Loc,
9197 Defining_Unit_Name => New_Copy (Pack_Id),
9198 Declarations => New_List (Act_Body));
9200 Insert_After (Inst_Node, Pack_Body);
9201 Set_Corresponding_Spec (Pack_Body, Pack_Id);
9202 Analyze (Pack_Body);
9205 Expander_Mode_Restore;
9206 end Instantiate_Subprogram_Body;
9208 ----------------------
9209 -- Instantiate_Type --
9210 ----------------------
9212 function Instantiate_Type
9215 Analyzed_Formal : Node_Id;
9216 Actual_Decls : List_Id) return List_Id
9218 Gen_T : constant Entity_Id := Defining_Identifier (Formal);
9219 A_Gen_T : constant Entity_Id :=
9220 Defining_Identifier (Analyzed_Formal);
9221 Ancestor : Entity_Id := Empty;
9222 Def : constant Node_Id := Formal_Type_Definition (Formal);
9224 Decl_Node : Node_Id;
9225 Decl_Nodes : List_Id;
9229 procedure Validate_Array_Type_Instance;
9230 procedure Validate_Access_Subprogram_Instance;
9231 procedure Validate_Access_Type_Instance;
9232 procedure Validate_Derived_Type_Instance;
9233 procedure Validate_Derived_Interface_Type_Instance;
9234 procedure Validate_Interface_Type_Instance;
9235 procedure Validate_Private_Type_Instance;
9236 -- These procedures perform validation tests for the named case
9238 function Subtypes_Match (Gen_T, Act_T : Entity_Id) return Boolean;
9239 -- Check that base types are the same and that the subtypes match
9240 -- statically. Used in several of the above.
9242 --------------------
9243 -- Subtypes_Match --
9244 --------------------
9246 function Subtypes_Match (Gen_T, Act_T : Entity_Id) return Boolean is
9247 T : constant Entity_Id := Get_Instance_Of (Gen_T);
9250 return (Base_Type (T) = Base_Type (Act_T)
9251 and then Subtypes_Statically_Match (T, Act_T))
9253 or else (Is_Class_Wide_Type (Gen_T)
9254 and then Is_Class_Wide_Type (Act_T)
9257 (Get_Instance_Of (Root_Type (Gen_T)),
9261 ((Ekind (Gen_T) = E_Anonymous_Access_Subprogram_Type
9262 or else Ekind (Gen_T) = E_Anonymous_Access_Type)
9263 and then Ekind (Act_T) = Ekind (Gen_T)
9265 Subtypes_Statically_Match
9266 (Designated_Type (Gen_T), Designated_Type (Act_T)));
9269 -----------------------------------------
9270 -- Validate_Access_Subprogram_Instance --
9271 -----------------------------------------
9273 procedure Validate_Access_Subprogram_Instance is
9275 if not Is_Access_Type (Act_T)
9276 or else Ekind (Designated_Type (Act_T)) /= E_Subprogram_Type
9279 ("expect access type in instantiation of &", Actual, Gen_T);
9280 Abandon_Instantiation (Actual);
9283 Check_Mode_Conformant
9284 (Designated_Type (Act_T),
9285 Designated_Type (A_Gen_T),
9289 if Ekind (Base_Type (Act_T)) = E_Access_Protected_Subprogram_Type then
9290 if Ekind (A_Gen_T) = E_Access_Subprogram_Type then
9292 ("protected access type not allowed for formal &",
9296 elsif Ekind (A_Gen_T) = E_Access_Protected_Subprogram_Type then
9298 ("expect protected access type for formal &",
9301 end Validate_Access_Subprogram_Instance;
9303 -----------------------------------
9304 -- Validate_Access_Type_Instance --
9305 -----------------------------------
9307 procedure Validate_Access_Type_Instance is
9308 Desig_Type : constant Entity_Id :=
9309 Find_Actual_Type (Designated_Type (A_Gen_T), A_Gen_T);
9310 Desig_Act : Entity_Id;
9313 if not Is_Access_Type (Act_T) then
9315 ("expect access type in instantiation of &", Actual, Gen_T);
9316 Abandon_Instantiation (Actual);
9319 if Is_Access_Constant (A_Gen_T) then
9320 if not Is_Access_Constant (Act_T) then
9322 ("actual type must be access-to-constant type", Actual);
9323 Abandon_Instantiation (Actual);
9326 if Is_Access_Constant (Act_T) then
9328 ("actual type must be access-to-variable type", Actual);
9329 Abandon_Instantiation (Actual);
9331 elsif Ekind (A_Gen_T) = E_General_Access_Type
9332 and then Ekind (Base_Type (Act_T)) /= E_General_Access_Type
9334 Error_Msg_N -- CODEFIX
9335 ("actual must be general access type!", Actual);
9336 Error_Msg_NE -- CODEFIX
9337 ("add ALL to }!", Actual, Act_T);
9338 Abandon_Instantiation (Actual);
9342 -- The designated subtypes, that is to say the subtypes introduced
9343 -- by an access type declaration (and not by a subtype declaration)
9346 Desig_Act := Designated_Type (Base_Type (Act_T));
9348 -- The designated type may have been introduced through a limited_
9349 -- with clause, in which case retrieve the non-limited view. This
9350 -- applies to incomplete types as well as to class-wide types.
9352 if From_With_Type (Desig_Act) then
9353 Desig_Act := Available_View (Desig_Act);
9356 if not Subtypes_Match
9357 (Desig_Type, Desig_Act) then
9359 ("designated type of actual does not match that of formal &",
9361 Abandon_Instantiation (Actual);
9363 elsif Is_Access_Type (Designated_Type (Act_T))
9364 and then Is_Constrained (Designated_Type (Designated_Type (Act_T)))
9366 Is_Constrained (Designated_Type (Desig_Type))
9369 ("designated type of actual does not match that of formal &",
9371 Abandon_Instantiation (Actual);
9374 -- Ada 2005: null-exclusion indicators of the two types must agree
9376 if Can_Never_Be_Null (A_Gen_T) /= Can_Never_Be_Null (Act_T) then
9378 ("non null exclusion of actual and formal & do not match",
9381 end Validate_Access_Type_Instance;
9383 ----------------------------------
9384 -- Validate_Array_Type_Instance --
9385 ----------------------------------
9387 procedure Validate_Array_Type_Instance is
9392 function Formal_Dimensions return Int;
9393 -- Count number of dimensions in array type formal
9395 -----------------------
9396 -- Formal_Dimensions --
9397 -----------------------
9399 function Formal_Dimensions return Int is
9404 if Nkind (Def) = N_Constrained_Array_Definition then
9405 Index := First (Discrete_Subtype_Definitions (Def));
9407 Index := First (Subtype_Marks (Def));
9410 while Present (Index) loop
9416 end Formal_Dimensions;
9418 -- Start of processing for Validate_Array_Type_Instance
9421 if not Is_Array_Type (Act_T) then
9423 ("expect array type in instantiation of &", Actual, Gen_T);
9424 Abandon_Instantiation (Actual);
9426 elsif Nkind (Def) = N_Constrained_Array_Definition then
9427 if not (Is_Constrained (Act_T)) then
9429 ("expect constrained array in instantiation of &",
9431 Abandon_Instantiation (Actual);
9435 if Is_Constrained (Act_T) then
9437 ("expect unconstrained array in instantiation of &",
9439 Abandon_Instantiation (Actual);
9443 if Formal_Dimensions /= Number_Dimensions (Act_T) then
9445 ("dimensions of actual do not match formal &", Actual, Gen_T);
9446 Abandon_Instantiation (Actual);
9449 I1 := First_Index (A_Gen_T);
9450 I2 := First_Index (Act_T);
9451 for J in 1 .. Formal_Dimensions loop
9453 -- If the indexes of the actual were given by a subtype_mark,
9454 -- the index was transformed into a range attribute. Retrieve
9455 -- the original type mark for checking.
9457 if Is_Entity_Name (Original_Node (I2)) then
9458 T2 := Entity (Original_Node (I2));
9463 if not Subtypes_Match
9464 (Find_Actual_Type (Etype (I1), A_Gen_T), T2)
9467 ("index types of actual do not match those of formal &",
9469 Abandon_Instantiation (Actual);
9476 -- Check matching subtypes. Note that there are complex visibility
9477 -- issues when the generic is a child unit and some aspect of the
9478 -- generic type is declared in a parent unit of the generic. We do
9479 -- the test to handle this special case only after a direct check
9480 -- for static matching has failed.
9483 (Component_Type (A_Gen_T), Component_Type (Act_T))
9484 or else Subtypes_Match
9485 (Find_Actual_Type (Component_Type (A_Gen_T), A_Gen_T),
9486 Component_Type (Act_T))
9491 ("component subtype of actual does not match that of formal &",
9493 Abandon_Instantiation (Actual);
9496 if Has_Aliased_Components (A_Gen_T)
9497 and then not Has_Aliased_Components (Act_T)
9500 ("actual must have aliased components to match formal type &",
9503 end Validate_Array_Type_Instance;
9505 -----------------------------------------------
9506 -- Validate_Derived_Interface_Type_Instance --
9507 -----------------------------------------------
9509 procedure Validate_Derived_Interface_Type_Instance is
9510 Par : constant Entity_Id := Entity (Subtype_Indication (Def));
9514 -- First apply interface instance checks
9516 Validate_Interface_Type_Instance;
9518 -- Verify that immediate parent interface is an ancestor of
9522 and then not Interface_Present_In_Ancestor (Act_T, Par)
9525 ("interface actual must include progenitor&", Actual, Par);
9528 -- Now verify that the actual includes all other ancestors of
9531 Elmt := First_Elmt (Interfaces (A_Gen_T));
9532 while Present (Elmt) loop
9533 if not Interface_Present_In_Ancestor
9534 (Act_T, Get_Instance_Of (Node (Elmt)))
9537 ("interface actual must include progenitor&",
9538 Actual, Node (Elmt));
9543 end Validate_Derived_Interface_Type_Instance;
9545 ------------------------------------
9546 -- Validate_Derived_Type_Instance --
9547 ------------------------------------
9549 procedure Validate_Derived_Type_Instance is
9550 Actual_Discr : Entity_Id;
9551 Ancestor_Discr : Entity_Id;
9554 -- If the parent type in the generic declaration is itself a previous
9555 -- formal type, then it is local to the generic and absent from the
9556 -- analyzed generic definition. In that case the ancestor is the
9557 -- instance of the formal (which must have been instantiated
9558 -- previously), unless the ancestor is itself a formal derived type.
9559 -- In this latter case (which is the subject of Corrigendum 8652/0038
9560 -- (AI-202) the ancestor of the formals is the ancestor of its
9561 -- parent. Otherwise, the analyzed generic carries the parent type.
9562 -- If the parent type is defined in a previous formal package, then
9563 -- the scope of that formal package is that of the generic type
9564 -- itself, and it has already been mapped into the corresponding type
9565 -- in the actual package.
9567 -- Common case: parent type defined outside of the generic
9569 if Is_Entity_Name (Subtype_Mark (Def))
9570 and then Present (Entity (Subtype_Mark (Def)))
9572 Ancestor := Get_Instance_Of (Entity (Subtype_Mark (Def)));
9574 -- Check whether parent is defined in a previous formal package
9577 Scope (Scope (Base_Type (Etype (A_Gen_T)))) = Scope (A_Gen_T)
9580 Get_Instance_Of (Base_Type (Etype (A_Gen_T)));
9582 -- The type may be a local derivation, or a type extension of a
9583 -- previous formal, or of a formal of a parent package.
9585 elsif Is_Derived_Type (Get_Instance_Of (A_Gen_T))
9587 Ekind (Get_Instance_Of (A_Gen_T)) = E_Record_Type_With_Private
9589 -- Check whether the parent is another derived formal type in the
9590 -- same generic unit.
9592 if Etype (A_Gen_T) /= A_Gen_T
9593 and then Is_Generic_Type (Etype (A_Gen_T))
9594 and then Scope (Etype (A_Gen_T)) = Scope (A_Gen_T)
9595 and then Etype (Etype (A_Gen_T)) /= Etype (A_Gen_T)
9597 -- Locate ancestor of parent from the subtype declaration
9598 -- created for the actual.
9604 Decl := First (Actual_Decls);
9605 while Present (Decl) loop
9606 if Nkind (Decl) = N_Subtype_Declaration
9607 and then Chars (Defining_Identifier (Decl)) =
9608 Chars (Etype (A_Gen_T))
9610 Ancestor := Generic_Parent_Type (Decl);
9618 pragma Assert (Present (Ancestor));
9622 Get_Instance_Of (Base_Type (Get_Instance_Of (A_Gen_T)));
9626 Ancestor := Get_Instance_Of (Etype (Base_Type (A_Gen_T)));
9629 -- If the formal derived type has pragma Preelaborable_Initialization
9630 -- then the actual type must have preelaborable initialization.
9632 if Known_To_Have_Preelab_Init (A_Gen_T)
9633 and then not Has_Preelaborable_Initialization (Act_T)
9636 ("actual for & must have preelaborable initialization",
9640 -- Ada 2005 (AI-251)
9642 if Ada_Version >= Ada_2005
9643 and then Is_Interface (Ancestor)
9645 if not Interface_Present_In_Ancestor (Act_T, Ancestor) then
9647 ("(Ada 2005) expected type implementing & in instantiation",
9651 elsif not Is_Ancestor (Base_Type (Ancestor), Act_T) then
9653 ("expect type derived from & in instantiation",
9654 Actual, First_Subtype (Ancestor));
9655 Abandon_Instantiation (Actual);
9658 -- Ada 2005 (AI-443): Synchronized formal derived type checks. Note
9659 -- that the formal type declaration has been rewritten as a private
9662 if Ada_Version >= Ada_2005
9663 and then Nkind (Parent (A_Gen_T)) = N_Private_Extension_Declaration
9664 and then Synchronized_Present (Parent (A_Gen_T))
9666 -- The actual must be a synchronized tagged type
9668 if not Is_Tagged_Type (Act_T) then
9670 ("actual of synchronized type must be tagged", Actual);
9671 Abandon_Instantiation (Actual);
9673 elsif Nkind (Parent (Act_T)) = N_Full_Type_Declaration
9674 and then Nkind (Type_Definition (Parent (Act_T))) =
9675 N_Derived_Type_Definition
9676 and then not Synchronized_Present (Type_Definition
9680 ("actual of synchronized type must be synchronized", Actual);
9681 Abandon_Instantiation (Actual);
9685 -- Perform atomic/volatile checks (RM C.6(12))
9687 if Is_Atomic (Act_T) and then not Is_Atomic (Ancestor) then
9689 ("cannot have atomic actual type for non-atomic formal type",
9692 elsif Is_Volatile (Act_T)
9693 and then not Is_Volatile (Ancestor)
9694 and then Is_By_Reference_Type (Ancestor)
9697 ("cannot have volatile actual type for non-volatile formal type",
9701 -- It should not be necessary to check for unknown discriminants on
9702 -- Formal, but for some reason Has_Unknown_Discriminants is false for
9703 -- A_Gen_T, so Is_Indefinite_Subtype incorrectly returns False. This
9704 -- needs fixing. ???
9706 if not Is_Indefinite_Subtype (A_Gen_T)
9707 and then not Unknown_Discriminants_Present (Formal)
9708 and then Is_Indefinite_Subtype (Act_T)
9711 ("actual subtype must be constrained", Actual);
9712 Abandon_Instantiation (Actual);
9715 if not Unknown_Discriminants_Present (Formal) then
9716 if Is_Constrained (Ancestor) then
9717 if not Is_Constrained (Act_T) then
9719 ("actual subtype must be constrained", Actual);
9720 Abandon_Instantiation (Actual);
9723 -- Ancestor is unconstrained, Check if generic formal and actual
9724 -- agree on constrainedness. The check only applies to array types
9725 -- and discriminated types.
9727 elsif Is_Constrained (Act_T) then
9728 if Ekind (Ancestor) = E_Access_Type
9730 (not Is_Constrained (A_Gen_T)
9731 and then Is_Composite_Type (A_Gen_T))
9734 ("actual subtype must be unconstrained", Actual);
9735 Abandon_Instantiation (Actual);
9738 -- A class-wide type is only allowed if the formal has unknown
9741 elsif Is_Class_Wide_Type (Act_T)
9742 and then not Has_Unknown_Discriminants (Ancestor)
9745 ("actual for & cannot be a class-wide type", Actual, Gen_T);
9746 Abandon_Instantiation (Actual);
9748 -- Otherwise, the formal and actual shall have the same number
9749 -- of discriminants and each discriminant of the actual must
9750 -- correspond to a discriminant of the formal.
9752 elsif Has_Discriminants (Act_T)
9753 and then not Has_Unknown_Discriminants (Act_T)
9754 and then Has_Discriminants (Ancestor)
9756 Actual_Discr := First_Discriminant (Act_T);
9757 Ancestor_Discr := First_Discriminant (Ancestor);
9758 while Present (Actual_Discr)
9759 and then Present (Ancestor_Discr)
9761 if Base_Type (Act_T) /= Base_Type (Ancestor) and then
9762 No (Corresponding_Discriminant (Actual_Discr))
9765 ("discriminant & does not correspond " &
9766 "to ancestor discriminant", Actual, Actual_Discr);
9767 Abandon_Instantiation (Actual);
9770 Next_Discriminant (Actual_Discr);
9771 Next_Discriminant (Ancestor_Discr);
9774 if Present (Actual_Discr) or else Present (Ancestor_Discr) then
9776 ("actual for & must have same number of discriminants",
9778 Abandon_Instantiation (Actual);
9781 -- This case should be caught by the earlier check for
9782 -- constrainedness, but the check here is added for completeness.
9784 elsif Has_Discriminants (Act_T)
9785 and then not Has_Unknown_Discriminants (Act_T)
9788 ("actual for & must not have discriminants", Actual, Gen_T);
9789 Abandon_Instantiation (Actual);
9791 elsif Has_Discriminants (Ancestor) then
9793 ("actual for & must have known discriminants", Actual, Gen_T);
9794 Abandon_Instantiation (Actual);
9797 if not Subtypes_Statically_Compatible (Act_T, Ancestor) then
9799 ("constraint on actual is incompatible with formal", Actual);
9800 Abandon_Instantiation (Actual);
9804 -- If the formal and actual types are abstract, check that there
9805 -- are no abstract primitives of the actual type that correspond to
9806 -- nonabstract primitives of the formal type (second sentence of
9809 if Is_Abstract_Type (A_Gen_T) and then Is_Abstract_Type (Act_T) then
9810 Check_Abstract_Primitives : declare
9811 Gen_Prims : constant Elist_Id :=
9812 Primitive_Operations (A_Gen_T);
9814 Gen_Subp : Entity_Id;
9815 Anc_Subp : Entity_Id;
9816 Anc_Formal : Entity_Id;
9817 Anc_F_Type : Entity_Id;
9819 Act_Prims : constant Elist_Id := Primitive_Operations (Act_T);
9821 Act_Subp : Entity_Id;
9822 Act_Formal : Entity_Id;
9823 Act_F_Type : Entity_Id;
9825 Subprograms_Correspond : Boolean;
9827 function Is_Tagged_Ancestor (T1, T2 : Entity_Id) return Boolean;
9828 -- Returns true if T2 is derived directly or indirectly from
9829 -- T1, including derivations from interfaces. T1 and T2 are
9830 -- required to be specific tagged base types.
9832 ------------------------
9833 -- Is_Tagged_Ancestor --
9834 ------------------------
9836 function Is_Tagged_Ancestor (T1, T2 : Entity_Id) return Boolean
9838 Intfc_Elmt : Elmt_Id;
9841 -- The predicate is satisfied if the types are the same
9846 -- If we've reached the top of the derivation chain then
9847 -- we know that T1 is not an ancestor of T2.
9849 elsif Etype (T2) = T2 then
9852 -- Proceed to check T2's immediate parent
9854 elsif Is_Ancestor (T1, Base_Type (Etype (T2))) then
9857 -- Finally, check to see if T1 is an ancestor of any of T2's
9861 Intfc_Elmt := First_Elmt (Interfaces (T2));
9862 while Present (Intfc_Elmt) loop
9863 if Is_Ancestor (T1, Node (Intfc_Elmt)) then
9867 Next_Elmt (Intfc_Elmt);
9872 end Is_Tagged_Ancestor;
9874 -- Start of processing for Check_Abstract_Primitives
9877 -- Loop over all of the formal derived type's primitives
9879 Gen_Elmt := First_Elmt (Gen_Prims);
9880 while Present (Gen_Elmt) loop
9881 Gen_Subp := Node (Gen_Elmt);
9883 -- If the primitive of the formal is not abstract, then
9884 -- determine whether there is a corresponding primitive of
9885 -- the actual type that's abstract.
9887 if not Is_Abstract_Subprogram (Gen_Subp) then
9888 Act_Elmt := First_Elmt (Act_Prims);
9889 while Present (Act_Elmt) loop
9890 Act_Subp := Node (Act_Elmt);
9892 -- If we find an abstract primitive of the actual,
9893 -- then we need to test whether it corresponds to the
9894 -- subprogram from which the generic formal primitive
9897 if Is_Abstract_Subprogram (Act_Subp) then
9898 Anc_Subp := Alias (Gen_Subp);
9900 -- Test whether we have a corresponding primitive
9901 -- by comparing names, kinds, formal types, and
9904 if Chars (Anc_Subp) = Chars (Act_Subp)
9905 and then Ekind (Anc_Subp) = Ekind (Act_Subp)
9907 Anc_Formal := First_Formal (Anc_Subp);
9908 Act_Formal := First_Formal (Act_Subp);
9909 while Present (Anc_Formal)
9910 and then Present (Act_Formal)
9912 Anc_F_Type := Etype (Anc_Formal);
9913 Act_F_Type := Etype (Act_Formal);
9915 if Ekind (Anc_F_Type)
9916 = E_Anonymous_Access_Type
9918 Anc_F_Type := Designated_Type (Anc_F_Type);
9920 if Ekind (Act_F_Type)
9921 = E_Anonymous_Access_Type
9924 Designated_Type (Act_F_Type);
9930 Ekind (Act_F_Type) = E_Anonymous_Access_Type
9935 Anc_F_Type := Base_Type (Anc_F_Type);
9936 Act_F_Type := Base_Type (Act_F_Type);
9938 -- If the formal is controlling, then the
9939 -- the type of the actual primitive's formal
9940 -- must be derived directly or indirectly
9941 -- from the type of the ancestor primitive's
9944 if Is_Controlling_Formal (Anc_Formal) then
9945 if not Is_Tagged_Ancestor
9946 (Anc_F_Type, Act_F_Type)
9951 -- Otherwise the types of the formals must
9954 elsif Anc_F_Type /= Act_F_Type then
9958 Next_Entity (Anc_Formal);
9959 Next_Entity (Act_Formal);
9962 -- If we traversed through all of the formals
9963 -- then so far the subprograms correspond, so
9964 -- now check that any result types correspond.
9966 if No (Anc_Formal) and then No (Act_Formal) then
9967 Subprograms_Correspond := True;
9969 if Ekind (Act_Subp) = E_Function then
9970 Anc_F_Type := Etype (Anc_Subp);
9971 Act_F_Type := Etype (Act_Subp);
9973 if Ekind (Anc_F_Type)
9974 = E_Anonymous_Access_Type
9977 Designated_Type (Anc_F_Type);
9979 if Ekind (Act_F_Type)
9980 = E_Anonymous_Access_Type
9983 Designated_Type (Act_F_Type);
9985 Subprograms_Correspond := False;
9990 = E_Anonymous_Access_Type
9992 Subprograms_Correspond := False;
9995 Anc_F_Type := Base_Type (Anc_F_Type);
9996 Act_F_Type := Base_Type (Act_F_Type);
9998 -- Now either the result types must be
9999 -- the same or, if the result type is
10000 -- controlling, the result type of the
10001 -- actual primitive must descend from the
10002 -- result type of the ancestor primitive.
10004 if Subprograms_Correspond
10005 and then Anc_F_Type /= Act_F_Type
10007 Has_Controlling_Result (Anc_Subp)
10009 not Is_Tagged_Ancestor
10010 (Anc_F_Type, Act_F_Type)
10012 Subprograms_Correspond := False;
10016 -- Found a matching subprogram belonging to
10017 -- formal ancestor type, so actual subprogram
10018 -- corresponds and this violates 3.9.3(9).
10020 if Subprograms_Correspond then
10022 ("abstract subprogram & overrides " &
10023 "nonabstract subprogram of ancestor",
10031 Next_Elmt (Act_Elmt);
10035 Next_Elmt (Gen_Elmt);
10037 end Check_Abstract_Primitives;
10040 -- Verify that limitedness matches. If parent is a limited
10041 -- interface then the generic formal is not unless declared
10042 -- explicitly so. If not declared limited, the actual cannot be
10043 -- limited (see AI05-0087).
10045 -- Even though this AI is a binding interpretation, we enable the
10046 -- check only in Ada 2012 mode, because this improper construct
10047 -- shows up in user code and in existing B-tests.
10049 if Is_Limited_Type (Act_T)
10050 and then not Is_Limited_Type (A_Gen_T)
10051 and then Ada_Version >= Ada_2012
10054 ("actual for non-limited & cannot be a limited type", Actual,
10056 Explain_Limited_Type (Act_T, Actual);
10057 Abandon_Instantiation (Actual);
10059 end Validate_Derived_Type_Instance;
10061 --------------------------------------
10062 -- Validate_Interface_Type_Instance --
10063 --------------------------------------
10065 procedure Validate_Interface_Type_Instance is
10067 if not Is_Interface (Act_T) then
10069 ("actual for formal interface type must be an interface",
10072 elsif Is_Limited_Type (Act_T) /= Is_Limited_Type (A_Gen_T)
10074 Is_Task_Interface (A_Gen_T) /= Is_Task_Interface (Act_T)
10076 Is_Protected_Interface (A_Gen_T) /=
10077 Is_Protected_Interface (Act_T)
10079 Is_Synchronized_Interface (A_Gen_T) /=
10080 Is_Synchronized_Interface (Act_T)
10083 ("actual for interface& does not match (RM 12.5.5(4))",
10086 end Validate_Interface_Type_Instance;
10088 ------------------------------------
10089 -- Validate_Private_Type_Instance --
10090 ------------------------------------
10092 procedure Validate_Private_Type_Instance is
10093 Formal_Discr : Entity_Id;
10094 Actual_Discr : Entity_Id;
10095 Formal_Subt : Entity_Id;
10098 if Is_Limited_Type (Act_T)
10099 and then not Is_Limited_Type (A_Gen_T)
10102 ("actual for non-limited & cannot be a limited type", Actual,
10104 Explain_Limited_Type (Act_T, Actual);
10105 Abandon_Instantiation (Actual);
10107 elsif Known_To_Have_Preelab_Init (A_Gen_T)
10108 and then not Has_Preelaborable_Initialization (Act_T)
10111 ("actual for & must have preelaborable initialization", Actual,
10114 elsif Is_Indefinite_Subtype (Act_T)
10115 and then not Is_Indefinite_Subtype (A_Gen_T)
10116 and then Ada_Version >= Ada_95
10119 ("actual for & must be a definite subtype", Actual, Gen_T);
10121 elsif not Is_Tagged_Type (Act_T)
10122 and then Is_Tagged_Type (A_Gen_T)
10125 ("actual for & must be a tagged type", Actual, Gen_T);
10127 elsif Has_Discriminants (A_Gen_T) then
10128 if not Has_Discriminants (Act_T) then
10130 ("actual for & must have discriminants", Actual, Gen_T);
10131 Abandon_Instantiation (Actual);
10133 elsif Is_Constrained (Act_T) then
10135 ("actual for & must be unconstrained", Actual, Gen_T);
10136 Abandon_Instantiation (Actual);
10139 Formal_Discr := First_Discriminant (A_Gen_T);
10140 Actual_Discr := First_Discriminant (Act_T);
10141 while Formal_Discr /= Empty loop
10142 if Actual_Discr = Empty then
10144 ("discriminants on actual do not match formal",
10146 Abandon_Instantiation (Actual);
10149 Formal_Subt := Get_Instance_Of (Etype (Formal_Discr));
10151 -- Access discriminants match if designated types do
10153 if Ekind (Base_Type (Formal_Subt)) = E_Anonymous_Access_Type
10154 and then (Ekind (Base_Type (Etype (Actual_Discr)))) =
10155 E_Anonymous_Access_Type
10158 (Designated_Type (Base_Type (Formal_Subt))) =
10159 Designated_Type (Base_Type (Etype (Actual_Discr)))
10163 elsif Base_Type (Formal_Subt) /=
10164 Base_Type (Etype (Actual_Discr))
10167 ("types of actual discriminants must match formal",
10169 Abandon_Instantiation (Actual);
10171 elsif not Subtypes_Statically_Match
10172 (Formal_Subt, Etype (Actual_Discr))
10173 and then Ada_Version >= Ada_95
10176 ("subtypes of actual discriminants must match formal",
10178 Abandon_Instantiation (Actual);
10181 Next_Discriminant (Formal_Discr);
10182 Next_Discriminant (Actual_Discr);
10185 if Actual_Discr /= Empty then
10187 ("discriminants on actual do not match formal",
10189 Abandon_Instantiation (Actual);
10196 end Validate_Private_Type_Instance;
10198 -- Start of processing for Instantiate_Type
10201 if Get_Instance_Of (A_Gen_T) /= A_Gen_T then
10202 Error_Msg_N ("duplicate instantiation of generic type", Actual);
10203 return New_List (Error);
10205 elsif not Is_Entity_Name (Actual)
10206 or else not Is_Type (Entity (Actual))
10209 ("expect valid subtype mark to instantiate &", Actual, Gen_T);
10210 Abandon_Instantiation (Actual);
10213 Act_T := Entity (Actual);
10215 -- Ada 2005 (AI-216): An Unchecked_Union subtype shall only be passed
10216 -- as a generic actual parameter if the corresponding formal type
10217 -- does not have a known_discriminant_part, or is a formal derived
10218 -- type that is an Unchecked_Union type.
10220 if Is_Unchecked_Union (Base_Type (Act_T)) then
10221 if not Has_Discriminants (A_Gen_T)
10223 (Is_Derived_Type (A_Gen_T)
10225 Is_Unchecked_Union (A_Gen_T))
10229 Error_Msg_N ("Unchecked_Union cannot be the actual for a" &
10230 " discriminated formal type", Act_T);
10235 -- Deal with fixed/floating restrictions
10237 if Is_Floating_Point_Type (Act_T) then
10238 Check_Restriction (No_Floating_Point, Actual);
10239 elsif Is_Fixed_Point_Type (Act_T) then
10240 Check_Restriction (No_Fixed_Point, Actual);
10243 -- Deal with error of using incomplete type as generic actual.
10244 -- This includes limited views of a type, even if the non-limited
10245 -- view may be available.
10247 if Ekind (Act_T) = E_Incomplete_Type
10248 or else (Is_Class_Wide_Type (Act_T)
10250 Ekind (Root_Type (Act_T)) = E_Incomplete_Type)
10252 if Is_Class_Wide_Type (Act_T)
10253 or else No (Full_View (Act_T))
10255 Error_Msg_N ("premature use of incomplete type", Actual);
10256 Abandon_Instantiation (Actual);
10258 Act_T := Full_View (Act_T);
10259 Set_Entity (Actual, Act_T);
10261 if Has_Private_Component (Act_T) then
10263 ("premature use of type with private component", Actual);
10267 -- Deal with error of premature use of private type as generic actual
10269 elsif Is_Private_Type (Act_T)
10270 and then Is_Private_Type (Base_Type (Act_T))
10271 and then not Is_Generic_Type (Act_T)
10272 and then not Is_Derived_Type (Act_T)
10273 and then No (Full_View (Root_Type (Act_T)))
10275 Error_Msg_N ("premature use of private type", Actual);
10277 elsif Has_Private_Component (Act_T) then
10279 ("premature use of type with private component", Actual);
10282 Set_Instance_Of (A_Gen_T, Act_T);
10284 -- If the type is generic, the class-wide type may also be used
10286 if Is_Tagged_Type (A_Gen_T)
10287 and then Is_Tagged_Type (Act_T)
10288 and then not Is_Class_Wide_Type (A_Gen_T)
10290 Set_Instance_Of (Class_Wide_Type (A_Gen_T),
10291 Class_Wide_Type (Act_T));
10294 if not Is_Abstract_Type (A_Gen_T)
10295 and then Is_Abstract_Type (Act_T)
10298 ("actual of non-abstract formal cannot be abstract", Actual);
10301 -- A generic scalar type is a first subtype for which we generate
10302 -- an anonymous base type. Indicate that the instance of this base
10303 -- is the base type of the actual.
10305 if Is_Scalar_Type (A_Gen_T) then
10306 Set_Instance_Of (Etype (A_Gen_T), Etype (Act_T));
10310 if Error_Posted (Act_T) then
10313 case Nkind (Def) is
10314 when N_Formal_Private_Type_Definition =>
10315 Validate_Private_Type_Instance;
10317 when N_Formal_Derived_Type_Definition =>
10318 Validate_Derived_Type_Instance;
10320 when N_Formal_Discrete_Type_Definition =>
10321 if not Is_Discrete_Type (Act_T) then
10323 ("expect discrete type in instantiation of&",
10325 Abandon_Instantiation (Actual);
10328 when N_Formal_Signed_Integer_Type_Definition =>
10329 if not Is_Signed_Integer_Type (Act_T) then
10331 ("expect signed integer type in instantiation of&",
10333 Abandon_Instantiation (Actual);
10336 when N_Formal_Modular_Type_Definition =>
10337 if not Is_Modular_Integer_Type (Act_T) then
10339 ("expect modular type in instantiation of &",
10341 Abandon_Instantiation (Actual);
10344 when N_Formal_Floating_Point_Definition =>
10345 if not Is_Floating_Point_Type (Act_T) then
10347 ("expect float type in instantiation of &", Actual, Gen_T);
10348 Abandon_Instantiation (Actual);
10351 when N_Formal_Ordinary_Fixed_Point_Definition =>
10352 if not Is_Ordinary_Fixed_Point_Type (Act_T) then
10354 ("expect ordinary fixed point type in instantiation of &",
10356 Abandon_Instantiation (Actual);
10359 when N_Formal_Decimal_Fixed_Point_Definition =>
10360 if not Is_Decimal_Fixed_Point_Type (Act_T) then
10362 ("expect decimal type in instantiation of &",
10364 Abandon_Instantiation (Actual);
10367 when N_Array_Type_Definition =>
10368 Validate_Array_Type_Instance;
10370 when N_Access_To_Object_Definition =>
10371 Validate_Access_Type_Instance;
10373 when N_Access_Function_Definition |
10374 N_Access_Procedure_Definition =>
10375 Validate_Access_Subprogram_Instance;
10377 when N_Record_Definition =>
10378 Validate_Interface_Type_Instance;
10380 when N_Derived_Type_Definition =>
10381 Validate_Derived_Interface_Type_Instance;
10384 raise Program_Error;
10389 Subt := New_Copy (Gen_T);
10391 -- Use adjusted sloc of subtype name as the location for other nodes in
10392 -- the subtype declaration.
10394 Loc := Sloc (Subt);
10397 Make_Subtype_Declaration (Loc,
10398 Defining_Identifier => Subt,
10399 Subtype_Indication => New_Reference_To (Act_T, Loc));
10401 if Is_Private_Type (Act_T) then
10402 Set_Has_Private_View (Subtype_Indication (Decl_Node));
10404 elsif Is_Access_Type (Act_T)
10405 and then Is_Private_Type (Designated_Type (Act_T))
10407 Set_Has_Private_View (Subtype_Indication (Decl_Node));
10410 Decl_Nodes := New_List (Decl_Node);
10412 -- Flag actual derived types so their elaboration produces the
10413 -- appropriate renamings for the primitive operations of the ancestor.
10414 -- Flag actual for formal private types as well, to determine whether
10415 -- operations in the private part may override inherited operations.
10416 -- If the formal has an interface list, the ancestor is not the
10417 -- parent, but the analyzed formal that includes the interface
10418 -- operations of all its progenitors.
10420 -- Same treatment for formal private types, so we can check whether the
10421 -- type is tagged limited when validating derivations in the private
10422 -- part. (See AI05-096).
10424 if Nkind (Def) = N_Formal_Derived_Type_Definition then
10425 if Present (Interface_List (Def)) then
10426 Set_Generic_Parent_Type (Decl_Node, A_Gen_T);
10428 Set_Generic_Parent_Type (Decl_Node, Ancestor);
10431 elsif Nkind (Def) = N_Formal_Private_Type_Definition then
10432 Set_Generic_Parent_Type (Decl_Node, A_Gen_T);
10435 -- If the actual is a synchronized type that implements an interface,
10436 -- the primitive operations are attached to the corresponding record,
10437 -- and we have to treat it as an additional generic actual, so that its
10438 -- primitive operations become visible in the instance. The task or
10439 -- protected type itself does not carry primitive operations.
10441 if Is_Concurrent_Type (Act_T)
10442 and then Is_Tagged_Type (Act_T)
10443 and then Present (Corresponding_Record_Type (Act_T))
10444 and then Present (Ancestor)
10445 and then Is_Interface (Ancestor)
10448 Corr_Rec : constant Entity_Id :=
10449 Corresponding_Record_Type (Act_T);
10450 New_Corr : Entity_Id;
10451 Corr_Decl : Node_Id;
10454 New_Corr := Make_Temporary (Loc, 'S');
10456 Make_Subtype_Declaration (Loc,
10457 Defining_Identifier => New_Corr,
10458 Subtype_Indication =>
10459 New_Reference_To (Corr_Rec, Loc));
10460 Append_To (Decl_Nodes, Corr_Decl);
10462 if Ekind (Act_T) = E_Task_Type then
10463 Set_Ekind (Subt, E_Task_Subtype);
10465 Set_Ekind (Subt, E_Protected_Subtype);
10468 Set_Corresponding_Record_Type (Subt, Corr_Rec);
10469 Set_Generic_Parent_Type (Corr_Decl, Ancestor);
10470 Set_Generic_Parent_Type (Decl_Node, Empty);
10475 end Instantiate_Type;
10477 ---------------------
10478 -- Is_In_Main_Unit --
10479 ---------------------
10481 function Is_In_Main_Unit (N : Node_Id) return Boolean is
10482 Unum : constant Unit_Number_Type := Get_Source_Unit (N);
10483 Current_Unit : Node_Id;
10486 if Unum = Main_Unit then
10489 -- If the current unit is a subunit then it is either the main unit or
10490 -- is being compiled as part of the main unit.
10492 elsif Nkind (N) = N_Compilation_Unit then
10493 return Nkind (Unit (N)) = N_Subunit;
10496 Current_Unit := Parent (N);
10497 while Present (Current_Unit)
10498 and then Nkind (Current_Unit) /= N_Compilation_Unit
10500 Current_Unit := Parent (Current_Unit);
10503 -- The instantiation node is in the main unit, or else the current node
10504 -- (perhaps as the result of nested instantiations) is in the main unit,
10505 -- or in the declaration of the main unit, which in this last case must
10508 return Unum = Main_Unit
10509 or else Current_Unit = Cunit (Main_Unit)
10510 or else Current_Unit = Library_Unit (Cunit (Main_Unit))
10511 or else (Present (Library_Unit (Current_Unit))
10512 and then Is_In_Main_Unit (Library_Unit (Current_Unit)));
10513 end Is_In_Main_Unit;
10515 ----------------------------
10516 -- Load_Parent_Of_Generic --
10517 ----------------------------
10519 procedure Load_Parent_Of_Generic
10522 Body_Optional : Boolean := False)
10524 Comp_Unit : constant Node_Id := Cunit (Get_Source_Unit (Spec));
10525 Save_Style_Check : constant Boolean := Style_Check;
10526 True_Parent : Node_Id;
10527 Inst_Node : Node_Id;
10529 Previous_Instances : constant Elist_Id := New_Elmt_List;
10531 procedure Collect_Previous_Instances (Decls : List_Id);
10532 -- Collect all instantiations in the given list of declarations, that
10533 -- precede the generic that we need to load. If the bodies of these
10534 -- instantiations are available, we must analyze them, to ensure that
10535 -- the public symbols generated are the same when the unit is compiled
10536 -- to generate code, and when it is compiled in the context of a unit
10537 -- that needs a particular nested instance. This process is applied to
10538 -- both package and subprogram instances.
10540 --------------------------------
10541 -- Collect_Previous_Instances --
10542 --------------------------------
10544 procedure Collect_Previous_Instances (Decls : List_Id) is
10548 Decl := First (Decls);
10549 while Present (Decl) loop
10550 if Sloc (Decl) >= Sloc (Inst_Node) then
10553 -- If Decl is an instantiation, then record it as requiring
10554 -- instantiation of the corresponding body, except if it is an
10555 -- abbreviated instantiation generated internally for conformance
10556 -- checking purposes only for the case of a formal package
10557 -- declared without a box (see Instantiate_Formal_Package). Such
10558 -- an instantiation does not generate any code (the actual code
10559 -- comes from actual) and thus does not need to be analyzed here.
10560 -- If the instantiation appears with a generic package body it is
10561 -- not analyzed here either.
10563 elsif Nkind (Decl) = N_Package_Instantiation
10564 and then not Is_Internal (Defining_Entity (Decl))
10566 Append_Elmt (Decl, Previous_Instances);
10568 -- For a subprogram instantiation, omit instantiations intrinsic
10569 -- operations (Unchecked_Conversions, etc.) that have no bodies.
10571 elsif Nkind_In (Decl, N_Function_Instantiation,
10572 N_Procedure_Instantiation)
10573 and then not Is_Intrinsic_Subprogram (Entity (Name (Decl)))
10575 Append_Elmt (Decl, Previous_Instances);
10577 elsif Nkind (Decl) = N_Package_Declaration then
10578 Collect_Previous_Instances
10579 (Visible_Declarations (Specification (Decl)));
10580 Collect_Previous_Instances
10581 (Private_Declarations (Specification (Decl)));
10583 -- Previous non-generic bodies may contain instances as well
10585 elsif Nkind (Decl) = N_Package_Body
10586 and then Ekind (Corresponding_Spec (Decl)) /= E_Generic_Package
10588 Collect_Previous_Instances (Declarations (Decl));
10590 elsif Nkind (Decl) = N_Subprogram_Body
10591 and then not Acts_As_Spec (Decl)
10592 and then not Is_Generic_Subprogram (Corresponding_Spec (Decl))
10594 Collect_Previous_Instances (Declarations (Decl));
10599 end Collect_Previous_Instances;
10601 -- Start of processing for Load_Parent_Of_Generic
10604 if not In_Same_Source_Unit (N, Spec)
10605 or else Nkind (Unit (Comp_Unit)) = N_Package_Declaration
10606 or else (Nkind (Unit (Comp_Unit)) = N_Package_Body
10607 and then not Is_In_Main_Unit (Spec))
10609 -- Find body of parent of spec, and analyze it. A special case arises
10610 -- when the parent is an instantiation, that is to say when we are
10611 -- currently instantiating a nested generic. In that case, there is
10612 -- no separate file for the body of the enclosing instance. Instead,
10613 -- the enclosing body must be instantiated as if it were a pending
10614 -- instantiation, in order to produce the body for the nested generic
10615 -- we require now. Note that in that case the generic may be defined
10616 -- in a package body, the instance defined in the same package body,
10617 -- and the original enclosing body may not be in the main unit.
10619 Inst_Node := Empty;
10621 True_Parent := Parent (Spec);
10622 while Present (True_Parent)
10623 and then Nkind (True_Parent) /= N_Compilation_Unit
10625 if Nkind (True_Parent) = N_Package_Declaration
10627 Nkind (Original_Node (True_Parent)) = N_Package_Instantiation
10629 -- Parent is a compilation unit that is an instantiation.
10630 -- Instantiation node has been replaced with package decl.
10632 Inst_Node := Original_Node (True_Parent);
10635 elsif Nkind (True_Parent) = N_Package_Declaration
10636 and then Present (Generic_Parent (Specification (True_Parent)))
10637 and then Nkind (Parent (True_Parent)) /= N_Compilation_Unit
10639 -- Parent is an instantiation within another specification.
10640 -- Declaration for instance has been inserted before original
10641 -- instantiation node. A direct link would be preferable?
10643 Inst_Node := Next (True_Parent);
10644 while Present (Inst_Node)
10645 and then Nkind (Inst_Node) /= N_Package_Instantiation
10650 -- If the instance appears within a generic, and the generic
10651 -- unit is defined within a formal package of the enclosing
10652 -- generic, there is no generic body available, and none
10653 -- needed. A more precise test should be used ???
10655 if No (Inst_Node) then
10662 True_Parent := Parent (True_Parent);
10666 -- Case where we are currently instantiating a nested generic
10668 if Present (Inst_Node) then
10669 if Nkind (Parent (True_Parent)) = N_Compilation_Unit then
10671 -- Instantiation node and declaration of instantiated package
10672 -- were exchanged when only the declaration was needed.
10673 -- Restore instantiation node before proceeding with body.
10675 Set_Unit (Parent (True_Parent), Inst_Node);
10678 -- Now complete instantiation of enclosing body, if it appears in
10679 -- some other unit. If it appears in the current unit, the body
10680 -- will have been instantiated already.
10682 if No (Corresponding_Body (Instance_Spec (Inst_Node))) then
10684 -- We need to determine the expander mode to instantiate the
10685 -- enclosing body. Because the generic body we need may use
10686 -- global entities declared in the enclosing package (including
10687 -- aggregates) it is in general necessary to compile this body
10688 -- with expansion enabled, except if we are within a generic
10689 -- package, in which case the usual generic rule applies.
10692 Exp_Status : Boolean := True;
10696 -- Loop through scopes looking for generic package
10698 Scop := Scope (Defining_Entity (Instance_Spec (Inst_Node)));
10699 while Present (Scop)
10700 and then Scop /= Standard_Standard
10702 if Ekind (Scop) = E_Generic_Package then
10703 Exp_Status := False;
10707 Scop := Scope (Scop);
10710 -- Collect previous instantiations in the unit that contains
10711 -- the desired generic.
10713 if Nkind (Parent (True_Parent)) /= N_Compilation_Unit
10714 and then not Body_Optional
10718 Info : Pending_Body_Info;
10722 Par := Parent (Inst_Node);
10723 while Present (Par) loop
10724 exit when Nkind (Parent (Par)) = N_Compilation_Unit;
10725 Par := Parent (Par);
10728 pragma Assert (Present (Par));
10730 if Nkind (Par) = N_Package_Body then
10731 Collect_Previous_Instances (Declarations (Par));
10733 elsif Nkind (Par) = N_Package_Declaration then
10734 Collect_Previous_Instances
10735 (Visible_Declarations (Specification (Par)));
10736 Collect_Previous_Instances
10737 (Private_Declarations (Specification (Par)));
10740 -- Enclosing unit is a subprogram body. In this
10741 -- case all instance bodies are processed in order
10742 -- and there is no need to collect them separately.
10747 Decl := First_Elmt (Previous_Instances);
10748 while Present (Decl) loop
10750 (Inst_Node => Node (Decl),
10752 Instance_Spec (Node (Decl)),
10753 Expander_Status => Exp_Status,
10754 Current_Sem_Unit =>
10755 Get_Code_Unit (Sloc (Node (Decl))),
10756 Scope_Suppress => Scope_Suppress,
10757 Local_Suppress_Stack_Top =>
10758 Local_Suppress_Stack_Top,
10759 Version => Ada_Version);
10761 -- Package instance
10764 Nkind (Node (Decl)) = N_Package_Instantiation
10766 Instantiate_Package_Body
10767 (Info, Body_Optional => True);
10769 -- Subprogram instance
10772 -- The instance_spec is the wrapper package,
10773 -- and the subprogram declaration is the last
10774 -- declaration in the wrapper.
10778 (Visible_Declarations
10779 (Specification (Info.Act_Decl)));
10781 Instantiate_Subprogram_Body
10782 (Info, Body_Optional => True);
10790 Instantiate_Package_Body
10792 ((Inst_Node => Inst_Node,
10793 Act_Decl => True_Parent,
10794 Expander_Status => Exp_Status,
10795 Current_Sem_Unit =>
10796 Get_Code_Unit (Sloc (Inst_Node)),
10797 Scope_Suppress => Scope_Suppress,
10798 Local_Suppress_Stack_Top =>
10799 Local_Suppress_Stack_Top,
10800 Version => Ada_Version)),
10801 Body_Optional => Body_Optional);
10805 -- Case where we are not instantiating a nested generic
10808 Opt.Style_Check := False;
10809 Expander_Mode_Save_And_Set (True);
10810 Load_Needed_Body (Comp_Unit, OK);
10811 Opt.Style_Check := Save_Style_Check;
10812 Expander_Mode_Restore;
10815 and then Unit_Requires_Body (Defining_Entity (Spec))
10816 and then not Body_Optional
10819 Bname : constant Unit_Name_Type :=
10820 Get_Body_Name (Get_Unit_Name (Unit (Comp_Unit)));
10823 -- In CodePeer mode, the missing body may make the analysis
10824 -- incomplete, but we do not treat it as fatal.
10826 if CodePeer_Mode then
10830 Error_Msg_Unit_1 := Bname;
10831 Error_Msg_N ("this instantiation requires$!", N);
10832 Error_Msg_File_1 :=
10833 Get_File_Name (Bname, Subunit => False);
10834 Error_Msg_N ("\but file{ was not found!", N);
10835 raise Unrecoverable_Error;
10842 -- If loading parent of the generic caused an instantiation circularity,
10843 -- we abandon compilation at this point, because otherwise in some cases
10844 -- we get into trouble with infinite recursions after this point.
10846 if Circularity_Detected then
10847 raise Unrecoverable_Error;
10849 end Load_Parent_Of_Generic;
10851 ---------------------------------
10852 -- Map_Formal_Package_Entities --
10853 ---------------------------------
10855 procedure Map_Formal_Package_Entities (Form : Entity_Id; Act : Entity_Id) is
10860 Set_Instance_Of (Form, Act);
10862 -- Traverse formal and actual package to map the corresponding entities.
10863 -- We skip over internal entities that may be generated during semantic
10864 -- analysis, and find the matching entities by name, given that they
10865 -- must appear in the same order.
10867 E1 := First_Entity (Form);
10868 E2 := First_Entity (Act);
10869 while Present (E1) and then E1 /= First_Private_Entity (Form) loop
10870 -- Could this test be a single condition???
10871 -- Seems like it could, and isn't FPE (Form) a constant anyway???
10873 if not Is_Internal (E1)
10874 and then Present (Parent (E1))
10875 and then not Is_Class_Wide_Type (E1)
10876 and then not Is_Internal_Name (Chars (E1))
10878 while Present (E2) and then Chars (E2) /= Chars (E1) loop
10885 Set_Instance_Of (E1, E2);
10887 if Is_Type (E1) and then Is_Tagged_Type (E2) then
10888 Set_Instance_Of (Class_Wide_Type (E1), Class_Wide_Type (E2));
10891 if Is_Constrained (E1) then
10892 Set_Instance_Of (Base_Type (E1), Base_Type (E2));
10895 if Ekind (E1) = E_Package and then No (Renamed_Object (E1)) then
10896 Map_Formal_Package_Entities (E1, E2);
10903 end Map_Formal_Package_Entities;
10905 -----------------------
10906 -- Move_Freeze_Nodes --
10907 -----------------------
10909 procedure Move_Freeze_Nodes
10910 (Out_Of : Entity_Id;
10915 Next_Decl : Node_Id;
10916 Next_Node : Node_Id := After;
10919 function Is_Outer_Type (T : Entity_Id) return Boolean;
10920 -- Check whether entity is declared in a scope external to that of the
10923 -------------------
10924 -- Is_Outer_Type --
10925 -------------------
10927 function Is_Outer_Type (T : Entity_Id) return Boolean is
10928 Scop : Entity_Id := Scope (T);
10931 if Scope_Depth (Scop) < Scope_Depth (Out_Of) then
10935 while Scop /= Standard_Standard loop
10936 if Scop = Out_Of then
10939 Scop := Scope (Scop);
10947 -- Start of processing for Move_Freeze_Nodes
10954 -- First remove the freeze nodes that may appear before all other
10958 while Present (Decl)
10959 and then Nkind (Decl) = N_Freeze_Entity
10960 and then Is_Outer_Type (Entity (Decl))
10962 Decl := Remove_Head (L);
10963 Insert_After (Next_Node, Decl);
10964 Set_Analyzed (Decl, False);
10969 -- Next scan the list of declarations and remove each freeze node that
10970 -- appears ahead of the current node.
10972 while Present (Decl) loop
10973 while Present (Next (Decl))
10974 and then Nkind (Next (Decl)) = N_Freeze_Entity
10975 and then Is_Outer_Type (Entity (Next (Decl)))
10977 Next_Decl := Remove_Next (Decl);
10978 Insert_After (Next_Node, Next_Decl);
10979 Set_Analyzed (Next_Decl, False);
10980 Next_Node := Next_Decl;
10983 -- If the declaration is a nested package or concurrent type, then
10984 -- recurse. Nested generic packages will have been processed from the
10987 case Nkind (Decl) is
10988 when N_Package_Declaration =>
10989 Spec := Specification (Decl);
10991 when N_Task_Type_Declaration =>
10992 Spec := Task_Definition (Decl);
10994 when N_Protected_Type_Declaration =>
10995 Spec := Protected_Definition (Decl);
11001 if Present (Spec) then
11002 Move_Freeze_Nodes (Out_Of, Next_Node, Visible_Declarations (Spec));
11003 Move_Freeze_Nodes (Out_Of, Next_Node, Private_Declarations (Spec));
11008 end Move_Freeze_Nodes;
11014 function Next_Assoc (E : Assoc_Ptr) return Assoc_Ptr is
11016 return Generic_Renamings.Table (E).Next_In_HTable;
11019 ------------------------
11020 -- Preanalyze_Actuals --
11021 ------------------------
11023 procedure Preanalyze_Actuals (N : Node_Id) is
11026 Errs : constant Int := Serious_Errors_Detected;
11028 Cur : Entity_Id := Empty;
11029 -- Current homograph of the instance name
11032 -- Saved visibility status of the current homograph
11035 Assoc := First (Generic_Associations (N));
11037 -- If the instance is a child unit, its name may hide an outer homonym,
11038 -- so make it invisible to perform name resolution on the actuals.
11040 if Nkind (Defining_Unit_Name (N)) = N_Defining_Program_Unit_Name
11042 (Current_Entity (Defining_Identifier (Defining_Unit_Name (N))))
11044 Cur := Current_Entity (Defining_Identifier (Defining_Unit_Name (N)));
11046 if Is_Compilation_Unit (Cur) then
11047 Vis := Is_Immediately_Visible (Cur);
11048 Set_Is_Immediately_Visible (Cur, False);
11054 while Present (Assoc) loop
11055 if Nkind (Assoc) /= N_Others_Choice then
11056 Act := Explicit_Generic_Actual_Parameter (Assoc);
11058 -- Within a nested instantiation, a defaulted actual is an empty
11059 -- association, so nothing to analyze. If the subprogram actual
11060 -- is an attribute, analyze prefix only, because actual is not a
11061 -- complete attribute reference.
11063 -- If actual is an allocator, analyze expression only. The full
11064 -- analysis can generate code, and if instance is a compilation
11065 -- unit we have to wait until the package instance is installed
11066 -- to have a proper place to insert this code.
11068 -- String literals may be operators, but at this point we do not
11069 -- know whether the actual is a formal subprogram or a string.
11074 elsif Nkind (Act) = N_Attribute_Reference then
11075 Analyze (Prefix (Act));
11077 elsif Nkind (Act) = N_Explicit_Dereference then
11078 Analyze (Prefix (Act));
11080 elsif Nkind (Act) = N_Allocator then
11082 Expr : constant Node_Id := Expression (Act);
11085 if Nkind (Expr) = N_Subtype_Indication then
11086 Analyze (Subtype_Mark (Expr));
11088 -- Analyze separately each discriminant constraint, when
11089 -- given with a named association.
11095 Constr := First (Constraints (Constraint (Expr)));
11096 while Present (Constr) loop
11097 if Nkind (Constr) = N_Discriminant_Association then
11098 Analyze (Expression (Constr));
11112 elsif Nkind (Act) /= N_Operator_Symbol then
11116 if Errs /= Serious_Errors_Detected then
11118 -- Do a minimal analysis of the generic, to prevent spurious
11119 -- warnings complaining about the generic being unreferenced,
11120 -- before abandoning the instantiation.
11122 Analyze (Name (N));
11124 if Is_Entity_Name (Name (N))
11125 and then Etype (Name (N)) /= Any_Type
11127 Generate_Reference (Entity (Name (N)), Name (N));
11128 Set_Is_Instantiated (Entity (Name (N)));
11131 if Present (Cur) then
11133 -- For the case of a child instance hiding an outer homonym,
11134 -- provide additional warning which might explain the error.
11136 Set_Is_Immediately_Visible (Cur, Vis);
11137 Error_Msg_NE ("& hides outer unit with the same name?",
11138 N, Defining_Unit_Name (N));
11141 Abandon_Instantiation (Act);
11148 if Present (Cur) then
11149 Set_Is_Immediately_Visible (Cur, Vis);
11151 end Preanalyze_Actuals;
11153 -------------------
11154 -- Remove_Parent --
11155 -------------------
11157 procedure Remove_Parent (In_Body : Boolean := False) is
11158 S : Entity_Id := Current_Scope;
11159 -- S is the scope containing the instantiation just completed. The scope
11160 -- stack contains the parent instances of the instantiation, followed by
11169 -- After child instantiation is complete, remove from scope stack the
11170 -- extra copy of the current scope, and then remove parent instances.
11172 if not In_Body then
11175 while Current_Scope /= S loop
11176 P := Current_Scope;
11177 End_Package_Scope (Current_Scope);
11179 if In_Open_Scopes (P) then
11180 E := First_Entity (P);
11181 while Present (E) loop
11182 Set_Is_Immediately_Visible (E, True);
11186 -- If instantiation is declared in a block, it is the enclosing
11187 -- scope that might be a parent instance. Note that only one
11188 -- block can be involved, because the parent instances have
11189 -- been installed within it.
11191 if Ekind (P) = E_Block then
11192 Cur_P := Scope (P);
11197 if Is_Generic_Instance (Cur_P) and then P /= Current_Scope then
11198 -- We are within an instance of some sibling. Retain
11199 -- visibility of parent, for proper subsequent cleanup, and
11200 -- reinstall private declarations as well.
11202 Set_In_Private_Part (P);
11203 Install_Private_Declarations (P);
11206 -- If the ultimate parent is a top-level unit recorded in
11207 -- Instance_Parent_Unit, then reset its visibility to what it was
11208 -- before instantiation. (It's not clear what the purpose is of
11209 -- testing whether Scope (P) is In_Open_Scopes, but that test was
11210 -- present before the ultimate parent test was added.???)
11212 elsif not In_Open_Scopes (Scope (P))
11213 or else (P = Instance_Parent_Unit
11214 and then not Parent_Unit_Visible)
11216 Set_Is_Immediately_Visible (P, False);
11218 -- If the current scope is itself an instantiation of a generic
11219 -- nested within P, and we are in the private part of body of this
11220 -- instantiation, restore the full views of P, that were removed
11221 -- in End_Package_Scope above. This obscure case can occur when a
11222 -- subunit of a generic contains an instance of a child unit of
11223 -- its generic parent unit.
11225 elsif S = Current_Scope and then Is_Generic_Instance (S) then
11227 Par : constant Entity_Id :=
11229 (Specification (Unit_Declaration_Node (S)));
11232 and then P = Scope (Par)
11233 and then (In_Package_Body (S) or else In_Private_Part (S))
11235 Set_In_Private_Part (P);
11236 Install_Private_Declarations (P);
11242 -- Reset visibility of entities in the enclosing scope
11244 Set_Is_Hidden_Open_Scope (Current_Scope, False);
11246 Hidden := First_Elmt (Hidden_Entities);
11247 while Present (Hidden) loop
11248 Set_Is_Immediately_Visible (Node (Hidden), True);
11249 Next_Elmt (Hidden);
11253 -- Each body is analyzed separately, and there is no context that
11254 -- needs preserving from one body instance to the next, so remove all
11255 -- parent scopes that have been installed.
11257 while Present (S) loop
11258 End_Package_Scope (S);
11259 Set_Is_Immediately_Visible (S, False);
11260 S := Current_Scope;
11261 exit when S = Standard_Standard;
11270 procedure Restore_Env is
11271 Saved : Instance_Env renames Instance_Envs.Table (Instance_Envs.Last);
11274 if No (Current_Instantiated_Parent.Act_Id) then
11275 -- Restore environment after subprogram inlining
11277 Restore_Private_Views (Empty);
11280 Current_Instantiated_Parent := Saved.Instantiated_Parent;
11281 Exchanged_Views := Saved.Exchanged_Views;
11282 Hidden_Entities := Saved.Hidden_Entities;
11283 Current_Sem_Unit := Saved.Current_Sem_Unit;
11284 Parent_Unit_Visible := Saved.Parent_Unit_Visible;
11285 Instance_Parent_Unit := Saved.Instance_Parent_Unit;
11287 Restore_Opt_Config_Switches (Saved.Switches);
11289 Instance_Envs.Decrement_Last;
11292 ---------------------------
11293 -- Restore_Private_Views --
11294 ---------------------------
11296 procedure Restore_Private_Views
11297 (Pack_Id : Entity_Id;
11298 Is_Package : Boolean := True)
11303 Dep_Elmt : Elmt_Id;
11306 procedure Restore_Nested_Formal (Formal : Entity_Id);
11307 -- Hide the generic formals of formal packages declared with box which
11308 -- were reachable in the current instantiation.
11310 ---------------------------
11311 -- Restore_Nested_Formal --
11312 ---------------------------
11314 procedure Restore_Nested_Formal (Formal : Entity_Id) is
11318 if Present (Renamed_Object (Formal))
11319 and then Denotes_Formal_Package (Renamed_Object (Formal), True)
11323 elsif Present (Associated_Formal_Package (Formal)) then
11324 Ent := First_Entity (Formal);
11325 while Present (Ent) loop
11326 exit when Ekind (Ent) = E_Package
11327 and then Renamed_Entity (Ent) = Renamed_Entity (Formal);
11329 Set_Is_Hidden (Ent);
11330 Set_Is_Potentially_Use_Visible (Ent, False);
11332 -- If package, then recurse
11334 if Ekind (Ent) = E_Package then
11335 Restore_Nested_Formal (Ent);
11341 end Restore_Nested_Formal;
11343 -- Start of processing for Restore_Private_Views
11346 M := First_Elmt (Exchanged_Views);
11347 while Present (M) loop
11350 -- Subtypes of types whose views have been exchanged, and that are
11351 -- defined within the instance, were not on the Private_Dependents
11352 -- list on entry to the instance, so they have to be exchanged
11353 -- explicitly now, in order to remain consistent with the view of the
11356 if Ekind_In (Typ, E_Private_Type,
11357 E_Limited_Private_Type,
11358 E_Record_Type_With_Private)
11360 Dep_Elmt := First_Elmt (Private_Dependents (Typ));
11361 while Present (Dep_Elmt) loop
11362 Dep_Typ := Node (Dep_Elmt);
11364 if Scope (Dep_Typ) = Pack_Id
11365 and then Present (Full_View (Dep_Typ))
11367 Replace_Elmt (Dep_Elmt, Full_View (Dep_Typ));
11368 Exchange_Declarations (Dep_Typ);
11371 Next_Elmt (Dep_Elmt);
11375 Exchange_Declarations (Node (M));
11379 if No (Pack_Id) then
11383 -- Make the generic formal parameters private, and make the formal types
11384 -- into subtypes of the actuals again.
11386 E := First_Entity (Pack_Id);
11387 while Present (E) loop
11388 Set_Is_Hidden (E, True);
11391 and then Nkind (Parent (E)) = N_Subtype_Declaration
11393 Set_Is_Generic_Actual_Type (E, False);
11395 -- An unusual case of aliasing: the actual may also be directly
11396 -- visible in the generic, and be private there, while it is fully
11397 -- visible in the context of the instance. The internal subtype
11398 -- is private in the instance but has full visibility like its
11399 -- parent in the enclosing scope. This enforces the invariant that
11400 -- the privacy status of all private dependents of a type coincide
11401 -- with that of the parent type. This can only happen when a
11402 -- generic child unit is instantiated within a sibling.
11404 if Is_Private_Type (E)
11405 and then not Is_Private_Type (Etype (E))
11407 Exchange_Declarations (E);
11410 elsif Ekind (E) = E_Package then
11412 -- The end of the renaming list is the renaming of the generic
11413 -- package itself. If the instance is a subprogram, all entities
11414 -- in the corresponding package are renamings. If this entity is
11415 -- a formal package, make its own formals private as well. The
11416 -- actual in this case is itself the renaming of an instantiation.
11417 -- If the entity is not a package renaming, it is the entity
11418 -- created to validate formal package actuals: ignore it.
11420 -- If the actual is itself a formal package for the enclosing
11421 -- generic, or the actual for such a formal package, it remains
11422 -- visible on exit from the instance, and therefore nothing needs
11423 -- to be done either, except to keep it accessible.
11425 if Is_Package and then Renamed_Object (E) = Pack_Id then
11428 elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then
11432 Denotes_Formal_Package (Renamed_Object (E), True, Pack_Id)
11434 Set_Is_Hidden (E, False);
11438 Act_P : constant Entity_Id := Renamed_Object (E);
11442 Id := First_Entity (Act_P);
11444 and then Id /= First_Private_Entity (Act_P)
11446 exit when Ekind (Id) = E_Package
11447 and then Renamed_Object (Id) = Act_P;
11449 Set_Is_Hidden (Id, True);
11450 Set_Is_Potentially_Use_Visible (Id, In_Use (Act_P));
11452 if Ekind (Id) = E_Package then
11453 Restore_Nested_Formal (Id);
11464 end Restore_Private_Views;
11471 (Gen_Unit : Entity_Id;
11472 Act_Unit : Entity_Id)
11476 Set_Instance_Env (Gen_Unit, Act_Unit);
11479 ----------------------------
11480 -- Save_Global_References --
11481 ----------------------------
11483 procedure Save_Global_References (N : Node_Id) is
11484 Gen_Scope : Entity_Id;
11488 function Is_Global (E : Entity_Id) return Boolean;
11489 -- Check whether entity is defined outside of generic unit. Examine the
11490 -- scope of an entity, and the scope of the scope, etc, until we find
11491 -- either Standard, in which case the entity is global, or the generic
11492 -- unit itself, which indicates that the entity is local. If the entity
11493 -- is the generic unit itself, as in the case of a recursive call, or
11494 -- the enclosing generic unit, if different from the current scope, then
11495 -- it is local as well, because it will be replaced at the point of
11496 -- instantiation. On the other hand, if it is a reference to a child
11497 -- unit of a common ancestor, which appears in an instantiation, it is
11498 -- global because it is used to denote a specific compilation unit at
11499 -- the time the instantiations will be analyzed.
11501 procedure Reset_Entity (N : Node_Id);
11502 -- Save semantic information on global entity so that it is not resolved
11503 -- again at instantiation time.
11505 procedure Save_Entity_Descendants (N : Node_Id);
11506 -- Apply Save_Global_References to the two syntactic descendants of
11507 -- non-terminal nodes that carry an Associated_Node and are processed
11508 -- through Reset_Entity. Once the global entity (if any) has been
11509 -- captured together with its type, only two syntactic descendants need
11510 -- to be traversed to complete the processing of the tree rooted at N.
11511 -- This applies to Selected_Components, Expanded_Names, and to Operator
11512 -- nodes. N can also be a character literal, identifier, or operator
11513 -- symbol node, but the call has no effect in these cases.
11515 procedure Save_Global_Defaults (N1, N2 : Node_Id);
11516 -- Default actuals in nested instances must be handled specially
11517 -- because there is no link to them from the original tree. When an
11518 -- actual subprogram is given by a default, we add an explicit generic
11519 -- association for it in the instantiation node. When we save the
11520 -- global references on the name of the instance, we recover the list
11521 -- of generic associations, and add an explicit one to the original
11522 -- generic tree, through which a global actual can be preserved.
11523 -- Similarly, if a child unit is instantiated within a sibling, in the
11524 -- context of the parent, we must preserve the identifier of the parent
11525 -- so that it can be properly resolved in a subsequent instantiation.
11527 procedure Save_Global_Descendant (D : Union_Id);
11528 -- Apply Save_Global_References recursively to the descendents of the
11531 procedure Save_References (N : Node_Id);
11532 -- This is the recursive procedure that does the work, once the
11533 -- enclosing generic scope has been established.
11539 function Is_Global (E : Entity_Id) return Boolean is
11542 function Is_Instance_Node (Decl : Node_Id) return Boolean;
11543 -- Determine whether the parent node of a reference to a child unit
11544 -- denotes an instantiation or a formal package, in which case the
11545 -- reference to the child unit is global, even if it appears within
11546 -- the current scope (e.g. when the instance appears within the body
11547 -- of an ancestor).
11549 ----------------------
11550 -- Is_Instance_Node --
11551 ----------------------
11553 function Is_Instance_Node (Decl : Node_Id) return Boolean is
11555 return Nkind (Decl) in N_Generic_Instantiation
11557 Nkind (Original_Node (Decl)) = N_Formal_Package_Declaration;
11558 end Is_Instance_Node;
11560 -- Start of processing for Is_Global
11563 if E = Gen_Scope then
11566 elsif E = Standard_Standard then
11569 elsif Is_Child_Unit (E)
11570 and then (Is_Instance_Node (Parent (N2))
11571 or else (Nkind (Parent (N2)) = N_Expanded_Name
11572 and then N2 = Selector_Name (Parent (N2))
11574 Is_Instance_Node (Parent (Parent (N2)))))
11580 while Se /= Gen_Scope loop
11581 if Se = Standard_Standard then
11596 procedure Reset_Entity (N : Node_Id) is
11598 procedure Set_Global_Type (N : Node_Id; N2 : Node_Id);
11599 -- If the type of N2 is global to the generic unit. Save the type in
11600 -- the generic node.
11601 -- What does this comment mean???
11603 function Top_Ancestor (E : Entity_Id) return Entity_Id;
11604 -- Find the ultimate ancestor of the current unit. If it is not a
11605 -- generic unit, then the name of the current unit in the prefix of
11606 -- an expanded name must be replaced with its generic homonym to
11607 -- ensure that it will be properly resolved in an instance.
11609 ---------------------
11610 -- Set_Global_Type --
11611 ---------------------
11613 procedure Set_Global_Type (N : Node_Id; N2 : Node_Id) is
11614 Typ : constant Entity_Id := Etype (N2);
11617 Set_Etype (N, Typ);
11619 if Entity (N) /= N2
11620 and then Has_Private_View (Entity (N))
11622 -- If the entity of N is not the associated node, this is a
11623 -- nested generic and it has an associated node as well, whose
11624 -- type is already the full view (see below). Indicate that the
11625 -- original node has a private view.
11627 Set_Has_Private_View (N);
11630 -- If not a private type, nothing else to do
11632 if not Is_Private_Type (Typ) then
11633 if Is_Array_Type (Typ)
11634 and then Is_Private_Type (Component_Type (Typ))
11636 Set_Has_Private_View (N);
11639 -- If it is a derivation of a private type in a context where no
11640 -- full view is needed, nothing to do either.
11642 elsif No (Full_View (Typ)) and then Typ /= Etype (Typ) then
11645 -- Otherwise mark the type for flipping and use the full view when
11649 Set_Has_Private_View (N);
11651 if Present (Full_View (Typ)) then
11652 Set_Etype (N2, Full_View (Typ));
11655 end Set_Global_Type;
11661 function Top_Ancestor (E : Entity_Id) return Entity_Id is
11666 while Is_Child_Unit (Par) loop
11667 Par := Scope (Par);
11673 -- Start of processing for Reset_Entity
11676 N2 := Get_Associated_Node (N);
11679 -- If the entity is an itype created as a subtype of an access type
11680 -- with a null exclusion restore source entity for proper visibility.
11681 -- The itype will be created anew in the instance.
11683 if Present (E) then
11685 and then Ekind (E) = E_Access_Subtype
11686 and then Is_Entity_Name (N)
11687 and then Chars (Etype (E)) = Chars (N)
11690 Set_Entity (N2, E);
11694 if Is_Global (E) then
11695 Set_Global_Type (N, N2);
11697 elsif Nkind (N) = N_Op_Concat
11698 and then Is_Generic_Type (Etype (N2))
11699 and then (Base_Type (Etype (Right_Opnd (N2))) = Etype (N2)
11701 Base_Type (Etype (Left_Opnd (N2))) = Etype (N2))
11702 and then Is_Intrinsic_Subprogram (E)
11707 -- Entity is local. Mark generic node as unresolved.
11708 -- Note that now it does not have an entity.
11710 Set_Associated_Node (N, Empty);
11711 Set_Etype (N, Empty);
11714 if Nkind (Parent (N)) in N_Generic_Instantiation
11715 and then N = Name (Parent (N))
11717 Save_Global_Defaults (Parent (N), Parent (N2));
11720 elsif Nkind (Parent (N)) = N_Selected_Component
11721 and then Nkind (Parent (N2)) = N_Expanded_Name
11723 if Is_Global (Entity (Parent (N2))) then
11724 Change_Selected_Component_To_Expanded_Name (Parent (N));
11725 Set_Associated_Node (Parent (N), Parent (N2));
11726 Set_Global_Type (Parent (N), Parent (N2));
11727 Save_Entity_Descendants (N);
11729 -- If this is a reference to the current generic entity, replace
11730 -- by the name of the generic homonym of the current package. This
11731 -- is because in an instantiation Par.P.Q will not resolve to the
11732 -- name of the instance, whose enclosing scope is not necessarily
11733 -- Par. We use the generic homonym rather that the name of the
11734 -- generic itself because it may be hidden by a local declaration.
11736 elsif In_Open_Scopes (Entity (Parent (N2)))
11738 Is_Generic_Unit (Top_Ancestor (Entity (Prefix (Parent (N2)))))
11740 if Ekind (Entity (Parent (N2))) = E_Generic_Package then
11741 Rewrite (Parent (N),
11742 Make_Identifier (Sloc (N),
11744 Chars (Generic_Homonym (Entity (Parent (N2))))));
11746 Rewrite (Parent (N),
11747 Make_Identifier (Sloc (N),
11748 Chars => Chars (Selector_Name (Parent (N2)))));
11752 if Nkind (Parent (Parent (N))) in N_Generic_Instantiation
11753 and then Parent (N) = Name (Parent (Parent (N)))
11755 Save_Global_Defaults
11756 (Parent (Parent (N)), Parent (Parent ((N2))));
11759 -- A selected component may denote a static constant that has been
11760 -- folded. If the static constant is global to the generic, capture
11761 -- its value. Otherwise the folding will happen in any instantiation.
11763 elsif Nkind (Parent (N)) = N_Selected_Component
11764 and then Nkind_In (Parent (N2), N_Integer_Literal, N_Real_Literal)
11766 if Present (Entity (Original_Node (Parent (N2))))
11767 and then Is_Global (Entity (Original_Node (Parent (N2))))
11769 Rewrite (Parent (N), New_Copy (Parent (N2)));
11770 Set_Analyzed (Parent (N), False);
11776 -- A selected component may be transformed into a parameterless
11777 -- function call. If the called entity is global, rewrite the node
11778 -- appropriately, i.e. as an extended name for the global entity.
11780 elsif Nkind (Parent (N)) = N_Selected_Component
11781 and then Nkind (Parent (N2)) = N_Function_Call
11782 and then N = Selector_Name (Parent (N))
11784 if No (Parameter_Associations (Parent (N2))) then
11785 if Is_Global (Entity (Name (Parent (N2)))) then
11786 Change_Selected_Component_To_Expanded_Name (Parent (N));
11787 Set_Associated_Node (Parent (N), Name (Parent (N2)));
11788 Set_Global_Type (Parent (N), Name (Parent (N2)));
11789 Save_Entity_Descendants (N);
11792 Set_Associated_Node (N, Empty);
11793 Set_Etype (N, Empty);
11796 -- In Ada 2005, X.F may be a call to a primitive operation,
11797 -- rewritten as F (X). This rewriting will be done again in an
11798 -- instance, so keep the original node. Global entities will be
11799 -- captured as for other constructs.
11805 -- Entity is local. Reset in generic unit, so that node is resolved
11806 -- anew at the point of instantiation.
11809 Set_Associated_Node (N, Empty);
11810 Set_Etype (N, Empty);
11814 -----------------------------
11815 -- Save_Entity_Descendants --
11816 -----------------------------
11818 procedure Save_Entity_Descendants (N : Node_Id) is
11821 when N_Binary_Op =>
11822 Save_Global_Descendant (Union_Id (Left_Opnd (N)));
11823 Save_Global_Descendant (Union_Id (Right_Opnd (N)));
11826 Save_Global_Descendant (Union_Id (Right_Opnd (N)));
11828 when N_Expanded_Name | N_Selected_Component =>
11829 Save_Global_Descendant (Union_Id (Prefix (N)));
11830 Save_Global_Descendant (Union_Id (Selector_Name (N)));
11832 when N_Identifier | N_Character_Literal | N_Operator_Symbol =>
11836 raise Program_Error;
11838 end Save_Entity_Descendants;
11840 --------------------------
11841 -- Save_Global_Defaults --
11842 --------------------------
11844 procedure Save_Global_Defaults (N1, N2 : Node_Id) is
11845 Loc : constant Source_Ptr := Sloc (N1);
11846 Assoc2 : constant List_Id := Generic_Associations (N2);
11847 Gen_Id : constant Entity_Id := Get_Generic_Entity (N2);
11854 Actual : Entity_Id;
11857 Assoc1 := Generic_Associations (N1);
11859 if Present (Assoc1) then
11860 Act1 := First (Assoc1);
11863 Set_Generic_Associations (N1, New_List);
11864 Assoc1 := Generic_Associations (N1);
11867 if Present (Assoc2) then
11868 Act2 := First (Assoc2);
11873 while Present (Act1) and then Present (Act2) loop
11878 -- Find the associations added for default subprograms
11880 if Present (Act2) then
11881 while Nkind (Act2) /= N_Generic_Association
11882 or else No (Entity (Selector_Name (Act2)))
11883 or else not Is_Overloadable (Entity (Selector_Name (Act2)))
11888 -- Add a similar association if the default is global. The
11889 -- renaming declaration for the actual has been analyzed, and
11890 -- its alias is the program it renames. Link the actual in the
11891 -- original generic tree with the node in the analyzed tree.
11893 while Present (Act2) loop
11894 Subp := Entity (Selector_Name (Act2));
11895 Def := Explicit_Generic_Actual_Parameter (Act2);
11897 -- Following test is defence against rubbish errors
11899 if No (Alias (Subp)) then
11903 -- Retrieve the resolved actual from the renaming declaration
11904 -- created for the instantiated formal.
11906 Actual := Entity (Name (Parent (Parent (Subp))));
11907 Set_Entity (Def, Actual);
11908 Set_Etype (Def, Etype (Actual));
11910 if Is_Global (Actual) then
11912 Make_Generic_Association (Loc,
11913 Selector_Name => New_Occurrence_Of (Subp, Loc),
11914 Explicit_Generic_Actual_Parameter =>
11915 New_Occurrence_Of (Actual, Loc));
11917 Set_Associated_Node
11918 (Explicit_Generic_Actual_Parameter (Ndec), Def);
11920 Append (Ndec, Assoc1);
11922 -- If there are other defaults, add a dummy association in case
11923 -- there are other defaulted formals with the same name.
11925 elsif Present (Next (Act2)) then
11927 Make_Generic_Association (Loc,
11928 Selector_Name => New_Occurrence_Of (Subp, Loc),
11929 Explicit_Generic_Actual_Parameter => Empty);
11931 Append (Ndec, Assoc1);
11938 if Nkind (Name (N1)) = N_Identifier
11939 and then Is_Child_Unit (Gen_Id)
11940 and then Is_Global (Gen_Id)
11941 and then Is_Generic_Unit (Scope (Gen_Id))
11942 and then In_Open_Scopes (Scope (Gen_Id))
11944 -- This is an instantiation of a child unit within a sibling, so
11945 -- that the generic parent is in scope. An eventual instance must
11946 -- occur within the scope of an instance of the parent. Make name
11947 -- in instance into an expanded name, to preserve the identifier
11948 -- of the parent, so it can be resolved subsequently.
11950 Rewrite (Name (N2),
11951 Make_Expanded_Name (Loc,
11952 Chars => Chars (Gen_Id),
11953 Prefix => New_Occurrence_Of (Scope (Gen_Id), Loc),
11954 Selector_Name => New_Occurrence_Of (Gen_Id, Loc)));
11955 Set_Entity (Name (N2), Gen_Id);
11957 Rewrite (Name (N1),
11958 Make_Expanded_Name (Loc,
11959 Chars => Chars (Gen_Id),
11960 Prefix => New_Occurrence_Of (Scope (Gen_Id), Loc),
11961 Selector_Name => New_Occurrence_Of (Gen_Id, Loc)));
11963 Set_Associated_Node (Name (N1), Name (N2));
11964 Set_Associated_Node (Prefix (Name (N1)), Empty);
11965 Set_Associated_Node
11966 (Selector_Name (Name (N1)), Selector_Name (Name (N2)));
11967 Set_Etype (Name (N1), Etype (Gen_Id));
11970 end Save_Global_Defaults;
11972 ----------------------------
11973 -- Save_Global_Descendant --
11974 ----------------------------
11976 procedure Save_Global_Descendant (D : Union_Id) is
11980 if D in Node_Range then
11981 if D = Union_Id (Empty) then
11984 elsif Nkind (Node_Id (D)) /= N_Compilation_Unit then
11985 Save_References (Node_Id (D));
11988 elsif D in List_Range then
11989 if D = Union_Id (No_List)
11990 or else Is_Empty_List (List_Id (D))
11995 N1 := First (List_Id (D));
11996 while Present (N1) loop
11997 Save_References (N1);
12002 -- Element list or other non-node field, nothing to do
12007 end Save_Global_Descendant;
12009 ---------------------
12010 -- Save_References --
12011 ---------------------
12013 -- This is the recursive procedure that does the work once the enclosing
12014 -- generic scope has been established. We have to treat specially a
12015 -- number of node rewritings that are required by semantic processing
12016 -- and which change the kind of nodes in the generic copy: typically
12017 -- constant-folding, replacing an operator node by a string literal, or
12018 -- a selected component by an expanded name. In each of those cases, the
12019 -- transformation is propagated to the generic unit.
12021 procedure Save_References (N : Node_Id) is
12022 Loc : constant Source_Ptr := Sloc (N);
12028 elsif Nkind_In (N, N_Character_Literal, N_Operator_Symbol) then
12029 if Nkind (N) = Nkind (Get_Associated_Node (N)) then
12032 elsif Nkind (N) = N_Operator_Symbol
12033 and then Nkind (Get_Associated_Node (N)) = N_String_Literal
12035 Change_Operator_Symbol_To_String_Literal (N);
12038 elsif Nkind (N) in N_Op then
12039 if Nkind (N) = Nkind (Get_Associated_Node (N)) then
12040 if Nkind (N) = N_Op_Concat then
12041 Set_Is_Component_Left_Opnd (N,
12042 Is_Component_Left_Opnd (Get_Associated_Node (N)));
12044 Set_Is_Component_Right_Opnd (N,
12045 Is_Component_Right_Opnd (Get_Associated_Node (N)));
12051 -- Node may be transformed into call to a user-defined operator
12053 N2 := Get_Associated_Node (N);
12055 if Nkind (N2) = N_Function_Call then
12056 E := Entity (Name (N2));
12059 and then Is_Global (E)
12061 Set_Etype (N, Etype (N2));
12063 Set_Associated_Node (N, Empty);
12064 Set_Etype (N, Empty);
12067 elsif Nkind_In (N2, N_Integer_Literal,
12071 if Present (Original_Node (N2))
12072 and then Nkind (Original_Node (N2)) = Nkind (N)
12075 -- Operation was constant-folded. Whenever possible,
12076 -- recover semantic information from unfolded node,
12079 Set_Associated_Node (N, Original_Node (N2));
12081 if Nkind (N) = N_Op_Concat then
12082 Set_Is_Component_Left_Opnd (N,
12083 Is_Component_Left_Opnd (Get_Associated_Node (N)));
12084 Set_Is_Component_Right_Opnd (N,
12085 Is_Component_Right_Opnd (Get_Associated_Node (N)));
12091 -- If original node is already modified, propagate
12092 -- constant-folding to template.
12094 Rewrite (N, New_Copy (N2));
12095 Set_Analyzed (N, False);
12098 elsif Nkind (N2) = N_Identifier
12099 and then Ekind (Entity (N2)) = E_Enumeration_Literal
12101 -- Same if call was folded into a literal, but in this case
12102 -- retain the entity to avoid spurious ambiguities if it is
12103 -- overloaded at the point of instantiation or inlining.
12105 Rewrite (N, New_Copy (N2));
12106 Set_Analyzed (N, False);
12110 -- Complete operands check if node has not been constant-folded
12112 if Nkind (N) in N_Op then
12113 Save_Entity_Descendants (N);
12116 elsif Nkind (N) = N_Identifier then
12117 if Nkind (N) = Nkind (Get_Associated_Node (N)) then
12119 -- If this is a discriminant reference, always save it. It is
12120 -- used in the instance to find the corresponding discriminant
12121 -- positionally rather than by name.
12123 Set_Original_Discriminant
12124 (N, Original_Discriminant (Get_Associated_Node (N)));
12128 N2 := Get_Associated_Node (N);
12130 if Nkind (N2) = N_Function_Call then
12131 E := Entity (Name (N2));
12133 -- Name resolves to a call to parameterless function. If
12134 -- original entity is global, mark node as resolved.
12137 and then Is_Global (E)
12139 Set_Etype (N, Etype (N2));
12141 Set_Associated_Node (N, Empty);
12142 Set_Etype (N, Empty);
12145 elsif Nkind_In (N2, N_Integer_Literal, N_Real_Literal)
12146 and then Is_Entity_Name (Original_Node (N2))
12148 -- Name resolves to named number that is constant-folded,
12149 -- We must preserve the original name for ASIS use, and
12150 -- undo the constant-folding, which will be repeated in
12153 Set_Associated_Node (N, Original_Node (N2));
12156 elsif Nkind (N2) = N_String_Literal then
12158 -- Name resolves to string literal. Perform the same
12159 -- replacement in generic.
12161 Rewrite (N, New_Copy (N2));
12163 elsif Nkind (N2) = N_Explicit_Dereference then
12165 -- An identifier is rewritten as a dereference if it is the
12166 -- prefix in an implicit dereference (call or attribute).
12167 -- The analysis of an instantiation will expand the node
12168 -- again, so we preserve the original tree but link it to
12169 -- the resolved entity in case it is global.
12171 if Is_Entity_Name (Prefix (N2))
12172 and then Present (Entity (Prefix (N2)))
12173 and then Is_Global (Entity (Prefix (N2)))
12175 Set_Associated_Node (N, Prefix (N2));
12177 elsif Nkind (Prefix (N2)) = N_Function_Call
12178 and then Is_Global (Entity (Name (Prefix (N2))))
12181 Make_Explicit_Dereference (Loc,
12182 Prefix => Make_Function_Call (Loc,
12184 New_Occurrence_Of (Entity (Name (Prefix (N2))),
12188 Set_Associated_Node (N, Empty);
12189 Set_Etype (N, Empty);
12192 -- The subtype mark of a nominally unconstrained object is
12193 -- rewritten as a subtype indication using the bounds of the
12194 -- expression. Recover the original subtype mark.
12196 elsif Nkind (N2) = N_Subtype_Indication
12197 and then Is_Entity_Name (Original_Node (N2))
12199 Set_Associated_Node (N, Original_Node (N2));
12207 elsif Nkind (N) in N_Entity then
12212 Qual : Node_Id := Empty;
12213 Typ : Entity_Id := Empty;
12216 use Atree.Unchecked_Access;
12217 -- This code section is part of implementing an untyped tree
12218 -- traversal, so it needs direct access to node fields.
12221 if Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then
12222 N2 := Get_Associated_Node (N);
12229 -- In an instance within a generic, use the name of the
12230 -- actual and not the original generic parameter. If the
12231 -- actual is global in the current generic it must be
12232 -- preserved for its instantiation.
12234 if Nkind (Parent (Typ)) = N_Subtype_Declaration
12236 Present (Generic_Parent_Type (Parent (Typ)))
12238 Typ := Base_Type (Typ);
12239 Set_Etype (N2, Typ);
12245 or else not Is_Global (Typ)
12247 Set_Associated_Node (N, Empty);
12249 -- If the aggregate is an actual in a call, it has been
12250 -- resolved in the current context, to some local type.
12251 -- The enclosing call may have been disambiguated by the
12252 -- aggregate, and this disambiguation might fail at
12253 -- instantiation time because the type to which the
12254 -- aggregate did resolve is not preserved. In order to
12255 -- preserve some of this information, we wrap the
12256 -- aggregate in a qualified expression, using the id of
12257 -- its type. For further disambiguation we qualify the
12258 -- type name with its scope (if visible) because both
12259 -- id's will have corresponding entities in an instance.
12260 -- This resolves most of the problems with missing type
12261 -- information on aggregates in instances.
12263 if Nkind (N2) = Nkind (N)
12265 Nkind_In (Parent (N2), N_Procedure_Call_Statement,
12267 and then Comes_From_Source (Typ)
12269 if Is_Immediately_Visible (Scope (Typ)) then
12270 Nam := Make_Selected_Component (Loc,
12272 Make_Identifier (Loc, Chars (Scope (Typ))),
12274 Make_Identifier (Loc, Chars (Typ)));
12276 Nam := Make_Identifier (Loc, Chars (Typ));
12280 Make_Qualified_Expression (Loc,
12281 Subtype_Mark => Nam,
12282 Expression => Relocate_Node (N));
12286 Save_Global_Descendant (Field1 (N));
12287 Save_Global_Descendant (Field2 (N));
12288 Save_Global_Descendant (Field3 (N));
12289 Save_Global_Descendant (Field5 (N));
12291 if Present (Qual) then
12295 -- All other cases than aggregates
12298 -- For pragmas, we propagate the Enabled status for the
12299 -- relevant pragmas to the original generic tree. This was
12300 -- originally needed for SCO generation. It is no longer
12301 -- needed there (since we use the Sloc value in calls to
12302 -- Set_SCO_Pragma_Enabled), but it seems a generally good
12303 -- idea to have this flag set properly.
12305 if Nkind (N) = N_Pragma
12307 (Pragma_Name (N) = Name_Assert or else
12308 Pragma_Name (N) = Name_Check or else
12309 Pragma_Name (N) = Name_Precondition or else
12310 Pragma_Name (N) = Name_Postcondition)
12311 and then Present (Associated_Node (Pragma_Identifier (N)))
12313 Set_Pragma_Enabled (N,
12315 (Parent (Associated_Node (Pragma_Identifier (N)))));
12318 Save_Global_Descendant (Field1 (N));
12319 Save_Global_Descendant (Field2 (N));
12320 Save_Global_Descendant (Field3 (N));
12321 Save_Global_Descendant (Field4 (N));
12322 Save_Global_Descendant (Field5 (N));
12326 end Save_References;
12328 -- Start of processing for Save_Global_References
12331 Gen_Scope := Current_Scope;
12333 -- If the generic unit is a child unit, references to entities in the
12334 -- parent are treated as local, because they will be resolved anew in
12335 -- the context of the instance of the parent.
12337 while Is_Child_Unit (Gen_Scope)
12338 and then Ekind (Scope (Gen_Scope)) = E_Generic_Package
12340 Gen_Scope := Scope (Gen_Scope);
12343 Save_References (N);
12344 end Save_Global_References;
12346 --------------------------------------
12347 -- Set_Copied_Sloc_For_Inlined_Body --
12348 --------------------------------------
12350 procedure Set_Copied_Sloc_For_Inlined_Body (N : Node_Id; E : Entity_Id) is
12352 Create_Instantiation_Source (N, E, True, S_Adjustment);
12353 end Set_Copied_Sloc_For_Inlined_Body;
12355 ---------------------
12356 -- Set_Instance_Of --
12357 ---------------------
12359 procedure Set_Instance_Of (A : Entity_Id; B : Entity_Id) is
12361 Generic_Renamings.Table (Generic_Renamings.Last) := (A, B, Assoc_Null);
12362 Generic_Renamings_HTable.Set (Generic_Renamings.Last);
12363 Generic_Renamings.Increment_Last;
12364 end Set_Instance_Of;
12366 --------------------
12367 -- Set_Next_Assoc --
12368 --------------------
12370 procedure Set_Next_Assoc (E : Assoc_Ptr; Next : Assoc_Ptr) is
12372 Generic_Renamings.Table (E).Next_In_HTable := Next;
12373 end Set_Next_Assoc;
12375 -------------------
12376 -- Start_Generic --
12377 -------------------
12379 procedure Start_Generic is
12381 -- ??? More things could be factored out in this routine.
12382 -- Should probably be done at a later stage.
12384 Generic_Flags.Append (Inside_A_Generic);
12385 Inside_A_Generic := True;
12387 Expander_Mode_Save_And_Set (False);
12390 ----------------------
12391 -- Set_Instance_Env --
12392 ----------------------
12394 procedure Set_Instance_Env
12395 (Gen_Unit : Entity_Id;
12396 Act_Unit : Entity_Id)
12399 -- Regardless of the current mode, predefined units are analyzed in the
12400 -- most current Ada mode, and earlier version Ada checks do not apply
12401 -- to predefined units. Nothing needs to be done for non-internal units.
12402 -- These are always analyzed in the current mode.
12404 if Is_Internal_File_Name
12405 (Fname => Unit_File_Name (Get_Source_Unit (Gen_Unit)),
12406 Renamings_Included => True)
12408 Set_Opt_Config_Switches (True, Current_Sem_Unit = Main_Unit);
12411 Current_Instantiated_Parent :=
12412 (Gen_Id => Gen_Unit,
12413 Act_Id => Act_Unit,
12414 Next_In_HTable => Assoc_Null);
12415 end Set_Instance_Env;
12421 procedure Switch_View (T : Entity_Id) is
12422 BT : constant Entity_Id := Base_Type (T);
12423 Priv_Elmt : Elmt_Id := No_Elmt;
12424 Priv_Sub : Entity_Id;
12427 -- T may be private but its base type may have been exchanged through
12428 -- some other occurrence, in which case there is nothing to switch
12429 -- besides T itself. Note that a private dependent subtype of a private
12430 -- type might not have been switched even if the base type has been,
12431 -- because of the last branch of Check_Private_View (see comment there).
12433 if not Is_Private_Type (BT) then
12434 Prepend_Elmt (Full_View (T), Exchanged_Views);
12435 Exchange_Declarations (T);
12439 Priv_Elmt := First_Elmt (Private_Dependents (BT));
12441 if Present (Full_View (BT)) then
12442 Prepend_Elmt (Full_View (BT), Exchanged_Views);
12443 Exchange_Declarations (BT);
12446 while Present (Priv_Elmt) loop
12447 Priv_Sub := (Node (Priv_Elmt));
12449 -- We avoid flipping the subtype if the Etype of its full view is
12450 -- private because this would result in a malformed subtype. This
12451 -- occurs when the Etype of the subtype full view is the full view of
12452 -- the base type (and since the base types were just switched, the
12453 -- subtype is pointing to the wrong view). This is currently the case
12454 -- for tagged record types, access types (maybe more?) and needs to
12455 -- be resolved. ???
12457 if Present (Full_View (Priv_Sub))
12458 and then not Is_Private_Type (Etype (Full_View (Priv_Sub)))
12460 Prepend_Elmt (Full_View (Priv_Sub), Exchanged_Views);
12461 Exchange_Declarations (Priv_Sub);
12464 Next_Elmt (Priv_Elmt);
12468 -----------------------------
12469 -- Valid_Default_Attribute --
12470 -----------------------------
12472 procedure Valid_Default_Attribute (Nam : Entity_Id; Def : Node_Id) is
12473 Attr_Id : constant Attribute_Id :=
12474 Get_Attribute_Id (Attribute_Name (Def));
12475 T : constant Entity_Id := Entity (Prefix (Def));
12476 Is_Fun : constant Boolean := (Ekind (Nam) = E_Function);
12489 F := First_Formal (Nam);
12490 while Present (F) loop
12491 Num_F := Num_F + 1;
12496 when Attribute_Adjacent | Attribute_Ceiling | Attribute_Copy_Sign |
12497 Attribute_Floor | Attribute_Fraction | Attribute_Machine |
12498 Attribute_Model | Attribute_Remainder | Attribute_Rounding |
12499 Attribute_Unbiased_Rounding =>
12502 and then Is_Floating_Point_Type (T);
12504 when Attribute_Image | Attribute_Pred | Attribute_Succ |
12505 Attribute_Value | Attribute_Wide_Image |
12506 Attribute_Wide_Value =>
12507 OK := (Is_Fun and then Num_F = 1 and then Is_Scalar_Type (T));
12509 when Attribute_Max | Attribute_Min =>
12510 OK := (Is_Fun and then Num_F = 2 and then Is_Scalar_Type (T));
12512 when Attribute_Input =>
12513 OK := (Is_Fun and then Num_F = 1);
12515 when Attribute_Output | Attribute_Read | Attribute_Write =>
12516 OK := (not Is_Fun and then Num_F = 2);
12523 Error_Msg_N ("attribute reference has wrong profile for subprogram",
12526 end Valid_Default_Attribute;