1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2007, 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 Atree
; use Atree
;
27 with Einfo
; use Einfo
;
28 with Elists
; use Elists
;
29 with Errout
; use Errout
;
30 with Expander
; use Expander
;
31 with Fname
; use Fname
;
32 with Fname
.UF
; use Fname
.UF
;
33 with Freeze
; use Freeze
;
36 with Lib
.Load
; use Lib
.Load
;
37 with Lib
.Xref
; use Lib
.Xref
;
38 with Nlists
; use Nlists
;
39 with Namet
; use Namet
;
40 with Nmake
; use Nmake
;
42 with Rident
; use Rident
;
43 with Restrict
; use Restrict
;
44 with Rtsfind
; use Rtsfind
;
46 with Sem_Cat
; use Sem_Cat
;
47 with Sem_Ch3
; use Sem_Ch3
;
48 with Sem_Ch6
; use Sem_Ch6
;
49 with Sem_Ch7
; use Sem_Ch7
;
50 with Sem_Ch8
; use Sem_Ch8
;
51 with Sem_Ch10
; use Sem_Ch10
;
52 with Sem_Ch13
; use Sem_Ch13
;
53 with Sem_Disp
; use Sem_Disp
;
54 with Sem_Elab
; use Sem_Elab
;
55 with Sem_Elim
; use Sem_Elim
;
56 with Sem_Eval
; use Sem_Eval
;
57 with Sem_Res
; use Sem_Res
;
58 with Sem_Type
; use Sem_Type
;
59 with Sem_Util
; use Sem_Util
;
60 with Sem_Warn
; use Sem_Warn
;
61 with Stand
; use Stand
;
62 with Sinfo
; use Sinfo
;
63 with Sinfo
.CN
; use Sinfo
.CN
;
64 with Sinput
; use Sinput
;
65 with Sinput
.L
; use Sinput
.L
;
66 with Snames
; use Snames
;
67 with Stringt
; use Stringt
;
68 with Uname
; use Uname
;
70 with Tbuild
; use Tbuild
;
71 with Uintp
; use Uintp
;
72 with Urealp
; use Urealp
;
76 package body Sem_Ch12
is
78 ----------------------------------------------------------
79 -- Implementation of Generic Analysis and Instantiation --
80 ----------------------------------------------------------
82 -- GNAT implements generics by macro expansion. No attempt is made to share
83 -- generic instantiations (for now). Analysis of a generic definition does
84 -- not perform any expansion action, but the expander must be called on the
85 -- tree for each instantiation, because the expansion may of course depend
86 -- on the generic actuals. All of this is best achieved as follows:
88 -- a) Semantic analysis of a generic unit is performed on a copy of the
89 -- tree for the generic unit. All tree modifications that follow analysis
90 -- do not affect the original tree. Links are kept between the original
91 -- tree and the copy, in order to recognize non-local references within
92 -- the generic, and propagate them to each instance (recall that name
93 -- resolution is done on the generic declaration: generics are not really
94 -- macros!). This is summarized in the following diagram:
96 -- .-----------. .----------.
97 -- | semantic |<--------------| generic |
99 -- | |==============>| |
100 -- |___________| global |__________|
111 -- b) Each instantiation copies the original tree, and inserts into it a
112 -- series of declarations that describe the mapping between generic formals
113 -- and actuals. For example, a generic In OUT parameter is an object
114 -- renaming of the corresponing actual, etc. Generic IN parameters are
115 -- constant declarations.
117 -- c) In order to give the right visibility for these renamings, we use
118 -- a different scheme for package and subprogram instantiations. For
119 -- packages, the list of renamings is inserted into the package
120 -- specification, before the visible declarations of the package. The
121 -- renamings are analyzed before any of the text of the instance, and are
122 -- thus visible at the right place. Furthermore, outside of the instance,
123 -- the generic parameters are visible and denote their corresponding
126 -- For subprograms, we create a container package to hold the renamings
127 -- and the subprogram instance itself. Analysis of the package makes the
128 -- renaming declarations visible to the subprogram. After analyzing the
129 -- package, the defining entity for the subprogram is touched-up so that
130 -- it appears declared in the current scope, and not inside the container
133 -- If the instantiation is a compilation unit, the container package is
134 -- given the same name as the subprogram instance. This ensures that
135 -- the elaboration procedure called by the binder, using the compilation
136 -- unit name, calls in fact the elaboration procedure for the package.
138 -- Not surprisingly, private types complicate this approach. By saving in
139 -- the original generic object the non-local references, we guarantee that
140 -- the proper entities are referenced at the point of instantiation.
141 -- However, for private types, this by itself does not insure that the
142 -- proper VIEW of the entity is used (the full type may be visible at the
143 -- point of generic definition, but not at instantiation, or vice-versa).
144 -- In order to reference the proper view, we special-case any reference
145 -- to private types in the generic object, by saving both views, one in
146 -- the generic and one in the semantic copy. At time of instantiation, we
147 -- check whether the two views are consistent, and exchange declarations if
148 -- necessary, in order to restore the correct visibility. Similarly, if
149 -- the instance view is private when the generic view was not, we perform
150 -- the exchange. After completing the instantiation, we restore the
151 -- current visibility. The flag Has_Private_View marks identifiers in the
152 -- the generic unit that require checking.
154 -- Visibility within nested generic units requires special handling.
155 -- Consider the following scheme:
157 -- type Global is ... -- outside of generic unit.
161 -- type Semi_Global is ... -- global to inner.
164 -- procedure inner (X1 : Global; X2 : Semi_Global);
166 -- procedure in2 is new inner (...); -- 4
169 -- package New_Outer is new Outer (...); -- 2
170 -- procedure New_Inner is new New_Outer.Inner (...); -- 3
172 -- The semantic analysis of Outer captures all occurrences of Global.
173 -- The semantic analysis of Inner (at 1) captures both occurrences of
174 -- Global and Semi_Global.
176 -- At point 2 (instantiation of Outer), we also produce a generic copy
177 -- of Inner, even though Inner is, at that point, not being instantiated.
178 -- (This is just part of the semantic analysis of New_Outer).
180 -- Critically, references to Global within Inner must be preserved, while
181 -- references to Semi_Global should not preserved, because they must now
182 -- resolve to an entity within New_Outer. To distinguish between these, we
183 -- use a global variable, Current_Instantiated_Parent, which is set when
184 -- performing a generic copy during instantiation (at 2). This variable is
185 -- used when performing a generic copy that is not an instantiation, but
186 -- that is nested within one, as the occurrence of 1 within 2. The analysis
187 -- of a nested generic only preserves references that are global to the
188 -- enclosing Current_Instantiated_Parent. We use the Scope_Depth value to
189 -- determine whether a reference is external to the given parent.
191 -- The instantiation at point 3 requires no special treatment. The method
192 -- works as well for further nestings of generic units, but of course the
193 -- variable Current_Instantiated_Parent must be stacked because nested
194 -- instantiations can occur, e.g. the occurrence of 4 within 2.
196 -- The instantiation of package and subprogram bodies is handled in a
197 -- similar manner, except that it is delayed until after semantic
198 -- analysis is complete. In this fashion complex cross-dependencies
199 -- between several package declarations and bodies containing generics
200 -- can be compiled which otherwise would diagnose spurious circularities.
202 -- For example, it is possible to compile two packages A and B that
203 -- have the following structure:
205 -- package A is package B is
206 -- generic ... generic ...
207 -- package G_A is package G_B is
210 -- package body A is package body B is
211 -- package N_B is new G_B (..) package N_A is new G_A (..)
213 -- The table Pending_Instantiations in package Inline is used to keep
214 -- track of body instantiations that are delayed in this manner. Inline
215 -- handles the actual calls to do the body instantiations. This activity
216 -- is part of Inline, since the processing occurs at the same point, and
217 -- for essentially the same reason, as the handling of inlined routines.
219 ----------------------------------------------
220 -- Detection of Instantiation Circularities --
221 ----------------------------------------------
223 -- If we have a chain of instantiations that is circular, this is static
224 -- error which must be detected at compile time. The detection of these
225 -- circularities is carried out at the point that we insert a generic
226 -- instance spec or body. If there is a circularity, then the analysis of
227 -- the offending spec or body will eventually result in trying to load the
228 -- same unit again, and we detect this problem as we analyze the package
229 -- instantiation for the second time.
231 -- At least in some cases after we have detected the circularity, we get
232 -- into trouble if we try to keep going. The following flag is set if a
233 -- circularity is detected, and used to abandon compilation after the
234 -- messages have been posted.
236 Circularity_Detected
: Boolean := False;
237 -- This should really be reset on encountering a new main unit, but in
238 -- practice we are not using multiple main units so it is not critical.
240 -------------------------------------------------
241 -- Formal packages and partial parametrization --
242 -------------------------------------------------
244 -- When compiling a generic, a formal package is a local instantiation. If
245 -- declared with a box, its generic formals are visible in the enclosing
246 -- generic. If declared with a partial list of actuals, those actuals that
247 -- are defaulted (covered by an Others clause, or given an explicit box
248 -- initialization) are also visible in the enclosing generic, while those
249 -- that have a corresponding actual are not.
251 -- In our source model of instantiation, the same visibility must be
252 -- present in the spec and body of an instance: the names of the formals
253 -- that are defaulted must be made visible within the instance, and made
254 -- invisible (hidden) after the instantiation is complete, so that they
255 -- are not accessible outside of the instance.
257 -- In a generic, a formal package is treated like a special instantiation.
258 -- Our Ada95 compiler handled formals with and without box in different
259 -- ways. With partial parametrization, we use a single model for both.
260 -- We create a package declaration that consists of the specification of
261 -- the generic package, and a set of declarations that map the actuals
262 -- into local renamings, just as we do for bona fide instantiations. For
263 -- defaulted parameters and formals with a box, we copy directly the
264 -- declarations of the formal into this local package. The result is a
265 -- a package whose visible declarations may include generic formals. This
266 -- package is only used for type checking and visibility analysis, and
267 -- never reaches the back-end, so it can freely violate the placement
268 -- rules for generic formal declarations.
270 -- The list of declarations (renamings and copies of formals) is built
271 -- by Analyze_Associations, just as for regular instantiations.
273 -- At the point of instantiation, conformance checking must be applied only
274 -- to those parameters that were specified in the formal. We perform this
275 -- checking by creating another internal instantiation, this one including
276 -- only the renamings and the formals (the rest of the package spec is not
277 -- relevant to conformance checking). We can then traverse two lists: the
278 -- list of actuals in the instance that corresponds to the formal package,
279 -- and the list of actuals produced for this bogus instantiation. We apply
280 -- the conformance rules to those actuals that are not defaulted (i.e.
281 -- which still appear as generic formals.
283 -- When we compile an instance body we must make the right parameters
284 -- visible again. The predicate Is_Generic_Formal indicates which of the
285 -- formals should have its Is_Hidden flag reset.
287 -----------------------
288 -- Local subprograms --
289 -----------------------
291 procedure Abandon_Instantiation
(N
: Node_Id
);
292 pragma No_Return
(Abandon_Instantiation
);
293 -- Posts an error message "instantiation abandoned" at the indicated node
294 -- and then raises the exception Instantiation_Error to do it.
296 procedure Analyze_Formal_Array_Type
297 (T
: in out Entity_Id
;
299 -- A formal array type is treated like an array type declaration, and
300 -- invokes Array_Type_Declaration (sem_ch3) whose first parameter is
301 -- in-out, because in the case of an anonymous type the entity is
302 -- actually created in the procedure.
304 -- The following procedures treat other kinds of formal parameters
306 procedure Analyze_Formal_Derived_Interface_Type
311 procedure Analyze_Formal_Derived_Type
316 procedure Analyze_Formal_Interface_Type
321 -- The following subprograms create abbreviated declarations for formal
322 -- scalar types. We introduce an anonymous base of the proper class for
323 -- each of them, and define the formals as constrained first subtypes of
324 -- their bases. The bounds are expressions that are non-static in the
327 procedure Analyze_Formal_Decimal_Fixed_Point_Type
328 (T
: Entity_Id
; Def
: Node_Id
);
329 procedure Analyze_Formal_Discrete_Type
(T
: Entity_Id
; Def
: Node_Id
);
330 procedure Analyze_Formal_Floating_Type
(T
: Entity_Id
; Def
: Node_Id
);
331 procedure Analyze_Formal_Signed_Integer_Type
(T
: Entity_Id
; Def
: Node_Id
);
332 procedure Analyze_Formal_Modular_Type
(T
: Entity_Id
; Def
: Node_Id
);
333 procedure Analyze_Formal_Ordinary_Fixed_Point_Type
334 (T
: Entity_Id
; Def
: Node_Id
);
336 procedure Analyze_Formal_Private_Type
340 -- Creates a new private type, which does not require completion
342 procedure Analyze_Generic_Formal_Part
(N
: Node_Id
);
344 procedure Analyze_Generic_Access_Type
(T
: Entity_Id
; Def
: Node_Id
);
345 -- Create a new access type with the given designated type
347 function Analyze_Associations
350 F_Copy
: List_Id
) return List_Id
;
351 -- At instantiation time, build the list of associations between formals
352 -- and actuals. Each association becomes a renaming declaration for the
353 -- formal entity. F_Copy is the analyzed list of formals in the generic
354 -- copy. It is used to apply legality checks to the actuals. I_Node is the
355 -- instantiation node itself.
357 procedure Analyze_Subprogram_Instantiation
361 procedure Build_Instance_Compilation_Unit_Nodes
365 -- This procedure is used in the case where the generic instance of a
366 -- subprogram body or package body is a library unit. In this case, the
367 -- original library unit node for the generic instantiation must be
368 -- replaced by the resulting generic body, and a link made to a new
369 -- compilation unit node for the generic declaration. The argument N is
370 -- the original generic instantiation. Act_Body and Act_Decl are the body
371 -- and declaration of the instance (either package body and declaration
372 -- nodes or subprogram body and declaration nodes depending on the case).
373 -- On return, the node N has been rewritten with the actual body.
375 procedure Check_Access_Definition
(N
: Node_Id
);
376 -- Subsidiary routine to null exclusion processing. Perform an assertion
377 -- check on Ada version and the presence of an access definition in N.
379 procedure Check_Formal_Packages
(P_Id
: Entity_Id
);
380 -- Apply the following to all formal packages in generic associations
382 procedure Check_Formal_Package_Instance
383 (Formal_Pack
: Entity_Id
;
384 Actual_Pack
: Entity_Id
);
385 -- Verify that the actuals of the actual instance match the actuals of
386 -- the template for a formal package that is not declared with a box.
388 procedure Check_Forward_Instantiation
(Decl
: Node_Id
);
389 -- If the generic is a local entity and the corresponding body has not
390 -- been seen yet, flag enclosing packages to indicate that it will be
391 -- elaborated after the generic body. Subprograms declared in the same
392 -- package cannot be inlined by the front-end because front-end inlining
393 -- requires a strict linear order of elaboration.
395 procedure Check_Hidden_Child_Unit
397 Gen_Unit
: Entity_Id
;
398 Act_Decl_Id
: Entity_Id
);
399 -- If the generic unit is an implicit child instance within a parent
400 -- instance, we need to make an explicit test that it is not hidden by
401 -- a child instance of the same name and parent.
403 procedure Check_Generic_Actuals
404 (Instance
: Entity_Id
;
405 Is_Formal_Box
: Boolean);
406 -- Similar to previous one. Check the actuals in the instantiation,
407 -- whose views can change between the point of instantiation and the point
408 -- of instantiation of the body. In addition, mark the generic renamings
409 -- as generic actuals, so that they are not compatible with other actuals.
410 -- Recurse on an actual that is a formal package whose declaration has
413 function Contains_Instance_Of
416 N
: Node_Id
) return Boolean;
417 -- Inner is instantiated within the generic Outer. Check whether Inner
418 -- directly or indirectly contains an instance of Outer or of one of its
419 -- parents, in the case of a subunit. Each generic unit holds a list of
420 -- the entities instantiated within (at any depth). This procedure
421 -- determines whether the set of such lists contains a cycle, i.e. an
422 -- illegal circular instantiation.
424 function Denotes_Formal_Package
426 On_Exit
: Boolean := False) return Boolean;
427 -- Returns True if E is a formal package of an enclosing generic, or
428 -- the actual for such a formal in an enclosing instantiation. If such
429 -- a package is used as a formal in an nested generic, or as an actual
430 -- in a nested instantiation, the visibility of ITS formals should not
431 -- be modified. When called from within Restore_Private_Views, the flag
432 -- On_Exit is true, to indicate that the search for a possible enclosing
433 -- instance should ignore the current one.
435 function Find_Actual_Type
437 Gen_Scope
: Entity_Id
) return Entity_Id
;
438 -- When validating the actual types of a child instance, check whether
439 -- the formal is a formal type of the parent unit, and retrieve the current
440 -- actual for it. Typ is the entity in the analyzed formal type declaration
441 -- (component or index type of an array type, or designated type of an
442 -- access formal) and Gen_Scope is the scope of the analyzed formal array
443 -- or access type. The desired actual may be a formal of a parent, or may
444 -- be declared in a formal package of a parent. In both cases it is a
445 -- generic actual type because it appears within a visible instance.
446 -- Ambiguities may still arise if two homonyms are declared in two formal
447 -- packages, and the prefix of the formal type may be needed to resolve
448 -- the ambiguity in the instance ???
450 function In_Same_Declarative_Part
452 Inst
: Node_Id
) return Boolean;
453 -- True if the instantiation Inst and the given freeze_node F_Node appear
454 -- within the same declarative part, ignoring subunits, but with no inter-
455 -- vening suprograms or concurrent units. If true, the freeze node
456 -- of the instance can be placed after the freeze node of the parent,
457 -- which it itself an instance.
459 function In_Main_Context
(E
: Entity_Id
) return Boolean;
460 -- Check whether an instantiation is in the context of the main unit.
461 -- Used to determine whether its body should be elaborated to allow
462 -- front-end inlining.
464 function Is_Generic_Formal
(E
: Entity_Id
) return Boolean;
465 -- Utility to determine whether a given entity is declared by means of
466 -- of a formal parameter declaration. Used to set properly the visiblity
467 -- of generic formals of a generic package declared with a box or with
468 -- partial parametrization.
470 procedure Set_Instance_Env
471 (Gen_Unit
: Entity_Id
;
472 Act_Unit
: Entity_Id
);
473 -- Save current instance on saved environment, to be used to determine
474 -- the global status of entities in nested instances. Part of Save_Env.
475 -- called after verifying that the generic unit is legal for the instance,
476 -- The procedure also examines whether the generic unit is a predefined
477 -- unit, in order to set configuration switches accordingly. As a result
478 -- the procedure must be called after analyzing and freezing the actuals.
480 procedure Set_Instance_Of
(A
: Entity_Id
; B
: Entity_Id
);
481 -- Associate analyzed generic parameter with corresponding
482 -- instance. Used for semantic checks at instantiation time.
484 function Has_Been_Exchanged
(E
: Entity_Id
) return Boolean;
485 -- Traverse the Exchanged_Views list to see if a type was private
486 -- and has already been flipped during this phase of instantiation.
488 procedure Hide_Current_Scope
;
489 -- When compiling a generic child unit, the parent context must be
490 -- present, but the instance and all entities that may be generated
491 -- must be inserted in the current scope. We leave the current scope
492 -- on the stack, but make its entities invisible to avoid visibility
493 -- problems. This is reversed at the end of instantiations. This is
494 -- not done for the instantiation of the bodies, which only require the
495 -- instances of the generic parents to be in scope.
497 procedure Install_Body
502 -- If the instantiation happens textually before the body of the generic,
503 -- the instantiation of the body must be analyzed after the generic body,
504 -- and not at the point of instantiation. Such early instantiations can
505 -- happen if the generic and the instance appear in a package declaration
506 -- because the generic body can only appear in the corresponding package
507 -- body. Early instantiations can also appear if generic, instance and
508 -- body are all in the declarative part of a subprogram or entry. Entities
509 -- of packages that are early instantiations are delayed, and their freeze
510 -- node appears after the generic body.
512 procedure Insert_After_Last_Decl
(N
: Node_Id
; F_Node
: Node_Id
);
513 -- Insert freeze node at the end of the declarative part that includes the
514 -- instance node N. If N is in the visible part of an enclosing package
515 -- declaration, the freeze node has to be inserted at the end of the
516 -- private declarations, if any.
518 procedure Freeze_Subprogram_Body
519 (Inst_Node
: Node_Id
;
521 Pack_Id
: Entity_Id
);
522 -- The generic body may appear textually after the instance, including
523 -- in the proper body of a stub, or within a different package instance.
524 -- Given that the instance can only be elaborated after the generic, we
525 -- place freeze_nodes for the instance and/or for packages that may enclose
526 -- the instance and the generic, so that the back-end can establish the
527 -- proper order of elaboration.
530 -- Establish environment for subsequent instantiation. Separated from
531 -- Save_Env because data-structures for visibility handling must be
532 -- initialized before call to Check_Generic_Child_Unit.
534 procedure Install_Formal_Packages
(Par
: Entity_Id
);
535 -- If any of the formals of the parent are formal packages with box,
536 -- their formal parts are visible in the parent and thus in the child
537 -- unit as well. Analogous to what is done in Check_Generic_Actuals
538 -- for the unit itself. This procedure is also used in an instance, to
539 -- make visible the proper entities of the actual for a formal package
540 -- declared with a box.
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 parametrized. In
607 -- 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 be
610 -- 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 an
630 -- instantiation that is a compilation unit.
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 Move_Freeze_Nodes
680 -- Freeze nodes can be generated in the analysis of a generic unit, but
681 -- will not be seen by the back-end. It is necessary to move those nodes
682 -- to the enclosing scope if they freeze an outer entity. We place them
683 -- at the end of the enclosing generic package, which is semantically
686 procedure Pre_Analyze_Actuals
(N
: Node_Id
);
687 -- Analyze actuals to perform name resolution. Full resolution is done
688 -- later, when the expected types are known, but names have to be captured
689 -- before installing parents of generics, that are not visible for the
690 -- actuals themselves.
692 procedure Valid_Default_Attribute
(Nam
: Entity_Id
; Def
: Node_Id
);
693 -- Verify that an attribute that appears as the default for a formal
694 -- subprogram is a function or procedure with the correct profile.
696 -------------------------------------------
697 -- Data Structures for Generic Renamings --
698 -------------------------------------------
700 -- The map Generic_Renamings associates generic entities with their
701 -- corresponding actuals. Currently used to validate type instances. It
702 -- will eventually be used for all generic parameters to eliminate the
703 -- need for overload resolution in the instance.
705 type Assoc_Ptr
is new Int
;
707 Assoc_Null
: constant Assoc_Ptr
:= -1;
712 Next_In_HTable
: Assoc_Ptr
;
715 package Generic_Renamings
is new Table
.Table
716 (Table_Component_Type
=> Assoc
,
717 Table_Index_Type
=> Assoc_Ptr
,
718 Table_Low_Bound
=> 0,
720 Table_Increment
=> 100,
721 Table_Name
=> "Generic_Renamings");
723 -- Variable to hold enclosing instantiation. When the environment is
724 -- saved for a subprogram inlining, the corresponding Act_Id is empty.
726 Current_Instantiated_Parent
: Assoc
:= (Empty
, Empty
, Assoc_Null
);
728 -- Hash table for associations
730 HTable_Size
: constant := 37;
731 type HTable_Range
is range 0 .. HTable_Size
- 1;
733 procedure Set_Next_Assoc
(E
: Assoc_Ptr
; Next
: Assoc_Ptr
);
734 function Next_Assoc
(E
: Assoc_Ptr
) return Assoc_Ptr
;
735 function Get_Gen_Id
(E
: Assoc_Ptr
) return Entity_Id
;
736 function Hash
(F
: Entity_Id
) return HTable_Range
;
738 package Generic_Renamings_HTable
is new GNAT
.HTable
.Static_HTable
(
739 Header_Num
=> HTable_Range
,
741 Elmt_Ptr
=> Assoc_Ptr
,
742 Null_Ptr
=> Assoc_Null
,
743 Set_Next
=> Set_Next_Assoc
,
746 Get_Key
=> Get_Gen_Id
,
750 Exchanged_Views
: Elist_Id
;
751 -- This list holds the private views that have been exchanged during
752 -- instantiation to restore the visibility of the generic declaration.
753 -- (see comments above). After instantiation, the current visibility is
754 -- reestablished by means of a traversal of this list.
756 Hidden_Entities
: Elist_Id
;
757 -- This list holds the entities of the current scope that are removed
758 -- from immediate visibility when instantiating a child unit. Their
759 -- visibility is restored in Remove_Parent.
761 -- Because instantiations can be recursive, the following must be saved
762 -- on entry and restored on exit from an instantiation (spec or body).
763 -- This is done by the two procedures Save_Env and Restore_Env. For
764 -- package and subprogram instantiations (but not for the body instances)
765 -- the action of Save_Env is done in two steps: Init_Env is called before
766 -- Check_Generic_Child_Unit, because setting the parent instances requires
767 -- that the visibility data structures be properly initialized. Once the
768 -- generic is unit is validated, Set_Instance_Env completes Save_Env.
770 Parent_Unit_Visible
: Boolean := False;
771 -- Parent_Unit_Visible is used when the generic is a child unit, and
772 -- indicates whether the ultimate parent of the generic is visible in the
773 -- instantiation environment. It is used to reset the visibility of the
774 -- parent at the end of the instantiation (see Remove_Parent).
776 Instance_Parent_Unit
: Entity_Id
:= Empty
;
777 -- This records the ultimate parent unit of an instance of a generic
778 -- child unit and is used in conjunction with Parent_Unit_Visible to
779 -- indicate the unit to which the Parent_Unit_Visible flag corresponds.
781 type Instance_Env
is record
782 Instantiated_Parent
: Assoc
;
783 Exchanged_Views
: Elist_Id
;
784 Hidden_Entities
: Elist_Id
;
785 Current_Sem_Unit
: Unit_Number_Type
;
786 Parent_Unit_Visible
: Boolean := False;
787 Instance_Parent_Unit
: Entity_Id
:= Empty
;
788 Switches
: Config_Switches_Type
;
791 package Instance_Envs
is new Table
.Table
(
792 Table_Component_Type
=> Instance_Env
,
793 Table_Index_Type
=> Int
,
794 Table_Low_Bound
=> 0,
796 Table_Increment
=> 100,
797 Table_Name
=> "Instance_Envs");
799 procedure Restore_Private_Views
800 (Pack_Id
: Entity_Id
;
801 Is_Package
: Boolean := True);
802 -- Restore the private views of external types, and unmark the generic
803 -- renamings of actuals, so that they become comptible subtypes again.
804 -- For subprograms, Pack_Id is the package constructed to hold the
807 procedure Switch_View
(T
: Entity_Id
);
808 -- Switch the partial and full views of a type and its private
809 -- dependents (i.e. its subtypes and derived types).
811 ------------------------------------
812 -- Structures for Error Reporting --
813 ------------------------------------
815 Instantiation_Node
: Node_Id
;
816 -- Used by subprograms that validate instantiation of formal parameters
817 -- where there might be no actual on which to place the error message.
818 -- Also used to locate the instantiation node for generic subunits.
820 Instantiation_Error
: exception;
821 -- When there is a semantic error in the generic parameter matching,
822 -- there is no point in continuing the instantiation, because the
823 -- number of cascaded errors is unpredictable. This exception aborts
824 -- the instantiation process altogether.
826 S_Adjustment
: Sloc_Adjustment
;
827 -- Offset created for each node in an instantiation, in order to keep
828 -- track of the source position of the instantiation in each of its nodes.
829 -- A subsequent semantic error or warning on a construct of the instance
830 -- points to both places: the original generic node, and the point of
831 -- instantiation. See Sinput and Sinput.L for additional details.
833 ------------------------------------------------------------
834 -- Data structure for keeping track when inside a Generic --
835 ------------------------------------------------------------
837 -- The following table is used to save values of the Inside_A_Generic
838 -- flag (see spec of Sem) when they are saved by Start_Generic.
840 package Generic_Flags
is new Table
.Table
(
841 Table_Component_Type
=> Boolean,
842 Table_Index_Type
=> Int
,
843 Table_Low_Bound
=> 0,
845 Table_Increment
=> 200,
846 Table_Name
=> "Generic_Flags");
848 ---------------------------
849 -- Abandon_Instantiation --
850 ---------------------------
852 procedure Abandon_Instantiation
(N
: Node_Id
) is
854 Error_Msg_N
("\instantiation abandoned!", N
);
855 raise Instantiation_Error
;
856 end Abandon_Instantiation
;
858 --------------------------
859 -- Analyze_Associations --
860 --------------------------
862 function Analyze_Associations
865 F_Copy
: List_Id
) return List_Id
867 Actual_Types
: constant Elist_Id
:= New_Elmt_List
;
868 Assoc
: constant List_Id
:= New_List
;
869 Default_Actuals
: constant Elist_Id
:= New_Elmt_List
;
870 Gen_Unit
: constant Entity_Id
:= Defining_Entity
(Parent
(F_Copy
));
874 Next_Formal
: Node_Id
;
875 Temp_Formal
: Node_Id
;
876 Analyzed_Formal
: Node_Id
;
879 First_Named
: Node_Id
:= Empty
;
881 Default_Formals
: constant List_Id
:= New_List
;
882 -- If an Other_Choice is present, some of the formals may be defaulted.
883 -- To simplify the treatement of visibility in an instance, we introduce
884 -- individual defaults for each such formal. These defaults are
885 -- appended to the list of associations and replace the Others_Choice.
887 Found_Assoc
: Node_Id
;
888 -- Association for the current formal being match. Empty if there are
889 -- no remaining actuals, or if there is no named association with the
890 -- name of the formal.
892 Is_Named_Assoc
: Boolean;
893 Num_Matched
: Int
:= 0;
894 Num_Actuals
: Int
:= 0;
896 Others_Present
: Boolean := False;
897 -- In Ada 2005, indicates partial parametrization of of a formal
898 -- package. As usual an others association must be last in the list.
900 function Matching_Actual
902 A_F
: Entity_Id
) return Node_Id
;
903 -- Find actual that corresponds to a given a formal parameter. If the
904 -- actuals are positional, return the next one, if any. If the actuals
905 -- are named, scan the parameter associations to find the right one.
906 -- A_F is the corresponding entity in the analyzed generic,which is
907 -- placed on the selector name for ASIS use.
909 -- In Ada 2005, a named association may be given with a box, in which
910 -- case Matching_Actual sets Found_Assoc to the generic association,
911 -- but return Empty for the actual itself. In this case the code below
912 -- creates a corresponding declaration for the formal.
914 function Partial_Parametrization
return Boolean;
915 -- Ada 2005: if no match is found for a given formal, check if the
916 -- association for it includes a box, or whether the associations
917 -- include an Others clause.
919 procedure Process_Default
(F
: Entity_Id
);
920 -- Add a copy of the declaration of generic formal F to the list of
921 -- associations, and add an explicit box association for F if there
922 -- is none yet, and the default comes from an Others_Choice.
924 procedure Set_Analyzed_Formal
;
925 -- Find the node in the generic copy that corresponds to a given formal.
926 -- The semantic information on this node is used to perform legality
927 -- checks on the actuals. Because semantic analysis can introduce some
928 -- anonymous entities or modify the declaration node itself, the
929 -- correspondence between the two lists is not one-one. In addition to
930 -- anonymous types, the presence a formal equality will introduce an
931 -- implicit declaration for the corresponding inequality.
933 ---------------------
934 -- Matching_Actual --
935 ---------------------
937 function Matching_Actual
939 A_F
: Entity_Id
) return Node_Id
945 Is_Named_Assoc
:= False;
947 -- End of list of purely positional parameters
950 or else Nkind
(Actual
) = N_Others_Choice
952 Found_Assoc
:= Empty
;
955 -- Case of positional parameter corresponding to current formal
957 elsif No
(Selector_Name
(Actual
)) then
958 Found_Assoc
:= Actual
;
959 Act
:= Explicit_Generic_Actual_Parameter
(Actual
);
960 Num_Matched
:= Num_Matched
+ 1;
963 -- Otherwise scan list of named actuals to find the one with the
964 -- desired name. All remaining actuals have explicit names.
967 Is_Named_Assoc
:= True;
968 Found_Assoc
:= Empty
;
972 while Present
(Actual
) loop
973 if Chars
(Selector_Name
(Actual
)) = Chars
(F
) then
974 Set_Entity
(Selector_Name
(Actual
), A_F
);
975 Set_Etype
(Selector_Name
(Actual
), Etype
(A_F
));
976 Generate_Reference
(A_F
, Selector_Name
(Actual
));
977 Found_Assoc
:= Actual
;
978 Act
:= Explicit_Generic_Actual_Parameter
(Actual
);
979 Num_Matched
:= Num_Matched
+ 1;
987 -- Reset for subsequent searches. In most cases the named
988 -- associations are in order. If they are not, we reorder them
989 -- to avoid scanning twice the same actual. This is not just a
990 -- question of efficiency: there may be multiple defaults with
991 -- boxes that have the same name. In a nested instantiation we
992 -- insert actuals for those defaults, and cannot rely on their
993 -- names to disambiguate them.
995 if Actual
= First_Named
then
998 elsif Present
(Actual
) then
999 Insert_Before
(First_Named
, Remove_Next
(Prev
));
1002 Actual
:= First_Named
;
1005 if Is_Entity_Name
(Act
) and then Present
(Entity
(Act
)) then
1006 Set_Used_As_Generic_Actual
(Entity
(Act
));
1010 end Matching_Actual
;
1012 -----------------------------
1013 -- Partial_Parametrization --
1014 -----------------------------
1016 function Partial_Parametrization
return Boolean is
1018 return Others_Present
1019 or else (Present
(Found_Assoc
) and then Box_Present
(Found_Assoc
));
1020 end Partial_Parametrization
;
1022 ---------------------
1023 -- Process_Default --
1024 ---------------------
1026 procedure Process_Default
(F
: Entity_Id
) is
1027 Loc
: constant Source_Ptr
:= Sloc
(I_Node
);
1033 -- Append copy of formal declaration to associations, and create
1034 -- new defining identifier for it.
1036 Decl
:= New_Copy_Tree
(F
);
1038 if Nkind
(F
) = N_Formal_Concrete_Subprogram_Declaration
then
1040 Make_Defining_Identifier
(Sloc
(Defining_Entity
(F
)),
1041 Chars
=> Chars
(Defining_Entity
(F
)));
1042 Set_Defining_Unit_Name
(Specification
(Decl
), Id
);
1046 Make_Defining_Identifier
(Sloc
(Defining_Entity
(F
)),
1047 Chars
=> Chars
(Defining_Identifier
(F
)));
1048 Set_Defining_Identifier
(Decl
, Id
);
1051 Append
(Decl
, Assoc
);
1053 if No
(Found_Assoc
) then
1055 Make_Generic_Association
(Loc
,
1056 Selector_Name
=> New_Occurrence_Of
(Id
, Loc
),
1057 Explicit_Generic_Actual_Parameter
=> Empty
);
1058 Set_Box_Present
(Default
);
1059 Append
(Default
, Default_Formals
);
1061 end Process_Default
;
1063 -------------------------
1064 -- Set_Analyzed_Formal --
1065 -------------------------
1067 procedure Set_Analyzed_Formal
is
1070 while Present
(Analyzed_Formal
) loop
1071 Kind
:= Nkind
(Analyzed_Formal
);
1073 case Nkind
(Formal
) is
1075 when N_Formal_Subprogram_Declaration
=>
1076 exit when Kind
in N_Formal_Subprogram_Declaration
1079 (Defining_Unit_Name
(Specification
(Formal
))) =
1081 (Defining_Unit_Name
(Specification
(Analyzed_Formal
)));
1083 when N_Formal_Package_Declaration
=>
1085 Kind
= N_Formal_Package_Declaration
1087 Kind
= N_Generic_Package_Declaration
1089 Kind
= N_Package_Declaration
;
1091 when N_Use_Package_Clause | N_Use_Type_Clause
=> exit;
1095 -- Skip freeze nodes, and nodes inserted to replace
1096 -- unrecognized pragmas.
1099 Kind
not in N_Formal_Subprogram_Declaration
1100 and then Kind
/= N_Subprogram_Declaration
1101 and then Kind
/= N_Freeze_Entity
1102 and then Kind
/= N_Null_Statement
1103 and then Kind
/= N_Itype_Reference
1104 and then Chars
(Defining_Identifier
(Formal
)) =
1105 Chars
(Defining_Identifier
(Analyzed_Formal
));
1108 Next
(Analyzed_Formal
);
1110 end Set_Analyzed_Formal
;
1112 -- Start of processing for Analyze_Associations
1115 Actuals
:= Generic_Associations
(I_Node
);
1117 if Present
(Actuals
) then
1119 -- check for an Others choice, indicating a partial parametrization
1120 -- for a formal package.
1122 Actual
:= First
(Actuals
);
1123 while Present
(Actual
) loop
1124 if Nkind
(Actual
) = N_Others_Choice
then
1125 Others_Present
:= True;
1126 if Present
(Next
(Actual
)) then
1127 Error_Msg_N
("others must be last association", Actual
);
1130 -- This subprogram is used both for formal packages and for
1131 -- instantiations. For the latter, associations must all be
1134 if Nkind
(I_Node
) /= N_Formal_Package_Declaration
1135 and then Comes_From_Source
(I_Node
)
1138 ("others association not allowed in an instance",
1142 -- In any case, nothing to do after the others association
1146 elsif Box_Present
(Actual
)
1147 and then Comes_From_Source
(I_Node
)
1148 and then Nkind
(I_Node
) /= N_Formal_Package_Declaration
1151 ("box association not allowed in an instance", Actual
);
1157 -- If named associations are present, save first named association
1158 -- (it may of course be Empty) to facilitate subsequent name search.
1160 First_Named
:= First
(Actuals
);
1161 while Present
(First_Named
)
1162 and then Nkind
(First_Named
) /= N_Others_Choice
1163 and then No
(Selector_Name
(First_Named
))
1165 Num_Actuals
:= Num_Actuals
+ 1;
1170 Named
:= First_Named
;
1171 while Present
(Named
) loop
1172 if Nkind
(Named
) /= N_Others_Choice
1173 and then No
(Selector_Name
(Named
))
1175 Error_Msg_N
("invalid positional actual after named one", Named
);
1176 Abandon_Instantiation
(Named
);
1179 -- A named association may lack an actual parameter, if it was
1180 -- introduced for a default subprogram that turns out to be local
1181 -- to the outer instantiation.
1183 if Nkind
(Named
) /= N_Others_Choice
1184 and then Present
(Explicit_Generic_Actual_Parameter
(Named
))
1186 Num_Actuals
:= Num_Actuals
+ 1;
1192 if Present
(Formals
) then
1193 Formal
:= First_Non_Pragma
(Formals
);
1194 Analyzed_Formal
:= First_Non_Pragma
(F_Copy
);
1196 if Present
(Actuals
) then
1197 Actual
:= First
(Actuals
);
1199 -- All formals should have default values
1205 while Present
(Formal
) loop
1206 Set_Analyzed_Formal
;
1207 Next_Formal
:= Next_Non_Pragma
(Formal
);
1209 case Nkind
(Formal
) is
1210 when N_Formal_Object_Declaration
=>
1213 Defining_Identifier
(Formal
),
1214 Defining_Identifier
(Analyzed_Formal
));
1216 if No
(Match
) and then Partial_Parametrization
then
1217 Process_Default
(Formal
);
1220 (Instantiate_Object
(Formal
, Match
, Analyzed_Formal
),
1224 when N_Formal_Type_Declaration
=>
1227 Defining_Identifier
(Formal
),
1228 Defining_Identifier
(Analyzed_Formal
));
1231 if Partial_Parametrization
then
1232 Process_Default
(Formal
);
1235 Error_Msg_Sloc
:= Sloc
(Gen_Unit
);
1239 Defining_Identifier
(Formal
));
1240 Error_Msg_NE
("\in instantiation of & declared#",
1241 Instantiation_Node
, Gen_Unit
);
1242 Abandon_Instantiation
(Instantiation_Node
);
1249 (Formal
, Match
, Analyzed_Formal
, Assoc
),
1252 -- An instantiation is a freeze point for the actuals,
1253 -- unless this is a rewritten formal package.
1255 if Nkind
(I_Node
) /= N_Formal_Package_Declaration
then
1256 Append_Elmt
(Entity
(Match
), Actual_Types
);
1260 -- A remote access-to-class-wide type must not be an
1261 -- actual parameter for a generic formal of an access
1262 -- type (E.2.2 (17)).
1264 if Nkind
(Analyzed_Formal
) = N_Formal_Type_Declaration
1266 Nkind
(Formal_Type_Definition
(Analyzed_Formal
)) =
1267 N_Access_To_Object_Definition
1269 Validate_Remote_Access_To_Class_Wide_Type
(Match
);
1272 when N_Formal_Subprogram_Declaration
=>
1275 Defining_Unit_Name
(Specification
(Formal
)),
1276 Defining_Unit_Name
(Specification
(Analyzed_Formal
)));
1278 -- If the formal subprogram has the same name as
1279 -- another formal subprogram of the generic, then
1280 -- a named association is illegal (12.3(9)). Exclude
1281 -- named associations that are generated for a nested
1285 and then Is_Named_Assoc
1286 and then Comes_From_Source
(Found_Assoc
)
1288 Temp_Formal
:= First
(Formals
);
1289 while Present
(Temp_Formal
) loop
1290 if Nkind
(Temp_Formal
) in
1291 N_Formal_Subprogram_Declaration
1292 and then Temp_Formal
/= Formal
1294 Chars
(Selector_Name
(Found_Assoc
)) =
1295 Chars
(Defining_Unit_Name
1296 (Specification
(Temp_Formal
)))
1299 ("name not allowed for overloaded formal",
1301 Abandon_Instantiation
(Instantiation_Node
);
1308 -- If there is no corresponding actual, this may be case of
1309 -- partial parametrization, or else the formal has a default
1313 and then Partial_Parametrization
1315 Process_Default
(Formal
);
1318 Instantiate_Formal_Subprogram
1319 (Formal
, Match
, Analyzed_Formal
));
1322 -- If this is a nested generic, preserve default for later
1326 and then Box_Present
(Formal
)
1329 (Defining_Unit_Name
(Specification
(Last
(Assoc
))),
1333 when N_Formal_Package_Declaration
=>
1336 Defining_Identifier
(Formal
),
1337 Defining_Identifier
(Original_Node
(Analyzed_Formal
)));
1340 if Partial_Parametrization
then
1341 Process_Default
(Formal
);
1344 Error_Msg_Sloc
:= Sloc
(Gen_Unit
);
1347 Instantiation_Node
, Defining_Identifier
(Formal
));
1348 Error_Msg_NE
("\in instantiation of & declared#",
1349 Instantiation_Node
, Gen_Unit
);
1351 Abandon_Instantiation
(Instantiation_Node
);
1357 (Instantiate_Formal_Package
1358 (Formal
, Match
, Analyzed_Formal
),
1362 -- For use type and use package appearing in the generic part,
1363 -- we have already copied them, so we can just move them where
1364 -- they belong (we mustn't recopy them since this would mess up
1365 -- the Sloc values).
1367 when N_Use_Package_Clause |
1368 N_Use_Type_Clause
=>
1369 if Nkind
(Original_Node
(I_Node
)) =
1370 N_Formal_Package_Declaration
1372 Append
(New_Copy_Tree
(Formal
), Assoc
);
1375 Append
(Formal
, Assoc
);
1379 raise Program_Error
;
1383 Formal
:= Next_Formal
;
1384 Next_Non_Pragma
(Analyzed_Formal
);
1387 if Num_Actuals
> Num_Matched
then
1388 Error_Msg_Sloc
:= Sloc
(Gen_Unit
);
1390 if Present
(Selector_Name
(Actual
)) then
1392 ("unmatched actual&",
1393 Actual
, Selector_Name
(Actual
));
1394 Error_Msg_NE
("\in instantiation of& declared#",
1398 ("unmatched actual in instantiation of& declared#",
1403 elsif Present
(Actuals
) then
1405 ("too many actuals in generic instantiation", Instantiation_Node
);
1409 Elmt
: Elmt_Id
:= First_Elmt
(Actual_Types
);
1412 while Present
(Elmt
) loop
1413 Freeze_Before
(I_Node
, Node
(Elmt
));
1418 -- If there are default subprograms, normalize the tree by adding
1419 -- explicit associations for them. This is required if the instance
1420 -- appears within a generic.
1428 Elmt
:= First_Elmt
(Default_Actuals
);
1429 while Present
(Elmt
) loop
1430 if No
(Actuals
) then
1431 Actuals
:= New_List
;
1432 Set_Generic_Associations
(I_Node
, Actuals
);
1435 Subp
:= Node
(Elmt
);
1437 Make_Generic_Association
(Sloc
(Subp
),
1438 Selector_Name
=> New_Occurrence_Of
(Subp
, Sloc
(Subp
)),
1439 Explicit_Generic_Actual_Parameter
=>
1440 New_Occurrence_Of
(Subp
, Sloc
(Subp
)));
1441 Mark_Rewrite_Insertion
(New_D
);
1442 Append_To
(Actuals
, New_D
);
1447 -- If this is a formal package. normalize the parameter list by adding
1448 -- explicit box asssociations for the formals that are covered by an
1451 if not Is_Empty_List
(Default_Formals
) then
1452 Append_List
(Default_Formals
, Formals
);
1456 end Analyze_Associations
;
1458 -------------------------------
1459 -- Analyze_Formal_Array_Type --
1460 -------------------------------
1462 procedure Analyze_Formal_Array_Type
1463 (T
: in out Entity_Id
;
1469 -- Treated like a non-generic array declaration, with additional
1474 if Nkind
(Def
) = N_Constrained_Array_Definition
then
1475 DSS
:= First
(Discrete_Subtype_Definitions
(Def
));
1476 while Present
(DSS
) loop
1477 if Nkind
(DSS
) = N_Subtype_Indication
1478 or else Nkind
(DSS
) = N_Range
1479 or else Nkind
(DSS
) = N_Attribute_Reference
1481 Error_Msg_N
("only a subtype mark is allowed in a formal", DSS
);
1488 Array_Type_Declaration
(T
, Def
);
1489 Set_Is_Generic_Type
(Base_Type
(T
));
1491 if Ekind
(Component_Type
(T
)) = E_Incomplete_Type
1492 and then No
(Full_View
(Component_Type
(T
)))
1494 Error_Msg_N
("premature usage of incomplete type", Def
);
1496 -- Check that range constraint is not allowed on the component type
1497 -- of a generic formal array type (AARM 12.5.3(3))
1499 elsif Is_Internal
(Component_Type
(T
))
1500 and then Present
(Subtype_Indication
(Component_Definition
(Def
)))
1501 and then Nkind
(Original_Node
1502 (Subtype_Indication
(Component_Definition
(Def
))))
1503 = N_Subtype_Indication
1506 ("in a formal, a subtype indication can only be "
1507 & "a subtype mark (RM 12.5.3(3))",
1508 Subtype_Indication
(Component_Definition
(Def
)));
1511 end Analyze_Formal_Array_Type
;
1513 ---------------------------------------------
1514 -- Analyze_Formal_Decimal_Fixed_Point_Type --
1515 ---------------------------------------------
1517 -- As for other generic types, we create a valid type representation with
1518 -- legal but arbitrary attributes, whose values are never considered
1519 -- static. For all scalar types we introduce an anonymous base type, with
1520 -- the same attributes. We choose the corresponding integer type to be
1521 -- Standard_Integer.
1523 procedure Analyze_Formal_Decimal_Fixed_Point_Type
1527 Loc
: constant Source_Ptr
:= Sloc
(Def
);
1528 Base
: constant Entity_Id
:=
1530 (E_Decimal_Fixed_Point_Type
,
1531 Current_Scope
, Sloc
(Def
), 'G');
1532 Int_Base
: constant Entity_Id
:= Standard_Integer
;
1533 Delta_Val
: constant Ureal
:= Ureal_1
;
1534 Digs_Val
: constant Uint
:= Uint_6
;
1539 Set_Etype
(Base
, Base
);
1540 Set_Size_Info
(Base
, Int_Base
);
1541 Set_RM_Size
(Base
, RM_Size
(Int_Base
));
1542 Set_First_Rep_Item
(Base
, First_Rep_Item
(Int_Base
));
1543 Set_Digits_Value
(Base
, Digs_Val
);
1544 Set_Delta_Value
(Base
, Delta_Val
);
1545 Set_Small_Value
(Base
, Delta_Val
);
1546 Set_Scalar_Range
(Base
,
1548 Low_Bound
=> Make_Real_Literal
(Loc
, Ureal_1
),
1549 High_Bound
=> Make_Real_Literal
(Loc
, Ureal_1
)));
1551 Set_Is_Generic_Type
(Base
);
1552 Set_Parent
(Base
, Parent
(Def
));
1554 Set_Ekind
(T
, E_Decimal_Fixed_Point_Subtype
);
1555 Set_Etype
(T
, Base
);
1556 Set_Size_Info
(T
, Int_Base
);
1557 Set_RM_Size
(T
, RM_Size
(Int_Base
));
1558 Set_First_Rep_Item
(T
, First_Rep_Item
(Int_Base
));
1559 Set_Digits_Value
(T
, Digs_Val
);
1560 Set_Delta_Value
(T
, Delta_Val
);
1561 Set_Small_Value
(T
, Delta_Val
);
1562 Set_Scalar_Range
(T
, Scalar_Range
(Base
));
1563 Set_Is_Constrained
(T
);
1565 Check_Restriction
(No_Fixed_Point
, Def
);
1566 end Analyze_Formal_Decimal_Fixed_Point_Type
;
1568 -------------------------------------------
1569 -- Analyze_Formal_Derived_Interface_Type --
1570 -------------------------------------------
1572 procedure Analyze_Formal_Derived_Interface_Type
1577 Loc
: constant Source_Ptr
:= Sloc
(Def
);
1580 -- Rewrite as a type declaration of a derived type. This ensures that
1581 -- the interface list and primitive operations are properly captured.
1584 Make_Full_Type_Declaration
(Loc
,
1585 Defining_Identifier
=> T
,
1586 Type_Definition
=> Def
));
1588 Set_Is_Generic_Type
(T
);
1589 end Analyze_Formal_Derived_Interface_Type
;
1591 ---------------------------------
1592 -- Analyze_Formal_Derived_Type --
1593 ---------------------------------
1595 procedure Analyze_Formal_Derived_Type
1600 Loc
: constant Source_Ptr
:= Sloc
(Def
);
1601 Unk_Disc
: constant Boolean := Unknown_Discriminants_Present
(N
);
1605 Set_Is_Generic_Type
(T
);
1607 if Private_Present
(Def
) then
1609 Make_Private_Extension_Declaration
(Loc
,
1610 Defining_Identifier
=> T
,
1611 Discriminant_Specifications
=> Discriminant_Specifications
(N
),
1612 Unknown_Discriminants_Present
=> Unk_Disc
,
1613 Subtype_Indication
=> Subtype_Mark
(Def
),
1614 Interface_List
=> Interface_List
(Def
));
1616 Set_Abstract_Present
(New_N
, Abstract_Present
(Def
));
1617 Set_Limited_Present
(New_N
, Limited_Present
(Def
));
1618 Set_Synchronized_Present
(New_N
, Synchronized_Present
(Def
));
1622 Make_Full_Type_Declaration
(Loc
,
1623 Defining_Identifier
=> T
,
1624 Discriminant_Specifications
=>
1625 Discriminant_Specifications
(Parent
(T
)),
1627 Make_Derived_Type_Definition
(Loc
,
1628 Subtype_Indication
=> Subtype_Mark
(Def
)));
1630 Set_Abstract_Present
1631 (Type_Definition
(New_N
), Abstract_Present
(Def
));
1633 (Type_Definition
(New_N
), Limited_Present
(Def
));
1640 if not Is_Composite_Type
(T
) then
1642 ("unknown discriminants not allowed for elementary types", N
);
1644 Set_Has_Unknown_Discriminants
(T
);
1645 Set_Is_Constrained
(T
, False);
1649 -- If the parent type has a known size, so does the formal, which makes
1650 -- legal representation clauses that involve the formal.
1652 Set_Size_Known_At_Compile_Time
1653 (T
, Size_Known_At_Compile_Time
(Entity
(Subtype_Mark
(Def
))));
1655 end Analyze_Formal_Derived_Type
;
1657 ----------------------------------
1658 -- Analyze_Formal_Discrete_Type --
1659 ----------------------------------
1661 -- The operations defined for a discrete types are those of an enumeration
1662 -- type. The size is set to an arbitrary value, for use in analyzing the
1665 procedure Analyze_Formal_Discrete_Type
(T
: Entity_Id
; Def
: Node_Id
) is
1666 Loc
: constant Source_Ptr
:= Sloc
(Def
);
1670 Base
: constant Entity_Id
:=
1672 (E_Floating_Point_Type
, Current_Scope
, Sloc
(Def
), 'G');
1675 Set_Ekind
(T
, E_Enumeration_Subtype
);
1676 Set_Etype
(T
, Base
);
1679 Set_Is_Generic_Type
(T
);
1680 Set_Is_Constrained
(T
);
1682 -- For semantic analysis, the bounds of the type must be set to some
1683 -- non-static value. The simplest is to create attribute nodes for those
1684 -- bounds, that refer to the type itself. These bounds are never
1685 -- analyzed but serve as place-holders.
1688 Make_Attribute_Reference
(Loc
,
1689 Attribute_Name
=> Name_First
,
1690 Prefix
=> New_Reference_To
(T
, Loc
));
1694 Make_Attribute_Reference
(Loc
,
1695 Attribute_Name
=> Name_Last
,
1696 Prefix
=> New_Reference_To
(T
, Loc
));
1699 Set_Scalar_Range
(T
,
1704 Set_Ekind
(Base
, E_Enumeration_Type
);
1705 Set_Etype
(Base
, Base
);
1706 Init_Size
(Base
, 8);
1707 Init_Alignment
(Base
);
1708 Set_Is_Generic_Type
(Base
);
1709 Set_Scalar_Range
(Base
, Scalar_Range
(T
));
1710 Set_Parent
(Base
, Parent
(Def
));
1711 end Analyze_Formal_Discrete_Type
;
1713 ----------------------------------
1714 -- Analyze_Formal_Floating_Type --
1715 ---------------------------------
1717 procedure Analyze_Formal_Floating_Type
(T
: Entity_Id
; Def
: Node_Id
) is
1718 Base
: constant Entity_Id
:=
1720 (E_Floating_Point_Type
, Current_Scope
, Sloc
(Def
), 'G');
1723 -- The various semantic attributes are taken from the predefined type
1724 -- Float, just so that all of them are initialized. Their values are
1725 -- never used because no constant folding or expansion takes place in
1726 -- the generic itself.
1729 Set_Ekind
(T
, E_Floating_Point_Subtype
);
1730 Set_Etype
(T
, Base
);
1731 Set_Size_Info
(T
, (Standard_Float
));
1732 Set_RM_Size
(T
, RM_Size
(Standard_Float
));
1733 Set_Digits_Value
(T
, Digits_Value
(Standard_Float
));
1734 Set_Scalar_Range
(T
, Scalar_Range
(Standard_Float
));
1735 Set_Is_Constrained
(T
);
1737 Set_Is_Generic_Type
(Base
);
1738 Set_Etype
(Base
, Base
);
1739 Set_Size_Info
(Base
, (Standard_Float
));
1740 Set_RM_Size
(Base
, RM_Size
(Standard_Float
));
1741 Set_Digits_Value
(Base
, Digits_Value
(Standard_Float
));
1742 Set_Scalar_Range
(Base
, Scalar_Range
(Standard_Float
));
1743 Set_Parent
(Base
, Parent
(Def
));
1745 Check_Restriction
(No_Floating_Point
, Def
);
1746 end Analyze_Formal_Floating_Type
;
1748 -----------------------------------
1749 -- Analyze_Formal_Interface_Type;--
1750 -----------------------------------
1752 procedure Analyze_Formal_Interface_Type
1757 Loc
: constant Source_Ptr
:= Sloc
(N
);
1762 Make_Full_Type_Declaration
(Loc
,
1763 Defining_Identifier
=> T
,
1764 Type_Definition
=> Def
);
1768 Set_Is_Generic_Type
(T
);
1769 end Analyze_Formal_Interface_Type
;
1771 ---------------------------------
1772 -- Analyze_Formal_Modular_Type --
1773 ---------------------------------
1775 procedure Analyze_Formal_Modular_Type
(T
: Entity_Id
; Def
: Node_Id
) is
1777 -- Apart from their entity kind, generic modular types are treated like
1778 -- signed integer types, and have the same attributes.
1780 Analyze_Formal_Signed_Integer_Type
(T
, Def
);
1781 Set_Ekind
(T
, E_Modular_Integer_Subtype
);
1782 Set_Ekind
(Etype
(T
), E_Modular_Integer_Type
);
1784 end Analyze_Formal_Modular_Type
;
1786 ---------------------------------------
1787 -- Analyze_Formal_Object_Declaration --
1788 ---------------------------------------
1790 procedure Analyze_Formal_Object_Declaration
(N
: Node_Id
) is
1791 E
: constant Node_Id
:= Default_Expression
(N
);
1792 Id
: constant Node_Id
:= Defining_Identifier
(N
);
1799 -- Determine the mode of the formal object
1801 if Out_Present
(N
) then
1802 K
:= E_Generic_In_Out_Parameter
;
1804 if not In_Present
(N
) then
1805 Error_Msg_N
("formal generic objects cannot have mode OUT", N
);
1809 K
:= E_Generic_In_Parameter
;
1812 if Present
(Subtype_Mark
(N
)) then
1813 Find_Type
(Subtype_Mark
(N
));
1814 T
:= Entity
(Subtype_Mark
(N
));
1816 -- Ada 2005 (AI-423): Formal object with an access definition
1819 Check_Access_Definition
(N
);
1820 T
:= Access_Definition
1822 N
=> Access_Definition
(N
));
1825 if Ekind
(T
) = E_Incomplete_Type
then
1827 Error_Node
: Node_Id
;
1830 if Present
(Subtype_Mark
(N
)) then
1831 Error_Node
:= Subtype_Mark
(N
);
1833 Check_Access_Definition
(N
);
1834 Error_Node
:= Access_Definition
(N
);
1837 Error_Msg_N
("premature usage of incomplete type", Error_Node
);
1841 if K
= E_Generic_In_Parameter
then
1843 -- Ada 2005 (AI-287): Limited aggregates allowed in generic formals
1845 if Ada_Version
< Ada_05
and then Is_Limited_Type
(T
) then
1847 ("generic formal of mode IN must not be of limited type", N
);
1848 Explain_Limited_Type
(T
, N
);
1851 if Is_Abstract_Type
(T
) then
1853 ("generic formal of mode IN must not be of abstract type", N
);
1857 Analyze_Per_Use_Expression
(E
, T
);
1859 if Is_Limited_Type
(T
) and then not OK_For_Limited_Init
(E
) then
1861 ("initialization not allowed for limited types", E
);
1862 Explain_Limited_Type
(T
, E
);
1869 -- Case of generic IN OUT parameter
1872 -- If the formal has an unconstrained type, construct its actual
1873 -- subtype, as is done for subprogram formals. In this fashion, all
1874 -- its uses can refer to specific bounds.
1879 if (Is_Array_Type
(T
)
1880 and then not Is_Constrained
(T
))
1882 (Ekind
(T
) = E_Record_Type
1883 and then Has_Discriminants
(T
))
1886 Non_Freezing_Ref
: constant Node_Id
:=
1887 New_Reference_To
(Id
, Sloc
(Id
));
1891 -- Make sure the actual subtype doesn't generate bogus freezing
1893 Set_Must_Not_Freeze
(Non_Freezing_Ref
);
1894 Decl
:= Build_Actual_Subtype
(T
, Non_Freezing_Ref
);
1895 Insert_Before_And_Analyze
(N
, Decl
);
1896 Set_Actual_Subtype
(Id
, Defining_Identifier
(Decl
));
1899 Set_Actual_Subtype
(Id
, T
);
1904 ("initialization not allowed for `IN OUT` formals", N
);
1908 end Analyze_Formal_Object_Declaration
;
1910 ----------------------------------------------
1911 -- Analyze_Formal_Ordinary_Fixed_Point_Type --
1912 ----------------------------------------------
1914 procedure Analyze_Formal_Ordinary_Fixed_Point_Type
1918 Loc
: constant Source_Ptr
:= Sloc
(Def
);
1919 Base
: constant Entity_Id
:=
1921 (E_Ordinary_Fixed_Point_Type
, Current_Scope
, Sloc
(Def
), 'G');
1923 -- The semantic attributes are set for completeness only, their values
1924 -- will never be used, since all properties of the type are non-static.
1927 Set_Ekind
(T
, E_Ordinary_Fixed_Point_Subtype
);
1928 Set_Etype
(T
, Base
);
1929 Set_Size_Info
(T
, Standard_Integer
);
1930 Set_RM_Size
(T
, RM_Size
(Standard_Integer
));
1931 Set_Small_Value
(T
, Ureal_1
);
1932 Set_Delta_Value
(T
, Ureal_1
);
1933 Set_Scalar_Range
(T
,
1935 Low_Bound
=> Make_Real_Literal
(Loc
, Ureal_1
),
1936 High_Bound
=> Make_Real_Literal
(Loc
, Ureal_1
)));
1937 Set_Is_Constrained
(T
);
1939 Set_Is_Generic_Type
(Base
);
1940 Set_Etype
(Base
, Base
);
1941 Set_Size_Info
(Base
, Standard_Integer
);
1942 Set_RM_Size
(Base
, RM_Size
(Standard_Integer
));
1943 Set_Small_Value
(Base
, Ureal_1
);
1944 Set_Delta_Value
(Base
, Ureal_1
);
1945 Set_Scalar_Range
(Base
, Scalar_Range
(T
));
1946 Set_Parent
(Base
, Parent
(Def
));
1948 Check_Restriction
(No_Fixed_Point
, Def
);
1949 end Analyze_Formal_Ordinary_Fixed_Point_Type
;
1951 ----------------------------
1952 -- Analyze_Formal_Package --
1953 ----------------------------
1955 procedure Analyze_Formal_Package
(N
: Node_Id
) is
1956 Loc
: constant Source_Ptr
:= Sloc
(N
);
1957 Pack_Id
: constant Entity_Id
:= Defining_Identifier
(N
);
1959 Gen_Id
: constant Node_Id
:= Name
(N
);
1961 Gen_Unit
: Entity_Id
;
1963 Parent_Installed
: Boolean := False;
1965 Parent_Instance
: Entity_Id
;
1966 Renaming_In_Par
: Entity_Id
;
1967 No_Associations
: Boolean := False;
1969 function Build_Local_Package
return Node_Id
;
1970 -- The formal package is rewritten so that its parameters are replaced
1971 -- with corresponding declarations. For parameters with bona fide
1972 -- associations these declarations are created by Analyze_Associations
1973 -- as for aa regular instantiation. For boxed parameters, we preserve
1974 -- the formal declarations and analyze them, in order to introduce
1975 -- entities of the right kind in the environment of the formal.
1977 -------------------------
1978 -- Build_Local_Package --
1979 -------------------------
1981 function Build_Local_Package
return Node_Id
is
1983 Pack_Decl
: Node_Id
;
1986 -- Within the formal, the name of the generic package is a renaming
1987 -- of the formal (as for a regular instantiation).
1990 Make_Package_Declaration
(Loc
,
1993 (Specification
(Original_Node
(Gen_Decl
)),
1994 Empty
, Instantiating
=> True));
1996 Renaming
:= Make_Package_Renaming_Declaration
(Loc
,
1997 Defining_Unit_Name
=>
1998 Make_Defining_Identifier
(Loc
, Chars
(Gen_Unit
)),
1999 Name
=> New_Occurrence_Of
(Formal
, Loc
));
2001 if Nkind
(Gen_Id
) = N_Identifier
2002 and then Chars
(Gen_Id
) = Chars
(Pack_Id
)
2005 ("& is hidden within declaration of instance", Gen_Id
, Gen_Unit
);
2008 -- If the formal is declared with a box, or with an others choice,
2009 -- create corresponding declarations for all entities in the formal
2010 -- part, so that names with the proper types are available in the
2011 -- specification of the formal package.
2012 -- On the other hand, if there are no associations, then all the
2013 -- formals must have defaults, and this will be checked by the
2014 -- call to Analyze_Associations.
2017 or else Nkind
(First
(Generic_Associations
(N
))) = N_Others_Choice
2020 Formal_Decl
: Node_Id
;
2023 -- TBA : for a formal package, need to recurse ???
2028 (Generic_Formal_Declarations
(Original_Node
(Gen_Decl
)));
2029 while Present
(Formal_Decl
) loop
2031 (Decls
, Copy_Generic_Node
(Formal_Decl
, Empty
, True));
2036 -- If generic associations are present, use Analyze_Associations to
2037 -- create the proper renaming declarations.
2041 Act_Tree
: constant Node_Id
:=
2043 (Original_Node
(Gen_Decl
), Empty
,
2044 Instantiating
=> True);
2047 Generic_Renamings
.Set_Last
(0);
2048 Generic_Renamings_HTable
.Reset
;
2049 Instantiation_Node
:= N
;
2052 Analyze_Associations
2054 Generic_Formal_Declarations
(Act_Tree
),
2055 Generic_Formal_Declarations
(Gen_Decl
));
2059 Append
(Renaming
, To
=> Decls
);
2061 -- Add generated declarations ahead of local declarations in
2064 if No
(Visible_Declarations
(Specification
(Pack_Decl
))) then
2065 Set_Visible_Declarations
(Specification
(Pack_Decl
), Decls
);
2068 (First
(Visible_Declarations
(Specification
(Pack_Decl
))),
2073 end Build_Local_Package
;
2075 -- Start of processing for Analyze_Formal_Package
2078 Text_IO_Kludge
(Gen_Id
);
2081 Check_Generic_Child_Unit
(Gen_Id
, Parent_Installed
);
2082 Gen_Unit
:= Entity
(Gen_Id
);
2084 -- Check for a formal package that is a package renaming
2086 if Present
(Renamed_Object
(Gen_Unit
)) then
2087 Gen_Unit
:= Renamed_Object
(Gen_Unit
);
2090 if Ekind
(Gen_Unit
) /= E_Generic_Package
then
2091 Error_Msg_N
("expect generic package name", Gen_Id
);
2095 elsif Gen_Unit
= Current_Scope
then
2097 ("generic package cannot be used as a formal package of itself",
2102 elsif In_Open_Scopes
(Gen_Unit
) then
2103 if Is_Compilation_Unit
(Gen_Unit
)
2104 and then Is_Child_Unit
(Current_Scope
)
2106 -- Special-case the error when the formal is a parent, and
2107 -- continue analysis to minimize cascaded errors.
2110 ("generic parent cannot be used as formal package "
2111 & "of a child unit",
2116 ("generic package cannot be used as a formal package "
2125 or else No
(Generic_Associations
(N
))
2126 or else Nkind
(First
(Generic_Associations
(N
))) = N_Others_Choice
2128 No_Associations
:= True;
2131 -- If there are no generic associations, the generic parameters appear
2132 -- as local entities and are instantiated like them. We copy the generic
2133 -- package declaration as if it were an instantiation, and analyze it
2134 -- like a regular package, except that we treat the formals as
2135 -- additional visible components.
2137 Gen_Decl
:= Unit_Declaration_Node
(Gen_Unit
);
2139 if In_Extended_Main_Source_Unit
(N
) then
2140 Set_Is_Instantiated
(Gen_Unit
);
2141 Generate_Reference
(Gen_Unit
, N
);
2144 Formal
:= New_Copy
(Pack_Id
);
2145 Create_Instantiation_Source
(N
, Gen_Unit
, False, S_Adjustment
);
2148 -- Make local generic without formals. The formals will be replaced
2149 -- with internal declarations.
2151 New_N
:= Build_Local_Package
;
2153 -- If there are errors in the parameter list, Analyze_Associations
2154 -- raises Instantiation_Error. Patch the declaration to prevent
2155 -- further exception propagation.
2158 when Instantiation_Error
=>
2160 Enter_Name
(Formal
);
2161 Set_Ekind
(Formal
, E_Variable
);
2162 Set_Etype
(Formal
, Any_Type
);
2164 if Parent_Installed
then
2172 Set_Defining_Unit_Name
(Specification
(New_N
), Formal
);
2173 Set_Generic_Parent
(Specification
(N
), Gen_Unit
);
2174 Set_Instance_Env
(Gen_Unit
, Formal
);
2175 Set_Is_Generic_Instance
(Formal
);
2177 Enter_Name
(Formal
);
2178 Set_Ekind
(Formal
, E_Package
);
2179 Set_Etype
(Formal
, Standard_Void_Type
);
2180 Set_Inner_Instances
(Formal
, New_Elmt_List
);
2181 Push_Scope
(Formal
);
2183 if Is_Child_Unit
(Gen_Unit
)
2184 and then Parent_Installed
2186 -- Similarly, we have to make the name of the formal visible in the
2187 -- parent instance, to resolve properly fully qualified names that
2188 -- may appear in the generic unit. The parent instance has been
2189 -- placed on the scope stack ahead of the current scope.
2191 Parent_Instance
:= Scope_Stack
.Table
(Scope_Stack
.Last
- 1).Entity
;
2194 Make_Defining_Identifier
(Loc
, Chars
(Gen_Unit
));
2195 Set_Ekind
(Renaming_In_Par
, E_Package
);
2196 Set_Etype
(Renaming_In_Par
, Standard_Void_Type
);
2197 Set_Scope
(Renaming_In_Par
, Parent_Instance
);
2198 Set_Parent
(Renaming_In_Par
, Parent
(Formal
));
2199 Set_Renamed_Object
(Renaming_In_Par
, Formal
);
2200 Append_Entity
(Renaming_In_Par
, Parent_Instance
);
2203 Analyze
(Specification
(N
));
2205 -- The formals for which associations are provided are not visible
2206 -- outside of the formal package. The others are still declared by a
2207 -- formal parameter declaration.
2209 if not No_Associations
then
2214 E
:= First_Entity
(Formal
);
2215 while Present
(E
) loop
2216 exit when Ekind
(E
) = E_Package
2217 and then Renamed_Entity
(E
) = Formal
;
2219 if not Is_Generic_Formal
(E
) then
2228 End_Package_Scope
(Formal
);
2230 if Parent_Installed
then
2236 -- Inside the generic unit, the formal package is a regular package, but
2237 -- no body is needed for it. Note that after instantiation, the defining
2238 -- unit name we need is in the new tree and not in the original (see
2239 -- Package_Instantiation). A generic formal package is an instance, and
2240 -- can be used as an actual for an inner instance.
2242 Set_Has_Completion
(Formal
, True);
2244 -- Add semantic information to the original defining identifier.
2247 Set_Ekind
(Pack_Id
, E_Package
);
2248 Set_Etype
(Pack_Id
, Standard_Void_Type
);
2249 Set_Scope
(Pack_Id
, Scope
(Formal
));
2250 Set_Has_Completion
(Pack_Id
, True);
2251 end Analyze_Formal_Package
;
2253 ---------------------------------
2254 -- Analyze_Formal_Private_Type --
2255 ---------------------------------
2257 procedure Analyze_Formal_Private_Type
2263 New_Private_Type
(N
, T
, Def
);
2265 -- Set the size to an arbitrary but legal value
2267 Set_Size_Info
(T
, Standard_Integer
);
2268 Set_RM_Size
(T
, RM_Size
(Standard_Integer
));
2269 end Analyze_Formal_Private_Type
;
2271 ----------------------------------------
2272 -- Analyze_Formal_Signed_Integer_Type --
2273 ----------------------------------------
2275 procedure Analyze_Formal_Signed_Integer_Type
2279 Base
: constant Entity_Id
:=
2281 (E_Signed_Integer_Type
, Current_Scope
, Sloc
(Def
), 'G');
2286 Set_Ekind
(T
, E_Signed_Integer_Subtype
);
2287 Set_Etype
(T
, Base
);
2288 Set_Size_Info
(T
, Standard_Integer
);
2289 Set_RM_Size
(T
, RM_Size
(Standard_Integer
));
2290 Set_Scalar_Range
(T
, Scalar_Range
(Standard_Integer
));
2291 Set_Is_Constrained
(T
);
2293 Set_Is_Generic_Type
(Base
);
2294 Set_Size_Info
(Base
, Standard_Integer
);
2295 Set_RM_Size
(Base
, RM_Size
(Standard_Integer
));
2296 Set_Etype
(Base
, Base
);
2297 Set_Scalar_Range
(Base
, Scalar_Range
(Standard_Integer
));
2298 Set_Parent
(Base
, Parent
(Def
));
2299 end Analyze_Formal_Signed_Integer_Type
;
2301 -------------------------------
2302 -- Analyze_Formal_Subprogram --
2303 -------------------------------
2305 procedure Analyze_Formal_Subprogram
(N
: Node_Id
) is
2306 Spec
: constant Node_Id
:= Specification
(N
);
2307 Def
: constant Node_Id
:= Default_Name
(N
);
2308 Nam
: constant Entity_Id
:= Defining_Unit_Name
(Spec
);
2316 if Nkind
(Nam
) = N_Defining_Program_Unit_Name
then
2317 Error_Msg_N
("name of formal subprogram must be a direct name", Nam
);
2321 Analyze_Subprogram_Declaration
(N
);
2322 Set_Is_Formal_Subprogram
(Nam
);
2323 Set_Has_Completion
(Nam
);
2325 if Nkind
(N
) = N_Formal_Abstract_Subprogram_Declaration
then
2326 Set_Is_Abstract_Subprogram
(Nam
);
2327 Set_Is_Dispatching_Operation
(Nam
);
2330 Ctrl_Type
: constant Entity_Id
:= Find_Dispatching_Type
(Nam
);
2332 if No
(Ctrl_Type
) then
2334 ("abstract formal subprogram must have a controlling type",
2337 Check_Controlling_Formals
(Ctrl_Type
, Nam
);
2342 -- Default name is resolved at the point of instantiation
2344 if Box_Present
(N
) then
2347 -- Else default is bound at the point of generic declaration
2349 elsif Present
(Def
) then
2350 if Nkind
(Def
) = N_Operator_Symbol
then
2351 Find_Direct_Name
(Def
);
2353 elsif Nkind
(Def
) /= N_Attribute_Reference
then
2357 -- For an attribute reference, analyze the prefix and verify
2358 -- that it has the proper profile for the subprogram.
2360 Analyze
(Prefix
(Def
));
2361 Valid_Default_Attribute
(Nam
, Def
);
2365 -- Default name may be overloaded, in which case the interpretation
2366 -- with the correct profile must be selected, as for a renaming.
2368 if Etype
(Def
) = Any_Type
then
2371 elsif Nkind
(Def
) = N_Selected_Component
then
2372 Subp
:= Entity
(Selector_Name
(Def
));
2374 if Ekind
(Subp
) /= E_Entry
then
2375 Error_Msg_N
("expect valid subprogram name as default", Def
);
2379 elsif Nkind
(Def
) = N_Indexed_Component
then
2381 if Nkind
(Prefix
(Def
)) /= N_Selected_Component
then
2382 Error_Msg_N
("expect valid subprogram name as default", Def
);
2386 Subp
:= Entity
(Selector_Name
(Prefix
(Def
)));
2388 if Ekind
(Subp
) /= E_Entry_Family
then
2389 Error_Msg_N
("expect valid subprogram name as default", Def
);
2394 elsif Nkind
(Def
) = N_Character_Literal
then
2396 -- Needs some type checks: subprogram should be parameterless???
2398 Resolve
(Def
, (Etype
(Nam
)));
2400 elsif not Is_Entity_Name
(Def
)
2401 or else not Is_Overloadable
(Entity
(Def
))
2403 Error_Msg_N
("expect valid subprogram name as default", Def
);
2406 elsif not Is_Overloaded
(Def
) then
2407 Subp
:= Entity
(Def
);
2410 Error_Msg_N
("premature usage of formal subprogram", Def
);
2412 elsif not Entity_Matches_Spec
(Subp
, Nam
) then
2413 Error_Msg_N
("no visible entity matches specification", Def
);
2419 I1
: Interp_Index
:= 0;
2425 Get_First_Interp
(Def
, I
, It
);
2426 while Present
(It
.Nam
) loop
2428 if Entity_Matches_Spec
(It
.Nam
, Nam
) then
2429 if Subp
/= Any_Id
then
2430 It1
:= Disambiguate
(Def
, I1
, I
, Etype
(Subp
));
2432 if It1
= No_Interp
then
2433 Error_Msg_N
("ambiguous default subprogram", Def
);
2446 Get_Next_Interp
(I
, It
);
2450 if Subp
/= Any_Id
then
2451 Set_Entity
(Def
, Subp
);
2454 Error_Msg_N
("premature usage of formal subprogram", Def
);
2456 elsif Ekind
(Subp
) /= E_Operator
then
2457 Check_Mode_Conformant
(Subp
, Nam
);
2461 Error_Msg_N
("no visible subprogram matches specification", N
);
2465 end Analyze_Formal_Subprogram
;
2467 -------------------------------------
2468 -- Analyze_Formal_Type_Declaration --
2469 -------------------------------------
2471 procedure Analyze_Formal_Type_Declaration
(N
: Node_Id
) is
2472 Def
: constant Node_Id
:= Formal_Type_Definition
(N
);
2476 T
:= Defining_Identifier
(N
);
2478 if Present
(Discriminant_Specifications
(N
))
2479 and then Nkind
(Def
) /= N_Formal_Private_Type_Definition
2482 ("discriminants not allowed for this formal type", T
);
2485 -- Enter the new name, and branch to specific routine
2488 when N_Formal_Private_Type_Definition
=>
2489 Analyze_Formal_Private_Type
(N
, T
, Def
);
2491 when N_Formal_Derived_Type_Definition
=>
2492 Analyze_Formal_Derived_Type
(N
, T
, Def
);
2494 when N_Formal_Discrete_Type_Definition
=>
2495 Analyze_Formal_Discrete_Type
(T
, Def
);
2497 when N_Formal_Signed_Integer_Type_Definition
=>
2498 Analyze_Formal_Signed_Integer_Type
(T
, Def
);
2500 when N_Formal_Modular_Type_Definition
=>
2501 Analyze_Formal_Modular_Type
(T
, Def
);
2503 when N_Formal_Floating_Point_Definition
=>
2504 Analyze_Formal_Floating_Type
(T
, Def
);
2506 when N_Formal_Ordinary_Fixed_Point_Definition
=>
2507 Analyze_Formal_Ordinary_Fixed_Point_Type
(T
, Def
);
2509 when N_Formal_Decimal_Fixed_Point_Definition
=>
2510 Analyze_Formal_Decimal_Fixed_Point_Type
(T
, Def
);
2512 when N_Array_Type_Definition
=>
2513 Analyze_Formal_Array_Type
(T
, Def
);
2515 when N_Access_To_Object_Definition |
2516 N_Access_Function_Definition |
2517 N_Access_Procedure_Definition
=>
2518 Analyze_Generic_Access_Type
(T
, Def
);
2520 -- Ada 2005: a interface declaration is encoded as an abstract
2521 -- record declaration or a abstract type derivation.
2523 when N_Record_Definition
=>
2524 Analyze_Formal_Interface_Type
(N
, T
, Def
);
2526 when N_Derived_Type_Definition
=>
2527 Analyze_Formal_Derived_Interface_Type
(N
, T
, Def
);
2533 raise Program_Error
;
2537 Set_Is_Generic_Type
(T
);
2538 end Analyze_Formal_Type_Declaration
;
2540 ------------------------------------
2541 -- Analyze_Function_Instantiation --
2542 ------------------------------------
2544 procedure Analyze_Function_Instantiation
(N
: Node_Id
) is
2546 Analyze_Subprogram_Instantiation
(N
, E_Function
);
2547 end Analyze_Function_Instantiation
;
2549 ---------------------------------
2550 -- Analyze_Generic_Access_Type --
2551 ---------------------------------
2553 procedure Analyze_Generic_Access_Type
(T
: Entity_Id
; Def
: Node_Id
) is
2557 if Nkind
(Def
) = N_Access_To_Object_Definition
then
2558 Access_Type_Declaration
(T
, Def
);
2560 if Is_Incomplete_Or_Private_Type
(Designated_Type
(T
))
2561 and then No
(Full_View
(Designated_Type
(T
)))
2562 and then not Is_Generic_Type
(Designated_Type
(T
))
2564 Error_Msg_N
("premature usage of incomplete type", Def
);
2566 elsif Is_Internal
(Designated_Type
(T
)) then
2568 ("only a subtype mark is allowed in a formal", Def
);
2572 Access_Subprogram_Declaration
(T
, Def
);
2574 end Analyze_Generic_Access_Type
;
2576 ---------------------------------
2577 -- Analyze_Generic_Formal_Part --
2578 ---------------------------------
2580 procedure Analyze_Generic_Formal_Part
(N
: Node_Id
) is
2581 Gen_Parm_Decl
: Node_Id
;
2584 -- The generic formals are processed in the scope of the generic unit,
2585 -- where they are immediately visible. The scope is installed by the
2588 Gen_Parm_Decl
:= First
(Generic_Formal_Declarations
(N
));
2590 while Present
(Gen_Parm_Decl
) loop
2591 Analyze
(Gen_Parm_Decl
);
2592 Next
(Gen_Parm_Decl
);
2595 Generate_Reference_To_Generic_Formals
(Current_Scope
);
2596 end Analyze_Generic_Formal_Part
;
2598 ------------------------------------------
2599 -- Analyze_Generic_Package_Declaration --
2600 ------------------------------------------
2602 procedure Analyze_Generic_Package_Declaration
(N
: Node_Id
) is
2603 Loc
: constant Source_Ptr
:= Sloc
(N
);
2606 Save_Parent
: Node_Id
;
2608 Decls
: constant List_Id
:=
2609 Visible_Declarations
(Specification
(N
));
2613 -- We introduce a renaming of the enclosing package, to have a usable
2614 -- entity as the prefix of an expanded name for a local entity of the
2615 -- form Par.P.Q, where P is the generic package. This is because a local
2616 -- entity named P may hide it, so that the usual visibility rules in
2617 -- the instance will not resolve properly.
2620 Make_Package_Renaming_Declaration
(Loc
,
2621 Defining_Unit_Name
=>
2622 Make_Defining_Identifier
(Loc
,
2623 Chars
=> New_External_Name
(Chars
(Defining_Entity
(N
)), "GH")),
2624 Name
=> Make_Identifier
(Loc
, Chars
(Defining_Entity
(N
))));
2626 if Present
(Decls
) then
2627 Decl
:= First
(Decls
);
2628 while Present
(Decl
)
2629 and then Nkind
(Decl
) = N_Pragma
2634 if Present
(Decl
) then
2635 Insert_Before
(Decl
, Renaming
);
2637 Append
(Renaming
, Visible_Declarations
(Specification
(N
)));
2641 Set_Visible_Declarations
(Specification
(N
), New_List
(Renaming
));
2644 -- Create copy of generic unit, and save for instantiation. If the unit
2645 -- is a child unit, do not copy the specifications for the parent, which
2646 -- are not part of the generic tree.
2648 Save_Parent
:= Parent_Spec
(N
);
2649 Set_Parent_Spec
(N
, Empty
);
2651 New_N
:= Copy_Generic_Node
(N
, Empty
, Instantiating
=> False);
2652 Set_Parent_Spec
(New_N
, Save_Parent
);
2654 Id
:= Defining_Entity
(N
);
2655 Generate_Definition
(Id
);
2657 -- Expansion is not applied to generic units
2662 Set_Ekind
(Id
, E_Generic_Package
);
2663 Set_Etype
(Id
, Standard_Void_Type
);
2665 Enter_Generic_Scope
(Id
);
2666 Set_Inner_Instances
(Id
, New_Elmt_List
);
2668 Set_Categorization_From_Pragmas
(N
);
2669 Set_Is_Pure
(Id
, Is_Pure
(Current_Scope
));
2671 -- Link the declaration of the generic homonym in the generic copy to
2672 -- the package it renames, so that it is always resolved properly.
2674 Set_Generic_Homonym
(Id
, Defining_Unit_Name
(Renaming
));
2675 Set_Entity
(Associated_Node
(Name
(Renaming
)), Id
);
2677 -- For a library unit, we have reconstructed the entity for the unit,
2678 -- and must reset it in the library tables.
2680 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
2681 Set_Cunit_Entity
(Current_Sem_Unit
, Id
);
2684 Analyze_Generic_Formal_Part
(N
);
2686 -- After processing the generic formals, analysis proceeds as for a
2687 -- non-generic package.
2689 Analyze
(Specification
(N
));
2691 Validate_Categorization_Dependency
(N
, Id
);
2695 End_Package_Scope
(Id
);
2696 Exit_Generic_Scope
(Id
);
2698 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
2699 Move_Freeze_Nodes
(Id
, N
, Visible_Declarations
(Specification
(N
)));
2700 Move_Freeze_Nodes
(Id
, N
, Private_Declarations
(Specification
(N
)));
2701 Move_Freeze_Nodes
(Id
, N
, Generic_Formal_Declarations
(N
));
2704 Set_Body_Required
(Parent
(N
), Unit_Requires_Body
(Id
));
2705 Validate_RT_RAT_Component
(N
);
2707 -- If this is a spec without a body, check that generic parameters
2710 if not Body_Required
(Parent
(N
)) then
2711 Check_References
(Id
);
2714 end Analyze_Generic_Package_Declaration
;
2716 --------------------------------------------
2717 -- Analyze_Generic_Subprogram_Declaration --
2718 --------------------------------------------
2720 procedure Analyze_Generic_Subprogram_Declaration
(N
: Node_Id
) is
2725 Result_Type
: Entity_Id
;
2726 Save_Parent
: Node_Id
;
2729 -- Create copy of generic unit,and save for instantiation. If the unit
2730 -- is a child unit, do not copy the specifications for the parent, which
2731 -- are not part of the generic tree.
2733 Save_Parent
:= Parent_Spec
(N
);
2734 Set_Parent_Spec
(N
, Empty
);
2736 New_N
:= Copy_Generic_Node
(N
, Empty
, Instantiating
=> False);
2737 Set_Parent_Spec
(New_N
, Save_Parent
);
2740 Spec
:= Specification
(N
);
2741 Id
:= Defining_Entity
(Spec
);
2742 Generate_Definition
(Id
);
2744 if Nkind
(Id
) = N_Defining_Operator_Symbol
then
2746 ("operator symbol not allowed for generic subprogram", Id
);
2753 Set_Scope_Depth_Value
(Id
, Scope_Depth
(Current_Scope
) + 1);
2755 Enter_Generic_Scope
(Id
);
2756 Set_Inner_Instances
(Id
, New_Elmt_List
);
2757 Set_Is_Pure
(Id
, Is_Pure
(Current_Scope
));
2759 Analyze_Generic_Formal_Part
(N
);
2761 Formals
:= Parameter_Specifications
(Spec
);
2763 if Present
(Formals
) then
2764 Process_Formals
(Formals
, Spec
);
2767 if Nkind
(Spec
) = N_Function_Specification
then
2768 Set_Ekind
(Id
, E_Generic_Function
);
2770 if Nkind
(Result_Definition
(Spec
)) = N_Access_Definition
then
2771 Result_Type
:= Access_Definition
(Spec
, Result_Definition
(Spec
));
2772 Set_Etype
(Id
, Result_Type
);
2774 Find_Type
(Result_Definition
(Spec
));
2775 Set_Etype
(Id
, Entity
(Result_Definition
(Spec
)));
2779 Set_Ekind
(Id
, E_Generic_Procedure
);
2780 Set_Etype
(Id
, Standard_Void_Type
);
2783 -- For a library unit, we have reconstructed the entity for the unit,
2784 -- and must reset it in the library tables. We also make sure that
2785 -- Body_Required is set properly in the original compilation unit node.
2787 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
2788 Set_Cunit_Entity
(Current_Sem_Unit
, Id
);
2789 Set_Body_Required
(Parent
(N
), Unit_Requires_Body
(Id
));
2792 Set_Categorization_From_Pragmas
(N
);
2793 Validate_Categorization_Dependency
(N
, Id
);
2795 Save_Global_References
(Original_Node
(N
));
2799 Exit_Generic_Scope
(Id
);
2800 Generate_Reference_To_Formals
(Id
);
2801 end Analyze_Generic_Subprogram_Declaration
;
2803 -----------------------------------
2804 -- Analyze_Package_Instantiation --
2805 -----------------------------------
2807 procedure Analyze_Package_Instantiation
(N
: Node_Id
) is
2808 Loc
: constant Source_Ptr
:= Sloc
(N
);
2809 Gen_Id
: constant Node_Id
:= Name
(N
);
2812 Act_Decl_Name
: Node_Id
;
2813 Act_Decl_Id
: Entity_Id
;
2818 Gen_Unit
: Entity_Id
;
2820 Is_Actual_Pack
: constant Boolean :=
2821 Is_Internal
(Defining_Entity
(N
));
2823 Env_Installed
: Boolean := False;
2824 Parent_Installed
: Boolean := False;
2825 Renaming_List
: List_Id
;
2826 Unit_Renaming
: Node_Id
;
2827 Needs_Body
: Boolean;
2828 Inline_Now
: Boolean := False;
2830 procedure Delay_Descriptors
(E
: Entity_Id
);
2831 -- Delay generation of subprogram descriptors for given entity
2833 function Might_Inline_Subp
return Boolean;
2834 -- If inlining is active and the generic contains inlined subprograms,
2835 -- we instantiate the body. This may cause superfluous instantiations,
2836 -- but it is simpler than detecting the need for the body at the point
2837 -- of inlining, when the context of the instance is not available.
2839 -----------------------
2840 -- Delay_Descriptors --
2841 -----------------------
2843 procedure Delay_Descriptors
(E
: Entity_Id
) is
2845 if not Delay_Subprogram_Descriptors
(E
) then
2846 Set_Delay_Subprogram_Descriptors
(E
);
2847 Pending_Descriptor
.Append
(E
);
2849 end Delay_Descriptors
;
2851 -----------------------
2852 -- Might_Inline_Subp --
2853 -----------------------
2855 function Might_Inline_Subp
return Boolean is
2859 if not Inline_Processing_Required
then
2863 E
:= First_Entity
(Gen_Unit
);
2864 while Present
(E
) loop
2865 if Is_Subprogram
(E
)
2866 and then Is_Inlined
(E
)
2876 end Might_Inline_Subp
;
2878 -- Start of processing for Analyze_Package_Instantiation
2881 -- Very first thing: apply the special kludge for Text_IO processing
2882 -- in case we are instantiating one of the children of [Wide_]Text_IO.
2884 Text_IO_Kludge
(Name
(N
));
2886 -- Make node global for error reporting
2888 Instantiation_Node
:= N
;
2890 -- Case of instantiation of a generic package
2892 if Nkind
(N
) = N_Package_Instantiation
then
2893 Act_Decl_Id
:= New_Copy
(Defining_Entity
(N
));
2894 Set_Comes_From_Source
(Act_Decl_Id
, True);
2896 if Nkind
(Defining_Unit_Name
(N
)) = N_Defining_Program_Unit_Name
then
2898 Make_Defining_Program_Unit_Name
(Loc
,
2899 Name
=> New_Copy_Tree
(Name
(Defining_Unit_Name
(N
))),
2900 Defining_Identifier
=> Act_Decl_Id
);
2902 Act_Decl_Name
:= Act_Decl_Id
;
2905 -- Case of instantiation of a formal package
2908 Act_Decl_Id
:= Defining_Identifier
(N
);
2909 Act_Decl_Name
:= Act_Decl_Id
;
2912 Generate_Definition
(Act_Decl_Id
);
2913 Pre_Analyze_Actuals
(N
);
2916 Env_Installed
:= True;
2917 Check_Generic_Child_Unit
(Gen_Id
, Parent_Installed
);
2918 Gen_Unit
:= Entity
(Gen_Id
);
2920 -- Verify that it is the name of a generic package
2922 if Etype
(Gen_Unit
) = Any_Type
then
2926 elsif Ekind
(Gen_Unit
) /= E_Generic_Package
then
2928 -- Ada 2005 (AI-50217): Cannot use instance in limited with_clause
2930 if From_With_Type
(Gen_Unit
) then
2932 ("cannot instantiate a limited withed package", Gen_Id
);
2935 ("expect name of generic package in instantiation", Gen_Id
);
2942 if In_Extended_Main_Source_Unit
(N
) then
2943 Set_Is_Instantiated
(Gen_Unit
);
2944 Generate_Reference
(Gen_Unit
, N
);
2946 if Present
(Renamed_Object
(Gen_Unit
)) then
2947 Set_Is_Instantiated
(Renamed_Object
(Gen_Unit
));
2948 Generate_Reference
(Renamed_Object
(Gen_Unit
), N
);
2952 if Nkind
(Gen_Id
) = N_Identifier
2953 and then Chars
(Gen_Unit
) = Chars
(Defining_Entity
(N
))
2956 ("& is hidden within declaration of instance", Gen_Id
, Gen_Unit
);
2958 elsif Nkind
(Gen_Id
) = N_Expanded_Name
2959 and then Is_Child_Unit
(Gen_Unit
)
2960 and then Nkind
(Prefix
(Gen_Id
)) = N_Identifier
2961 and then Chars
(Act_Decl_Id
) = Chars
(Prefix
(Gen_Id
))
2964 ("& is hidden within declaration of instance ", Prefix
(Gen_Id
));
2967 Set_Entity
(Gen_Id
, Gen_Unit
);
2969 -- If generic is a renaming, get original generic unit
2971 if Present
(Renamed_Object
(Gen_Unit
))
2972 and then Ekind
(Renamed_Object
(Gen_Unit
)) = E_Generic_Package
2974 Gen_Unit
:= Renamed_Object
(Gen_Unit
);
2977 -- Verify that there are no circular instantiations
2979 if In_Open_Scopes
(Gen_Unit
) then
2980 Error_Msg_NE
("instantiation of & within itself", N
, Gen_Unit
);
2984 elsif Contains_Instance_Of
(Gen_Unit
, Current_Scope
, Gen_Id
) then
2985 Error_Msg_Node_2
:= Current_Scope
;
2987 ("circular Instantiation: & instantiated in &!", N
, Gen_Unit
);
2988 Circularity_Detected
:= True;
2993 Gen_Decl
:= Unit_Declaration_Node
(Gen_Unit
);
2995 -- Initialize renamings map, for error checking, and the list that
2996 -- holds private entities whose views have changed between generic
2997 -- definition and instantiation. If this is the instance created to
2998 -- validate an actual package, the instantiation environment is that
2999 -- of the enclosing instance.
3001 Generic_Renamings
.Set_Last
(0);
3002 Generic_Renamings_HTable
.Reset
;
3004 Create_Instantiation_Source
(N
, Gen_Unit
, False, S_Adjustment
);
3006 -- Copy original generic tree, to produce text for instantiation
3010 (Original_Node
(Gen_Decl
), Empty
, Instantiating
=> True);
3012 Act_Spec
:= Specification
(Act_Tree
);
3014 -- If this is the instance created to validate an actual package,
3015 -- only the formals matter, do not examine the package spec itself.
3017 if Is_Actual_Pack
then
3018 Set_Visible_Declarations
(Act_Spec
, New_List
);
3019 Set_Private_Declarations
(Act_Spec
, New_List
);
3023 Analyze_Associations
3025 Generic_Formal_Declarations
(Act_Tree
),
3026 Generic_Formal_Declarations
(Gen_Decl
));
3028 Set_Instance_Env
(Gen_Unit
, Act_Decl_Id
);
3029 Set_Defining_Unit_Name
(Act_Spec
, Act_Decl_Name
);
3030 Set_Is_Generic_Instance
(Act_Decl_Id
);
3032 Set_Generic_Parent
(Act_Spec
, Gen_Unit
);
3034 -- References to the generic in its own declaration or its body are
3035 -- references to the instance. Add a renaming declaration for the
3036 -- generic unit itself. This declaration, as well as the renaming
3037 -- declarations for the generic formals, must remain private to the
3038 -- unit: the formals, because this is the language semantics, and
3039 -- the unit because its use is an artifact of the implementation.
3042 Make_Package_Renaming_Declaration
(Loc
,
3043 Defining_Unit_Name
=>
3044 Make_Defining_Identifier
(Loc
, Chars
(Gen_Unit
)),
3045 Name
=> New_Reference_To
(Act_Decl_Id
, Loc
));
3047 Append
(Unit_Renaming
, Renaming_List
);
3049 -- The renaming declarations are the first local declarations of
3052 if Is_Non_Empty_List
(Visible_Declarations
(Act_Spec
)) then
3054 (First
(Visible_Declarations
(Act_Spec
)), Renaming_List
);
3056 Set_Visible_Declarations
(Act_Spec
, Renaming_List
);
3060 Make_Package_Declaration
(Loc
,
3061 Specification
=> Act_Spec
);
3063 -- Save the instantiation node, for subsequent instantiation of the
3064 -- body, if there is one and we are generating code for the current
3065 -- unit. Mark the unit as having a body, to avoid a premature error
3068 -- We instantiate the body if we are generating code, if we are
3069 -- generating cross-reference information, or if we are building
3070 -- trees for ASIS use.
3073 Enclosing_Body_Present
: Boolean := False;
3074 -- If the generic unit is not a compilation unit, then a body may
3075 -- be present in its parent even if none is required. We create a
3076 -- tentative pending instantiation for the body, which will be
3077 -- discarded if none is actually present.
3082 if Scope
(Gen_Unit
) /= Standard_Standard
3083 and then not Is_Child_Unit
(Gen_Unit
)
3085 Scop
:= Scope
(Gen_Unit
);
3087 while Present
(Scop
)
3088 and then Scop
/= Standard_Standard
3090 if Unit_Requires_Body
(Scop
) then
3091 Enclosing_Body_Present
:= True;
3094 elsif In_Open_Scopes
(Scop
)
3095 and then In_Package_Body
(Scop
)
3097 Enclosing_Body_Present
:= True;
3101 exit when Is_Compilation_Unit
(Scop
);
3102 Scop
:= Scope
(Scop
);
3106 -- If front-end inlining is enabled, and this is a unit for which
3107 -- code will be generated, we instantiate the body at once.
3109 -- This is done if the instance is not the main unit, and if the
3110 -- generic is not a child unit of another generic, to avoid scope
3111 -- problems and the reinstallation of parent instances.
3114 and then (not Is_Child_Unit
(Gen_Unit
)
3115 or else not Is_Generic_Unit
(Scope
(Gen_Unit
)))
3116 and then Might_Inline_Subp
3117 and then not Is_Actual_Pack
3119 if Front_End_Inlining
3120 and then (Is_In_Main_Unit
(N
)
3121 or else In_Main_Context
(Current_Scope
))
3122 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit
3126 -- In configurable_run_time mode we force the inlining of
3127 -- predefined subprogram marked Inline_Always, to minimize
3128 -- the use of the run-time library.
3130 elsif Is_Predefined_File_Name
3131 (Unit_File_Name
(Get_Source_Unit
(Gen_Decl
)))
3132 and then Configurable_Run_Time_Mode
3133 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit
3138 -- If the current scope is itself an instance within a child
3139 -- unit, there will be duplications in the scope stack, and the
3140 -- unstacking mechanism in Inline_Instance_Body will fail.
3141 -- This loses some rare cases of optimization, and might be
3142 -- improved some day, if we can find a proper abstraction for
3143 -- "the complete compilation context" that can be saved and
3146 if Is_Generic_Instance
(Current_Scope
) then
3148 Curr_Unit
: constant Entity_Id
:=
3149 Cunit_Entity
(Current_Sem_Unit
);
3151 if Curr_Unit
/= Current_Scope
3152 and then Is_Child_Unit
(Curr_Unit
)
3154 Inline_Now
:= False;
3161 (Unit_Requires_Body
(Gen_Unit
)
3162 or else Enclosing_Body_Present
3163 or else Present
(Corresponding_Body
(Gen_Decl
)))
3164 and then (Is_In_Main_Unit
(N
)
3165 or else Might_Inline_Subp
)
3166 and then not Is_Actual_Pack
3167 and then not Inline_Now
3168 and then (Operating_Mode
= Generate_Code
3169 or else (Operating_Mode
= Check_Semantics
3170 and then ASIS_Mode
));
3172 -- If front_end_inlining is enabled, do not instantiate body if
3173 -- within a generic context.
3175 if (Front_End_Inlining
3176 and then not Expander_Active
)
3177 or else Is_Generic_Unit
(Cunit_Entity
(Main_Unit
))
3179 Needs_Body
:= False;
3182 -- If the current context is generic, and the package being
3183 -- instantiated is declared within a formal package, there is no
3184 -- body to instantiate until the enclosing generic is instantiated
3185 -- and there is an actual for the formal package. If the formal
3186 -- package has parameters, we build a regular package instance for
3187 -- it, that preceeds the original formal package declaration.
3189 if In_Open_Scopes
(Scope
(Scope
(Gen_Unit
))) then
3191 Decl
: constant Node_Id
:=
3193 (Unit_Declaration_Node
(Scope
(Gen_Unit
)));
3195 if Nkind
(Decl
) = N_Formal_Package_Declaration
3196 or else (Nkind
(Decl
) = N_Package_Declaration
3197 and then Is_List_Member
(Decl
)
3198 and then Present
(Next
(Decl
))
3200 Nkind
(Next
(Decl
)) = N_Formal_Package_Declaration
)
3202 Needs_Body
:= False;
3208 -- If we are generating the calling stubs from the instantiation of
3209 -- a generic RCI package, we will not use the body of the generic
3212 if Distribution_Stub_Mode
= Generate_Caller_Stub_Body
3213 and then Is_Compilation_Unit
(Defining_Entity
(N
))
3215 Needs_Body
:= False;
3220 -- Here is a defence against a ludicrous number of instantiations
3221 -- caused by a circular set of instantiation attempts.
3223 if Pending_Instantiations
.Last
>
3224 Hostparm
.Max_Instantiations
3226 Error_Msg_N
("too many instantiations", N
);
3227 raise Unrecoverable_Error
;
3230 -- Indicate that the enclosing scopes contain an instantiation,
3231 -- and that cleanup actions should be delayed until after the
3232 -- instance body is expanded.
3234 Check_Forward_Instantiation
(Gen_Decl
);
3235 if Nkind
(N
) = N_Package_Instantiation
then
3237 Enclosing_Master
: Entity_Id
;
3240 -- Loop to search enclosing masters
3242 Enclosing_Master
:= Current_Scope
;
3243 Scope_Loop
: while Enclosing_Master
/= Standard_Standard
loop
3244 if Ekind
(Enclosing_Master
) = E_Package
then
3245 if Is_Compilation_Unit
(Enclosing_Master
) then
3246 if In_Package_Body
(Enclosing_Master
) then
3248 (Body_Entity
(Enclosing_Master
));
3257 Enclosing_Master
:= Scope
(Enclosing_Master
);
3260 elsif Ekind
(Enclosing_Master
) = E_Generic_Package
then
3261 Enclosing_Master
:= Scope
(Enclosing_Master
);
3263 elsif Is_Generic_Subprogram
(Enclosing_Master
)
3264 or else Ekind
(Enclosing_Master
) = E_Void
3266 -- Cleanup actions will eventually be performed on the
3267 -- enclosing instance, if any. Enclosing scope is void
3268 -- in the formal part of a generic subprogram.
3273 if Ekind
(Enclosing_Master
) = E_Entry
3275 Ekind
(Scope
(Enclosing_Master
)) = E_Protected_Type
3277 if not Expander_Active
then
3281 Protected_Body_Subprogram
(Enclosing_Master
);
3285 Set_Delay_Cleanups
(Enclosing_Master
);
3287 while Ekind
(Enclosing_Master
) = E_Block
loop
3288 Enclosing_Master
:= Scope
(Enclosing_Master
);
3291 if Is_Subprogram
(Enclosing_Master
) then
3292 Delay_Descriptors
(Enclosing_Master
);
3294 elsif Is_Task_Type
(Enclosing_Master
) then
3296 TBP
: constant Node_Id
:=
3297 Get_Task_Body_Procedure
3300 if Present
(TBP
) then
3301 Delay_Descriptors
(TBP
);
3302 Set_Delay_Cleanups
(TBP
);
3309 end loop Scope_Loop
;
3312 -- Make entry in table
3314 Pending_Instantiations
.Append
3316 Act_Decl
=> Act_Decl
,
3317 Expander_Status
=> Expander_Active
,
3318 Current_Sem_Unit
=> Current_Sem_Unit
,
3319 Scope_Suppress
=> Scope_Suppress
,
3320 Local_Suppress_Stack_Top
=> Local_Suppress_Stack_Top
));
3324 Set_Categorization_From_Pragmas
(Act_Decl
);
3326 if Parent_Installed
then
3330 Set_Instance_Spec
(N
, Act_Decl
);
3332 -- If not a compilation unit, insert the package declaration before
3333 -- the original instantiation node.
3335 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
3336 Mark_Rewrite_Insertion
(Act_Decl
);
3337 Insert_Before
(N
, Act_Decl
);
3340 -- For an instantiation that is a compilation unit, place declaration
3341 -- on current node so context is complete for analysis (including
3342 -- nested instantiations). If this is the main unit, the declaration
3343 -- eventually replaces the instantiation node. If the instance body
3344 -- is later created, it replaces the instance node, and the declation
3345 -- is attached to it (see Build_Instance_Compilation_Unit_Nodes).
3348 if Cunit_Entity
(Current_Sem_Unit
) = Defining_Entity
(N
) then
3350 -- The entity for the current unit is the newly created one,
3351 -- and all semantic information is attached to it.
3353 Set_Cunit_Entity
(Current_Sem_Unit
, Act_Decl_Id
);
3355 -- If this is the main unit, replace the main entity as well
3357 if Current_Sem_Unit
= Main_Unit
then
3358 Main_Unit_Entity
:= Act_Decl_Id
;
3362 Set_Unit
(Parent
(N
), Act_Decl
);
3363 Set_Parent_Spec
(Act_Decl
, Parent_Spec
(N
));
3364 Set_Package_Instantiation
(Act_Decl_Id
, N
);
3366 Set_Unit
(Parent
(N
), N
);
3367 Set_Body_Required
(Parent
(N
), False);
3369 -- We never need elaboration checks on instantiations, since by
3370 -- definition, the body instantiation is elaborated at the same
3371 -- time as the spec instantiation.
3373 Set_Suppress_Elaboration_Warnings
(Act_Decl_Id
);
3374 Set_Kill_Elaboration_Checks
(Act_Decl_Id
);
3377 Check_Elab_Instantiation
(N
);
3379 if ABE_Is_Certain
(N
) and then Needs_Body
then
3380 Pending_Instantiations
.Decrement_Last
;
3383 Check_Hidden_Child_Unit
(N
, Gen_Unit
, Act_Decl_Id
);
3385 Set_First_Private_Entity
(Defining_Unit_Name
(Unit_Renaming
),
3386 First_Private_Entity
(Act_Decl_Id
));
3388 -- If the instantiation will receive a body, the unit will be
3389 -- transformed into a package body, and receive its own elaboration
3390 -- entity. Otherwise, the nature of the unit is now a package
3393 if Nkind
(Parent
(N
)) = N_Compilation_Unit
3394 and then not Needs_Body
3396 Rewrite
(N
, Act_Decl
);
3399 if Present
(Corresponding_Body
(Gen_Decl
))
3400 or else Unit_Requires_Body
(Gen_Unit
)
3402 Set_Has_Completion
(Act_Decl_Id
);
3405 Check_Formal_Packages
(Act_Decl_Id
);
3407 Restore_Private_Views
(Act_Decl_Id
);
3409 Inherit_Context
(Gen_Decl
, N
);
3411 if Parent_Installed
then
3416 Env_Installed
:= False;
3419 Validate_Categorization_Dependency
(N
, Act_Decl_Id
);
3421 -- Check restriction, but skip this if something went wrong in the above
3422 -- analysis, indicated by Act_Decl_Id being void.
3424 if Ekind
(Act_Decl_Id
) /= E_Void
3425 and then not Is_Library_Level_Entity
(Act_Decl_Id
)
3427 Check_Restriction
(No_Local_Allocators
, N
);
3431 Inline_Instance_Body
(N
, Gen_Unit
, Act_Decl
);
3434 -- The following is a tree patch for ASIS: ASIS needs separate nodes to
3435 -- be used as defining identifiers for a formal package and for the
3436 -- corresponding expanded package.
3438 if Nkind
(N
) = N_Formal_Package_Declaration
then
3439 Act_Decl_Id
:= New_Copy
(Defining_Entity
(N
));
3440 Set_Comes_From_Source
(Act_Decl_Id
, True);
3441 Set_Is_Generic_Instance
(Act_Decl_Id
, False);
3442 Set_Defining_Identifier
(N
, Act_Decl_Id
);
3446 when Instantiation_Error
=>
3447 if Parent_Installed
then
3451 if Env_Installed
then
3454 end Analyze_Package_Instantiation
;
3456 --------------------------
3457 -- Inline_Instance_Body --
3458 --------------------------
3460 procedure Inline_Instance_Body
3462 Gen_Unit
: Entity_Id
;
3466 Gen_Comp
: constant Entity_Id
:=
3467 Cunit_Entity
(Get_Source_Unit
(Gen_Unit
));
3468 Curr_Comp
: constant Node_Id
:= Cunit
(Current_Sem_Unit
);
3469 Curr_Scope
: Entity_Id
:= Empty
;
3470 Curr_Unit
: constant Entity_Id
:=
3471 Cunit_Entity
(Current_Sem_Unit
);
3472 Removed
: Boolean := False;
3473 Num_Scopes
: Int
:= 0;
3475 Scope_Stack_Depth
: constant Int
:=
3476 Scope_Stack
.Last
- Scope_Stack
.First
+ 1;
3478 Use_Clauses
: array (1 .. Scope_Stack_Depth
) of Node_Id
;
3479 Instances
: array (1 .. Scope_Stack_Depth
) of Entity_Id
;
3480 Inner_Scopes
: array (1 .. Scope_Stack_Depth
) of Entity_Id
;
3481 Num_Inner
: Int
:= 0;
3482 N_Instances
: Int
:= 0;
3486 -- Case of generic unit defined in another unit. We must remove the
3487 -- complete context of the current unit to install that of the generic.
3489 if Gen_Comp
/= Cunit_Entity
(Current_Sem_Unit
) then
3491 -- Add some comments for the following two loops ???
3494 while Present
(S
) and then S
/= Standard_Standard
loop
3496 Num_Scopes
:= Num_Scopes
+ 1;
3498 Use_Clauses
(Num_Scopes
) :=
3500 (Scope_Stack
.Last
- Num_Scopes
+ 1).
3502 End_Use_Clauses
(Use_Clauses
(Num_Scopes
));
3504 exit when Scope_Stack
.Last
- Num_Scopes
+ 1 = Scope_Stack
.First
3505 or else Scope_Stack
.Table
3506 (Scope_Stack
.Last
- Num_Scopes
).Entity
3510 exit when Is_Generic_Instance
(S
)
3511 and then (In_Package_Body
(S
)
3512 or else Ekind
(S
) = E_Procedure
3513 or else Ekind
(S
) = E_Function
);
3517 Vis
:= Is_Immediately_Visible
(Gen_Comp
);
3519 -- Find and save all enclosing instances
3524 and then S
/= Standard_Standard
3526 if Is_Generic_Instance
(S
) then
3527 N_Instances
:= N_Instances
+ 1;
3528 Instances
(N_Instances
) := S
;
3530 exit when In_Package_Body
(S
);
3536 -- Remove context of current compilation unit, unless we are within a
3537 -- nested package instantiation, in which case the context has been
3538 -- removed previously.
3540 -- If current scope is the body of a child unit, remove context of
3541 -- spec as well. If an enclosing scope is an instance body. the
3542 -- context has already been removed, but the entities in the body
3543 -- must be made invisible as well.
3548 and then S
/= Standard_Standard
3550 if Is_Generic_Instance
(S
)
3551 and then (In_Package_Body
(S
)
3552 or else Ekind
(S
) = E_Procedure
3553 or else Ekind
(S
) = E_Function
)
3555 -- We still have to remove the entities of the enclosing
3556 -- instance from direct visibility.
3561 E
:= First_Entity
(S
);
3562 while Present
(E
) loop
3563 Set_Is_Immediately_Visible
(E
, False);
3572 or else (Ekind
(Curr_Unit
) = E_Package_Body
3573 and then S
= Spec_Entity
(Curr_Unit
))
3574 or else (Ekind
(Curr_Unit
) = E_Subprogram_Body
3577 (Unit_Declaration_Node
(Curr_Unit
)))
3581 -- Remove entities in current scopes from visibility, so that
3582 -- instance body is compiled in a clean environment.
3584 Save_Scope_Stack
(Handle_Use
=> False);
3586 if Is_Child_Unit
(S
) then
3588 -- Remove child unit from stack, as well as inner scopes.
3589 -- Removing the context of a child unit removes parent units
3592 while Current_Scope
/= S
loop
3593 Num_Inner
:= Num_Inner
+ 1;
3594 Inner_Scopes
(Num_Inner
) := Current_Scope
;
3599 Remove_Context
(Curr_Comp
);
3603 Remove_Context
(Curr_Comp
);
3606 if Ekind
(Curr_Unit
) = E_Package_Body
then
3607 Remove_Context
(Library_Unit
(Curr_Comp
));
3613 pragma Assert
(Num_Inner
< Num_Scopes
);
3615 Push_Scope
(Standard_Standard
);
3616 Scope_Stack
.Table
(Scope_Stack
.Last
).Is_Active_Stack_Base
:= True;
3617 Instantiate_Package_Body
3620 Act_Decl
=> Act_Decl
,
3621 Expander_Status
=> Expander_Active
,
3622 Current_Sem_Unit
=> Current_Sem_Unit
,
3623 Scope_Suppress
=> Scope_Suppress
,
3624 Local_Suppress_Stack_Top
=> Local_Suppress_Stack_Top
)),
3625 Inlined_Body
=> True);
3631 Set_Is_Immediately_Visible
(Gen_Comp
, Vis
);
3633 -- Reset Generic_Instance flag so that use clauses can be installed
3634 -- in the proper order. (See Use_One_Package for effect of enclosing
3635 -- instances on processing of use clauses).
3637 for J
in 1 .. N_Instances
loop
3638 Set_Is_Generic_Instance
(Instances
(J
), False);
3642 Install_Context
(Curr_Comp
);
3644 if Present
(Curr_Scope
)
3645 and then Is_Child_Unit
(Curr_Scope
)
3647 Push_Scope
(Curr_Scope
);
3648 Set_Is_Immediately_Visible
(Curr_Scope
);
3650 -- Finally, restore inner scopes as well
3652 for J
in reverse 1 .. Num_Inner
loop
3653 Push_Scope
(Inner_Scopes
(J
));
3657 Restore_Scope_Stack
(Handle_Use
=> False);
3659 if Present
(Curr_Scope
)
3661 (In_Private_Part
(Curr_Scope
)
3662 or else In_Package_Body
(Curr_Scope
))
3664 -- Install private declaration of ancestor units, which are
3665 -- currently available. Restore_Scope_Stack and Install_Context
3666 -- only install the visible part of parents.
3671 Par
:= Scope
(Curr_Scope
);
3672 while (Present
(Par
))
3673 and then Par
/= Standard_Standard
3675 Install_Private_Declarations
(Par
);
3682 -- Restore use clauses. For a child unit, use clauses in the parents
3683 -- are restored when installing the context, so only those in inner
3684 -- scopes (and those local to the child unit itself) need to be
3685 -- installed explicitly.
3687 if Is_Child_Unit
(Curr_Unit
)
3690 for J
in reverse 1 .. Num_Inner
+ 1 loop
3691 Scope_Stack
.Table
(Scope_Stack
.Last
- J
+ 1).First_Use_Clause
:=
3693 Install_Use_Clauses
(Use_Clauses
(J
));
3697 for J
in reverse 1 .. Num_Scopes
loop
3698 Scope_Stack
.Table
(Scope_Stack
.Last
- J
+ 1).First_Use_Clause
:=
3700 Install_Use_Clauses
(Use_Clauses
(J
));
3704 -- Restore status of instances. If one of them is a body, make
3705 -- its local entities visible again.
3712 for J
in 1 .. N_Instances
loop
3713 Inst
:= Instances
(J
);
3714 Set_Is_Generic_Instance
(Inst
, True);
3716 if In_Package_Body
(Inst
)
3717 or else Ekind
(S
) = E_Procedure
3718 or else Ekind
(S
) = E_Function
3720 E
:= First_Entity
(Instances
(J
));
3721 while Present
(E
) loop
3722 Set_Is_Immediately_Visible
(E
);
3729 -- If generic unit is in current unit, current context is correct
3732 Instantiate_Package_Body
3735 Act_Decl
=> Act_Decl
,
3736 Expander_Status
=> Expander_Active
,
3737 Current_Sem_Unit
=> Current_Sem_Unit
,
3738 Scope_Suppress
=> Scope_Suppress
,
3739 Local_Suppress_Stack_Top
=> Local_Suppress_Stack_Top
)),
3740 Inlined_Body
=> True);
3742 end Inline_Instance_Body
;
3744 -------------------------------------
3745 -- Analyze_Procedure_Instantiation --
3746 -------------------------------------
3748 procedure Analyze_Procedure_Instantiation
(N
: Node_Id
) is
3750 Analyze_Subprogram_Instantiation
(N
, E_Procedure
);
3751 end Analyze_Procedure_Instantiation
;
3753 --------------------------------------
3754 -- Analyze_Subprogram_Instantiation --
3755 --------------------------------------
3757 procedure Analyze_Subprogram_Instantiation
3761 Loc
: constant Source_Ptr
:= Sloc
(N
);
3762 Gen_Id
: constant Node_Id
:= Name
(N
);
3764 Anon_Id
: constant Entity_Id
:=
3765 Make_Defining_Identifier
(Sloc
(Defining_Entity
(N
)),
3766 Chars
=> New_External_Name
3767 (Chars
(Defining_Entity
(N
)), 'R'));
3769 Act_Decl_Id
: Entity_Id
;
3774 Env_Installed
: Boolean := False;
3775 Gen_Unit
: Entity_Id
;
3777 Pack_Id
: Entity_Id
;
3778 Parent_Installed
: Boolean := False;
3779 Renaming_List
: List_Id
;
3781 procedure Analyze_Instance_And_Renamings
;
3782 -- The instance must be analyzed in a context that includes the mappings
3783 -- of generic parameters into actuals. We create a package declaration
3784 -- for this purpose, and a subprogram with an internal name within the
3785 -- package. The subprogram instance is simply an alias for the internal
3786 -- subprogram, declared in the current scope.
3788 ------------------------------------
3789 -- Analyze_Instance_And_Renamings --
3790 ------------------------------------
3792 procedure Analyze_Instance_And_Renamings
is
3793 Def_Ent
: constant Entity_Id
:= Defining_Entity
(N
);
3794 Pack_Decl
: Node_Id
;
3797 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
3799 -- For the case of a compilation unit, the container package has
3800 -- the same name as the instantiation, to insure that the binder
3801 -- calls the elaboration procedure with the right name. Copy the
3802 -- entity of the instance, which may have compilation level flags
3803 -- (e.g. Is_Child_Unit) set.
3805 Pack_Id
:= New_Copy
(Def_Ent
);
3808 -- Otherwise we use the name of the instantiation concatenated
3809 -- with its source position to ensure uniqueness if there are
3810 -- several instantiations with the same name.
3813 Make_Defining_Identifier
(Loc
,
3814 Chars
=> New_External_Name
3815 (Related_Id
=> Chars
(Def_Ent
),
3817 Suffix_Index
=> Source_Offset
(Sloc
(Def_Ent
))));
3820 Pack_Decl
:= Make_Package_Declaration
(Loc
,
3821 Specification
=> Make_Package_Specification
(Loc
,
3822 Defining_Unit_Name
=> Pack_Id
,
3823 Visible_Declarations
=> Renaming_List
,
3824 End_Label
=> Empty
));
3826 Set_Instance_Spec
(N
, Pack_Decl
);
3827 Set_Is_Generic_Instance
(Pack_Id
);
3828 Set_Needs_Debug_Info
(Pack_Id
);
3830 -- Case of not a compilation unit
3832 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
3833 Mark_Rewrite_Insertion
(Pack_Decl
);
3834 Insert_Before
(N
, Pack_Decl
);
3835 Set_Has_Completion
(Pack_Id
);
3837 -- Case of an instantiation that is a compilation unit
3839 -- Place declaration on current node so context is complete for
3840 -- analysis (including nested instantiations), and for use in a
3841 -- context_clause (see Analyze_With_Clause).
3844 Set_Unit
(Parent
(N
), Pack_Decl
);
3845 Set_Parent_Spec
(Pack_Decl
, Parent_Spec
(N
));
3848 Analyze
(Pack_Decl
);
3849 Check_Formal_Packages
(Pack_Id
);
3850 Set_Is_Generic_Instance
(Pack_Id
, False);
3852 -- Body of the enclosing package is supplied when instantiating the
3853 -- subprogram body, after semantic analysis is completed.
3855 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
3857 -- Remove package itself from visibility, so it does not
3858 -- conflict with subprogram.
3860 Set_Name_Entity_Id
(Chars
(Pack_Id
), Homonym
(Pack_Id
));
3862 -- Set name and scope of internal subprogram so that the proper
3863 -- external name will be generated. The proper scope is the scope
3864 -- of the wrapper package. We need to generate debugging info for
3865 -- the internal subprogram, so set flag accordingly.
3867 Set_Chars
(Anon_Id
, Chars
(Defining_Entity
(N
)));
3868 Set_Scope
(Anon_Id
, Scope
(Pack_Id
));
3870 -- Mark wrapper package as referenced, to avoid spurious warnings
3871 -- if the instantiation appears in various with_ clauses of
3872 -- subunits of the main unit.
3874 Set_Referenced
(Pack_Id
);
3877 Set_Is_Generic_Instance
(Anon_Id
);
3878 Set_Needs_Debug_Info
(Anon_Id
);
3879 Act_Decl_Id
:= New_Copy
(Anon_Id
);
3881 Set_Parent
(Act_Decl_Id
, Parent
(Anon_Id
));
3882 Set_Chars
(Act_Decl_Id
, Chars
(Defining_Entity
(N
)));
3883 Set_Sloc
(Act_Decl_Id
, Sloc
(Defining_Entity
(N
)));
3884 Set_Comes_From_Source
(Act_Decl_Id
, True);
3886 -- The signature may involve types that are not frozen yet, but the
3887 -- subprogram will be frozen at the point the wrapper package is
3888 -- frozen, so it does not need its own freeze node. In fact, if one
3889 -- is created, it might conflict with the freezing actions from the
3890 -- wrapper package (see 7206-013).
3892 -- Should not really reference non-public TN's in comments ???
3894 Set_Has_Delayed_Freeze
(Anon_Id
, False);
3896 -- If the instance is a child unit, mark the Id accordingly. Mark
3897 -- the anonymous entity as well, which is the real subprogram and
3898 -- which is used when the instance appears in a context clause.
3900 Set_Is_Child_Unit
(Act_Decl_Id
, Is_Child_Unit
(Defining_Entity
(N
)));
3901 Set_Is_Child_Unit
(Anon_Id
, Is_Child_Unit
(Defining_Entity
(N
)));
3902 New_Overloaded_Entity
(Act_Decl_Id
);
3903 Check_Eliminated
(Act_Decl_Id
);
3905 -- In compilation unit case, kill elaboration checks on the
3906 -- instantiation, since they are never needed -- the body is
3907 -- instantiated at the same point as the spec.
3909 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
3910 Set_Suppress_Elaboration_Warnings
(Act_Decl_Id
);
3911 Set_Kill_Elaboration_Checks
(Act_Decl_Id
);
3912 Set_Is_Compilation_Unit
(Anon_Id
);
3914 Set_Cunit_Entity
(Current_Sem_Unit
, Pack_Id
);
3917 -- The instance is not a freezing point for the new subprogram
3919 Set_Is_Frozen
(Act_Decl_Id
, False);
3921 if Nkind
(Defining_Entity
(N
)) = N_Defining_Operator_Symbol
then
3922 Valid_Operator_Definition
(Act_Decl_Id
);
3925 Set_Alias
(Act_Decl_Id
, Anon_Id
);
3926 Set_Parent
(Act_Decl_Id
, Parent
(Anon_Id
));
3927 Set_Has_Completion
(Act_Decl_Id
);
3928 Set_Related_Instance
(Pack_Id
, Act_Decl_Id
);
3930 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
3931 Set_Body_Required
(Parent
(N
), False);
3933 end Analyze_Instance_And_Renamings
;
3935 -- Start of processing for Analyze_Subprogram_Instantiation
3938 -- Very first thing: apply the special kludge for Text_IO processing
3939 -- in case we are instantiating one of the children of [Wide_]Text_IO.
3940 -- Of course such an instantiation is bogus (these are packages, not
3941 -- subprograms), but we get a better error message if we do this.
3943 Text_IO_Kludge
(Gen_Id
);
3945 -- Make node global for error reporting
3947 Instantiation_Node
:= N
;
3948 Pre_Analyze_Actuals
(N
);
3951 Env_Installed
:= True;
3952 Check_Generic_Child_Unit
(Gen_Id
, Parent_Installed
);
3953 Gen_Unit
:= Entity
(Gen_Id
);
3955 Generate_Reference
(Gen_Unit
, Gen_Id
);
3957 if Nkind
(Gen_Id
) = N_Identifier
3958 and then Chars
(Gen_Unit
) = Chars
(Defining_Entity
(N
))
3961 ("& is hidden within declaration of instance", Gen_Id
, Gen_Unit
);
3964 if Etype
(Gen_Unit
) = Any_Type
then
3969 -- Verify that it is a generic subprogram of the right kind, and that
3970 -- it does not lead to a circular instantiation.
3972 if Ekind
(Gen_Unit
) /= E_Generic_Procedure
3973 and then Ekind
(Gen_Unit
) /= E_Generic_Function
3975 Error_Msg_N
("expect generic subprogram in instantiation", Gen_Id
);
3977 elsif In_Open_Scopes
(Gen_Unit
) then
3978 Error_Msg_NE
("instantiation of & within itself", N
, Gen_Unit
);
3980 elsif K
= E_Procedure
3981 and then Ekind
(Gen_Unit
) /= E_Generic_Procedure
3983 if Ekind
(Gen_Unit
) = E_Generic_Function
then
3985 ("cannot instantiate generic function as procedure", Gen_Id
);
3988 ("expect name of generic procedure in instantiation", Gen_Id
);
3991 elsif K
= E_Function
3992 and then Ekind
(Gen_Unit
) /= E_Generic_Function
3994 if Ekind
(Gen_Unit
) = E_Generic_Procedure
then
3996 ("cannot instantiate generic procedure as function", Gen_Id
);
3999 ("expect name of generic function in instantiation", Gen_Id
);
4003 Set_Entity
(Gen_Id
, Gen_Unit
);
4004 Set_Is_Instantiated
(Gen_Unit
);
4006 if In_Extended_Main_Source_Unit
(N
) then
4007 Generate_Reference
(Gen_Unit
, N
);
4010 -- If renaming, get original unit
4012 if Present
(Renamed_Object
(Gen_Unit
))
4013 and then (Ekind
(Renamed_Object
(Gen_Unit
)) = E_Generic_Procedure
4015 Ekind
(Renamed_Object
(Gen_Unit
)) = E_Generic_Function
)
4017 Gen_Unit
:= Renamed_Object
(Gen_Unit
);
4018 Set_Is_Instantiated
(Gen_Unit
);
4019 Generate_Reference
(Gen_Unit
, N
);
4022 if Contains_Instance_Of
(Gen_Unit
, Current_Scope
, Gen_Id
) then
4023 Error_Msg_Node_2
:= Current_Scope
;
4025 ("circular Instantiation: & instantiated in &!", N
, Gen_Unit
);
4026 Circularity_Detected
:= True;
4030 Gen_Decl
:= Unit_Declaration_Node
(Gen_Unit
);
4032 -- Initialize renamings map, for error checking
4034 Generic_Renamings
.Set_Last
(0);
4035 Generic_Renamings_HTable
.Reset
;
4037 Create_Instantiation_Source
(N
, Gen_Unit
, False, S_Adjustment
);
4039 -- Copy original generic tree, to produce text for instantiation
4043 (Original_Node
(Gen_Decl
), Empty
, Instantiating
=> True);
4045 Act_Spec
:= Specification
(Act_Tree
);
4047 Analyze_Associations
4049 Generic_Formal_Declarations
(Act_Tree
),
4050 Generic_Formal_Declarations
(Gen_Decl
));
4052 -- The subprogram itself cannot contain a nested instance, so the
4053 -- current parent is left empty.
4055 Set_Instance_Env
(Gen_Unit
, Empty
);
4057 -- Build the subprogram declaration, which does not appear in the
4058 -- generic template, and give it a sloc consistent with that of the
4061 Set_Defining_Unit_Name
(Act_Spec
, Anon_Id
);
4062 Set_Generic_Parent
(Act_Spec
, Gen_Unit
);
4064 Make_Subprogram_Declaration
(Sloc
(Act_Spec
),
4065 Specification
=> Act_Spec
);
4067 Set_Categorization_From_Pragmas
(Act_Decl
);
4069 if Parent_Installed
then
4073 Append
(Act_Decl
, Renaming_List
);
4074 Analyze_Instance_And_Renamings
;
4076 -- If the generic is marked Import (Intrinsic), then so is the
4077 -- instance. This indicates that there is no body to instantiate. If
4078 -- generic is marked inline, so it the instance, and the anonymous
4079 -- subprogram it renames. If inlined, or else if inlining is enabled
4080 -- for the compilation, we generate the instance body even if it is
4081 -- not within the main unit.
4083 -- Any other pragmas might also be inherited ???
4085 if Is_Intrinsic_Subprogram
(Gen_Unit
) then
4086 Set_Is_Intrinsic_Subprogram
(Anon_Id
);
4087 Set_Is_Intrinsic_Subprogram
(Act_Decl_Id
);
4089 if Chars
(Gen_Unit
) = Name_Unchecked_Conversion
then
4090 Validate_Unchecked_Conversion
(N
, Act_Decl_Id
);
4094 Generate_Definition
(Act_Decl_Id
);
4096 Set_Is_Inlined
(Act_Decl_Id
, Is_Inlined
(Gen_Unit
));
4097 Set_Is_Inlined
(Anon_Id
, Is_Inlined
(Gen_Unit
));
4099 if not Is_Intrinsic_Subprogram
(Gen_Unit
) then
4100 Check_Elab_Instantiation
(N
);
4103 if Is_Dispatching_Operation
(Act_Decl_Id
)
4104 and then Ada_Version
>= Ada_05
4110 Formal
:= First_Formal
(Act_Decl_Id
);
4111 while Present
(Formal
) loop
4112 if Ekind
(Etype
(Formal
)) = E_Anonymous_Access_Type
4113 and then Is_Controlling_Formal
(Formal
)
4114 and then not Can_Never_Be_Null
(Formal
)
4116 Error_Msg_NE
("access parameter& is controlling,",
4118 Error_Msg_NE
("\corresponding parameter of & must be"
4119 & " explicitly null-excluding", N
, Gen_Id
);
4122 Next_Formal
(Formal
);
4127 Check_Hidden_Child_Unit
(N
, Gen_Unit
, Act_Decl_Id
);
4129 -- Subject to change, pending on if other pragmas are inherited ???
4131 Validate_Categorization_Dependency
(N
, Act_Decl_Id
);
4133 if not Is_Intrinsic_Subprogram
(Act_Decl_Id
) then
4134 Inherit_Context
(Gen_Decl
, N
);
4136 Restore_Private_Views
(Pack_Id
, False);
4138 -- If the context requires a full instantiation, mark node for
4139 -- subsequent construction of the body.
4141 if (Is_In_Main_Unit
(N
)
4142 or else Is_Inlined
(Act_Decl_Id
))
4143 and then (Operating_Mode
= Generate_Code
4144 or else (Operating_Mode
= Check_Semantics
4145 and then ASIS_Mode
))
4146 and then (Expander_Active
or else ASIS_Mode
)
4147 and then not ABE_Is_Certain
(N
)
4148 and then not Is_Eliminated
(Act_Decl_Id
)
4150 Pending_Instantiations
.Append
4152 Act_Decl
=> Act_Decl
,
4153 Expander_Status
=> Expander_Active
,
4154 Current_Sem_Unit
=> Current_Sem_Unit
,
4155 Scope_Suppress
=> Scope_Suppress
,
4156 Local_Suppress_Stack_Top
=> Local_Suppress_Stack_Top
));
4158 Check_Forward_Instantiation
(Gen_Decl
);
4160 -- The wrapper package is always delayed, because it does not
4161 -- constitute a freeze point, but to insure that the freeze
4162 -- node is placed properly, it is created directly when
4163 -- instantiating the body (otherwise the freeze node might
4164 -- appear to early for nested instantiations).
4166 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
then
4168 -- For ASIS purposes, indicate that the wrapper package has
4169 -- replaced the instantiation node.
4171 Rewrite
(N
, Unit
(Parent
(N
)));
4172 Set_Unit
(Parent
(N
), N
);
4175 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
then
4177 -- Replace instance node for library-level instantiations of
4178 -- intrinsic subprograms, for ASIS use.
4180 Rewrite
(N
, Unit
(Parent
(N
)));
4181 Set_Unit
(Parent
(N
), N
);
4184 if Parent_Installed
then
4189 Env_Installed
:= False;
4190 Generic_Renamings
.Set_Last
(0);
4191 Generic_Renamings_HTable
.Reset
;
4195 when Instantiation_Error
=>
4196 if Parent_Installed
then
4200 if Env_Installed
then
4203 end Analyze_Subprogram_Instantiation
;
4205 -------------------------
4206 -- Get_Associated_Node --
4207 -------------------------
4209 function Get_Associated_Node
(N
: Node_Id
) return Node_Id
is
4210 Assoc
: Node_Id
:= Associated_Node
(N
);
4213 if Nkind
(Assoc
) /= Nkind
(N
) then
4216 elsif Nkind
(Assoc
) = N_Aggregate
4217 or else Nkind
(Assoc
) = N_Extension_Aggregate
4222 -- If the node is part of an inner generic, it may itself have been
4223 -- remapped into a further generic copy. Associated_Node is otherwise
4224 -- used for the entity of the node, and will be of a different node
4225 -- kind, or else N has been rewritten as a literal or function call.
4227 while Present
(Associated_Node
(Assoc
))
4228 and then Nkind
(Associated_Node
(Assoc
)) = Nkind
(Assoc
)
4230 Assoc
:= Associated_Node
(Assoc
);
4233 -- Follow and additional link in case the final node was rewritten.
4234 -- This can only happen with nested generic units.
4236 if (Nkind
(Assoc
) = N_Identifier
or else Nkind
(Assoc
) in N_Op
)
4237 and then Present
(Associated_Node
(Assoc
))
4238 and then (Nkind
(Associated_Node
(Assoc
)) = N_Function_Call
4240 Nkind
(Associated_Node
(Assoc
)) = N_Explicit_Dereference
4242 Nkind
(Associated_Node
(Assoc
)) = N_Integer_Literal
4244 Nkind
(Associated_Node
(Assoc
)) = N_Real_Literal
4246 Nkind
(Associated_Node
(Assoc
)) = N_String_Literal
)
4248 Assoc
:= Associated_Node
(Assoc
);
4253 end Get_Associated_Node
;
4255 -------------------------------------------
4256 -- Build_Instance_Compilation_Unit_Nodes --
4257 -------------------------------------------
4259 procedure Build_Instance_Compilation_Unit_Nodes
4264 Decl_Cunit
: Node_Id
;
4265 Body_Cunit
: Node_Id
;
4267 New_Main
: constant Entity_Id
:= Defining_Entity
(Act_Decl
);
4268 Old_Main
: constant Entity_Id
:= Cunit_Entity
(Main_Unit
);
4271 -- A new compilation unit node is built for the instance declaration
4274 Make_Compilation_Unit
(Sloc
(N
),
4275 Context_Items
=> Empty_List
,
4278 Make_Compilation_Unit_Aux
(Sloc
(N
)));
4280 Set_Parent_Spec
(Act_Decl
, Parent_Spec
(N
));
4281 Set_Body_Required
(Decl_Cunit
, True);
4283 -- We use the original instantiation compilation unit as the resulting
4284 -- compilation unit of the instance, since this is the main unit.
4286 Rewrite
(N
, Act_Body
);
4287 Body_Cunit
:= Parent
(N
);
4289 -- The two compilation unit nodes are linked by the Library_Unit field
4291 Set_Library_Unit
(Decl_Cunit
, Body_Cunit
);
4292 Set_Library_Unit
(Body_Cunit
, Decl_Cunit
);
4294 -- Preserve the private nature of the package if needed
4296 Set_Private_Present
(Decl_Cunit
, Private_Present
(Body_Cunit
));
4298 -- If the instance is not the main unit, its context, categorization,
4299 -- and elaboration entity are not relevant to the compilation.
4301 if Parent
(N
) /= Cunit
(Main_Unit
) then
4305 -- The context clause items on the instantiation, which are now attached
4306 -- to the body compilation unit (since the body overwrote the original
4307 -- instantiation node), semantically belong on the spec, so copy them
4308 -- there. It's harmless to leave them on the body as well. In fact one
4309 -- could argue that they belong in both places.
4311 Citem
:= First
(Context_Items
(Body_Cunit
));
4312 while Present
(Citem
) loop
4313 Append
(New_Copy
(Citem
), Context_Items
(Decl_Cunit
));
4317 -- Propagate categorization flags on packages, so that they appear in
4318 -- the ali file for the spec of the unit.
4320 if Ekind
(New_Main
) = E_Package
then
4321 Set_Is_Pure
(Old_Main
, Is_Pure
(New_Main
));
4322 Set_Is_Preelaborated
(Old_Main
, Is_Preelaborated
(New_Main
));
4323 Set_Is_Remote_Types
(Old_Main
, Is_Remote_Types
(New_Main
));
4324 Set_Is_Shared_Passive
(Old_Main
, Is_Shared_Passive
(New_Main
));
4325 Set_Is_Remote_Call_Interface
4326 (Old_Main
, Is_Remote_Call_Interface
(New_Main
));
4329 -- Make entry in Units table, so that binder can generate call to
4330 -- elaboration procedure for body, if any.
4332 Make_Instance_Unit
(Body_Cunit
);
4333 Main_Unit_Entity
:= New_Main
;
4334 Set_Cunit_Entity
(Main_Unit
, Main_Unit_Entity
);
4336 -- Build elaboration entity, since the instance may certainly generate
4337 -- elaboration code requiring a flag for protection.
4339 Build_Elaboration_Entity
(Decl_Cunit
, New_Main
);
4340 end Build_Instance_Compilation_Unit_Nodes
;
4342 -----------------------------
4343 -- Check_Access_Definition --
4344 -----------------------------
4346 procedure Check_Access_Definition
(N
: Node_Id
) is
4349 (Ada_Version
>= Ada_05
4350 and then Present
(Access_Definition
(N
)));
4352 end Check_Access_Definition
;
4354 -----------------------------------
4355 -- Check_Formal_Package_Instance --
4356 -----------------------------------
4358 -- If the formal has specific parameters, they must match those of the
4359 -- actual. Both of them are instances, and the renaming declarations for
4360 -- their formal parameters appear in the same order in both. The analyzed
4361 -- formal has been analyzed in the context of the current instance.
4363 procedure Check_Formal_Package_Instance
4364 (Formal_Pack
: Entity_Id
;
4365 Actual_Pack
: Entity_Id
)
4367 E1
: Entity_Id
:= First_Entity
(Actual_Pack
);
4368 E2
: Entity_Id
:= First_Entity
(Formal_Pack
);
4373 procedure Check_Mismatch
(B
: Boolean);
4374 -- Common error routine for mismatch between the parameters of the
4375 -- actual instance and those of the formal package.
4377 function Same_Instantiated_Constant
(E1
, E2
: Entity_Id
) return Boolean;
4378 -- The formal may come from a nested formal package, and the actual may
4379 -- have been constant-folded. To determine whether the two denote the
4380 -- same entity we may have to traverse several definitions to recover
4381 -- the ultimate entity that they refer to.
4383 function Same_Instantiated_Variable
(E1
, E2
: Entity_Id
) return Boolean;
4384 -- Similarly, if the formal comes from a nested formal package, the
4385 -- actual may designate the formal through multiple renamings, which
4386 -- have to be followed to determine the original variable in question.
4388 --------------------
4389 -- Check_Mismatch --
4390 --------------------
4392 procedure Check_Mismatch
(B
: Boolean) is
4393 Kind
: constant Node_Kind
:= Nkind
(Parent
(E2
));
4396 if Kind
= N_Formal_Type_Declaration
then
4399 elsif Kind
= N_Formal_Object_Declaration
4400 or else Kind
in N_Formal_Subprogram_Declaration
4401 or else Kind
= N_Formal_Package_Declaration
4407 ("actual for & in actual instance does not match formal",
4408 Parent
(Actual_Pack
), E1
);
4412 --------------------------------
4413 -- Same_Instantiated_Constant --
4414 --------------------------------
4416 function Same_Instantiated_Constant
4417 (E1
, E2
: Entity_Id
) return Boolean
4423 while Present
(Ent
) loop
4427 elsif Ekind
(Ent
) /= E_Constant
then
4430 elsif Is_Entity_Name
(Constant_Value
(Ent
)) then
4431 if Entity
(Constant_Value
(Ent
)) = E1
then
4434 Ent
:= Entity
(Constant_Value
(Ent
));
4437 -- The actual may be a constant that has been folded. Recover
4440 elsif Is_Entity_Name
(Original_Node
(Constant_Value
(Ent
))) then
4441 Ent
:= Entity
(Original_Node
(Constant_Value
(Ent
)));
4448 end Same_Instantiated_Constant
;
4450 --------------------------------
4451 -- Same_Instantiated_Variable --
4452 --------------------------------
4454 function Same_Instantiated_Variable
4455 (E1
, E2
: Entity_Id
) return Boolean
4457 function Original_Entity
(E
: Entity_Id
) return Entity_Id
;
4458 -- Follow chain of renamings to the ultimate ancestor
4460 ---------------------
4461 -- Original_Entity --
4462 ---------------------
4464 function Original_Entity
(E
: Entity_Id
) return Entity_Id
is
4469 while Nkind
(Parent
(Orig
)) = N_Object_Renaming_Declaration
4470 and then Present
(Renamed_Object
(Orig
))
4471 and then Is_Entity_Name
(Renamed_Object
(Orig
))
4473 Orig
:= Entity
(Renamed_Object
(Orig
));
4477 end Original_Entity
;
4479 -- Start of processing for Same_Instantiated_Variable
4482 return Ekind
(E1
) = Ekind
(E2
)
4483 and then Original_Entity
(E1
) = Original_Entity
(E2
);
4484 end Same_Instantiated_Variable
;
4486 -- Start of processing for Check_Formal_Package_Instance
4490 and then Present
(E2
)
4492 exit when Ekind
(E1
) = E_Package
4493 and then Renamed_Entity
(E1
) = Renamed_Entity
(Actual_Pack
);
4495 -- If the formal is the renaming of the formal package, this
4496 -- is the end of its formal part, which may occur before the
4497 -- end of the formal part in the actual in the presence of
4498 -- defaulted parameters in the formal package.
4500 exit when Nkind
(Parent
(E2
)) = N_Package_Renaming_Declaration
4501 and then Renamed_Entity
(E2
) = Scope
(E2
);
4503 -- The analysis of the actual may generate additional internal
4504 -- entities. If the formal is defaulted, there is no corresponding
4505 -- analysis and the internal entities must be skipped, until we
4506 -- find corresponding entities again.
4508 if Comes_From_Source
(E2
)
4509 and then not Comes_From_Source
(E1
)
4510 and then Chars
(E1
) /= Chars
(E2
)
4513 and then Chars
(E1
) /= Chars
(E2
)
4522 -- If the formal entity comes from a formal declaration. it was
4523 -- defaulted in the formal package, and no check is needed on it.
4525 elsif Nkind
(Parent
(E2
)) = N_Formal_Object_Declaration
then
4528 elsif Is_Type
(E1
) then
4530 -- Subtypes must statically match. E1, E2 are the local entities
4531 -- that are subtypes of the actuals. Itypes generated for other
4532 -- parameters need not be checked, the check will be performed
4533 -- on the parameters themselves.
4535 -- If E2 is a formal type declaration, it is a defaulted parameter
4536 -- and needs no checking.
4538 if not Is_Itype
(E1
)
4539 and then not Is_Itype
(E2
)
4543 or else Etype
(E1
) /= Etype
(E2
)
4544 or else not Subtypes_Statically_Match
(E1
, E2
));
4547 elsif Ekind
(E1
) = E_Constant
then
4549 -- IN parameters must denote the same static value, or the same
4550 -- constant, or the literal null.
4552 Expr1
:= Expression
(Parent
(E1
));
4554 if Ekind
(E2
) /= E_Constant
then
4555 Check_Mismatch
(True);
4558 Expr2
:= Expression
(Parent
(E2
));
4561 if Is_Static_Expression
(Expr1
) then
4563 if not Is_Static_Expression
(Expr2
) then
4564 Check_Mismatch
(True);
4566 elsif Is_Discrete_Type
(Etype
(E1
)) then
4568 V1
: constant Uint
:= Expr_Value
(Expr1
);
4569 V2
: constant Uint
:= Expr_Value
(Expr2
);
4571 Check_Mismatch
(V1
/= V2
);
4574 elsif Is_Real_Type
(Etype
(E1
)) then
4576 V1
: constant Ureal
:= Expr_Value_R
(Expr1
);
4577 V2
: constant Ureal
:= Expr_Value_R
(Expr2
);
4579 Check_Mismatch
(V1
/= V2
);
4582 elsif Is_String_Type
(Etype
(E1
))
4583 and then Nkind
(Expr1
) = N_String_Literal
4585 if Nkind
(Expr2
) /= N_String_Literal
then
4586 Check_Mismatch
(True);
4589 (not String_Equal
(Strval
(Expr1
), Strval
(Expr2
)));
4593 elsif Is_Entity_Name
(Expr1
) then
4594 if Is_Entity_Name
(Expr2
) then
4595 if Entity
(Expr1
) = Entity
(Expr2
) then
4599 (not Same_Instantiated_Constant
4600 (Entity
(Expr1
), Entity
(Expr2
)));
4603 Check_Mismatch
(True);
4606 elsif Is_Entity_Name
(Original_Node
(Expr1
))
4607 and then Is_Entity_Name
(Expr2
)
4609 Same_Instantiated_Constant
4610 (Entity
(Original_Node
(Expr1
)), Entity
(Expr2
))
4614 elsif Nkind
(Expr1
) = N_Null
then
4615 Check_Mismatch
(Nkind
(Expr1
) /= N_Null
);
4618 Check_Mismatch
(True);
4621 elsif Ekind
(E1
) = E_Variable
then
4622 Check_Mismatch
(not Same_Instantiated_Variable
(E1
, E2
));
4624 elsif Ekind
(E1
) = E_Package
then
4626 (Ekind
(E1
) /= Ekind
(E2
)
4627 or else Renamed_Object
(E1
) /= Renamed_Object
(E2
));
4629 elsif Is_Overloadable
(E1
) then
4631 -- Verify that the names of the entities match. Note that actuals
4632 -- that are attributes are rewritten as subprograms.
4635 (Ekind
(E2
) /= Ekind
(E1
) or else (Alias
(E1
)) /= Alias
(E2
));
4638 raise Program_Error
;
4645 end Check_Formal_Package_Instance
;
4647 ---------------------------
4648 -- Check_Formal_Packages --
4649 ---------------------------
4651 procedure Check_Formal_Packages
(P_Id
: Entity_Id
) is
4653 Formal_P
: Entity_Id
;
4656 -- Iterate through the declarations in the instance, looking for package
4657 -- renaming declarations that denote instances of formal packages. Stop
4658 -- when we find the renaming of the current package itself. The
4659 -- declaration for a formal package without a box is followed by an
4660 -- internal entity that repeats the instantiation.
4662 E
:= First_Entity
(P_Id
);
4663 while Present
(E
) loop
4664 if Ekind
(E
) = E_Package
then
4665 if Renamed_Object
(E
) = P_Id
then
4668 elsif Nkind
(Parent
(E
)) /= N_Package_Renaming_Declaration
then
4671 elsif not Box_Present
(Parent
(Associated_Formal_Package
(E
))) then
4672 Formal_P
:= Next_Entity
(E
);
4673 Check_Formal_Package_Instance
(Formal_P
, E
);
4675 -- After checking, remove the internal validating package. It
4676 -- is only needed for semantic checks, and as it may contain
4677 -- generic formal declarations it should not reach gigi.
4679 Remove
(Unit_Declaration_Node
(Formal_P
));
4685 end Check_Formal_Packages
;
4687 ---------------------------------
4688 -- Check_Forward_Instantiation --
4689 ---------------------------------
4691 procedure Check_Forward_Instantiation
(Decl
: Node_Id
) is
4693 Gen_Comp
: Entity_Id
:= Cunit_Entity
(Get_Source_Unit
(Decl
));
4696 -- The instantiation appears before the generic body if we are in the
4697 -- scope of the unit containing the generic, either in its spec or in
4698 -- the package body. and before the generic body.
4700 if Ekind
(Gen_Comp
) = E_Package_Body
then
4701 Gen_Comp
:= Spec_Entity
(Gen_Comp
);
4704 if In_Open_Scopes
(Gen_Comp
)
4705 and then No
(Corresponding_Body
(Decl
))
4710 and then not Is_Compilation_Unit
(S
)
4711 and then not Is_Child_Unit
(S
)
4713 if Ekind
(S
) = E_Package
then
4714 Set_Has_Forward_Instantiation
(S
);
4720 end Check_Forward_Instantiation
;
4722 ---------------------------
4723 -- Check_Generic_Actuals --
4724 ---------------------------
4726 -- The visibility of the actuals may be different between the point of
4727 -- generic instantiation and the instantiation of the body.
4729 procedure Check_Generic_Actuals
4730 (Instance
: Entity_Id
;
4731 Is_Formal_Box
: Boolean)
4736 function Denotes_Previous_Actual
(Typ
: Entity_Id
) return Boolean;
4737 -- For a formal that is an array type, the component type is often a
4738 -- previous formal in the same unit. The privacy status of the component
4739 -- type will have been examined earlier in the traversal of the
4740 -- corresponding actuals, and this status should not be modified for the
4741 -- array type itself.
4743 -- To detect this case we have to rescan the list of formals, which
4744 -- is usually short enough to ignore the resulting inefficiency.
4746 function Denotes_Previous_Actual
(Typ
: Entity_Id
) return Boolean is
4749 Prev
:= First_Entity
(Instance
);
4750 while Present
(Prev
) loop
4752 and then Nkind
(Parent
(Prev
)) = N_Subtype_Declaration
4753 and then Is_Entity_Name
(Subtype_Indication
(Parent
(Prev
)))
4754 and then Entity
(Subtype_Indication
(Parent
(Prev
))) = Typ
4764 end Denotes_Previous_Actual
;
4766 -- Start of processing for Check_Generic_Actuals
4769 E
:= First_Entity
(Instance
);
4770 while Present
(E
) loop
4772 and then Nkind
(Parent
(E
)) = N_Subtype_Declaration
4773 and then Scope
(Etype
(E
)) /= Instance
4774 and then Is_Entity_Name
(Subtype_Indication
(Parent
(E
)))
4776 if Is_Array_Type
(E
)
4777 and then Denotes_Previous_Actual
(Component_Type
(E
))
4781 Check_Private_View
(Subtype_Indication
(Parent
(E
)));
4783 Set_Is_Generic_Actual_Type
(E
, True);
4784 Set_Is_Hidden
(E
, False);
4785 Set_Is_Potentially_Use_Visible
(E
,
4788 -- We constructed the generic actual type as a subtype of the
4789 -- supplied type. This means that it normally would not inherit
4790 -- subtype specific attributes of the actual, which is wrong for
4791 -- the generic case.
4793 Astype
:= Ancestor_Subtype
(E
);
4797 -- This can happen when E is an itype that is the full view of
4798 -- a private type completed, e.g. with a constrained array. In
4799 -- that case, use the first subtype, which will carry size
4800 -- information. The base type itself is unconstrained and will
4803 Astype
:= First_Subtype
(E
);
4806 Set_Size_Info
(E
, (Astype
));
4807 Set_RM_Size
(E
, RM_Size
(Astype
));
4808 Set_First_Rep_Item
(E
, First_Rep_Item
(Astype
));
4810 if Is_Discrete_Or_Fixed_Point_Type
(E
) then
4811 Set_RM_Size
(E
, RM_Size
(Astype
));
4813 -- In nested instances, the base type of an access actual
4814 -- may itself be private, and need to be exchanged.
4816 elsif Is_Access_Type
(E
)
4817 and then Is_Private_Type
(Etype
(E
))
4820 (New_Occurrence_Of
(Etype
(E
), Sloc
(Instance
)));
4823 elsif Ekind
(E
) = E_Package
then
4825 -- If this is the renaming for the current instance, we're done.
4826 -- Otherwise it is a formal package. If the corresponding formal
4827 -- was declared with a box, the (instantiations of the) generic
4828 -- formal part are also visible. Otherwise, ignore the entity
4829 -- created to validate the actuals.
4831 if Renamed_Object
(E
) = Instance
then
4834 elsif Nkind
(Parent
(E
)) /= N_Package_Renaming_Declaration
then
4837 -- The visibility of a formal of an enclosing generic is already
4840 elsif Denotes_Formal_Package
(E
) then
4843 elsif Present
(Associated_Formal_Package
(E
))
4844 and then not Is_Generic_Formal
(E
)
4846 if Box_Present
(Parent
(Associated_Formal_Package
(E
))) then
4847 Check_Generic_Actuals
(Renamed_Object
(E
), True);
4850 Check_Generic_Actuals
(Renamed_Object
(E
), False);
4853 Set_Is_Hidden
(E
, False);
4856 -- If this is a subprogram instance (in a wrapper package) the
4857 -- actual is fully visible.
4859 elsif Is_Wrapper_Package
(Instance
) then
4860 Set_Is_Hidden
(E
, False);
4862 -- If the formal package is declared with a box, or if the formal
4863 -- parameter is defaulted, it is visible in the body.
4866 or else Is_Visible_Formal
(E
)
4868 Set_Is_Hidden
(E
, False);
4873 end Check_Generic_Actuals
;
4875 ------------------------------
4876 -- Check_Generic_Child_Unit --
4877 ------------------------------
4879 procedure Check_Generic_Child_Unit
4881 Parent_Installed
: in out Boolean)
4883 Loc
: constant Source_Ptr
:= Sloc
(Gen_Id
);
4884 Gen_Par
: Entity_Id
:= Empty
;
4886 Inst_Par
: Entity_Id
;
4889 function Find_Generic_Child
4891 Id
: Node_Id
) return Entity_Id
;
4892 -- Search generic parent for possible child unit with the given name
4894 function In_Enclosing_Instance
return Boolean;
4895 -- Within an instance of the parent, the child unit may be denoted
4896 -- by a simple name, or an abbreviated expanded name. Examine enclosing
4897 -- scopes to locate a possible parent instantiation.
4899 ------------------------
4900 -- Find_Generic_Child --
4901 ------------------------
4903 function Find_Generic_Child
4905 Id
: Node_Id
) return Entity_Id
4910 -- If entity of name is already set, instance has already been
4911 -- resolved, e.g. in an enclosing instantiation.
4913 if Present
(Entity
(Id
)) then
4914 if Scope
(Entity
(Id
)) = Scop
then
4921 E
:= First_Entity
(Scop
);
4922 while Present
(E
) loop
4923 if Chars
(E
) = Chars
(Id
)
4924 and then Is_Child_Unit
(E
)
4926 if Is_Child_Unit
(E
)
4927 and then not Is_Visible_Child_Unit
(E
)
4930 ("generic child unit& is not visible", Gen_Id
, E
);
4942 end Find_Generic_Child
;
4944 ---------------------------
4945 -- In_Enclosing_Instance --
4946 ---------------------------
4948 function In_Enclosing_Instance
return Boolean is
4949 Enclosing_Instance
: Node_Id
;
4950 Instance_Decl
: Node_Id
;
4953 -- We do not inline any call that contains instantiations, except
4954 -- for instantiations of Unchecked_Conversion, so if we are within
4955 -- an inlined body the current instance does not require parents.
4957 if In_Inlined_Body
then
4958 pragma Assert
(Chars
(Gen_Id
) = Name_Unchecked_Conversion
);
4962 -- Loop to check enclosing scopes
4964 Enclosing_Instance
:= Current_Scope
;
4965 while Present
(Enclosing_Instance
) loop
4966 Instance_Decl
:= Unit_Declaration_Node
(Enclosing_Instance
);
4968 if Ekind
(Enclosing_Instance
) = E_Package
4969 and then Is_Generic_Instance
(Enclosing_Instance
)
4971 (Generic_Parent
(Specification
(Instance_Decl
)))
4973 -- Check whether the generic we are looking for is a child of
4976 E
:= Find_Generic_Child
4977 (Generic_Parent
(Specification
(Instance_Decl
)), Gen_Id
);
4978 exit when Present
(E
);
4984 Enclosing_Instance
:= Scope
(Enclosing_Instance
);
4996 Make_Expanded_Name
(Loc
,
4998 Prefix
=> New_Occurrence_Of
(Enclosing_Instance
, Loc
),
4999 Selector_Name
=> New_Occurrence_Of
(E
, Loc
)));
5001 Set_Entity
(Gen_Id
, E
);
5002 Set_Etype
(Gen_Id
, Etype
(E
));
5003 Parent_Installed
:= False; -- Already in scope.
5006 end In_Enclosing_Instance
;
5008 -- Start of processing for Check_Generic_Child_Unit
5011 -- If the name of the generic is given by a selected component, it may
5012 -- be the name of a generic child unit, and the prefix is the name of an
5013 -- instance of the parent, in which case the child unit must be visible.
5014 -- If this instance is not in scope, it must be placed there and removed
5015 -- after instantiation, because what is being instantiated is not the
5016 -- original child, but the corresponding child present in the instance
5019 -- If the child is instantiated within the parent, it can be given by
5020 -- a simple name. In this case the instance is already in scope, but
5021 -- the child generic must be recovered from the generic parent as well.
5023 if Nkind
(Gen_Id
) = N_Selected_Component
then
5024 S
:= Selector_Name
(Gen_Id
);
5025 Analyze
(Prefix
(Gen_Id
));
5026 Inst_Par
:= Entity
(Prefix
(Gen_Id
));
5028 if Ekind
(Inst_Par
) = E_Package
5029 and then Present
(Renamed_Object
(Inst_Par
))
5031 Inst_Par
:= Renamed_Object
(Inst_Par
);
5034 if Ekind
(Inst_Par
) = E_Package
then
5035 if Nkind
(Parent
(Inst_Par
)) = N_Package_Specification
then
5036 Gen_Par
:= Generic_Parent
(Parent
(Inst_Par
));
5038 elsif Nkind
(Parent
(Inst_Par
)) = N_Defining_Program_Unit_Name
5040 Nkind
(Parent
(Parent
(Inst_Par
))) = N_Package_Specification
5042 Gen_Par
:= Generic_Parent
(Parent
(Parent
(Inst_Par
)));
5045 elsif Ekind
(Inst_Par
) = E_Generic_Package
5046 and then Nkind
(Parent
(Gen_Id
)) = N_Formal_Package_Declaration
5048 -- A formal package may be a real child package, and not the
5049 -- implicit instance within a parent. In this case the child is
5050 -- not visible and has to be retrieved explicitly as well.
5052 Gen_Par
:= Inst_Par
;
5055 if Present
(Gen_Par
) then
5057 -- The prefix denotes an instantiation. The entity itself may be a
5058 -- nested generic, or a child unit.
5060 E
:= Find_Generic_Child
(Gen_Par
, S
);
5063 Change_Selected_Component_To_Expanded_Name
(Gen_Id
);
5064 Set_Entity
(Gen_Id
, E
);
5065 Set_Etype
(Gen_Id
, Etype
(E
));
5067 Set_Etype
(S
, Etype
(E
));
5069 -- Indicate that this is a reference to the parent
5071 if In_Extended_Main_Source_Unit
(Gen_Id
) then
5072 Set_Is_Instantiated
(Inst_Par
);
5075 -- A common mistake is to replicate the naming scheme of a
5076 -- hierarchy by instantiating a generic child directly, rather
5077 -- than the implicit child in a parent instance:
5079 -- generic .. package Gpar is ..
5080 -- generic .. package Gpar.Child is ..
5081 -- package Par is new Gpar ();
5084 -- package Par.Child is new Gpar.Child ();
5085 -- rather than Par.Child
5087 -- In this case the instantiation is within Par, which is an
5088 -- instance, but Gpar does not denote Par because we are not IN
5089 -- the instance of Gpar, so this is illegal. The test below
5090 -- recognizes this particular case.
5092 if Is_Child_Unit
(E
)
5093 and then not Comes_From_Source
(Entity
(Prefix
(Gen_Id
)))
5094 and then (not In_Instance
5095 or else Nkind
(Parent
(Parent
(Gen_Id
))) =
5099 ("prefix of generic child unit must be instance of parent",
5103 if not In_Open_Scopes
(Inst_Par
)
5104 and then Nkind
(Parent
(Gen_Id
)) not in
5105 N_Generic_Renaming_Declaration
5107 Install_Parent
(Inst_Par
);
5108 Parent_Installed
:= True;
5110 elsif In_Open_Scopes
(Inst_Par
) then
5112 -- If the parent is already installed verify that the
5113 -- actuals for its formal packages declared with a box
5114 -- are already installed. This is necessary when the
5115 -- child instance is a child of the parent instance.
5116 -- In this case the parent is placed on the scope stack
5117 -- but the formal packages are not made visible.
5119 Install_Formal_Packages
(Inst_Par
);
5123 -- If the generic parent does not contain an entity that
5124 -- corresponds to the selector, the instance doesn't either.
5125 -- Analyzing the node will yield the appropriate error message.
5126 -- If the entity is not a child unit, then it is an inner
5127 -- generic in the parent.
5135 if Is_Child_Unit
(Entity
(Gen_Id
))
5137 Nkind
(Parent
(Gen_Id
)) not in N_Generic_Renaming_Declaration
5138 and then not In_Open_Scopes
(Inst_Par
)
5140 Install_Parent
(Inst_Par
);
5141 Parent_Installed
:= True;
5145 elsif Nkind
(Gen_Id
) = N_Expanded_Name
then
5147 -- Entity already present, analyze prefix, whose meaning may be
5148 -- an instance in the current context. If it is an instance of
5149 -- a relative within another, the proper parent may still have
5150 -- to be installed, if they are not of the same generation.
5152 Analyze
(Prefix
(Gen_Id
));
5154 -- In the unlikely case that a local declaration hides the name
5155 -- of the parent package, locate it on the homonym chain. If the
5156 -- context is an instance of the parent, the renaming entity is
5159 Inst_Par
:= Entity
(Prefix
(Gen_Id
));
5160 while Present
(Inst_Par
)
5161 and then Ekind
(Inst_Par
) /= E_Package
5162 and then Ekind
(Inst_Par
) /= E_Generic_Package
5164 Inst_Par
:= Homonym
(Inst_Par
);
5167 pragma Assert
(Present
(Inst_Par
));
5168 Set_Entity
(Prefix
(Gen_Id
), Inst_Par
);
5170 if In_Enclosing_Instance
then
5173 elsif Present
(Entity
(Gen_Id
))
5174 and then Is_Child_Unit
(Entity
(Gen_Id
))
5175 and then not In_Open_Scopes
(Inst_Par
)
5177 Install_Parent
(Inst_Par
);
5178 Parent_Installed
:= True;
5181 elsif In_Enclosing_Instance
then
5183 -- The child unit is found in some enclosing scope
5190 -- If this is the renaming of the implicit child in a parent
5191 -- instance, recover the parent name and install it.
5193 if Is_Entity_Name
(Gen_Id
) then
5194 E
:= Entity
(Gen_Id
);
5196 if Is_Generic_Unit
(E
)
5197 and then Nkind
(Parent
(E
)) in N_Generic_Renaming_Declaration
5198 and then Is_Child_Unit
(Renamed_Object
(E
))
5199 and then Is_Generic_Unit
(Scope
(Renamed_Object
(E
)))
5200 and then Nkind
(Name
(Parent
(E
))) = N_Expanded_Name
5203 New_Copy_Tree
(Name
(Parent
(E
))));
5204 Inst_Par
:= Entity
(Prefix
(Gen_Id
));
5206 if not In_Open_Scopes
(Inst_Par
) then
5207 Install_Parent
(Inst_Par
);
5208 Parent_Installed
:= True;
5211 -- If it is a child unit of a non-generic parent, it may be
5212 -- use-visible and given by a direct name. Install parent as
5215 elsif Is_Generic_Unit
(E
)
5216 and then Is_Child_Unit
(E
)
5218 Nkind
(Parent
(Gen_Id
)) not in N_Generic_Renaming_Declaration
5219 and then not Is_Generic_Unit
(Scope
(E
))
5221 if not In_Open_Scopes
(Scope
(E
)) then
5222 Install_Parent
(Scope
(E
));
5223 Parent_Installed
:= True;
5228 end Check_Generic_Child_Unit
;
5230 -----------------------------
5231 -- Check_Hidden_Child_Unit --
5232 -----------------------------
5234 procedure Check_Hidden_Child_Unit
5236 Gen_Unit
: Entity_Id
;
5237 Act_Decl_Id
: Entity_Id
)
5239 Gen_Id
: constant Node_Id
:= Name
(N
);
5242 if Is_Child_Unit
(Gen_Unit
)
5243 and then Is_Child_Unit
(Act_Decl_Id
)
5244 and then Nkind
(Gen_Id
) = N_Expanded_Name
5245 and then Entity
(Prefix
(Gen_Id
)) = Scope
(Act_Decl_Id
)
5246 and then Chars
(Gen_Unit
) = Chars
(Act_Decl_Id
)
5248 Error_Msg_Node_2
:= Scope
(Act_Decl_Id
);
5250 ("generic unit & is implicitly declared in &",
5251 Defining_Unit_Name
(N
), Gen_Unit
);
5252 Error_Msg_N
("\instance must have different name",
5253 Defining_Unit_Name
(N
));
5255 end Check_Hidden_Child_Unit
;
5257 ------------------------
5258 -- Check_Private_View --
5259 ------------------------
5261 procedure Check_Private_View
(N
: Node_Id
) is
5262 T
: constant Entity_Id
:= Etype
(N
);
5266 -- Exchange views if the type was not private in the generic but is
5267 -- private at the point of instantiation. Do not exchange views if
5268 -- the scope of the type is in scope. This can happen if both generic
5269 -- and instance are sibling units, or if type is defined in a parent.
5270 -- In this case the visibility of the type will be correct for all
5274 BT
:= Base_Type
(T
);
5276 if Is_Private_Type
(T
)
5277 and then not Has_Private_View
(N
)
5278 and then Present
(Full_View
(T
))
5279 and then not In_Open_Scopes
(Scope
(T
))
5281 -- In the generic, the full type was visible. Save the private
5282 -- entity, for subsequent exchange.
5286 elsif Has_Private_View
(N
)
5287 and then not Is_Private_Type
(T
)
5288 and then not Has_Been_Exchanged
(T
)
5289 and then Etype
(Get_Associated_Node
(N
)) /= T
5291 -- Only the private declaration was visible in the generic. If
5292 -- the type appears in a subtype declaration, the subtype in the
5293 -- instance must have a view compatible with that of its parent,
5294 -- which must be exchanged (see corresponding code in Restore_
5295 -- Private_Views). Otherwise, if the type is defined in a parent
5296 -- unit, leave full visibility within instance, which is safe.
5298 if In_Open_Scopes
(Scope
(Base_Type
(T
)))
5299 and then not Is_Private_Type
(Base_Type
(T
))
5300 and then Comes_From_Source
(Base_Type
(T
))
5304 elsif Nkind
(Parent
(N
)) = N_Subtype_Declaration
5305 or else not In_Private_Part
(Scope
(Base_Type
(T
)))
5307 Prepend_Elmt
(T
, Exchanged_Views
);
5308 Exchange_Declarations
(Etype
(Get_Associated_Node
(N
)));
5311 -- For composite types with inconsistent representation exchange
5312 -- component types accordingly.
5314 elsif Is_Access_Type
(T
)
5315 and then Is_Private_Type
(Designated_Type
(T
))
5316 and then not Has_Private_View
(N
)
5317 and then Present
(Full_View
(Designated_Type
(T
)))
5319 Switch_View
(Designated_Type
(T
));
5321 elsif Is_Array_Type
(T
) then
5322 if Is_Private_Type
(Component_Type
(T
))
5323 and then not Has_Private_View
(N
)
5324 and then Present
(Full_View
(Component_Type
(T
)))
5326 Switch_View
(Component_Type
(T
));
5329 -- The normal exchange mechanism relies on the setting of a
5330 -- flag on the reference in the generic. However, an additional
5331 -- mechanism is needed for types that are not explicitly mentioned
5332 -- in the generic, but may be needed in expanded code in the
5333 -- instance. This includes component types of arrays and
5334 -- designated types of access types. This processing must also
5335 -- include the index types of arrays which we take care of here.
5342 Indx
:= First_Index
(T
);
5343 Typ
:= Base_Type
(Etype
(Indx
));
5344 while Present
(Indx
) loop
5345 if Is_Private_Type
(Typ
)
5346 and then Present
(Full_View
(Typ
))
5355 elsif Is_Private_Type
(T
)
5356 and then Present
(Full_View
(T
))
5357 and then Is_Array_Type
(Full_View
(T
))
5358 and then Is_Private_Type
(Component_Type
(Full_View
(T
)))
5362 -- Finally, a non-private subtype may have a private base type, which
5363 -- must be exchanged for consistency. This can happen when a package
5364 -- body is instantiated, when the scope stack is empty but in fact
5365 -- the subtype and the base type are declared in an enclosing scope.
5367 -- Note that in this case we introduce an inconsistency in the view
5368 -- set, because we switch the base type BT, but there could be some
5369 -- private dependent subtypes of BT which remain unswitched. Such
5370 -- subtypes might need to be switched at a later point (see specific
5371 -- provision for that case in Switch_View).
5373 elsif not Is_Private_Type
(T
)
5374 and then not Has_Private_View
(N
)
5375 and then Is_Private_Type
(BT
)
5376 and then Present
(Full_View
(BT
))
5377 and then not Is_Generic_Type
(BT
)
5378 and then not In_Open_Scopes
(BT
)
5380 Prepend_Elmt
(Full_View
(BT
), Exchanged_Views
);
5381 Exchange_Declarations
(BT
);
5384 end Check_Private_View
;
5386 --------------------------
5387 -- Contains_Instance_Of --
5388 --------------------------
5390 function Contains_Instance_Of
5393 N
: Node_Id
) return Boolean
5401 -- Verify that there are no circular instantiations. We check whether
5402 -- the unit contains an instance of the current scope or some enclosing
5403 -- scope (in case one of the instances appears in a subunit). Longer
5404 -- circularities involving subunits might seem too pathological to
5405 -- consider, but they were not too pathological for the authors of
5406 -- DEC bc30vsq, so we loop over all enclosing scopes, and mark all
5407 -- enclosing generic scopes as containing an instance.
5410 -- Within a generic subprogram body, the scope is not generic, to
5411 -- allow for recursive subprograms. Use the declaration to determine
5412 -- whether this is a generic unit.
5414 if Ekind
(Scop
) = E_Generic_Package
5415 or else (Is_Subprogram
(Scop
)
5416 and then Nkind
(Unit_Declaration_Node
(Scop
)) =
5417 N_Generic_Subprogram_Declaration
)
5419 Elmt
:= First_Elmt
(Inner_Instances
(Inner
));
5421 while Present
(Elmt
) loop
5422 if Node
(Elmt
) = Scop
then
5423 Error_Msg_Node_2
:= Inner
;
5425 ("circular Instantiation: & instantiated within &!",
5429 elsif Node
(Elmt
) = Inner
then
5432 elsif Contains_Instance_Of
(Node
(Elmt
), Scop
, N
) then
5433 Error_Msg_Node_2
:= Inner
;
5435 ("circular Instantiation: & instantiated within &!",
5443 -- Indicate that Inner is being instantiated within Scop
5445 Append_Elmt
(Inner
, Inner_Instances
(Scop
));
5448 if Scop
= Standard_Standard
then
5451 Scop
:= Scope
(Scop
);
5456 end Contains_Instance_Of
;
5458 -----------------------
5459 -- Copy_Generic_Node --
5460 -----------------------
5462 function Copy_Generic_Node
5464 Parent_Id
: Node_Id
;
5465 Instantiating
: Boolean) return Node_Id
5470 function Copy_Generic_Descendant
(D
: Union_Id
) return Union_Id
;
5471 -- Check the given value of one of the Fields referenced by the
5472 -- current node to determine whether to copy it recursively. The
5473 -- field may hold a Node_Id, a List_Id, or an Elist_Id, or a plain
5474 -- value (Sloc, Uint, Char) in which case it need not be copied.
5476 procedure Copy_Descendants
;
5477 -- Common utility for various nodes
5479 function Copy_Generic_Elist
(E
: Elist_Id
) return Elist_Id
;
5480 -- Make copy of element list
5482 function Copy_Generic_List
5484 Parent_Id
: Node_Id
) return List_Id
;
5485 -- Apply Copy_Node recursively to the members of a node list
5487 function In_Defining_Unit_Name
(Nam
: Node_Id
) return Boolean;
5488 -- True if an identifier is part of the defining program unit name
5489 -- of a child unit. The entity of such an identifier must be kept
5490 -- (for ASIS use) even though as the name of an enclosing generic
5491 -- it would otherwise not be preserved in the generic tree.
5493 ----------------------
5494 -- Copy_Descendants --
5495 ----------------------
5497 procedure Copy_Descendants
is
5499 use Atree
.Unchecked_Access
;
5500 -- This code section is part of the implementation of an untyped
5501 -- tree traversal, so it needs direct access to node fields.
5504 Set_Field1
(New_N
, Copy_Generic_Descendant
(Field1
(N
)));
5505 Set_Field2
(New_N
, Copy_Generic_Descendant
(Field2
(N
)));
5506 Set_Field3
(New_N
, Copy_Generic_Descendant
(Field3
(N
)));
5507 Set_Field4
(New_N
, Copy_Generic_Descendant
(Field4
(N
)));
5508 Set_Field5
(New_N
, Copy_Generic_Descendant
(Field5
(N
)));
5509 end Copy_Descendants
;
5511 -----------------------------
5512 -- Copy_Generic_Descendant --
5513 -----------------------------
5515 function Copy_Generic_Descendant
(D
: Union_Id
) return Union_Id
is
5517 if D
= Union_Id
(Empty
) then
5520 elsif D
in Node_Range
then
5522 (Copy_Generic_Node
(Node_Id
(D
), New_N
, Instantiating
));
5524 elsif D
in List_Range
then
5525 return Union_Id
(Copy_Generic_List
(List_Id
(D
), New_N
));
5527 elsif D
in Elist_Range
then
5528 return Union_Id
(Copy_Generic_Elist
(Elist_Id
(D
)));
5530 -- Nothing else is copyable (e.g. Uint values), return as is
5535 end Copy_Generic_Descendant
;
5537 ------------------------
5538 -- Copy_Generic_Elist --
5539 ------------------------
5541 function Copy_Generic_Elist
(E
: Elist_Id
) return Elist_Id
is
5548 M
:= First_Elmt
(E
);
5549 while Present
(M
) loop
5551 (Copy_Generic_Node
(Node
(M
), Empty
, Instantiating
), L
);
5560 end Copy_Generic_Elist
;
5562 -----------------------
5563 -- Copy_Generic_List --
5564 -----------------------
5566 function Copy_Generic_List
5568 Parent_Id
: Node_Id
) return List_Id
5576 Set_Parent
(New_L
, Parent_Id
);
5579 while Present
(N
) loop
5580 Append
(Copy_Generic_Node
(N
, Empty
, Instantiating
), New_L
);
5589 end Copy_Generic_List
;
5591 ---------------------------
5592 -- In_Defining_Unit_Name --
5593 ---------------------------
5595 function In_Defining_Unit_Name
(Nam
: Node_Id
) return Boolean is
5597 return Present
(Parent
(Nam
))
5598 and then (Nkind
(Parent
(Nam
)) = N_Defining_Program_Unit_Name
5600 (Nkind
(Parent
(Nam
)) = N_Expanded_Name
5601 and then In_Defining_Unit_Name
(Parent
(Nam
))));
5602 end In_Defining_Unit_Name
;
5604 -- Start of processing for Copy_Generic_Node
5611 New_N
:= New_Copy
(N
);
5613 if Instantiating
then
5614 Adjust_Instantiation_Sloc
(New_N
, S_Adjustment
);
5617 if not Is_List_Member
(N
) then
5618 Set_Parent
(New_N
, Parent_Id
);
5621 -- If defining identifier, then all fields have been copied already
5623 if Nkind
(New_N
) in N_Entity
then
5626 -- Special casing for identifiers and other entity names and operators
5628 elsif Nkind
(New_N
) = N_Identifier
5629 or else Nkind
(New_N
) = N_Character_Literal
5630 or else Nkind
(New_N
) = N_Expanded_Name
5631 or else Nkind
(New_N
) = N_Operator_Symbol
5632 or else Nkind
(New_N
) in N_Op
5634 if not Instantiating
then
5636 -- Link both nodes in order to assign subsequently the
5637 -- entity of the copy to the original node, in case this
5638 -- is a global reference.
5640 Set_Associated_Node
(N
, New_N
);
5642 -- If we are within an instantiation, this is a nested generic
5643 -- that has already been analyzed at the point of definition. We
5644 -- must preserve references that were global to the enclosing
5645 -- parent at that point. Other occurrences, whether global or
5646 -- local to the current generic, must be resolved anew, so we
5647 -- reset the entity in the generic copy. A global reference has a
5648 -- smaller depth than the parent, or else the same depth in case
5649 -- both are distinct compilation units.
5650 -- A child unit is implicitly declared within the enclosing parent
5651 -- but is in fact global to it, and must be preserved.
5653 -- It is also possible for Current_Instantiated_Parent to be
5654 -- defined, and for this not to be a nested generic, namely if the
5655 -- unit is loaded through Rtsfind. In that case, the entity of
5656 -- New_N is only a link to the associated node, and not a defining
5659 -- The entities for parent units in the defining_program_unit of a
5660 -- generic child unit are established when the context of the unit
5661 -- is first analyzed, before the generic copy is made. They are
5662 -- preserved in the copy for use in ASIS queries.
5664 Ent
:= Entity
(New_N
);
5666 if No
(Current_Instantiated_Parent
.Gen_Id
) then
5668 or else Nkind
(Ent
) /= N_Defining_Identifier
5669 or else not In_Defining_Unit_Name
(N
)
5671 Set_Associated_Node
(New_N
, Empty
);
5676 not (Nkind
(Ent
) = N_Defining_Identifier
5678 Nkind
(Ent
) = N_Defining_Character_Literal
5680 Nkind
(Ent
) = N_Defining_Operator_Symbol
)
5681 or else No
(Scope
(Ent
))
5683 (Scope
(Ent
) = Current_Instantiated_Parent
.Gen_Id
5684 and then not Is_Child_Unit
(Ent
))
5685 or else (Scope_Depth
(Scope
(Ent
)) >
5686 Scope_Depth
(Current_Instantiated_Parent
.Gen_Id
)
5688 Get_Source_Unit
(Ent
) =
5689 Get_Source_Unit
(Current_Instantiated_Parent
.Gen_Id
))
5691 Set_Associated_Node
(New_N
, Empty
);
5694 -- Case of instantiating identifier or some other name or operator
5697 -- If the associated node is still defined, the entity in it is
5698 -- global, and must be copied to the instance. If this copy is
5699 -- being made for a body to inline, it is applied to an
5700 -- instantiated tree, and the entity is already present and must
5701 -- be also preserved.
5704 Assoc
: constant Node_Id
:= Get_Associated_Node
(N
);
5706 if Present
(Assoc
) then
5707 if Nkind
(Assoc
) = Nkind
(N
) then
5708 Set_Entity
(New_N
, Entity
(Assoc
));
5709 Check_Private_View
(N
);
5711 elsif Nkind
(Assoc
) = N_Function_Call
then
5712 Set_Entity
(New_N
, Entity
(Name
(Assoc
)));
5714 elsif (Nkind
(Assoc
) = N_Defining_Identifier
5715 or else Nkind
(Assoc
) = N_Defining_Character_Literal
5716 or else Nkind
(Assoc
) = N_Defining_Operator_Symbol
)
5717 and then Expander_Active
5719 -- Inlining case: we are copying a tree that contains
5720 -- global entities, which are preserved in the copy to be
5721 -- used for subsequent inlining.
5726 Set_Entity
(New_N
, Empty
);
5732 -- For expanded name, we must copy the Prefix and Selector_Name
5734 if Nkind
(N
) = N_Expanded_Name
then
5736 (New_N
, Copy_Generic_Node
(Prefix
(N
), New_N
, Instantiating
));
5738 Set_Selector_Name
(New_N
,
5739 Copy_Generic_Node
(Selector_Name
(N
), New_N
, Instantiating
));
5741 -- For operators, we must copy the right operand
5743 elsif Nkind
(N
) in N_Op
then
5744 Set_Right_Opnd
(New_N
,
5745 Copy_Generic_Node
(Right_Opnd
(N
), New_N
, Instantiating
));
5747 -- And for binary operators, the left operand as well
5749 if Nkind
(N
) in N_Binary_Op
then
5750 Set_Left_Opnd
(New_N
,
5751 Copy_Generic_Node
(Left_Opnd
(N
), New_N
, Instantiating
));
5755 -- Special casing for stubs
5757 elsif Nkind
(N
) in N_Body_Stub
then
5759 -- In any case, we must copy the specification or defining
5760 -- identifier as appropriate.
5762 if Nkind
(N
) = N_Subprogram_Body_Stub
then
5763 Set_Specification
(New_N
,
5764 Copy_Generic_Node
(Specification
(N
), New_N
, Instantiating
));
5767 Set_Defining_Identifier
(New_N
,
5769 (Defining_Identifier
(N
), New_N
, Instantiating
));
5772 -- If we are not instantiating, then this is where we load and
5773 -- analyze subunits, i.e. at the point where the stub occurs. A
5774 -- more permissivle system might defer this analysis to the point
5775 -- of instantiation, but this seems to complicated for now.
5777 if not Instantiating
then
5779 Subunit_Name
: constant Unit_Name_Type
:= Get_Unit_Name
(N
);
5781 Unum
: Unit_Number_Type
;
5787 (Load_Name
=> Subunit_Name
,
5792 -- If the proper body is not found, a warning message will be
5793 -- emitted when analyzing the stub, or later at the the point
5794 -- of instantiation. Here we just leave the stub as is.
5796 if Unum
= No_Unit
then
5797 Subunits_Missing
:= True;
5798 goto Subunit_Not_Found
;
5801 Subunit
:= Cunit
(Unum
);
5803 if Nkind
(Unit
(Subunit
)) /= N_Subunit
then
5805 ("found child unit instead of expected SEPARATE subunit",
5807 Error_Msg_Sloc
:= Sloc
(N
);
5808 Error_Msg_N
("\to complete stub #", Subunit
);
5809 goto Subunit_Not_Found
;
5812 -- We must create a generic copy of the subunit, in order to
5813 -- perform semantic analysis on it, and we must replace the
5814 -- stub in the original generic unit with the subunit, in order
5815 -- to preserve non-local references within.
5817 -- Only the proper body needs to be copied. Library_Unit and
5818 -- context clause are simply inherited by the generic copy.
5819 -- Note that the copy (which may be recursive if there are
5820 -- nested subunits) must be done first, before attaching it to
5821 -- the enclosing generic.
5825 (Proper_Body
(Unit
(Subunit
)),
5826 Empty
, Instantiating
=> False);
5828 -- Now place the original proper body in the original generic
5829 -- unit. This is a body, not a compilation unit.
5831 Rewrite
(N
, Proper_Body
(Unit
(Subunit
)));
5832 Set_Is_Compilation_Unit
(Defining_Entity
(N
), False);
5833 Set_Was_Originally_Stub
(N
);
5835 -- Finally replace the body of the subunit with its copy, and
5836 -- make this new subunit into the library unit of the generic
5837 -- copy, which does not have stubs any longer.
5839 Set_Proper_Body
(Unit
(Subunit
), New_Body
);
5840 Set_Library_Unit
(New_N
, Subunit
);
5841 Inherit_Context
(Unit
(Subunit
), N
);
5844 -- If we are instantiating, this must be an error case, since
5845 -- otherwise we would have replaced the stub node by the proper body
5846 -- that corresponds. So just ignore it in the copy (i.e. we have
5847 -- copied it, and that is good enough).
5853 <<Subunit_Not_Found
>> null;
5855 -- If the node is a compilation unit, it is the subunit of a stub, which
5856 -- has been loaded already (see code below). In this case, the library
5857 -- unit field of N points to the parent unit (which is a compilation
5858 -- unit) and need not (and cannot!) be copied.
5860 -- When the proper body of the stub is analyzed, thie library_unit link
5861 -- is used to establish the proper context (see sem_ch10).
5863 -- The other fields of a compilation unit are copied as usual
5865 elsif Nkind
(N
) = N_Compilation_Unit
then
5867 -- This code can only be executed when not instantiating, because in
5868 -- the copy made for an instantiation, the compilation unit node has
5869 -- disappeared at the point that a stub is replaced by its proper
5872 pragma Assert
(not Instantiating
);
5874 Set_Context_Items
(New_N
,
5875 Copy_Generic_List
(Context_Items
(N
), New_N
));
5878 Copy_Generic_Node
(Unit
(N
), New_N
, False));
5880 Set_First_Inlined_Subprogram
(New_N
,
5882 (First_Inlined_Subprogram
(N
), New_N
, False));
5884 Set_Aux_Decls_Node
(New_N
,
5885 Copy_Generic_Node
(Aux_Decls_Node
(N
), New_N
, False));
5887 -- For an assignment node, the assignment is known to be semantically
5888 -- legal if we are instantiating the template. This avoids incorrect
5889 -- diagnostics in generated code.
5891 elsif Nkind
(N
) = N_Assignment_Statement
then
5893 -- Copy name and expression fields in usual manner
5896 Copy_Generic_Node
(Name
(N
), New_N
, Instantiating
));
5898 Set_Expression
(New_N
,
5899 Copy_Generic_Node
(Expression
(N
), New_N
, Instantiating
));
5901 if Instantiating
then
5902 Set_Assignment_OK
(Name
(New_N
), True);
5905 elsif Nkind
(N
) = N_Aggregate
5906 or else Nkind
(N
) = N_Extension_Aggregate
5908 if not Instantiating
then
5909 Set_Associated_Node
(N
, New_N
);
5912 if Present
(Get_Associated_Node
(N
))
5913 and then Nkind
(Get_Associated_Node
(N
)) = Nkind
(N
)
5915 -- In the generic the aggregate has some composite type. If at
5916 -- the point of instantiation the type has a private view,
5917 -- install the full view (and that of its ancestors, if any).
5920 T
: Entity_Id
:= (Etype
(Get_Associated_Node
(New_N
)));
5925 and then Is_Private_Type
(T
)
5931 and then Is_Tagged_Type
(T
)
5932 and then Is_Derived_Type
(T
)
5934 Rt
:= Root_Type
(T
);
5939 if Is_Private_Type
(T
) then
5950 -- Do not copy the associated node, which points to
5951 -- the generic copy of the aggregate.
5954 use Atree
.Unchecked_Access
;
5955 -- This code section is part of the implementation of an untyped
5956 -- tree traversal, so it needs direct access to node fields.
5959 Set_Field1
(New_N
, Copy_Generic_Descendant
(Field1
(N
)));
5960 Set_Field2
(New_N
, Copy_Generic_Descendant
(Field2
(N
)));
5961 Set_Field3
(New_N
, Copy_Generic_Descendant
(Field3
(N
)));
5962 Set_Field5
(New_N
, Copy_Generic_Descendant
(Field5
(N
)));
5965 -- Allocators do not have an identifier denoting the access type,
5966 -- so we must locate it through the expression to check whether
5967 -- the views are consistent.
5969 elsif Nkind
(N
) = N_Allocator
5970 and then Nkind
(Expression
(N
)) = N_Qualified_Expression
5971 and then Is_Entity_Name
(Subtype_Mark
(Expression
(N
)))
5972 and then Instantiating
5975 T
: constant Node_Id
:=
5976 Get_Associated_Node
(Subtype_Mark
(Expression
(N
)));
5982 -- Retrieve the allocator node in the generic copy
5984 Acc_T
:= Etype
(Parent
(Parent
(T
)));
5986 and then Is_Private_Type
(Acc_T
)
5988 Switch_View
(Acc_T
);
5995 -- For a proper body, we must catch the case of a proper body that
5996 -- replaces a stub. This represents the point at which a separate
5997 -- compilation unit, and hence template file, may be referenced, so we
5998 -- must make a new source instantiation entry for the template of the
5999 -- subunit, and ensure that all nodes in the subunit are adjusted using
6000 -- this new source instantiation entry.
6002 elsif Nkind
(N
) in N_Proper_Body
then
6004 Save_Adjustment
: constant Sloc_Adjustment
:= S_Adjustment
;
6007 if Instantiating
and then Was_Originally_Stub
(N
) then
6008 Create_Instantiation_Source
6009 (Instantiation_Node
,
6010 Defining_Entity
(N
),
6015 -- Now copy the fields of the proper body, using the new
6016 -- adjustment factor if one was needed as per test above.
6020 -- Restore the original adjustment factor in case changed
6022 S_Adjustment
:= Save_Adjustment
;
6025 -- Don't copy Ident or Comment pragmas, since the comment belongs to the
6026 -- generic unit, not to the instantiating unit.
6028 elsif Nkind
(N
) = N_Pragma
6029 and then Instantiating
6032 Prag_Id
: constant Pragma_Id
:= Get_Pragma_Id
(Chars
(N
));
6035 if Prag_Id
= Pragma_Ident
6036 or else Prag_Id
= Pragma_Comment
6038 New_N
:= Make_Null_Statement
(Sloc
(N
));
6045 elsif Nkind
(N
) = N_Integer_Literal
6046 or else Nkind
(N
) = N_Real_Literal
6047 or else Nkind
(N
) = N_String_Literal
6049 -- No descendant fields need traversing
6053 -- For the remaining nodes, copy recursively their descendants
6059 and then Nkind
(N
) = N_Subprogram_Body
6061 Set_Generic_Parent
(Specification
(New_N
), N
);
6066 end Copy_Generic_Node
;
6068 ----------------------------
6069 -- Denotes_Formal_Package --
6070 ----------------------------
6072 function Denotes_Formal_Package
6074 On_Exit
: Boolean := False) return Boolean
6077 Scop
: constant Entity_Id
:= Scope
(Pack
);
6084 (Instance_Envs
.Last
).Instantiated_Parent
.Act_Id
;
6086 Par
:= Current_Instantiated_Parent
.Act_Id
;
6089 if Ekind
(Scop
) = E_Generic_Package
6090 or else Nkind
(Unit_Declaration_Node
(Scop
)) =
6091 N_Generic_Subprogram_Declaration
6095 elsif Nkind
(Original_Node
(Unit_Declaration_Node
(Pack
))) =
6096 N_Formal_Package_Declaration
6104 -- Check whether this package is associated with a formal package of
6105 -- the enclosing instantiation. Iterate over the list of renamings.
6107 E
:= First_Entity
(Par
);
6108 while Present
(E
) loop
6109 if Ekind
(E
) /= E_Package
6110 or else Nkind
(Parent
(E
)) /= N_Package_Renaming_Declaration
6114 elsif Renamed_Object
(E
) = Par
then
6117 elsif Renamed_Object
(E
) = Pack
then
6126 end Denotes_Formal_Package
;
6132 procedure End_Generic
is
6134 -- ??? More things could be factored out in this routine. Should
6135 -- probably be done at a later stage.
6137 Inside_A_Generic
:= Generic_Flags
.Table
(Generic_Flags
.Last
);
6138 Generic_Flags
.Decrement_Last
;
6140 Expander_Mode_Restore
;
6143 ----------------------
6144 -- Find_Actual_Type --
6145 ----------------------
6147 function Find_Actual_Type
6149 Gen_Scope
: Entity_Id
) return Entity_Id
6154 if not Is_Child_Unit
(Gen_Scope
) then
6155 return Get_Instance_Of
(Typ
);
6157 elsif not Is_Generic_Type
(Typ
)
6158 or else Scope
(Typ
) = Gen_Scope
6160 return Get_Instance_Of
(Typ
);
6163 T
:= Current_Entity
(Typ
);
6164 while Present
(T
) loop
6165 if In_Open_Scopes
(Scope
(T
)) then
6168 elsif Is_Generic_Actual_Type
(T
) then
6177 end Find_Actual_Type
;
6179 ----------------------------
6180 -- Freeze_Subprogram_Body --
6181 ----------------------------
6183 procedure Freeze_Subprogram_Body
6184 (Inst_Node
: Node_Id
;
6186 Pack_Id
: Entity_Id
)
6189 Gen_Unit
: constant Entity_Id
:= Get_Generic_Entity
(Inst_Node
);
6190 Par
: constant Entity_Id
:= Scope
(Gen_Unit
);
6195 function Earlier
(N1
, N2
: Node_Id
) return Boolean;
6196 -- Yields True if N1 and N2 appear in the same compilation unit,
6197 -- ignoring subunits, and if N1 is to the left of N2 in a left-to-right
6198 -- traversal of the tree for the unit.
6200 function Enclosing_Body
(N
: Node_Id
) return Node_Id
;
6201 -- Find innermost package body that encloses the given node, and which
6202 -- is not a compilation unit. Freeze nodes for the instance, or for its
6203 -- enclosing body, may be inserted after the enclosing_body of the
6206 function Package_Freeze_Node
(B
: Node_Id
) return Node_Id
;
6207 -- Find entity for given package body, and locate or create a freeze
6210 function True_Parent
(N
: Node_Id
) return Node_Id
;
6211 -- For a subunit, return parent of corresponding stub
6217 function Earlier
(N1
, N2
: Node_Id
) return Boolean is
6223 procedure Find_Depth
(P
: in out Node_Id
; D
: in out Integer);
6224 -- Find distance from given node to enclosing compilation unit
6230 procedure Find_Depth
(P
: in out Node_Id
; D
: in out Integer) is
6233 and then Nkind
(P
) /= N_Compilation_Unit
6235 P
:= True_Parent
(P
);
6240 -- Start of procesing for Earlier
6243 Find_Depth
(P1
, D1
);
6244 Find_Depth
(P2
, D2
);
6254 P1
:= True_Parent
(P1
);
6259 P2
:= True_Parent
(P2
);
6263 -- At this point P1 and P2 are at the same distance from the root.
6264 -- We examine their parents until we find a common declarative
6265 -- list, at which point we can establish their relative placement
6266 -- by comparing their ultimate slocs. If we reach the root,
6267 -- N1 and N2 do not descend from the same declarative list (e.g.
6268 -- one is nested in the declarative part and the other is in a block
6269 -- in the statement part) and the earlier one is already frozen.
6271 while not Is_List_Member
(P1
)
6272 or else not Is_List_Member
(P2
)
6273 or else List_Containing
(P1
) /= List_Containing
(P2
)
6275 P1
:= True_Parent
(P1
);
6276 P2
:= True_Parent
(P2
);
6278 if Nkind
(Parent
(P1
)) = N_Subunit
then
6279 P1
:= Corresponding_Stub
(Parent
(P1
));
6282 if Nkind
(Parent
(P2
)) = N_Subunit
then
6283 P2
:= Corresponding_Stub
(Parent
(P2
));
6292 Top_Level_Location
(Sloc
(P1
)) < Top_Level_Location
(Sloc
(P2
));
6295 --------------------
6296 -- Enclosing_Body --
6297 --------------------
6299 function Enclosing_Body
(N
: Node_Id
) return Node_Id
is
6300 P
: Node_Id
:= Parent
(N
);
6304 and then Nkind
(Parent
(P
)) /= N_Compilation_Unit
6306 if Nkind
(P
) = N_Package_Body
then
6308 if Nkind
(Parent
(P
)) = N_Subunit
then
6309 return Corresponding_Stub
(Parent
(P
));
6315 P
:= True_Parent
(P
);
6321 -------------------------
6322 -- Package_Freeze_Node --
6323 -------------------------
6325 function Package_Freeze_Node
(B
: Node_Id
) return Node_Id
is
6329 if Nkind
(B
) = N_Package_Body
then
6330 Id
:= Corresponding_Spec
(B
);
6332 else pragma Assert
(Nkind
(B
) = N_Package_Body_Stub
);
6333 Id
:= Corresponding_Spec
(Proper_Body
(Unit
(Library_Unit
(B
))));
6336 Ensure_Freeze_Node
(Id
);
6337 return Freeze_Node
(Id
);
6338 end Package_Freeze_Node
;
6344 function True_Parent
(N
: Node_Id
) return Node_Id
is
6346 if Nkind
(Parent
(N
)) = N_Subunit
then
6347 return Parent
(Corresponding_Stub
(Parent
(N
)));
6353 -- Start of processing of Freeze_Subprogram_Body
6356 -- If the instance and the generic body appear within the same unit, and
6357 -- the instance preceeds the generic, the freeze node for the instance
6358 -- must appear after that of the generic. If the generic is nested
6359 -- within another instance I2, then current instance must be frozen
6360 -- after I2. In both cases, the freeze nodes are those of enclosing
6361 -- packages. Otherwise, the freeze node is placed at the end of the
6362 -- current declarative part.
6364 Enc_G
:= Enclosing_Body
(Gen_Body
);
6365 Enc_I
:= Enclosing_Body
(Inst_Node
);
6366 Ensure_Freeze_Node
(Pack_Id
);
6367 F_Node
:= Freeze_Node
(Pack_Id
);
6369 if Is_Generic_Instance
(Par
)
6370 and then Present
(Freeze_Node
(Par
))
6372 In_Same_Declarative_Part
(Freeze_Node
(Par
), Inst_Node
)
6374 if ABE_Is_Certain
(Get_Package_Instantiation_Node
(Par
)) then
6376 -- The parent was a premature instantiation. Insert freeze node at
6377 -- the end the current declarative part.
6379 Insert_After_Last_Decl
(Inst_Node
, F_Node
);
6382 Insert_After
(Freeze_Node
(Par
), F_Node
);
6385 -- The body enclosing the instance should be frozen after the body that
6386 -- includes the generic, because the body of the instance may make
6387 -- references to entities therein. If the two are not in the same
6388 -- declarative part, or if the one enclosing the instance is frozen
6389 -- already, freeze the instance at the end of the current declarative
6392 elsif Is_Generic_Instance
(Par
)
6393 and then Present
(Freeze_Node
(Par
))
6394 and then Present
(Enc_I
)
6396 if In_Same_Declarative_Part
(Freeze_Node
(Par
), Enc_I
)
6398 (Nkind
(Enc_I
) = N_Package_Body
6400 In_Same_Declarative_Part
(Freeze_Node
(Par
), Parent
(Enc_I
)))
6402 -- The enclosing package may contain several instances. Rather
6403 -- than computing the earliest point at which to insert its
6404 -- freeze node, we place it at the end of the declarative part
6405 -- of the parent of the generic.
6407 Insert_After_Last_Decl
6408 (Freeze_Node
(Par
), Package_Freeze_Node
(Enc_I
));
6411 Insert_After_Last_Decl
(Inst_Node
, F_Node
);
6413 elsif Present
(Enc_G
)
6414 and then Present
(Enc_I
)
6415 and then Enc_G
/= Enc_I
6416 and then Earlier
(Inst_Node
, Gen_Body
)
6418 if Nkind
(Enc_G
) = N_Package_Body
then
6419 E_G_Id
:= Corresponding_Spec
(Enc_G
);
6420 else pragma Assert
(Nkind
(Enc_G
) = N_Package_Body_Stub
);
6422 Corresponding_Spec
(Proper_Body
(Unit
(Library_Unit
(Enc_G
))));
6425 -- Freeze package that encloses instance, and place node after
6426 -- package that encloses generic. If enclosing package is already
6427 -- frozen we have to assume it is at the proper place. This may be
6428 -- a potential ABE that requires dynamic checking. Do not add a
6429 -- freeze node if the package that encloses the generic is inside
6430 -- the body that encloses the instance, because the freeze node
6431 -- would be in the wrong scope. Additional contortions needed if
6432 -- the bodies are within a subunit.
6435 Enclosing_Body
: Node_Id
;
6438 if Nkind
(Enc_I
) = N_Package_Body_Stub
then
6439 Enclosing_Body
:= Proper_Body
(Unit
(Library_Unit
(Enc_I
)));
6441 Enclosing_Body
:= Enc_I
;
6444 if Parent
(List_Containing
(Enc_G
)) /= Enclosing_Body
then
6445 Insert_After_Last_Decl
(Enc_G
, Package_Freeze_Node
(Enc_I
));
6449 -- Freeze enclosing subunit before instance
6451 Ensure_Freeze_Node
(E_G_Id
);
6453 if not Is_List_Member
(Freeze_Node
(E_G_Id
)) then
6454 Insert_After
(Enc_G
, Freeze_Node
(E_G_Id
));
6457 Insert_After_Last_Decl
(Inst_Node
, F_Node
);
6460 -- If none of the above, insert freeze node at the end of the current
6461 -- declarative part.
6463 Insert_After_Last_Decl
(Inst_Node
, F_Node
);
6465 end Freeze_Subprogram_Body
;
6471 function Get_Gen_Id
(E
: Assoc_Ptr
) return Entity_Id
is
6473 return Generic_Renamings
.Table
(E
).Gen_Id
;
6476 ---------------------
6477 -- Get_Instance_Of --
6478 ---------------------
6480 function Get_Instance_Of
(A
: Entity_Id
) return Entity_Id
is
6481 Res
: constant Assoc_Ptr
:= Generic_Renamings_HTable
.Get
(A
);
6484 if Res
/= Assoc_Null
then
6485 return Generic_Renamings
.Table
(Res
).Act_Id
;
6487 -- On exit, entity is not instantiated: not a generic parameter, or
6488 -- else parameter of an inner generic unit.
6492 end Get_Instance_Of
;
6494 ------------------------------------
6495 -- Get_Package_Instantiation_Node --
6496 ------------------------------------
6498 function Get_Package_Instantiation_Node
(A
: Entity_Id
) return Node_Id
is
6499 Decl
: Node_Id
:= Unit_Declaration_Node
(A
);
6503 -- If the Package_Instantiation attribute has been set on the package
6504 -- entity, then use it directly when it (or its Original_Node) refers
6505 -- to an N_Package_Instantiation node. In principle it should be
6506 -- possible to have this field set in all cases, which should be
6507 -- investigated, and would allow this function to be significantly
6510 if Present
(Package_Instantiation
(A
)) then
6511 if Nkind
(Package_Instantiation
(A
)) = N_Package_Instantiation
then
6512 return Package_Instantiation
(A
);
6514 elsif Nkind
(Original_Node
(Package_Instantiation
(A
)))
6515 = N_Package_Instantiation
6517 return Original_Node
(Package_Instantiation
(A
));
6521 -- If the instantiation is a compilation unit that does not need body
6522 -- then the instantiation node has been rewritten as a package
6523 -- declaration for the instance, and we return the original node.
6525 -- If it is a compilation unit and the instance node has not been
6526 -- rewritten, then it is still the unit of the compilation. Finally, if
6527 -- a body is present, this is a parent of the main unit whose body has
6528 -- been compiled for inlining purposes, and the instantiation node has
6529 -- been rewritten with the instance body.
6531 -- Otherwise the instantiation node appears after the declaration. If
6532 -- the entity is a formal package, the declaration may have been
6533 -- rewritten as a generic declaration (in the case of a formal with box)
6534 -- or left as a formal package declaration if it has actuals, and is
6535 -- found with a forward search.
6537 if Nkind
(Parent
(Decl
)) = N_Compilation_Unit
then
6538 if Nkind
(Decl
) = N_Package_Declaration
6539 and then Present
(Corresponding_Body
(Decl
))
6541 Decl
:= Unit_Declaration_Node
(Corresponding_Body
(Decl
));
6544 if Nkind
(Original_Node
(Decl
)) = N_Package_Instantiation
then
6545 return Original_Node
(Decl
);
6547 return Unit
(Parent
(Decl
));
6550 elsif Nkind
(Decl
) = N_Package_Declaration
6551 and then Nkind
(Original_Node
(Decl
)) = N_Formal_Package_Declaration
6553 return Original_Node
(Decl
);
6556 Inst
:= Next
(Decl
);
6557 while Nkind
(Inst
) /= N_Package_Instantiation
6558 and then Nkind
(Inst
) /= N_Formal_Package_Declaration
6565 end Get_Package_Instantiation_Node
;
6567 ------------------------
6568 -- Has_Been_Exchanged --
6569 ------------------------
6571 function Has_Been_Exchanged
(E
: Entity_Id
) return Boolean is
6575 Next
:= First_Elmt
(Exchanged_Views
);
6576 while Present
(Next
) loop
6577 if Full_View
(Node
(Next
)) = E
then
6585 end Has_Been_Exchanged
;
6591 function Hash
(F
: Entity_Id
) return HTable_Range
is
6593 return HTable_Range
(F
mod HTable_Size
);
6596 ------------------------
6597 -- Hide_Current_Scope --
6598 ------------------------
6600 procedure Hide_Current_Scope
is
6601 C
: constant Entity_Id
:= Current_Scope
;
6605 Set_Is_Hidden_Open_Scope
(C
);
6607 E
:= First_Entity
(C
);
6608 while Present
(E
) loop
6609 if Is_Immediately_Visible
(E
) then
6610 Set_Is_Immediately_Visible
(E
, False);
6611 Append_Elmt
(E
, Hidden_Entities
);
6617 -- Make the scope name invisible as well. This is necessary, but might
6618 -- conflict with calls to Rtsfind later on, in case the scope is a
6619 -- predefined one. There is no clean solution to this problem, so for
6620 -- now we depend on the user not redefining Standard itself in one of
6621 -- the parent units.
6623 if Is_Immediately_Visible
(C
)
6624 and then C
/= Standard_Standard
6626 Set_Is_Immediately_Visible
(C
, False);
6627 Append_Elmt
(C
, Hidden_Entities
);
6630 end Hide_Current_Scope
;
6636 procedure Init_Env
is
6637 Saved
: Instance_Env
;
6640 Saved
.Instantiated_Parent
:= Current_Instantiated_Parent
;
6641 Saved
.Exchanged_Views
:= Exchanged_Views
;
6642 Saved
.Hidden_Entities
:= Hidden_Entities
;
6643 Saved
.Current_Sem_Unit
:= Current_Sem_Unit
;
6644 Saved
.Parent_Unit_Visible
:= Parent_Unit_Visible
;
6645 Saved
.Instance_Parent_Unit
:= Instance_Parent_Unit
;
6647 -- Save configuration switches. These may be reset if the unit is a
6648 -- predefined unit, and the current mode is not Ada 2005.
6650 Save_Opt_Config_Switches
(Saved
.Switches
);
6652 Instance_Envs
.Append
(Saved
);
6654 Exchanged_Views
:= New_Elmt_List
;
6655 Hidden_Entities
:= New_Elmt_List
;
6657 -- Make dummy entry for Instantiated parent. If generic unit is legal,
6658 -- this is set properly in Set_Instance_Env.
6660 Current_Instantiated_Parent
:=
6661 (Current_Scope
, Current_Scope
, Assoc_Null
);
6664 ------------------------------
6665 -- In_Same_Declarative_Part --
6666 ------------------------------
6668 function In_Same_Declarative_Part
6670 Inst
: Node_Id
) return Boolean
6672 Decls
: constant Node_Id
:= Parent
(F_Node
);
6673 Nod
: Node_Id
:= Parent
(Inst
);
6676 while Present
(Nod
) loop
6680 elsif Nkind
(Nod
) = N_Subprogram_Body
6681 or else Nkind
(Nod
) = N_Package_Body
6682 or else Nkind
(Nod
) = N_Task_Body
6683 or else Nkind
(Nod
) = N_Protected_Body
6684 or else Nkind
(Nod
) = N_Block_Statement
6688 elsif Nkind
(Nod
) = N_Subunit
then
6689 Nod
:= Corresponding_Stub
(Nod
);
6691 elsif Nkind
(Nod
) = N_Compilation_Unit
then
6694 Nod
:= Parent
(Nod
);
6699 end In_Same_Declarative_Part
;
6701 ---------------------
6702 -- In_Main_Context --
6703 ---------------------
6705 function In_Main_Context
(E
: Entity_Id
) return Boolean is
6711 if not Is_Compilation_Unit
(E
)
6712 or else Ekind
(E
) /= E_Package
6713 or else In_Private_Part
(E
)
6718 Context
:= Context_Items
(Cunit
(Main_Unit
));
6720 Clause
:= First
(Context
);
6721 while Present
(Clause
) loop
6722 if Nkind
(Clause
) = N_With_Clause
then
6723 Nam
:= Name
(Clause
);
6725 -- If the current scope is part of the context of the main unit,
6726 -- analysis of the corresponding with_clause is not complete, and
6727 -- the entity is not set. We use the Chars field directly, which
6728 -- might produce false positives in rare cases, but guarantees
6729 -- that we produce all the instance bodies we will need.
6731 if (Nkind
(Nam
) = N_Identifier
6732 and then Chars
(Nam
) = Chars
(E
))
6733 or else (Nkind
(Nam
) = N_Selected_Component
6734 and then Chars
(Selector_Name
(Nam
)) = Chars
(E
))
6744 end In_Main_Context
;
6746 ---------------------
6747 -- Inherit_Context --
6748 ---------------------
6750 procedure Inherit_Context
(Gen_Decl
: Node_Id
; Inst
: Node_Id
) is
6751 Current_Context
: List_Id
;
6752 Current_Unit
: Node_Id
;
6757 if Nkind
(Parent
(Gen_Decl
)) = N_Compilation_Unit
then
6759 -- The inherited context is attached to the enclosing compilation
6760 -- unit. This is either the main unit, or the declaration for the
6761 -- main unit (in case the instantation appears within the package
6762 -- declaration and the main unit is its body).
6764 Current_Unit
:= Parent
(Inst
);
6765 while Present
(Current_Unit
)
6766 and then Nkind
(Current_Unit
) /= N_Compilation_Unit
6768 Current_Unit
:= Parent
(Current_Unit
);
6771 Current_Context
:= Context_Items
(Current_Unit
);
6773 Item
:= First
(Context_Items
(Parent
(Gen_Decl
)));
6774 while Present
(Item
) loop
6775 if Nkind
(Item
) = N_With_Clause
then
6776 New_I
:= New_Copy
(Item
);
6777 Set_Implicit_With
(New_I
, True);
6778 Append
(New_I
, Current_Context
);
6784 end Inherit_Context
;
6790 procedure Initialize
is
6792 Generic_Renamings
.Init
;
6795 Generic_Renamings_HTable
.Reset
;
6796 Circularity_Detected
:= False;
6797 Exchanged_Views
:= No_Elist
;
6798 Hidden_Entities
:= No_Elist
;
6801 ----------------------------
6802 -- Insert_After_Last_Decl --
6803 ----------------------------
6805 procedure Insert_After_Last_Decl
(N
: Node_Id
; F_Node
: Node_Id
) is
6806 L
: List_Id
:= List_Containing
(N
);
6807 P
: constant Node_Id
:= Parent
(L
);
6810 if not Is_List_Member
(F_Node
) then
6811 if Nkind
(P
) = N_Package_Specification
6812 and then L
= Visible_Declarations
(P
)
6813 and then Present
(Private_Declarations
(P
))
6814 and then not Is_Empty_List
(Private_Declarations
(P
))
6816 L
:= Private_Declarations
(P
);
6819 Insert_After
(Last
(L
), F_Node
);
6821 end Insert_After_Last_Decl
;
6827 procedure Install_Body
6828 (Act_Body
: Node_Id
;
6833 Act_Id
: constant Entity_Id
:= Corresponding_Spec
(Act_Body
);
6834 Act_Unit
: constant Node_Id
:= Unit
(Cunit
(Get_Source_Unit
(N
)));
6835 Gen_Id
: constant Entity_Id
:= Corresponding_Spec
(Gen_Body
);
6836 Par
: constant Entity_Id
:= Scope
(Gen_Id
);
6837 Gen_Unit
: constant Node_Id
:=
6838 Unit
(Cunit
(Get_Source_Unit
(Gen_Decl
)));
6839 Orig_Body
: Node_Id
:= Gen_Body
;
6841 Body_Unit
: Node_Id
;
6843 Must_Delay
: Boolean;
6845 function Enclosing_Subp
(Id
: Entity_Id
) return Entity_Id
;
6846 -- Find subprogram (if any) that encloses instance and/or generic body
6848 function True_Sloc
(N
: Node_Id
) return Source_Ptr
;
6849 -- If the instance is nested inside a generic unit, the Sloc of the
6850 -- instance indicates the place of the original definition, not the
6851 -- point of the current enclosing instance. Pending a better usage of
6852 -- Slocs to indicate instantiation places, we determine the place of
6853 -- origin of a node by finding the maximum sloc of any ancestor node.
6854 -- Why is this not equivalent to Top_Level_Location ???
6856 --------------------
6857 -- Enclosing_Subp --
6858 --------------------
6860 function Enclosing_Subp
(Id
: Entity_Id
) return Entity_Id
is
6861 Scop
: Entity_Id
:= Scope
(Id
);
6864 while Scop
/= Standard_Standard
6865 and then not Is_Overloadable
(Scop
)
6867 Scop
:= Scope
(Scop
);
6877 function True_Sloc
(N
: Node_Id
) return Source_Ptr
is
6884 while Present
(N1
) and then N1
/= Act_Unit
loop
6885 if Sloc
(N1
) > Res
then
6895 -- Start of processing for Install_Body
6898 -- If the body is a subunit, the freeze point is the corresponding
6899 -- stub in the current compilation, not the subunit itself.
6901 if Nkind
(Parent
(Gen_Body
)) = N_Subunit
then
6902 Orig_Body
:= Corresponding_Stub
(Parent
(Gen_Body
));
6904 Orig_Body
:= Gen_Body
;
6907 Body_Unit
:= Unit
(Cunit
(Get_Source_Unit
(Orig_Body
)));
6909 -- If the instantiation and the generic definition appear in the same
6910 -- package declaration, this is an early instantiation. If they appear
6911 -- in the same declarative part, it is an early instantiation only if
6912 -- the generic body appears textually later, and the generic body is
6913 -- also in the main unit.
6915 -- If instance is nested within a subprogram, and the generic body is
6916 -- not, the instance is delayed because the enclosing body is. If
6917 -- instance and body are within the same scope, or the same sub-
6918 -- program body, indicate explicitly that the instance is delayed.
6921 (Gen_Unit
= Act_Unit
6922 and then ((Nkind
(Gen_Unit
) = N_Package_Declaration
)
6923 or else Nkind
(Gen_Unit
) = N_Generic_Package_Declaration
6924 or else (Gen_Unit
= Body_Unit
6925 and then True_Sloc
(N
) < Sloc
(Orig_Body
)))
6926 and then Is_In_Main_Unit
(Gen_Unit
)
6927 and then (Scope
(Act_Id
) = Scope
(Gen_Id
)
6929 Enclosing_Subp
(Act_Id
) = Enclosing_Subp
(Gen_Id
)));
6931 -- If this is an early instantiation, the freeze node is placed after
6932 -- the generic body. Otherwise, if the generic appears in an instance,
6933 -- we cannot freeze the current instance until the outer one is frozen.
6934 -- This is only relevant if the current instance is nested within some
6935 -- inner scope not itself within the outer instance. If this scope is
6936 -- a package body in the same declarative part as the outer instance,
6937 -- then that body needs to be frozen after the outer instance. Finally,
6938 -- if no delay is needed, we place the freeze node at the end of the
6939 -- current declarative part.
6941 if Expander_Active
then
6942 Ensure_Freeze_Node
(Act_Id
);
6943 F_Node
:= Freeze_Node
(Act_Id
);
6946 Insert_After
(Orig_Body
, F_Node
);
6948 elsif Is_Generic_Instance
(Par
)
6949 and then Present
(Freeze_Node
(Par
))
6950 and then Scope
(Act_Id
) /= Par
6952 -- Freeze instance of inner generic after instance of enclosing
6955 if In_Same_Declarative_Part
(Freeze_Node
(Par
), N
) then
6956 Insert_After
(Freeze_Node
(Par
), F_Node
);
6958 -- Freeze package enclosing instance of inner generic after
6959 -- instance of enclosing generic.
6961 elsif Nkind
(Parent
(N
)) = N_Package_Body
6962 and then In_Same_Declarative_Part
(Freeze_Node
(Par
), Parent
(N
))
6966 Enclosing
: constant Entity_Id
:=
6967 Corresponding_Spec
(Parent
(N
));
6970 Insert_After_Last_Decl
(N
, F_Node
);
6971 Ensure_Freeze_Node
(Enclosing
);
6973 if not Is_List_Member
(Freeze_Node
(Enclosing
)) then
6974 Insert_After
(Freeze_Node
(Par
), Freeze_Node
(Enclosing
));
6979 Insert_After_Last_Decl
(N
, F_Node
);
6983 Insert_After_Last_Decl
(N
, F_Node
);
6987 Set_Is_Frozen
(Act_Id
);
6988 Insert_Before
(N
, Act_Body
);
6989 Mark_Rewrite_Insertion
(Act_Body
);
6992 -----------------------------
6993 -- Install_Formal_Packages --
6994 -----------------------------
6996 procedure Install_Formal_Packages
(Par
: Entity_Id
) is
7000 E
:= First_Entity
(Par
);
7001 while Present
(E
) loop
7002 if Ekind
(E
) = E_Package
7003 and then Nkind
(Parent
(E
)) = N_Package_Renaming_Declaration
7005 -- If this is the renaming for the parent instance, done
7007 if Renamed_Object
(E
) = Par
then
7010 -- The visibility of a formal of an enclosing generic is
7013 elsif Denotes_Formal_Package
(E
) then
7016 elsif Present
(Associated_Formal_Package
(E
))
7017 and then Box_Present
(Parent
(Associated_Formal_Package
(E
)))
7019 Check_Generic_Actuals
(Renamed_Object
(E
), True);
7020 Set_Is_Hidden
(E
, False);
7026 end Install_Formal_Packages
;
7028 --------------------
7029 -- Install_Parent --
7030 --------------------
7032 procedure Install_Parent
(P
: Entity_Id
; In_Body
: Boolean := False) is
7033 Ancestors
: constant Elist_Id
:= New_Elmt_List
;
7034 S
: constant Entity_Id
:= Current_Scope
;
7035 Inst_Par
: Entity_Id
;
7036 First_Par
: Entity_Id
;
7037 Inst_Node
: Node_Id
;
7038 Gen_Par
: Entity_Id
;
7039 First_Gen
: Entity_Id
;
7042 procedure Install_Noninstance_Specs
(Par
: Entity_Id
);
7043 -- Install the scopes of noninstance parent units ending with Par
7045 procedure Install_Spec
(Par
: Entity_Id
);
7046 -- The child unit is within the declarative part of the parent, so
7047 -- the declarations within the parent are immediately visible.
7049 -------------------------------
7050 -- Install_Noninstance_Specs --
7051 -------------------------------
7053 procedure Install_Noninstance_Specs
(Par
: Entity_Id
) is
7056 and then Par
/= Standard_Standard
7057 and then not In_Open_Scopes
(Par
)
7059 Install_Noninstance_Specs
(Scope
(Par
));
7062 end Install_Noninstance_Specs
;
7068 procedure Install_Spec
(Par
: Entity_Id
) is
7069 Spec
: constant Node_Id
:=
7070 Specification
(Unit_Declaration_Node
(Par
));
7073 -- If this parent of the child instance is a top-level unit,
7074 -- then record the unit and its visibility for later resetting
7075 -- in Remove_Parent. We exclude units that are generic instances,
7076 -- as we only want to record this information for the ultimate
7077 -- top-level noninstance parent (is that always correct???).
7079 if Scope
(Par
) = Standard_Standard
7080 and then not Is_Generic_Instance
(Par
)
7082 Parent_Unit_Visible
:= Is_Immediately_Visible
(Par
);
7083 Instance_Parent_Unit
:= Par
;
7086 -- Open the parent scope and make it and its declarations visible.
7087 -- If this point is not within a body, then only the visible
7088 -- declarations should be made visible, and installation of the
7089 -- private declarations is deferred until the appropriate point
7090 -- within analysis of the spec being instantiated (see the handling
7091 -- of parent visibility in Analyze_Package_Specification). This is
7092 -- relaxed in the case where the parent unit is Ada.Tags, to avoid
7093 -- private view problems that occur when compiling instantiations of
7094 -- a generic child of that package (Generic_Dispatching_Constructor).
7095 -- If the instance freezes a tagged type, inlinings of operations
7096 -- from Ada.Tags may need the full view of type Tag. If inlining took
7097 -- proper account of establishing visibility of inlined subprograms'
7098 -- parents then it should be possible to remove this
7099 -- special check. ???
7102 Set_Is_Immediately_Visible
(Par
);
7103 Install_Visible_Declarations
(Par
);
7104 Set_Use
(Visible_Declarations
(Spec
));
7106 if In_Body
or else Is_RTU
(Par
, Ada_Tags
) then
7107 Install_Private_Declarations
(Par
);
7108 Set_Use
(Private_Declarations
(Spec
));
7112 -- Start of processing for Install_Parent
7115 -- We need to install the parent instance to compile the instantiation
7116 -- of the child, but the child instance must appear in the current
7117 -- scope. Given that we cannot place the parent above the current scope
7118 -- in the scope stack, we duplicate the current scope and unstack both
7119 -- after the instantiation is complete.
7121 -- If the parent is itself the instantiation of a child unit, we must
7122 -- also stack the instantiation of its parent, and so on. Each such
7123 -- ancestor is the prefix of the name in a prior instantiation.
7125 -- If this is a nested instance, the parent unit itself resolves to
7126 -- a renaming of the parent instance, whose declaration we need.
7128 -- Finally, the parent may be a generic (not an instance) when the
7129 -- child unit appears as a formal package.
7133 if Present
(Renamed_Entity
(Inst_Par
)) then
7134 Inst_Par
:= Renamed_Entity
(Inst_Par
);
7137 First_Par
:= Inst_Par
;
7140 Generic_Parent
(Specification
(Unit_Declaration_Node
(Inst_Par
)));
7142 First_Gen
:= Gen_Par
;
7144 while Present
(Gen_Par
)
7145 and then Is_Child_Unit
(Gen_Par
)
7147 -- Load grandparent instance as well
7149 Inst_Node
:= Get_Package_Instantiation_Node
(Inst_Par
);
7151 if Nkind
(Name
(Inst_Node
)) = N_Expanded_Name
then
7152 Inst_Par
:= Entity
(Prefix
(Name
(Inst_Node
)));
7154 if Present
(Renamed_Entity
(Inst_Par
)) then
7155 Inst_Par
:= Renamed_Entity
(Inst_Par
);
7160 (Specification
(Unit_Declaration_Node
(Inst_Par
)));
7162 if Present
(Gen_Par
) then
7163 Prepend_Elmt
(Inst_Par
, Ancestors
);
7166 -- Parent is not the name of an instantiation
7168 Install_Noninstance_Specs
(Inst_Par
);
7180 if Present
(First_Gen
) then
7181 Append_Elmt
(First_Par
, Ancestors
);
7184 Install_Noninstance_Specs
(First_Par
);
7187 if not Is_Empty_Elmt_List
(Ancestors
) then
7188 Elmt
:= First_Elmt
(Ancestors
);
7190 while Present
(Elmt
) loop
7191 Install_Spec
(Node
(Elmt
));
7192 Install_Formal_Packages
(Node
(Elmt
));
7203 --------------------------------
7204 -- Instantiate_Formal_Package --
7205 --------------------------------
7207 function Instantiate_Formal_Package
7210 Analyzed_Formal
: Node_Id
) return List_Id
7212 Loc
: constant Source_Ptr
:= Sloc
(Actual
);
7213 Actual_Pack
: Entity_Id
;
7214 Formal_Pack
: Entity_Id
;
7215 Gen_Parent
: Entity_Id
;
7218 Parent_Spec
: Node_Id
;
7220 procedure Find_Matching_Actual
7222 Act
: in out Entity_Id
);
7223 -- We need to associate each formal entity in the formal package
7224 -- with the corresponding entity in the actual package. The actual
7225 -- package has been analyzed and possibly expanded, and as a result
7226 -- there is no one-to-one correspondence between the two lists (for
7227 -- example, the actual may include subtypes, itypes, and inherited
7228 -- primitive operations, interspersed among the renaming declarations
7229 -- for the actuals) . We retrieve the corresponding actual by name
7230 -- because each actual has the same name as the formal, and they do
7231 -- appear in the same order.
7233 function Get_Formal_Entity
(N
: Node_Id
) return Entity_Id
;
7234 -- Retrieve entity of defining entity of generic formal parameter.
7235 -- Only the declarations of formals need to be considered when
7236 -- linking them to actuals, but the declarative list may include
7237 -- internal entities generated during analysis, and those are ignored.
7239 procedure Match_Formal_Entity
7240 (Formal_Node
: Node_Id
;
7241 Formal_Ent
: Entity_Id
;
7242 Actual_Ent
: Entity_Id
);
7243 -- Associates the formal entity with the actual. In the case
7244 -- where Formal_Ent is a formal package, this procedure iterates
7245 -- through all of its formals and enters associations betwen the
7246 -- actuals occurring in the formal package's corresponding actual
7247 -- package (given by Actual_Ent) and the formal package's formal
7248 -- parameters. This procedure recurses if any of the parameters is
7249 -- itself a package.
7251 function Is_Instance_Of
7252 (Act_Spec
: Entity_Id
;
7253 Gen_Anc
: Entity_Id
) return Boolean;
7254 -- The actual can be an instantiation of a generic within another
7255 -- instance, in which case there is no direct link from it to the
7256 -- original generic ancestor. In that case, we recognize that the
7257 -- ultimate ancestor is the same by examining names and scopes.
7259 procedure Map_Entities
(Form
: Entity_Id
; Act
: Entity_Id
);
7260 -- Within the generic part, entities in the formal package are
7261 -- visible. To validate subsequent type declarations, indicate
7262 -- the correspondence betwen the entities in the analyzed formal,
7263 -- and the entities in the actual package. There are three packages
7264 -- involved in the instantiation of a formal package: the parent
7265 -- generic P1 which appears in the generic declaration, the fake
7266 -- instantiation P2 which appears in the analyzed generic, and whose
7267 -- visible entities may be used in subsequent formals, and the actual
7268 -- P3 in the instance. To validate subsequent formals, me indicate
7269 -- that the entities in P2 are mapped into those of P3. The mapping of
7270 -- entities has to be done recursively for nested packages.
7272 procedure Process_Nested_Formal
(Formal
: Entity_Id
);
7273 -- If the current formal is declared with a box, its own formals are
7274 -- visible in the instance, as they were in the generic, and their
7275 -- Hidden flag must be reset. If some of these formals are themselves
7276 -- packages declared with a box, the processing must be recursive.
7278 --------------------------
7279 -- Find_Matching_Actual --
7280 --------------------------
7282 procedure Find_Matching_Actual
7284 Act
: in out Entity_Id
)
7286 Formal_Ent
: Entity_Id
;
7289 case Nkind
(Original_Node
(F
)) is
7290 when N_Formal_Object_Declaration |
7291 N_Formal_Type_Declaration
=>
7292 Formal_Ent
:= Defining_Identifier
(F
);
7294 while Chars
(Act
) /= Chars
(Formal_Ent
) loop
7298 when N_Formal_Subprogram_Declaration |
7299 N_Formal_Package_Declaration |
7300 N_Package_Declaration |
7301 N_Generic_Package_Declaration
=>
7302 Formal_Ent
:= Defining_Entity
(F
);
7304 while Chars
(Act
) /= Chars
(Formal_Ent
) loop
7309 raise Program_Error
;
7311 end Find_Matching_Actual
;
7313 -------------------------
7314 -- Match_Formal_Entity --
7315 -------------------------
7317 procedure Match_Formal_Entity
7318 (Formal_Node
: Node_Id
;
7319 Formal_Ent
: Entity_Id
;
7320 Actual_Ent
: Entity_Id
)
7322 Act_Pkg
: Entity_Id
;
7325 Set_Instance_Of
(Formal_Ent
, Actual_Ent
);
7327 if Ekind
(Actual_Ent
) = E_Package
then
7329 -- Record associations for each parameter
7331 Act_Pkg
:= Actual_Ent
;
7334 A_Ent
: Entity_Id
:= First_Entity
(Act_Pkg
);
7343 -- Retrieve the actual given in the formal package declaration
7345 Actual
:= Entity
(Name
(Original_Node
(Formal_Node
)));
7347 -- The actual in the formal package declaration may be a
7348 -- renamed generic package, in which case we want to retrieve
7349 -- the original generic in order to traverse its formal part.
7351 if Present
(Renamed_Entity
(Actual
)) then
7352 Gen_Decl
:= Unit_Declaration_Node
(Renamed_Entity
(Actual
));
7354 Gen_Decl
:= Unit_Declaration_Node
(Actual
);
7357 Formals
:= Generic_Formal_Declarations
(Gen_Decl
);
7359 if Present
(Formals
) then
7360 F_Node
:= First_Non_Pragma
(Formals
);
7365 while Present
(A_Ent
)
7366 and then Present
(F_Node
)
7367 and then A_Ent
/= First_Private_Entity
(Act_Pkg
)
7369 F_Ent
:= Get_Formal_Entity
(F_Node
);
7371 if Present
(F_Ent
) then
7373 -- This is a formal of the original package. Record
7374 -- association and recurse.
7376 Find_Matching_Actual
(F_Node
, A_Ent
);
7377 Match_Formal_Entity
(F_Node
, F_Ent
, A_Ent
);
7378 Next_Entity
(A_Ent
);
7381 Next_Non_Pragma
(F_Node
);
7385 end Match_Formal_Entity
;
7387 -----------------------
7388 -- Get_Formal_Entity --
7389 -----------------------
7391 function Get_Formal_Entity
(N
: Node_Id
) return Entity_Id
is
7392 Kind
: constant Node_Kind
:= Nkind
(Original_Node
(N
));
7395 when N_Formal_Object_Declaration
=>
7396 return Defining_Identifier
(N
);
7398 when N_Formal_Type_Declaration
=>
7399 return Defining_Identifier
(N
);
7401 when N_Formal_Subprogram_Declaration
=>
7402 return Defining_Unit_Name
(Specification
(N
));
7404 when N_Formal_Package_Declaration
=>
7405 return Defining_Identifier
(Original_Node
(N
));
7407 when N_Generic_Package_Declaration
=>
7408 return Defining_Identifier
(Original_Node
(N
));
7410 -- All other declarations are introduced by semantic analysis and
7411 -- have no match in the actual.
7416 end Get_Formal_Entity
;
7418 --------------------
7419 -- Is_Instance_Of --
7420 --------------------
7422 function Is_Instance_Of
7423 (Act_Spec
: Entity_Id
;
7424 Gen_Anc
: Entity_Id
) return Boolean
7426 Gen_Par
: constant Entity_Id
:= Generic_Parent
(Act_Spec
);
7429 if No
(Gen_Par
) then
7432 -- Simplest case: the generic parent of the actual is the formal
7434 elsif Gen_Par
= Gen_Anc
then
7437 elsif Chars
(Gen_Par
) /= Chars
(Gen_Anc
) then
7440 -- The actual may be obtained through several instantiations. Its
7441 -- scope must itself be an instance of a generic declared in the
7442 -- same scope as the formal. Any other case is detected above.
7444 elsif not Is_Generic_Instance
(Scope
(Gen_Par
)) then
7448 return Generic_Parent
(Parent
(Scope
(Gen_Par
))) = Scope
(Gen_Anc
);
7456 procedure Map_Entities
(Form
: Entity_Id
; Act
: Entity_Id
) is
7461 Set_Instance_Of
(Form
, Act
);
7463 -- Traverse formal and actual package to map the corresponding
7464 -- entities. We skip over internal entities that may be generated
7465 -- during semantic analysis, and find the matching entities by
7466 -- name, given that they must appear in the same order.
7468 E1
:= First_Entity
(Form
);
7469 E2
:= First_Entity
(Act
);
7471 and then E1
/= First_Private_Entity
(Form
)
7473 -- Could this test be a single condition???
7474 -- Seems like it could, and isn't FPE (Form) a constant anyway???
7476 if not Is_Internal
(E1
)
7477 and then Present
(Parent
(E1
))
7478 and then not Is_Class_Wide_Type
(E1
)
7479 and then not Is_Internal_Name
(Chars
(E1
))
7482 and then Chars
(E2
) /= Chars
(E1
)
7490 Set_Instance_Of
(E1
, E2
);
7493 and then Is_Tagged_Type
(E2
)
7496 (Class_Wide_Type
(E1
), Class_Wide_Type
(E2
));
7499 if Ekind
(E1
) = E_Package
7500 and then No
(Renamed_Object
(E1
))
7502 Map_Entities
(E1
, E2
);
7511 ---------------------------
7512 -- Process_Nested_Formal --
7513 ---------------------------
7515 procedure Process_Nested_Formal
(Formal
: Entity_Id
) is
7519 if Present
(Associated_Formal_Package
(Formal
))
7520 and then Box_Present
(Parent
(Associated_Formal_Package
(Formal
)))
7522 Ent
:= First_Entity
(Formal
);
7523 while Present
(Ent
) loop
7524 Set_Is_Hidden
(Ent
, False);
7525 Set_Is_Visible_Formal
(Ent
);
7526 Set_Is_Potentially_Use_Visible
7527 (Ent
, Is_Potentially_Use_Visible
(Formal
));
7529 if Ekind
(Ent
) = E_Package
then
7530 exit when Renamed_Entity
(Ent
) = Renamed_Entity
(Formal
);
7531 Process_Nested_Formal
(Ent
);
7537 end Process_Nested_Formal
;
7539 -- Start of processing for Instantiate_Formal_Package
7544 if not Is_Entity_Name
(Actual
)
7545 or else Ekind
(Entity
(Actual
)) /= E_Package
7548 ("expect package instance to instantiate formal", Actual
);
7549 Abandon_Instantiation
(Actual
);
7550 raise Program_Error
;
7553 Actual_Pack
:= Entity
(Actual
);
7554 Set_Is_Instantiated
(Actual_Pack
);
7556 -- The actual may be a renamed package, or an outer generic formal
7557 -- package whose instantiation is converted into a renaming.
7559 if Present
(Renamed_Object
(Actual_Pack
)) then
7560 Actual_Pack
:= Renamed_Object
(Actual_Pack
);
7563 if Nkind
(Analyzed_Formal
) = N_Formal_Package_Declaration
then
7564 Gen_Parent
:= Get_Instance_Of
(Entity
(Name
(Analyzed_Formal
)));
7565 Formal_Pack
:= Defining_Identifier
(Analyzed_Formal
);
7568 Generic_Parent
(Specification
(Analyzed_Formal
));
7570 Defining_Unit_Name
(Specification
(Analyzed_Formal
));
7573 if Nkind
(Parent
(Actual_Pack
)) = N_Defining_Program_Unit_Name
then
7574 Parent_Spec
:= Specification
(Unit_Declaration_Node
(Actual_Pack
));
7576 Parent_Spec
:= Parent
(Actual_Pack
);
7579 if Gen_Parent
= Any_Id
then
7581 ("previous error in declaration of formal package", Actual
);
7582 Abandon_Instantiation
(Actual
);
7585 Is_Instance_Of
(Parent_Spec
, Get_Instance_Of
(Gen_Parent
))
7591 ("actual parameter must be instance of&", Actual
, Gen_Parent
);
7592 Abandon_Instantiation
(Actual
);
7595 Set_Instance_Of
(Defining_Identifier
(Formal
), Actual_Pack
);
7596 Map_Entities
(Formal_Pack
, Actual_Pack
);
7599 Make_Package_Renaming_Declaration
(Loc
,
7600 Defining_Unit_Name
=> New_Copy
(Defining_Identifier
(Formal
)),
7601 Name
=> New_Reference_To
(Actual_Pack
, Loc
));
7603 Set_Associated_Formal_Package
(Defining_Unit_Name
(Nod
),
7604 Defining_Identifier
(Formal
));
7605 Decls
:= New_List
(Nod
);
7607 -- If the formal F has a box, then the generic declarations are
7608 -- visible in the generic G. In an instance of G, the corresponding
7609 -- entities in the actual for F (which are the actuals for the
7610 -- instantiation of the generic that F denotes) must also be made
7611 -- visible for analysis of the current instance. On exit from the
7612 -- current instance, those entities are made private again. If the
7613 -- actual is currently in use, these entities are also use-visible.
7615 -- The loop through the actual entities also steps through the formal
7616 -- entities and enters associations from formals to actuals into the
7617 -- renaming map. This is necessary to properly handle checking of
7618 -- actual parameter associations for later formals that depend on
7619 -- actuals declared in the formal package.
7621 -- In Ada 2005, partial parametrization requires that we make visible
7622 -- the actuals corresponding to formals that were defaulted in the
7623 -- formal package. There formals are identified because they remain
7624 -- formal generics within the formal package, rather than being
7625 -- renamings of the actuals supplied.
7628 Gen_Decl
: constant Node_Id
:=
7629 Unit_Declaration_Node
(Gen_Parent
);
7630 Formals
: constant List_Id
:=
7631 Generic_Formal_Declarations
(Gen_Decl
);
7633 Actual_Ent
: Entity_Id
;
7634 Actual_Of_Formal
: Node_Id
;
7635 Formal_Node
: Node_Id
;
7636 Formal_Ent
: Entity_Id
;
7639 if Present
(Formals
) then
7640 Formal_Node
:= First_Non_Pragma
(Formals
);
7642 Formal_Node
:= Empty
;
7645 Actual_Ent
:= First_Entity
(Actual_Pack
);
7647 First
(Visible_Declarations
(Specification
(Analyzed_Formal
)));
7648 while Present
(Actual_Ent
)
7649 and then Actual_Ent
/= First_Private_Entity
(Actual_Pack
)
7651 if Present
(Formal_Node
) then
7652 Formal_Ent
:= Get_Formal_Entity
(Formal_Node
);
7654 if Present
(Formal_Ent
) then
7655 Find_Matching_Actual
(Formal_Node
, Actual_Ent
);
7657 (Formal_Node
, Formal_Ent
, Actual_Ent
);
7659 -- We iterate at the same time over the actuals of the
7660 -- local package created for the formal, to determine
7661 -- which one of the formals of the original generic were
7662 -- defaulted in the formal. The corresponding actual
7663 -- entities are visible in the enclosing instance.
7665 if Box_Present
(Formal
)
7667 (Present
(Actual_Of_Formal
)
7670 (Get_Formal_Entity
(Actual_Of_Formal
)))
7672 Set_Is_Hidden
(Actual_Ent
, False);
7673 Set_Is_Visible_Formal
(Actual_Ent
);
7674 Set_Is_Potentially_Use_Visible
7675 (Actual_Ent
, In_Use
(Actual_Pack
));
7677 if Ekind
(Actual_Ent
) = E_Package
then
7678 Process_Nested_Formal
(Actual_Ent
);
7682 Set_Is_Hidden
(Actual_Ent
);
7683 Set_Is_Potentially_Use_Visible
(Actual_Ent
, False);
7687 Next_Non_Pragma
(Formal_Node
);
7688 Next
(Actual_Of_Formal
);
7691 -- No further formals to match, but the generic part may
7692 -- contain inherited operation that are not hidden in the
7693 -- enclosing instance.
7695 Next_Entity
(Actual_Ent
);
7699 -- Inherited subprograms generated by formal derived types are
7700 -- also visible if the types are.
7702 Actual_Ent
:= First_Entity
(Actual_Pack
);
7703 while Present
(Actual_Ent
)
7704 and then Actual_Ent
/= First_Private_Entity
(Actual_Pack
)
7706 if Is_Overloadable
(Actual_Ent
)
7708 Nkind
(Parent
(Actual_Ent
)) = N_Subtype_Declaration
7710 not Is_Hidden
(Defining_Identifier
(Parent
(Actual_Ent
)))
7712 Set_Is_Hidden
(Actual_Ent
, False);
7713 Set_Is_Potentially_Use_Visible
7714 (Actual_Ent
, In_Use
(Actual_Pack
));
7717 Next_Entity
(Actual_Ent
);
7721 -- If the formal is not declared with a box, reanalyze it as an
7722 -- abbreviated instantiation, to verify the matching rules of 12.7.
7723 -- The actual checks are performed after the generic associations
7724 -- have been analyzed, to guarantee the same visibility for this
7725 -- instantiation and for the actuals.
7727 -- In Ada 2005, the generic associations for the formal can include
7728 -- defaulted parameters. These are ignored during check. This
7729 -- internal instantiation is removed from the tree after conformance
7730 -- checking, because it contains formal declarations for those
7731 -- defaulted parameters, and those should not reach the back-end.
7733 if not Box_Present
(Formal
) then
7735 I_Pack
: constant Entity_Id
:=
7736 Make_Defining_Identifier
(Sloc
(Actual
),
7737 Chars
=> New_Internal_Name
('P'));
7740 Set_Is_Internal
(I_Pack
);
7743 Make_Package_Instantiation
(Sloc
(Actual
),
7744 Defining_Unit_Name
=> I_Pack
,
7747 (Get_Instance_Of
(Gen_Parent
), Sloc
(Actual
)),
7748 Generic_Associations
=>
7749 Generic_Associations
(Formal
)));
7755 end Instantiate_Formal_Package
;
7757 -----------------------------------
7758 -- Instantiate_Formal_Subprogram --
7759 -----------------------------------
7761 function Instantiate_Formal_Subprogram
7764 Analyzed_Formal
: Node_Id
) return Node_Id
7767 Formal_Sub
: constant Entity_Id
:=
7768 Defining_Unit_Name
(Specification
(Formal
));
7769 Analyzed_S
: constant Entity_Id
:=
7770 Defining_Unit_Name
(Specification
(Analyzed_Formal
));
7771 Decl_Node
: Node_Id
;
7775 function From_Parent_Scope
(Subp
: Entity_Id
) return Boolean;
7776 -- If the generic is a child unit, the parent has been installed on the
7777 -- scope stack, but a default subprogram cannot resolve to something on
7778 -- the parent because that parent is not really part of the visible
7779 -- context (it is there to resolve explicit local entities). If the
7780 -- default has resolved in this way, we remove the entity from
7781 -- immediate visibility and analyze the node again to emit an error
7782 -- message or find another visible candidate.
7784 procedure Valid_Actual_Subprogram
(Act
: Node_Id
);
7785 -- Perform legality check and raise exception on failure
7787 -----------------------
7788 -- From_Parent_Scope --
7789 -----------------------
7791 function From_Parent_Scope
(Subp
: Entity_Id
) return Boolean is
7792 Gen_Scope
: Node_Id
;
7795 Gen_Scope
:= Scope
(Analyzed_S
);
7796 while Present
(Gen_Scope
)
7797 and then Is_Child_Unit
(Gen_Scope
)
7799 if Scope
(Subp
) = Scope
(Gen_Scope
) then
7803 Gen_Scope
:= Scope
(Gen_Scope
);
7807 end From_Parent_Scope
;
7809 -----------------------------
7810 -- Valid_Actual_Subprogram --
7811 -----------------------------
7813 procedure Valid_Actual_Subprogram
(Act
: Node_Id
) is
7817 if Is_Entity_Name
(Act
) then
7818 Act_E
:= Entity
(Act
);
7820 elsif Nkind
(Act
) = N_Selected_Component
7821 and then Is_Entity_Name
(Selector_Name
(Act
))
7823 Act_E
:= Entity
(Selector_Name
(Act
));
7829 if (Present
(Act_E
) and then Is_Overloadable
(Act_E
))
7830 or else Nkind
(Act
) = N_Attribute_Reference
7831 or else Nkind
(Act
) = N_Indexed_Component
7832 or else Nkind
(Act
) = N_Character_Literal
7833 or else Nkind
(Act
) = N_Explicit_Dereference
7839 ("expect subprogram or entry name in instantiation of&",
7840 Instantiation_Node
, Formal_Sub
);
7841 Abandon_Instantiation
(Instantiation_Node
);
7843 end Valid_Actual_Subprogram
;
7845 -- Start of processing for Instantiate_Formal_Subprogram
7848 New_Spec
:= New_Copy_Tree
(Specification
(Formal
));
7850 -- The tree copy has created the proper instantiation sloc for the
7851 -- new specification. Use this location for all other constructed
7854 Loc
:= Sloc
(Defining_Unit_Name
(New_Spec
));
7856 -- Create new entity for the actual (New_Copy_Tree does not)
7858 Set_Defining_Unit_Name
7859 (New_Spec
, Make_Defining_Identifier
(Loc
, Chars
(Formal_Sub
)));
7861 -- Create new entities for the each of the formals in the
7862 -- specification of the renaming declaration built for the actual.
7864 if Present
(Parameter_Specifications
(New_Spec
)) then
7868 F
:= First
(Parameter_Specifications
(New_Spec
));
7869 while Present
(F
) loop
7870 Set_Defining_Identifier
(F
,
7871 Make_Defining_Identifier
(Sloc
(F
),
7872 Chars
=> Chars
(Defining_Identifier
(F
))));
7878 -- Find entity of actual. If the actual is an attribute reference, it
7879 -- cannot be resolved here (its formal is missing) but is handled
7880 -- instead in Attribute_Renaming. If the actual is overloaded, it is
7881 -- fully resolved subsequently, when the renaming declaration for the
7882 -- formal is analyzed. If it is an explicit dereference, resolve the
7883 -- prefix but not the actual itself, to prevent interpretation as call.
7885 if Present
(Actual
) then
7886 Loc
:= Sloc
(Actual
);
7887 Set_Sloc
(New_Spec
, Loc
);
7889 if Nkind
(Actual
) = N_Operator_Symbol
then
7890 Find_Direct_Name
(Actual
);
7892 elsif Nkind
(Actual
) = N_Explicit_Dereference
then
7893 Analyze
(Prefix
(Actual
));
7895 elsif Nkind
(Actual
) /= N_Attribute_Reference
then
7899 Valid_Actual_Subprogram
(Actual
);
7902 elsif Present
(Default_Name
(Formal
)) then
7903 if Nkind
(Default_Name
(Formal
)) /= N_Attribute_Reference
7904 and then Nkind
(Default_Name
(Formal
)) /= N_Selected_Component
7905 and then Nkind
(Default_Name
(Formal
)) /= N_Indexed_Component
7906 and then Nkind
(Default_Name
(Formal
)) /= N_Character_Literal
7907 and then Present
(Entity
(Default_Name
(Formal
)))
7909 Nam
:= New_Occurrence_Of
(Entity
(Default_Name
(Formal
)), Loc
);
7911 Nam
:= New_Copy
(Default_Name
(Formal
));
7912 Set_Sloc
(Nam
, Loc
);
7915 elsif Box_Present
(Formal
) then
7917 -- Actual is resolved at the point of instantiation. Create an
7918 -- identifier or operator with the same name as the formal.
7920 if Nkind
(Formal_Sub
) = N_Defining_Operator_Symbol
then
7921 Nam
:= Make_Operator_Symbol
(Loc
,
7922 Chars
=> Chars
(Formal_Sub
),
7923 Strval
=> No_String
);
7925 Nam
:= Make_Identifier
(Loc
, Chars
(Formal_Sub
));
7928 elsif Nkind
(Specification
(Formal
)) = N_Procedure_Specification
7929 and then Null_Present
(Specification
(Formal
))
7931 -- Generate null body for procedure, for use in the instance
7934 Make_Subprogram_Body
(Loc
,
7935 Specification
=> New_Spec
,
7936 Declarations
=> New_List
,
7937 Handled_Statement_Sequence
=>
7938 Make_Handled_Sequence_Of_Statements
(Loc
,
7939 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
7941 Set_Is_Intrinsic_Subprogram
(Defining_Unit_Name
(New_Spec
));
7945 Error_Msg_Sloc
:= Sloc
(Scope
(Analyzed_S
));
7947 ("missing actual&", Instantiation_Node
, Formal_Sub
);
7949 ("\in instantiation of & declared#",
7950 Instantiation_Node
, Scope
(Analyzed_S
));
7951 Abandon_Instantiation
(Instantiation_Node
);
7955 Make_Subprogram_Renaming_Declaration
(Loc
,
7956 Specification
=> New_Spec
,
7959 -- If we do not have an actual and the formal specified <> then set to
7960 -- get proper default.
7962 if No
(Actual
) and then Box_Present
(Formal
) then
7963 Set_From_Default
(Decl_Node
);
7966 -- Gather possible interpretations for the actual before analyzing the
7967 -- instance. If overloaded, it will be resolved when analyzing the
7968 -- renaming declaration.
7970 if Box_Present
(Formal
)
7971 and then No
(Actual
)
7975 if Is_Child_Unit
(Scope
(Analyzed_S
))
7976 and then Present
(Entity
(Nam
))
7978 if not Is_Overloaded
(Nam
) then
7980 if From_Parent_Scope
(Entity
(Nam
)) then
7981 Set_Is_Immediately_Visible
(Entity
(Nam
), False);
7982 Set_Entity
(Nam
, Empty
);
7983 Set_Etype
(Nam
, Empty
);
7987 Set_Is_Immediately_Visible
(Entity
(Nam
));
7996 Get_First_Interp
(Nam
, I
, It
);
7998 while Present
(It
.Nam
) loop
7999 if From_Parent_Scope
(It
.Nam
) then
8003 Get_Next_Interp
(I
, It
);
8010 -- The generic instantiation freezes the actual. This can only be done
8011 -- once the actual is resolved, in the analysis of the renaming
8012 -- declaration. To make the formal subprogram entity available, we set
8013 -- Corresponding_Formal_Spec to point to the formal subprogram entity.
8014 -- This is also needed in Analyze_Subprogram_Renaming for the processing
8015 -- of formal abstract subprograms.
8017 Set_Corresponding_Formal_Spec
(Decl_Node
, Analyzed_S
);
8019 -- We cannot analyze the renaming declaration, and thus find the actual,
8020 -- until all the actuals are assembled in the instance. For subsequent
8021 -- checks of other actuals, indicate the node that will hold the
8022 -- instance of this formal.
8024 Set_Instance_Of
(Analyzed_S
, Nam
);
8026 if Nkind
(Actual
) = N_Selected_Component
8027 and then Is_Task_Type
(Etype
(Prefix
(Actual
)))
8028 and then not Is_Frozen
(Etype
(Prefix
(Actual
)))
8030 -- The renaming declaration will create a body, which must appear
8031 -- outside of the instantiation, We move the renaming declaration
8032 -- out of the instance, and create an additional renaming inside,
8033 -- to prevent freezing anomalies.
8036 Anon_Id
: constant Entity_Id
:=
8037 Make_Defining_Identifier
8038 (Loc
, New_Internal_Name
('E'));
8040 Set_Defining_Unit_Name
(New_Spec
, Anon_Id
);
8041 Insert_Before
(Instantiation_Node
, Decl_Node
);
8042 Analyze
(Decl_Node
);
8044 -- Now create renaming within the instance
8047 Make_Subprogram_Renaming_Declaration
(Loc
,
8048 Specification
=> New_Copy_Tree
(New_Spec
),
8049 Name
=> New_Occurrence_Of
(Anon_Id
, Loc
));
8051 Set_Defining_Unit_Name
(Specification
(Decl_Node
),
8052 Make_Defining_Identifier
(Loc
, Chars
(Formal_Sub
)));
8057 end Instantiate_Formal_Subprogram
;
8059 ------------------------
8060 -- Instantiate_Object --
8061 ------------------------
8063 function Instantiate_Object
8066 Analyzed_Formal
: Node_Id
) return List_Id
8068 Acc_Def
: Node_Id
:= Empty
;
8069 Act_Assoc
: constant Node_Id
:= Parent
(Actual
);
8070 Actual_Decl
: Node_Id
:= Empty
;
8071 Formal_Id
: constant Entity_Id
:= Defining_Identifier
(Formal
);
8072 Decl_Node
: Node_Id
;
8075 List
: constant List_Id
:= New_List
;
8076 Loc
: constant Source_Ptr
:= Sloc
(Actual
);
8077 Orig_Ftyp
: constant Entity_Id
:=
8078 Etype
(Defining_Identifier
(Analyzed_Formal
));
8079 Subt_Decl
: Node_Id
:= Empty
;
8080 Subt_Mark
: Node_Id
:= Empty
;
8083 if Present
(Subtype_Mark
(Formal
)) then
8084 Subt_Mark
:= Subtype_Mark
(Formal
);
8086 Check_Access_Definition
(Formal
);
8087 Acc_Def
:= Access_Definition
(Formal
);
8090 -- Sloc for error message on missing actual
8092 Error_Msg_Sloc
:= Sloc
(Scope
(Defining_Identifier
(Analyzed_Formal
)));
8094 if Get_Instance_Of
(Formal_Id
) /= Formal_Id
then
8095 Error_Msg_N
("duplicate instantiation of generic parameter", Actual
);
8098 Set_Parent
(List
, Parent
(Actual
));
8102 if Out_Present
(Formal
) then
8104 -- An IN OUT generic actual must be a name. The instantiation is a
8105 -- renaming declaration. The actual is the name being renamed. We
8106 -- use the actual directly, rather than a copy, because it is not
8107 -- used further in the list of actuals, and because a copy or a use
8108 -- of relocate_node is incorrect if the instance is nested within a
8109 -- generic. In order to simplify ASIS searches, the Generic_Parent
8110 -- field links the declaration to the generic association.
8115 Instantiation_Node
, Formal_Id
);
8117 ("\in instantiation of & declared#",
8119 Scope
(Defining_Identifier
(Analyzed_Formal
)));
8120 Abandon_Instantiation
(Instantiation_Node
);
8123 if Present
(Subt_Mark
) then
8125 Make_Object_Renaming_Declaration
(Loc
,
8126 Defining_Identifier
=> New_Copy
(Formal_Id
),
8127 Subtype_Mark
=> New_Copy_Tree
(Subt_Mark
),
8130 else pragma Assert
(Present
(Acc_Def
));
8132 Make_Object_Renaming_Declaration
(Loc
,
8133 Defining_Identifier
=> New_Copy
(Formal_Id
),
8134 Access_Definition
=> New_Copy_Tree
(Acc_Def
),
8138 Set_Corresponding_Generic_Association
(Decl_Node
, Act_Assoc
);
8140 -- The analysis of the actual may produce insert_action nodes, so
8141 -- the declaration must have a context in which to attach them.
8143 Append
(Decl_Node
, List
);
8146 -- Return if the analysis of the actual reported some error
8148 if Etype
(Actual
) = Any_Type
then
8152 -- This check is performed here because Analyze_Object_Renaming will
8153 -- not check it when Comes_From_Source is False. Note though that the
8154 -- check for the actual being the name of an object will be performed
8155 -- in Analyze_Object_Renaming.
8157 if Is_Object_Reference
(Actual
)
8158 and then Is_Dependent_Component_Of_Mutable_Object
(Actual
)
8161 ("illegal discriminant-dependent component for in out parameter",
8165 -- The actual has to be resolved in order to check that it is a
8166 -- variable (due to cases such as F(1), where F returns
8167 -- access to an array, and for overloaded prefixes).
8170 Get_Instance_Of
(Etype
(Defining_Identifier
(Analyzed_Formal
)));
8172 if Is_Private_Type
(Ftyp
)
8173 and then not Is_Private_Type
(Etype
(Actual
))
8174 and then (Base_Type
(Full_View
(Ftyp
)) = Base_Type
(Etype
(Actual
))
8175 or else Base_Type
(Etype
(Actual
)) = Ftyp
)
8177 -- If the actual has the type of the full view of the formal, or
8178 -- else a non-private subtype of the formal, then the visibility
8179 -- of the formal type has changed. Add to the actuals a subtype
8180 -- declaration that will force the exchange of views in the body
8181 -- of the instance as well.
8184 Make_Subtype_Declaration
(Loc
,
8185 Defining_Identifier
=>
8186 Make_Defining_Identifier
(Loc
, New_Internal_Name
('P')),
8187 Subtype_Indication
=> New_Occurrence_Of
(Ftyp
, Loc
));
8189 Prepend
(Subt_Decl
, List
);
8191 Prepend_Elmt
(Full_View
(Ftyp
), Exchanged_Views
);
8192 Exchange_Declarations
(Ftyp
);
8195 Resolve
(Actual
, Ftyp
);
8197 if not Is_Variable
(Actual
) or else Paren_Count
(Actual
) > 0 then
8199 ("actual for& must be a variable", Actual
, Formal_Id
);
8201 elsif Base_Type
(Ftyp
) /= Base_Type
(Etype
(Actual
)) then
8203 -- Ada 2005 (AI-423): For a generic formal object of mode in out,
8204 -- the type of the actual shall resolve to a specific anonymous
8207 if Ada_Version
< Ada_05
8209 Ekind
(Base_Type
(Ftyp
)) /=
8210 E_Anonymous_Access_Type
8212 Ekind
(Base_Type
(Etype
(Actual
))) /=
8213 E_Anonymous_Access_Type
8215 Error_Msg_NE
("type of actual does not match type of&",
8220 Note_Possible_Modification
(Actual
);
8222 -- Check for instantiation of atomic/volatile actual for
8223 -- non-atomic/volatile formal (RM C.6 (12)).
8225 if Is_Atomic_Object
(Actual
)
8226 and then not Is_Atomic
(Orig_Ftyp
)
8229 ("cannot instantiate non-atomic formal object " &
8230 "with atomic actual", Actual
);
8232 elsif Is_Volatile_Object
(Actual
)
8233 and then not Is_Volatile
(Orig_Ftyp
)
8236 ("cannot instantiate non-volatile formal object " &
8237 "with volatile actual", Actual
);
8243 -- The instantiation of a generic formal in-parameter is constant
8244 -- declaration. The actual is the expression for that declaration.
8246 if Present
(Actual
) then
8247 if Present
(Subt_Mark
) then
8249 else pragma Assert
(Present
(Acc_Def
));
8254 Make_Object_Declaration
(Loc
,
8255 Defining_Identifier
=> New_Copy
(Formal_Id
),
8256 Constant_Present
=> True,
8257 Object_Definition
=> New_Copy_Tree
(Def
),
8258 Expression
=> Actual
);
8260 Set_Corresponding_Generic_Association
(Decl_Node
, Act_Assoc
);
8262 -- A generic formal object of a tagged type is defined to be
8263 -- aliased so the new constant must also be treated as aliased.
8266 (Etype
(Defining_Identifier
(Analyzed_Formal
)))
8268 Set_Aliased_Present
(Decl_Node
);
8271 Append
(Decl_Node
, List
);
8273 -- No need to repeat (pre-)analysis of some expression nodes
8274 -- already handled in Pre_Analyze_Actuals.
8276 if Nkind
(Actual
) /= N_Allocator
then
8279 -- Return if the analysis of the actual reported some error
8281 if Etype
(Actual
) = Any_Type
then
8287 Typ
: constant Entity_Id
:=
8289 (Etype
(Defining_Identifier
(Analyzed_Formal
)));
8292 Freeze_Before
(Instantiation_Node
, Typ
);
8294 -- If the actual is an aggregate, perform name resolution on
8295 -- its components (the analysis of an aggregate does not do it)
8296 -- to capture local names that may be hidden if the generic is
8299 if Nkind
(Actual
) = N_Aggregate
then
8300 Pre_Analyze_And_Resolve
(Actual
, Typ
);
8303 if Is_Limited_Type
(Typ
)
8304 and then not OK_For_Limited_Init
(Actual
)
8307 ("initialization not allowed for limited types", Actual
);
8308 Explain_Limited_Type
(Typ
, Actual
);
8312 elsif Present
(Default_Expression
(Formal
)) then
8314 -- Use default to construct declaration
8316 if Present
(Subt_Mark
) then
8318 else pragma Assert
(Present
(Acc_Def
));
8323 Make_Object_Declaration
(Sloc
(Formal
),
8324 Defining_Identifier
=> New_Copy
(Formal_Id
),
8325 Constant_Present
=> True,
8326 Object_Definition
=> New_Copy
(Def
),
8327 Expression
=> New_Copy_Tree
(Default_Expression
8330 Append
(Decl_Node
, List
);
8331 Set_Analyzed
(Expression
(Decl_Node
), False);
8336 Instantiation_Node
, Formal_Id
);
8337 Error_Msg_NE
("\in instantiation of & declared#",
8339 Scope
(Defining_Identifier
(Analyzed_Formal
)));
8342 (Etype
(Defining_Identifier
(Analyzed_Formal
)))
8344 -- Create dummy constant declaration so that instance can be
8345 -- analyzed, to minimize cascaded visibility errors.
8347 if Present
(Subt_Mark
) then
8349 else pragma Assert
(Present
(Acc_Def
));
8354 Make_Object_Declaration
(Loc
,
8355 Defining_Identifier
=> New_Copy
(Formal_Id
),
8356 Constant_Present
=> True,
8357 Object_Definition
=> New_Copy
(Def
),
8359 Make_Attribute_Reference
(Sloc
(Formal_Id
),
8360 Attribute_Name
=> Name_First
,
8361 Prefix
=> New_Copy
(Def
)));
8363 Append
(Decl_Node
, List
);
8366 Abandon_Instantiation
(Instantiation_Node
);
8371 if Nkind
(Actual
) in N_Has_Entity
then
8372 Actual_Decl
:= Parent
(Entity
(Actual
));
8375 -- Ada 2005 (AI-423): For a formal object declaration with a null
8376 -- exclusion or an access definition that has a null exclusion: If the
8377 -- actual matching the formal object declaration denotes a generic
8378 -- formal object of another generic unit G, and the instantiation
8379 -- containing the actual occurs within the body of G or within the body
8380 -- of a generic unit declared within the declarative region of G, then
8381 -- the declaration of the formal object of G must have a null exclusion.
8382 -- Otherwise, the subtype of the actual matching the formal object
8383 -- declaration shall exclude null.
8385 if Ada_Version
>= Ada_05
8386 and then Present
(Actual_Decl
)
8388 (Nkind
(Actual_Decl
) = N_Formal_Object_Declaration
8389 or else Nkind
(Actual_Decl
) = N_Object_Declaration
)
8390 and then Nkind
(Analyzed_Formal
) = N_Formal_Object_Declaration
8391 and then Has_Null_Exclusion
(Actual_Decl
)
8392 and then not Has_Null_Exclusion
(Analyzed_Formal
)
8394 Error_Msg_Sloc
:= Sloc
(Actual_Decl
);
8396 ("`NOT NULL` required in formal, to match actual #",
8401 end Instantiate_Object
;
8403 ------------------------------
8404 -- Instantiate_Package_Body --
8405 ------------------------------
8407 procedure Instantiate_Package_Body
8408 (Body_Info
: Pending_Body_Info
;
8409 Inlined_Body
: Boolean := False;
8410 Body_Optional
: Boolean := False)
8412 Act_Decl
: constant Node_Id
:= Body_Info
.Act_Decl
;
8413 Inst_Node
: constant Node_Id
:= Body_Info
.Inst_Node
;
8414 Loc
: constant Source_Ptr
:= Sloc
(Inst_Node
);
8416 Gen_Id
: constant Node_Id
:= Name
(Inst_Node
);
8417 Gen_Unit
: constant Entity_Id
:= Get_Generic_Entity
(Inst_Node
);
8418 Gen_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Gen_Unit
);
8419 Act_Spec
: constant Node_Id
:= Specification
(Act_Decl
);
8420 Act_Decl_Id
: constant Entity_Id
:= Defining_Entity
(Act_Spec
);
8422 Act_Body_Name
: Node_Id
;
8424 Gen_Body_Id
: Node_Id
;
8426 Act_Body_Id
: Entity_Id
;
8428 Parent_Installed
: Boolean := False;
8429 Save_Style_Check
: constant Boolean := Style_Check
;
8432 Gen_Body_Id
:= Corresponding_Body
(Gen_Decl
);
8434 -- The instance body may already have been processed, as the parent of
8435 -- another instance that is inlined (Load_Parent_Of_Generic).
8437 if Present
(Corresponding_Body
(Instance_Spec
(Inst_Node
))) then
8441 Expander_Mode_Save_And_Set
(Body_Info
.Expander_Status
);
8443 -- Re-establish the state of information on which checks are suppressed.
8444 -- This information was set in Body_Info at the point of instantiation,
8445 -- and now we restore it so that the instance is compiled using the
8446 -- check status at the instantiation (RM 11.5 (7.2/2), AI95-00224-01).
8448 Local_Suppress_Stack_Top
:= Body_Info
.Local_Suppress_Stack_Top
;
8449 Scope_Suppress
:= Body_Info
.Scope_Suppress
;
8451 if No
(Gen_Body_Id
) then
8452 Load_Parent_Of_Generic
8453 (Inst_Node
, Specification
(Gen_Decl
), Body_Optional
);
8454 Gen_Body_Id
:= Corresponding_Body
(Gen_Decl
);
8457 -- Establish global variable for sloc adjustment and for error recovery
8459 Instantiation_Node
:= Inst_Node
;
8461 if Present
(Gen_Body_Id
) then
8462 Save_Env
(Gen_Unit
, Act_Decl_Id
);
8463 Style_Check
:= False;
8464 Current_Sem_Unit
:= Body_Info
.Current_Sem_Unit
;
8466 Gen_Body
:= Unit_Declaration_Node
(Gen_Body_Id
);
8468 Create_Instantiation_Source
8469 (Inst_Node
, Gen_Body_Id
, False, S_Adjustment
);
8473 (Original_Node
(Gen_Body
), Empty
, Instantiating
=> True);
8475 -- Build new name (possibly qualified) for body declaration
8477 Act_Body_Id
:= New_Copy
(Act_Decl_Id
);
8479 -- Some attributes of spec entity are not inherited by body entity
8481 Set_Handler_Records
(Act_Body_Id
, No_List
);
8483 if Nkind
(Defining_Unit_Name
(Act_Spec
)) =
8484 N_Defining_Program_Unit_Name
8487 Make_Defining_Program_Unit_Name
(Loc
,
8488 Name
=> New_Copy_Tree
(Name
(Defining_Unit_Name
(Act_Spec
))),
8489 Defining_Identifier
=> Act_Body_Id
);
8491 Act_Body_Name
:= Act_Body_Id
;
8494 Set_Defining_Unit_Name
(Act_Body
, Act_Body_Name
);
8496 Set_Corresponding_Spec
(Act_Body
, Act_Decl_Id
);
8497 Check_Generic_Actuals
(Act_Decl_Id
, False);
8499 -- If it is a child unit, make the parent instance (which is an
8500 -- instance of the parent of the generic) visible. The parent
8501 -- instance is the prefix of the name of the generic unit.
8503 if Ekind
(Scope
(Gen_Unit
)) = E_Generic_Package
8504 and then Nkind
(Gen_Id
) = N_Expanded_Name
8506 Install_Parent
(Entity
(Prefix
(Gen_Id
)), In_Body
=> True);
8507 Parent_Installed
:= True;
8509 elsif Is_Child_Unit
(Gen_Unit
) then
8510 Install_Parent
(Scope
(Gen_Unit
), In_Body
=> True);
8511 Parent_Installed
:= True;
8514 -- If the instantiation is a library unit, and this is the main unit,
8515 -- then build the resulting compilation unit nodes for the instance.
8516 -- If this is a compilation unit but it is not the main unit, then it
8517 -- is the body of a unit in the context, that is being compiled
8518 -- because it is encloses some inlined unit or another generic unit
8519 -- being instantiated. In that case, this body is not part of the
8520 -- current compilation, and is not attached to the tree, but its
8521 -- parent must be set for analysis.
8523 if Nkind
(Parent
(Inst_Node
)) = N_Compilation_Unit
then
8525 -- Replace instance node with body of instance, and create new
8526 -- node for corresponding instance declaration.
8528 Build_Instance_Compilation_Unit_Nodes
8529 (Inst_Node
, Act_Body
, Act_Decl
);
8530 Analyze
(Inst_Node
);
8532 if Parent
(Inst_Node
) = Cunit
(Main_Unit
) then
8534 -- If the instance is a child unit itself, then set the scope
8535 -- of the expanded body to be the parent of the instantiation
8536 -- (ensuring that the fully qualified name will be generated
8537 -- for the elaboration subprogram).
8539 if Nkind
(Defining_Unit_Name
(Act_Spec
)) =
8540 N_Defining_Program_Unit_Name
8543 (Defining_Entity
(Inst_Node
), Scope
(Act_Decl_Id
));
8547 -- Case where instantiation is not a library unit
8550 -- If this is an early instantiation, i.e. appears textually
8551 -- before the corresponding body and must be elaborated first,
8552 -- indicate that the body instance is to be delayed.
8554 Install_Body
(Act_Body
, Inst_Node
, Gen_Body
, Gen_Decl
);
8556 -- Now analyze the body. We turn off all checks if this is an
8557 -- internal unit, since there is no reason to have checks on for
8558 -- any predefined run-time library code. All such code is designed
8559 -- to be compiled with checks off.
8561 -- Note that we do NOT apply this criterion to children of GNAT
8562 -- (or on VMS, children of DEC). The latter units must suppress
8563 -- checks explicitly if this is needed.
8565 if Is_Predefined_File_Name
8566 (Unit_File_Name
(Get_Source_Unit
(Gen_Decl
)))
8568 Analyze
(Act_Body
, Suppress
=> All_Checks
);
8574 Inherit_Context
(Gen_Body
, Inst_Node
);
8576 -- Remove the parent instances if they have been placed on the scope
8577 -- stack to compile the body.
8579 if Parent_Installed
then
8580 Remove_Parent
(In_Body
=> True);
8583 Restore_Private_Views
(Act_Decl_Id
);
8585 -- Remove the current unit from visibility if this is an instance
8586 -- that is not elaborated on the fly for inlining purposes.
8588 if not Inlined_Body
then
8589 Set_Is_Immediately_Visible
(Act_Decl_Id
, False);
8593 Style_Check
:= Save_Style_Check
;
8595 -- If we have no body, and the unit requires a body, then complain. This
8596 -- complaint is suppressed if we have detected other errors (since a
8597 -- common reason for missing the body is that it had errors).
8599 elsif Unit_Requires_Body
(Gen_Unit
)
8600 and then not Body_Optional
8602 if Serious_Errors_Detected
= 0 then
8604 ("cannot find body of generic package &", Inst_Node
, Gen_Unit
);
8606 -- Don't attempt to perform any cleanup actions if some other error
8607 -- was aready detected, since this can cause blowups.
8613 -- Case of package that does not need a body
8616 -- If the instantiation of the declaration is a library unit, rewrite
8617 -- the original package instantiation as a package declaration in the
8618 -- compilation unit node.
8620 if Nkind
(Parent
(Inst_Node
)) = N_Compilation_Unit
then
8621 Set_Parent_Spec
(Act_Decl
, Parent_Spec
(Inst_Node
));
8622 Rewrite
(Inst_Node
, Act_Decl
);
8624 -- Generate elaboration entity, in case spec has elaboration code.
8625 -- This cannot be done when the instance is analyzed, because it
8626 -- is not known yet whether the body exists.
8628 Set_Elaboration_Entity_Required
(Act_Decl_Id
, False);
8629 Build_Elaboration_Entity
(Parent
(Inst_Node
), Act_Decl_Id
);
8631 -- If the instantiation is not a library unit, then append the
8632 -- declaration to the list of implicitly generated entities. unless
8633 -- it is already a list member which means that it was already
8636 elsif not Is_List_Member
(Act_Decl
) then
8637 Mark_Rewrite_Insertion
(Act_Decl
);
8638 Insert_Before
(Inst_Node
, Act_Decl
);
8642 Expander_Mode_Restore
;
8643 end Instantiate_Package_Body
;
8645 ---------------------------------
8646 -- Instantiate_Subprogram_Body --
8647 ---------------------------------
8649 procedure Instantiate_Subprogram_Body
8650 (Body_Info
: Pending_Body_Info
)
8652 Act_Decl
: constant Node_Id
:= Body_Info
.Act_Decl
;
8653 Inst_Node
: constant Node_Id
:= Body_Info
.Inst_Node
;
8654 Loc
: constant Source_Ptr
:= Sloc
(Inst_Node
);
8655 Gen_Id
: constant Node_Id
:= Name
(Inst_Node
);
8656 Gen_Unit
: constant Entity_Id
:= Get_Generic_Entity
(Inst_Node
);
8657 Gen_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Gen_Unit
);
8658 Anon_Id
: constant Entity_Id
:=
8659 Defining_Unit_Name
(Specification
(Act_Decl
));
8660 Pack_Id
: constant Entity_Id
:=
8661 Defining_Unit_Name
(Parent
(Act_Decl
));
8664 Gen_Body_Id
: Node_Id
;
8666 Pack_Body
: Node_Id
;
8667 Prev_Formal
: Entity_Id
;
8669 Unit_Renaming
: Node_Id
;
8671 Parent_Installed
: Boolean := False;
8672 Save_Style_Check
: constant Boolean := Style_Check
;
8675 Gen_Body_Id
:= Corresponding_Body
(Gen_Decl
);
8677 Expander_Mode_Save_And_Set
(Body_Info
.Expander_Status
);
8679 -- Re-establish the state of information on which checks are suppressed.
8680 -- This information was set in Body_Info at the point of instantiation,
8681 -- and now we restore it so that the instance is compiled using the
8682 -- check status at the instantiation (RM 11.5 (7.2/2), AI95-00224-01).
8684 Local_Suppress_Stack_Top
:= Body_Info
.Local_Suppress_Stack_Top
;
8685 Scope_Suppress
:= Body_Info
.Scope_Suppress
;
8687 if No
(Gen_Body_Id
) then
8688 Load_Parent_Of_Generic
(Inst_Node
, Specification
(Gen_Decl
));
8689 Gen_Body_Id
:= Corresponding_Body
(Gen_Decl
);
8692 Instantiation_Node
:= Inst_Node
;
8694 if Present
(Gen_Body_Id
) then
8695 Gen_Body
:= Unit_Declaration_Node
(Gen_Body_Id
);
8697 if Nkind
(Gen_Body
) = N_Subprogram_Body_Stub
then
8699 -- Either body is not present, or context is non-expanding, as
8700 -- when compiling a subunit. Mark the instance as completed, and
8701 -- diagnose a missing body when needed.
8704 and then Operating_Mode
= Generate_Code
8707 ("missing proper body for instantiation", Gen_Body
);
8710 Set_Has_Completion
(Anon_Id
);
8714 Save_Env
(Gen_Unit
, Anon_Id
);
8715 Style_Check
:= False;
8716 Current_Sem_Unit
:= Body_Info
.Current_Sem_Unit
;
8717 Create_Instantiation_Source
8725 (Original_Node
(Gen_Body
), Empty
, Instantiating
=> True);
8727 -- Create proper defining name for the body, to correspond to
8728 -- the one in the spec.
8730 Set_Defining_Unit_Name
(Specification
(Act_Body
),
8731 Make_Defining_Identifier
8732 (Sloc
(Defining_Entity
(Inst_Node
)), Chars
(Anon_Id
)));
8733 Set_Corresponding_Spec
(Act_Body
, Anon_Id
);
8734 Set_Has_Completion
(Anon_Id
);
8735 Check_Generic_Actuals
(Pack_Id
, False);
8737 -- Generate a reference to link the visible subprogram instance to
8738 -- the the generic body, which for navigation purposes is the only
8739 -- available source for the instance.
8742 (Related_Instance
(Pack_Id
),
8743 Gen_Body_Id
, 'b', Set_Ref
=> False, Force
=> True);
8745 -- If it is a child unit, make the parent instance (which is an
8746 -- instance of the parent of the generic) visible. The parent
8747 -- instance is the prefix of the name of the generic unit.
8749 if Ekind
(Scope
(Gen_Unit
)) = E_Generic_Package
8750 and then Nkind
(Gen_Id
) = N_Expanded_Name
8752 Install_Parent
(Entity
(Prefix
(Gen_Id
)), In_Body
=> True);
8753 Parent_Installed
:= True;
8755 elsif Is_Child_Unit
(Gen_Unit
) then
8756 Install_Parent
(Scope
(Gen_Unit
), In_Body
=> True);
8757 Parent_Installed
:= True;
8760 -- Inside its body, a reference to the generic unit is a reference
8761 -- to the instance. The corresponding renaming is the first
8762 -- declaration in the body.
8765 Make_Subprogram_Renaming_Declaration
(Loc
,
8768 Specification
(Original_Node
(Gen_Body
)),
8770 Instantiating
=> True),
8771 Name
=> New_Occurrence_Of
(Anon_Id
, Loc
));
8773 -- If there is a formal subprogram with the same name as the unit
8774 -- itself, do not add this renaming declaration. This is a temporary
8775 -- fix for one ACVC test. ???
8777 Prev_Formal
:= First_Entity
(Pack_Id
);
8778 while Present
(Prev_Formal
) loop
8779 if Chars
(Prev_Formal
) = Chars
(Gen_Unit
)
8780 and then Is_Overloadable
(Prev_Formal
)
8785 Next_Entity
(Prev_Formal
);
8788 if Present
(Prev_Formal
) then
8789 Decls
:= New_List
(Act_Body
);
8791 Decls
:= New_List
(Unit_Renaming
, Act_Body
);
8794 -- The subprogram body is placed in the body of a dummy package body,
8795 -- whose spec contains the subprogram declaration as well as the
8796 -- renaming declarations for the generic parameters.
8798 Pack_Body
:= Make_Package_Body
(Loc
,
8799 Defining_Unit_Name
=> New_Copy
(Pack_Id
),
8800 Declarations
=> Decls
);
8802 Set_Corresponding_Spec
(Pack_Body
, Pack_Id
);
8804 -- If the instantiation is a library unit, then build resulting
8805 -- compilation unit nodes for the instance. The declaration of
8806 -- the enclosing package is the grandparent of the subprogram
8807 -- declaration. First replace the instantiation node as the unit
8808 -- of the corresponding compilation.
8810 if Nkind
(Parent
(Inst_Node
)) = N_Compilation_Unit
then
8811 if Parent
(Inst_Node
) = Cunit
(Main_Unit
) then
8812 Set_Unit
(Parent
(Inst_Node
), Inst_Node
);
8813 Build_Instance_Compilation_Unit_Nodes
8814 (Inst_Node
, Pack_Body
, Parent
(Parent
(Act_Decl
)));
8815 Analyze
(Inst_Node
);
8817 Set_Parent
(Pack_Body
, Parent
(Inst_Node
));
8818 Analyze
(Pack_Body
);
8822 Insert_Before
(Inst_Node
, Pack_Body
);
8823 Mark_Rewrite_Insertion
(Pack_Body
);
8824 Analyze
(Pack_Body
);
8826 if Expander_Active
then
8827 Freeze_Subprogram_Body
(Inst_Node
, Gen_Body
, Pack_Id
);
8831 Inherit_Context
(Gen_Body
, Inst_Node
);
8833 Restore_Private_Views
(Pack_Id
, False);
8835 if Parent_Installed
then
8836 Remove_Parent
(In_Body
=> True);
8840 Style_Check
:= Save_Style_Check
;
8842 -- Body not found. Error was emitted already. If there were no previous
8843 -- errors, this may be an instance whose scope is a premature instance.
8844 -- In that case we must insure that the (legal) program does raise
8845 -- program error if executed. We generate a subprogram body for this
8846 -- purpose. See DEC ac30vso.
8848 -- Should not reference proprietary DEC tests in comments ???
8850 elsif Serious_Errors_Detected
= 0
8851 and then Nkind
(Parent
(Inst_Node
)) /= N_Compilation_Unit
8853 if Ekind
(Anon_Id
) = E_Procedure
then
8855 Make_Subprogram_Body
(Loc
,
8857 Make_Procedure_Specification
(Loc
,
8858 Defining_Unit_Name
=>
8859 Make_Defining_Identifier
(Loc
, Chars
(Anon_Id
)),
8860 Parameter_Specifications
=>
8862 (Parameter_Specifications
(Parent
(Anon_Id
)))),
8864 Declarations
=> Empty_List
,
8865 Handled_Statement_Sequence
=>
8866 Make_Handled_Sequence_Of_Statements
(Loc
,
8869 Make_Raise_Program_Error
(Loc
,
8871 PE_Access_Before_Elaboration
))));
8875 Make_Raise_Program_Error
(Loc
,
8876 Reason
=> PE_Access_Before_Elaboration
);
8878 Set_Etype
(Ret_Expr
, (Etype
(Anon_Id
)));
8879 Set_Analyzed
(Ret_Expr
);
8882 Make_Subprogram_Body
(Loc
,
8884 Make_Function_Specification
(Loc
,
8885 Defining_Unit_Name
=>
8886 Make_Defining_Identifier
(Loc
, Chars
(Anon_Id
)),
8887 Parameter_Specifications
=>
8889 (Parameter_Specifications
(Parent
(Anon_Id
))),
8890 Result_Definition
=>
8891 New_Occurrence_Of
(Etype
(Anon_Id
), Loc
)),
8893 Declarations
=> Empty_List
,
8894 Handled_Statement_Sequence
=>
8895 Make_Handled_Sequence_Of_Statements
(Loc
,
8898 (Make_Simple_Return_Statement
(Loc
, Ret_Expr
))));
8901 Pack_Body
:= Make_Package_Body
(Loc
,
8902 Defining_Unit_Name
=> New_Copy
(Pack_Id
),
8903 Declarations
=> New_List
(Act_Body
));
8905 Insert_After
(Inst_Node
, Pack_Body
);
8906 Set_Corresponding_Spec
(Pack_Body
, Pack_Id
);
8907 Analyze
(Pack_Body
);
8910 Expander_Mode_Restore
;
8911 end Instantiate_Subprogram_Body
;
8913 ----------------------
8914 -- Instantiate_Type --
8915 ----------------------
8917 function Instantiate_Type
8920 Analyzed_Formal
: Node_Id
;
8921 Actual_Decls
: List_Id
) return List_Id
8923 Gen_T
: constant Entity_Id
:= Defining_Identifier
(Formal
);
8924 A_Gen_T
: constant Entity_Id
:=
8925 Defining_Identifier
(Analyzed_Formal
);
8926 Ancestor
: Entity_Id
:= Empty
;
8927 Def
: constant Node_Id
:= Formal_Type_Definition
(Formal
);
8929 Decl_Node
: Node_Id
;
8930 Decl_Nodes
: List_Id
;
8934 procedure Validate_Array_Type_Instance
;
8935 procedure Validate_Access_Subprogram_Instance
;
8936 procedure Validate_Access_Type_Instance
;
8937 procedure Validate_Derived_Type_Instance
;
8938 procedure Validate_Derived_Interface_Type_Instance
;
8939 procedure Validate_Interface_Type_Instance
;
8940 procedure Validate_Private_Type_Instance
;
8941 -- These procedures perform validation tests for the named case
8943 function Subtypes_Match
(Gen_T
, Act_T
: Entity_Id
) return Boolean;
8944 -- Check that base types are the same and that the subtypes match
8945 -- statically. Used in several of the above.
8947 --------------------
8948 -- Subtypes_Match --
8949 --------------------
8951 function Subtypes_Match
(Gen_T
, Act_T
: Entity_Id
) return Boolean is
8952 T
: constant Entity_Id
:= Get_Instance_Of
(Gen_T
);
8955 return (Base_Type
(T
) = Base_Type
(Act_T
)
8956 and then Subtypes_Statically_Match
(T
, Act_T
))
8958 or else (Is_Class_Wide_Type
(Gen_T
)
8959 and then Is_Class_Wide_Type
(Act_T
)
8962 (Get_Instance_Of
(Root_Type
(Gen_T
)),
8966 ((Ekind
(Gen_T
) = E_Anonymous_Access_Subprogram_Type
8967 or else Ekind
(Gen_T
) = E_Anonymous_Access_Type
)
8968 and then Ekind
(Act_T
) = Ekind
(Gen_T
)
8970 Subtypes_Statically_Match
8971 (Designated_Type
(Gen_T
), Designated_Type
(Act_T
)));
8974 -----------------------------------------
8975 -- Validate_Access_Subprogram_Instance --
8976 -----------------------------------------
8978 procedure Validate_Access_Subprogram_Instance
is
8980 if not Is_Access_Type
(Act_T
)
8981 or else Ekind
(Designated_Type
(Act_T
)) /= E_Subprogram_Type
8984 ("expect access type in instantiation of &", Actual
, Gen_T
);
8985 Abandon_Instantiation
(Actual
);
8988 Check_Mode_Conformant
8989 (Designated_Type
(Act_T
),
8990 Designated_Type
(A_Gen_T
),
8994 if Ekind
(Base_Type
(Act_T
)) = E_Access_Protected_Subprogram_Type
then
8995 if Ekind
(A_Gen_T
) = E_Access_Subprogram_Type
then
8997 ("protected access type not allowed for formal &",
9001 elsif Ekind
(A_Gen_T
) = E_Access_Protected_Subprogram_Type
then
9003 ("expect protected access type for formal &",
9006 end Validate_Access_Subprogram_Instance
;
9008 -----------------------------------
9009 -- Validate_Access_Type_Instance --
9010 -----------------------------------
9012 procedure Validate_Access_Type_Instance
is
9013 Desig_Type
: constant Entity_Id
:=
9015 (Designated_Type
(A_Gen_T
), Scope
(A_Gen_T
));
9018 if not Is_Access_Type
(Act_T
) then
9020 ("expect access type in instantiation of &", Actual
, Gen_T
);
9021 Abandon_Instantiation
(Actual
);
9024 if Is_Access_Constant
(A_Gen_T
) then
9025 if not Is_Access_Constant
(Act_T
) then
9027 ("actual type must be access-to-constant type", Actual
);
9028 Abandon_Instantiation
(Actual
);
9031 if Is_Access_Constant
(Act_T
) then
9033 ("actual type must be access-to-variable type", Actual
);
9034 Abandon_Instantiation
(Actual
);
9036 elsif Ekind
(A_Gen_T
) = E_General_Access_Type
9037 and then Ekind
(Base_Type
(Act_T
)) /= E_General_Access_Type
9039 Error_Msg_N
("actual must be general access type!", Actual
);
9040 Error_Msg_NE
("add ALL to }!", Actual
, Act_T
);
9041 Abandon_Instantiation
(Actual
);
9045 -- The designated subtypes, that is to say the subtypes introduced
9046 -- by an access type declaration (and not by a subtype declaration)
9049 if not Subtypes_Match
9050 (Desig_Type
, Designated_Type
(Base_Type
(Act_T
)))
9053 ("designated type of actual does not match that of formal &",
9055 Abandon_Instantiation
(Actual
);
9057 elsif Is_Access_Type
(Designated_Type
(Act_T
))
9058 and then Is_Constrained
(Designated_Type
(Designated_Type
(Act_T
)))
9060 Is_Constrained
(Designated_Type
(Desig_Type
))
9063 ("designated type of actual does not match that of formal &",
9065 Abandon_Instantiation
(Actual
);
9068 -- Ada 2005: null-exclusion indicators of the two types must agree
9070 if Can_Never_Be_Null
(A_Gen_T
) /= Can_Never_Be_Null
(Act_T
) then
9072 ("non null exclusion of actual and formal & do not match",
9075 end Validate_Access_Type_Instance
;
9077 ----------------------------------
9078 -- Validate_Array_Type_Instance --
9079 ----------------------------------
9081 procedure Validate_Array_Type_Instance
is
9086 function Formal_Dimensions
return Int
;
9087 -- Count number of dimensions in array type formal
9089 -----------------------
9090 -- Formal_Dimensions --
9091 -----------------------
9093 function Formal_Dimensions
return Int
is
9098 if Nkind
(Def
) = N_Constrained_Array_Definition
then
9099 Index
:= First
(Discrete_Subtype_Definitions
(Def
));
9101 Index
:= First
(Subtype_Marks
(Def
));
9104 while Present
(Index
) loop
9110 end Formal_Dimensions
;
9112 -- Start of processing for Validate_Array_Type_Instance
9115 if not Is_Array_Type
(Act_T
) then
9117 ("expect array type in instantiation of &", Actual
, Gen_T
);
9118 Abandon_Instantiation
(Actual
);
9120 elsif Nkind
(Def
) = N_Constrained_Array_Definition
then
9121 if not (Is_Constrained
(Act_T
)) then
9123 ("expect constrained array in instantiation of &",
9125 Abandon_Instantiation
(Actual
);
9129 if Is_Constrained
(Act_T
) then
9131 ("expect unconstrained array in instantiation of &",
9133 Abandon_Instantiation
(Actual
);
9137 if Formal_Dimensions
/= Number_Dimensions
(Act_T
) then
9139 ("dimensions of actual do not match formal &", Actual
, Gen_T
);
9140 Abandon_Instantiation
(Actual
);
9143 I1
:= First_Index
(A_Gen_T
);
9144 I2
:= First_Index
(Act_T
);
9145 for J
in 1 .. Formal_Dimensions
loop
9147 -- If the indices of the actual were given by a subtype_mark,
9148 -- the index was transformed into a range attribute. Retrieve
9149 -- the original type mark for checking.
9151 if Is_Entity_Name
(Original_Node
(I2
)) then
9152 T2
:= Entity
(Original_Node
(I2
));
9157 if not Subtypes_Match
9158 (Find_Actual_Type
(Etype
(I1
), Scope
(A_Gen_T
)), T2
)
9161 ("index types of actual do not match those of formal &",
9163 Abandon_Instantiation
(Actual
);
9170 if not Subtypes_Match
(
9171 Find_Actual_Type
(Component_Type
(A_Gen_T
), Scope
(A_Gen_T
)),
9172 Component_Type
(Act_T
))
9175 ("component subtype of actual does not match that of formal &",
9177 Abandon_Instantiation
(Actual
);
9180 if Has_Aliased_Components
(A_Gen_T
)
9181 and then not Has_Aliased_Components
(Act_T
)
9184 ("actual must have aliased components to match formal type &",
9188 end Validate_Array_Type_Instance
;
9190 -----------------------------------------------
9191 -- Validate_Derived_Interface_Type_Instance --
9192 -----------------------------------------------
9194 procedure Validate_Derived_Interface_Type_Instance
is
9195 Par
: constant Entity_Id
:= Entity
(Subtype_Indication
(Def
));
9199 -- First apply interface instance checks
9201 Validate_Interface_Type_Instance
;
9203 -- Verify that immediate parent interface is an ancestor of
9207 and then not Interface_Present_In_Ancestor
(Act_T
, Par
)
9210 ("interface actual must include progenitor&", Actual
, Par
);
9213 -- Now verify that the actual includes all other ancestors of
9216 Elmt
:= First_Elmt
(Abstract_Interfaces
(A_Gen_T
));
9217 while Present
(Elmt
) loop
9218 if not Interface_Present_In_Ancestor
9219 (Act_T
, Get_Instance_Of
(Node
(Elmt
)))
9222 ("interface actual must include progenitor&",
9223 Actual
, Node
(Elmt
));
9228 end Validate_Derived_Interface_Type_Instance
;
9230 ------------------------------------
9231 -- Validate_Derived_Type_Instance --
9232 ------------------------------------
9234 procedure Validate_Derived_Type_Instance
is
9235 Actual_Discr
: Entity_Id
;
9236 Ancestor_Discr
: Entity_Id
;
9239 -- If the parent type in the generic declaration is itself a previous
9240 -- formal type, then it is local to the generic and absent from the
9241 -- analyzed generic definition. In that case the ancestor is the
9242 -- instance of the formal (which must have been instantiated
9243 -- previously), unless the ancestor is itself a formal derived type.
9244 -- In this latter case (which is the subject of Corrigendum 8652/0038
9245 -- (AI-202) the ancestor of the formals is the ancestor of its
9246 -- parent. Otherwise, the analyzed generic carries the parent type.
9247 -- If the parent type is defined in a previous formal package, then
9248 -- the scope of that formal package is that of the generic type
9249 -- itself, and it has already been mapped into the corresponding type
9250 -- in the actual package.
9252 -- Common case: parent type defined outside of the generic
9254 if Is_Entity_Name
(Subtype_Mark
(Def
))
9255 and then Present
(Entity
(Subtype_Mark
(Def
)))
9257 Ancestor
:= Get_Instance_Of
(Entity
(Subtype_Mark
(Def
)));
9259 -- Check whether parent is defined in a previous formal package
9262 Scope
(Scope
(Base_Type
(Etype
(A_Gen_T
)))) = Scope
(A_Gen_T
)
9265 Get_Instance_Of
(Base_Type
(Etype
(A_Gen_T
)));
9267 -- The type may be a local derivation, or a type extension of a
9268 -- previous formal, or of a formal of a parent package.
9270 elsif Is_Derived_Type
(Get_Instance_Of
(A_Gen_T
))
9272 Ekind
(Get_Instance_Of
(A_Gen_T
)) = E_Record_Type_With_Private
9274 -- Check whether the parent is another derived formal type in the
9275 -- same generic unit.
9277 if Etype
(A_Gen_T
) /= A_Gen_T
9278 and then Is_Generic_Type
(Etype
(A_Gen_T
))
9279 and then Scope
(Etype
(A_Gen_T
)) = Scope
(A_Gen_T
)
9280 and then Etype
(Etype
(A_Gen_T
)) /= Etype
(A_Gen_T
)
9282 -- Locate ancestor of parent from the subtype declaration
9283 -- created for the actual.
9289 Decl
:= First
(Actual_Decls
);
9290 while Present
(Decl
) loop
9291 if Nkind
(Decl
) = N_Subtype_Declaration
9292 and then Chars
(Defining_Identifier
(Decl
)) =
9293 Chars
(Etype
(A_Gen_T
))
9295 Ancestor
:= Generic_Parent_Type
(Decl
);
9303 pragma Assert
(Present
(Ancestor
));
9307 Get_Instance_Of
(Base_Type
(Get_Instance_Of
(A_Gen_T
)));
9311 Ancestor
:= Get_Instance_Of
(Etype
(Base_Type
(A_Gen_T
)));
9314 -- If the formal derived type has pragma Preelaborable_Initialization
9315 -- then the actual type must have preelaborable initialization.
9317 if Known_To_Have_Preelab_Init
(A_Gen_T
)
9318 and then not Has_Preelaborable_Initialization
(Act_T
)
9321 ("actual for & must have preelaborable initialization",
9325 -- Ada 2005 (AI-251)
9327 if Ada_Version
>= Ada_05
9328 and then Is_Interface
(Ancestor
)
9330 if not Interface_Present_In_Ancestor
(Act_T
, Ancestor
) then
9332 ("(Ada 2005) expected type implementing & in instantiation",
9336 elsif not Is_Ancestor
(Base_Type
(Ancestor
), Act_T
) then
9338 ("expect type derived from & in instantiation",
9339 Actual
, First_Subtype
(Ancestor
));
9340 Abandon_Instantiation
(Actual
);
9343 -- Ada 2005 (AI-443): Synchronized formal derived type ckecks. Note
9344 -- that the formal type declaration has been rewritten as a private
9347 if Ada_Version
>= Ada_05
9348 and then Nkind
(Parent
(A_Gen_T
)) = N_Private_Extension_Declaration
9349 and then Synchronized_Present
(Parent
(A_Gen_T
))
9351 -- The actual must be a synchronized tagged type
9353 if not Is_Tagged_Type
(Act_T
) then
9355 ("actual of synchronized type must be tagged", Actual
);
9356 Abandon_Instantiation
(Actual
);
9358 elsif Nkind
(Parent
(Act_T
)) = N_Full_Type_Declaration
9359 and then Nkind
(Type_Definition
(Parent
(Act_T
))) =
9360 N_Derived_Type_Definition
9361 and then not Synchronized_Present
(Type_Definition
9365 ("actual of synchronized type must be synchronized", Actual
);
9366 Abandon_Instantiation
(Actual
);
9370 -- Perform atomic/volatile checks (RM C.6(12))
9372 if Is_Atomic
(Act_T
) and then not Is_Atomic
(Ancestor
) then
9374 ("cannot have atomic actual type for non-atomic formal type",
9377 elsif Is_Volatile
(Act_T
)
9378 and then not Is_Volatile
(Ancestor
)
9379 and then Is_By_Reference_Type
(Ancestor
)
9382 ("cannot have volatile actual type for non-volatile formal type",
9386 -- It should not be necessary to check for unknown discriminants on
9387 -- Formal, but for some reason Has_Unknown_Discriminants is false for
9388 -- A_Gen_T, so Is_Indefinite_Subtype incorrectly returns False. This
9389 -- needs fixing. ???
9391 if not Is_Indefinite_Subtype
(A_Gen_T
)
9392 and then not Unknown_Discriminants_Present
(Formal
)
9393 and then Is_Indefinite_Subtype
(Act_T
)
9396 ("actual subtype must be constrained", Actual
);
9397 Abandon_Instantiation
(Actual
);
9400 if not Unknown_Discriminants_Present
(Formal
) then
9401 if Is_Constrained
(Ancestor
) then
9402 if not Is_Constrained
(Act_T
) then
9404 ("actual subtype must be constrained", Actual
);
9405 Abandon_Instantiation
(Actual
);
9408 -- Ancestor is unconstrained, Check if generic formal and actual
9409 -- agree on constrainedness. The check only applies to array types
9410 -- and discriminated types.
9412 elsif Is_Constrained
(Act_T
) then
9413 if Ekind
(Ancestor
) = E_Access_Type
9415 (not Is_Constrained
(A_Gen_T
)
9416 and then Is_Composite_Type
(A_Gen_T
))
9419 ("actual subtype must be unconstrained", Actual
);
9420 Abandon_Instantiation
(Actual
);
9423 -- A class-wide type is only allowed if the formal has unknown
9426 elsif Is_Class_Wide_Type
(Act_T
)
9427 and then not Has_Unknown_Discriminants
(Ancestor
)
9430 ("actual for & cannot be a class-wide type", Actual
, Gen_T
);
9431 Abandon_Instantiation
(Actual
);
9433 -- Otherwise, the formal and actual shall have the same number
9434 -- of discriminants and each discriminant of the actual must
9435 -- correspond to a discriminant of the formal.
9437 elsif Has_Discriminants
(Act_T
)
9438 and then not Has_Unknown_Discriminants
(Act_T
)
9439 and then Has_Discriminants
(Ancestor
)
9441 Actual_Discr
:= First_Discriminant
(Act_T
);
9442 Ancestor_Discr
:= First_Discriminant
(Ancestor
);
9443 while Present
(Actual_Discr
)
9444 and then Present
(Ancestor_Discr
)
9446 if Base_Type
(Act_T
) /= Base_Type
(Ancestor
) and then
9447 No
(Corresponding_Discriminant
(Actual_Discr
))
9450 ("discriminant & does not correspond " &
9451 "to ancestor discriminant", Actual
, Actual_Discr
);
9452 Abandon_Instantiation
(Actual
);
9455 Next_Discriminant
(Actual_Discr
);
9456 Next_Discriminant
(Ancestor_Discr
);
9459 if Present
(Actual_Discr
) or else Present
(Ancestor_Discr
) then
9461 ("actual for & must have same number of discriminants",
9463 Abandon_Instantiation
(Actual
);
9466 -- This case should be caught by the earlier check for for
9467 -- constrainedness, but the check here is added for completeness.
9469 elsif Has_Discriminants
(Act_T
)
9470 and then not Has_Unknown_Discriminants
(Act_T
)
9473 ("actual for & must not have discriminants", Actual
, Gen_T
);
9474 Abandon_Instantiation
(Actual
);
9476 elsif Has_Discriminants
(Ancestor
) then
9478 ("actual for & must have known discriminants", Actual
, Gen_T
);
9479 Abandon_Instantiation
(Actual
);
9482 if not Subtypes_Statically_Compatible
(Act_T
, Ancestor
) then
9484 ("constraint on actual is incompatible with formal", Actual
);
9485 Abandon_Instantiation
(Actual
);
9489 -- If the formal and actual types are abstract, check that there
9490 -- are no abstract primitives of the actual type that correspond to
9491 -- nonabstract primitives of the formal type (second sentence of
9494 if Is_Abstract_Type
(A_Gen_T
) and then Is_Abstract_Type
(Act_T
) then
9495 Check_Abstract_Primitives
: declare
9496 Gen_Prims
: constant Elist_Id
:=
9497 Primitive_Operations
(A_Gen_T
);
9499 Gen_Subp
: Entity_Id
;
9500 Anc_Subp
: Entity_Id
;
9501 Anc_Formal
: Entity_Id
;
9502 Anc_F_Type
: Entity_Id
;
9504 Act_Prims
: constant Elist_Id
:= Primitive_Operations
(Act_T
);
9506 Act_Subp
: Entity_Id
;
9507 Act_Formal
: Entity_Id
;
9508 Act_F_Type
: Entity_Id
;
9510 Subprograms_Correspond
: Boolean;
9512 function Is_Tagged_Ancestor
(T1
, T2
: Entity_Id
) return Boolean;
9513 -- Returns true if T2 is derived directly or indirectly from
9514 -- T1, including derivations from interfaces. T1 and T2 are
9515 -- required to be specific tagged base types.
9517 ------------------------
9518 -- Is_Tagged_Ancestor --
9519 ------------------------
9521 function Is_Tagged_Ancestor
(T1
, T2
: Entity_Id
) return Boolean
9523 Interfaces
: Elist_Id
;
9524 Intfc_Elmt
: Elmt_Id
;
9527 -- The predicate is satisfied if the types are the same
9532 -- If we've reached the top of the derivation chain then
9533 -- we know that T1 is not an ancestor of T2.
9535 elsif Etype
(T2
) = T2
then
9538 -- Proceed to check T2's immediate parent
9540 elsif Is_Ancestor
(T1
, Base_Type
(Etype
(T2
))) then
9543 -- Finally, check to see if T1 is an ancestor of any of T2's
9547 Interfaces
:= Abstract_Interfaces
(T2
);
9549 Intfc_Elmt
:= First_Elmt
(Interfaces
);
9550 while Present
(Intfc_Elmt
) loop
9551 if Is_Ancestor
(T1
, Node
(Intfc_Elmt
)) then
9555 Next_Elmt
(Intfc_Elmt
);
9560 end Is_Tagged_Ancestor
;
9562 -- Start of processing for Check_Abstract_Primitives
9565 -- Loop over all of the formal derived type's primitives
9567 Gen_Elmt
:= First_Elmt
(Gen_Prims
);
9568 while Present
(Gen_Elmt
) loop
9569 Gen_Subp
:= Node
(Gen_Elmt
);
9571 -- If the primitive of the formal is not abstract, then
9572 -- determine whether there is a corresponding primitive of
9573 -- the actual type that's abstract.
9575 if not Is_Abstract_Subprogram
(Gen_Subp
) then
9576 Act_Elmt
:= First_Elmt
(Act_Prims
);
9577 while Present
(Act_Elmt
) loop
9578 Act_Subp
:= Node
(Act_Elmt
);
9580 -- If we find an abstract primitive of the actual,
9581 -- then we need to test whether it corresponds to the
9582 -- subprogram from which the generic formal primitive
9585 if Is_Abstract_Subprogram
(Act_Subp
) then
9586 Anc_Subp
:= Alias
(Gen_Subp
);
9588 -- Test whether we have a corresponding primitive
9589 -- by comparing names, kinds, formal types, and
9592 if Chars
(Anc_Subp
) = Chars
(Act_Subp
)
9593 and then Ekind
(Anc_Subp
) = Ekind
(Act_Subp
)
9595 Anc_Formal
:= First_Formal
(Anc_Subp
);
9596 Act_Formal
:= First_Formal
(Act_Subp
);
9597 while Present
(Anc_Formal
)
9598 and then Present
(Act_Formal
)
9600 Anc_F_Type
:= Etype
(Anc_Formal
);
9601 Act_F_Type
:= Etype
(Act_Formal
);
9603 if Ekind
(Anc_F_Type
)
9604 = E_Anonymous_Access_Type
9606 Anc_F_Type
:= Designated_Type
(Anc_F_Type
);
9608 if Ekind
(Act_F_Type
)
9609 = E_Anonymous_Access_Type
9612 Designated_Type
(Act_F_Type
);
9618 Ekind
(Act_F_Type
) = E_Anonymous_Access_Type
9623 Anc_F_Type
:= Base_Type
(Anc_F_Type
);
9624 Act_F_Type
:= Base_Type
(Act_F_Type
);
9626 -- If the formal is controlling, then the
9627 -- the type of the actual primitive's formal
9628 -- must be derived directly or indirectly
9629 -- from the type of the ancestor primitive's
9632 if Is_Controlling_Formal
(Anc_Formal
) then
9633 if not Is_Tagged_Ancestor
9634 (Anc_F_Type
, Act_F_Type
)
9639 -- Otherwise the types of the formals must
9642 elsif Anc_F_Type
/= Act_F_Type
then
9646 Next_Entity
(Anc_Formal
);
9647 Next_Entity
(Act_Formal
);
9650 -- If we traversed through all of the formals
9651 -- then so far the subprograms correspond, so
9652 -- now check that any result types correspond.
9655 and then No
(Act_Formal
)
9657 Subprograms_Correspond
:= True;
9659 if Ekind
(Act_Subp
) = E_Function
then
9660 Anc_F_Type
:= Etype
(Anc_Subp
);
9661 Act_F_Type
:= Etype
(Act_Subp
);
9663 if Ekind
(Anc_F_Type
)
9664 = E_Anonymous_Access_Type
9667 Designated_Type
(Anc_F_Type
);
9669 if Ekind
(Act_F_Type
)
9670 = E_Anonymous_Access_Type
9673 Designated_Type
(Act_F_Type
);
9675 Subprograms_Correspond
:= False;
9680 = E_Anonymous_Access_Type
9682 Subprograms_Correspond
:= False;
9685 Anc_F_Type
:= Base_Type
(Anc_F_Type
);
9686 Act_F_Type
:= Base_Type
(Act_F_Type
);
9688 -- Now either the result types must be
9689 -- the same or, if the result type is
9690 -- controlling, the result type of the
9691 -- actual primitive must descend from the
9692 -- result type of the ancestor primitive.
9694 if Subprograms_Correspond
9695 and then Anc_F_Type
/= Act_F_Type
9697 Has_Controlling_Result
(Anc_Subp
)
9699 not Is_Tagged_Ancestor
9700 (Anc_F_Type
, Act_F_Type
)
9702 Subprograms_Correspond
:= False;
9706 -- Found a matching subprogram belonging to
9707 -- formal ancestor type, so actual subprogram
9708 -- corresponds and this violates 3.9.3(9).
9710 if Subprograms_Correspond
then
9712 ("abstract subprogram & overrides " &
9713 "nonabstract subprogram of ancestor",
9721 Next_Elmt
(Act_Elmt
);
9725 Next_Elmt
(Gen_Elmt
);
9727 end Check_Abstract_Primitives
;
9729 end Validate_Derived_Type_Instance
;
9731 --------------------------------------
9732 -- Validate_Interface_Type_Instance --
9733 --------------------------------------
9735 procedure Validate_Interface_Type_Instance
is
9737 if not Is_Interface
(Act_T
) then
9739 ("actual for formal interface type must be an interface",
9742 elsif Is_Limited_Type
(Act_T
) /= Is_Limited_Type
(A_Gen_T
)
9744 Is_Task_Interface
(A_Gen_T
) /= Is_Task_Interface
(Act_T
)
9746 Is_Protected_Interface
(A_Gen_T
) /=
9747 Is_Protected_Interface
(Act_T
)
9749 Is_Synchronized_Interface
(A_Gen_T
) /=
9750 Is_Synchronized_Interface
(Act_T
)
9753 ("actual for interface& does not match (RM 12.5.5(4))",
9756 end Validate_Interface_Type_Instance
;
9758 ------------------------------------
9759 -- Validate_Private_Type_Instance --
9760 ------------------------------------
9762 procedure Validate_Private_Type_Instance
is
9763 Formal_Discr
: Entity_Id
;
9764 Actual_Discr
: Entity_Id
;
9765 Formal_Subt
: Entity_Id
;
9768 if Is_Limited_Type
(Act_T
)
9769 and then not Is_Limited_Type
(A_Gen_T
)
9772 ("actual for non-limited & cannot be a limited type", Actual
,
9774 Explain_Limited_Type
(Act_T
, Actual
);
9775 Abandon_Instantiation
(Actual
);
9777 elsif Known_To_Have_Preelab_Init
(A_Gen_T
)
9778 and then not Has_Preelaborable_Initialization
(Act_T
)
9781 ("actual for & must have preelaborable initialization", Actual
,
9784 elsif Is_Indefinite_Subtype
(Act_T
)
9785 and then not Is_Indefinite_Subtype
(A_Gen_T
)
9786 and then Ada_Version
>= Ada_95
9789 ("actual for & must be a definite subtype", Actual
, Gen_T
);
9791 elsif not Is_Tagged_Type
(Act_T
)
9792 and then Is_Tagged_Type
(A_Gen_T
)
9795 ("actual for & must be a tagged type", Actual
, Gen_T
);
9797 elsif Has_Discriminants
(A_Gen_T
) then
9798 if not Has_Discriminants
(Act_T
) then
9800 ("actual for & must have discriminants", Actual
, Gen_T
);
9801 Abandon_Instantiation
(Actual
);
9803 elsif Is_Constrained
(Act_T
) then
9805 ("actual for & must be unconstrained", Actual
, Gen_T
);
9806 Abandon_Instantiation
(Actual
);
9809 Formal_Discr
:= First_Discriminant
(A_Gen_T
);
9810 Actual_Discr
:= First_Discriminant
(Act_T
);
9811 while Formal_Discr
/= Empty
loop
9812 if Actual_Discr
= Empty
then
9814 ("discriminants on actual do not match formal",
9816 Abandon_Instantiation
(Actual
);
9819 Formal_Subt
:= Get_Instance_Of
(Etype
(Formal_Discr
));
9821 -- Access discriminants match if designated types do
9823 if Ekind
(Base_Type
(Formal_Subt
)) = E_Anonymous_Access_Type
9824 and then (Ekind
(Base_Type
(Etype
(Actual_Discr
)))) =
9825 E_Anonymous_Access_Type
9828 (Designated_Type
(Base_Type
(Formal_Subt
))) =
9829 Designated_Type
(Base_Type
(Etype
(Actual_Discr
)))
9833 elsif Base_Type
(Formal_Subt
) /=
9834 Base_Type
(Etype
(Actual_Discr
))
9837 ("types of actual discriminants must match formal",
9839 Abandon_Instantiation
(Actual
);
9841 elsif not Subtypes_Statically_Match
9842 (Formal_Subt
, Etype
(Actual_Discr
))
9843 and then Ada_Version
>= Ada_95
9846 ("subtypes of actual discriminants must match formal",
9848 Abandon_Instantiation
(Actual
);
9851 Next_Discriminant
(Formal_Discr
);
9852 Next_Discriminant
(Actual_Discr
);
9855 if Actual_Discr
/= Empty
then
9857 ("discriminants on actual do not match formal",
9859 Abandon_Instantiation
(Actual
);
9866 end Validate_Private_Type_Instance
;
9868 -- Start of processing for Instantiate_Type
9871 if Get_Instance_Of
(A_Gen_T
) /= A_Gen_T
then
9872 Error_Msg_N
("duplicate instantiation of generic type", Actual
);
9873 return New_List
(Error
);
9875 elsif not Is_Entity_Name
(Actual
)
9876 or else not Is_Type
(Entity
(Actual
))
9879 ("expect valid subtype mark to instantiate &", Actual
, Gen_T
);
9880 Abandon_Instantiation
(Actual
);
9883 Act_T
:= Entity
(Actual
);
9885 -- Ada 2005 (AI-216): An Unchecked_Union subtype shall only be passed
9886 -- as a generic actual parameter if the corresponding formal type
9887 -- does not have a known_discriminant_part, or is a formal derived
9888 -- type that is an Unchecked_Union type.
9890 if Is_Unchecked_Union
(Base_Type
(Act_T
)) then
9891 if not Has_Discriminants
(A_Gen_T
)
9893 (Is_Derived_Type
(A_Gen_T
)
9895 Is_Unchecked_Union
(A_Gen_T
))
9899 Error_Msg_N
("Unchecked_Union cannot be the actual for a" &
9900 " discriminated formal type", Act_T
);
9905 -- Deal with fixed/floating restrictions
9907 if Is_Floating_Point_Type
(Act_T
) then
9908 Check_Restriction
(No_Floating_Point
, Actual
);
9909 elsif Is_Fixed_Point_Type
(Act_T
) then
9910 Check_Restriction
(No_Fixed_Point
, Actual
);
9913 -- Deal with error of using incomplete type as generic actual
9915 if Ekind
(Act_T
) = E_Incomplete_Type
9916 or else (Is_Class_Wide_Type
(Act_T
)
9918 Ekind
(Root_Type
(Act_T
)) = E_Incomplete_Type
)
9920 if Is_Class_Wide_Type
(Act_T
)
9921 or else No
(Underlying_Type
(Act_T
))
9923 Error_Msg_N
("premature use of incomplete type", Actual
);
9924 Abandon_Instantiation
(Actual
);
9926 Act_T
:= Full_View
(Act_T
);
9927 Set_Entity
(Actual
, Act_T
);
9929 if Has_Private_Component
(Act_T
) then
9931 ("premature use of type with private component", Actual
);
9935 -- Deal with error of premature use of private type as generic actual
9937 elsif Is_Private_Type
(Act_T
)
9938 and then Is_Private_Type
(Base_Type
(Act_T
))
9939 and then not Is_Generic_Type
(Act_T
)
9940 and then not Is_Derived_Type
(Act_T
)
9941 and then No
(Full_View
(Root_Type
(Act_T
)))
9943 Error_Msg_N
("premature use of private type", Actual
);
9945 elsif Has_Private_Component
(Act_T
) then
9947 ("premature use of type with private component", Actual
);
9950 Set_Instance_Of
(A_Gen_T
, Act_T
);
9952 -- If the type is generic, the class-wide type may also be used
9954 if Is_Tagged_Type
(A_Gen_T
)
9955 and then Is_Tagged_Type
(Act_T
)
9956 and then not Is_Class_Wide_Type
(A_Gen_T
)
9958 Set_Instance_Of
(Class_Wide_Type
(A_Gen_T
),
9959 Class_Wide_Type
(Act_T
));
9962 if not Is_Abstract_Type
(A_Gen_T
)
9963 and then Is_Abstract_Type
(Act_T
)
9966 ("actual of non-abstract formal cannot be abstract", Actual
);
9969 -- A generic scalar type is a first subtype for which we generate
9970 -- an anonymous base type. Indicate that the instance of this base
9971 -- is the base type of the actual.
9973 if Is_Scalar_Type
(A_Gen_T
) then
9974 Set_Instance_Of
(Etype
(A_Gen_T
), Etype
(Act_T
));
9978 if Error_Posted
(Act_T
) then
9982 when N_Formal_Private_Type_Definition
=>
9983 Validate_Private_Type_Instance
;
9985 when N_Formal_Derived_Type_Definition
=>
9986 Validate_Derived_Type_Instance
;
9988 when N_Formal_Discrete_Type_Definition
=>
9989 if not Is_Discrete_Type
(Act_T
) then
9991 ("expect discrete type in instantiation of&",
9993 Abandon_Instantiation
(Actual
);
9996 when N_Formal_Signed_Integer_Type_Definition
=>
9997 if not Is_Signed_Integer_Type
(Act_T
) then
9999 ("expect signed integer type in instantiation of&",
10001 Abandon_Instantiation
(Actual
);
10004 when N_Formal_Modular_Type_Definition
=>
10005 if not Is_Modular_Integer_Type
(Act_T
) then
10007 ("expect modular type in instantiation of &",
10009 Abandon_Instantiation
(Actual
);
10012 when N_Formal_Floating_Point_Definition
=>
10013 if not Is_Floating_Point_Type
(Act_T
) then
10015 ("expect float type in instantiation of &", Actual
, Gen_T
);
10016 Abandon_Instantiation
(Actual
);
10019 when N_Formal_Ordinary_Fixed_Point_Definition
=>
10020 if not Is_Ordinary_Fixed_Point_Type
(Act_T
) then
10022 ("expect ordinary fixed point type in instantiation of &",
10024 Abandon_Instantiation
(Actual
);
10027 when N_Formal_Decimal_Fixed_Point_Definition
=>
10028 if not Is_Decimal_Fixed_Point_Type
(Act_T
) then
10030 ("expect decimal type in instantiation of &",
10032 Abandon_Instantiation
(Actual
);
10035 when N_Array_Type_Definition
=>
10036 Validate_Array_Type_Instance
;
10038 when N_Access_To_Object_Definition
=>
10039 Validate_Access_Type_Instance
;
10041 when N_Access_Function_Definition |
10042 N_Access_Procedure_Definition
=>
10043 Validate_Access_Subprogram_Instance
;
10045 when N_Record_Definition
=>
10046 Validate_Interface_Type_Instance
;
10048 when N_Derived_Type_Definition
=>
10049 Validate_Derived_Interface_Type_Instance
;
10052 raise Program_Error
;
10057 Subt
:= New_Copy
(Gen_T
);
10059 -- Use adjusted sloc of subtype name as the location for other nodes in
10060 -- the subtype declaration.
10062 Loc
:= Sloc
(Subt
);
10065 Make_Subtype_Declaration
(Loc
,
10066 Defining_Identifier
=> Subt
,
10067 Subtype_Indication
=> New_Reference_To
(Act_T
, Loc
));
10069 if Is_Private_Type
(Act_T
) then
10070 Set_Has_Private_View
(Subtype_Indication
(Decl_Node
));
10072 elsif Is_Access_Type
(Act_T
)
10073 and then Is_Private_Type
(Designated_Type
(Act_T
))
10075 Set_Has_Private_View
(Subtype_Indication
(Decl_Node
));
10078 Decl_Nodes
:= New_List
(Decl_Node
);
10080 -- Flag actual derived types so their elaboration produces the
10081 -- appropriate renamings for the primitive operations of the ancestor.
10082 -- Flag actual for formal private types as well, to determine whether
10083 -- operations in the private part may override inherited operations.
10084 -- If the formal has an interface list, the ancestor is not the
10085 -- parent, but the analyzed formal that includes the interface
10086 -- operations of all its progenitors.
10088 if Nkind
(Def
) = N_Formal_Derived_Type_Definition
then
10089 if Present
(Interface_List
(Def
)) then
10090 Set_Generic_Parent_Type
(Decl_Node
, A_Gen_T
);
10092 Set_Generic_Parent_Type
(Decl_Node
, Ancestor
);
10095 elsif Nkind
(Def
) = N_Formal_Private_Type_Definition
then
10096 Set_Generic_Parent_Type
(Decl_Node
, Ancestor
);
10099 -- If the actual is a synchronized type that implements an interface,
10100 -- the primitive operations are attached to the corresponding record,
10101 -- and we have to treat it as an additional generic actual, so that its
10102 -- primitive operations become visible in the instance. The task or
10103 -- protected type itself does not carry primitive operations.
10105 if Is_Concurrent_Type
(Act_T
)
10106 and then Is_Tagged_Type
(Act_T
)
10107 and then Present
(Corresponding_Record_Type
(Act_T
))
10108 and then Present
(Ancestor
)
10109 and then Is_Interface
(Ancestor
)
10112 Corr_Rec
: constant Entity_Id
:=
10113 Corresponding_Record_Type
(Act_T
);
10114 New_Corr
: Entity_Id
;
10115 Corr_Decl
: Node_Id
;
10118 New_Corr
:= Make_Defining_Identifier
(Loc
,
10119 Chars
=> New_Internal_Name
('S'));
10121 Make_Subtype_Declaration
(Loc
,
10122 Defining_Identifier
=> New_Corr
,
10123 Subtype_Indication
=>
10124 New_Reference_To
(Corr_Rec
, Loc
));
10125 Append_To
(Decl_Nodes
, Corr_Decl
);
10127 if Ekind
(Act_T
) = E_Task_Type
then
10128 Set_Ekind
(Subt
, E_Task_Subtype
);
10130 Set_Ekind
(Subt
, E_Protected_Subtype
);
10133 Set_Corresponding_Record_Type
(Subt
, Corr_Rec
);
10134 Set_Generic_Parent_Type
(Corr_Decl
, Ancestor
);
10135 Set_Generic_Parent_Type
(Decl_Node
, Empty
);
10140 end Instantiate_Type
;
10142 -----------------------
10143 -- Is_Generic_Formal --
10144 -----------------------
10146 function Is_Generic_Formal
(E
: Entity_Id
) return Boolean is
10152 Kind
:= Nkind
(Parent
(E
));
10154 Kind
= N_Formal_Object_Declaration
10155 or else Kind
= N_Formal_Package_Declaration
10156 or else Kind
= N_Formal_Type_Declaration
10158 (Is_Formal_Subprogram
(E
)
10160 Nkind
(Parent
(Parent
(E
))) in
10161 N_Formal_Subprogram_Declaration
);
10163 end Is_Generic_Formal
;
10165 ---------------------
10166 -- Is_In_Main_Unit --
10167 ---------------------
10169 function Is_In_Main_Unit
(N
: Node_Id
) return Boolean is
10170 Unum
: constant Unit_Number_Type
:= Get_Source_Unit
(N
);
10171 Current_Unit
: Node_Id
;
10174 if Unum
= Main_Unit
then
10177 -- If the current unit is a subunit then it is either the main unit or
10178 -- is being compiled as part of the main unit.
10180 elsif Nkind
(N
) = N_Compilation_Unit
then
10181 return Nkind
(Unit
(N
)) = N_Subunit
;
10184 Current_Unit
:= Parent
(N
);
10185 while Present
(Current_Unit
)
10186 and then Nkind
(Current_Unit
) /= N_Compilation_Unit
10188 Current_Unit
:= Parent
(Current_Unit
);
10191 -- The instantiation node is in the main unit, or else the current node
10192 -- (perhaps as the result of nested instantiations) is in the main unit,
10193 -- or in the declaration of the main unit, which in this last case must
10196 return Unum
= Main_Unit
10197 or else Current_Unit
= Cunit
(Main_Unit
)
10198 or else Current_Unit
= Library_Unit
(Cunit
(Main_Unit
))
10199 or else (Present
(Library_Unit
(Current_Unit
))
10200 and then Is_In_Main_Unit
(Library_Unit
(Current_Unit
)));
10201 end Is_In_Main_Unit
;
10203 ----------------------------
10204 -- Load_Parent_Of_Generic --
10205 ----------------------------
10207 procedure Load_Parent_Of_Generic
10210 Body_Optional
: Boolean := False)
10212 Comp_Unit
: constant Node_Id
:= Cunit
(Get_Source_Unit
(Spec
));
10213 Save_Style_Check
: constant Boolean := Style_Check
;
10214 True_Parent
: Node_Id
;
10215 Inst_Node
: Node_Id
;
10217 Previous_Instances
: constant Elist_Id
:= New_Elmt_List
;
10219 procedure Collect_Previous_Instances
(Decls
: List_Id
);
10220 -- Collect all instantiations in the given list of declarations, that
10221 -- precede the generic that we need to load. If the bodies of these
10222 -- instantiations are available, we must analyze them, to ensure that
10223 -- the public symbols generated are the same when the unit is compiled
10224 -- to generate code, and when it is compiled in the context of a unit
10225 -- that needs a particular nested instance.
10227 --------------------------------
10228 -- Collect_Previous_Instances --
10229 --------------------------------
10231 procedure Collect_Previous_Instances
(Decls
: List_Id
) is
10235 Decl
:= First
(Decls
);
10236 while Present
(Decl
) loop
10237 if Sloc
(Decl
) >= Sloc
(Inst_Node
) then
10240 -- If Decl is an instantiation, then record it as requiring
10241 -- instantiation of the corresponding body, except if it is an
10242 -- abbreviated instantiation generated internally for conformance
10243 -- checking purposes only for the case of a formal package
10244 -- declared without a box (see Instantiate_Formal_Package). Such
10245 -- an instantiation does not generate any code (the actual code
10246 -- comes from actual) and thus does not need to be analyzed here.
10248 elsif Nkind
(Decl
) = N_Package_Instantiation
10249 and then not Is_Internal
(Defining_Entity
(Decl
))
10251 Append_Elmt
(Decl
, Previous_Instances
);
10253 elsif Nkind
(Decl
) = N_Package_Declaration
then
10254 Collect_Previous_Instances
10255 (Visible_Declarations
(Specification
(Decl
)));
10256 Collect_Previous_Instances
10257 (Private_Declarations
(Specification
(Decl
)));
10259 elsif Nkind
(Decl
) = N_Package_Body
then
10260 Collect_Previous_Instances
(Declarations
(Decl
));
10265 end Collect_Previous_Instances
;
10267 -- Start of processing for Load_Parent_Of_Generic
10270 if not In_Same_Source_Unit
(N
, Spec
)
10271 or else Nkind
(Unit
(Comp_Unit
)) = N_Package_Declaration
10272 or else (Nkind
(Unit
(Comp_Unit
)) = N_Package_Body
10273 and then not Is_In_Main_Unit
(Spec
))
10275 -- Find body of parent of spec, and analyze it. A special case arises
10276 -- when the parent is an instantiation, that is to say when we are
10277 -- currently instantiating a nested generic. In that case, there is
10278 -- no separate file for the body of the enclosing instance. Instead,
10279 -- the enclosing body must be instantiated as if it were a pending
10280 -- instantiation, in order to produce the body for the nested generic
10281 -- we require now. Note that in that case the generic may be defined
10282 -- in a package body, the instance defined in the same package body,
10283 -- and the original enclosing body may not be in the main unit.
10285 Inst_Node
:= Empty
;
10287 True_Parent
:= Parent
(Spec
);
10288 while Present
(True_Parent
)
10289 and then Nkind
(True_Parent
) /= N_Compilation_Unit
10291 if Nkind
(True_Parent
) = N_Package_Declaration
10293 Nkind
(Original_Node
(True_Parent
)) = N_Package_Instantiation
10295 -- Parent is a compilation unit that is an instantiation.
10296 -- Instantiation node has been replaced with package decl.
10298 Inst_Node
:= Original_Node
(True_Parent
);
10301 elsif Nkind
(True_Parent
) = N_Package_Declaration
10302 and then Present
(Generic_Parent
(Specification
(True_Parent
)))
10303 and then Nkind
(Parent
(True_Parent
)) /= N_Compilation_Unit
10305 -- Parent is an instantiation within another specification.
10306 -- Declaration for instance has been inserted before original
10307 -- instantiation node. A direct link would be preferable?
10309 Inst_Node
:= Next
(True_Parent
);
10310 while Present
(Inst_Node
)
10311 and then Nkind
(Inst_Node
) /= N_Package_Instantiation
10316 -- If the instance appears within a generic, and the generic
10317 -- unit is defined within a formal package of the enclosing
10318 -- generic, there is no generic body available, and none
10319 -- needed. A more precise test should be used ???
10321 if No
(Inst_Node
) then
10328 True_Parent
:= Parent
(True_Parent
);
10332 -- Case where we are currently instantiating a nested generic
10334 if Present
(Inst_Node
) then
10335 if Nkind
(Parent
(True_Parent
)) = N_Compilation_Unit
then
10337 -- Instantiation node and declaration of instantiated package
10338 -- were exchanged when only the declaration was needed.
10339 -- Restore instantiation node before proceeding with body.
10341 Set_Unit
(Parent
(True_Parent
), Inst_Node
);
10344 -- Now complete instantiation of enclosing body, if it appears
10345 -- in some other unit. If it appears in the current unit, the
10346 -- body will have been instantiated already.
10348 if No
(Corresponding_Body
(Instance_Spec
(Inst_Node
))) then
10350 -- We need to determine the expander mode to instantiate the
10351 -- enclosing body. Because the generic body we need may use
10352 -- global entities declared in the enclosing package (including
10353 -- aggregates) it is in general necessary to compile this body
10354 -- with expansion enabled. The exception is if we are within a
10355 -- generic package, in which case the usual generic rule
10359 Exp_Status
: Boolean := True;
10363 -- Loop through scopes looking for generic package
10365 Scop
:= Scope
(Defining_Entity
(Instance_Spec
(Inst_Node
)));
10366 while Present
(Scop
)
10367 and then Scop
/= Standard_Standard
10369 if Ekind
(Scop
) = E_Generic_Package
then
10370 Exp_Status
:= False;
10374 Scop
:= Scope
(Scop
);
10377 -- Collect previous instantiations in the unit that
10378 -- contains the desired generic.
10380 if Nkind
(Parent
(True_Parent
)) /= N_Compilation_Unit
10381 and then not Body_Optional
10388 Par
:= Parent
(Inst_Node
);
10389 while Present
(Par
) loop
10390 exit when Nkind
(Parent
(Par
)) = N_Compilation_Unit
;
10391 Par
:= Parent
(Par
);
10394 pragma Assert
(Present
(Par
));
10396 if Nkind
(Par
) = N_Package_Body
then
10397 Collect_Previous_Instances
(Declarations
(Par
));
10399 elsif Nkind
(Par
) = N_Package_Declaration
then
10400 Collect_Previous_Instances
10401 (Visible_Declarations
(Specification
(Par
)));
10402 Collect_Previous_Instances
10403 (Private_Declarations
(Specification
(Par
)));
10406 -- Enclosing unit is a subprogram body, In this
10407 -- case all instance bodies are processed in order
10408 -- and there is no need to collect them separately.
10413 Decl
:= First_Elmt
(Previous_Instances
);
10414 while Present
(Decl
) loop
10415 Instantiate_Package_Body
10417 ((Inst_Node
=> Node
(Decl
),
10419 Instance_Spec
(Node
(Decl
)),
10420 Expander_Status
=> Exp_Status
,
10421 Current_Sem_Unit
=>
10422 Get_Code_Unit
(Sloc
(Node
(Decl
))),
10423 Scope_Suppress
=> Scope_Suppress
,
10424 Local_Suppress_Stack_Top
=>
10425 Local_Suppress_Stack_Top
)),
10426 Body_Optional
=> True);
10433 Instantiate_Package_Body
10435 ((Inst_Node
=> Inst_Node
,
10436 Act_Decl
=> True_Parent
,
10437 Expander_Status
=> Exp_Status
,
10438 Current_Sem_Unit
=>
10439 Get_Code_Unit
(Sloc
(Inst_Node
)),
10440 Scope_Suppress
=> Scope_Suppress
,
10441 Local_Suppress_Stack_Top
=>
10442 Local_Suppress_Stack_Top
)),
10443 Body_Optional
=> Body_Optional
);
10447 -- Case where we are not instantiating a nested generic
10450 Opt
.Style_Check
:= False;
10451 Expander_Mode_Save_And_Set
(True);
10452 Load_Needed_Body
(Comp_Unit
, OK
);
10453 Opt
.Style_Check
:= Save_Style_Check
;
10454 Expander_Mode_Restore
;
10457 and then Unit_Requires_Body
(Defining_Entity
(Spec
))
10458 and then not Body_Optional
10461 Bname
: constant Unit_Name_Type
:=
10462 Get_Body_Name
(Get_Unit_Name
(Unit
(Comp_Unit
)));
10465 Error_Msg_Unit_1
:= Bname
;
10466 Error_Msg_N
("this instantiation requires$!", N
);
10467 Error_Msg_File_1
:= Get_File_Name
(Bname
, Subunit
=> False);
10468 Error_Msg_N
("\but file{ was not found!", N
);
10469 raise Unrecoverable_Error
;
10475 -- If loading parent of the generic caused an instantiation circularity,
10476 -- we abandon compilation at this point, because otherwise in some cases
10477 -- we get into trouble with infinite recursions after this point.
10479 if Circularity_Detected
then
10480 raise Unrecoverable_Error
;
10482 end Load_Parent_Of_Generic
;
10484 -----------------------
10485 -- Move_Freeze_Nodes --
10486 -----------------------
10488 procedure Move_Freeze_Nodes
10489 (Out_Of
: Entity_Id
;
10494 Next_Decl
: Node_Id
;
10495 Next_Node
: Node_Id
:= After
;
10498 function Is_Outer_Type
(T
: Entity_Id
) return Boolean;
10499 -- Check whether entity is declared in a scope external to that
10500 -- of the generic unit.
10502 -------------------
10503 -- Is_Outer_Type --
10504 -------------------
10506 function Is_Outer_Type
(T
: Entity_Id
) return Boolean is
10507 Scop
: Entity_Id
:= Scope
(T
);
10510 if Scope_Depth
(Scop
) < Scope_Depth
(Out_Of
) then
10514 while Scop
/= Standard_Standard
loop
10515 if Scop
= Out_Of
then
10518 Scop
:= Scope
(Scop
);
10526 -- Start of processing for Move_Freeze_Nodes
10533 -- First remove the freeze nodes that may appear before all other
10537 while Present
(Decl
)
10538 and then Nkind
(Decl
) = N_Freeze_Entity
10539 and then Is_Outer_Type
(Entity
(Decl
))
10541 Decl
:= Remove_Head
(L
);
10542 Insert_After
(Next_Node
, Decl
);
10543 Set_Analyzed
(Decl
, False);
10548 -- Next scan the list of declarations and remove each freeze node that
10549 -- appears ahead of the current node.
10551 while Present
(Decl
) loop
10552 while Present
(Next
(Decl
))
10553 and then Nkind
(Next
(Decl
)) = N_Freeze_Entity
10554 and then Is_Outer_Type
(Entity
(Next
(Decl
)))
10556 Next_Decl
:= Remove_Next
(Decl
);
10557 Insert_After
(Next_Node
, Next_Decl
);
10558 Set_Analyzed
(Next_Decl
, False);
10559 Next_Node
:= Next_Decl
;
10562 -- If the declaration is a nested package or concurrent type, then
10563 -- recurse. Nested generic packages will have been processed from the
10566 if Nkind
(Decl
) = N_Package_Declaration
then
10567 Spec
:= Specification
(Decl
);
10569 elsif Nkind
(Decl
) = N_Task_Type_Declaration
then
10570 Spec
:= Task_Definition
(Decl
);
10572 elsif Nkind
(Decl
) = N_Protected_Type_Declaration
then
10573 Spec
:= Protected_Definition
(Decl
);
10579 if Present
(Spec
) then
10580 Move_Freeze_Nodes
(Out_Of
, Next_Node
,
10581 Visible_Declarations
(Spec
));
10582 Move_Freeze_Nodes
(Out_Of
, Next_Node
,
10583 Private_Declarations
(Spec
));
10588 end Move_Freeze_Nodes
;
10594 function Next_Assoc
(E
: Assoc_Ptr
) return Assoc_Ptr
is
10596 return Generic_Renamings
.Table
(E
).Next_In_HTable
;
10599 ------------------------
10600 -- Preanalyze_Actuals --
10601 ------------------------
10603 procedure Pre_Analyze_Actuals
(N
: Node_Id
) is
10606 Errs
: constant Int
:= Serious_Errors_Detected
;
10609 Assoc
:= First
(Generic_Associations
(N
));
10610 while Present
(Assoc
) loop
10611 if Nkind
(Assoc
) /= N_Others_Choice
then
10612 Act
:= Explicit_Generic_Actual_Parameter
(Assoc
);
10614 -- Within a nested instantiation, a defaulted actual is an empty
10615 -- association, so nothing to analyze. If the subprogram actual
10616 -- isan attribute, analyze prefix only, because actual is not a
10617 -- complete attribute reference.
10619 -- If actual is an allocator, analyze expression only. The full
10620 -- analysis can generate code, and if instance is a compilation
10621 -- unit we have to wait until the package instance is installed
10622 -- to have a proper place to insert this code.
10624 -- String literals may be operators, but at this point we do not
10625 -- know whether the actual is a formal subprogram or a string.
10630 elsif Nkind
(Act
) = N_Attribute_Reference
then
10631 Analyze
(Prefix
(Act
));
10633 elsif Nkind
(Act
) = N_Explicit_Dereference
then
10634 Analyze
(Prefix
(Act
));
10636 elsif Nkind
(Act
) = N_Allocator
then
10638 Expr
: constant Node_Id
:= Expression
(Act
);
10641 if Nkind
(Expr
) = N_Subtype_Indication
then
10642 Analyze
(Subtype_Mark
(Expr
));
10644 -- Analyze separately each discriminant constraint,
10645 -- when given with a named association.
10651 Constr
:= First
(Constraints
(Constraint
(Expr
)));
10652 while Present
(Constr
) loop
10653 if Nkind
(Constr
) = N_Discriminant_Association
then
10654 Analyze
(Expression
(Constr
));
10668 elsif Nkind
(Act
) /= N_Operator_Symbol
then
10672 if Errs
/= Serious_Errors_Detected
then
10673 Abandon_Instantiation
(Act
);
10679 end Pre_Analyze_Actuals
;
10681 -------------------
10682 -- Remove_Parent --
10683 -------------------
10685 procedure Remove_Parent
(In_Body
: Boolean := False) is
10686 S
: Entity_Id
:= Current_Scope
;
10692 -- After child instantiation is complete, remove from scope stack the
10693 -- extra copy of the current scope, and then remove parent instances.
10695 if not In_Body
then
10698 while Current_Scope
/= S
loop
10699 P
:= Current_Scope
;
10700 End_Package_Scope
(Current_Scope
);
10702 if In_Open_Scopes
(P
) then
10703 E
:= First_Entity
(P
);
10705 while Present
(E
) loop
10706 Set_Is_Immediately_Visible
(E
, True);
10710 if Is_Generic_Instance
(Current_Scope
)
10711 and then P
/= Current_Scope
10713 -- We are within an instance of some sibling. Retain
10714 -- visibility of parent, for proper subsequent cleanup,
10715 -- and reinstall private declarations as well.
10717 Set_In_Private_Part
(P
);
10718 Install_Private_Declarations
(P
);
10721 -- If the ultimate parent is a top-level unit recorded in
10722 -- Instance_Parent_Unit, then reset its visibility to what
10723 -- it was before instantiation. (It's not clear what the
10724 -- purpose is of testing whether Scope (P) is In_Open_Scopes,
10725 -- but that test was present before the ultimate parent test
10728 elsif not In_Open_Scopes
(Scope
(P
))
10729 or else (P
= Instance_Parent_Unit
10730 and then not Parent_Unit_Visible
)
10732 Set_Is_Immediately_Visible
(P
, False);
10736 -- Reset visibility of entities in the enclosing scope
10738 Set_Is_Hidden_Open_Scope
(Current_Scope
, False);
10739 Hidden
:= First_Elmt
(Hidden_Entities
);
10741 while Present
(Hidden
) loop
10742 Set_Is_Immediately_Visible
(Node
(Hidden
), True);
10743 Next_Elmt
(Hidden
);
10747 -- Each body is analyzed separately, and there is no context
10748 -- that needs preserving from one body instance to the next,
10749 -- so remove all parent scopes that have been installed.
10751 while Present
(S
) loop
10752 End_Package_Scope
(S
);
10753 Set_Is_Immediately_Visible
(S
, False);
10754 S
:= Current_Scope
;
10755 exit when S
= Standard_Standard
;
10764 procedure Restore_Env
is
10765 Saved
: Instance_Env
renames Instance_Envs
.Table
(Instance_Envs
.Last
);
10768 if No
(Current_Instantiated_Parent
.Act_Id
) then
10770 -- Restore environment after subprogram inlining
10772 Restore_Private_Views
(Empty
);
10775 Current_Instantiated_Parent
:= Saved
.Instantiated_Parent
;
10776 Exchanged_Views
:= Saved
.Exchanged_Views
;
10777 Hidden_Entities
:= Saved
.Hidden_Entities
;
10778 Current_Sem_Unit
:= Saved
.Current_Sem_Unit
;
10779 Parent_Unit_Visible
:= Saved
.Parent_Unit_Visible
;
10780 Instance_Parent_Unit
:= Saved
.Instance_Parent_Unit
;
10782 Restore_Opt_Config_Switches
(Saved
.Switches
);
10784 Instance_Envs
.Decrement_Last
;
10787 ---------------------------
10788 -- Restore_Private_Views --
10789 ---------------------------
10791 procedure Restore_Private_Views
10792 (Pack_Id
: Entity_Id
;
10793 Is_Package
: Boolean := True)
10798 Dep_Elmt
: Elmt_Id
;
10801 procedure Restore_Nested_Formal
(Formal
: Entity_Id
);
10802 -- Hide the generic formals of formal packages declared with box
10803 -- which were reachable in the current instantiation.
10805 ---------------------------
10806 -- Restore_Nested_Formal --
10807 ---------------------------
10809 procedure Restore_Nested_Formal
(Formal
: Entity_Id
) is
10813 if Present
(Renamed_Object
(Formal
))
10814 and then Denotes_Formal_Package
(Renamed_Object
(Formal
), True)
10818 elsif Present
(Associated_Formal_Package
(Formal
)) then
10820 Ent
:= First_Entity
(Formal
);
10821 while Present
(Ent
) loop
10822 exit when Ekind
(Ent
) = E_Package
10823 and then Renamed_Entity
(Ent
) = Renamed_Entity
(Formal
);
10825 Set_Is_Hidden
(Ent
);
10826 Set_Is_Potentially_Use_Visible
(Ent
, False);
10828 -- If package, then recurse
10830 if Ekind
(Ent
) = E_Package
then
10831 Restore_Nested_Formal
(Ent
);
10837 end Restore_Nested_Formal
;
10839 -- Start of processing for Restore_Private_Views
10842 M
:= First_Elmt
(Exchanged_Views
);
10843 while Present
(M
) loop
10846 -- Subtypes of types whose views have been exchanged, and that
10847 -- are defined within the instance, were not on the list of
10848 -- Private_Dependents on entry to the instance, so they have to
10849 -- be exchanged explicitly now, in order to remain consistent with
10850 -- the view of the parent type.
10852 if Ekind
(Typ
) = E_Private_Type
10853 or else Ekind
(Typ
) = E_Limited_Private_Type
10854 or else Ekind
(Typ
) = E_Record_Type_With_Private
10856 Dep_Elmt
:= First_Elmt
(Private_Dependents
(Typ
));
10857 while Present
(Dep_Elmt
) loop
10858 Dep_Typ
:= Node
(Dep_Elmt
);
10860 if Scope
(Dep_Typ
) = Pack_Id
10861 and then Present
(Full_View
(Dep_Typ
))
10863 Replace_Elmt
(Dep_Elmt
, Full_View
(Dep_Typ
));
10864 Exchange_Declarations
(Dep_Typ
);
10867 Next_Elmt
(Dep_Elmt
);
10871 Exchange_Declarations
(Node
(M
));
10875 if No
(Pack_Id
) then
10879 -- Make the generic formal parameters private, and make the formal
10880 -- types into subtypes of the actuals again.
10882 E
:= First_Entity
(Pack_Id
);
10883 while Present
(E
) loop
10884 Set_Is_Hidden
(E
, True);
10887 and then Nkind
(Parent
(E
)) = N_Subtype_Declaration
10889 Set_Is_Generic_Actual_Type
(E
, False);
10891 -- An unusual case of aliasing: the actual may also be directly
10892 -- visible in the generic, and be private there, while it is fully
10893 -- visible in the context of the instance. The internal subtype is
10894 -- private in the instance, but has full visibility like its
10895 -- parent in the enclosing scope. This enforces the invariant that
10896 -- the privacy status of all private dependents of a type coincide
10897 -- with that of the parent type. This can only happen when a
10898 -- generic child unit is instantiated within sibling.
10900 if Is_Private_Type
(E
)
10901 and then not Is_Private_Type
(Etype
(E
))
10903 Exchange_Declarations
(E
);
10906 elsif Ekind
(E
) = E_Package
then
10908 -- The end of the renaming list is the renaming of the generic
10909 -- package itself. If the instance is a subprogram, all entities
10910 -- in the corresponding package are renamings. If this entity is
10911 -- a formal package, make its own formals private as well. The
10912 -- actual in this case is itself the renaming of an instantation.
10913 -- If the entity is not a package renaming, it is the entity
10914 -- created to validate formal package actuals: ignore.
10916 -- If the actual is itself a formal package for the enclosing
10917 -- generic, or the actual for such a formal package, it remains
10918 -- visible on exit from the instance, and therefore nothing
10919 -- needs to be done either, except to keep it accessible.
10922 and then Renamed_Object
(E
) = Pack_Id
10926 elsif Nkind
(Parent
(E
)) /= N_Package_Renaming_Declaration
then
10929 elsif Denotes_Formal_Package
(Renamed_Object
(E
), True) then
10930 Set_Is_Hidden
(E
, False);
10934 Act_P
: constant Entity_Id
:= Renamed_Object
(E
);
10938 Id
:= First_Entity
(Act_P
);
10940 and then Id
/= First_Private_Entity
(Act_P
)
10942 exit when Ekind
(Id
) = E_Package
10943 and then Renamed_Object
(Id
) = Act_P
;
10945 Set_Is_Hidden
(Id
, True);
10946 Set_Is_Potentially_Use_Visible
(Id
, In_Use
(Act_P
));
10948 if Ekind
(Id
) = E_Package
then
10949 Restore_Nested_Formal
(Id
);
10960 end Restore_Private_Views
;
10967 (Gen_Unit
: Entity_Id
;
10968 Act_Unit
: Entity_Id
)
10972 Set_Instance_Env
(Gen_Unit
, Act_Unit
);
10975 ----------------------------
10976 -- Save_Global_References --
10977 ----------------------------
10979 procedure Save_Global_References
(N
: Node_Id
) is
10980 Gen_Scope
: Entity_Id
;
10984 function Is_Global
(E
: Entity_Id
) return Boolean;
10985 -- Check whether entity is defined outside of generic unit. Examine the
10986 -- scope of an entity, and the scope of the scope, etc, until we find
10987 -- either Standard, in which case the entity is global, or the generic
10988 -- unit itself, which indicates that the entity is local. If the entity
10989 -- is the generic unit itself, as in the case of a recursive call, or
10990 -- the enclosing generic unit, if different from the current scope, then
10991 -- it is local as well, because it will be replaced at the point of
10992 -- instantiation. On the other hand, if it is a reference to a child
10993 -- unit of a common ancestor, which appears in an instantiation, it is
10994 -- global because it is used to denote a specific compilation unit at
10995 -- the time the instantiations will be analyzed.
10997 procedure Reset_Entity
(N
: Node_Id
);
10998 -- Save semantic information on global entity, so that it is not
10999 -- resolved again at instantiation time.
11001 procedure Save_Entity_Descendants
(N
: Node_Id
);
11002 -- Apply Save_Global_References to the two syntactic descendants of
11003 -- non-terminal nodes that carry an Associated_Node and are processed
11004 -- through Reset_Entity. Once the global entity (if any) has been
11005 -- captured together with its type, only two syntactic descendants need
11006 -- to be traversed to complete the processing of the tree rooted at N.
11007 -- This applies to Selected_Components, Expanded_Names, and to Operator
11008 -- nodes. N can also be a character literal, identifier, or operator
11009 -- symbol node, but the call has no effect in these cases.
11011 procedure Save_Global_Defaults
(N1
, N2
: Node_Id
);
11012 -- Default actuals in nested instances must be handled specially
11013 -- because there is no link to them from the original tree. When an
11014 -- actual subprogram is given by a default, we add an explicit generic
11015 -- association for it in the instantiation node. When we save the
11016 -- global references on the name of the instance, we recover the list
11017 -- of generic associations, and add an explicit one to the original
11018 -- generic tree, through which a global actual can be preserved.
11019 -- Similarly, if a child unit is instantiated within a sibling, in the
11020 -- context of the parent, we must preserve the identifier of the parent
11021 -- so that it can be properly resolved in a subsequent instantiation.
11023 procedure Save_Global_Descendant
(D
: Union_Id
);
11024 -- Apply Save_Global_References recursively to the descendents of the
11027 procedure Save_References
(N
: Node_Id
);
11028 -- This is the recursive procedure that does the work, once the
11029 -- enclosing generic scope has been established.
11035 function Is_Global
(E
: Entity_Id
) return Boolean is
11036 Se
: Entity_Id
:= Scope
(E
);
11038 function Is_Instance_Node
(Decl
: Node_Id
) return Boolean;
11039 -- Determine whether the parent node of a reference to a child unit
11040 -- denotes an instantiation or a formal package, in which case the
11041 -- reference to the child unit is global, even if it appears within
11042 -- the current scope (e.g. when the instance appears within the body
11043 -- of an ancestor).
11045 ----------------------
11046 -- Is_Instance_Node --
11047 ----------------------
11049 function Is_Instance_Node
(Decl
: Node_Id
) return Boolean is
11051 return (Nkind
(Decl
) in N_Generic_Instantiation
11053 Nkind
(Original_Node
(Decl
)) = N_Formal_Package_Declaration
);
11054 end Is_Instance_Node
;
11056 -- Start of processing for Is_Global
11059 if E
= Gen_Scope
then
11062 elsif E
= Standard_Standard
then
11065 elsif Is_Child_Unit
(E
)
11066 and then (Is_Instance_Node
(Parent
(N2
))
11067 or else (Nkind
(Parent
(N2
)) = N_Expanded_Name
11068 and then N2
= Selector_Name
(Parent
(N2
))
11069 and then Is_Instance_Node
(Parent
(Parent
(N2
)))))
11074 while Se
/= Gen_Scope
loop
11075 if Se
= Standard_Standard
then
11090 procedure Reset_Entity
(N
: Node_Id
) is
11092 procedure Set_Global_Type
(N
: Node_Id
; N2
: Node_Id
);
11093 -- If the type of N2 is global to the generic unit. Save
11094 -- the type in the generic node.
11096 function Top_Ancestor
(E
: Entity_Id
) return Entity_Id
;
11097 -- Find the ultimate ancestor of the current unit. If it is
11098 -- not a generic unit, then the name of the current unit
11099 -- in the prefix of an expanded name must be replaced with
11100 -- its generic homonym to ensure that it will be properly
11101 -- resolved in an instance.
11103 ---------------------
11104 -- Set_Global_Type --
11105 ---------------------
11107 procedure Set_Global_Type
(N
: Node_Id
; N2
: Node_Id
) is
11108 Typ
: constant Entity_Id
:= Etype
(N2
);
11111 Set_Etype
(N
, Typ
);
11113 if Entity
(N
) /= N2
11114 and then Has_Private_View
(Entity
(N
))
11116 -- If the entity of N is not the associated node, this is
11117 -- a nested generic and it has an associated node as well,
11118 -- whose type is already the full view (see below). Indicate
11119 -- that the original node has a private view.
11121 Set_Has_Private_View
(N
);
11124 -- If not a private type, nothing else to do
11126 if not Is_Private_Type
(Typ
) then
11127 if Is_Array_Type
(Typ
)
11128 and then Is_Private_Type
(Component_Type
(Typ
))
11130 Set_Has_Private_View
(N
);
11133 -- If it is a derivation of a private type in a context where
11134 -- no full view is needed, nothing to do either.
11136 elsif No
(Full_View
(Typ
)) and then Typ
/= Etype
(Typ
) then
11139 -- Otherwise mark the type for flipping and use the full_view
11143 Set_Has_Private_View
(N
);
11145 if Present
(Full_View
(Typ
)) then
11146 Set_Etype
(N2
, Full_View
(Typ
));
11149 end Set_Global_Type
;
11155 function Top_Ancestor
(E
: Entity_Id
) return Entity_Id
is
11156 Par
: Entity_Id
:= E
;
11159 while Is_Child_Unit
(Par
) loop
11160 Par
:= Scope
(Par
);
11166 -- Start of processing for Reset_Entity
11169 N2
:= Get_Associated_Node
(N
);
11172 if Present
(E
) then
11173 if Is_Global
(E
) then
11174 Set_Global_Type
(N
, N2
);
11176 elsif Nkind
(N
) = N_Op_Concat
11177 and then Is_Generic_Type
(Etype
(N2
))
11179 (Base_Type
(Etype
(Right_Opnd
(N2
))) = Etype
(N2
)
11180 or else Base_Type
(Etype
(Left_Opnd
(N2
))) = Etype
(N2
))
11181 and then Is_Intrinsic_Subprogram
(E
)
11186 -- Entity is local. Mark generic node as unresolved.
11187 -- Note that now it does not have an entity.
11189 Set_Associated_Node
(N
, Empty
);
11190 Set_Etype
(N
, Empty
);
11193 if Nkind
(Parent
(N
)) in N_Generic_Instantiation
11194 and then N
= Name
(Parent
(N
))
11196 Save_Global_Defaults
(Parent
(N
), Parent
(N2
));
11199 elsif Nkind
(Parent
(N
)) = N_Selected_Component
11200 and then Nkind
(Parent
(N2
)) = N_Expanded_Name
11202 if Is_Global
(Entity
(Parent
(N2
))) then
11203 Change_Selected_Component_To_Expanded_Name
(Parent
(N
));
11204 Set_Associated_Node
(Parent
(N
), Parent
(N2
));
11205 Set_Global_Type
(Parent
(N
), Parent
(N2
));
11206 Save_Entity_Descendants
(N
);
11208 -- If this is a reference to the current generic entity, replace
11209 -- by the name of the generic homonym of the current package. This
11210 -- is because in an instantiation Par.P.Q will not resolve to the
11211 -- name of the instance, whose enclosing scope is not necessarily
11212 -- Par. We use the generic homonym rather that the name of the
11213 -- generic itself, because it may be hidden by a local
11216 elsif In_Open_Scopes
(Entity
(Parent
(N2
)))
11218 Is_Generic_Unit
(Top_Ancestor
(Entity
(Prefix
(Parent
(N2
)))))
11220 if Ekind
(Entity
(Parent
(N2
))) = E_Generic_Package
then
11221 Rewrite
(Parent
(N
),
11222 Make_Identifier
(Sloc
(N
),
11224 Chars
(Generic_Homonym
(Entity
(Parent
(N2
))))));
11226 Rewrite
(Parent
(N
),
11227 Make_Identifier
(Sloc
(N
),
11228 Chars
=> Chars
(Selector_Name
(Parent
(N2
)))));
11232 if Nkind
(Parent
(Parent
(N
))) in N_Generic_Instantiation
11233 and then Parent
(N
) = Name
(Parent
(Parent
(N
)))
11235 Save_Global_Defaults
11236 (Parent
(Parent
(N
)), Parent
(Parent
((N2
))));
11239 -- A selected component may denote a static constant that has been
11240 -- folded. If the static constant is global to the generic, capture
11241 -- its value. Otherwise the folding will happen in any instantiation,
11243 elsif Nkind
(Parent
(N
)) = N_Selected_Component
11244 and then (Nkind
(Parent
(N2
)) = N_Integer_Literal
11245 or else Nkind
(Parent
(N2
)) = N_Real_Literal
)
11247 if Present
(Entity
(Original_Node
(Parent
(N2
))))
11248 and then Is_Global
(Entity
(Original_Node
(Parent
(N2
))))
11250 Rewrite
(Parent
(N
), New_Copy
(Parent
(N2
)));
11251 Set_Analyzed
(Parent
(N
), False);
11257 -- A selected component may be transformed into a parameterless
11258 -- function call. If the called entity is global, rewrite the node
11259 -- appropriately, i.e. as an extended name for the global entity.
11261 elsif Nkind
(Parent
(N
)) = N_Selected_Component
11262 and then Nkind
(Parent
(N2
)) = N_Function_Call
11263 and then N
= Selector_Name
(Parent
(N
))
11265 if No
(Parameter_Associations
(Parent
(N2
))) then
11266 if Is_Global
(Entity
(Name
(Parent
(N2
)))) then
11267 Change_Selected_Component_To_Expanded_Name
(Parent
(N
));
11268 Set_Associated_Node
(Parent
(N
), Name
(Parent
(N2
)));
11269 Set_Global_Type
(Parent
(N
), Name
(Parent
(N2
)));
11270 Save_Entity_Descendants
(N
);
11273 Set_Associated_Node
(N
, Empty
);
11274 Set_Etype
(N
, Empty
);
11277 -- In Ada 2005, X.F may be a call to a primitive operation,
11278 -- rewritten as F (X). This rewriting will be done again in an
11279 -- instance, so keep the original node. Global entities will be
11280 -- captured as for other constructs.
11286 -- Entity is local. Reset in generic unit, so that node is resolved
11287 -- anew at the point of instantiation.
11290 Set_Associated_Node
(N
, Empty
);
11291 Set_Etype
(N
, Empty
);
11295 -----------------------------
11296 -- Save_Entity_Descendants --
11297 -----------------------------
11299 procedure Save_Entity_Descendants
(N
: Node_Id
) is
11302 when N_Binary_Op
=>
11303 Save_Global_Descendant
(Union_Id
(Left_Opnd
(N
)));
11304 Save_Global_Descendant
(Union_Id
(Right_Opnd
(N
)));
11307 Save_Global_Descendant
(Union_Id
(Right_Opnd
(N
)));
11309 when N_Expanded_Name | N_Selected_Component
=>
11310 Save_Global_Descendant
(Union_Id
(Prefix
(N
)));
11311 Save_Global_Descendant
(Union_Id
(Selector_Name
(N
)));
11313 when N_Identifier | N_Character_Literal | N_Operator_Symbol
=>
11317 raise Program_Error
;
11319 end Save_Entity_Descendants
;
11321 --------------------------
11322 -- Save_Global_Defaults --
11323 --------------------------
11325 procedure Save_Global_Defaults
(N1
, N2
: Node_Id
) is
11326 Loc
: constant Source_Ptr
:= Sloc
(N1
);
11327 Assoc2
: constant List_Id
:= Generic_Associations
(N2
);
11328 Gen_Id
: constant Entity_Id
:= Get_Generic_Entity
(N2
);
11335 Actual
: Entity_Id
;
11338 Assoc1
:= Generic_Associations
(N1
);
11340 if Present
(Assoc1
) then
11341 Act1
:= First
(Assoc1
);
11344 Set_Generic_Associations
(N1
, New_List
);
11345 Assoc1
:= Generic_Associations
(N1
);
11348 if Present
(Assoc2
) then
11349 Act2
:= First
(Assoc2
);
11354 while Present
(Act1
) and then Present
(Act2
) loop
11359 -- Find the associations added for default suprograms
11361 if Present
(Act2
) then
11362 while Nkind
(Act2
) /= N_Generic_Association
11363 or else No
(Entity
(Selector_Name
(Act2
)))
11364 or else not Is_Overloadable
(Entity
(Selector_Name
(Act2
)))
11369 -- Add a similar association if the default is global. The
11370 -- renaming declaration for the actual has been analyzed, and
11371 -- its alias is the program it renames. Link the actual in the
11372 -- original generic tree with the node in the analyzed tree.
11374 while Present
(Act2
) loop
11375 Subp
:= Entity
(Selector_Name
(Act2
));
11376 Def
:= Explicit_Generic_Actual_Parameter
(Act2
);
11378 -- Following test is defence against rubbish errors
11380 if No
(Alias
(Subp
)) then
11384 -- Retrieve the resolved actual from the renaming declaration
11385 -- created for the instantiated formal.
11387 Actual
:= Entity
(Name
(Parent
(Parent
(Subp
))));
11388 Set_Entity
(Def
, Actual
);
11389 Set_Etype
(Def
, Etype
(Actual
));
11391 if Is_Global
(Actual
) then
11393 Make_Generic_Association
(Loc
,
11394 Selector_Name
=> New_Occurrence_Of
(Subp
, Loc
),
11395 Explicit_Generic_Actual_Parameter
=>
11396 New_Occurrence_Of
(Actual
, Loc
));
11398 Set_Associated_Node
11399 (Explicit_Generic_Actual_Parameter
(Ndec
), Def
);
11401 Append
(Ndec
, Assoc1
);
11403 -- If there are other defaults, add a dummy association in case
11404 -- there are other defaulted formals with the same name.
11406 elsif Present
(Next
(Act2
)) then
11408 Make_Generic_Association
(Loc
,
11409 Selector_Name
=> New_Occurrence_Of
(Subp
, Loc
),
11410 Explicit_Generic_Actual_Parameter
=> Empty
);
11412 Append
(Ndec
, Assoc1
);
11419 if Nkind
(Name
(N1
)) = N_Identifier
11420 and then Is_Child_Unit
(Gen_Id
)
11421 and then Is_Global
(Gen_Id
)
11422 and then Is_Generic_Unit
(Scope
(Gen_Id
))
11423 and then In_Open_Scopes
(Scope
(Gen_Id
))
11425 -- This is an instantiation of a child unit within a sibling,
11426 -- so that the generic parent is in scope. An eventual instance
11427 -- must occur within the scope of an instance of the parent.
11428 -- Make name in instance into an expanded name, to preserve the
11429 -- identifier of the parent, so it can be resolved subsequently.
11431 Rewrite
(Name
(N2
),
11432 Make_Expanded_Name
(Loc
,
11433 Chars
=> Chars
(Gen_Id
),
11434 Prefix
=> New_Occurrence_Of
(Scope
(Gen_Id
), Loc
),
11435 Selector_Name
=> New_Occurrence_Of
(Gen_Id
, Loc
)));
11436 Set_Entity
(Name
(N2
), Gen_Id
);
11438 Rewrite
(Name
(N1
),
11439 Make_Expanded_Name
(Loc
,
11440 Chars
=> Chars
(Gen_Id
),
11441 Prefix
=> New_Occurrence_Of
(Scope
(Gen_Id
), Loc
),
11442 Selector_Name
=> New_Occurrence_Of
(Gen_Id
, Loc
)));
11444 Set_Associated_Node
(Name
(N1
), Name
(N2
));
11445 Set_Associated_Node
(Prefix
(Name
(N1
)), Empty
);
11446 Set_Associated_Node
11447 (Selector_Name
(Name
(N1
)), Selector_Name
(Name
(N2
)));
11448 Set_Etype
(Name
(N1
), Etype
(Gen_Id
));
11451 end Save_Global_Defaults
;
11453 ----------------------------
11454 -- Save_Global_Descendant --
11455 ----------------------------
11457 procedure Save_Global_Descendant
(D
: Union_Id
) is
11461 if D
in Node_Range
then
11462 if D
= Union_Id
(Empty
) then
11465 elsif Nkind
(Node_Id
(D
)) /= N_Compilation_Unit
then
11466 Save_References
(Node_Id
(D
));
11469 elsif D
in List_Range
then
11470 if D
= Union_Id
(No_List
)
11471 or else Is_Empty_List
(List_Id
(D
))
11476 N1
:= First
(List_Id
(D
));
11477 while Present
(N1
) loop
11478 Save_References
(N1
);
11483 -- Element list or other non-node field, nothing to do
11488 end Save_Global_Descendant
;
11490 ---------------------
11491 -- Save_References --
11492 ---------------------
11494 -- This is the recursive procedure that does the work, once the
11495 -- enclosing generic scope has been established. We have to treat
11496 -- specially a number of node rewritings that are required by semantic
11497 -- processing and which change the kind of nodes in the generic copy:
11498 -- typically constant-folding, replacing an operator node by a string
11499 -- literal, or a selected component by an expanded name. In each of
11500 -- those cases, the transformation is propagated to the generic unit.
11502 procedure Save_References
(N
: Node_Id
) is
11507 elsif Nkind
(N
) = N_Character_Literal
11508 or else Nkind
(N
) = N_Operator_Symbol
11510 if Nkind
(N
) = Nkind
(Get_Associated_Node
(N
)) then
11513 elsif Nkind
(N
) = N_Operator_Symbol
11514 and then Nkind
(Get_Associated_Node
(N
)) = N_String_Literal
11516 Change_Operator_Symbol_To_String_Literal
(N
);
11519 elsif Nkind
(N
) in N_Op
then
11520 if Nkind
(N
) = Nkind
(Get_Associated_Node
(N
)) then
11521 if Nkind
(N
) = N_Op_Concat
then
11522 Set_Is_Component_Left_Opnd
(N
,
11523 Is_Component_Left_Opnd
(Get_Associated_Node
(N
)));
11525 Set_Is_Component_Right_Opnd
(N
,
11526 Is_Component_Right_Opnd
(Get_Associated_Node
(N
)));
11532 -- Node may be transformed into call to a user-defined operator
11534 N2
:= Get_Associated_Node
(N
);
11536 if Nkind
(N2
) = N_Function_Call
then
11537 E
:= Entity
(Name
(N2
));
11540 and then Is_Global
(E
)
11542 Set_Etype
(N
, Etype
(N2
));
11544 Set_Associated_Node
(N
, Empty
);
11545 Set_Etype
(N
, Empty
);
11548 elsif Nkind
(N2
) = N_Integer_Literal
11549 or else Nkind
(N2
) = N_Real_Literal
11550 or else Nkind
(N2
) = N_String_Literal
11552 if Present
(Original_Node
(N2
))
11553 and then Nkind
(Original_Node
(N2
)) = Nkind
(N
)
11556 -- Operation was constant-folded. Whenever possible,
11557 -- recover semantic information from unfolded node,
11560 Set_Associated_Node
(N
, Original_Node
(N2
));
11562 if Nkind
(N
) = N_Op_Concat
then
11563 Set_Is_Component_Left_Opnd
(N
,
11564 Is_Component_Left_Opnd
(Get_Associated_Node
(N
)));
11565 Set_Is_Component_Right_Opnd
(N
,
11566 Is_Component_Right_Opnd
(Get_Associated_Node
(N
)));
11572 -- If original node is already modified, propagate
11573 -- constant-folding to template.
11575 Rewrite
(N
, New_Copy
(N2
));
11576 Set_Analyzed
(N
, False);
11579 elsif Nkind
(N2
) = N_Identifier
11580 and then Ekind
(Entity
(N2
)) = E_Enumeration_Literal
11582 -- Same if call was folded into a literal, but in this case
11583 -- retain the entity to avoid spurious ambiguities if id is
11584 -- overloaded at the point of instantiation or inlining.
11586 Rewrite
(N
, New_Copy
(N2
));
11587 Set_Analyzed
(N
, False);
11591 -- Complete the check on operands, if node has not been
11592 -- constant-folded.
11594 if Nkind
(N
) in N_Op
then
11595 Save_Entity_Descendants
(N
);
11598 elsif Nkind
(N
) = N_Identifier
then
11599 if Nkind
(N
) = Nkind
(Get_Associated_Node
(N
)) then
11601 -- If this is a discriminant reference, always save it. It is
11602 -- used in the instance to find the corresponding discriminant
11603 -- positionally rather than by name.
11605 Set_Original_Discriminant
11606 (N
, Original_Discriminant
(Get_Associated_Node
(N
)));
11610 N2
:= Get_Associated_Node
(N
);
11612 if Nkind
(N2
) = N_Function_Call
then
11613 E
:= Entity
(Name
(N2
));
11615 -- Name resolves to a call to parameterless function. If
11616 -- original entity is global, mark node as resolved.
11619 and then Is_Global
(E
)
11621 Set_Etype
(N
, Etype
(N2
));
11623 Set_Associated_Node
(N
, Empty
);
11624 Set_Etype
(N
, Empty
);
11628 (Nkind
(N2
) = N_Integer_Literal
11630 Nkind
(N2
) = N_Real_Literal
)
11631 and then Is_Entity_Name
(Original_Node
(N2
))
11633 -- Name resolves to named number that is constant-folded,
11634 -- We must preserve the original name for ASIS use, and
11635 -- undo the constant-folding, which will be repeated in
11638 Set_Associated_Node
(N
, Original_Node
(N2
));
11641 elsif Nkind
(N2
) = N_String_Literal
then
11643 -- Name resolves to string literal. Perform the same
11644 -- replacement in generic.
11646 Rewrite
(N
, New_Copy
(N2
));
11648 elsif Nkind
(N2
) = N_Explicit_Dereference
then
11650 -- An identifier is rewritten as a dereference if it is
11651 -- the prefix in a selected component, and it denotes an
11652 -- access to a composite type, or a parameterless function
11653 -- call that returns an access type.
11655 -- Check whether corresponding entity in prefix is global
11657 if Is_Entity_Name
(Prefix
(N2
))
11658 and then Present
(Entity
(Prefix
(N2
)))
11659 and then Is_Global
(Entity
(Prefix
(N2
)))
11662 Make_Explicit_Dereference
(Sloc
(N
),
11663 Prefix
=> Make_Identifier
(Sloc
(N
),
11664 Chars
=> Chars
(N
))));
11665 Set_Associated_Node
(Prefix
(N
), Prefix
(N2
));
11667 elsif Nkind
(Prefix
(N2
)) = N_Function_Call
11668 and then Is_Global
(Entity
(Name
(Prefix
(N2
))))
11671 Make_Explicit_Dereference
(Sloc
(N
),
11672 Prefix
=> Make_Function_Call
(Sloc
(N
),
11674 Make_Identifier
(Sloc
(N
),
11675 Chars
=> Chars
(N
)))));
11677 Set_Associated_Node
11678 (Name
(Prefix
(N
)), Name
(Prefix
(N2
)));
11681 Set_Associated_Node
(N
, Empty
);
11682 Set_Etype
(N
, Empty
);
11685 -- The subtype mark of a nominally unconstrained object is
11686 -- rewritten as a subtype indication using the bounds of the
11687 -- expression. Recover the original subtype mark.
11689 elsif Nkind
(N2
) = N_Subtype_Indication
11690 and then Is_Entity_Name
(Original_Node
(N2
))
11692 Set_Associated_Node
(N
, Original_Node
(N2
));
11700 elsif Nkind
(N
) in N_Entity
then
11705 Loc
: constant Source_Ptr
:= Sloc
(N
);
11706 Qual
: Node_Id
:= Empty
;
11707 Typ
: Entity_Id
:= Empty
;
11710 use Atree
.Unchecked_Access
;
11711 -- This code section is part of implementing an untyped tree
11712 -- traversal, so it needs direct access to node fields.
11715 if Nkind
(N
) = N_Aggregate
11717 Nkind
(N
) = N_Extension_Aggregate
11719 N2
:= Get_Associated_Node
(N
);
11726 -- In an instance within a generic, use the name of
11727 -- the actual and not the original generic parameter.
11728 -- If the actual is global in the current generic it
11729 -- must be preserved for its instantiation.
11731 if Nkind
(Parent
(Typ
)) = N_Subtype_Declaration
11733 Present
(Generic_Parent_Type
(Parent
(Typ
)))
11735 Typ
:= Base_Type
(Typ
);
11736 Set_Etype
(N2
, Typ
);
11742 or else not Is_Global
(Typ
)
11744 Set_Associated_Node
(N
, Empty
);
11746 -- If the aggregate is an actual in a call, it has been
11747 -- resolved in the current context, to some local type.
11748 -- The enclosing call may have been disambiguated by the
11749 -- aggregate, and this disambiguation might fail at
11750 -- instantiation time because the type to which the
11751 -- aggregate did resolve is not preserved. In order to
11752 -- preserve some of this information, we wrap the
11753 -- aggregate in a qualified expression, using the id of
11754 -- its type. For further disambiguation we qualify the
11755 -- type name with its scope (if visible) because both
11756 -- id's will have corresponding entities in an instance.
11757 -- This resolves most of the problems with missing type
11758 -- information on aggregates in instances.
11760 if Nkind
(N2
) = Nkind
(N
)
11762 (Nkind
(Parent
(N2
)) = N_Procedure_Call_Statement
11763 or else Nkind
(Parent
(N2
)) = N_Function_Call
)
11764 and then Comes_From_Source
(Typ
)
11766 if Is_Immediately_Visible
(Scope
(Typ
)) then
11767 Nam
:= Make_Selected_Component
(Loc
,
11769 Make_Identifier
(Loc
, Chars
(Scope
(Typ
))),
11771 Make_Identifier
(Loc
, Chars
(Typ
)));
11773 Nam
:= Make_Identifier
(Loc
, Chars
(Typ
));
11777 Make_Qualified_Expression
(Loc
,
11778 Subtype_Mark
=> Nam
,
11779 Expression
=> Relocate_Node
(N
));
11783 Save_Global_Descendant
(Field1
(N
));
11784 Save_Global_Descendant
(Field2
(N
));
11785 Save_Global_Descendant
(Field3
(N
));
11786 Save_Global_Descendant
(Field5
(N
));
11788 if Present
(Qual
) then
11792 -- All other cases than aggregates
11795 Save_Global_Descendant
(Field1
(N
));
11796 Save_Global_Descendant
(Field2
(N
));
11797 Save_Global_Descendant
(Field3
(N
));
11798 Save_Global_Descendant
(Field4
(N
));
11799 Save_Global_Descendant
(Field5
(N
));
11803 end Save_References
;
11805 -- Start of processing for Save_Global_References
11808 Gen_Scope
:= Current_Scope
;
11810 -- If the generic unit is a child unit, references to entities in the
11811 -- parent are treated as local, because they will be resolved anew in
11812 -- the context of the instance of the parent.
11814 while Is_Child_Unit
(Gen_Scope
)
11815 and then Ekind
(Scope
(Gen_Scope
)) = E_Generic_Package
11817 Gen_Scope
:= Scope
(Gen_Scope
);
11820 Save_References
(N
);
11821 end Save_Global_References
;
11823 --------------------------------------
11824 -- Set_Copied_Sloc_For_Inlined_Body --
11825 --------------------------------------
11827 procedure Set_Copied_Sloc_For_Inlined_Body
(N
: Node_Id
; E
: Entity_Id
) is
11829 Create_Instantiation_Source
(N
, E
, True, S_Adjustment
);
11830 end Set_Copied_Sloc_For_Inlined_Body
;
11832 ---------------------
11833 -- Set_Instance_Of --
11834 ---------------------
11836 procedure Set_Instance_Of
(A
: Entity_Id
; B
: Entity_Id
) is
11838 Generic_Renamings
.Table
(Generic_Renamings
.Last
) := (A
, B
, Assoc_Null
);
11839 Generic_Renamings_HTable
.Set
(Generic_Renamings
.Last
);
11840 Generic_Renamings
.Increment_Last
;
11841 end Set_Instance_Of
;
11843 --------------------
11844 -- Set_Next_Assoc --
11845 --------------------
11847 procedure Set_Next_Assoc
(E
: Assoc_Ptr
; Next
: Assoc_Ptr
) is
11849 Generic_Renamings
.Table
(E
).Next_In_HTable
:= Next
;
11850 end Set_Next_Assoc
;
11852 -------------------
11853 -- Start_Generic --
11854 -------------------
11856 procedure Start_Generic
is
11858 -- ??? More things could be factored out in this routine.
11859 -- Should probably be done at a later stage.
11861 Generic_Flags
.Append
(Inside_A_Generic
);
11862 Inside_A_Generic
:= True;
11864 Expander_Mode_Save_And_Set
(False);
11867 ----------------------
11868 -- Set_Instance_Env --
11869 ----------------------
11871 procedure Set_Instance_Env
11872 (Gen_Unit
: Entity_Id
;
11873 Act_Unit
: Entity_Id
)
11876 -- Regardless of the current mode, predefined units are analyzed in
11877 -- the most current Ada mode, and earlier version Ada checks do not
11878 -- apply to predefined units. Nothing needs to be done for non-internal
11879 -- units. These are always analyzed in the current mode.
11881 if Is_Internal_File_Name
11882 (Fname
=> Unit_File_Name
(Get_Source_Unit
(Gen_Unit
)),
11883 Renamings_Included
=> True)
11885 Set_Opt_Config_Switches
(True, Current_Sem_Unit
= Main_Unit
);
11888 Current_Instantiated_Parent
:= (Gen_Unit
, Act_Unit
, Assoc_Null
);
11889 end Set_Instance_Env
;
11895 procedure Switch_View
(T
: Entity_Id
) is
11896 BT
: constant Entity_Id
:= Base_Type
(T
);
11897 Priv_Elmt
: Elmt_Id
:= No_Elmt
;
11898 Priv_Sub
: Entity_Id
;
11901 -- T may be private but its base type may have been exchanged through
11902 -- some other occurrence, in which case there is nothing to switch
11903 -- besides T itself. Note that a private dependent subtype of a private
11904 -- type might not have been switched even if the base type has been,
11905 -- because of the last branch of Check_Private_View (see comment there).
11907 if not Is_Private_Type
(BT
) then
11908 Prepend_Elmt
(Full_View
(T
), Exchanged_Views
);
11909 Exchange_Declarations
(T
);
11913 Priv_Elmt
:= First_Elmt
(Private_Dependents
(BT
));
11915 if Present
(Full_View
(BT
)) then
11916 Prepend_Elmt
(Full_View
(BT
), Exchanged_Views
);
11917 Exchange_Declarations
(BT
);
11920 while Present
(Priv_Elmt
) loop
11921 Priv_Sub
:= (Node
(Priv_Elmt
));
11923 -- We avoid flipping the subtype if the Etype of its full view is
11924 -- private because this would result in a malformed subtype. This
11925 -- occurs when the Etype of the subtype full view is the full view of
11926 -- the base type (and since the base types were just switched, the
11927 -- subtype is pointing to the wrong view). This is currently the case
11928 -- for tagged record types, access types (maybe more?) and needs to
11929 -- be resolved. ???
11931 if Present
(Full_View
(Priv_Sub
))
11932 and then not Is_Private_Type
(Etype
(Full_View
(Priv_Sub
)))
11934 Prepend_Elmt
(Full_View
(Priv_Sub
), Exchanged_Views
);
11935 Exchange_Declarations
(Priv_Sub
);
11938 Next_Elmt
(Priv_Elmt
);
11942 -----------------------------
11943 -- Valid_Default_Attribute --
11944 -----------------------------
11946 procedure Valid_Default_Attribute
(Nam
: Entity_Id
; Def
: Node_Id
) is
11947 Attr_Id
: constant Attribute_Id
:=
11948 Get_Attribute_Id
(Attribute_Name
(Def
));
11949 T
: constant Entity_Id
:= Entity
(Prefix
(Def
));
11950 Is_Fun
: constant Boolean := (Ekind
(Nam
) = E_Function
);
11963 F
:= First_Formal
(Nam
);
11964 while Present
(F
) loop
11965 Num_F
:= Num_F
+ 1;
11970 when Attribute_Adjacent | Attribute_Ceiling | Attribute_Copy_Sign |
11971 Attribute_Floor | Attribute_Fraction | Attribute_Machine |
11972 Attribute_Model | Attribute_Remainder | Attribute_Rounding |
11973 Attribute_Unbiased_Rounding
=>
11976 and then Is_Floating_Point_Type
(T
);
11978 when Attribute_Image | Attribute_Pred | Attribute_Succ |
11979 Attribute_Value | Attribute_Wide_Image |
11980 Attribute_Wide_Value
=>
11981 OK
:= (Is_Fun
and then Num_F
= 1 and then Is_Scalar_Type
(T
));
11983 when Attribute_Max | Attribute_Min
=>
11984 OK
:= (Is_Fun
and then Num_F
= 2 and then Is_Scalar_Type
(T
));
11986 when Attribute_Input
=>
11987 OK
:= (Is_Fun
and then Num_F
= 1);
11989 when Attribute_Output | Attribute_Read | Attribute_Write
=>
11990 OK
:= (not Is_Fun
and then Num_F
= 2);
11997 Error_Msg_N
("attribute reference has wrong profile for subprogram",
12000 end Valid_Default_Attribute
;