1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2009, 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
;
35 with Itypes
; use Itypes
;
37 with Lib
.Load
; use Lib
.Load
;
38 with Lib
.Xref
; use Lib
.Xref
;
39 with Nlists
; use Nlists
;
40 with Namet
; use Namet
;
41 with Nmake
; use Nmake
;
43 with Rident
; use Rident
;
44 with Restrict
; use Restrict
;
45 with Rtsfind
; use Rtsfind
;
47 with Sem_Aux
; use Sem_Aux
;
48 with Sem_Cat
; use Sem_Cat
;
49 with Sem_Ch3
; use Sem_Ch3
;
50 with Sem_Ch6
; use Sem_Ch6
;
51 with Sem_Ch7
; use Sem_Ch7
;
52 with Sem_Ch8
; use Sem_Ch8
;
53 with Sem_Ch10
; use Sem_Ch10
;
54 with Sem_Ch13
; use Sem_Ch13
;
55 with Sem_Disp
; use Sem_Disp
;
56 with Sem_Elab
; use Sem_Elab
;
57 with Sem_Elim
; use Sem_Elim
;
58 with Sem_Eval
; use Sem_Eval
;
59 with Sem_Res
; use Sem_Res
;
60 with Sem_Type
; use Sem_Type
;
61 with Sem_Util
; use Sem_Util
;
62 with Sem_Warn
; use Sem_Warn
;
63 with Stand
; use Stand
;
64 with Sinfo
; use Sinfo
;
65 with Sinfo
.CN
; use Sinfo
.CN
;
66 with Sinput
; use Sinput
;
67 with Sinput
.L
; use Sinput
.L
;
68 with Snames
; use Snames
;
69 with Stringt
; use Stringt
;
70 with Uname
; use Uname
;
72 with Tbuild
; use Tbuild
;
73 with Uintp
; use Uintp
;
74 with Urealp
; use Urealp
;
78 package body Sem_Ch12
is
80 ----------------------------------------------------------
81 -- Implementation of Generic Analysis and Instantiation --
82 ----------------------------------------------------------
84 -- GNAT implements generics by macro expansion. No attempt is made to share
85 -- generic instantiations (for now). Analysis of a generic definition does
86 -- not perform any expansion action, but the expander must be called on the
87 -- tree for each instantiation, because the expansion may of course depend
88 -- on the generic actuals. All of this is best achieved as follows:
90 -- a) Semantic analysis of a generic unit is performed on a copy of the
91 -- tree for the generic unit. All tree modifications that follow analysis
92 -- do not affect the original tree. Links are kept between the original
93 -- tree and the copy, in order to recognize non-local references within
94 -- the generic, and propagate them to each instance (recall that name
95 -- resolution is done on the generic declaration: generics are not really
96 -- macros!). This is summarized in the following diagram:
98 -- .-----------. .----------.
99 -- | semantic |<--------------| generic |
101 -- | |==============>| |
102 -- |___________| global |__________|
113 -- b) Each instantiation copies the original tree, and inserts into it a
114 -- series of declarations that describe the mapping between generic formals
115 -- and actuals. For example, a generic In OUT parameter is an object
116 -- renaming of the corresponding actual, etc. Generic IN parameters are
117 -- constant declarations.
119 -- c) In order to give the right visibility for these renamings, we use
120 -- a different scheme for package and subprogram instantiations. For
121 -- packages, the list of renamings is inserted into the package
122 -- specification, before the visible declarations of the package. The
123 -- renamings are analyzed before any of the text of the instance, and are
124 -- thus visible at the right place. Furthermore, outside of the instance,
125 -- the generic parameters are visible and denote their corresponding
128 -- For subprograms, we create a container package to hold the renamings
129 -- and the subprogram instance itself. Analysis of the package makes the
130 -- renaming declarations visible to the subprogram. After analyzing the
131 -- package, the defining entity for the subprogram is touched-up so that
132 -- it appears declared in the current scope, and not inside the container
135 -- If the instantiation is a compilation unit, the container package is
136 -- given the same name as the subprogram instance. This ensures that
137 -- the elaboration procedure called by the binder, using the compilation
138 -- unit name, calls in fact the elaboration procedure for the package.
140 -- Not surprisingly, private types complicate this approach. By saving in
141 -- the original generic object the non-local references, we guarantee that
142 -- the proper entities are referenced at the point of instantiation.
143 -- However, for private types, this by itself does not insure that the
144 -- proper VIEW of the entity is used (the full type may be visible at the
145 -- point of generic definition, but not at instantiation, or vice-versa).
146 -- In order to reference the proper view, we special-case any reference
147 -- to private types in the generic object, by saving both views, one in
148 -- the generic and one in the semantic copy. At time of instantiation, we
149 -- check whether the two views are consistent, and exchange declarations if
150 -- necessary, in order to restore the correct visibility. Similarly, if
151 -- the instance view is private when the generic view was not, we perform
152 -- the exchange. After completing the instantiation, we restore the
153 -- current visibility. The flag Has_Private_View marks identifiers in the
154 -- the generic unit that require checking.
156 -- Visibility within nested generic units requires special handling.
157 -- Consider the following scheme:
159 -- type Global is ... -- outside of generic unit.
163 -- type Semi_Global is ... -- global to inner.
166 -- procedure inner (X1 : Global; X2 : Semi_Global);
168 -- procedure in2 is new inner (...); -- 4
171 -- package New_Outer is new Outer (...); -- 2
172 -- procedure New_Inner is new New_Outer.Inner (...); -- 3
174 -- The semantic analysis of Outer captures all occurrences of Global.
175 -- The semantic analysis of Inner (at 1) captures both occurrences of
176 -- Global and Semi_Global.
178 -- At point 2 (instantiation of Outer), we also produce a generic copy
179 -- of Inner, even though Inner is, at that point, not being instantiated.
180 -- (This is just part of the semantic analysis of New_Outer).
182 -- Critically, references to Global within Inner must be preserved, while
183 -- references to Semi_Global should not preserved, because they must now
184 -- resolve to an entity within New_Outer. To distinguish between these, we
185 -- use a global variable, Current_Instantiated_Parent, which is set when
186 -- performing a generic copy during instantiation (at 2). This variable is
187 -- used when performing a generic copy that is not an instantiation, but
188 -- that is nested within one, as the occurrence of 1 within 2. The analysis
189 -- of a nested generic only preserves references that are global to the
190 -- enclosing Current_Instantiated_Parent. We use the Scope_Depth value to
191 -- determine whether a reference is external to the given parent.
193 -- The instantiation at point 3 requires no special treatment. The method
194 -- works as well for further nestings of generic units, but of course the
195 -- variable Current_Instantiated_Parent must be stacked because nested
196 -- instantiations can occur, e.g. the occurrence of 4 within 2.
198 -- The instantiation of package and subprogram bodies is handled in a
199 -- similar manner, except that it is delayed until after semantic
200 -- analysis is complete. In this fashion complex cross-dependencies
201 -- between several package declarations and bodies containing generics
202 -- can be compiled which otherwise would diagnose spurious circularities.
204 -- For example, it is possible to compile two packages A and B that
205 -- have the following structure:
207 -- package A is package B is
208 -- generic ... generic ...
209 -- package G_A is package G_B is
212 -- package body A is package body B is
213 -- package N_B is new G_B (..) package N_A is new G_A (..)
215 -- The table Pending_Instantiations in package Inline is used to keep
216 -- track of body instantiations that are delayed in this manner. Inline
217 -- handles the actual calls to do the body instantiations. This activity
218 -- is part of Inline, since the processing occurs at the same point, and
219 -- for essentially the same reason, as the handling of inlined routines.
221 ----------------------------------------------
222 -- Detection of Instantiation Circularities --
223 ----------------------------------------------
225 -- If we have a chain of instantiations that is circular, this is static
226 -- error which must be detected at compile time. The detection of these
227 -- circularities is carried out at the point that we insert a generic
228 -- instance spec or body. If there is a circularity, then the analysis of
229 -- the offending spec or body will eventually result in trying to load the
230 -- same unit again, and we detect this problem as we analyze the package
231 -- instantiation for the second time.
233 -- At least in some cases after we have detected the circularity, we get
234 -- into trouble if we try to keep going. The following flag is set if a
235 -- circularity is detected, and used to abandon compilation after the
236 -- messages have been posted.
238 Circularity_Detected
: Boolean := False;
239 -- This should really be reset on encountering a new main unit, but in
240 -- practice we are not using multiple main units so it is not critical.
242 -------------------------------------------------
243 -- Formal packages and partial parametrization --
244 -------------------------------------------------
246 -- When compiling a generic, a formal package is a local instantiation. If
247 -- declared with a box, its generic formals are visible in the enclosing
248 -- generic. If declared with a partial list of actuals, those actuals that
249 -- are defaulted (covered by an Others clause, or given an explicit box
250 -- initialization) are also visible in the enclosing generic, while those
251 -- that have a corresponding actual are not.
253 -- In our source model of instantiation, the same visibility must be
254 -- present in the spec and body of an instance: the names of the formals
255 -- that are defaulted must be made visible within the instance, and made
256 -- invisible (hidden) after the instantiation is complete, so that they
257 -- are not accessible outside of the instance.
259 -- In a generic, a formal package is treated like a special instantiation.
260 -- Our Ada95 compiler handled formals with and without box in different
261 -- ways. With partial parametrization, we use a single model for both.
262 -- We create a package declaration that consists of the specification of
263 -- the generic package, and a set of declarations that map the actuals
264 -- into local renamings, just as we do for bona fide instantiations. For
265 -- defaulted parameters and formals with a box, we copy directly the
266 -- declarations of the formal into this local package. The result is a
267 -- a package whose visible declarations may include generic formals. This
268 -- package is only used for type checking and visibility analysis, and
269 -- never reaches the back-end, so it can freely violate the placement
270 -- rules for generic formal declarations.
272 -- The list of declarations (renamings and copies of formals) is built
273 -- by Analyze_Associations, just as for regular instantiations.
275 -- At the point of instantiation, conformance checking must be applied only
276 -- to those parameters that were specified in the formal. We perform this
277 -- checking by creating another internal instantiation, this one including
278 -- only the renamings and the formals (the rest of the package spec is not
279 -- relevant to conformance checking). We can then traverse two lists: the
280 -- list of actuals in the instance that corresponds to the formal package,
281 -- and the list of actuals produced for this bogus instantiation. We apply
282 -- the conformance rules to those actuals that are not defaulted (i.e.
283 -- which still appear as generic formals.
285 -- When we compile an instance body we must make the right parameters
286 -- visible again. The predicate Is_Generic_Formal indicates which of the
287 -- formals should have its Is_Hidden flag reset.
289 -----------------------
290 -- Local subprograms --
291 -----------------------
293 procedure Abandon_Instantiation
(N
: Node_Id
);
294 pragma No_Return
(Abandon_Instantiation
);
295 -- Posts an error message "instantiation abandoned" at the indicated node
296 -- and then raises the exception Instantiation_Error to do it.
298 procedure Analyze_Formal_Array_Type
299 (T
: in out Entity_Id
;
301 -- A formal array type is treated like an array type declaration, and
302 -- invokes Array_Type_Declaration (sem_ch3) whose first parameter is
303 -- in-out, because in the case of an anonymous type the entity is
304 -- actually created in the procedure.
306 -- The following procedures treat other kinds of formal parameters
308 procedure Analyze_Formal_Derived_Interface_Type
313 procedure Analyze_Formal_Derived_Type
318 procedure Analyze_Formal_Interface_Type
323 -- The following subprograms create abbreviated declarations for formal
324 -- scalar types. We introduce an anonymous base of the proper class for
325 -- each of them, and define the formals as constrained first subtypes of
326 -- their bases. The bounds are expressions that are non-static in the
329 procedure Analyze_Formal_Decimal_Fixed_Point_Type
330 (T
: Entity_Id
; Def
: Node_Id
);
331 procedure Analyze_Formal_Discrete_Type
(T
: Entity_Id
; Def
: Node_Id
);
332 procedure Analyze_Formal_Floating_Type
(T
: Entity_Id
; Def
: Node_Id
);
333 procedure Analyze_Formal_Signed_Integer_Type
(T
: Entity_Id
; Def
: Node_Id
);
334 procedure Analyze_Formal_Modular_Type
(T
: Entity_Id
; Def
: Node_Id
);
335 procedure Analyze_Formal_Ordinary_Fixed_Point_Type
336 (T
: Entity_Id
; Def
: Node_Id
);
338 procedure Analyze_Formal_Private_Type
342 -- Creates a new private type, which does not require completion
344 procedure Analyze_Generic_Formal_Part
(N
: Node_Id
);
346 procedure Analyze_Generic_Access_Type
(T
: Entity_Id
; Def
: Node_Id
);
347 -- Create a new access type with the given designated type
349 function Analyze_Associations
352 F_Copy
: List_Id
) return List_Id
;
353 -- At instantiation time, build the list of associations between formals
354 -- and actuals. Each association becomes a renaming declaration for the
355 -- formal entity. F_Copy is the analyzed list of formals in the generic
356 -- copy. It is used to apply legality checks to the actuals. I_Node is the
357 -- instantiation node itself.
359 procedure Analyze_Subprogram_Instantiation
363 procedure Build_Instance_Compilation_Unit_Nodes
367 -- This procedure is used in the case where the generic instance of a
368 -- subprogram body or package body is a library unit. In this case, the
369 -- original library unit node for the generic instantiation must be
370 -- replaced by the resulting generic body, and a link made to a new
371 -- compilation unit node for the generic declaration. The argument N is
372 -- the original generic instantiation. Act_Body and Act_Decl are the body
373 -- and declaration of the instance (either package body and declaration
374 -- nodes or subprogram body and declaration nodes depending on the case).
375 -- On return, the node N has been rewritten with the actual body.
377 procedure Check_Access_Definition
(N
: Node_Id
);
378 -- Subsidiary routine to null exclusion processing. Perform an assertion
379 -- check on Ada version and the presence of an access definition in N.
381 procedure Check_Formal_Packages
(P_Id
: Entity_Id
);
382 -- Apply the following to all formal packages in generic associations
384 procedure Check_Formal_Package_Instance
385 (Formal_Pack
: Entity_Id
;
386 Actual_Pack
: Entity_Id
);
387 -- Verify that the actuals of the actual instance match the actuals of
388 -- the template for a formal package that is not declared with a box.
390 procedure Check_Forward_Instantiation
(Decl
: Node_Id
);
391 -- If the generic is a local entity and the corresponding body has not
392 -- been seen yet, flag enclosing packages to indicate that it will be
393 -- elaborated after the generic body. Subprograms declared in the same
394 -- package cannot be inlined by the front-end because front-end inlining
395 -- requires a strict linear order of elaboration.
397 procedure Check_Hidden_Child_Unit
399 Gen_Unit
: Entity_Id
;
400 Act_Decl_Id
: Entity_Id
);
401 -- If the generic unit is an implicit child instance within a parent
402 -- instance, we need to make an explicit test that it is not hidden by
403 -- a child instance of the same name and parent.
405 procedure Check_Generic_Actuals
406 (Instance
: Entity_Id
;
407 Is_Formal_Box
: Boolean);
408 -- Similar to previous one. Check the actuals in the instantiation,
409 -- whose views can change between the point of instantiation and the point
410 -- of instantiation of the body. In addition, mark the generic renamings
411 -- as generic actuals, so that they are not compatible with other actuals.
412 -- Recurse on an actual that is a formal package whose declaration has
415 function Contains_Instance_Of
418 N
: Node_Id
) return Boolean;
419 -- Inner is instantiated within the generic Outer. Check whether Inner
420 -- directly or indirectly contains an instance of Outer or of one of its
421 -- parents, in the case of a subunit. Each generic unit holds a list of
422 -- the entities instantiated within (at any depth). This procedure
423 -- determines whether the set of such lists contains a cycle, i.e. an
424 -- illegal circular instantiation.
426 function Denotes_Formal_Package
428 On_Exit
: Boolean := False;
429 Instance
: Entity_Id
:= Empty
) return Boolean;
430 -- Returns True if E is a formal package of an enclosing generic, or
431 -- the actual for such a formal in an enclosing instantiation. If such
432 -- a package is used as a formal in an nested generic, or as an actual
433 -- in a nested instantiation, the visibility of ITS formals should not
434 -- be modified. When called from within Restore_Private_Views, the flag
435 -- On_Exit is true, to indicate that the search for a possible enclosing
436 -- instance should ignore the current one. In that case Instance denotes
437 -- the declaration for which this is an actual. This declaration may be
438 -- an instantiation in the source, or the internal instantiation that
439 -- corresponds to the actual for a formal package.
441 function Find_Actual_Type
443 Gen_Type
: Entity_Id
) return Entity_Id
;
444 -- When validating the actual types of a child instance, check whether
445 -- the formal is a formal type of the parent unit, and retrieve the current
446 -- actual for it. Typ is the entity in the analyzed formal type declaration
447 -- (component or index type of an array type, or designated type of an
448 -- access formal) and Gen_Type is the enclosing analyzed formal array
449 -- or access type. The desired actual may be a formal of a parent, or may
450 -- be declared in a formal package of a parent. In both cases it is a
451 -- generic actual type because it appears within a visible instance.
452 -- Finally, it may be declared in a parent unit without being a formal
453 -- of that unit, in which case it must be retrieved by visibility.
454 -- Ambiguities may still arise if two homonyms are declared in two formal
455 -- packages, and the prefix of the formal type may be needed to resolve
456 -- the ambiguity in the instance ???
458 function In_Same_Declarative_Part
460 Inst
: Node_Id
) return Boolean;
461 -- True if the instantiation Inst and the given freeze_node F_Node appear
462 -- within the same declarative part, ignoring subunits, but with no inter-
463 -- vening subprograms or concurrent units. If true, the freeze node
464 -- of the instance can be placed after the freeze node of the parent,
465 -- which it itself an instance.
467 function In_Main_Context
(E
: Entity_Id
) return Boolean;
468 -- Check whether an instantiation is in the context of the main unit.
469 -- Used to determine whether its body should be elaborated to allow
470 -- front-end inlining.
472 function Is_Generic_Formal
(E
: Entity_Id
) return Boolean;
473 -- Utility to determine whether a given entity is declared by means of
474 -- of a formal parameter declaration. Used to set properly the visibility
475 -- of generic formals of a generic package declared with a box or with
476 -- partial parametrization.
478 procedure Set_Instance_Env
479 (Gen_Unit
: Entity_Id
;
480 Act_Unit
: Entity_Id
);
481 -- Save current instance on saved environment, to be used to determine
482 -- the global status of entities in nested instances. Part of Save_Env.
483 -- called after verifying that the generic unit is legal for the instance,
484 -- The procedure also examines whether the generic unit is a predefined
485 -- unit, in order to set configuration switches accordingly. As a result
486 -- the procedure must be called after analyzing and freezing the actuals.
488 procedure Set_Instance_Of
(A
: Entity_Id
; B
: Entity_Id
);
489 -- Associate analyzed generic parameter with corresponding
490 -- instance. Used for semantic checks at instantiation time.
492 function Has_Been_Exchanged
(E
: Entity_Id
) return Boolean;
493 -- Traverse the Exchanged_Views list to see if a type was private
494 -- and has already been flipped during this phase of instantiation.
496 procedure Hide_Current_Scope
;
497 -- When instantiating a generic child unit, the parent context must be
498 -- present, but the instance and all entities that may be generated
499 -- must be inserted in the current scope. We leave the current scope
500 -- on the stack, but make its entities invisible to avoid visibility
501 -- problems. This is reversed at the end of the instantiation. This is
502 -- not done for the instantiation of the bodies, which only require the
503 -- instances of the generic parents to be in scope.
505 procedure Install_Body
510 -- If the instantiation happens textually before the body of the generic,
511 -- the instantiation of the body must be analyzed after the generic body,
512 -- and not at the point of instantiation. Such early instantiations can
513 -- happen if the generic and the instance appear in a package declaration
514 -- because the generic body can only appear in the corresponding package
515 -- body. Early instantiations can also appear if generic, instance and
516 -- body are all in the declarative part of a subprogram or entry. Entities
517 -- of packages that are early instantiations are delayed, and their freeze
518 -- node appears after the generic body.
520 procedure Insert_After_Last_Decl
(N
: Node_Id
; F_Node
: Node_Id
);
521 -- Insert freeze node at the end of the declarative part that includes the
522 -- instance node N. If N is in the visible part of an enclosing package
523 -- declaration, the freeze node has to be inserted at the end of the
524 -- private declarations, if any.
526 procedure Freeze_Subprogram_Body
527 (Inst_Node
: Node_Id
;
529 Pack_Id
: Entity_Id
);
530 -- The generic body may appear textually after the instance, including
531 -- in the proper body of a stub, or within a different package instance.
532 -- Given that the instance can only be elaborated after the generic, we
533 -- place freeze_nodes for the instance and/or for packages that may enclose
534 -- the instance and the generic, so that the back-end can establish the
535 -- proper order of elaboration.
538 -- Establish environment for subsequent instantiation. Separated from
539 -- Save_Env because data-structures for visibility handling must be
540 -- initialized before call to Check_Generic_Child_Unit.
542 procedure Install_Formal_Packages
(Par
: Entity_Id
);
543 -- If any of the formals of the parent are formal packages with box,
544 -- their formal parts are visible in the parent and thus in the child
545 -- unit as well. Analogous to what is done in Check_Generic_Actuals
546 -- for the unit itself. This procedure is also used in an instance, to
547 -- make visible the proper entities of the actual for a formal package
548 -- declared with a box.
550 procedure Install_Parent
(P
: Entity_Id
; In_Body
: Boolean := False);
551 -- When compiling an instance of a child unit the parent (which is
552 -- itself an instance) is an enclosing scope that must be made
553 -- immediately visible. This procedure is also used to install the non-
554 -- generic parent of a generic child unit when compiling its body, so
555 -- that full views of types in the parent are made visible.
557 procedure Remove_Parent
(In_Body
: Boolean := False);
558 -- Reverse effect after instantiation of child is complete
560 procedure Inline_Instance_Body
562 Gen_Unit
: Entity_Id
;
564 -- If front-end inlining is requested, instantiate the package body,
565 -- and preserve the visibility of its compilation unit, to insure
566 -- that successive instantiations succeed.
568 -- The functions Instantiate_XXX perform various legality checks and build
569 -- the declarations for instantiated generic parameters. In all of these
570 -- Formal is the entity in the generic unit, Actual is the entity of
571 -- expression in the generic associations, and Analyzed_Formal is the
572 -- formal in the generic copy, which contains the semantic information to
573 -- be used to validate the actual.
575 function Instantiate_Object
578 Analyzed_Formal
: Node_Id
) return List_Id
;
580 function Instantiate_Type
583 Analyzed_Formal
: Node_Id
;
584 Actual_Decls
: List_Id
) return List_Id
;
586 function Instantiate_Formal_Subprogram
589 Analyzed_Formal
: Node_Id
) return Node_Id
;
591 function Instantiate_Formal_Package
594 Analyzed_Formal
: Node_Id
) return List_Id
;
595 -- If the formal package is declared with a box, special visibility rules
596 -- apply to its formals: they are in the visible part of the package. This
597 -- is true in the declarative region of the formal package, that is to say
598 -- in the enclosing generic or instantiation. For an instantiation, the
599 -- parameters of the formal package are made visible in an explicit step.
600 -- Furthermore, if the actual has a visible USE clause, these formals must
601 -- be made potentially use-visible as well. On exit from the enclosing
602 -- instantiation, the reverse must be done.
604 -- For a formal package declared without a box, there are conformance rules
605 -- that apply to the actuals in the generic declaration and the actuals of
606 -- the actual package in the enclosing instantiation. The simplest way to
607 -- apply these rules is to repeat the instantiation of the formal package
608 -- in the context of the enclosing instance, and compare the generic
609 -- associations of this instantiation with those of the actual package.
610 -- This internal instantiation only needs to contain the renamings of the
611 -- formals: the visible and private declarations themselves need not be
614 -- In Ada 2005, the formal package may be only partially parametrized. In
615 -- that case the visibility step must make visible those actuals whose
616 -- corresponding formals were given with a box. A final complication
617 -- involves inherited operations from formal derived types, which must be
618 -- visible if the type is.
620 function Is_In_Main_Unit
(N
: Node_Id
) return Boolean;
621 -- Test if given node is in the main unit
623 procedure Load_Parent_Of_Generic
626 Body_Optional
: Boolean := False);
627 -- If the generic appears in a separate non-generic library unit, load the
628 -- corresponding body to retrieve the body of the generic. N is the node
629 -- for the generic instantiation, Spec is the generic package declaration.
631 -- Body_Optional is a flag that indicates that the body is being loaded to
632 -- ensure that temporaries are generated consistently when there are other
633 -- instances in the current declarative part that precede the one being
634 -- loaded. In that case a missing body is acceptable.
636 procedure Inherit_Context
(Gen_Decl
: Node_Id
; Inst
: Node_Id
);
637 -- Add the context clause of the unit containing a generic unit to a
638 -- compilation unit that is, or contains, an instantiation.
640 function Get_Associated_Node
(N
: Node_Id
) return Node_Id
;
641 -- In order to propagate semantic information back from the analyzed copy
642 -- to the original generic, we maintain links between selected nodes in the
643 -- generic and their corresponding copies. At the end of generic analysis,
644 -- the routine Save_Global_References traverses the generic tree, examines
645 -- the semantic information, and preserves the links to those nodes that
646 -- contain global information. At instantiation, the information from the
647 -- associated node is placed on the new copy, so that name resolution is
650 -- Three kinds of source nodes have associated nodes:
652 -- a) those that can reference (denote) entities, that is identifiers,
653 -- character literals, expanded_names, operator symbols, operators,
654 -- and attribute reference nodes. These nodes have an Entity field
655 -- and are the set of nodes that are in N_Has_Entity.
657 -- b) aggregates (N_Aggregate and N_Extension_Aggregate)
659 -- c) selected components (N_Selected_Component)
661 -- For the first class, the associated node preserves the entity if it is
662 -- global. If the generic contains nested instantiations, the associated
663 -- node itself has been recopied, and a chain of them must be followed.
665 -- For aggregates, the associated node allows retrieval of the type, which
666 -- may otherwise not appear in the generic. The view of this type may be
667 -- different between generic and instantiation, and the full view can be
668 -- installed before the instantiation is analyzed. For aggregates of type
669 -- extensions, the same view exchange may have to be performed for some of
670 -- the ancestor types, if their view is private at the point of
673 -- Nodes that are selected components in the parse tree may be rewritten
674 -- as expanded names after resolution, and must be treated as potential
675 -- entity holders, which is why they also have an Associated_Node.
677 -- Nodes that do not come from source, such as freeze nodes, do not appear
678 -- in the generic tree, and need not have an associated node.
680 -- The associated node is stored in the Associated_Node field. Note that
681 -- this field overlaps Entity, which is fine, because the whole point is
682 -- that we don't need or want the normal Entity field in this situation.
684 procedure Map_Formal_Package_Entities
(Form
: Entity_Id
; Act
: Entity_Id
);
685 -- Within the generic part, entities in the formal package are
686 -- visible. To validate subsequent type declarations, indicate
687 -- the correspondence between the entities in the analyzed formal,
688 -- and the entities in the actual package. There are three packages
689 -- involved in the instantiation of a formal package: the parent
690 -- generic P1 which appears in the generic declaration, the fake
691 -- instantiation P2 which appears in the analyzed generic, and whose
692 -- visible entities may be used in subsequent formals, and the actual
693 -- P3 in the instance. To validate subsequent formals, me indicate
694 -- that the entities in P2 are mapped into those of P3. The mapping of
695 -- entities has to be done recursively for nested packages.
697 procedure Move_Freeze_Nodes
701 -- Freeze nodes can be generated in the analysis of a generic unit, but
702 -- will not be seen by the back-end. It is necessary to move those nodes
703 -- to the enclosing scope if they freeze an outer entity. We place them
704 -- at the end of the enclosing generic package, which is semantically
707 procedure Preanalyze_Actuals
(N
: Node_Id
);
708 -- Analyze actuals to perform name resolution. Full resolution is done
709 -- later, when the expected types are known, but names have to be captured
710 -- before installing parents of generics, that are not visible for the
711 -- actuals themselves.
713 procedure Valid_Default_Attribute
(Nam
: Entity_Id
; Def
: Node_Id
);
714 -- Verify that an attribute that appears as the default for a formal
715 -- subprogram is a function or procedure with the correct profile.
717 -------------------------------------------
718 -- Data Structures for Generic Renamings --
719 -------------------------------------------
721 -- The map Generic_Renamings associates generic entities with their
722 -- corresponding actuals. Currently used to validate type instances. It
723 -- will eventually be used for all generic parameters to eliminate the
724 -- need for overload resolution in the instance.
726 type Assoc_Ptr
is new Int
;
728 Assoc_Null
: constant Assoc_Ptr
:= -1;
733 Next_In_HTable
: Assoc_Ptr
;
736 package Generic_Renamings
is new Table
.Table
737 (Table_Component_Type
=> Assoc
,
738 Table_Index_Type
=> Assoc_Ptr
,
739 Table_Low_Bound
=> 0,
741 Table_Increment
=> 100,
742 Table_Name
=> "Generic_Renamings");
744 -- Variable to hold enclosing instantiation. When the environment is
745 -- saved for a subprogram inlining, the corresponding Act_Id is empty.
747 Current_Instantiated_Parent
: Assoc
:= (Empty
, Empty
, Assoc_Null
);
749 -- Hash table for associations
751 HTable_Size
: constant := 37;
752 type HTable_Range
is range 0 .. HTable_Size
- 1;
754 procedure Set_Next_Assoc
(E
: Assoc_Ptr
; Next
: Assoc_Ptr
);
755 function Next_Assoc
(E
: Assoc_Ptr
) return Assoc_Ptr
;
756 function Get_Gen_Id
(E
: Assoc_Ptr
) return Entity_Id
;
757 function Hash
(F
: Entity_Id
) return HTable_Range
;
759 package Generic_Renamings_HTable
is new GNAT
.HTable
.Static_HTable
(
760 Header_Num
=> HTable_Range
,
762 Elmt_Ptr
=> Assoc_Ptr
,
763 Null_Ptr
=> Assoc_Null
,
764 Set_Next
=> Set_Next_Assoc
,
767 Get_Key
=> Get_Gen_Id
,
771 Exchanged_Views
: Elist_Id
;
772 -- This list holds the private views that have been exchanged during
773 -- instantiation to restore the visibility of the generic declaration.
774 -- (see comments above). After instantiation, the current visibility is
775 -- reestablished by means of a traversal of this list.
777 Hidden_Entities
: Elist_Id
;
778 -- This list holds the entities of the current scope that are removed
779 -- from immediate visibility when instantiating a child unit. Their
780 -- visibility is restored in Remove_Parent.
782 -- Because instantiations can be recursive, the following must be saved
783 -- on entry and restored on exit from an instantiation (spec or body).
784 -- This is done by the two procedures Save_Env and Restore_Env. For
785 -- package and subprogram instantiations (but not for the body instances)
786 -- the action of Save_Env is done in two steps: Init_Env is called before
787 -- Check_Generic_Child_Unit, because setting the parent instances requires
788 -- that the visibility data structures be properly initialized. Once the
789 -- generic is unit is validated, Set_Instance_Env completes Save_Env.
791 Parent_Unit_Visible
: Boolean := False;
792 -- Parent_Unit_Visible is used when the generic is a child unit, and
793 -- indicates whether the ultimate parent of the generic is visible in the
794 -- instantiation environment. It is used to reset the visibility of the
795 -- parent at the end of the instantiation (see Remove_Parent).
797 Instance_Parent_Unit
: Entity_Id
:= Empty
;
798 -- This records the ultimate parent unit of an instance of a generic
799 -- child unit and is used in conjunction with Parent_Unit_Visible to
800 -- indicate the unit to which the Parent_Unit_Visible flag corresponds.
802 type Instance_Env
is record
803 Instantiated_Parent
: Assoc
;
804 Exchanged_Views
: Elist_Id
;
805 Hidden_Entities
: Elist_Id
;
806 Current_Sem_Unit
: Unit_Number_Type
;
807 Parent_Unit_Visible
: Boolean := False;
808 Instance_Parent_Unit
: Entity_Id
:= Empty
;
809 Switches
: Config_Switches_Type
;
812 package Instance_Envs
is new Table
.Table
(
813 Table_Component_Type
=> Instance_Env
,
814 Table_Index_Type
=> Int
,
815 Table_Low_Bound
=> 0,
817 Table_Increment
=> 100,
818 Table_Name
=> "Instance_Envs");
820 procedure Restore_Private_Views
821 (Pack_Id
: Entity_Id
;
822 Is_Package
: Boolean := True);
823 -- Restore the private views of external types, and unmark the generic
824 -- renamings of actuals, so that they become compatible subtypes again.
825 -- For subprograms, Pack_Id is the package constructed to hold the
828 procedure Switch_View
(T
: Entity_Id
);
829 -- Switch the partial and full views of a type and its private
830 -- dependents (i.e. its subtypes and derived types).
832 ------------------------------------
833 -- Structures for Error Reporting --
834 ------------------------------------
836 Instantiation_Node
: Node_Id
;
837 -- Used by subprograms that validate instantiation of formal parameters
838 -- where there might be no actual on which to place the error message.
839 -- Also used to locate the instantiation node for generic subunits.
841 Instantiation_Error
: exception;
842 -- When there is a semantic error in the generic parameter matching,
843 -- there is no point in continuing the instantiation, because the
844 -- number of cascaded errors is unpredictable. This exception aborts
845 -- the instantiation process altogether.
847 S_Adjustment
: Sloc_Adjustment
;
848 -- Offset created for each node in an instantiation, in order to keep
849 -- track of the source position of the instantiation in each of its nodes.
850 -- A subsequent semantic error or warning on a construct of the instance
851 -- points to both places: the original generic node, and the point of
852 -- instantiation. See Sinput and Sinput.L for additional details.
854 ------------------------------------------------------------
855 -- Data structure for keeping track when inside a Generic --
856 ------------------------------------------------------------
858 -- The following table is used to save values of the Inside_A_Generic
859 -- flag (see spec of Sem) when they are saved by Start_Generic.
861 package Generic_Flags
is new Table
.Table
(
862 Table_Component_Type
=> Boolean,
863 Table_Index_Type
=> Int
,
864 Table_Low_Bound
=> 0,
866 Table_Increment
=> 200,
867 Table_Name
=> "Generic_Flags");
869 ---------------------------
870 -- Abandon_Instantiation --
871 ---------------------------
873 procedure Abandon_Instantiation
(N
: Node_Id
) is
875 Error_Msg_N
("\instantiation abandoned!", N
);
876 raise Instantiation_Error
;
877 end Abandon_Instantiation
;
879 --------------------------
880 -- Analyze_Associations --
881 --------------------------
883 function Analyze_Associations
886 F_Copy
: List_Id
) return List_Id
889 Actual_Types
: constant Elist_Id
:= New_Elmt_List
;
890 Assoc
: constant List_Id
:= New_List
;
891 Default_Actuals
: constant Elist_Id
:= New_Elmt_List
;
892 Gen_Unit
: constant Entity_Id
:=
893 Defining_Entity
(Parent
(F_Copy
));
898 Next_Formal
: Node_Id
;
899 Temp_Formal
: Node_Id
;
900 Analyzed_Formal
: Node_Id
;
903 First_Named
: Node_Id
:= Empty
;
905 Default_Formals
: constant List_Id
:= New_List
;
906 -- If an Others_Choice is present, some of the formals may be defaulted.
907 -- To simplify the treatment of visibility in an instance, we introduce
908 -- individual defaults for each such formal. These defaults are
909 -- appended to the list of associations and replace the Others_Choice.
911 Found_Assoc
: Node_Id
;
912 -- Association for the current formal being match. Empty if there are
913 -- no remaining actuals, or if there is no named association with the
914 -- name of the formal.
916 Is_Named_Assoc
: Boolean;
917 Num_Matched
: Int
:= 0;
918 Num_Actuals
: Int
:= 0;
920 Others_Present
: Boolean := False;
921 -- In Ada 2005, indicates partial parametrization of a formal
922 -- package. As usual an other association must be last in the list.
924 function Matching_Actual
926 A_F
: Entity_Id
) return Node_Id
;
927 -- Find actual that corresponds to a given a formal parameter. If the
928 -- actuals are positional, return the next one, if any. If the actuals
929 -- are named, scan the parameter associations to find the right one.
930 -- A_F is the corresponding entity in the analyzed generic,which is
931 -- placed on the selector name for ASIS use.
933 -- In Ada 2005, a named association may be given with a box, in which
934 -- case Matching_Actual sets Found_Assoc to the generic association,
935 -- but return Empty for the actual itself. In this case the code below
936 -- creates a corresponding declaration for the formal.
938 function Partial_Parametrization
return Boolean;
939 -- Ada 2005: if no match is found for a given formal, check if the
940 -- association for it includes a box, or whether the associations
941 -- include an Others clause.
943 procedure Process_Default
(F
: Entity_Id
);
944 -- Add a copy of the declaration of generic formal F to the list of
945 -- associations, and add an explicit box association for F if there
946 -- is none yet, and the default comes from an Others_Choice.
948 procedure Set_Analyzed_Formal
;
949 -- Find the node in the generic copy that corresponds to a given formal.
950 -- The semantic information on this node is used to perform legality
951 -- checks on the actuals. Because semantic analysis can introduce some
952 -- anonymous entities or modify the declaration node itself, the
953 -- correspondence between the two lists is not one-one. In addition to
954 -- anonymous types, the presence a formal equality will introduce an
955 -- implicit declaration for the corresponding inequality.
957 ---------------------
958 -- Matching_Actual --
959 ---------------------
961 function Matching_Actual
963 A_F
: Entity_Id
) return Node_Id
969 Is_Named_Assoc
:= False;
971 -- End of list of purely positional parameters
973 if No
(Actual
) or else Nkind
(Actual
) = N_Others_Choice
then
974 Found_Assoc
:= Empty
;
977 -- Case of positional parameter corresponding to current formal
979 elsif No
(Selector_Name
(Actual
)) then
980 Found_Assoc
:= Actual
;
981 Act
:= Explicit_Generic_Actual_Parameter
(Actual
);
982 Num_Matched
:= Num_Matched
+ 1;
985 -- Otherwise scan list of named actuals to find the one with the
986 -- desired name. All remaining actuals have explicit names.
989 Is_Named_Assoc
:= True;
990 Found_Assoc
:= Empty
;
994 while Present
(Actual
) loop
995 if Chars
(Selector_Name
(Actual
)) = Chars
(F
) then
996 Set_Entity
(Selector_Name
(Actual
), A_F
);
997 Set_Etype
(Selector_Name
(Actual
), Etype
(A_F
));
998 Generate_Reference
(A_F
, Selector_Name
(Actual
));
999 Found_Assoc
:= Actual
;
1000 Act
:= Explicit_Generic_Actual_Parameter
(Actual
);
1001 Num_Matched
:= Num_Matched
+ 1;
1009 -- Reset for subsequent searches. In most cases the named
1010 -- associations are in order. If they are not, we reorder them
1011 -- to avoid scanning twice the same actual. This is not just a
1012 -- question of efficiency: there may be multiple defaults with
1013 -- boxes that have the same name. In a nested instantiation we
1014 -- insert actuals for those defaults, and cannot rely on their
1015 -- names to disambiguate them.
1017 if Actual
= First_Named
then
1020 elsif Present
(Actual
) then
1021 Insert_Before
(First_Named
, Remove_Next
(Prev
));
1024 Actual
:= First_Named
;
1027 if Is_Entity_Name
(Act
) and then Present
(Entity
(Act
)) then
1028 Set_Used_As_Generic_Actual
(Entity
(Act
));
1032 end Matching_Actual
;
1034 -----------------------------
1035 -- Partial_Parametrization --
1036 -----------------------------
1038 function Partial_Parametrization
return Boolean is
1040 return Others_Present
1041 or else (Present
(Found_Assoc
) and then Box_Present
(Found_Assoc
));
1042 end Partial_Parametrization
;
1044 ---------------------
1045 -- Process_Default --
1046 ---------------------
1048 procedure Process_Default
(F
: Entity_Id
) is
1049 Loc
: constant Source_Ptr
:= Sloc
(I_Node
);
1050 F_Id
: constant Entity_Id
:= Defining_Entity
(F
);
1056 -- Append copy of formal declaration to associations, and create new
1057 -- defining identifier for it.
1059 Decl
:= New_Copy_Tree
(F
);
1060 Id
:= Make_Defining_Identifier
(Sloc
(F_Id
), Chars
=> Chars
(F_Id
));
1062 if Nkind
(F
) in N_Formal_Subprogram_Declaration
then
1063 Set_Defining_Unit_Name
(Specification
(Decl
), Id
);
1066 Set_Defining_Identifier
(Decl
, Id
);
1069 Append
(Decl
, Assoc
);
1071 if No
(Found_Assoc
) then
1073 Make_Generic_Association
(Loc
,
1074 Selector_Name
=> New_Occurrence_Of
(Id
, Loc
),
1075 Explicit_Generic_Actual_Parameter
=> Empty
);
1076 Set_Box_Present
(Default
);
1077 Append
(Default
, Default_Formals
);
1079 end Process_Default
;
1081 -------------------------
1082 -- Set_Analyzed_Formal --
1083 -------------------------
1085 procedure Set_Analyzed_Formal
is
1089 while Present
(Analyzed_Formal
) loop
1090 Kind
:= Nkind
(Analyzed_Formal
);
1092 case Nkind
(Formal
) is
1094 when N_Formal_Subprogram_Declaration
=>
1095 exit when Kind
in N_Formal_Subprogram_Declaration
1098 (Defining_Unit_Name
(Specification
(Formal
))) =
1100 (Defining_Unit_Name
(Specification
(Analyzed_Formal
)));
1102 when N_Formal_Package_Declaration
=>
1103 exit when Nkind_In
(Kind
, N_Formal_Package_Declaration
,
1104 N_Generic_Package_Declaration
,
1105 N_Package_Declaration
);
1107 when N_Use_Package_Clause | N_Use_Type_Clause
=> exit;
1111 -- Skip freeze nodes, and nodes inserted to replace
1112 -- unrecognized pragmas.
1115 Kind
not in N_Formal_Subprogram_Declaration
1116 and then not Nkind_In
(Kind
, N_Subprogram_Declaration
,
1120 and then Chars
(Defining_Identifier
(Formal
)) =
1121 Chars
(Defining_Identifier
(Analyzed_Formal
));
1124 Next
(Analyzed_Formal
);
1126 end Set_Analyzed_Formal
;
1128 -- Start of processing for Analyze_Associations
1131 Actuals
:= Generic_Associations
(I_Node
);
1133 if Present
(Actuals
) then
1135 -- Check for an Others choice, indicating a partial parametrization
1136 -- for a formal package.
1138 Actual
:= First
(Actuals
);
1139 while Present
(Actual
) loop
1140 if Nkind
(Actual
) = N_Others_Choice
then
1141 Others_Present
:= True;
1143 if Present
(Next
(Actual
)) then
1144 Error_Msg_N
("others must be last association", Actual
);
1147 -- This subprogram is used both for formal packages and for
1148 -- instantiations. For the latter, associations must all be
1151 if Nkind
(I_Node
) /= N_Formal_Package_Declaration
1152 and then Comes_From_Source
(I_Node
)
1155 ("others association not allowed in an instance",
1159 -- In any case, nothing to do after the others association
1163 elsif Box_Present
(Actual
)
1164 and then Comes_From_Source
(I_Node
)
1165 and then Nkind
(I_Node
) /= N_Formal_Package_Declaration
1168 ("box association not allowed in an instance", Actual
);
1174 -- If named associations are present, save first named association
1175 -- (it may of course be Empty) to facilitate subsequent name search.
1177 First_Named
:= First
(Actuals
);
1178 while Present
(First_Named
)
1179 and then Nkind
(First_Named
) /= N_Others_Choice
1180 and then No
(Selector_Name
(First_Named
))
1182 Num_Actuals
:= Num_Actuals
+ 1;
1187 Named
:= First_Named
;
1188 while Present
(Named
) loop
1189 if Nkind
(Named
) /= N_Others_Choice
1190 and then No
(Selector_Name
(Named
))
1192 Error_Msg_N
("invalid positional actual after named one", Named
);
1193 Abandon_Instantiation
(Named
);
1196 -- A named association may lack an actual parameter, if it was
1197 -- introduced for a default subprogram that turns out to be local
1198 -- to the outer instantiation.
1200 if Nkind
(Named
) /= N_Others_Choice
1201 and then Present
(Explicit_Generic_Actual_Parameter
(Named
))
1203 Num_Actuals
:= Num_Actuals
+ 1;
1209 if Present
(Formals
) then
1210 Formal
:= First_Non_Pragma
(Formals
);
1211 Analyzed_Formal
:= First_Non_Pragma
(F_Copy
);
1213 if Present
(Actuals
) then
1214 Actual
:= First
(Actuals
);
1216 -- All formals should have default values
1222 while Present
(Formal
) loop
1223 Set_Analyzed_Formal
;
1224 Next_Formal
:= Next_Non_Pragma
(Formal
);
1226 case Nkind
(Formal
) is
1227 when N_Formal_Object_Declaration
=>
1230 Defining_Identifier
(Formal
),
1231 Defining_Identifier
(Analyzed_Formal
));
1233 if No
(Match
) and then Partial_Parametrization
then
1234 Process_Default
(Formal
);
1237 (Instantiate_Object
(Formal
, Match
, Analyzed_Formal
),
1241 when N_Formal_Type_Declaration
=>
1244 Defining_Identifier
(Formal
),
1245 Defining_Identifier
(Analyzed_Formal
));
1248 if Partial_Parametrization
then
1249 Process_Default
(Formal
);
1252 Error_Msg_Sloc
:= Sloc
(Gen_Unit
);
1256 Defining_Identifier
(Formal
));
1257 Error_Msg_NE
("\in instantiation of & declared#",
1258 Instantiation_Node
, Gen_Unit
);
1259 Abandon_Instantiation
(Instantiation_Node
);
1266 (Formal
, Match
, Analyzed_Formal
, Assoc
),
1269 -- An instantiation is a freeze point for the actuals,
1270 -- unless this is a rewritten formal package.
1272 if Nkind
(I_Node
) /= N_Formal_Package_Declaration
then
1273 Append_Elmt
(Entity
(Match
), Actual_Types
);
1277 -- A remote access-to-class-wide type must not be an
1278 -- actual parameter for a generic formal of an access
1279 -- type (E.2.2 (17)).
1281 if Nkind
(Analyzed_Formal
) = N_Formal_Type_Declaration
1283 Nkind
(Formal_Type_Definition
(Analyzed_Formal
)) =
1284 N_Access_To_Object_Definition
1286 Validate_Remote_Access_To_Class_Wide_Type
(Match
);
1289 when N_Formal_Subprogram_Declaration
=>
1292 Defining_Unit_Name
(Specification
(Formal
)),
1293 Defining_Unit_Name
(Specification
(Analyzed_Formal
)));
1295 -- If the formal subprogram has the same name as another
1296 -- formal subprogram of the generic, then a named
1297 -- association is illegal (12.3(9)). Exclude named
1298 -- associations that are generated for a nested instance.
1301 and then Is_Named_Assoc
1302 and then Comes_From_Source
(Found_Assoc
)
1304 Temp_Formal
:= First
(Formals
);
1305 while Present
(Temp_Formal
) loop
1306 if Nkind
(Temp_Formal
) in
1307 N_Formal_Subprogram_Declaration
1308 and then Temp_Formal
/= Formal
1310 Chars
(Selector_Name
(Found_Assoc
)) =
1311 Chars
(Defining_Unit_Name
1312 (Specification
(Temp_Formal
)))
1315 ("name not allowed for overloaded formal",
1317 Abandon_Instantiation
(Instantiation_Node
);
1324 -- If there is no corresponding actual, this may be case of
1325 -- partial parametrization, or else the formal has a default
1329 and then Partial_Parametrization
1331 Process_Default
(Formal
);
1334 Instantiate_Formal_Subprogram
1335 (Formal
, Match
, Analyzed_Formal
));
1338 -- If this is a nested generic, preserve default for later
1342 and then Box_Present
(Formal
)
1345 (Defining_Unit_Name
(Specification
(Last
(Assoc
))),
1349 when N_Formal_Package_Declaration
=>
1352 Defining_Identifier
(Formal
),
1353 Defining_Identifier
(Original_Node
(Analyzed_Formal
)));
1356 if Partial_Parametrization
then
1357 Process_Default
(Formal
);
1360 Error_Msg_Sloc
:= Sloc
(Gen_Unit
);
1363 Instantiation_Node
, Defining_Identifier
(Formal
));
1364 Error_Msg_NE
("\in instantiation of & declared#",
1365 Instantiation_Node
, Gen_Unit
);
1367 Abandon_Instantiation
(Instantiation_Node
);
1373 (Instantiate_Formal_Package
1374 (Formal
, Match
, Analyzed_Formal
),
1378 -- For use type and use package appearing in the generic part,
1379 -- we have already copied them, so we can just move them where
1380 -- they belong (we mustn't recopy them since this would mess up
1381 -- the Sloc values).
1383 when N_Use_Package_Clause |
1384 N_Use_Type_Clause
=>
1385 if Nkind
(Original_Node
(I_Node
)) =
1386 N_Formal_Package_Declaration
1388 Append
(New_Copy_Tree
(Formal
), Assoc
);
1391 Append
(Formal
, Assoc
);
1395 raise Program_Error
;
1399 Formal
:= Next_Formal
;
1400 Next_Non_Pragma
(Analyzed_Formal
);
1403 if Num_Actuals
> Num_Matched
then
1404 Error_Msg_Sloc
:= Sloc
(Gen_Unit
);
1406 if Present
(Selector_Name
(Actual
)) then
1408 ("unmatched actual&",
1409 Actual
, Selector_Name
(Actual
));
1410 Error_Msg_NE
("\in instantiation of& declared#",
1414 ("unmatched actual in instantiation of& declared#",
1419 elsif Present
(Actuals
) then
1421 ("too many actuals in generic instantiation", Instantiation_Node
);
1425 Elmt
: Elmt_Id
:= First_Elmt
(Actual_Types
);
1427 while Present
(Elmt
) loop
1428 Freeze_Before
(I_Node
, Node
(Elmt
));
1433 -- If there are default subprograms, normalize the tree by adding
1434 -- explicit associations for them. This is required if the instance
1435 -- appears within a generic.
1443 Elmt
:= First_Elmt
(Default_Actuals
);
1444 while Present
(Elmt
) loop
1445 if No
(Actuals
) then
1446 Actuals
:= New_List
;
1447 Set_Generic_Associations
(I_Node
, Actuals
);
1450 Subp
:= Node
(Elmt
);
1452 Make_Generic_Association
(Sloc
(Subp
),
1453 Selector_Name
=> New_Occurrence_Of
(Subp
, Sloc
(Subp
)),
1454 Explicit_Generic_Actual_Parameter
=>
1455 New_Occurrence_Of
(Subp
, Sloc
(Subp
)));
1456 Mark_Rewrite_Insertion
(New_D
);
1457 Append_To
(Actuals
, New_D
);
1462 -- If this is a formal package, normalize the parameter list by adding
1463 -- explicit box associations for the formals that are covered by an
1466 if not Is_Empty_List
(Default_Formals
) then
1467 Append_List
(Default_Formals
, Formals
);
1471 end Analyze_Associations
;
1473 -------------------------------
1474 -- Analyze_Formal_Array_Type --
1475 -------------------------------
1477 procedure Analyze_Formal_Array_Type
1478 (T
: in out Entity_Id
;
1484 -- Treated like a non-generic array declaration, with additional
1489 if Nkind
(Def
) = N_Constrained_Array_Definition
then
1490 DSS
:= First
(Discrete_Subtype_Definitions
(Def
));
1491 while Present
(DSS
) loop
1492 if Nkind_In
(DSS
, N_Subtype_Indication
,
1494 N_Attribute_Reference
)
1496 Error_Msg_N
("only a subtype mark is allowed in a formal", DSS
);
1503 Array_Type_Declaration
(T
, Def
);
1504 Set_Is_Generic_Type
(Base_Type
(T
));
1506 if Ekind
(Component_Type
(T
)) = E_Incomplete_Type
1507 and then No
(Full_View
(Component_Type
(T
)))
1509 Error_Msg_N
("premature usage of incomplete type", Def
);
1511 -- Check that range constraint is not allowed on the component type
1512 -- of a generic formal array type (AARM 12.5.3(3))
1514 elsif Is_Internal
(Component_Type
(T
))
1515 and then Present
(Subtype_Indication
(Component_Definition
(Def
)))
1516 and then Nkind
(Original_Node
1517 (Subtype_Indication
(Component_Definition
(Def
)))) =
1518 N_Subtype_Indication
1521 ("in a formal, a subtype indication can only be "
1522 & "a subtype mark (RM 12.5.3(3))",
1523 Subtype_Indication
(Component_Definition
(Def
)));
1526 end Analyze_Formal_Array_Type
;
1528 ---------------------------------------------
1529 -- Analyze_Formal_Decimal_Fixed_Point_Type --
1530 ---------------------------------------------
1532 -- As for other generic types, we create a valid type representation with
1533 -- legal but arbitrary attributes, whose values are never considered
1534 -- static. For all scalar types we introduce an anonymous base type, with
1535 -- the same attributes. We choose the corresponding integer type to be
1536 -- Standard_Integer.
1538 procedure Analyze_Formal_Decimal_Fixed_Point_Type
1542 Loc
: constant Source_Ptr
:= Sloc
(Def
);
1543 Base
: constant Entity_Id
:=
1545 (E_Decimal_Fixed_Point_Type
,
1546 Current_Scope
, Sloc
(Def
), 'G');
1547 Int_Base
: constant Entity_Id
:= Standard_Integer
;
1548 Delta_Val
: constant Ureal
:= Ureal_1
;
1549 Digs_Val
: constant Uint
:= Uint_6
;
1554 Set_Etype
(Base
, Base
);
1555 Set_Size_Info
(Base
, Int_Base
);
1556 Set_RM_Size
(Base
, RM_Size
(Int_Base
));
1557 Set_First_Rep_Item
(Base
, First_Rep_Item
(Int_Base
));
1558 Set_Digits_Value
(Base
, Digs_Val
);
1559 Set_Delta_Value
(Base
, Delta_Val
);
1560 Set_Small_Value
(Base
, Delta_Val
);
1561 Set_Scalar_Range
(Base
,
1563 Low_Bound
=> Make_Real_Literal
(Loc
, Ureal_1
),
1564 High_Bound
=> Make_Real_Literal
(Loc
, Ureal_1
)));
1566 Set_Is_Generic_Type
(Base
);
1567 Set_Parent
(Base
, Parent
(Def
));
1569 Set_Ekind
(T
, E_Decimal_Fixed_Point_Subtype
);
1570 Set_Etype
(T
, Base
);
1571 Set_Size_Info
(T
, Int_Base
);
1572 Set_RM_Size
(T
, RM_Size
(Int_Base
));
1573 Set_First_Rep_Item
(T
, First_Rep_Item
(Int_Base
));
1574 Set_Digits_Value
(T
, Digs_Val
);
1575 Set_Delta_Value
(T
, Delta_Val
);
1576 Set_Small_Value
(T
, Delta_Val
);
1577 Set_Scalar_Range
(T
, Scalar_Range
(Base
));
1578 Set_Is_Constrained
(T
);
1580 Check_Restriction
(No_Fixed_Point
, Def
);
1581 end Analyze_Formal_Decimal_Fixed_Point_Type
;
1583 -------------------------------------------
1584 -- Analyze_Formal_Derived_Interface_Type --
1585 -------------------------------------------
1587 procedure Analyze_Formal_Derived_Interface_Type
1592 Loc
: constant Source_Ptr
:= Sloc
(Def
);
1595 -- Rewrite as a type declaration of a derived type. This ensures that
1596 -- the interface list and primitive operations are properly captured.
1599 Make_Full_Type_Declaration
(Loc
,
1600 Defining_Identifier
=> T
,
1601 Type_Definition
=> Def
));
1603 Set_Is_Generic_Type
(T
);
1604 end Analyze_Formal_Derived_Interface_Type
;
1606 ---------------------------------
1607 -- Analyze_Formal_Derived_Type --
1608 ---------------------------------
1610 procedure Analyze_Formal_Derived_Type
1615 Loc
: constant Source_Ptr
:= Sloc
(Def
);
1616 Unk_Disc
: constant Boolean := Unknown_Discriminants_Present
(N
);
1620 Set_Is_Generic_Type
(T
);
1622 if Private_Present
(Def
) then
1624 Make_Private_Extension_Declaration
(Loc
,
1625 Defining_Identifier
=> T
,
1626 Discriminant_Specifications
=> Discriminant_Specifications
(N
),
1627 Unknown_Discriminants_Present
=> Unk_Disc
,
1628 Subtype_Indication
=> Subtype_Mark
(Def
),
1629 Interface_List
=> Interface_List
(Def
));
1631 Set_Abstract_Present
(New_N
, Abstract_Present
(Def
));
1632 Set_Limited_Present
(New_N
, Limited_Present
(Def
));
1633 Set_Synchronized_Present
(New_N
, Synchronized_Present
(Def
));
1637 Make_Full_Type_Declaration
(Loc
,
1638 Defining_Identifier
=> T
,
1639 Discriminant_Specifications
=>
1640 Discriminant_Specifications
(Parent
(T
)),
1642 Make_Derived_Type_Definition
(Loc
,
1643 Subtype_Indication
=> Subtype_Mark
(Def
)));
1645 Set_Abstract_Present
1646 (Type_Definition
(New_N
), Abstract_Present
(Def
));
1648 (Type_Definition
(New_N
), Limited_Present
(Def
));
1655 if not Is_Composite_Type
(T
) then
1657 ("unknown discriminants not allowed for elementary types", N
);
1659 Set_Has_Unknown_Discriminants
(T
);
1660 Set_Is_Constrained
(T
, False);
1664 -- If the parent type has a known size, so does the formal, which makes
1665 -- legal representation clauses that involve the formal.
1667 Set_Size_Known_At_Compile_Time
1668 (T
, Size_Known_At_Compile_Time
(Entity
(Subtype_Mark
(Def
))));
1669 end Analyze_Formal_Derived_Type
;
1671 ----------------------------------
1672 -- Analyze_Formal_Discrete_Type --
1673 ----------------------------------
1675 -- The operations defined for a discrete types are those of an enumeration
1676 -- type. The size is set to an arbitrary value, for use in analyzing the
1679 procedure Analyze_Formal_Discrete_Type
(T
: Entity_Id
; Def
: Node_Id
) is
1680 Loc
: constant Source_Ptr
:= Sloc
(Def
);
1684 Base
: constant Entity_Id
:=
1686 (E_Floating_Point_Type
, Current_Scope
, Sloc
(Def
), 'G');
1689 Set_Ekind
(T
, E_Enumeration_Subtype
);
1690 Set_Etype
(T
, Base
);
1693 Set_Is_Generic_Type
(T
);
1694 Set_Is_Constrained
(T
);
1696 -- For semantic analysis, the bounds of the type must be set to some
1697 -- non-static value. The simplest is to create attribute nodes for those
1698 -- bounds, that refer to the type itself. These bounds are never
1699 -- analyzed but serve as place-holders.
1702 Make_Attribute_Reference
(Loc
,
1703 Attribute_Name
=> Name_First
,
1704 Prefix
=> New_Reference_To
(T
, Loc
));
1708 Make_Attribute_Reference
(Loc
,
1709 Attribute_Name
=> Name_Last
,
1710 Prefix
=> New_Reference_To
(T
, Loc
));
1713 Set_Scalar_Range
(T
,
1718 Set_Ekind
(Base
, E_Enumeration_Type
);
1719 Set_Etype
(Base
, Base
);
1720 Init_Size
(Base
, 8);
1721 Init_Alignment
(Base
);
1722 Set_Is_Generic_Type
(Base
);
1723 Set_Scalar_Range
(Base
, Scalar_Range
(T
));
1724 Set_Parent
(Base
, Parent
(Def
));
1725 end Analyze_Formal_Discrete_Type
;
1727 ----------------------------------
1728 -- Analyze_Formal_Floating_Type --
1729 ---------------------------------
1731 procedure Analyze_Formal_Floating_Type
(T
: Entity_Id
; Def
: Node_Id
) is
1732 Base
: constant Entity_Id
:=
1734 (E_Floating_Point_Type
, Current_Scope
, Sloc
(Def
), 'G');
1737 -- The various semantic attributes are taken from the predefined type
1738 -- Float, just so that all of them are initialized. Their values are
1739 -- never used because no constant folding or expansion takes place in
1740 -- the generic itself.
1743 Set_Ekind
(T
, E_Floating_Point_Subtype
);
1744 Set_Etype
(T
, Base
);
1745 Set_Size_Info
(T
, (Standard_Float
));
1746 Set_RM_Size
(T
, RM_Size
(Standard_Float
));
1747 Set_Digits_Value
(T
, Digits_Value
(Standard_Float
));
1748 Set_Scalar_Range
(T
, Scalar_Range
(Standard_Float
));
1749 Set_Is_Constrained
(T
);
1751 Set_Is_Generic_Type
(Base
);
1752 Set_Etype
(Base
, Base
);
1753 Set_Size_Info
(Base
, (Standard_Float
));
1754 Set_RM_Size
(Base
, RM_Size
(Standard_Float
));
1755 Set_Digits_Value
(Base
, Digits_Value
(Standard_Float
));
1756 Set_Scalar_Range
(Base
, Scalar_Range
(Standard_Float
));
1757 Set_Parent
(Base
, Parent
(Def
));
1759 Check_Restriction
(No_Floating_Point
, Def
);
1760 end Analyze_Formal_Floating_Type
;
1762 -----------------------------------
1763 -- Analyze_Formal_Interface_Type;--
1764 -----------------------------------
1766 procedure Analyze_Formal_Interface_Type
1771 Loc
: constant Source_Ptr
:= Sloc
(N
);
1776 Make_Full_Type_Declaration
(Loc
,
1777 Defining_Identifier
=> T
,
1778 Type_Definition
=> Def
);
1782 Set_Is_Generic_Type
(T
);
1783 end Analyze_Formal_Interface_Type
;
1785 ---------------------------------
1786 -- Analyze_Formal_Modular_Type --
1787 ---------------------------------
1789 procedure Analyze_Formal_Modular_Type
(T
: Entity_Id
; Def
: Node_Id
) is
1791 -- Apart from their entity kind, generic modular types are treated like
1792 -- signed integer types, and have the same attributes.
1794 Analyze_Formal_Signed_Integer_Type
(T
, Def
);
1795 Set_Ekind
(T
, E_Modular_Integer_Subtype
);
1796 Set_Ekind
(Etype
(T
), E_Modular_Integer_Type
);
1798 end Analyze_Formal_Modular_Type
;
1800 ---------------------------------------
1801 -- Analyze_Formal_Object_Declaration --
1802 ---------------------------------------
1804 procedure Analyze_Formal_Object_Declaration
(N
: Node_Id
) is
1805 E
: constant Node_Id
:= Default_Expression
(N
);
1806 Id
: constant Node_Id
:= Defining_Identifier
(N
);
1813 -- Determine the mode of the formal object
1815 if Out_Present
(N
) then
1816 K
:= E_Generic_In_Out_Parameter
;
1818 if not In_Present
(N
) then
1819 Error_Msg_N
("formal generic objects cannot have mode OUT", N
);
1823 K
:= E_Generic_In_Parameter
;
1826 if Present
(Subtype_Mark
(N
)) then
1827 Find_Type
(Subtype_Mark
(N
));
1828 T
:= Entity
(Subtype_Mark
(N
));
1830 -- Verify that there is no redundant null exclusion
1832 if Null_Exclusion_Present
(N
) then
1833 if not Is_Access_Type
(T
) then
1835 ("null exclusion can only apply to an access type", N
);
1837 elsif Can_Never_Be_Null
(T
) then
1839 ("`NOT NULL` not allowed (& already excludes null)",
1844 -- Ada 2005 (AI-423): Formal object with an access definition
1847 Check_Access_Definition
(N
);
1848 T
:= Access_Definition
1850 N
=> Access_Definition
(N
));
1853 if Ekind
(T
) = E_Incomplete_Type
then
1855 Error_Node
: Node_Id
;
1858 if Present
(Subtype_Mark
(N
)) then
1859 Error_Node
:= Subtype_Mark
(N
);
1861 Check_Access_Definition
(N
);
1862 Error_Node
:= Access_Definition
(N
);
1865 Error_Msg_N
("premature usage of incomplete type", Error_Node
);
1869 if K
= E_Generic_In_Parameter
then
1871 -- Ada 2005 (AI-287): Limited aggregates allowed in generic formals
1873 if Ada_Version
< Ada_05
and then Is_Limited_Type
(T
) then
1875 ("generic formal of mode IN must not be of limited type", N
);
1876 Explain_Limited_Type
(T
, N
);
1879 if Is_Abstract_Type
(T
) then
1881 ("generic formal of mode IN must not be of abstract type", N
);
1885 Preanalyze_Spec_Expression
(E
, T
);
1887 if Is_Limited_Type
(T
) and then not OK_For_Limited_Init
(E
) then
1889 ("initialization not allowed for limited types", E
);
1890 Explain_Limited_Type
(T
, E
);
1897 -- Case of generic IN OUT parameter
1900 -- If the formal has an unconstrained type, construct its actual
1901 -- subtype, as is done for subprogram formals. In this fashion, all
1902 -- its uses can refer to specific bounds.
1907 if (Is_Array_Type
(T
)
1908 and then not Is_Constrained
(T
))
1910 (Ekind
(T
) = E_Record_Type
1911 and then Has_Discriminants
(T
))
1914 Non_Freezing_Ref
: constant Node_Id
:=
1915 New_Reference_To
(Id
, Sloc
(Id
));
1919 -- Make sure the actual subtype doesn't generate bogus freezing
1921 Set_Must_Not_Freeze
(Non_Freezing_Ref
);
1922 Decl
:= Build_Actual_Subtype
(T
, Non_Freezing_Ref
);
1923 Insert_Before_And_Analyze
(N
, Decl
);
1924 Set_Actual_Subtype
(Id
, Defining_Identifier
(Decl
));
1927 Set_Actual_Subtype
(Id
, T
);
1932 ("initialization not allowed for `IN OUT` formals", N
);
1935 end Analyze_Formal_Object_Declaration
;
1937 ----------------------------------------------
1938 -- Analyze_Formal_Ordinary_Fixed_Point_Type --
1939 ----------------------------------------------
1941 procedure Analyze_Formal_Ordinary_Fixed_Point_Type
1945 Loc
: constant Source_Ptr
:= Sloc
(Def
);
1946 Base
: constant Entity_Id
:=
1948 (E_Ordinary_Fixed_Point_Type
, Current_Scope
, Sloc
(Def
), 'G');
1950 -- The semantic attributes are set for completeness only, their values
1951 -- will never be used, since all properties of the type are non-static.
1954 Set_Ekind
(T
, E_Ordinary_Fixed_Point_Subtype
);
1955 Set_Etype
(T
, Base
);
1956 Set_Size_Info
(T
, Standard_Integer
);
1957 Set_RM_Size
(T
, RM_Size
(Standard_Integer
));
1958 Set_Small_Value
(T
, Ureal_1
);
1959 Set_Delta_Value
(T
, Ureal_1
);
1960 Set_Scalar_Range
(T
,
1962 Low_Bound
=> Make_Real_Literal
(Loc
, Ureal_1
),
1963 High_Bound
=> Make_Real_Literal
(Loc
, Ureal_1
)));
1964 Set_Is_Constrained
(T
);
1966 Set_Is_Generic_Type
(Base
);
1967 Set_Etype
(Base
, Base
);
1968 Set_Size_Info
(Base
, Standard_Integer
);
1969 Set_RM_Size
(Base
, RM_Size
(Standard_Integer
));
1970 Set_Small_Value
(Base
, Ureal_1
);
1971 Set_Delta_Value
(Base
, Ureal_1
);
1972 Set_Scalar_Range
(Base
, Scalar_Range
(T
));
1973 Set_Parent
(Base
, Parent
(Def
));
1975 Check_Restriction
(No_Fixed_Point
, Def
);
1976 end Analyze_Formal_Ordinary_Fixed_Point_Type
;
1978 ----------------------------
1979 -- Analyze_Formal_Package --
1980 ----------------------------
1982 procedure Analyze_Formal_Package
(N
: Node_Id
) is
1983 Loc
: constant Source_Ptr
:= Sloc
(N
);
1984 Pack_Id
: constant Entity_Id
:= Defining_Identifier
(N
);
1986 Gen_Id
: constant Node_Id
:= Name
(N
);
1988 Gen_Unit
: Entity_Id
;
1990 Parent_Installed
: Boolean := False;
1992 Parent_Instance
: Entity_Id
;
1993 Renaming_In_Par
: Entity_Id
;
1994 No_Associations
: Boolean := False;
1996 function Build_Local_Package
return Node_Id
;
1997 -- The formal package is rewritten so that its parameters are replaced
1998 -- with corresponding declarations. For parameters with bona fide
1999 -- associations these declarations are created by Analyze_Associations
2000 -- as for a regular instantiation. For boxed parameters, we preserve
2001 -- the formal declarations and analyze them, in order to introduce
2002 -- entities of the right kind in the environment of the formal.
2004 -------------------------
2005 -- Build_Local_Package --
2006 -------------------------
2008 function Build_Local_Package
return Node_Id
is
2010 Pack_Decl
: Node_Id
;
2013 -- Within the formal, the name of the generic package is a renaming
2014 -- of the formal (as for a regular instantiation).
2017 Make_Package_Declaration
(Loc
,
2020 (Specification
(Original_Node
(Gen_Decl
)),
2021 Empty
, Instantiating
=> True));
2023 Renaming
:= Make_Package_Renaming_Declaration
(Loc
,
2024 Defining_Unit_Name
=>
2025 Make_Defining_Identifier
(Loc
, Chars
(Gen_Unit
)),
2026 Name
=> New_Occurrence_Of
(Formal
, Loc
));
2028 if Nkind
(Gen_Id
) = N_Identifier
2029 and then Chars
(Gen_Id
) = Chars
(Pack_Id
)
2032 ("& is hidden within declaration of instance", Gen_Id
, Gen_Unit
);
2035 -- If the formal is declared with a box, or with an others choice,
2036 -- create corresponding declarations for all entities in the formal
2037 -- part, so that names with the proper types are available in the
2038 -- specification of the formal package.
2040 -- On the other hand, if there are no associations, then all the
2041 -- formals must have defaults, and this will be checked by the
2042 -- call to Analyze_Associations.
2045 or else Nkind
(First
(Generic_Associations
(N
))) = N_Others_Choice
2048 Formal_Decl
: Node_Id
;
2051 -- TBA : for a formal package, need to recurse ???
2056 (Generic_Formal_Declarations
(Original_Node
(Gen_Decl
)));
2057 while Present
(Formal_Decl
) loop
2059 (Decls
, Copy_Generic_Node
(Formal_Decl
, Empty
, True));
2064 -- If generic associations are present, use Analyze_Associations to
2065 -- create the proper renaming declarations.
2069 Act_Tree
: constant Node_Id
:=
2071 (Original_Node
(Gen_Decl
), Empty
,
2072 Instantiating
=> True);
2075 Generic_Renamings
.Set_Last
(0);
2076 Generic_Renamings_HTable
.Reset
;
2077 Instantiation_Node
:= N
;
2080 Analyze_Associations
2082 Generic_Formal_Declarations
(Act_Tree
),
2083 Generic_Formal_Declarations
(Gen_Decl
));
2087 Append
(Renaming
, To
=> Decls
);
2089 -- Add generated declarations ahead of local declarations in
2092 if No
(Visible_Declarations
(Specification
(Pack_Decl
))) then
2093 Set_Visible_Declarations
(Specification
(Pack_Decl
), Decls
);
2096 (First
(Visible_Declarations
(Specification
(Pack_Decl
))),
2101 end Build_Local_Package
;
2103 -- Start of processing for Analyze_Formal_Package
2106 Text_IO_Kludge
(Gen_Id
);
2109 Check_Generic_Child_Unit
(Gen_Id
, Parent_Installed
);
2110 Gen_Unit
:= Entity
(Gen_Id
);
2112 -- Check for a formal package that is a package renaming
2114 if Present
(Renamed_Object
(Gen_Unit
)) then
2115 Gen_Unit
:= Renamed_Object
(Gen_Unit
);
2118 if Ekind
(Gen_Unit
) /= E_Generic_Package
then
2119 Error_Msg_N
("expect generic package name", Gen_Id
);
2123 elsif Gen_Unit
= Current_Scope
then
2125 ("generic package cannot be used as a formal package of itself",
2130 elsif In_Open_Scopes
(Gen_Unit
) then
2131 if Is_Compilation_Unit
(Gen_Unit
)
2132 and then Is_Child_Unit
(Current_Scope
)
2134 -- Special-case the error when the formal is a parent, and
2135 -- continue analysis to minimize cascaded errors.
2138 ("generic parent cannot be used as formal package "
2139 & "of a child unit",
2144 ("generic package cannot be used as a formal package "
2153 or else No
(Generic_Associations
(N
))
2154 or else Nkind
(First
(Generic_Associations
(N
))) = N_Others_Choice
2156 No_Associations
:= True;
2159 -- If there are no generic associations, the generic parameters appear
2160 -- as local entities and are instantiated like them. We copy the generic
2161 -- package declaration as if it were an instantiation, and analyze it
2162 -- like a regular package, except that we treat the formals as
2163 -- additional visible components.
2165 Gen_Decl
:= Unit_Declaration_Node
(Gen_Unit
);
2167 if In_Extended_Main_Source_Unit
(N
) then
2168 Set_Is_Instantiated
(Gen_Unit
);
2169 Generate_Reference
(Gen_Unit
, N
);
2172 Formal
:= New_Copy
(Pack_Id
);
2173 Create_Instantiation_Source
(N
, Gen_Unit
, False, S_Adjustment
);
2176 -- Make local generic without formals. The formals will be replaced
2177 -- with internal declarations.
2179 New_N
:= Build_Local_Package
;
2181 -- If there are errors in the parameter list, Analyze_Associations
2182 -- raises Instantiation_Error. Patch the declaration to prevent
2183 -- further exception propagation.
2186 when Instantiation_Error
=>
2188 Enter_Name
(Formal
);
2189 Set_Ekind
(Formal
, E_Variable
);
2190 Set_Etype
(Formal
, Any_Type
);
2192 if Parent_Installed
then
2200 Set_Defining_Unit_Name
(Specification
(New_N
), Formal
);
2201 Set_Generic_Parent
(Specification
(N
), Gen_Unit
);
2202 Set_Instance_Env
(Gen_Unit
, Formal
);
2203 Set_Is_Generic_Instance
(Formal
);
2205 Enter_Name
(Formal
);
2206 Set_Ekind
(Formal
, E_Package
);
2207 Set_Etype
(Formal
, Standard_Void_Type
);
2208 Set_Inner_Instances
(Formal
, New_Elmt_List
);
2209 Push_Scope
(Formal
);
2211 if Is_Child_Unit
(Gen_Unit
)
2212 and then Parent_Installed
2214 -- Similarly, we have to make the name of the formal visible in the
2215 -- parent instance, to resolve properly fully qualified names that
2216 -- may appear in the generic unit. The parent instance has been
2217 -- placed on the scope stack ahead of the current scope.
2219 Parent_Instance
:= Scope_Stack
.Table
(Scope_Stack
.Last
- 1).Entity
;
2222 Make_Defining_Identifier
(Loc
, Chars
(Gen_Unit
));
2223 Set_Ekind
(Renaming_In_Par
, E_Package
);
2224 Set_Etype
(Renaming_In_Par
, Standard_Void_Type
);
2225 Set_Scope
(Renaming_In_Par
, Parent_Instance
);
2226 Set_Parent
(Renaming_In_Par
, Parent
(Formal
));
2227 Set_Renamed_Object
(Renaming_In_Par
, Formal
);
2228 Append_Entity
(Renaming_In_Par
, Parent_Instance
);
2231 Analyze
(Specification
(N
));
2233 -- The formals for which associations are provided are not visible
2234 -- outside of the formal package. The others are still declared by a
2235 -- formal parameter declaration.
2237 if not No_Associations
then
2242 E
:= First_Entity
(Formal
);
2243 while Present
(E
) loop
2244 exit when Ekind
(E
) = E_Package
2245 and then Renamed_Entity
(E
) = Formal
;
2247 if not Is_Generic_Formal
(E
) then
2256 End_Package_Scope
(Formal
);
2258 if Parent_Installed
then
2264 -- Inside the generic unit, the formal package is a regular package, but
2265 -- no body is needed for it. Note that after instantiation, the defining
2266 -- unit name we need is in the new tree and not in the original (see
2267 -- Package_Instantiation). A generic formal package is an instance, and
2268 -- can be used as an actual for an inner instance.
2270 Set_Has_Completion
(Formal
, True);
2272 -- Add semantic information to the original defining identifier.
2275 Set_Ekind
(Pack_Id
, E_Package
);
2276 Set_Etype
(Pack_Id
, Standard_Void_Type
);
2277 Set_Scope
(Pack_Id
, Scope
(Formal
));
2278 Set_Has_Completion
(Pack_Id
, True);
2279 end Analyze_Formal_Package
;
2281 ---------------------------------
2282 -- Analyze_Formal_Private_Type --
2283 ---------------------------------
2285 procedure Analyze_Formal_Private_Type
2291 New_Private_Type
(N
, T
, Def
);
2293 -- Set the size to an arbitrary but legal value
2295 Set_Size_Info
(T
, Standard_Integer
);
2296 Set_RM_Size
(T
, RM_Size
(Standard_Integer
));
2297 end Analyze_Formal_Private_Type
;
2299 ----------------------------------------
2300 -- Analyze_Formal_Signed_Integer_Type --
2301 ----------------------------------------
2303 procedure Analyze_Formal_Signed_Integer_Type
2307 Base
: constant Entity_Id
:=
2309 (E_Signed_Integer_Type
, Current_Scope
, Sloc
(Def
), 'G');
2314 Set_Ekind
(T
, E_Signed_Integer_Subtype
);
2315 Set_Etype
(T
, Base
);
2316 Set_Size_Info
(T
, Standard_Integer
);
2317 Set_RM_Size
(T
, RM_Size
(Standard_Integer
));
2318 Set_Scalar_Range
(T
, Scalar_Range
(Standard_Integer
));
2319 Set_Is_Constrained
(T
);
2321 Set_Is_Generic_Type
(Base
);
2322 Set_Size_Info
(Base
, Standard_Integer
);
2323 Set_RM_Size
(Base
, RM_Size
(Standard_Integer
));
2324 Set_Etype
(Base
, Base
);
2325 Set_Scalar_Range
(Base
, Scalar_Range
(Standard_Integer
));
2326 Set_Parent
(Base
, Parent
(Def
));
2327 end Analyze_Formal_Signed_Integer_Type
;
2329 -------------------------------
2330 -- Analyze_Formal_Subprogram --
2331 -------------------------------
2333 procedure Analyze_Formal_Subprogram
(N
: Node_Id
) is
2334 Spec
: constant Node_Id
:= Specification
(N
);
2335 Def
: constant Node_Id
:= Default_Name
(N
);
2336 Nam
: constant Entity_Id
:= Defining_Unit_Name
(Spec
);
2344 if Nkind
(Nam
) = N_Defining_Program_Unit_Name
then
2345 Error_Msg_N
("name of formal subprogram must be a direct name", Nam
);
2349 Analyze_Subprogram_Declaration
(N
);
2350 Set_Is_Formal_Subprogram
(Nam
);
2351 Set_Has_Completion
(Nam
);
2353 if Nkind
(N
) = N_Formal_Abstract_Subprogram_Declaration
then
2354 Set_Is_Abstract_Subprogram
(Nam
);
2355 Set_Is_Dispatching_Operation
(Nam
);
2358 Ctrl_Type
: constant Entity_Id
:= Find_Dispatching_Type
(Nam
);
2360 if No
(Ctrl_Type
) then
2362 ("abstract formal subprogram must have a controlling type",
2365 Check_Controlling_Formals
(Ctrl_Type
, Nam
);
2370 -- Default name is resolved at the point of instantiation
2372 if Box_Present
(N
) then
2375 -- Else default is bound at the point of generic declaration
2377 elsif Present
(Def
) then
2378 if Nkind
(Def
) = N_Operator_Symbol
then
2379 Find_Direct_Name
(Def
);
2381 elsif Nkind
(Def
) /= N_Attribute_Reference
then
2385 -- For an attribute reference, analyze the prefix and verify
2386 -- that it has the proper profile for the subprogram.
2388 Analyze
(Prefix
(Def
));
2389 Valid_Default_Attribute
(Nam
, Def
);
2393 -- Default name may be overloaded, in which case the interpretation
2394 -- with the correct profile must be selected, as for a renaming.
2395 -- If the definition is an indexed component, it must denote a
2396 -- member of an entry family. If it is a selected component, it
2397 -- can be a protected operation.
2399 if Etype
(Def
) = Any_Type
then
2402 elsif Nkind
(Def
) = N_Selected_Component
then
2403 if not Is_Overloadable
(Entity
(Selector_Name
(Def
))) then
2404 Error_Msg_N
("expect valid subprogram name as default", Def
);
2407 elsif Nkind
(Def
) = N_Indexed_Component
then
2408 if Is_Entity_Name
(Prefix
(Def
)) then
2409 if Ekind
(Entity
(Prefix
(Def
))) /= E_Entry_Family
then
2410 Error_Msg_N
("expect valid subprogram name as default", Def
);
2413 elsif Nkind
(Prefix
(Def
)) = N_Selected_Component
then
2414 if Ekind
(Entity
(Selector_Name
(Prefix
(Def
))))
2417 Error_Msg_N
("expect valid subprogram name as default", Def
);
2421 Error_Msg_N
("expect valid subprogram name as default", Def
);
2425 elsif Nkind
(Def
) = N_Character_Literal
then
2427 -- Needs some type checks: subprogram should be parameterless???
2429 Resolve
(Def
, (Etype
(Nam
)));
2431 elsif not Is_Entity_Name
(Def
)
2432 or else not Is_Overloadable
(Entity
(Def
))
2434 Error_Msg_N
("expect valid subprogram name as default", Def
);
2437 elsif not Is_Overloaded
(Def
) then
2438 Subp
:= Entity
(Def
);
2441 Error_Msg_N
("premature usage of formal subprogram", Def
);
2443 elsif not Entity_Matches_Spec
(Subp
, Nam
) then
2444 Error_Msg_N
("no visible entity matches specification", Def
);
2447 -- More than one interpretation, so disambiguate as for a renaming
2452 I1
: Interp_Index
:= 0;
2458 Get_First_Interp
(Def
, I
, It
);
2459 while Present
(It
.Nam
) loop
2460 if Entity_Matches_Spec
(It
.Nam
, Nam
) then
2461 if Subp
/= Any_Id
then
2462 It1
:= Disambiguate
(Def
, I1
, I
, Etype
(Subp
));
2464 if It1
= No_Interp
then
2465 Error_Msg_N
("ambiguous default subprogram", Def
);
2478 Get_Next_Interp
(I
, It
);
2482 if Subp
/= Any_Id
then
2483 Set_Entity
(Def
, Subp
);
2486 Error_Msg_N
("premature usage of formal subprogram", Def
);
2488 elsif Ekind
(Subp
) /= E_Operator
then
2489 Check_Mode_Conformant
(Subp
, Nam
);
2493 Error_Msg_N
("no visible subprogram matches specification", N
);
2497 end Analyze_Formal_Subprogram
;
2499 -------------------------------------
2500 -- Analyze_Formal_Type_Declaration --
2501 -------------------------------------
2503 procedure Analyze_Formal_Type_Declaration
(N
: Node_Id
) is
2504 Def
: constant Node_Id
:= Formal_Type_Definition
(N
);
2508 T
:= Defining_Identifier
(N
);
2510 if Present
(Discriminant_Specifications
(N
))
2511 and then Nkind
(Def
) /= N_Formal_Private_Type_Definition
2514 ("discriminants not allowed for this formal type", T
);
2517 -- Enter the new name, and branch to specific routine
2520 when N_Formal_Private_Type_Definition
=>
2521 Analyze_Formal_Private_Type
(N
, T
, Def
);
2523 when N_Formal_Derived_Type_Definition
=>
2524 Analyze_Formal_Derived_Type
(N
, T
, Def
);
2526 when N_Formal_Discrete_Type_Definition
=>
2527 Analyze_Formal_Discrete_Type
(T
, Def
);
2529 when N_Formal_Signed_Integer_Type_Definition
=>
2530 Analyze_Formal_Signed_Integer_Type
(T
, Def
);
2532 when N_Formal_Modular_Type_Definition
=>
2533 Analyze_Formal_Modular_Type
(T
, Def
);
2535 when N_Formal_Floating_Point_Definition
=>
2536 Analyze_Formal_Floating_Type
(T
, Def
);
2538 when N_Formal_Ordinary_Fixed_Point_Definition
=>
2539 Analyze_Formal_Ordinary_Fixed_Point_Type
(T
, Def
);
2541 when N_Formal_Decimal_Fixed_Point_Definition
=>
2542 Analyze_Formal_Decimal_Fixed_Point_Type
(T
, Def
);
2544 when N_Array_Type_Definition
=>
2545 Analyze_Formal_Array_Type
(T
, Def
);
2547 when N_Access_To_Object_Definition |
2548 N_Access_Function_Definition |
2549 N_Access_Procedure_Definition
=>
2550 Analyze_Generic_Access_Type
(T
, Def
);
2552 -- Ada 2005: a interface declaration is encoded as an abstract
2553 -- record declaration or a abstract type derivation.
2555 when N_Record_Definition
=>
2556 Analyze_Formal_Interface_Type
(N
, T
, Def
);
2558 when N_Derived_Type_Definition
=>
2559 Analyze_Formal_Derived_Interface_Type
(N
, T
, Def
);
2565 raise Program_Error
;
2569 Set_Is_Generic_Type
(T
);
2570 end Analyze_Formal_Type_Declaration
;
2572 ------------------------------------
2573 -- Analyze_Function_Instantiation --
2574 ------------------------------------
2576 procedure Analyze_Function_Instantiation
(N
: Node_Id
) is
2578 Analyze_Subprogram_Instantiation
(N
, E_Function
);
2579 end Analyze_Function_Instantiation
;
2581 ---------------------------------
2582 -- Analyze_Generic_Access_Type --
2583 ---------------------------------
2585 procedure Analyze_Generic_Access_Type
(T
: Entity_Id
; Def
: Node_Id
) is
2589 if Nkind
(Def
) = N_Access_To_Object_Definition
then
2590 Access_Type_Declaration
(T
, Def
);
2592 if Is_Incomplete_Or_Private_Type
(Designated_Type
(T
))
2593 and then No
(Full_View
(Designated_Type
(T
)))
2594 and then not Is_Generic_Type
(Designated_Type
(T
))
2596 Error_Msg_N
("premature usage of incomplete type", Def
);
2598 elsif Is_Internal
(Designated_Type
(T
)) then
2600 ("only a subtype mark is allowed in a formal", Def
);
2604 Access_Subprogram_Declaration
(T
, Def
);
2606 end Analyze_Generic_Access_Type
;
2608 ---------------------------------
2609 -- Analyze_Generic_Formal_Part --
2610 ---------------------------------
2612 procedure Analyze_Generic_Formal_Part
(N
: Node_Id
) is
2613 Gen_Parm_Decl
: Node_Id
;
2616 -- The generic formals are processed in the scope of the generic unit,
2617 -- where they are immediately visible. The scope is installed by the
2620 Gen_Parm_Decl
:= First
(Generic_Formal_Declarations
(N
));
2622 while Present
(Gen_Parm_Decl
) loop
2623 Analyze
(Gen_Parm_Decl
);
2624 Next
(Gen_Parm_Decl
);
2627 Generate_Reference_To_Generic_Formals
(Current_Scope
);
2628 end Analyze_Generic_Formal_Part
;
2630 ------------------------------------------
2631 -- Analyze_Generic_Package_Declaration --
2632 ------------------------------------------
2634 procedure Analyze_Generic_Package_Declaration
(N
: Node_Id
) is
2635 Loc
: constant Source_Ptr
:= Sloc
(N
);
2638 Save_Parent
: Node_Id
;
2640 Decls
: constant List_Id
:=
2641 Visible_Declarations
(Specification
(N
));
2645 -- We introduce a renaming of the enclosing package, to have a usable
2646 -- entity as the prefix of an expanded name for a local entity of the
2647 -- form Par.P.Q, where P is the generic package. This is because a local
2648 -- entity named P may hide it, so that the usual visibility rules in
2649 -- the instance will not resolve properly.
2652 Make_Package_Renaming_Declaration
(Loc
,
2653 Defining_Unit_Name
=>
2654 Make_Defining_Identifier
(Loc
,
2655 Chars
=> New_External_Name
(Chars
(Defining_Entity
(N
)), "GH")),
2656 Name
=> Make_Identifier
(Loc
, Chars
(Defining_Entity
(N
))));
2658 if Present
(Decls
) then
2659 Decl
:= First
(Decls
);
2660 while Present
(Decl
)
2661 and then Nkind
(Decl
) = N_Pragma
2666 if Present
(Decl
) then
2667 Insert_Before
(Decl
, Renaming
);
2669 Append
(Renaming
, Visible_Declarations
(Specification
(N
)));
2673 Set_Visible_Declarations
(Specification
(N
), New_List
(Renaming
));
2676 -- Create copy of generic unit, and save for instantiation. If the unit
2677 -- is a child unit, do not copy the specifications for the parent, which
2678 -- are not part of the generic tree.
2680 Save_Parent
:= Parent_Spec
(N
);
2681 Set_Parent_Spec
(N
, Empty
);
2683 New_N
:= Copy_Generic_Node
(N
, Empty
, Instantiating
=> False);
2684 Set_Parent_Spec
(New_N
, Save_Parent
);
2686 Id
:= Defining_Entity
(N
);
2687 Generate_Definition
(Id
);
2689 -- Expansion is not applied to generic units
2694 Set_Ekind
(Id
, E_Generic_Package
);
2695 Set_Etype
(Id
, Standard_Void_Type
);
2697 Enter_Generic_Scope
(Id
);
2698 Set_Inner_Instances
(Id
, New_Elmt_List
);
2700 Set_Categorization_From_Pragmas
(N
);
2701 Set_Is_Pure
(Id
, Is_Pure
(Current_Scope
));
2703 -- Link the declaration of the generic homonym in the generic copy to
2704 -- the package it renames, so that it is always resolved properly.
2706 Set_Generic_Homonym
(Id
, Defining_Unit_Name
(Renaming
));
2707 Set_Entity
(Associated_Node
(Name
(Renaming
)), Id
);
2709 -- For a library unit, we have reconstructed the entity for the unit,
2710 -- and must reset it in the library tables.
2712 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
2713 Set_Cunit_Entity
(Current_Sem_Unit
, Id
);
2716 Analyze_Generic_Formal_Part
(N
);
2718 -- After processing the generic formals, analysis proceeds as for a
2719 -- non-generic package.
2721 Analyze
(Specification
(N
));
2723 Validate_Categorization_Dependency
(N
, Id
);
2727 End_Package_Scope
(Id
);
2728 Exit_Generic_Scope
(Id
);
2730 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
2731 Move_Freeze_Nodes
(Id
, N
, Visible_Declarations
(Specification
(N
)));
2732 Move_Freeze_Nodes
(Id
, N
, Private_Declarations
(Specification
(N
)));
2733 Move_Freeze_Nodes
(Id
, N
, Generic_Formal_Declarations
(N
));
2736 Set_Body_Required
(Parent
(N
), Unit_Requires_Body
(Id
));
2737 Validate_RT_RAT_Component
(N
);
2739 -- If this is a spec without a body, check that generic parameters
2742 if not Body_Required
(Parent
(N
)) then
2743 Check_References
(Id
);
2746 end Analyze_Generic_Package_Declaration
;
2748 --------------------------------------------
2749 -- Analyze_Generic_Subprogram_Declaration --
2750 --------------------------------------------
2752 procedure Analyze_Generic_Subprogram_Declaration
(N
: Node_Id
) is
2757 Result_Type
: Entity_Id
;
2758 Save_Parent
: Node_Id
;
2762 -- Create copy of generic unit, and save for instantiation. If the unit
2763 -- is a child unit, do not copy the specifications for the parent, which
2764 -- are not part of the generic tree.
2766 Save_Parent
:= Parent_Spec
(N
);
2767 Set_Parent_Spec
(N
, Empty
);
2769 New_N
:= Copy_Generic_Node
(N
, Empty
, Instantiating
=> False);
2770 Set_Parent_Spec
(New_N
, Save_Parent
);
2773 Spec
:= Specification
(N
);
2774 Id
:= Defining_Entity
(Spec
);
2775 Generate_Definition
(Id
);
2777 if Nkind
(Id
) = N_Defining_Operator_Symbol
then
2779 ("operator symbol not allowed for generic subprogram", Id
);
2786 Set_Scope_Depth_Value
(Id
, Scope_Depth
(Current_Scope
) + 1);
2788 Enter_Generic_Scope
(Id
);
2789 Set_Inner_Instances
(Id
, New_Elmt_List
);
2790 Set_Is_Pure
(Id
, Is_Pure
(Current_Scope
));
2792 Analyze_Generic_Formal_Part
(N
);
2794 Formals
:= Parameter_Specifications
(Spec
);
2796 if Present
(Formals
) then
2797 Process_Formals
(Formals
, Spec
);
2800 if Nkind
(Spec
) = N_Function_Specification
then
2801 Set_Ekind
(Id
, E_Generic_Function
);
2803 if Nkind
(Result_Definition
(Spec
)) = N_Access_Definition
then
2804 Result_Type
:= Access_Definition
(Spec
, Result_Definition
(Spec
));
2805 Set_Etype
(Id
, Result_Type
);
2807 Find_Type
(Result_Definition
(Spec
));
2808 Typ
:= Entity
(Result_Definition
(Spec
));
2810 -- If a null exclusion is imposed on the result type, then create
2811 -- a null-excluding itype (an access subtype) and use it as the
2812 -- function's Etype.
2814 if Is_Access_Type
(Typ
)
2815 and then Null_Exclusion_Present
(Spec
)
2818 Create_Null_Excluding_Itype
2820 Related_Nod
=> Spec
,
2821 Scope_Id
=> Defining_Unit_Name
(Spec
)));
2823 Set_Etype
(Id
, Typ
);
2828 Set_Ekind
(Id
, E_Generic_Procedure
);
2829 Set_Etype
(Id
, Standard_Void_Type
);
2832 -- For a library unit, we have reconstructed the entity for the unit,
2833 -- and must reset it in the library tables. We also make sure that
2834 -- Body_Required is set properly in the original compilation unit node.
2836 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
2837 Set_Cunit_Entity
(Current_Sem_Unit
, Id
);
2838 Set_Body_Required
(Parent
(N
), Unit_Requires_Body
(Id
));
2841 Set_Categorization_From_Pragmas
(N
);
2842 Validate_Categorization_Dependency
(N
, Id
);
2844 Save_Global_References
(Original_Node
(N
));
2848 Exit_Generic_Scope
(Id
);
2849 Generate_Reference_To_Formals
(Id
);
2850 end Analyze_Generic_Subprogram_Declaration
;
2852 -----------------------------------
2853 -- Analyze_Package_Instantiation --
2854 -----------------------------------
2856 procedure Analyze_Package_Instantiation
(N
: Node_Id
) is
2857 Loc
: constant Source_Ptr
:= Sloc
(N
);
2858 Gen_Id
: constant Node_Id
:= Name
(N
);
2861 Act_Decl_Name
: Node_Id
;
2862 Act_Decl_Id
: Entity_Id
;
2867 Gen_Unit
: Entity_Id
;
2869 Is_Actual_Pack
: constant Boolean :=
2870 Is_Internal
(Defining_Entity
(N
));
2872 Env_Installed
: Boolean := False;
2873 Parent_Installed
: Boolean := False;
2874 Renaming_List
: List_Id
;
2875 Unit_Renaming
: Node_Id
;
2876 Needs_Body
: Boolean;
2877 Inline_Now
: Boolean := False;
2879 procedure Delay_Descriptors
(E
: Entity_Id
);
2880 -- Delay generation of subprogram descriptors for given entity
2882 function Might_Inline_Subp
return Boolean;
2883 -- If inlining is active and the generic contains inlined subprograms,
2884 -- we instantiate the body. This may cause superfluous instantiations,
2885 -- but it is simpler than detecting the need for the body at the point
2886 -- of inlining, when the context of the instance is not available.
2888 -----------------------
2889 -- Delay_Descriptors --
2890 -----------------------
2892 procedure Delay_Descriptors
(E
: Entity_Id
) is
2894 if not Delay_Subprogram_Descriptors
(E
) then
2895 Set_Delay_Subprogram_Descriptors
(E
);
2896 Pending_Descriptor
.Append
(E
);
2898 end Delay_Descriptors
;
2900 -----------------------
2901 -- Might_Inline_Subp --
2902 -----------------------
2904 function Might_Inline_Subp
return Boolean is
2908 if not Inline_Processing_Required
then
2912 E
:= First_Entity
(Gen_Unit
);
2913 while Present
(E
) loop
2914 if Is_Subprogram
(E
)
2915 and then Is_Inlined
(E
)
2925 end Might_Inline_Subp
;
2927 -- Start of processing for Analyze_Package_Instantiation
2930 -- Very first thing: apply the special kludge for Text_IO processing
2931 -- in case we are instantiating one of the children of [Wide_]Text_IO.
2933 Text_IO_Kludge
(Name
(N
));
2935 -- Make node global for error reporting
2937 Instantiation_Node
:= N
;
2939 -- Case of instantiation of a generic package
2941 if Nkind
(N
) = N_Package_Instantiation
then
2942 Act_Decl_Id
:= New_Copy
(Defining_Entity
(N
));
2943 Set_Comes_From_Source
(Act_Decl_Id
, True);
2945 if Nkind
(Defining_Unit_Name
(N
)) = N_Defining_Program_Unit_Name
then
2947 Make_Defining_Program_Unit_Name
(Loc
,
2948 Name
=> New_Copy_Tree
(Name
(Defining_Unit_Name
(N
))),
2949 Defining_Identifier
=> Act_Decl_Id
);
2951 Act_Decl_Name
:= Act_Decl_Id
;
2954 -- Case of instantiation of a formal package
2957 Act_Decl_Id
:= Defining_Identifier
(N
);
2958 Act_Decl_Name
:= Act_Decl_Id
;
2961 Generate_Definition
(Act_Decl_Id
);
2962 Preanalyze_Actuals
(N
);
2965 Env_Installed
:= True;
2967 -- Reset renaming map for formal types. The mapping is established
2968 -- when analyzing the generic associations, but some mappings are
2969 -- inherited from formal packages of parent units, and these are
2970 -- constructed when the parents are installed.
2972 Generic_Renamings
.Set_Last
(0);
2973 Generic_Renamings_HTable
.Reset
;
2975 Check_Generic_Child_Unit
(Gen_Id
, Parent_Installed
);
2976 Gen_Unit
:= Entity
(Gen_Id
);
2978 -- Verify that it is the name of a generic package
2980 -- A visibility glitch: if the instance is a child unit and the generic
2981 -- is the generic unit of a parent instance (i.e. both the parent and
2982 -- the child units are instances of the same package) the name now
2983 -- denotes the renaming within the parent, not the intended generic
2984 -- unit. See if there is a homonym that is the desired generic. The
2985 -- renaming declaration must be visible inside the instance of the
2986 -- child, but not when analyzing the name in the instantiation itself.
2988 if Ekind
(Gen_Unit
) = E_Package
2989 and then Present
(Renamed_Entity
(Gen_Unit
))
2990 and then In_Open_Scopes
(Renamed_Entity
(Gen_Unit
))
2991 and then Is_Generic_Instance
(Renamed_Entity
(Gen_Unit
))
2992 and then Present
(Homonym
(Gen_Unit
))
2994 Gen_Unit
:= Homonym
(Gen_Unit
);
2997 if Etype
(Gen_Unit
) = Any_Type
then
3001 elsif Ekind
(Gen_Unit
) /= E_Generic_Package
then
3003 -- Ada 2005 (AI-50217): Cannot use instance in limited with_clause
3005 if From_With_Type
(Gen_Unit
) then
3007 ("cannot instantiate a limited withed package", Gen_Id
);
3010 ("expect name of generic package in instantiation", Gen_Id
);
3017 if In_Extended_Main_Source_Unit
(N
) then
3018 Set_Is_Instantiated
(Gen_Unit
);
3019 Generate_Reference
(Gen_Unit
, N
);
3021 if Present
(Renamed_Object
(Gen_Unit
)) then
3022 Set_Is_Instantiated
(Renamed_Object
(Gen_Unit
));
3023 Generate_Reference
(Renamed_Object
(Gen_Unit
), N
);
3027 if Nkind
(Gen_Id
) = N_Identifier
3028 and then Chars
(Gen_Unit
) = Chars
(Defining_Entity
(N
))
3031 ("& is hidden within declaration of instance", Gen_Id
, Gen_Unit
);
3033 elsif Nkind
(Gen_Id
) = N_Expanded_Name
3034 and then Is_Child_Unit
(Gen_Unit
)
3035 and then Nkind
(Prefix
(Gen_Id
)) = N_Identifier
3036 and then Chars
(Act_Decl_Id
) = Chars
(Prefix
(Gen_Id
))
3039 ("& is hidden within declaration of instance ", Prefix
(Gen_Id
));
3042 Set_Entity
(Gen_Id
, Gen_Unit
);
3044 -- If generic is a renaming, get original generic unit
3046 if Present
(Renamed_Object
(Gen_Unit
))
3047 and then Ekind
(Renamed_Object
(Gen_Unit
)) = E_Generic_Package
3049 Gen_Unit
:= Renamed_Object
(Gen_Unit
);
3052 -- Verify that there are no circular instantiations
3054 if In_Open_Scopes
(Gen_Unit
) then
3055 Error_Msg_NE
("instantiation of & within itself", N
, Gen_Unit
);
3059 elsif Contains_Instance_Of
(Gen_Unit
, Current_Scope
, Gen_Id
) then
3060 Error_Msg_Node_2
:= Current_Scope
;
3062 ("circular Instantiation: & instantiated in &!", N
, Gen_Unit
);
3063 Circularity_Detected
:= True;
3068 Gen_Decl
:= Unit_Declaration_Node
(Gen_Unit
);
3070 -- Initialize renamings map, for error checking, and the list that
3071 -- holds private entities whose views have changed between generic
3072 -- definition and instantiation. If this is the instance created to
3073 -- validate an actual package, the instantiation environment is that
3074 -- of the enclosing instance.
3076 Create_Instantiation_Source
(N
, Gen_Unit
, False, S_Adjustment
);
3078 -- Copy original generic tree, to produce text for instantiation
3082 (Original_Node
(Gen_Decl
), Empty
, Instantiating
=> True);
3084 Act_Spec
:= Specification
(Act_Tree
);
3086 -- If this is the instance created to validate an actual package,
3087 -- only the formals matter, do not examine the package spec itself.
3089 if Is_Actual_Pack
then
3090 Set_Visible_Declarations
(Act_Spec
, New_List
);
3091 Set_Private_Declarations
(Act_Spec
, New_List
);
3095 Analyze_Associations
3097 Generic_Formal_Declarations
(Act_Tree
),
3098 Generic_Formal_Declarations
(Gen_Decl
));
3100 Set_Instance_Env
(Gen_Unit
, Act_Decl_Id
);
3101 Set_Defining_Unit_Name
(Act_Spec
, Act_Decl_Name
);
3102 Set_Is_Generic_Instance
(Act_Decl_Id
);
3104 Set_Generic_Parent
(Act_Spec
, Gen_Unit
);
3106 -- References to the generic in its own declaration or its body are
3107 -- references to the instance. Add a renaming declaration for the
3108 -- generic unit itself. This declaration, as well as the renaming
3109 -- declarations for the generic formals, must remain private to the
3110 -- unit: the formals, because this is the language semantics, and
3111 -- the unit because its use is an artifact of the implementation.
3114 Make_Package_Renaming_Declaration
(Loc
,
3115 Defining_Unit_Name
=>
3116 Make_Defining_Identifier
(Loc
, Chars
(Gen_Unit
)),
3117 Name
=> New_Reference_To
(Act_Decl_Id
, Loc
));
3119 Append
(Unit_Renaming
, Renaming_List
);
3121 -- The renaming declarations are the first local declarations of
3124 if Is_Non_Empty_List
(Visible_Declarations
(Act_Spec
)) then
3126 (First
(Visible_Declarations
(Act_Spec
)), Renaming_List
);
3128 Set_Visible_Declarations
(Act_Spec
, Renaming_List
);
3132 Make_Package_Declaration
(Loc
,
3133 Specification
=> Act_Spec
);
3135 -- Save the instantiation node, for subsequent instantiation of the
3136 -- body, if there is one and we are generating code for the current
3137 -- unit. Mark the unit as having a body, to avoid a premature error
3140 -- We instantiate the body if we are generating code, if we are
3141 -- generating cross-reference information, or if we are building
3142 -- trees for ASIS use.
3145 Enclosing_Body_Present
: Boolean := False;
3146 -- If the generic unit is not a compilation unit, then a body may
3147 -- be present in its parent even if none is required. We create a
3148 -- tentative pending instantiation for the body, which will be
3149 -- discarded if none is actually present.
3154 if Scope
(Gen_Unit
) /= Standard_Standard
3155 and then not Is_Child_Unit
(Gen_Unit
)
3157 Scop
:= Scope
(Gen_Unit
);
3159 while Present
(Scop
)
3160 and then Scop
/= Standard_Standard
3162 if Unit_Requires_Body
(Scop
) then
3163 Enclosing_Body_Present
:= True;
3166 elsif In_Open_Scopes
(Scop
)
3167 and then In_Package_Body
(Scop
)
3169 Enclosing_Body_Present
:= True;
3173 exit when Is_Compilation_Unit
(Scop
);
3174 Scop
:= Scope
(Scop
);
3178 -- If front-end inlining is enabled, and this is a unit for which
3179 -- code will be generated, we instantiate the body at once.
3181 -- This is done if the instance is not the main unit, and if the
3182 -- generic is not a child unit of another generic, to avoid scope
3183 -- problems and the reinstallation of parent instances.
3186 and then (not Is_Child_Unit
(Gen_Unit
)
3187 or else not Is_Generic_Unit
(Scope
(Gen_Unit
)))
3188 and then Might_Inline_Subp
3189 and then not Is_Actual_Pack
3191 if Front_End_Inlining
3192 and then (Is_In_Main_Unit
(N
)
3193 or else In_Main_Context
(Current_Scope
))
3194 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit
3198 -- In configurable_run_time mode we force the inlining of
3199 -- predefined subprograms marked Inline_Always, to minimize
3200 -- the use of the run-time library.
3202 elsif Is_Predefined_File_Name
3203 (Unit_File_Name
(Get_Source_Unit
(Gen_Decl
)))
3204 and then Configurable_Run_Time_Mode
3205 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit
3210 -- If the current scope is itself an instance within a child
3211 -- unit, there will be duplications in the scope stack, and the
3212 -- unstacking mechanism in Inline_Instance_Body will fail.
3213 -- This loses some rare cases of optimization, and might be
3214 -- improved some day, if we can find a proper abstraction for
3215 -- "the complete compilation context" that can be saved and
3218 if Is_Generic_Instance
(Current_Scope
) then
3220 Curr_Unit
: constant Entity_Id
:=
3221 Cunit_Entity
(Current_Sem_Unit
);
3223 if Curr_Unit
/= Current_Scope
3224 and then Is_Child_Unit
(Curr_Unit
)
3226 Inline_Now
:= False;
3233 (Unit_Requires_Body
(Gen_Unit
)
3234 or else Enclosing_Body_Present
3235 or else Present
(Corresponding_Body
(Gen_Decl
)))
3236 and then (Is_In_Main_Unit
(N
)
3237 or else Might_Inline_Subp
)
3238 and then not Is_Actual_Pack
3239 and then not Inline_Now
3240 and then (Operating_Mode
= Generate_Code
3241 or else (Operating_Mode
= Check_Semantics
3242 and then ASIS_Mode
));
3244 -- If front_end_inlining is enabled, do not instantiate body if
3245 -- within a generic context.
3247 if (Front_End_Inlining
3248 and then not Expander_Active
)
3249 or else Is_Generic_Unit
(Cunit_Entity
(Main_Unit
))
3251 Needs_Body
:= False;
3254 -- If the current context is generic, and the package being
3255 -- instantiated is declared within a formal package, there is no
3256 -- body to instantiate until the enclosing generic is instantiated
3257 -- and there is an actual for the formal package. If the formal
3258 -- package has parameters, we build a regular package instance for
3259 -- it, that precedes the original formal package declaration.
3261 if In_Open_Scopes
(Scope
(Scope
(Gen_Unit
))) then
3263 Decl
: constant Node_Id
:=
3265 (Unit_Declaration_Node
(Scope
(Gen_Unit
)));
3267 if Nkind
(Decl
) = N_Formal_Package_Declaration
3268 or else (Nkind
(Decl
) = N_Package_Declaration
3269 and then Is_List_Member
(Decl
)
3270 and then Present
(Next
(Decl
))
3272 Nkind
(Next
(Decl
)) =
3273 N_Formal_Package_Declaration
)
3275 Needs_Body
:= False;
3281 -- If we are generating the calling stubs from the instantiation of
3282 -- a generic RCI package, we will not use the body of the generic
3285 if Distribution_Stub_Mode
= Generate_Caller_Stub_Body
3286 and then Is_Compilation_Unit
(Defining_Entity
(N
))
3288 Needs_Body
:= False;
3293 -- Here is a defence against a ludicrous number of instantiations
3294 -- caused by a circular set of instantiation attempts.
3296 if Pending_Instantiations
.Last
>
3297 Hostparm
.Max_Instantiations
3299 Error_Msg_N
("too many instantiations", N
);
3300 raise Unrecoverable_Error
;
3303 -- Indicate that the enclosing scopes contain an instantiation,
3304 -- and that cleanup actions should be delayed until after the
3305 -- instance body is expanded.
3307 Check_Forward_Instantiation
(Gen_Decl
);
3308 if Nkind
(N
) = N_Package_Instantiation
then
3310 Enclosing_Master
: Entity_Id
;
3313 -- Loop to search enclosing masters
3315 Enclosing_Master
:= Current_Scope
;
3316 Scope_Loop
: while Enclosing_Master
/= Standard_Standard
loop
3317 if Ekind
(Enclosing_Master
) = E_Package
then
3318 if Is_Compilation_Unit
(Enclosing_Master
) then
3319 if In_Package_Body
(Enclosing_Master
) then
3321 (Body_Entity
(Enclosing_Master
));
3330 Enclosing_Master
:= Scope
(Enclosing_Master
);
3333 elsif Ekind
(Enclosing_Master
) = E_Generic_Package
then
3334 Enclosing_Master
:= Scope
(Enclosing_Master
);
3336 elsif Is_Generic_Subprogram
(Enclosing_Master
)
3337 or else Ekind
(Enclosing_Master
) = E_Void
3339 -- Cleanup actions will eventually be performed on the
3340 -- enclosing instance, if any. Enclosing scope is void
3341 -- in the formal part of a generic subprogram.
3346 if Ekind
(Enclosing_Master
) = E_Entry
3348 Ekind
(Scope
(Enclosing_Master
)) = E_Protected_Type
3350 if not Expander_Active
then
3354 Protected_Body_Subprogram
(Enclosing_Master
);
3358 Set_Delay_Cleanups
(Enclosing_Master
);
3360 while Ekind
(Enclosing_Master
) = E_Block
loop
3361 Enclosing_Master
:= Scope
(Enclosing_Master
);
3364 if Is_Subprogram
(Enclosing_Master
) then
3365 Delay_Descriptors
(Enclosing_Master
);
3367 elsif Is_Task_Type
(Enclosing_Master
) then
3369 TBP
: constant Node_Id
:=
3370 Get_Task_Body_Procedure
3373 if Present
(TBP
) then
3374 Delay_Descriptors
(TBP
);
3375 Set_Delay_Cleanups
(TBP
);
3382 end loop Scope_Loop
;
3385 -- Make entry in table
3387 Pending_Instantiations
.Append
3389 Act_Decl
=> Act_Decl
,
3390 Expander_Status
=> Expander_Active
,
3391 Current_Sem_Unit
=> Current_Sem_Unit
,
3392 Scope_Suppress
=> Scope_Suppress
,
3393 Local_Suppress_Stack_Top
=> Local_Suppress_Stack_Top
));
3397 Set_Categorization_From_Pragmas
(Act_Decl
);
3399 if Parent_Installed
then
3403 Set_Instance_Spec
(N
, Act_Decl
);
3405 -- If not a compilation unit, insert the package declaration before
3406 -- the original instantiation node.
3408 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
3409 Mark_Rewrite_Insertion
(Act_Decl
);
3410 Insert_Before
(N
, Act_Decl
);
3413 -- For an instantiation that is a compilation unit, place declaration
3414 -- on current node so context is complete for analysis (including
3415 -- nested instantiations). If this is the main unit, the declaration
3416 -- eventually replaces the instantiation node. If the instance body
3417 -- is created later, it replaces the instance node, and the
3418 -- declaration is attached to it (see
3419 -- Build_Instance_Compilation_Unit_Nodes).
3422 if Cunit_Entity
(Current_Sem_Unit
) = Defining_Entity
(N
) then
3424 -- The entity for the current unit is the newly created one,
3425 -- and all semantic information is attached to it.
3427 Set_Cunit_Entity
(Current_Sem_Unit
, Act_Decl_Id
);
3429 -- If this is the main unit, replace the main entity as well
3431 if Current_Sem_Unit
= Main_Unit
then
3432 Main_Unit_Entity
:= Act_Decl_Id
;
3436 Set_Unit
(Parent
(N
), Act_Decl
);
3437 Set_Parent_Spec
(Act_Decl
, Parent_Spec
(N
));
3438 Set_Package_Instantiation
(Act_Decl_Id
, N
);
3440 Set_Unit
(Parent
(N
), N
);
3441 Set_Body_Required
(Parent
(N
), False);
3443 -- We never need elaboration checks on instantiations, since by
3444 -- definition, the body instantiation is elaborated at the same
3445 -- time as the spec instantiation.
3447 Set_Suppress_Elaboration_Warnings
(Act_Decl_Id
);
3448 Set_Kill_Elaboration_Checks
(Act_Decl_Id
);
3451 Check_Elab_Instantiation
(N
);
3453 if ABE_Is_Certain
(N
) and then Needs_Body
then
3454 Pending_Instantiations
.Decrement_Last
;
3457 Check_Hidden_Child_Unit
(N
, Gen_Unit
, Act_Decl_Id
);
3459 Set_First_Private_Entity
(Defining_Unit_Name
(Unit_Renaming
),
3460 First_Private_Entity
(Act_Decl_Id
));
3462 -- If the instantiation will receive a body, the unit will be
3463 -- transformed into a package body, and receive its own elaboration
3464 -- entity. Otherwise, the nature of the unit is now a package
3467 if Nkind
(Parent
(N
)) = N_Compilation_Unit
3468 and then not Needs_Body
3470 Rewrite
(N
, Act_Decl
);
3473 if Present
(Corresponding_Body
(Gen_Decl
))
3474 or else Unit_Requires_Body
(Gen_Unit
)
3476 Set_Has_Completion
(Act_Decl_Id
);
3479 Check_Formal_Packages
(Act_Decl_Id
);
3481 Restore_Private_Views
(Act_Decl_Id
);
3483 Inherit_Context
(Gen_Decl
, N
);
3485 if Parent_Installed
then
3490 Env_Installed
:= False;
3493 Validate_Categorization_Dependency
(N
, Act_Decl_Id
);
3495 -- There used to be a check here to prevent instantiations in local
3496 -- contexts if the No_Local_Allocators restriction was active. This
3497 -- check was removed by a binding interpretation in AI-95-00130/07,
3498 -- but we retain the code for documentation purposes.
3500 -- if Ekind (Act_Decl_Id) /= E_Void
3501 -- and then not Is_Library_Level_Entity (Act_Decl_Id)
3503 -- Check_Restriction (No_Local_Allocators, N);
3507 Inline_Instance_Body
(N
, Gen_Unit
, Act_Decl
);
3510 -- The following is a tree patch for ASIS: ASIS needs separate nodes to
3511 -- be used as defining identifiers for a formal package and for the
3512 -- corresponding expanded package.
3514 if Nkind
(N
) = N_Formal_Package_Declaration
then
3515 Act_Decl_Id
:= New_Copy
(Defining_Entity
(N
));
3516 Set_Comes_From_Source
(Act_Decl_Id
, True);
3517 Set_Is_Generic_Instance
(Act_Decl_Id
, False);
3518 Set_Defining_Identifier
(N
, Act_Decl_Id
);
3522 when Instantiation_Error
=>
3523 if Parent_Installed
then
3527 if Env_Installed
then
3530 end Analyze_Package_Instantiation
;
3532 --------------------------
3533 -- Inline_Instance_Body --
3534 --------------------------
3536 procedure Inline_Instance_Body
3538 Gen_Unit
: Entity_Id
;
3542 Gen_Comp
: constant Entity_Id
:=
3543 Cunit_Entity
(Get_Source_Unit
(Gen_Unit
));
3544 Curr_Comp
: constant Node_Id
:= Cunit
(Current_Sem_Unit
);
3545 Curr_Scope
: Entity_Id
:= Empty
;
3546 Curr_Unit
: constant Entity_Id
:=
3547 Cunit_Entity
(Current_Sem_Unit
);
3548 Removed
: Boolean := False;
3549 Num_Scopes
: Int
:= 0;
3551 Scope_Stack_Depth
: constant Int
:=
3552 Scope_Stack
.Last
- Scope_Stack
.First
+ 1;
3554 Use_Clauses
: array (1 .. Scope_Stack_Depth
) of Node_Id
;
3555 Instances
: array (1 .. Scope_Stack_Depth
) of Entity_Id
;
3556 Inner_Scopes
: array (1 .. Scope_Stack_Depth
) of Entity_Id
;
3557 Num_Inner
: Int
:= 0;
3558 N_Instances
: Int
:= 0;
3562 -- Case of generic unit defined in another unit. We must remove the
3563 -- complete context of the current unit to install that of the generic.
3565 if Gen_Comp
/= Cunit_Entity
(Current_Sem_Unit
) then
3567 -- Add some comments for the following two loops ???
3570 while Present
(S
) and then S
/= Standard_Standard
loop
3572 Num_Scopes
:= Num_Scopes
+ 1;
3574 Use_Clauses
(Num_Scopes
) :=
3576 (Scope_Stack
.Last
- Num_Scopes
+ 1).
3578 End_Use_Clauses
(Use_Clauses
(Num_Scopes
));
3580 exit when Scope_Stack
.Last
- Num_Scopes
+ 1 = Scope_Stack
.First
3581 or else Scope_Stack
.Table
3582 (Scope_Stack
.Last
- Num_Scopes
).Entity
3586 exit when Is_Generic_Instance
(S
)
3587 and then (In_Package_Body
(S
)
3588 or else Ekind
(S
) = E_Procedure
3589 or else Ekind
(S
) = E_Function
);
3593 Vis
:= Is_Immediately_Visible
(Gen_Comp
);
3595 -- Find and save all enclosing instances
3600 and then S
/= Standard_Standard
3602 if Is_Generic_Instance
(S
) then
3603 N_Instances
:= N_Instances
+ 1;
3604 Instances
(N_Instances
) := S
;
3606 exit when In_Package_Body
(S
);
3612 -- Remove context of current compilation unit, unless we are within a
3613 -- nested package instantiation, in which case the context has been
3614 -- removed previously.
3616 -- If current scope is the body of a child unit, remove context of
3617 -- spec as well. If an enclosing scope is an instance body, the
3618 -- context has already been removed, but the entities in the body
3619 -- must be made invisible as well.
3624 and then S
/= Standard_Standard
3626 if Is_Generic_Instance
(S
)
3627 and then (In_Package_Body
(S
)
3628 or else Ekind
(S
) = E_Procedure
3629 or else Ekind
(S
) = E_Function
)
3631 -- We still have to remove the entities of the enclosing
3632 -- instance from direct visibility.
3637 E
:= First_Entity
(S
);
3638 while Present
(E
) loop
3639 Set_Is_Immediately_Visible
(E
, False);
3648 or else (Ekind
(Curr_Unit
) = E_Package_Body
3649 and then S
= Spec_Entity
(Curr_Unit
))
3650 or else (Ekind
(Curr_Unit
) = E_Subprogram_Body
3653 (Unit_Declaration_Node
(Curr_Unit
)))
3657 -- Remove entities in current scopes from visibility, so that
3658 -- instance body is compiled in a clean environment.
3660 Save_Scope_Stack
(Handle_Use
=> False);
3662 if Is_Child_Unit
(S
) then
3664 -- Remove child unit from stack, as well as inner scopes.
3665 -- Removing the context of a child unit removes parent units
3668 while Current_Scope
/= S
loop
3669 Num_Inner
:= Num_Inner
+ 1;
3670 Inner_Scopes
(Num_Inner
) := Current_Scope
;
3675 Remove_Context
(Curr_Comp
);
3679 Remove_Context
(Curr_Comp
);
3682 if Ekind
(Curr_Unit
) = E_Package_Body
then
3683 Remove_Context
(Library_Unit
(Curr_Comp
));
3689 pragma Assert
(Num_Inner
< Num_Scopes
);
3691 Push_Scope
(Standard_Standard
);
3692 Scope_Stack
.Table
(Scope_Stack
.Last
).Is_Active_Stack_Base
:= True;
3693 Instantiate_Package_Body
3696 Act_Decl
=> Act_Decl
,
3697 Expander_Status
=> Expander_Active
,
3698 Current_Sem_Unit
=> Current_Sem_Unit
,
3699 Scope_Suppress
=> Scope_Suppress
,
3700 Local_Suppress_Stack_Top
=> Local_Suppress_Stack_Top
)),
3701 Inlined_Body
=> True);
3707 Set_Is_Immediately_Visible
(Gen_Comp
, Vis
);
3709 -- Reset Generic_Instance flag so that use clauses can be installed
3710 -- in the proper order. (See Use_One_Package for effect of enclosing
3711 -- instances on processing of use clauses).
3713 for J
in 1 .. N_Instances
loop
3714 Set_Is_Generic_Instance
(Instances
(J
), False);
3718 Install_Context
(Curr_Comp
);
3720 if Present
(Curr_Scope
)
3721 and then Is_Child_Unit
(Curr_Scope
)
3723 Push_Scope
(Curr_Scope
);
3724 Set_Is_Immediately_Visible
(Curr_Scope
);
3726 -- Finally, restore inner scopes as well
3728 for J
in reverse 1 .. Num_Inner
loop
3729 Push_Scope
(Inner_Scopes
(J
));
3733 Restore_Scope_Stack
(Handle_Use
=> False);
3735 if Present
(Curr_Scope
)
3737 (In_Private_Part
(Curr_Scope
)
3738 or else In_Package_Body
(Curr_Scope
))
3740 -- Install private declaration of ancestor units, which are
3741 -- currently available. Restore_Scope_Stack and Install_Context
3742 -- only install the visible part of parents.
3747 Par
:= Scope
(Curr_Scope
);
3748 while (Present
(Par
))
3749 and then Par
/= Standard_Standard
3751 Install_Private_Declarations
(Par
);
3758 -- Restore use clauses. For a child unit, use clauses in the parents
3759 -- are restored when installing the context, so only those in inner
3760 -- scopes (and those local to the child unit itself) need to be
3761 -- installed explicitly.
3763 if Is_Child_Unit
(Curr_Unit
)
3766 for J
in reverse 1 .. Num_Inner
+ 1 loop
3767 Scope_Stack
.Table
(Scope_Stack
.Last
- J
+ 1).First_Use_Clause
:=
3769 Install_Use_Clauses
(Use_Clauses
(J
));
3773 for J
in reverse 1 .. Num_Scopes
loop
3774 Scope_Stack
.Table
(Scope_Stack
.Last
- J
+ 1).First_Use_Clause
:=
3776 Install_Use_Clauses
(Use_Clauses
(J
));
3780 -- Restore status of instances. If one of them is a body, make
3781 -- its local entities visible again.
3788 for J
in 1 .. N_Instances
loop
3789 Inst
:= Instances
(J
);
3790 Set_Is_Generic_Instance
(Inst
, True);
3792 if In_Package_Body
(Inst
)
3793 or else Ekind
(S
) = E_Procedure
3794 or else Ekind
(S
) = E_Function
3796 E
:= First_Entity
(Instances
(J
));
3797 while Present
(E
) loop
3798 Set_Is_Immediately_Visible
(E
);
3805 -- If generic unit is in current unit, current context is correct
3808 Instantiate_Package_Body
3811 Act_Decl
=> Act_Decl
,
3812 Expander_Status
=> Expander_Active
,
3813 Current_Sem_Unit
=> Current_Sem_Unit
,
3814 Scope_Suppress
=> Scope_Suppress
,
3815 Local_Suppress_Stack_Top
=> Local_Suppress_Stack_Top
)),
3816 Inlined_Body
=> True);
3818 end Inline_Instance_Body
;
3820 -------------------------------------
3821 -- Analyze_Procedure_Instantiation --
3822 -------------------------------------
3824 procedure Analyze_Procedure_Instantiation
(N
: Node_Id
) is
3826 Analyze_Subprogram_Instantiation
(N
, E_Procedure
);
3827 end Analyze_Procedure_Instantiation
;
3829 -----------------------------------
3830 -- Need_Subprogram_Instance_Body --
3831 -----------------------------------
3833 function Need_Subprogram_Instance_Body
3835 Subp
: Entity_Id
) return Boolean
3838 if (Is_In_Main_Unit
(N
)
3839 or else Is_Inlined
(Subp
)
3840 or else Is_Inlined
(Alias
(Subp
)))
3841 and then (Operating_Mode
= Generate_Code
3842 or else (Operating_Mode
= Check_Semantics
3843 and then ASIS_Mode
))
3844 and then (Expander_Active
or else ASIS_Mode
)
3845 and then not ABE_Is_Certain
(N
)
3846 and then not Is_Eliminated
(Subp
)
3848 Pending_Instantiations
.Append
3850 Act_Decl
=> Unit_Declaration_Node
(Subp
),
3851 Expander_Status
=> Expander_Active
,
3852 Current_Sem_Unit
=> Current_Sem_Unit
,
3853 Scope_Suppress
=> Scope_Suppress
,
3854 Local_Suppress_Stack_Top
=> Local_Suppress_Stack_Top
));
3859 end Need_Subprogram_Instance_Body
;
3861 --------------------------------------
3862 -- Analyze_Subprogram_Instantiation --
3863 --------------------------------------
3865 procedure Analyze_Subprogram_Instantiation
3869 Loc
: constant Source_Ptr
:= Sloc
(N
);
3870 Gen_Id
: constant Node_Id
:= Name
(N
);
3872 Anon_Id
: constant Entity_Id
:=
3873 Make_Defining_Identifier
(Sloc
(Defining_Entity
(N
)),
3874 Chars
=> New_External_Name
3875 (Chars
(Defining_Entity
(N
)), 'R'));
3877 Act_Decl_Id
: Entity_Id
;
3882 Env_Installed
: Boolean := False;
3883 Gen_Unit
: Entity_Id
;
3885 Pack_Id
: Entity_Id
;
3886 Parent_Installed
: Boolean := False;
3887 Renaming_List
: List_Id
;
3889 procedure Analyze_Instance_And_Renamings
;
3890 -- The instance must be analyzed in a context that includes the mappings
3891 -- of generic parameters into actuals. We create a package declaration
3892 -- for this purpose, and a subprogram with an internal name within the
3893 -- package. The subprogram instance is simply an alias for the internal
3894 -- subprogram, declared in the current scope.
3896 ------------------------------------
3897 -- Analyze_Instance_And_Renamings --
3898 ------------------------------------
3900 procedure Analyze_Instance_And_Renamings
is
3901 Def_Ent
: constant Entity_Id
:= Defining_Entity
(N
);
3902 Pack_Decl
: Node_Id
;
3905 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
3907 -- For the case of a compilation unit, the container package has
3908 -- the same name as the instantiation, to insure that the binder
3909 -- calls the elaboration procedure with the right name. Copy the
3910 -- entity of the instance, which may have compilation level flags
3911 -- (e.g. Is_Child_Unit) set.
3913 Pack_Id
:= New_Copy
(Def_Ent
);
3916 -- Otherwise we use the name of the instantiation concatenated
3917 -- with its source position to ensure uniqueness if there are
3918 -- several instantiations with the same name.
3921 Make_Defining_Identifier
(Loc
,
3922 Chars
=> New_External_Name
3923 (Related_Id
=> Chars
(Def_Ent
),
3925 Suffix_Index
=> Source_Offset
(Sloc
(Def_Ent
))));
3928 Pack_Decl
:= Make_Package_Declaration
(Loc
,
3929 Specification
=> Make_Package_Specification
(Loc
,
3930 Defining_Unit_Name
=> Pack_Id
,
3931 Visible_Declarations
=> Renaming_List
,
3932 End_Label
=> Empty
));
3934 Set_Instance_Spec
(N
, Pack_Decl
);
3935 Set_Is_Generic_Instance
(Pack_Id
);
3936 Set_Debug_Info_Needed
(Pack_Id
);
3938 -- Case of not a compilation unit
3940 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
3941 Mark_Rewrite_Insertion
(Pack_Decl
);
3942 Insert_Before
(N
, Pack_Decl
);
3943 Set_Has_Completion
(Pack_Id
);
3945 -- Case of an instantiation that is a compilation unit
3947 -- Place declaration on current node so context is complete for
3948 -- analysis (including nested instantiations), and for use in a
3949 -- context_clause (see Analyze_With_Clause).
3952 Set_Unit
(Parent
(N
), Pack_Decl
);
3953 Set_Parent_Spec
(Pack_Decl
, Parent_Spec
(N
));
3956 Analyze
(Pack_Decl
);
3957 Check_Formal_Packages
(Pack_Id
);
3958 Set_Is_Generic_Instance
(Pack_Id
, False);
3960 -- Body of the enclosing package is supplied when instantiating the
3961 -- subprogram body, after semantic analysis is completed.
3963 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
3965 -- Remove package itself from visibility, so it does not
3966 -- conflict with subprogram.
3968 Set_Name_Entity_Id
(Chars
(Pack_Id
), Homonym
(Pack_Id
));
3970 -- Set name and scope of internal subprogram so that the proper
3971 -- external name will be generated. The proper scope is the scope
3972 -- of the wrapper package. We need to generate debugging info for
3973 -- the internal subprogram, so set flag accordingly.
3975 Set_Chars
(Anon_Id
, Chars
(Defining_Entity
(N
)));
3976 Set_Scope
(Anon_Id
, Scope
(Pack_Id
));
3978 -- Mark wrapper package as referenced, to avoid spurious warnings
3979 -- if the instantiation appears in various with_ clauses of
3980 -- subunits of the main unit.
3982 Set_Referenced
(Pack_Id
);
3985 Set_Is_Generic_Instance
(Anon_Id
);
3986 Set_Debug_Info_Needed
(Anon_Id
);
3987 Act_Decl_Id
:= New_Copy
(Anon_Id
);
3989 Set_Parent
(Act_Decl_Id
, Parent
(Anon_Id
));
3990 Set_Chars
(Act_Decl_Id
, Chars
(Defining_Entity
(N
)));
3991 Set_Sloc
(Act_Decl_Id
, Sloc
(Defining_Entity
(N
)));
3992 Set_Comes_From_Source
(Act_Decl_Id
, True);
3994 -- The signature may involve types that are not frozen yet, but the
3995 -- subprogram will be frozen at the point the wrapper package is
3996 -- frozen, so it does not need its own freeze node. In fact, if one
3997 -- is created, it might conflict with the freezing actions from the
4000 Set_Has_Delayed_Freeze
(Anon_Id
, False);
4002 -- If the instance is a child unit, mark the Id accordingly. Mark
4003 -- the anonymous entity as well, which is the real subprogram and
4004 -- which is used when the instance appears in a context clause.
4006 Set_Is_Child_Unit
(Act_Decl_Id
, Is_Child_Unit
(Defining_Entity
(N
)));
4007 Set_Is_Child_Unit
(Anon_Id
, Is_Child_Unit
(Defining_Entity
(N
)));
4008 New_Overloaded_Entity
(Act_Decl_Id
);
4009 Check_Eliminated
(Act_Decl_Id
);
4011 -- In compilation unit case, kill elaboration checks on the
4012 -- instantiation, since they are never needed -- the body is
4013 -- instantiated at the same point as the spec.
4015 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
4016 Set_Suppress_Elaboration_Warnings
(Act_Decl_Id
);
4017 Set_Kill_Elaboration_Checks
(Act_Decl_Id
);
4018 Set_Is_Compilation_Unit
(Anon_Id
);
4020 Set_Cunit_Entity
(Current_Sem_Unit
, Pack_Id
);
4023 -- The instance is not a freezing point for the new subprogram
4025 Set_Is_Frozen
(Act_Decl_Id
, False);
4027 if Nkind
(Defining_Entity
(N
)) = N_Defining_Operator_Symbol
then
4028 Valid_Operator_Definition
(Act_Decl_Id
);
4031 Set_Alias
(Act_Decl_Id
, Anon_Id
);
4032 Set_Parent
(Act_Decl_Id
, Parent
(Anon_Id
));
4033 Set_Has_Completion
(Act_Decl_Id
);
4034 Set_Related_Instance
(Pack_Id
, Act_Decl_Id
);
4036 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
4037 Set_Body_Required
(Parent
(N
), False);
4039 end Analyze_Instance_And_Renamings
;
4041 -- Start of processing for Analyze_Subprogram_Instantiation
4044 -- Very first thing: apply the special kludge for Text_IO processing
4045 -- in case we are instantiating one of the children of [Wide_]Text_IO.
4046 -- Of course such an instantiation is bogus (these are packages, not
4047 -- subprograms), but we get a better error message if we do this.
4049 Text_IO_Kludge
(Gen_Id
);
4051 -- Make node global for error reporting
4053 Instantiation_Node
:= N
;
4054 Preanalyze_Actuals
(N
);
4057 Env_Installed
:= True;
4058 Check_Generic_Child_Unit
(Gen_Id
, Parent_Installed
);
4059 Gen_Unit
:= Entity
(Gen_Id
);
4061 Generate_Reference
(Gen_Unit
, Gen_Id
);
4063 if Nkind
(Gen_Id
) = N_Identifier
4064 and then Chars
(Gen_Unit
) = Chars
(Defining_Entity
(N
))
4067 ("& is hidden within declaration of instance", Gen_Id
, Gen_Unit
);
4070 if Etype
(Gen_Unit
) = Any_Type
then
4075 -- Verify that it is a generic subprogram of the right kind, and that
4076 -- it does not lead to a circular instantiation.
4078 if Ekind
(Gen_Unit
) /= E_Generic_Procedure
4079 and then Ekind
(Gen_Unit
) /= E_Generic_Function
4081 Error_Msg_N
("expect generic subprogram in instantiation", Gen_Id
);
4083 elsif In_Open_Scopes
(Gen_Unit
) then
4084 Error_Msg_NE
("instantiation of & within itself", N
, Gen_Unit
);
4086 elsif K
= E_Procedure
4087 and then Ekind
(Gen_Unit
) /= E_Generic_Procedure
4089 if Ekind
(Gen_Unit
) = E_Generic_Function
then
4091 ("cannot instantiate generic function as procedure", Gen_Id
);
4094 ("expect name of generic procedure in instantiation", Gen_Id
);
4097 elsif K
= E_Function
4098 and then Ekind
(Gen_Unit
) /= E_Generic_Function
4100 if Ekind
(Gen_Unit
) = E_Generic_Procedure
then
4102 ("cannot instantiate generic procedure as function", Gen_Id
);
4105 ("expect name of generic function in instantiation", Gen_Id
);
4109 Set_Entity
(Gen_Id
, Gen_Unit
);
4110 Set_Is_Instantiated
(Gen_Unit
);
4112 if In_Extended_Main_Source_Unit
(N
) then
4113 Generate_Reference
(Gen_Unit
, N
);
4116 -- If renaming, get original unit
4118 if Present
(Renamed_Object
(Gen_Unit
))
4119 and then (Ekind
(Renamed_Object
(Gen_Unit
)) = E_Generic_Procedure
4121 Ekind
(Renamed_Object
(Gen_Unit
)) = E_Generic_Function
)
4123 Gen_Unit
:= Renamed_Object
(Gen_Unit
);
4124 Set_Is_Instantiated
(Gen_Unit
);
4125 Generate_Reference
(Gen_Unit
, N
);
4128 if Contains_Instance_Of
(Gen_Unit
, Current_Scope
, Gen_Id
) then
4129 Error_Msg_Node_2
:= Current_Scope
;
4131 ("circular Instantiation: & instantiated in &!", N
, Gen_Unit
);
4132 Circularity_Detected
:= True;
4136 Gen_Decl
:= Unit_Declaration_Node
(Gen_Unit
);
4138 -- Initialize renamings map, for error checking
4140 Generic_Renamings
.Set_Last
(0);
4141 Generic_Renamings_HTable
.Reset
;
4143 Create_Instantiation_Source
(N
, Gen_Unit
, False, S_Adjustment
);
4145 -- Copy original generic tree, to produce text for instantiation
4149 (Original_Node
(Gen_Decl
), Empty
, Instantiating
=> True);
4151 -- Inherit overriding indicator from instance node
4153 Act_Spec
:= Specification
(Act_Tree
);
4154 Set_Must_Override
(Act_Spec
, Must_Override
(N
));
4155 Set_Must_Not_Override
(Act_Spec
, Must_Not_Override
(N
));
4158 Analyze_Associations
4160 Generic_Formal_Declarations
(Act_Tree
),
4161 Generic_Formal_Declarations
(Gen_Decl
));
4163 -- The subprogram itself cannot contain a nested instance, so the
4164 -- current parent is left empty.
4166 Set_Instance_Env
(Gen_Unit
, Empty
);
4168 -- Build the subprogram declaration, which does not appear in the
4169 -- generic template, and give it a sloc consistent with that of the
4172 Set_Defining_Unit_Name
(Act_Spec
, Anon_Id
);
4173 Set_Generic_Parent
(Act_Spec
, Gen_Unit
);
4175 Make_Subprogram_Declaration
(Sloc
(Act_Spec
),
4176 Specification
=> Act_Spec
);
4178 Set_Categorization_From_Pragmas
(Act_Decl
);
4180 if Parent_Installed
then
4184 Append
(Act_Decl
, Renaming_List
);
4185 Analyze_Instance_And_Renamings
;
4187 -- If the generic is marked Import (Intrinsic), then so is the
4188 -- instance. This indicates that there is no body to instantiate. If
4189 -- generic is marked inline, so it the instance, and the anonymous
4190 -- subprogram it renames. If inlined, or else if inlining is enabled
4191 -- for the compilation, we generate the instance body even if it is
4192 -- not within the main unit.
4194 -- Any other pragmas might also be inherited ???
4196 if Is_Intrinsic_Subprogram
(Gen_Unit
) then
4197 Set_Is_Intrinsic_Subprogram
(Anon_Id
);
4198 Set_Is_Intrinsic_Subprogram
(Act_Decl_Id
);
4200 if Chars
(Gen_Unit
) = Name_Unchecked_Conversion
then
4201 Validate_Unchecked_Conversion
(N
, Act_Decl_Id
);
4205 Generate_Definition
(Act_Decl_Id
);
4207 Set_Is_Inlined
(Act_Decl_Id
, Is_Inlined
(Gen_Unit
));
4208 Set_Is_Inlined
(Anon_Id
, Is_Inlined
(Gen_Unit
));
4210 if not Is_Intrinsic_Subprogram
(Gen_Unit
) then
4211 Check_Elab_Instantiation
(N
);
4214 if Is_Dispatching_Operation
(Act_Decl_Id
)
4215 and then Ada_Version
>= Ada_05
4221 Formal
:= First_Formal
(Act_Decl_Id
);
4222 while Present
(Formal
) loop
4223 if Ekind
(Etype
(Formal
)) = E_Anonymous_Access_Type
4224 and then Is_Controlling_Formal
(Formal
)
4225 and then not Can_Never_Be_Null
(Formal
)
4227 Error_Msg_NE
("access parameter& is controlling,",
4229 Error_Msg_NE
("\corresponding parameter of & must be"
4230 & " explicitly null-excluding", N
, Gen_Id
);
4233 Next_Formal
(Formal
);
4238 Check_Hidden_Child_Unit
(N
, Gen_Unit
, Act_Decl_Id
);
4240 -- Subject to change, pending on if other pragmas are inherited ???
4242 Validate_Categorization_Dependency
(N
, Act_Decl_Id
);
4244 if not Is_Intrinsic_Subprogram
(Act_Decl_Id
) then
4245 Inherit_Context
(Gen_Decl
, N
);
4247 Restore_Private_Views
(Pack_Id
, False);
4249 -- If the context requires a full instantiation, mark node for
4250 -- subsequent construction of the body.
4252 if Need_Subprogram_Instance_Body
(N
, Act_Decl_Id
) then
4254 Check_Forward_Instantiation
(Gen_Decl
);
4256 -- The wrapper package is always delayed, because it does not
4257 -- constitute a freeze point, but to insure that the freeze
4258 -- node is placed properly, it is created directly when
4259 -- instantiating the body (otherwise the freeze node might
4260 -- appear to early for nested instantiations).
4262 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
then
4264 -- For ASIS purposes, indicate that the wrapper package has
4265 -- replaced the instantiation node.
4267 Rewrite
(N
, Unit
(Parent
(N
)));
4268 Set_Unit
(Parent
(N
), N
);
4271 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
then
4273 -- Replace instance node for library-level instantiations of
4274 -- intrinsic subprograms, for ASIS use.
4276 Rewrite
(N
, Unit
(Parent
(N
)));
4277 Set_Unit
(Parent
(N
), N
);
4280 if Parent_Installed
then
4285 Env_Installed
:= False;
4286 Generic_Renamings
.Set_Last
(0);
4287 Generic_Renamings_HTable
.Reset
;
4291 when Instantiation_Error
=>
4292 if Parent_Installed
then
4296 if Env_Installed
then
4299 end Analyze_Subprogram_Instantiation
;
4301 -------------------------
4302 -- Get_Associated_Node --
4303 -------------------------
4305 function Get_Associated_Node
(N
: Node_Id
) return Node_Id
is
4309 Assoc
:= Associated_Node
(N
);
4311 if Nkind
(Assoc
) /= Nkind
(N
) then
4314 elsif Nkind_In
(Assoc
, N_Aggregate
, N_Extension_Aggregate
) then
4318 -- If the node is part of an inner generic, it may itself have been
4319 -- remapped into a further generic copy. Associated_Node is otherwise
4320 -- used for the entity of the node, and will be of a different node
4321 -- kind, or else N has been rewritten as a literal or function call.
4323 while Present
(Associated_Node
(Assoc
))
4324 and then Nkind
(Associated_Node
(Assoc
)) = Nkind
(Assoc
)
4326 Assoc
:= Associated_Node
(Assoc
);
4329 -- Follow and additional link in case the final node was rewritten.
4330 -- This can only happen with nested generic units.
4332 if (Nkind
(Assoc
) = N_Identifier
or else Nkind
(Assoc
) in N_Op
)
4333 and then Present
(Associated_Node
(Assoc
))
4334 and then (Nkind_In
(Associated_Node
(Assoc
), N_Function_Call
,
4335 N_Explicit_Dereference
,
4340 Assoc
:= Associated_Node
(Assoc
);
4345 end Get_Associated_Node
;
4347 -------------------------------------------
4348 -- Build_Instance_Compilation_Unit_Nodes --
4349 -------------------------------------------
4351 procedure Build_Instance_Compilation_Unit_Nodes
4356 Decl_Cunit
: Node_Id
;
4357 Body_Cunit
: Node_Id
;
4359 New_Main
: constant Entity_Id
:= Defining_Entity
(Act_Decl
);
4360 Old_Main
: constant Entity_Id
:= Cunit_Entity
(Main_Unit
);
4363 -- A new compilation unit node is built for the instance declaration.
4364 -- Place the context of the compilation this declaration, so that it
4365 -- it is processed before the instance in CodePeer.
4368 Make_Compilation_Unit
(Sloc
(N
),
4369 Context_Items
=> Context_Items
(Parent
(N
)),
4372 Make_Compilation_Unit_Aux
(Sloc
(N
)));
4374 Set_Parent_Spec
(Act_Decl
, Parent_Spec
(N
));
4375 Set_Context_Items
(Parent
(N
), Empty_List
);
4377 -- The new compilation unit is linked to its body, but both share the
4378 -- same file, so we do not set Body_Required on the new unit so as not
4379 -- to create a spurious dependency on a non-existent body in the ali.
4380 -- This simplifies Codepeer unit traversal.
4382 -- We use the original instantiation compilation unit as the resulting
4383 -- compilation unit of the instance, since this is the main unit.
4385 Rewrite
(N
, Act_Body
);
4386 Body_Cunit
:= Parent
(N
);
4388 -- The two compilation unit nodes are linked by the Library_Unit field
4390 Set_Library_Unit
(Decl_Cunit
, Body_Cunit
);
4391 Set_Library_Unit
(Body_Cunit
, Decl_Cunit
);
4393 -- Preserve the private nature of the package if needed
4395 Set_Private_Present
(Decl_Cunit
, Private_Present
(Body_Cunit
));
4397 -- If the instance is not the main unit, its context, categorization
4398 -- and elaboration entity are not relevant to the compilation.
4400 if Body_Cunit
/= Cunit
(Main_Unit
) then
4401 Make_Instance_Unit
(Body_Cunit
, In_Main
=> False);
4405 -- The context clause items on the instantiation, which are now attached
4406 -- to the body compilation unit (since the body overwrote the original
4407 -- instantiation node), semantically belong on the spec, so copy them
4408 -- there. It's harmless to leave them on the body as well. In fact one
4409 -- could argue that they belong in both places.
4411 Citem
:= First
(Context_Items
(Body_Cunit
));
4412 while Present
(Citem
) loop
4413 Append
(New_Copy
(Citem
), Context_Items
(Decl_Cunit
));
4417 -- Propagate categorization flags on packages, so that they appear in
4418 -- the ali file for the spec of the unit.
4420 if Ekind
(New_Main
) = E_Package
then
4421 Set_Is_Pure
(Old_Main
, Is_Pure
(New_Main
));
4422 Set_Is_Preelaborated
(Old_Main
, Is_Preelaborated
(New_Main
));
4423 Set_Is_Remote_Types
(Old_Main
, Is_Remote_Types
(New_Main
));
4424 Set_Is_Shared_Passive
(Old_Main
, Is_Shared_Passive
(New_Main
));
4425 Set_Is_Remote_Call_Interface
4426 (Old_Main
, Is_Remote_Call_Interface
(New_Main
));
4429 -- Make entry in Units table, so that binder can generate call to
4430 -- elaboration procedure for body, if any.
4432 Make_Instance_Unit
(Body_Cunit
, In_Main
=> True);
4433 Main_Unit_Entity
:= New_Main
;
4434 Set_Cunit_Entity
(Main_Unit
, Main_Unit_Entity
);
4436 -- Build elaboration entity, since the instance may certainly generate
4437 -- elaboration code requiring a flag for protection.
4439 Build_Elaboration_Entity
(Decl_Cunit
, New_Main
);
4440 end Build_Instance_Compilation_Unit_Nodes
;
4442 -----------------------------
4443 -- Check_Access_Definition --
4444 -----------------------------
4446 procedure Check_Access_Definition
(N
: Node_Id
) is
4449 (Ada_Version
>= Ada_05
4450 and then Present
(Access_Definition
(N
)));
4452 end Check_Access_Definition
;
4454 -----------------------------------
4455 -- Check_Formal_Package_Instance --
4456 -----------------------------------
4458 -- If the formal has specific parameters, they must match those of the
4459 -- actual. Both of them are instances, and the renaming declarations for
4460 -- their formal parameters appear in the same order in both. The analyzed
4461 -- formal has been analyzed in the context of the current instance.
4463 procedure Check_Formal_Package_Instance
4464 (Formal_Pack
: Entity_Id
;
4465 Actual_Pack
: Entity_Id
)
4467 E1
: Entity_Id
:= First_Entity
(Actual_Pack
);
4468 E2
: Entity_Id
:= First_Entity
(Formal_Pack
);
4473 procedure Check_Mismatch
(B
: Boolean);
4474 -- Common error routine for mismatch between the parameters of the
4475 -- actual instance and those of the formal package.
4477 function Same_Instantiated_Constant
(E1
, E2
: Entity_Id
) return Boolean;
4478 -- The formal may come from a nested formal package, and the actual may
4479 -- have been constant-folded. To determine whether the two denote the
4480 -- same entity we may have to traverse several definitions to recover
4481 -- the ultimate entity that they refer to.
4483 function Same_Instantiated_Variable
(E1
, E2
: Entity_Id
) return Boolean;
4484 -- Similarly, if the formal comes from a nested formal package, the
4485 -- actual may designate the formal through multiple renamings, which
4486 -- have to be followed to determine the original variable in question.
4488 --------------------
4489 -- Check_Mismatch --
4490 --------------------
4492 procedure Check_Mismatch
(B
: Boolean) is
4493 Kind
: constant Node_Kind
:= Nkind
(Parent
(E2
));
4496 if Kind
= N_Formal_Type_Declaration
then
4499 elsif Nkind_In
(Kind
, N_Formal_Object_Declaration
,
4500 N_Formal_Package_Declaration
)
4501 or else Kind
in N_Formal_Subprogram_Declaration
4507 ("actual for & in actual instance does not match formal",
4508 Parent
(Actual_Pack
), E1
);
4512 --------------------------------
4513 -- Same_Instantiated_Constant --
4514 --------------------------------
4516 function Same_Instantiated_Constant
4517 (E1
, E2
: Entity_Id
) return Boolean
4523 while Present
(Ent
) loop
4527 elsif Ekind
(Ent
) /= E_Constant
then
4530 elsif Is_Entity_Name
(Constant_Value
(Ent
)) then
4531 if Entity
(Constant_Value
(Ent
)) = E1
then
4534 Ent
:= Entity
(Constant_Value
(Ent
));
4537 -- The actual may be a constant that has been folded. Recover
4540 elsif Is_Entity_Name
(Original_Node
(Constant_Value
(Ent
))) then
4541 Ent
:= Entity
(Original_Node
(Constant_Value
(Ent
)));
4548 end Same_Instantiated_Constant
;
4550 --------------------------------
4551 -- Same_Instantiated_Variable --
4552 --------------------------------
4554 function Same_Instantiated_Variable
4555 (E1
, E2
: Entity_Id
) return Boolean
4557 function Original_Entity
(E
: Entity_Id
) return Entity_Id
;
4558 -- Follow chain of renamings to the ultimate ancestor
4560 ---------------------
4561 -- Original_Entity --
4562 ---------------------
4564 function Original_Entity
(E
: Entity_Id
) return Entity_Id
is
4569 while Nkind
(Parent
(Orig
)) = N_Object_Renaming_Declaration
4570 and then Present
(Renamed_Object
(Orig
))
4571 and then Is_Entity_Name
(Renamed_Object
(Orig
))
4573 Orig
:= Entity
(Renamed_Object
(Orig
));
4577 end Original_Entity
;
4579 -- Start of processing for Same_Instantiated_Variable
4582 return Ekind
(E1
) = Ekind
(E2
)
4583 and then Original_Entity
(E1
) = Original_Entity
(E2
);
4584 end Same_Instantiated_Variable
;
4586 -- Start of processing for Check_Formal_Package_Instance
4590 and then Present
(E2
)
4592 exit when Ekind
(E1
) = E_Package
4593 and then Renamed_Entity
(E1
) = Renamed_Entity
(Actual_Pack
);
4595 -- If the formal is the renaming of the formal package, this
4596 -- is the end of its formal part, which may occur before the
4597 -- end of the formal part in the actual in the presence of
4598 -- defaulted parameters in the formal package.
4600 exit when Nkind
(Parent
(E2
)) = N_Package_Renaming_Declaration
4601 and then Renamed_Entity
(E2
) = Scope
(E2
);
4603 -- The analysis of the actual may generate additional internal
4604 -- entities. If the formal is defaulted, there is no corresponding
4605 -- analysis and the internal entities must be skipped, until we
4606 -- find corresponding entities again.
4608 if Comes_From_Source
(E2
)
4609 and then not Comes_From_Source
(E1
)
4610 and then Chars
(E1
) /= Chars
(E2
)
4613 and then Chars
(E1
) /= Chars
(E2
)
4622 -- If the formal entity comes from a formal declaration, it was
4623 -- defaulted in the formal package, and no check is needed on it.
4625 elsif Nkind
(Parent
(E2
)) = N_Formal_Object_Declaration
then
4628 elsif Is_Type
(E1
) then
4630 -- Subtypes must statically match. E1, E2 are the local entities
4631 -- that are subtypes of the actuals. Itypes generated for other
4632 -- parameters need not be checked, the check will be performed
4633 -- on the parameters themselves.
4635 -- If E2 is a formal type declaration, it is a defaulted parameter
4636 -- and needs no checking.
4638 if not Is_Itype
(E1
)
4639 and then not Is_Itype
(E2
)
4643 or else Etype
(E1
) /= Etype
(E2
)
4644 or else not Subtypes_Statically_Match
(E1
, E2
));
4647 elsif Ekind
(E1
) = E_Constant
then
4649 -- IN parameters must denote the same static value, or the same
4650 -- constant, or the literal null.
4652 Expr1
:= Expression
(Parent
(E1
));
4654 if Ekind
(E2
) /= E_Constant
then
4655 Check_Mismatch
(True);
4658 Expr2
:= Expression
(Parent
(E2
));
4661 if Is_Static_Expression
(Expr1
) then
4663 if not Is_Static_Expression
(Expr2
) then
4664 Check_Mismatch
(True);
4666 elsif Is_Discrete_Type
(Etype
(E1
)) then
4668 V1
: constant Uint
:= Expr_Value
(Expr1
);
4669 V2
: constant Uint
:= Expr_Value
(Expr2
);
4671 Check_Mismatch
(V1
/= V2
);
4674 elsif Is_Real_Type
(Etype
(E1
)) then
4676 V1
: constant Ureal
:= Expr_Value_R
(Expr1
);
4677 V2
: constant Ureal
:= Expr_Value_R
(Expr2
);
4679 Check_Mismatch
(V1
/= V2
);
4682 elsif Is_String_Type
(Etype
(E1
))
4683 and then Nkind
(Expr1
) = N_String_Literal
4685 if Nkind
(Expr2
) /= N_String_Literal
then
4686 Check_Mismatch
(True);
4689 (not String_Equal
(Strval
(Expr1
), Strval
(Expr2
)));
4693 elsif Is_Entity_Name
(Expr1
) then
4694 if Is_Entity_Name
(Expr2
) then
4695 if Entity
(Expr1
) = Entity
(Expr2
) then
4699 (not Same_Instantiated_Constant
4700 (Entity
(Expr1
), Entity
(Expr2
)));
4703 Check_Mismatch
(True);
4706 elsif Is_Entity_Name
(Original_Node
(Expr1
))
4707 and then Is_Entity_Name
(Expr2
)
4709 Same_Instantiated_Constant
4710 (Entity
(Original_Node
(Expr1
)), Entity
(Expr2
))
4714 elsif Nkind
(Expr1
) = N_Null
then
4715 Check_Mismatch
(Nkind
(Expr1
) /= N_Null
);
4718 Check_Mismatch
(True);
4721 elsif Ekind
(E1
) = E_Variable
then
4722 Check_Mismatch
(not Same_Instantiated_Variable
(E1
, E2
));
4724 elsif Ekind
(E1
) = E_Package
then
4726 (Ekind
(E1
) /= Ekind
(E2
)
4727 or else Renamed_Object
(E1
) /= Renamed_Object
(E2
));
4729 elsif Is_Overloadable
(E1
) then
4731 -- Verify that the actual subprograms match. Note that actuals
4732 -- that are attributes are rewritten as subprograms. If the
4733 -- subprogram in the formal package is defaulted, no check is
4734 -- needed. Note that this can only happen in Ada 2005 when the
4735 -- formal package can be partially parametrized.
4737 if Nkind
(Unit_Declaration_Node
(E1
)) =
4738 N_Subprogram_Renaming_Declaration
4739 and then From_Default
(Unit_Declaration_Node
(E1
))
4745 (Ekind
(E2
) /= Ekind
(E1
) or else (Alias
(E1
)) /= Alias
(E2
));
4749 raise Program_Error
;
4756 end Check_Formal_Package_Instance
;
4758 ---------------------------
4759 -- Check_Formal_Packages --
4760 ---------------------------
4762 procedure Check_Formal_Packages
(P_Id
: Entity_Id
) is
4764 Formal_P
: Entity_Id
;
4767 -- Iterate through the declarations in the instance, looking for package
4768 -- renaming declarations that denote instances of formal packages. Stop
4769 -- when we find the renaming of the current package itself. The
4770 -- declaration for a formal package without a box is followed by an
4771 -- internal entity that repeats the instantiation.
4773 E
:= First_Entity
(P_Id
);
4774 while Present
(E
) loop
4775 if Ekind
(E
) = E_Package
then
4776 if Renamed_Object
(E
) = P_Id
then
4779 elsif Nkind
(Parent
(E
)) /= N_Package_Renaming_Declaration
then
4782 elsif not Box_Present
(Parent
(Associated_Formal_Package
(E
))) then
4783 Formal_P
:= Next_Entity
(E
);
4784 Check_Formal_Package_Instance
(Formal_P
, E
);
4786 -- After checking, remove the internal validating package. It
4787 -- is only needed for semantic checks, and as it may contain
4788 -- generic formal declarations it should not reach gigi.
4790 Remove
(Unit_Declaration_Node
(Formal_P
));
4796 end Check_Formal_Packages
;
4798 ---------------------------------
4799 -- Check_Forward_Instantiation --
4800 ---------------------------------
4802 procedure Check_Forward_Instantiation
(Decl
: Node_Id
) is
4804 Gen_Comp
: Entity_Id
:= Cunit_Entity
(Get_Source_Unit
(Decl
));
4807 -- The instantiation appears before the generic body if we are in the
4808 -- scope of the unit containing the generic, either in its spec or in
4809 -- the package body, and before the generic body.
4811 if Ekind
(Gen_Comp
) = E_Package_Body
then
4812 Gen_Comp
:= Spec_Entity
(Gen_Comp
);
4815 if In_Open_Scopes
(Gen_Comp
)
4816 and then No
(Corresponding_Body
(Decl
))
4821 and then not Is_Compilation_Unit
(S
)
4822 and then not Is_Child_Unit
(S
)
4824 if Ekind
(S
) = E_Package
then
4825 Set_Has_Forward_Instantiation
(S
);
4831 end Check_Forward_Instantiation
;
4833 ---------------------------
4834 -- Check_Generic_Actuals --
4835 ---------------------------
4837 -- The visibility of the actuals may be different between the point of
4838 -- generic instantiation and the instantiation of the body.
4840 procedure Check_Generic_Actuals
4841 (Instance
: Entity_Id
;
4842 Is_Formal_Box
: Boolean)
4847 function Denotes_Previous_Actual
(Typ
: Entity_Id
) return Boolean;
4848 -- For a formal that is an array type, the component type is often a
4849 -- previous formal in the same unit. The privacy status of the component
4850 -- type will have been examined earlier in the traversal of the
4851 -- corresponding actuals, and this status should not be modified for the
4852 -- array type itself.
4854 -- To detect this case we have to rescan the list of formals, which
4855 -- is usually short enough to ignore the resulting inefficiency.
4857 function Denotes_Previous_Actual
(Typ
: Entity_Id
) return Boolean is
4860 Prev
:= First_Entity
(Instance
);
4861 while Present
(Prev
) loop
4863 and then Nkind
(Parent
(Prev
)) = N_Subtype_Declaration
4864 and then Is_Entity_Name
(Subtype_Indication
(Parent
(Prev
)))
4865 and then Entity
(Subtype_Indication
(Parent
(Prev
))) = Typ
4875 end Denotes_Previous_Actual
;
4877 -- Start of processing for Check_Generic_Actuals
4880 E
:= First_Entity
(Instance
);
4881 while Present
(E
) loop
4883 and then Nkind
(Parent
(E
)) = N_Subtype_Declaration
4884 and then Scope
(Etype
(E
)) /= Instance
4885 and then Is_Entity_Name
(Subtype_Indication
(Parent
(E
)))
4887 if Is_Array_Type
(E
)
4888 and then Denotes_Previous_Actual
(Component_Type
(E
))
4892 Check_Private_View
(Subtype_Indication
(Parent
(E
)));
4894 Set_Is_Generic_Actual_Type
(E
, True);
4895 Set_Is_Hidden
(E
, False);
4896 Set_Is_Potentially_Use_Visible
(E
,
4899 -- We constructed the generic actual type as a subtype of the
4900 -- supplied type. This means that it normally would not inherit
4901 -- subtype specific attributes of the actual, which is wrong for
4902 -- the generic case.
4904 Astype
:= Ancestor_Subtype
(E
);
4908 -- This can happen when E is an itype that is the full view of
4909 -- a private type completed, e.g. with a constrained array. In
4910 -- that case, use the first subtype, which will carry size
4911 -- information. The base type itself is unconstrained and will
4914 Astype
:= First_Subtype
(E
);
4917 Set_Size_Info
(E
, (Astype
));
4918 Set_RM_Size
(E
, RM_Size
(Astype
));
4919 Set_First_Rep_Item
(E
, First_Rep_Item
(Astype
));
4921 if Is_Discrete_Or_Fixed_Point_Type
(E
) then
4922 Set_RM_Size
(E
, RM_Size
(Astype
));
4924 -- In nested instances, the base type of an access actual
4925 -- may itself be private, and need to be exchanged.
4927 elsif Is_Access_Type
(E
)
4928 and then Is_Private_Type
(Etype
(E
))
4931 (New_Occurrence_Of
(Etype
(E
), Sloc
(Instance
)));
4934 elsif Ekind
(E
) = E_Package
then
4936 -- If this is the renaming for the current instance, we're done.
4937 -- Otherwise it is a formal package. If the corresponding formal
4938 -- was declared with a box, the (instantiations of the) generic
4939 -- formal part are also visible. Otherwise, ignore the entity
4940 -- created to validate the actuals.
4942 if Renamed_Object
(E
) = Instance
then
4945 elsif Nkind
(Parent
(E
)) /= N_Package_Renaming_Declaration
then
4948 -- The visibility of a formal of an enclosing generic is already
4951 elsif Denotes_Formal_Package
(E
) then
4954 elsif Present
(Associated_Formal_Package
(E
))
4955 and then not Is_Generic_Formal
(E
)
4957 if Box_Present
(Parent
(Associated_Formal_Package
(E
))) then
4958 Check_Generic_Actuals
(Renamed_Object
(E
), True);
4961 Check_Generic_Actuals
(Renamed_Object
(E
), False);
4964 Set_Is_Hidden
(E
, False);
4967 -- If this is a subprogram instance (in a wrapper package) the
4968 -- actual is fully visible.
4970 elsif Is_Wrapper_Package
(Instance
) then
4971 Set_Is_Hidden
(E
, False);
4973 -- If the formal package is declared with a box, or if the formal
4974 -- parameter is defaulted, it is visible in the body.
4977 or else Is_Visible_Formal
(E
)
4979 Set_Is_Hidden
(E
, False);
4984 end Check_Generic_Actuals
;
4986 ------------------------------
4987 -- Check_Generic_Child_Unit --
4988 ------------------------------
4990 procedure Check_Generic_Child_Unit
4992 Parent_Installed
: in out Boolean)
4994 Loc
: constant Source_Ptr
:= Sloc
(Gen_Id
);
4995 Gen_Par
: Entity_Id
:= Empty
;
4997 Inst_Par
: Entity_Id
;
5000 function Find_Generic_Child
5002 Id
: Node_Id
) return Entity_Id
;
5003 -- Search generic parent for possible child unit with the given name
5005 function In_Enclosing_Instance
return Boolean;
5006 -- Within an instance of the parent, the child unit may be denoted
5007 -- by a simple name, or an abbreviated expanded name. Examine enclosing
5008 -- scopes to locate a possible parent instantiation.
5010 ------------------------
5011 -- Find_Generic_Child --
5012 ------------------------
5014 function Find_Generic_Child
5016 Id
: Node_Id
) return Entity_Id
5021 -- If entity of name is already set, instance has already been
5022 -- resolved, e.g. in an enclosing instantiation.
5024 if Present
(Entity
(Id
)) then
5025 if Scope
(Entity
(Id
)) = Scop
then
5032 E
:= First_Entity
(Scop
);
5033 while Present
(E
) loop
5034 if Chars
(E
) = Chars
(Id
)
5035 and then Is_Child_Unit
(E
)
5037 if Is_Child_Unit
(E
)
5038 and then not Is_Visible_Child_Unit
(E
)
5041 ("generic child unit& is not visible", Gen_Id
, E
);
5053 end Find_Generic_Child
;
5055 ---------------------------
5056 -- In_Enclosing_Instance --
5057 ---------------------------
5059 function In_Enclosing_Instance
return Boolean is
5060 Enclosing_Instance
: Node_Id
;
5061 Instance_Decl
: Node_Id
;
5064 -- We do not inline any call that contains instantiations, except
5065 -- for instantiations of Unchecked_Conversion, so if we are within
5066 -- an inlined body the current instance does not require parents.
5068 if In_Inlined_Body
then
5069 pragma Assert
(Chars
(Gen_Id
) = Name_Unchecked_Conversion
);
5073 -- Loop to check enclosing scopes
5075 Enclosing_Instance
:= Current_Scope
;
5076 while Present
(Enclosing_Instance
) loop
5077 Instance_Decl
:= Unit_Declaration_Node
(Enclosing_Instance
);
5079 if Ekind
(Enclosing_Instance
) = E_Package
5080 and then Is_Generic_Instance
(Enclosing_Instance
)
5082 (Generic_Parent
(Specification
(Instance_Decl
)))
5084 -- Check whether the generic we are looking for is a child of
5087 E
:= Find_Generic_Child
5088 (Generic_Parent
(Specification
(Instance_Decl
)), Gen_Id
);
5089 exit when Present
(E
);
5095 Enclosing_Instance
:= Scope
(Enclosing_Instance
);
5107 Make_Expanded_Name
(Loc
,
5109 Prefix
=> New_Occurrence_Of
(Enclosing_Instance
, Loc
),
5110 Selector_Name
=> New_Occurrence_Of
(E
, Loc
)));
5112 Set_Entity
(Gen_Id
, E
);
5113 Set_Etype
(Gen_Id
, Etype
(E
));
5114 Parent_Installed
:= False; -- Already in scope.
5117 end In_Enclosing_Instance
;
5119 -- Start of processing for Check_Generic_Child_Unit
5122 -- If the name of the generic is given by a selected component, it may
5123 -- be the name of a generic child unit, and the prefix is the name of an
5124 -- instance of the parent, in which case the child unit must be visible.
5125 -- If this instance is not in scope, it must be placed there and removed
5126 -- after instantiation, because what is being instantiated is not the
5127 -- original child, but the corresponding child present in the instance
5130 -- If the child is instantiated within the parent, it can be given by
5131 -- a simple name. In this case the instance is already in scope, but
5132 -- the child generic must be recovered from the generic parent as well.
5134 if Nkind
(Gen_Id
) = N_Selected_Component
then
5135 S
:= Selector_Name
(Gen_Id
);
5136 Analyze
(Prefix
(Gen_Id
));
5137 Inst_Par
:= Entity
(Prefix
(Gen_Id
));
5139 if Ekind
(Inst_Par
) = E_Package
5140 and then Present
(Renamed_Object
(Inst_Par
))
5142 Inst_Par
:= Renamed_Object
(Inst_Par
);
5145 if Ekind
(Inst_Par
) = E_Package
then
5146 if Nkind
(Parent
(Inst_Par
)) = N_Package_Specification
then
5147 Gen_Par
:= Generic_Parent
(Parent
(Inst_Par
));
5149 elsif Nkind
(Parent
(Inst_Par
)) = N_Defining_Program_Unit_Name
5151 Nkind
(Parent
(Parent
(Inst_Par
))) = N_Package_Specification
5153 Gen_Par
:= Generic_Parent
(Parent
(Parent
(Inst_Par
)));
5156 elsif Ekind
(Inst_Par
) = E_Generic_Package
5157 and then Nkind
(Parent
(Gen_Id
)) = N_Formal_Package_Declaration
5159 -- A formal package may be a real child package, and not the
5160 -- implicit instance within a parent. In this case the child is
5161 -- not visible and has to be retrieved explicitly as well.
5163 Gen_Par
:= Inst_Par
;
5166 if Present
(Gen_Par
) then
5168 -- The prefix denotes an instantiation. The entity itself may be a
5169 -- nested generic, or a child unit.
5171 E
:= Find_Generic_Child
(Gen_Par
, S
);
5174 Change_Selected_Component_To_Expanded_Name
(Gen_Id
);
5175 Set_Entity
(Gen_Id
, E
);
5176 Set_Etype
(Gen_Id
, Etype
(E
));
5178 Set_Etype
(S
, Etype
(E
));
5180 -- Indicate that this is a reference to the parent
5182 if In_Extended_Main_Source_Unit
(Gen_Id
) then
5183 Set_Is_Instantiated
(Inst_Par
);
5186 -- A common mistake is to replicate the naming scheme of a
5187 -- hierarchy by instantiating a generic child directly, rather
5188 -- than the implicit child in a parent instance:
5190 -- generic .. package Gpar is ..
5191 -- generic .. package Gpar.Child is ..
5192 -- package Par is new Gpar ();
5195 -- package Par.Child is new Gpar.Child ();
5196 -- rather than Par.Child
5198 -- In this case the instantiation is within Par, which is an
5199 -- instance, but Gpar does not denote Par because we are not IN
5200 -- the instance of Gpar, so this is illegal. The test below
5201 -- recognizes this particular case.
5203 if Is_Child_Unit
(E
)
5204 and then not Comes_From_Source
(Entity
(Prefix
(Gen_Id
)))
5205 and then (not In_Instance
5206 or else Nkind
(Parent
(Parent
(Gen_Id
))) =
5210 ("prefix of generic child unit must be instance of parent",
5214 if not In_Open_Scopes
(Inst_Par
)
5215 and then Nkind
(Parent
(Gen_Id
)) not in
5216 N_Generic_Renaming_Declaration
5218 Install_Parent
(Inst_Par
);
5219 Parent_Installed
:= True;
5221 elsif In_Open_Scopes
(Inst_Par
) then
5223 -- If the parent is already installed verify that the
5224 -- actuals for its formal packages declared with a box
5225 -- are already installed. This is necessary when the
5226 -- child instance is a child of the parent instance.
5227 -- In this case the parent is placed on the scope stack
5228 -- but the formal packages are not made visible.
5230 Install_Formal_Packages
(Inst_Par
);
5234 -- If the generic parent does not contain an entity that
5235 -- corresponds to the selector, the instance doesn't either.
5236 -- Analyzing the node will yield the appropriate error message.
5237 -- If the entity is not a child unit, then it is an inner
5238 -- generic in the parent.
5246 if Is_Child_Unit
(Entity
(Gen_Id
))
5248 Nkind
(Parent
(Gen_Id
)) not in N_Generic_Renaming_Declaration
5249 and then not In_Open_Scopes
(Inst_Par
)
5251 Install_Parent
(Inst_Par
);
5252 Parent_Installed
:= True;
5256 elsif Nkind
(Gen_Id
) = N_Expanded_Name
then
5258 -- Entity already present, analyze prefix, whose meaning may be
5259 -- an instance in the current context. If it is an instance of
5260 -- a relative within another, the proper parent may still have
5261 -- to be installed, if they are not of the same generation.
5263 Analyze
(Prefix
(Gen_Id
));
5265 -- In the unlikely case that a local declaration hides the name
5266 -- of the parent package, locate it on the homonym chain. If the
5267 -- context is an instance of the parent, the renaming entity is
5270 Inst_Par
:= Entity
(Prefix
(Gen_Id
));
5271 while Present
(Inst_Par
)
5272 and then not Is_Package_Or_Generic_Package
(Inst_Par
)
5274 Inst_Par
:= Homonym
(Inst_Par
);
5277 pragma Assert
(Present
(Inst_Par
));
5278 Set_Entity
(Prefix
(Gen_Id
), Inst_Par
);
5280 if In_Enclosing_Instance
then
5283 elsif Present
(Entity
(Gen_Id
))
5284 and then Is_Child_Unit
(Entity
(Gen_Id
))
5285 and then not In_Open_Scopes
(Inst_Par
)
5287 Install_Parent
(Inst_Par
);
5288 Parent_Installed
:= True;
5291 elsif In_Enclosing_Instance
then
5293 -- The child unit is found in some enclosing scope
5300 -- If this is the renaming of the implicit child in a parent
5301 -- instance, recover the parent name and install it.
5303 if Is_Entity_Name
(Gen_Id
) then
5304 E
:= Entity
(Gen_Id
);
5306 if Is_Generic_Unit
(E
)
5307 and then Nkind
(Parent
(E
)) in N_Generic_Renaming_Declaration
5308 and then Is_Child_Unit
(Renamed_Object
(E
))
5309 and then Is_Generic_Unit
(Scope
(Renamed_Object
(E
)))
5310 and then Nkind
(Name
(Parent
(E
))) = N_Expanded_Name
5313 New_Copy_Tree
(Name
(Parent
(E
))));
5314 Inst_Par
:= Entity
(Prefix
(Gen_Id
));
5316 if not In_Open_Scopes
(Inst_Par
) then
5317 Install_Parent
(Inst_Par
);
5318 Parent_Installed
:= True;
5321 -- If it is a child unit of a non-generic parent, it may be
5322 -- use-visible and given by a direct name. Install parent as
5325 elsif Is_Generic_Unit
(E
)
5326 and then Is_Child_Unit
(E
)
5328 Nkind
(Parent
(Gen_Id
)) not in N_Generic_Renaming_Declaration
5329 and then not Is_Generic_Unit
(Scope
(E
))
5331 if not In_Open_Scopes
(Scope
(E
)) then
5332 Install_Parent
(Scope
(E
));
5333 Parent_Installed
:= True;
5338 end Check_Generic_Child_Unit
;
5340 -----------------------------
5341 -- Check_Hidden_Child_Unit --
5342 -----------------------------
5344 procedure Check_Hidden_Child_Unit
5346 Gen_Unit
: Entity_Id
;
5347 Act_Decl_Id
: Entity_Id
)
5349 Gen_Id
: constant Node_Id
:= Name
(N
);
5352 if Is_Child_Unit
(Gen_Unit
)
5353 and then Is_Child_Unit
(Act_Decl_Id
)
5354 and then Nkind
(Gen_Id
) = N_Expanded_Name
5355 and then Entity
(Prefix
(Gen_Id
)) = Scope
(Act_Decl_Id
)
5356 and then Chars
(Gen_Unit
) = Chars
(Act_Decl_Id
)
5358 Error_Msg_Node_2
:= Scope
(Act_Decl_Id
);
5360 ("generic unit & is implicitly declared in &",
5361 Defining_Unit_Name
(N
), Gen_Unit
);
5362 Error_Msg_N
("\instance must have different name",
5363 Defining_Unit_Name
(N
));
5365 end Check_Hidden_Child_Unit
;
5367 ------------------------
5368 -- Check_Private_View --
5369 ------------------------
5371 procedure Check_Private_View
(N
: Node_Id
) is
5372 T
: constant Entity_Id
:= Etype
(N
);
5376 -- Exchange views if the type was not private in the generic but is
5377 -- private at the point of instantiation. Do not exchange views if
5378 -- the scope of the type is in scope. This can happen if both generic
5379 -- and instance are sibling units, or if type is defined in a parent.
5380 -- In this case the visibility of the type will be correct for all
5384 BT
:= Base_Type
(T
);
5386 if Is_Private_Type
(T
)
5387 and then not Has_Private_View
(N
)
5388 and then Present
(Full_View
(T
))
5389 and then not In_Open_Scopes
(Scope
(T
))
5391 -- In the generic, the full type was visible. Save the private
5392 -- entity, for subsequent exchange.
5396 elsif Has_Private_View
(N
)
5397 and then not Is_Private_Type
(T
)
5398 and then not Has_Been_Exchanged
(T
)
5399 and then Etype
(Get_Associated_Node
(N
)) /= T
5401 -- Only the private declaration was visible in the generic. If
5402 -- the type appears in a subtype declaration, the subtype in the
5403 -- instance must have a view compatible with that of its parent,
5404 -- which must be exchanged (see corresponding code in Restore_
5405 -- Private_Views). Otherwise, if the type is defined in a parent
5406 -- unit, leave full visibility within instance, which is safe.
5408 if In_Open_Scopes
(Scope
(Base_Type
(T
)))
5409 and then not Is_Private_Type
(Base_Type
(T
))
5410 and then Comes_From_Source
(Base_Type
(T
))
5414 elsif Nkind
(Parent
(N
)) = N_Subtype_Declaration
5415 or else not In_Private_Part
(Scope
(Base_Type
(T
)))
5417 Prepend_Elmt
(T
, Exchanged_Views
);
5418 Exchange_Declarations
(Etype
(Get_Associated_Node
(N
)));
5421 -- For composite types with inconsistent representation exchange
5422 -- component types accordingly.
5424 elsif Is_Access_Type
(T
)
5425 and then Is_Private_Type
(Designated_Type
(T
))
5426 and then not Has_Private_View
(N
)
5427 and then Present
(Full_View
(Designated_Type
(T
)))
5429 Switch_View
(Designated_Type
(T
));
5431 elsif Is_Array_Type
(T
) then
5432 if Is_Private_Type
(Component_Type
(T
))
5433 and then not Has_Private_View
(N
)
5434 and then Present
(Full_View
(Component_Type
(T
)))
5436 Switch_View
(Component_Type
(T
));
5439 -- The normal exchange mechanism relies on the setting of a
5440 -- flag on the reference in the generic. However, an additional
5441 -- mechanism is needed for types that are not explicitly mentioned
5442 -- in the generic, but may be needed in expanded code in the
5443 -- instance. This includes component types of arrays and
5444 -- designated types of access types. This processing must also
5445 -- include the index types of arrays which we take care of here.
5452 Indx
:= First_Index
(T
);
5453 Typ
:= Base_Type
(Etype
(Indx
));
5454 while Present
(Indx
) loop
5455 if Is_Private_Type
(Typ
)
5456 and then Present
(Full_View
(Typ
))
5465 elsif Is_Private_Type
(T
)
5466 and then Present
(Full_View
(T
))
5467 and then Is_Array_Type
(Full_View
(T
))
5468 and then Is_Private_Type
(Component_Type
(Full_View
(T
)))
5472 -- Finally, a non-private subtype may have a private base type, which
5473 -- must be exchanged for consistency. This can happen when a package
5474 -- body is instantiated, when the scope stack is empty but in fact
5475 -- the subtype and the base type are declared in an enclosing scope.
5477 -- Note that in this case we introduce an inconsistency in the view
5478 -- set, because we switch the base type BT, but there could be some
5479 -- private dependent subtypes of BT which remain unswitched. Such
5480 -- subtypes might need to be switched at a later point (see specific
5481 -- provision for that case in Switch_View).
5483 elsif not Is_Private_Type
(T
)
5484 and then not Has_Private_View
(N
)
5485 and then Is_Private_Type
(BT
)
5486 and then Present
(Full_View
(BT
))
5487 and then not Is_Generic_Type
(BT
)
5488 and then not In_Open_Scopes
(BT
)
5490 Prepend_Elmt
(Full_View
(BT
), Exchanged_Views
);
5491 Exchange_Declarations
(BT
);
5494 end Check_Private_View
;
5496 --------------------------
5497 -- Contains_Instance_Of --
5498 --------------------------
5500 function Contains_Instance_Of
5503 N
: Node_Id
) return Boolean
5511 -- Verify that there are no circular instantiations. We check whether
5512 -- the unit contains an instance of the current scope or some enclosing
5513 -- scope (in case one of the instances appears in a subunit). Longer
5514 -- circularities involving subunits might seem too pathological to
5515 -- consider, but they were not too pathological for the authors of
5516 -- DEC bc30vsq, so we loop over all enclosing scopes, and mark all
5517 -- enclosing generic scopes as containing an instance.
5520 -- Within a generic subprogram body, the scope is not generic, to
5521 -- allow for recursive subprograms. Use the declaration to determine
5522 -- whether this is a generic unit.
5524 if Ekind
(Scop
) = E_Generic_Package
5525 or else (Is_Subprogram
(Scop
)
5526 and then Nkind
(Unit_Declaration_Node
(Scop
)) =
5527 N_Generic_Subprogram_Declaration
)
5529 Elmt
:= First_Elmt
(Inner_Instances
(Inner
));
5531 while Present
(Elmt
) loop
5532 if Node
(Elmt
) = Scop
then
5533 Error_Msg_Node_2
:= Inner
;
5535 ("circular Instantiation: & instantiated within &!",
5539 elsif Node
(Elmt
) = Inner
then
5542 elsif Contains_Instance_Of
(Node
(Elmt
), Scop
, N
) then
5543 Error_Msg_Node_2
:= Inner
;
5545 ("circular Instantiation: & instantiated within &!",
5553 -- Indicate that Inner is being instantiated within Scop
5555 Append_Elmt
(Inner
, Inner_Instances
(Scop
));
5558 if Scop
= Standard_Standard
then
5561 Scop
:= Scope
(Scop
);
5566 end Contains_Instance_Of
;
5568 -----------------------
5569 -- Copy_Generic_Node --
5570 -----------------------
5572 function Copy_Generic_Node
5574 Parent_Id
: Node_Id
;
5575 Instantiating
: Boolean) return Node_Id
5580 function Copy_Generic_Descendant
(D
: Union_Id
) return Union_Id
;
5581 -- Check the given value of one of the Fields referenced by the
5582 -- current node to determine whether to copy it recursively. The
5583 -- field may hold a Node_Id, a List_Id, or an Elist_Id, or a plain
5584 -- value (Sloc, Uint, Char) in which case it need not be copied.
5586 procedure Copy_Descendants
;
5587 -- Common utility for various nodes
5589 function Copy_Generic_Elist
(E
: Elist_Id
) return Elist_Id
;
5590 -- Make copy of element list
5592 function Copy_Generic_List
5594 Parent_Id
: Node_Id
) return List_Id
;
5595 -- Apply Copy_Node recursively to the members of a node list
5597 function In_Defining_Unit_Name
(Nam
: Node_Id
) return Boolean;
5598 -- True if an identifier is part of the defining program unit name
5599 -- of a child unit. The entity of such an identifier must be kept
5600 -- (for ASIS use) even though as the name of an enclosing generic
5601 -- it would otherwise not be preserved in the generic tree.
5603 ----------------------
5604 -- Copy_Descendants --
5605 ----------------------
5607 procedure Copy_Descendants
is
5609 use Atree
.Unchecked_Access
;
5610 -- This code section is part of the implementation of an untyped
5611 -- tree traversal, so it needs direct access to node fields.
5614 Set_Field1
(New_N
, Copy_Generic_Descendant
(Field1
(N
)));
5615 Set_Field2
(New_N
, Copy_Generic_Descendant
(Field2
(N
)));
5616 Set_Field3
(New_N
, Copy_Generic_Descendant
(Field3
(N
)));
5617 Set_Field4
(New_N
, Copy_Generic_Descendant
(Field4
(N
)));
5618 Set_Field5
(New_N
, Copy_Generic_Descendant
(Field5
(N
)));
5619 end Copy_Descendants
;
5621 -----------------------------
5622 -- Copy_Generic_Descendant --
5623 -----------------------------
5625 function Copy_Generic_Descendant
(D
: Union_Id
) return Union_Id
is
5627 if D
= Union_Id
(Empty
) then
5630 elsif D
in Node_Range
then
5632 (Copy_Generic_Node
(Node_Id
(D
), New_N
, Instantiating
));
5634 elsif D
in List_Range
then
5635 return Union_Id
(Copy_Generic_List
(List_Id
(D
), New_N
));
5637 elsif D
in Elist_Range
then
5638 return Union_Id
(Copy_Generic_Elist
(Elist_Id
(D
)));
5640 -- Nothing else is copyable (e.g. Uint values), return as is
5645 end Copy_Generic_Descendant
;
5647 ------------------------
5648 -- Copy_Generic_Elist --
5649 ------------------------
5651 function Copy_Generic_Elist
(E
: Elist_Id
) return Elist_Id
is
5658 M
:= First_Elmt
(E
);
5659 while Present
(M
) loop
5661 (Copy_Generic_Node
(Node
(M
), Empty
, Instantiating
), L
);
5670 end Copy_Generic_Elist
;
5672 -----------------------
5673 -- Copy_Generic_List --
5674 -----------------------
5676 function Copy_Generic_List
5678 Parent_Id
: Node_Id
) return List_Id
5686 Set_Parent
(New_L
, Parent_Id
);
5689 while Present
(N
) loop
5690 Append
(Copy_Generic_Node
(N
, Empty
, Instantiating
), New_L
);
5699 end Copy_Generic_List
;
5701 ---------------------------
5702 -- In_Defining_Unit_Name --
5703 ---------------------------
5705 function In_Defining_Unit_Name
(Nam
: Node_Id
) return Boolean is
5707 return Present
(Parent
(Nam
))
5708 and then (Nkind
(Parent
(Nam
)) = N_Defining_Program_Unit_Name
5710 (Nkind
(Parent
(Nam
)) = N_Expanded_Name
5711 and then In_Defining_Unit_Name
(Parent
(Nam
))));
5712 end In_Defining_Unit_Name
;
5714 -- Start of processing for Copy_Generic_Node
5721 New_N
:= New_Copy
(N
);
5723 if Instantiating
then
5724 Adjust_Instantiation_Sloc
(New_N
, S_Adjustment
);
5727 if not Is_List_Member
(N
) then
5728 Set_Parent
(New_N
, Parent_Id
);
5731 -- If defining identifier, then all fields have been copied already
5733 if Nkind
(New_N
) in N_Entity
then
5736 -- Special casing for identifiers and other entity names and operators
5738 elsif Nkind_In
(New_N
, N_Identifier
,
5739 N_Character_Literal
,
5742 or else Nkind
(New_N
) in N_Op
5744 if not Instantiating
then
5746 -- Link both nodes in order to assign subsequently the entity of
5747 -- the copy to the original node, in case this is a global
5750 Set_Associated_Node
(N
, New_N
);
5752 -- If we are within an instantiation, this is a nested generic
5753 -- that has already been analyzed at the point of definition. We
5754 -- must preserve references that were global to the enclosing
5755 -- parent at that point. Other occurrences, whether global or
5756 -- local to the current generic, must be resolved anew, so we
5757 -- reset the entity in the generic copy. A global reference has a
5758 -- smaller depth than the parent, or else the same depth in case
5759 -- both are distinct compilation units.
5760 -- A child unit is implicitly declared within the enclosing parent
5761 -- but is in fact global to it, and must be preserved.
5763 -- It is also possible for Current_Instantiated_Parent to be
5764 -- defined, and for this not to be a nested generic, namely if the
5765 -- unit is loaded through Rtsfind. In that case, the entity of
5766 -- New_N is only a link to the associated node, and not a defining
5769 -- The entities for parent units in the defining_program_unit of a
5770 -- generic child unit are established when the context of the unit
5771 -- is first analyzed, before the generic copy is made. They are
5772 -- preserved in the copy for use in ASIS queries.
5774 Ent
:= Entity
(New_N
);
5776 if No
(Current_Instantiated_Parent
.Gen_Id
) then
5778 or else Nkind
(Ent
) /= N_Defining_Identifier
5779 or else not In_Defining_Unit_Name
(N
)
5781 Set_Associated_Node
(New_N
, Empty
);
5786 not Nkind_In
(Ent
, N_Defining_Identifier
,
5787 N_Defining_Character_Literal
,
5788 N_Defining_Operator_Symbol
)
5789 or else No
(Scope
(Ent
))
5791 (Scope
(Ent
) = Current_Instantiated_Parent
.Gen_Id
5792 and then not Is_Child_Unit
(Ent
))
5794 (Scope_Depth
(Scope
(Ent
)) >
5795 Scope_Depth
(Current_Instantiated_Parent
.Gen_Id
)
5797 Get_Source_Unit
(Ent
) =
5798 Get_Source_Unit
(Current_Instantiated_Parent
.Gen_Id
))
5800 Set_Associated_Node
(New_N
, Empty
);
5803 -- Case of instantiating identifier or some other name or operator
5806 -- If the associated node is still defined, the entity in it is
5807 -- global, and must be copied to the instance. If this copy is
5808 -- being made for a body to inline, it is applied to an
5809 -- instantiated tree, and the entity is already present and must
5810 -- be also preserved.
5813 Assoc
: constant Node_Id
:= Get_Associated_Node
(N
);
5816 if Present
(Assoc
) then
5817 if Nkind
(Assoc
) = Nkind
(N
) then
5818 Set_Entity
(New_N
, Entity
(Assoc
));
5819 Check_Private_View
(N
);
5821 elsif Nkind
(Assoc
) = N_Function_Call
then
5822 Set_Entity
(New_N
, Entity
(Name
(Assoc
)));
5824 elsif Nkind_In
(Assoc
, N_Defining_Identifier
,
5825 N_Defining_Character_Literal
,
5826 N_Defining_Operator_Symbol
)
5827 and then Expander_Active
5829 -- Inlining case: we are copying a tree that contains
5830 -- global entities, which are preserved in the copy to be
5831 -- used for subsequent inlining.
5836 Set_Entity
(New_N
, Empty
);
5842 -- For expanded name, we must copy the Prefix and Selector_Name
5844 if Nkind
(N
) = N_Expanded_Name
then
5846 (New_N
, Copy_Generic_Node
(Prefix
(N
), New_N
, Instantiating
));
5848 Set_Selector_Name
(New_N
,
5849 Copy_Generic_Node
(Selector_Name
(N
), New_N
, Instantiating
));
5851 -- For operators, we must copy the right operand
5853 elsif Nkind
(N
) in N_Op
then
5854 Set_Right_Opnd
(New_N
,
5855 Copy_Generic_Node
(Right_Opnd
(N
), New_N
, Instantiating
));
5857 -- And for binary operators, the left operand as well
5859 if Nkind
(N
) in N_Binary_Op
then
5860 Set_Left_Opnd
(New_N
,
5861 Copy_Generic_Node
(Left_Opnd
(N
), New_N
, Instantiating
));
5865 -- Special casing for stubs
5867 elsif Nkind
(N
) in N_Body_Stub
then
5869 -- In any case, we must copy the specification or defining
5870 -- identifier as appropriate.
5872 if Nkind
(N
) = N_Subprogram_Body_Stub
then
5873 Set_Specification
(New_N
,
5874 Copy_Generic_Node
(Specification
(N
), New_N
, Instantiating
));
5877 Set_Defining_Identifier
(New_N
,
5879 (Defining_Identifier
(N
), New_N
, Instantiating
));
5882 -- If we are not instantiating, then this is where we load and
5883 -- analyze subunits, i.e. at the point where the stub occurs. A
5884 -- more permissible system might defer this analysis to the point
5885 -- of instantiation, but this seems to complicated for now.
5887 if not Instantiating
then
5889 Subunit_Name
: constant Unit_Name_Type
:= Get_Unit_Name
(N
);
5891 Unum
: Unit_Number_Type
;
5897 (Load_Name
=> Subunit_Name
,
5902 -- If the proper body is not found, a warning message will be
5903 -- emitted when analyzing the stub, or later at the point
5904 -- of instantiation. Here we just leave the stub as is.
5906 if Unum
= No_Unit
then
5907 Subunits_Missing
:= True;
5908 goto Subunit_Not_Found
;
5911 Subunit
:= Cunit
(Unum
);
5913 if Nkind
(Unit
(Subunit
)) /= N_Subunit
then
5915 ("found child unit instead of expected SEPARATE subunit",
5917 Error_Msg_Sloc
:= Sloc
(N
);
5918 Error_Msg_N
("\to complete stub #", Subunit
);
5919 goto Subunit_Not_Found
;
5922 -- We must create a generic copy of the subunit, in order to
5923 -- perform semantic analysis on it, and we must replace the
5924 -- stub in the original generic unit with the subunit, in order
5925 -- to preserve non-local references within.
5927 -- Only the proper body needs to be copied. Library_Unit and
5928 -- context clause are simply inherited by the generic copy.
5929 -- Note that the copy (which may be recursive if there are
5930 -- nested subunits) must be done first, before attaching it to
5931 -- the enclosing generic.
5935 (Proper_Body
(Unit
(Subunit
)),
5936 Empty
, Instantiating
=> False);
5938 -- Now place the original proper body in the original generic
5939 -- unit. This is a body, not a compilation unit.
5941 Rewrite
(N
, Proper_Body
(Unit
(Subunit
)));
5942 Set_Is_Compilation_Unit
(Defining_Entity
(N
), False);
5943 Set_Was_Originally_Stub
(N
);
5945 -- Finally replace the body of the subunit with its copy, and
5946 -- make this new subunit into the library unit of the generic
5947 -- copy, which does not have stubs any longer.
5949 Set_Proper_Body
(Unit
(Subunit
), New_Body
);
5950 Set_Library_Unit
(New_N
, Subunit
);
5951 Inherit_Context
(Unit
(Subunit
), N
);
5954 -- If we are instantiating, this must be an error case, since
5955 -- otherwise we would have replaced the stub node by the proper body
5956 -- that corresponds. So just ignore it in the copy (i.e. we have
5957 -- copied it, and that is good enough).
5963 <<Subunit_Not_Found
>> null;
5965 -- If the node is a compilation unit, it is the subunit of a stub, which
5966 -- has been loaded already (see code below). In this case, the library
5967 -- unit field of N points to the parent unit (which is a compilation
5968 -- unit) and need not (and cannot!) be copied.
5970 -- When the proper body of the stub is analyzed, the library_unit link
5971 -- is used to establish the proper context (see sem_ch10).
5973 -- The other fields of a compilation unit are copied as usual
5975 elsif Nkind
(N
) = N_Compilation_Unit
then
5977 -- This code can only be executed when not instantiating, because in
5978 -- the copy made for an instantiation, the compilation unit node has
5979 -- disappeared at the point that a stub is replaced by its proper
5982 pragma Assert
(not Instantiating
);
5984 Set_Context_Items
(New_N
,
5985 Copy_Generic_List
(Context_Items
(N
), New_N
));
5988 Copy_Generic_Node
(Unit
(N
), New_N
, False));
5990 Set_First_Inlined_Subprogram
(New_N
,
5992 (First_Inlined_Subprogram
(N
), New_N
, False));
5994 Set_Aux_Decls_Node
(New_N
,
5995 Copy_Generic_Node
(Aux_Decls_Node
(N
), New_N
, False));
5997 -- For an assignment node, the assignment is known to be semantically
5998 -- legal if we are instantiating the template. This avoids incorrect
5999 -- diagnostics in generated code.
6001 elsif Nkind
(N
) = N_Assignment_Statement
then
6003 -- Copy name and expression fields in usual manner
6006 Copy_Generic_Node
(Name
(N
), New_N
, Instantiating
));
6008 Set_Expression
(New_N
,
6009 Copy_Generic_Node
(Expression
(N
), New_N
, Instantiating
));
6011 if Instantiating
then
6012 Set_Assignment_OK
(Name
(New_N
), True);
6015 elsif Nkind_In
(N
, N_Aggregate
, N_Extension_Aggregate
) then
6016 if not Instantiating
then
6017 Set_Associated_Node
(N
, New_N
);
6020 if Present
(Get_Associated_Node
(N
))
6021 and then Nkind
(Get_Associated_Node
(N
)) = Nkind
(N
)
6023 -- In the generic the aggregate has some composite type. If at
6024 -- the point of instantiation the type has a private view,
6025 -- install the full view (and that of its ancestors, if any).
6028 T
: Entity_Id
:= (Etype
(Get_Associated_Node
(New_N
)));
6033 and then Is_Private_Type
(T
)
6039 and then Is_Tagged_Type
(T
)
6040 and then Is_Derived_Type
(T
)
6042 Rt
:= Root_Type
(T
);
6047 if Is_Private_Type
(T
) then
6058 -- Do not copy the associated node, which points to
6059 -- the generic copy of the aggregate.
6062 use Atree
.Unchecked_Access
;
6063 -- This code section is part of the implementation of an untyped
6064 -- tree traversal, so it needs direct access to node fields.
6067 Set_Field1
(New_N
, Copy_Generic_Descendant
(Field1
(N
)));
6068 Set_Field2
(New_N
, Copy_Generic_Descendant
(Field2
(N
)));
6069 Set_Field3
(New_N
, Copy_Generic_Descendant
(Field3
(N
)));
6070 Set_Field5
(New_N
, Copy_Generic_Descendant
(Field5
(N
)));
6073 -- Allocators do not have an identifier denoting the access type,
6074 -- so we must locate it through the expression to check whether
6075 -- the views are consistent.
6077 elsif Nkind
(N
) = N_Allocator
6078 and then Nkind
(Expression
(N
)) = N_Qualified_Expression
6079 and then Is_Entity_Name
(Subtype_Mark
(Expression
(N
)))
6080 and then Instantiating
6083 T
: constant Node_Id
:=
6084 Get_Associated_Node
(Subtype_Mark
(Expression
(N
)));
6090 -- Retrieve the allocator node in the generic copy
6092 Acc_T
:= Etype
(Parent
(Parent
(T
)));
6094 and then Is_Private_Type
(Acc_T
)
6096 Switch_View
(Acc_T
);
6103 -- For a proper body, we must catch the case of a proper body that
6104 -- replaces a stub. This represents the point at which a separate
6105 -- compilation unit, and hence template file, may be referenced, so we
6106 -- must make a new source instantiation entry for the template of the
6107 -- subunit, and ensure that all nodes in the subunit are adjusted using
6108 -- this new source instantiation entry.
6110 elsif Nkind
(N
) in N_Proper_Body
then
6112 Save_Adjustment
: constant Sloc_Adjustment
:= S_Adjustment
;
6115 if Instantiating
and then Was_Originally_Stub
(N
) then
6116 Create_Instantiation_Source
6117 (Instantiation_Node
,
6118 Defining_Entity
(N
),
6123 -- Now copy the fields of the proper body, using the new
6124 -- adjustment factor if one was needed as per test above.
6128 -- Restore the original adjustment factor in case changed
6130 S_Adjustment
:= Save_Adjustment
;
6133 -- Don't copy Ident or Comment pragmas, since the comment belongs to the
6134 -- generic unit, not to the instantiating unit.
6136 elsif Nkind
(N
) = N_Pragma
6137 and then Instantiating
6140 Prag_Id
: constant Pragma_Id
:= Get_Pragma_Id
(N
);
6142 if Prag_Id
= Pragma_Ident
6143 or else Prag_Id
= Pragma_Comment
6145 New_N
:= Make_Null_Statement
(Sloc
(N
));
6151 elsif Nkind_In
(N
, N_Integer_Literal
,
6155 -- No descendant fields need traversing
6159 -- For the remaining nodes, copy recursively their descendants
6165 and then Nkind
(N
) = N_Subprogram_Body
6167 Set_Generic_Parent
(Specification
(New_N
), N
);
6172 end Copy_Generic_Node
;
6174 ----------------------------
6175 -- Denotes_Formal_Package --
6176 ----------------------------
6178 function Denotes_Formal_Package
6180 On_Exit
: Boolean := False;
6181 Instance
: Entity_Id
:= Empty
) return Boolean
6184 Scop
: constant Entity_Id
:= Scope
(Pack
);
6187 function Is_Actual_Of_Previous_Formal
(P
: Entity_Id
) return Boolean;
6188 -- The package in question may be an actual for a previous formal
6189 -- package P of the current instance, so examine its actuals as well.
6190 -- This must be recursive over other formal packages.
6192 ----------------------------------
6193 -- Is_Actual_Of_Previous_Formal --
6194 ----------------------------------
6196 function Is_Actual_Of_Previous_Formal
(P
: Entity_Id
) return Boolean is
6200 E1
:= First_Entity
(P
);
6201 while Present
(E1
) and then E1
/= Instance
loop
6202 if Ekind
(E1
) = E_Package
6203 and then Nkind
(Parent
(E1
)) = N_Package_Renaming_Declaration
6205 if Renamed_Object
(E1
) = Pack
then
6209 or else Renamed_Object
(E1
) = P
6213 elsif Is_Actual_Of_Previous_Formal
(E1
) then
6222 end Is_Actual_Of_Previous_Formal
;
6224 -- Start of processing for Denotes_Formal_Package
6230 (Instance_Envs
.Last
).Instantiated_Parent
.Act_Id
;
6232 Par
:= Current_Instantiated_Parent
.Act_Id
;
6235 if Ekind
(Scop
) = E_Generic_Package
6236 or else Nkind
(Unit_Declaration_Node
(Scop
)) =
6237 N_Generic_Subprogram_Declaration
6241 elsif Nkind
(Original_Node
(Unit_Declaration_Node
(Pack
))) =
6242 N_Formal_Package_Declaration
6250 -- Check whether this package is associated with a formal package of
6251 -- the enclosing instantiation. Iterate over the list of renamings.
6253 E
:= First_Entity
(Par
);
6254 while Present
(E
) loop
6255 if Ekind
(E
) /= E_Package
6256 or else Nkind
(Parent
(E
)) /= N_Package_Renaming_Declaration
6260 elsif Renamed_Object
(E
) = Par
then
6263 elsif Renamed_Object
(E
) = Pack
then
6266 elsif Is_Actual_Of_Previous_Formal
(E
) then
6276 end Denotes_Formal_Package
;
6282 procedure End_Generic
is
6284 -- ??? More things could be factored out in this routine. Should
6285 -- probably be done at a later stage.
6287 Inside_A_Generic
:= Generic_Flags
.Table
(Generic_Flags
.Last
);
6288 Generic_Flags
.Decrement_Last
;
6290 Expander_Mode_Restore
;
6293 ----------------------
6294 -- Find_Actual_Type --
6295 ----------------------
6297 function Find_Actual_Type
6299 Gen_Type
: Entity_Id
) return Entity_Id
6301 Gen_Scope
: constant Entity_Id
:= Scope
(Gen_Type
);
6305 -- Special processing only applies to child units
6307 if not Is_Child_Unit
(Gen_Scope
) then
6308 return Get_Instance_Of
(Typ
);
6310 -- If designated or component type is itself a formal of the child unit,
6311 -- its instance is available.
6313 elsif Scope
(Typ
) = Gen_Scope
then
6314 return Get_Instance_Of
(Typ
);
6316 -- If the array or access type is not declared in the parent unit,
6317 -- no special processing needed.
6319 elsif not Is_Generic_Type
(Typ
)
6320 and then Scope
(Gen_Scope
) /= Scope
(Typ
)
6322 return Get_Instance_Of
(Typ
);
6324 -- Otherwise, retrieve designated or component type by visibility
6327 T
:= Current_Entity
(Typ
);
6328 while Present
(T
) loop
6329 if In_Open_Scopes
(Scope
(T
)) then
6332 elsif Is_Generic_Actual_Type
(T
) then
6341 end Find_Actual_Type
;
6343 ----------------------------
6344 -- Freeze_Subprogram_Body --
6345 ----------------------------
6347 procedure Freeze_Subprogram_Body
6348 (Inst_Node
: Node_Id
;
6350 Pack_Id
: Entity_Id
)
6353 Gen_Unit
: constant Entity_Id
:= Get_Generic_Entity
(Inst_Node
);
6354 Par
: constant Entity_Id
:= Scope
(Gen_Unit
);
6359 function Earlier
(N1
, N2
: Node_Id
) return Boolean;
6360 -- Yields True if N1 and N2 appear in the same compilation unit,
6361 -- ignoring subunits, and if N1 is to the left of N2 in a left-to-right
6362 -- traversal of the tree for the unit.
6364 function Enclosing_Body
(N
: Node_Id
) return Node_Id
;
6365 -- Find innermost package body that encloses the given node, and which
6366 -- is not a compilation unit. Freeze nodes for the instance, or for its
6367 -- enclosing body, may be inserted after the enclosing_body of the
6370 function Package_Freeze_Node
(B
: Node_Id
) return Node_Id
;
6371 -- Find entity for given package body, and locate or create a freeze
6374 function True_Parent
(N
: Node_Id
) return Node_Id
;
6375 -- For a subunit, return parent of corresponding stub
6381 function Earlier
(N1
, N2
: Node_Id
) return Boolean is
6387 procedure Find_Depth
(P
: in out Node_Id
; D
: in out Integer);
6388 -- Find distance from given node to enclosing compilation unit
6394 procedure Find_Depth
(P
: in out Node_Id
; D
: in out Integer) is
6397 and then Nkind
(P
) /= N_Compilation_Unit
6399 P
:= True_Parent
(P
);
6404 -- Start of processing for Earlier
6407 Find_Depth
(P1
, D1
);
6408 Find_Depth
(P2
, D2
);
6418 P1
:= True_Parent
(P1
);
6423 P2
:= True_Parent
(P2
);
6427 -- At this point P1 and P2 are at the same distance from the root.
6428 -- We examine their parents until we find a common declarative
6429 -- list, at which point we can establish their relative placement
6430 -- by comparing their ultimate slocs. If we reach the root,
6431 -- N1 and N2 do not descend from the same declarative list (e.g.
6432 -- one is nested in the declarative part and the other is in a block
6433 -- in the statement part) and the earlier one is already frozen.
6435 while not Is_List_Member
(P1
)
6436 or else not Is_List_Member
(P2
)
6437 or else List_Containing
(P1
) /= List_Containing
(P2
)
6439 P1
:= True_Parent
(P1
);
6440 P2
:= True_Parent
(P2
);
6442 if Nkind
(Parent
(P1
)) = N_Subunit
then
6443 P1
:= Corresponding_Stub
(Parent
(P1
));
6446 if Nkind
(Parent
(P2
)) = N_Subunit
then
6447 P2
:= Corresponding_Stub
(Parent
(P2
));
6456 Top_Level_Location
(Sloc
(P1
)) < Top_Level_Location
(Sloc
(P2
));
6459 --------------------
6460 -- Enclosing_Body --
6461 --------------------
6463 function Enclosing_Body
(N
: Node_Id
) return Node_Id
is
6464 P
: Node_Id
:= Parent
(N
);
6468 and then Nkind
(Parent
(P
)) /= N_Compilation_Unit
6470 if Nkind
(P
) = N_Package_Body
then
6472 if Nkind
(Parent
(P
)) = N_Subunit
then
6473 return Corresponding_Stub
(Parent
(P
));
6479 P
:= True_Parent
(P
);
6485 -------------------------
6486 -- Package_Freeze_Node --
6487 -------------------------
6489 function Package_Freeze_Node
(B
: Node_Id
) return Node_Id
is
6493 if Nkind
(B
) = N_Package_Body
then
6494 Id
:= Corresponding_Spec
(B
);
6496 else pragma Assert
(Nkind
(B
) = N_Package_Body_Stub
);
6497 Id
:= Corresponding_Spec
(Proper_Body
(Unit
(Library_Unit
(B
))));
6500 Ensure_Freeze_Node
(Id
);
6501 return Freeze_Node
(Id
);
6502 end Package_Freeze_Node
;
6508 function True_Parent
(N
: Node_Id
) return Node_Id
is
6510 if Nkind
(Parent
(N
)) = N_Subunit
then
6511 return Parent
(Corresponding_Stub
(Parent
(N
)));
6517 -- Start of processing of Freeze_Subprogram_Body
6520 -- If the instance and the generic body appear within the same unit, and
6521 -- the instance precedes the generic, the freeze node for the instance
6522 -- must appear after that of the generic. If the generic is nested
6523 -- within another instance I2, then current instance must be frozen
6524 -- after I2. In both cases, the freeze nodes are those of enclosing
6525 -- packages. Otherwise, the freeze node is placed at the end of the
6526 -- current declarative part.
6528 Enc_G
:= Enclosing_Body
(Gen_Body
);
6529 Enc_I
:= Enclosing_Body
(Inst_Node
);
6530 Ensure_Freeze_Node
(Pack_Id
);
6531 F_Node
:= Freeze_Node
(Pack_Id
);
6533 if Is_Generic_Instance
(Par
)
6534 and then Present
(Freeze_Node
(Par
))
6536 In_Same_Declarative_Part
(Freeze_Node
(Par
), Inst_Node
)
6538 if ABE_Is_Certain
(Get_Package_Instantiation_Node
(Par
)) then
6540 -- The parent was a premature instantiation. Insert freeze node at
6541 -- the end the current declarative part.
6543 Insert_After_Last_Decl
(Inst_Node
, F_Node
);
6546 Insert_After
(Freeze_Node
(Par
), F_Node
);
6549 -- The body enclosing the instance should be frozen after the body that
6550 -- includes the generic, because the body of the instance may make
6551 -- references to entities therein. If the two are not in the same
6552 -- declarative part, or if the one enclosing the instance is frozen
6553 -- already, freeze the instance at the end of the current declarative
6556 elsif Is_Generic_Instance
(Par
)
6557 and then Present
(Freeze_Node
(Par
))
6558 and then Present
(Enc_I
)
6560 if In_Same_Declarative_Part
(Freeze_Node
(Par
), Enc_I
)
6562 (Nkind
(Enc_I
) = N_Package_Body
6564 In_Same_Declarative_Part
(Freeze_Node
(Par
), Parent
(Enc_I
)))
6566 -- The enclosing package may contain several instances. Rather
6567 -- than computing the earliest point at which to insert its
6568 -- freeze node, we place it at the end of the declarative part
6569 -- of the parent of the generic.
6571 Insert_After_Last_Decl
6572 (Freeze_Node
(Par
), Package_Freeze_Node
(Enc_I
));
6575 Insert_After_Last_Decl
(Inst_Node
, F_Node
);
6577 elsif Present
(Enc_G
)
6578 and then Present
(Enc_I
)
6579 and then Enc_G
/= Enc_I
6580 and then Earlier
(Inst_Node
, Gen_Body
)
6582 if Nkind
(Enc_G
) = N_Package_Body
then
6583 E_G_Id
:= Corresponding_Spec
(Enc_G
);
6584 else pragma Assert
(Nkind
(Enc_G
) = N_Package_Body_Stub
);
6586 Corresponding_Spec
(Proper_Body
(Unit
(Library_Unit
(Enc_G
))));
6589 -- Freeze package that encloses instance, and place node after
6590 -- package that encloses generic. If enclosing package is already
6591 -- frozen we have to assume it is at the proper place. This may be
6592 -- a potential ABE that requires dynamic checking. Do not add a
6593 -- freeze node if the package that encloses the generic is inside
6594 -- the body that encloses the instance, because the freeze node
6595 -- would be in the wrong scope. Additional contortions needed if
6596 -- the bodies are within a subunit.
6599 Enclosing_Body
: Node_Id
;
6602 if Nkind
(Enc_I
) = N_Package_Body_Stub
then
6603 Enclosing_Body
:= Proper_Body
(Unit
(Library_Unit
(Enc_I
)));
6605 Enclosing_Body
:= Enc_I
;
6608 if Parent
(List_Containing
(Enc_G
)) /= Enclosing_Body
then
6609 Insert_After_Last_Decl
(Enc_G
, Package_Freeze_Node
(Enc_I
));
6613 -- Freeze enclosing subunit before instance
6615 Ensure_Freeze_Node
(E_G_Id
);
6617 if not Is_List_Member
(Freeze_Node
(E_G_Id
)) then
6618 Insert_After
(Enc_G
, Freeze_Node
(E_G_Id
));
6621 Insert_After_Last_Decl
(Inst_Node
, F_Node
);
6624 -- If none of the above, insert freeze node at the end of the current
6625 -- declarative part.
6627 Insert_After_Last_Decl
(Inst_Node
, F_Node
);
6629 end Freeze_Subprogram_Body
;
6635 function Get_Gen_Id
(E
: Assoc_Ptr
) return Entity_Id
is
6637 return Generic_Renamings
.Table
(E
).Gen_Id
;
6640 ---------------------
6641 -- Get_Instance_Of --
6642 ---------------------
6644 function Get_Instance_Of
(A
: Entity_Id
) return Entity_Id
is
6645 Res
: constant Assoc_Ptr
:= Generic_Renamings_HTable
.Get
(A
);
6648 if Res
/= Assoc_Null
then
6649 return Generic_Renamings
.Table
(Res
).Act_Id
;
6651 -- On exit, entity is not instantiated: not a generic parameter, or
6652 -- else parameter of an inner generic unit.
6656 end Get_Instance_Of
;
6658 ------------------------------------
6659 -- Get_Package_Instantiation_Node --
6660 ------------------------------------
6662 function Get_Package_Instantiation_Node
(A
: Entity_Id
) return Node_Id
is
6663 Decl
: Node_Id
:= Unit_Declaration_Node
(A
);
6667 -- If the Package_Instantiation attribute has been set on the package
6668 -- entity, then use it directly when it (or its Original_Node) refers
6669 -- to an N_Package_Instantiation node. In principle it should be
6670 -- possible to have this field set in all cases, which should be
6671 -- investigated, and would allow this function to be significantly
6674 if Present
(Package_Instantiation
(A
)) then
6675 if Nkind
(Package_Instantiation
(A
)) = N_Package_Instantiation
then
6676 return Package_Instantiation
(A
);
6678 elsif Nkind
(Original_Node
(Package_Instantiation
(A
))) =
6679 N_Package_Instantiation
6681 return Original_Node
(Package_Instantiation
(A
));
6685 -- If the instantiation is a compilation unit that does not need body
6686 -- then the instantiation node has been rewritten as a package
6687 -- declaration for the instance, and we return the original node.
6689 -- If it is a compilation unit and the instance node has not been
6690 -- rewritten, then it is still the unit of the compilation. Finally, if
6691 -- a body is present, this is a parent of the main unit whose body has
6692 -- been compiled for inlining purposes, and the instantiation node has
6693 -- been rewritten with the instance body.
6695 -- Otherwise the instantiation node appears after the declaration. If
6696 -- the entity is a formal package, the declaration may have been
6697 -- rewritten as a generic declaration (in the case of a formal with box)
6698 -- or left as a formal package declaration if it has actuals, and is
6699 -- found with a forward search.
6701 if Nkind
(Parent
(Decl
)) = N_Compilation_Unit
then
6702 if Nkind
(Decl
) = N_Package_Declaration
6703 and then Present
(Corresponding_Body
(Decl
))
6705 Decl
:= Unit_Declaration_Node
(Corresponding_Body
(Decl
));
6708 if Nkind
(Original_Node
(Decl
)) = N_Package_Instantiation
then
6709 return Original_Node
(Decl
);
6711 return Unit
(Parent
(Decl
));
6714 elsif Nkind
(Decl
) = N_Package_Declaration
6715 and then Nkind
(Original_Node
(Decl
)) = N_Formal_Package_Declaration
6717 return Original_Node
(Decl
);
6720 Inst
:= Next
(Decl
);
6721 while not Nkind_In
(Inst
, N_Package_Instantiation
,
6722 N_Formal_Package_Declaration
)
6729 end Get_Package_Instantiation_Node
;
6731 ------------------------
6732 -- Has_Been_Exchanged --
6733 ------------------------
6735 function Has_Been_Exchanged
(E
: Entity_Id
) return Boolean is
6739 Next
:= First_Elmt
(Exchanged_Views
);
6740 while Present
(Next
) loop
6741 if Full_View
(Node
(Next
)) = E
then
6749 end Has_Been_Exchanged
;
6755 function Hash
(F
: Entity_Id
) return HTable_Range
is
6757 return HTable_Range
(F
mod HTable_Size
);
6760 ------------------------
6761 -- Hide_Current_Scope --
6762 ------------------------
6764 procedure Hide_Current_Scope
is
6765 C
: constant Entity_Id
:= Current_Scope
;
6769 Set_Is_Hidden_Open_Scope
(C
);
6771 E
:= First_Entity
(C
);
6772 while Present
(E
) loop
6773 if Is_Immediately_Visible
(E
) then
6774 Set_Is_Immediately_Visible
(E
, False);
6775 Append_Elmt
(E
, Hidden_Entities
);
6781 -- Make the scope name invisible as well. This is necessary, but might
6782 -- conflict with calls to Rtsfind later on, in case the scope is a
6783 -- predefined one. There is no clean solution to this problem, so for
6784 -- now we depend on the user not redefining Standard itself in one of
6785 -- the parent units.
6787 if Is_Immediately_Visible
(C
)
6788 and then C
/= Standard_Standard
6790 Set_Is_Immediately_Visible
(C
, False);
6791 Append_Elmt
(C
, Hidden_Entities
);
6794 end Hide_Current_Scope
;
6800 procedure Init_Env
is
6801 Saved
: Instance_Env
;
6804 Saved
.Instantiated_Parent
:= Current_Instantiated_Parent
;
6805 Saved
.Exchanged_Views
:= Exchanged_Views
;
6806 Saved
.Hidden_Entities
:= Hidden_Entities
;
6807 Saved
.Current_Sem_Unit
:= Current_Sem_Unit
;
6808 Saved
.Parent_Unit_Visible
:= Parent_Unit_Visible
;
6809 Saved
.Instance_Parent_Unit
:= Instance_Parent_Unit
;
6811 -- Save configuration switches. These may be reset if the unit is a
6812 -- predefined unit, and the current mode is not Ada 2005.
6814 Save_Opt_Config_Switches
(Saved
.Switches
);
6816 Instance_Envs
.Append
(Saved
);
6818 Exchanged_Views
:= New_Elmt_List
;
6819 Hidden_Entities
:= New_Elmt_List
;
6821 -- Make dummy entry for Instantiated parent. If generic unit is legal,
6822 -- this is set properly in Set_Instance_Env.
6824 Current_Instantiated_Parent
:=
6825 (Current_Scope
, Current_Scope
, Assoc_Null
);
6828 ------------------------------
6829 -- In_Same_Declarative_Part --
6830 ------------------------------
6832 function In_Same_Declarative_Part
6834 Inst
: Node_Id
) return Boolean
6836 Decls
: constant Node_Id
:= Parent
(F_Node
);
6837 Nod
: Node_Id
:= Parent
(Inst
);
6840 while Present
(Nod
) loop
6844 elsif Nkind_In
(Nod
, N_Subprogram_Body
,
6852 elsif Nkind
(Nod
) = N_Subunit
then
6853 Nod
:= Corresponding_Stub
(Nod
);
6855 elsif Nkind
(Nod
) = N_Compilation_Unit
then
6859 Nod
:= Parent
(Nod
);
6864 end In_Same_Declarative_Part
;
6866 ---------------------
6867 -- In_Main_Context --
6868 ---------------------
6870 function In_Main_Context
(E
: Entity_Id
) return Boolean is
6876 if not Is_Compilation_Unit
(E
)
6877 or else Ekind
(E
) /= E_Package
6878 or else In_Private_Part
(E
)
6883 Context
:= Context_Items
(Cunit
(Main_Unit
));
6885 Clause
:= First
(Context
);
6886 while Present
(Clause
) loop
6887 if Nkind
(Clause
) = N_With_Clause
then
6888 Nam
:= Name
(Clause
);
6890 -- If the current scope is part of the context of the main unit,
6891 -- analysis of the corresponding with_clause is not complete, and
6892 -- the entity is not set. We use the Chars field directly, which
6893 -- might produce false positives in rare cases, but guarantees
6894 -- that we produce all the instance bodies we will need.
6896 if (Is_Entity_Name
(Nam
)
6897 and then Chars
(Nam
) = Chars
(E
))
6898 or else (Nkind
(Nam
) = N_Selected_Component
6899 and then Chars
(Selector_Name
(Nam
)) = Chars
(E
))
6909 end In_Main_Context
;
6911 ---------------------
6912 -- Inherit_Context --
6913 ---------------------
6915 procedure Inherit_Context
(Gen_Decl
: Node_Id
; Inst
: Node_Id
) is
6916 Current_Context
: List_Id
;
6917 Current_Unit
: Node_Id
;
6922 if Nkind
(Parent
(Gen_Decl
)) = N_Compilation_Unit
then
6924 -- The inherited context is attached to the enclosing compilation
6925 -- unit. This is either the main unit, or the declaration for the
6926 -- main unit (in case the instantiation appears within the package
6927 -- declaration and the main unit is its body).
6929 Current_Unit
:= Parent
(Inst
);
6930 while Present
(Current_Unit
)
6931 and then Nkind
(Current_Unit
) /= N_Compilation_Unit
6933 Current_Unit
:= Parent
(Current_Unit
);
6936 Current_Context
:= Context_Items
(Current_Unit
);
6938 Item
:= First
(Context_Items
(Parent
(Gen_Decl
)));
6939 while Present
(Item
) loop
6940 if Nkind
(Item
) = N_With_Clause
then
6942 -- Take care to prevent direct cyclic with's, which can happen
6943 -- if the generic body with's the current unit. Such a case
6944 -- would result in binder errors (or run-time errors if the
6945 -- -gnatE switch is in effect), but we want to prevent it here,
6946 -- because Sem.Walk_Library_Items doesn't like cycles. Note
6947 -- that we don't bother to detect indirect cycles.
6949 if Library_Unit
(Item
) /= Current_Unit
then
6950 New_I
:= New_Copy
(Item
);
6951 Set_Implicit_With
(New_I
, True);
6952 Append
(New_I
, Current_Context
);
6959 end Inherit_Context
;
6965 procedure Initialize
is
6967 Generic_Renamings
.Init
;
6970 Generic_Renamings_HTable
.Reset
;
6971 Circularity_Detected
:= False;
6972 Exchanged_Views
:= No_Elist
;
6973 Hidden_Entities
:= No_Elist
;
6976 ----------------------------
6977 -- Insert_After_Last_Decl --
6978 ----------------------------
6980 procedure Insert_After_Last_Decl
(N
: Node_Id
; F_Node
: Node_Id
) is
6981 L
: List_Id
:= List_Containing
(N
);
6982 P
: constant Node_Id
:= Parent
(L
);
6985 if not Is_List_Member
(F_Node
) then
6986 if Nkind
(P
) = N_Package_Specification
6987 and then L
= Visible_Declarations
(P
)
6988 and then Present
(Private_Declarations
(P
))
6989 and then not Is_Empty_List
(Private_Declarations
(P
))
6991 L
:= Private_Declarations
(P
);
6994 Insert_After
(Last
(L
), F_Node
);
6996 end Insert_After_Last_Decl
;
7002 procedure Install_Body
7003 (Act_Body
: Node_Id
;
7008 Act_Id
: constant Entity_Id
:= Corresponding_Spec
(Act_Body
);
7009 Act_Unit
: constant Node_Id
:= Unit
(Cunit
(Get_Source_Unit
(N
)));
7010 Gen_Id
: constant Entity_Id
:= Corresponding_Spec
(Gen_Body
);
7011 Par
: constant Entity_Id
:= Scope
(Gen_Id
);
7012 Gen_Unit
: constant Node_Id
:=
7013 Unit
(Cunit
(Get_Source_Unit
(Gen_Decl
)));
7014 Orig_Body
: Node_Id
:= Gen_Body
;
7016 Body_Unit
: Node_Id
;
7018 Must_Delay
: Boolean;
7020 function Enclosing_Subp
(Id
: Entity_Id
) return Entity_Id
;
7021 -- Find subprogram (if any) that encloses instance and/or generic body
7023 function True_Sloc
(N
: Node_Id
) return Source_Ptr
;
7024 -- If the instance is nested inside a generic unit, the Sloc of the
7025 -- instance indicates the place of the original definition, not the
7026 -- point of the current enclosing instance. Pending a better usage of
7027 -- Slocs to indicate instantiation places, we determine the place of
7028 -- origin of a node by finding the maximum sloc of any ancestor node.
7029 -- Why is this not equivalent to Top_Level_Location ???
7031 --------------------
7032 -- Enclosing_Subp --
7033 --------------------
7035 function Enclosing_Subp
(Id
: Entity_Id
) return Entity_Id
is
7036 Scop
: Entity_Id
:= Scope
(Id
);
7039 while Scop
/= Standard_Standard
7040 and then not Is_Overloadable
(Scop
)
7042 Scop
:= Scope
(Scop
);
7052 function True_Sloc
(N
: Node_Id
) return Source_Ptr
is
7059 while Present
(N1
) and then N1
/= Act_Unit
loop
7060 if Sloc
(N1
) > Res
then
7070 -- Start of processing for Install_Body
7074 -- If the body is a subunit, the freeze point is the corresponding
7075 -- stub in the current compilation, not the subunit itself.
7077 if Nkind
(Parent
(Gen_Body
)) = N_Subunit
then
7078 Orig_Body
:= Corresponding_Stub
(Parent
(Gen_Body
));
7080 Orig_Body
:= Gen_Body
;
7083 Body_Unit
:= Unit
(Cunit
(Get_Source_Unit
(Orig_Body
)));
7085 -- If the instantiation and the generic definition appear in the same
7086 -- package declaration, this is an early instantiation. If they appear
7087 -- in the same declarative part, it is an early instantiation only if
7088 -- the generic body appears textually later, and the generic body is
7089 -- also in the main unit.
7091 -- If instance is nested within a subprogram, and the generic body is
7092 -- not, the instance is delayed because the enclosing body is. If
7093 -- instance and body are within the same scope, or the same sub-
7094 -- program body, indicate explicitly that the instance is delayed.
7097 (Gen_Unit
= Act_Unit
7098 and then (Nkind_In
(Gen_Unit
, N_Package_Declaration
,
7099 N_Generic_Package_Declaration
)
7100 or else (Gen_Unit
= Body_Unit
7101 and then True_Sloc
(N
) < Sloc
(Orig_Body
)))
7102 and then Is_In_Main_Unit
(Gen_Unit
)
7103 and then (Scope
(Act_Id
) = Scope
(Gen_Id
)
7105 Enclosing_Subp
(Act_Id
) = Enclosing_Subp
(Gen_Id
)));
7107 -- If this is an early instantiation, the freeze node is placed after
7108 -- the generic body. Otherwise, if the generic appears in an instance,
7109 -- we cannot freeze the current instance until the outer one is frozen.
7110 -- This is only relevant if the current instance is nested within some
7111 -- inner scope not itself within the outer instance. If this scope is
7112 -- a package body in the same declarative part as the outer instance,
7113 -- then that body needs to be frozen after the outer instance. Finally,
7114 -- if no delay is needed, we place the freeze node at the end of the
7115 -- current declarative part.
7117 if Expander_Active
then
7118 Ensure_Freeze_Node
(Act_Id
);
7119 F_Node
:= Freeze_Node
(Act_Id
);
7122 Insert_After
(Orig_Body
, F_Node
);
7124 elsif Is_Generic_Instance
(Par
)
7125 and then Present
(Freeze_Node
(Par
))
7126 and then Scope
(Act_Id
) /= Par
7128 -- Freeze instance of inner generic after instance of enclosing
7131 if In_Same_Declarative_Part
(Freeze_Node
(Par
), N
) then
7132 Insert_After
(Freeze_Node
(Par
), F_Node
);
7134 -- Freeze package enclosing instance of inner generic after
7135 -- instance of enclosing generic.
7137 elsif Nkind
(Parent
(N
)) = N_Package_Body
7138 and then In_Same_Declarative_Part
(Freeze_Node
(Par
), Parent
(N
))
7142 Enclosing
: constant Entity_Id
:=
7143 Corresponding_Spec
(Parent
(N
));
7146 Insert_After_Last_Decl
(N
, F_Node
);
7147 Ensure_Freeze_Node
(Enclosing
);
7149 if not Is_List_Member
(Freeze_Node
(Enclosing
)) then
7150 Insert_After
(Freeze_Node
(Par
), Freeze_Node
(Enclosing
));
7155 Insert_After_Last_Decl
(N
, F_Node
);
7159 Insert_After_Last_Decl
(N
, F_Node
);
7163 Set_Is_Frozen
(Act_Id
);
7164 Insert_Before
(N
, Act_Body
);
7165 Mark_Rewrite_Insertion
(Act_Body
);
7168 -----------------------------
7169 -- Install_Formal_Packages --
7170 -----------------------------
7172 procedure Install_Formal_Packages
(Par
: Entity_Id
) is
7175 Gen_E
: Entity_Id
:= Empty
;
7178 E
:= First_Entity
(Par
);
7180 -- In we are installing an instance parent, locate the formal packages
7181 -- of its generic parent.
7183 if Is_Generic_Instance
(Par
) then
7184 Gen
:= Generic_Parent
(Specification
(Unit_Declaration_Node
(Par
)));
7185 Gen_E
:= First_Entity
(Gen
);
7188 while Present
(E
) loop
7189 if Ekind
(E
) = E_Package
7190 and then Nkind
(Parent
(E
)) = N_Package_Renaming_Declaration
7192 -- If this is the renaming for the parent instance, done
7194 if Renamed_Object
(E
) = Par
then
7197 -- The visibility of a formal of an enclosing generic is
7200 elsif Denotes_Formal_Package
(E
) then
7203 elsif Present
(Associated_Formal_Package
(E
))
7204 and then Box_Present
(Parent
(Associated_Formal_Package
(E
)))
7206 Check_Generic_Actuals
(Renamed_Object
(E
), True);
7207 Set_Is_Hidden
(E
, False);
7209 -- Find formal package in generic unit that corresponds to
7210 -- (instance of) formal package in instance.
7212 while Present
(Gen_E
)
7213 and then Chars
(Gen_E
) /= Chars
(E
)
7215 Next_Entity
(Gen_E
);
7218 if Present
(Gen_E
) then
7219 Map_Formal_Package_Entities
(Gen_E
, E
);
7225 if Present
(Gen_E
) then
7226 Next_Entity
(Gen_E
);
7229 end Install_Formal_Packages
;
7231 --------------------
7232 -- Install_Parent --
7233 --------------------
7235 procedure Install_Parent
(P
: Entity_Id
; In_Body
: Boolean := False) is
7236 Ancestors
: constant Elist_Id
:= New_Elmt_List
;
7237 S
: constant Entity_Id
:= Current_Scope
;
7238 Inst_Par
: Entity_Id
;
7239 First_Par
: Entity_Id
;
7240 Inst_Node
: Node_Id
;
7241 Gen_Par
: Entity_Id
;
7242 First_Gen
: Entity_Id
;
7245 procedure Install_Noninstance_Specs
(Par
: Entity_Id
);
7246 -- Install the scopes of noninstance parent units ending with Par
7248 procedure Install_Spec
(Par
: Entity_Id
);
7249 -- The child unit is within the declarative part of the parent, so
7250 -- the declarations within the parent are immediately visible.
7252 -------------------------------
7253 -- Install_Noninstance_Specs --
7254 -------------------------------
7256 procedure Install_Noninstance_Specs
(Par
: Entity_Id
) is
7259 and then Par
/= Standard_Standard
7260 and then not In_Open_Scopes
(Par
)
7262 Install_Noninstance_Specs
(Scope
(Par
));
7265 end Install_Noninstance_Specs
;
7271 procedure Install_Spec
(Par
: Entity_Id
) is
7272 Spec
: constant Node_Id
:=
7273 Specification
(Unit_Declaration_Node
(Par
));
7276 -- If this parent of the child instance is a top-level unit,
7277 -- then record the unit and its visibility for later resetting
7278 -- in Remove_Parent. We exclude units that are generic instances,
7279 -- as we only want to record this information for the ultimate
7280 -- top-level noninstance parent (is that always correct???).
7282 if Scope
(Par
) = Standard_Standard
7283 and then not Is_Generic_Instance
(Par
)
7285 Parent_Unit_Visible
:= Is_Immediately_Visible
(Par
);
7286 Instance_Parent_Unit
:= Par
;
7289 -- Open the parent scope and make it and its declarations visible.
7290 -- If this point is not within a body, then only the visible
7291 -- declarations should be made visible, and installation of the
7292 -- private declarations is deferred until the appropriate point
7293 -- within analysis of the spec being instantiated (see the handling
7294 -- of parent visibility in Analyze_Package_Specification). This is
7295 -- relaxed in the case where the parent unit is Ada.Tags, to avoid
7296 -- private view problems that occur when compiling instantiations of
7297 -- a generic child of that package (Generic_Dispatching_Constructor).
7298 -- If the instance freezes a tagged type, inlinings of operations
7299 -- from Ada.Tags may need the full view of type Tag. If inlining took
7300 -- proper account of establishing visibility of inlined subprograms'
7301 -- parents then it should be possible to remove this
7302 -- special check. ???
7305 Set_Is_Immediately_Visible
(Par
);
7306 Install_Visible_Declarations
(Par
);
7307 Set_Use
(Visible_Declarations
(Spec
));
7309 if In_Body
or else Is_RTU
(Par
, Ada_Tags
) then
7310 Install_Private_Declarations
(Par
);
7311 Set_Use
(Private_Declarations
(Spec
));
7315 -- Start of processing for Install_Parent
7318 -- We need to install the parent instance to compile the instantiation
7319 -- of the child, but the child instance must appear in the current
7320 -- scope. Given that we cannot place the parent above the current scope
7321 -- in the scope stack, we duplicate the current scope and unstack both
7322 -- after the instantiation is complete.
7324 -- If the parent is itself the instantiation of a child unit, we must
7325 -- also stack the instantiation of its parent, and so on. Each such
7326 -- ancestor is the prefix of the name in a prior instantiation.
7328 -- If this is a nested instance, the parent unit itself resolves to
7329 -- a renaming of the parent instance, whose declaration we need.
7331 -- Finally, the parent may be a generic (not an instance) when the
7332 -- child unit appears as a formal package.
7336 if Present
(Renamed_Entity
(Inst_Par
)) then
7337 Inst_Par
:= Renamed_Entity
(Inst_Par
);
7340 First_Par
:= Inst_Par
;
7343 Generic_Parent
(Specification
(Unit_Declaration_Node
(Inst_Par
)));
7345 First_Gen
:= Gen_Par
;
7347 while Present
(Gen_Par
)
7348 and then Is_Child_Unit
(Gen_Par
)
7350 -- Load grandparent instance as well
7352 Inst_Node
:= Get_Package_Instantiation_Node
(Inst_Par
);
7354 if Nkind
(Name
(Inst_Node
)) = N_Expanded_Name
then
7355 Inst_Par
:= Entity
(Prefix
(Name
(Inst_Node
)));
7357 if Present
(Renamed_Entity
(Inst_Par
)) then
7358 Inst_Par
:= Renamed_Entity
(Inst_Par
);
7363 (Specification
(Unit_Declaration_Node
(Inst_Par
)));
7365 if Present
(Gen_Par
) then
7366 Prepend_Elmt
(Inst_Par
, Ancestors
);
7369 -- Parent is not the name of an instantiation
7371 Install_Noninstance_Specs
(Inst_Par
);
7383 if Present
(First_Gen
) then
7384 Append_Elmt
(First_Par
, Ancestors
);
7387 Install_Noninstance_Specs
(First_Par
);
7390 if not Is_Empty_Elmt_List
(Ancestors
) then
7391 Elmt
:= First_Elmt
(Ancestors
);
7393 while Present
(Elmt
) loop
7394 Install_Spec
(Node
(Elmt
));
7395 Install_Formal_Packages
(Node
(Elmt
));
7406 --------------------------------
7407 -- Instantiate_Formal_Package --
7408 --------------------------------
7410 function Instantiate_Formal_Package
7413 Analyzed_Formal
: Node_Id
) return List_Id
7415 Loc
: constant Source_Ptr
:= Sloc
(Actual
);
7416 Actual_Pack
: Entity_Id
;
7417 Formal_Pack
: Entity_Id
;
7418 Gen_Parent
: Entity_Id
;
7421 Parent_Spec
: Node_Id
;
7423 procedure Find_Matching_Actual
7425 Act
: in out Entity_Id
);
7426 -- We need to associate each formal entity in the formal package
7427 -- with the corresponding entity in the actual package. The actual
7428 -- package has been analyzed and possibly expanded, and as a result
7429 -- there is no one-to-one correspondence between the two lists (for
7430 -- example, the actual may include subtypes, itypes, and inherited
7431 -- primitive operations, interspersed among the renaming declarations
7432 -- for the actuals) . We retrieve the corresponding actual by name
7433 -- because each actual has the same name as the formal, and they do
7434 -- appear in the same order.
7436 function Get_Formal_Entity
(N
: Node_Id
) return Entity_Id
;
7437 -- Retrieve entity of defining entity of generic formal parameter.
7438 -- Only the declarations of formals need to be considered when
7439 -- linking them to actuals, but the declarative list may include
7440 -- internal entities generated during analysis, and those are ignored.
7442 procedure Match_Formal_Entity
7443 (Formal_Node
: Node_Id
;
7444 Formal_Ent
: Entity_Id
;
7445 Actual_Ent
: Entity_Id
);
7446 -- Associates the formal entity with the actual. In the case
7447 -- where Formal_Ent is a formal package, this procedure iterates
7448 -- through all of its formals and enters associations between the
7449 -- actuals occurring in the formal package's corresponding actual
7450 -- package (given by Actual_Ent) and the formal package's formal
7451 -- parameters. This procedure recurses if any of the parameters is
7452 -- itself a package.
7454 function Is_Instance_Of
7455 (Act_Spec
: Entity_Id
;
7456 Gen_Anc
: Entity_Id
) return Boolean;
7457 -- The actual can be an instantiation of a generic within another
7458 -- instance, in which case there is no direct link from it to the
7459 -- original generic ancestor. In that case, we recognize that the
7460 -- ultimate ancestor is the same by examining names and scopes.
7462 procedure Process_Nested_Formal
(Formal
: Entity_Id
);
7463 -- If the current formal is declared with a box, its own formals are
7464 -- visible in the instance, as they were in the generic, and their
7465 -- Hidden flag must be reset. If some of these formals are themselves
7466 -- packages declared with a box, the processing must be recursive.
7468 --------------------------
7469 -- Find_Matching_Actual --
7470 --------------------------
7472 procedure Find_Matching_Actual
7474 Act
: in out Entity_Id
)
7476 Formal_Ent
: Entity_Id
;
7479 case Nkind
(Original_Node
(F
)) is
7480 when N_Formal_Object_Declaration |
7481 N_Formal_Type_Declaration
=>
7482 Formal_Ent
:= Defining_Identifier
(F
);
7484 while Chars
(Act
) /= Chars
(Formal_Ent
) loop
7488 when N_Formal_Subprogram_Declaration |
7489 N_Formal_Package_Declaration |
7490 N_Package_Declaration |
7491 N_Generic_Package_Declaration
=>
7492 Formal_Ent
:= Defining_Entity
(F
);
7494 while Chars
(Act
) /= Chars
(Formal_Ent
) loop
7499 raise Program_Error
;
7501 end Find_Matching_Actual
;
7503 -------------------------
7504 -- Match_Formal_Entity --
7505 -------------------------
7507 procedure Match_Formal_Entity
7508 (Formal_Node
: Node_Id
;
7509 Formal_Ent
: Entity_Id
;
7510 Actual_Ent
: Entity_Id
)
7512 Act_Pkg
: Entity_Id
;
7515 Set_Instance_Of
(Formal_Ent
, Actual_Ent
);
7517 if Ekind
(Actual_Ent
) = E_Package
then
7519 -- Record associations for each parameter
7521 Act_Pkg
:= Actual_Ent
;
7524 A_Ent
: Entity_Id
:= First_Entity
(Act_Pkg
);
7533 -- Retrieve the actual given in the formal package declaration
7535 Actual
:= Entity
(Name
(Original_Node
(Formal_Node
)));
7537 -- The actual in the formal package declaration may be a
7538 -- renamed generic package, in which case we want to retrieve
7539 -- the original generic in order to traverse its formal part.
7541 if Present
(Renamed_Entity
(Actual
)) then
7542 Gen_Decl
:= Unit_Declaration_Node
(Renamed_Entity
(Actual
));
7544 Gen_Decl
:= Unit_Declaration_Node
(Actual
);
7547 Formals
:= Generic_Formal_Declarations
(Gen_Decl
);
7549 if Present
(Formals
) then
7550 F_Node
:= First_Non_Pragma
(Formals
);
7555 while Present
(A_Ent
)
7556 and then Present
(F_Node
)
7557 and then A_Ent
/= First_Private_Entity
(Act_Pkg
)
7559 F_Ent
:= Get_Formal_Entity
(F_Node
);
7561 if Present
(F_Ent
) then
7563 -- This is a formal of the original package. Record
7564 -- association and recurse.
7566 Find_Matching_Actual
(F_Node
, A_Ent
);
7567 Match_Formal_Entity
(F_Node
, F_Ent
, A_Ent
);
7568 Next_Entity
(A_Ent
);
7571 Next_Non_Pragma
(F_Node
);
7575 end Match_Formal_Entity
;
7577 -----------------------
7578 -- Get_Formal_Entity --
7579 -----------------------
7581 function Get_Formal_Entity
(N
: Node_Id
) return Entity_Id
is
7582 Kind
: constant Node_Kind
:= Nkind
(Original_Node
(N
));
7585 when N_Formal_Object_Declaration
=>
7586 return Defining_Identifier
(N
);
7588 when N_Formal_Type_Declaration
=>
7589 return Defining_Identifier
(N
);
7591 when N_Formal_Subprogram_Declaration
=>
7592 return Defining_Unit_Name
(Specification
(N
));
7594 when N_Formal_Package_Declaration
=>
7595 return Defining_Identifier
(Original_Node
(N
));
7597 when N_Generic_Package_Declaration
=>
7598 return Defining_Identifier
(Original_Node
(N
));
7600 -- All other declarations are introduced by semantic analysis and
7601 -- have no match in the actual.
7606 end Get_Formal_Entity
;
7608 --------------------
7609 -- Is_Instance_Of --
7610 --------------------
7612 function Is_Instance_Of
7613 (Act_Spec
: Entity_Id
;
7614 Gen_Anc
: Entity_Id
) return Boolean
7616 Gen_Par
: constant Entity_Id
:= Generic_Parent
(Act_Spec
);
7619 if No
(Gen_Par
) then
7622 -- Simplest case: the generic parent of the actual is the formal
7624 elsif Gen_Par
= Gen_Anc
then
7627 elsif Chars
(Gen_Par
) /= Chars
(Gen_Anc
) then
7630 -- The actual may be obtained through several instantiations. Its
7631 -- scope must itself be an instance of a generic declared in the
7632 -- same scope as the formal. Any other case is detected above.
7634 elsif not Is_Generic_Instance
(Scope
(Gen_Par
)) then
7638 return Generic_Parent
(Parent
(Scope
(Gen_Par
))) = Scope
(Gen_Anc
);
7642 ---------------------------
7643 -- Process_Nested_Formal --
7644 ---------------------------
7646 procedure Process_Nested_Formal
(Formal
: Entity_Id
) is
7650 if Present
(Associated_Formal_Package
(Formal
))
7651 and then Box_Present
(Parent
(Associated_Formal_Package
(Formal
)))
7653 Ent
:= First_Entity
(Formal
);
7654 while Present
(Ent
) loop
7655 Set_Is_Hidden
(Ent
, False);
7656 Set_Is_Visible_Formal
(Ent
);
7657 Set_Is_Potentially_Use_Visible
7658 (Ent
, Is_Potentially_Use_Visible
(Formal
));
7660 if Ekind
(Ent
) = E_Package
then
7661 exit when Renamed_Entity
(Ent
) = Renamed_Entity
(Formal
);
7662 Process_Nested_Formal
(Ent
);
7668 end Process_Nested_Formal
;
7670 -- Start of processing for Instantiate_Formal_Package
7675 if not Is_Entity_Name
(Actual
)
7676 or else Ekind
(Entity
(Actual
)) /= E_Package
7679 ("expect package instance to instantiate formal", Actual
);
7680 Abandon_Instantiation
(Actual
);
7681 raise Program_Error
;
7684 Actual_Pack
:= Entity
(Actual
);
7685 Set_Is_Instantiated
(Actual_Pack
);
7687 -- The actual may be a renamed package, or an outer generic formal
7688 -- package whose instantiation is converted into a renaming.
7690 if Present
(Renamed_Object
(Actual_Pack
)) then
7691 Actual_Pack
:= Renamed_Object
(Actual_Pack
);
7694 if Nkind
(Analyzed_Formal
) = N_Formal_Package_Declaration
then
7695 Gen_Parent
:= Get_Instance_Of
(Entity
(Name
(Analyzed_Formal
)));
7696 Formal_Pack
:= Defining_Identifier
(Analyzed_Formal
);
7699 Generic_Parent
(Specification
(Analyzed_Formal
));
7701 Defining_Unit_Name
(Specification
(Analyzed_Formal
));
7704 if Nkind
(Parent
(Actual_Pack
)) = N_Defining_Program_Unit_Name
then
7705 Parent_Spec
:= Specification
(Unit_Declaration_Node
(Actual_Pack
));
7707 Parent_Spec
:= Parent
(Actual_Pack
);
7710 if Gen_Parent
= Any_Id
then
7712 ("previous error in declaration of formal package", Actual
);
7713 Abandon_Instantiation
(Actual
);
7716 Is_Instance_Of
(Parent_Spec
, Get_Instance_Of
(Gen_Parent
))
7722 ("actual parameter must be instance of&", Actual
, Gen_Parent
);
7723 Abandon_Instantiation
(Actual
);
7726 Set_Instance_Of
(Defining_Identifier
(Formal
), Actual_Pack
);
7727 Map_Formal_Package_Entities
(Formal_Pack
, Actual_Pack
);
7730 Make_Package_Renaming_Declaration
(Loc
,
7731 Defining_Unit_Name
=> New_Copy
(Defining_Identifier
(Formal
)),
7732 Name
=> New_Reference_To
(Actual_Pack
, Loc
));
7734 Set_Associated_Formal_Package
(Defining_Unit_Name
(Nod
),
7735 Defining_Identifier
(Formal
));
7736 Decls
:= New_List
(Nod
);
7738 -- If the formal F has a box, then the generic declarations are
7739 -- visible in the generic G. In an instance of G, the corresponding
7740 -- entities in the actual for F (which are the actuals for the
7741 -- instantiation of the generic that F denotes) must also be made
7742 -- visible for analysis of the current instance. On exit from the
7743 -- current instance, those entities are made private again. If the
7744 -- actual is currently in use, these entities are also use-visible.
7746 -- The loop through the actual entities also steps through the formal
7747 -- entities and enters associations from formals to actuals into the
7748 -- renaming map. This is necessary to properly handle checking of
7749 -- actual parameter associations for later formals that depend on
7750 -- actuals declared in the formal package.
7752 -- In Ada 2005, partial parametrization requires that we make visible
7753 -- the actuals corresponding to formals that were defaulted in the
7754 -- formal package. There formals are identified because they remain
7755 -- formal generics within the formal package, rather than being
7756 -- renamings of the actuals supplied.
7759 Gen_Decl
: constant Node_Id
:=
7760 Unit_Declaration_Node
(Gen_Parent
);
7761 Formals
: constant List_Id
:=
7762 Generic_Formal_Declarations
(Gen_Decl
);
7764 Actual_Ent
: Entity_Id
;
7765 Actual_Of_Formal
: Node_Id
;
7766 Formal_Node
: Node_Id
;
7767 Formal_Ent
: Entity_Id
;
7770 if Present
(Formals
) then
7771 Formal_Node
:= First_Non_Pragma
(Formals
);
7773 Formal_Node
:= Empty
;
7776 Actual_Ent
:= First_Entity
(Actual_Pack
);
7778 First
(Visible_Declarations
(Specification
(Analyzed_Formal
)));
7779 while Present
(Actual_Ent
)
7780 and then Actual_Ent
/= First_Private_Entity
(Actual_Pack
)
7782 if Present
(Formal_Node
) then
7783 Formal_Ent
:= Get_Formal_Entity
(Formal_Node
);
7785 if Present
(Formal_Ent
) then
7786 Find_Matching_Actual
(Formal_Node
, Actual_Ent
);
7788 (Formal_Node
, Formal_Ent
, Actual_Ent
);
7790 -- We iterate at the same time over the actuals of the
7791 -- local package created for the formal, to determine
7792 -- which one of the formals of the original generic were
7793 -- defaulted in the formal. The corresponding actual
7794 -- entities are visible in the enclosing instance.
7796 if Box_Present
(Formal
)
7798 (Present
(Actual_Of_Formal
)
7801 (Get_Formal_Entity
(Actual_Of_Formal
)))
7803 Set_Is_Hidden
(Actual_Ent
, False);
7804 Set_Is_Visible_Formal
(Actual_Ent
);
7805 Set_Is_Potentially_Use_Visible
7806 (Actual_Ent
, In_Use
(Actual_Pack
));
7808 if Ekind
(Actual_Ent
) = E_Package
then
7809 Process_Nested_Formal
(Actual_Ent
);
7813 Set_Is_Hidden
(Actual_Ent
);
7814 Set_Is_Potentially_Use_Visible
(Actual_Ent
, False);
7818 Next_Non_Pragma
(Formal_Node
);
7819 Next
(Actual_Of_Formal
);
7822 -- No further formals to match, but the generic part may
7823 -- contain inherited operation that are not hidden in the
7824 -- enclosing instance.
7826 Next_Entity
(Actual_Ent
);
7830 -- Inherited subprograms generated by formal derived types are
7831 -- also visible if the types are.
7833 Actual_Ent
:= First_Entity
(Actual_Pack
);
7834 while Present
(Actual_Ent
)
7835 and then Actual_Ent
/= First_Private_Entity
(Actual_Pack
)
7837 if Is_Overloadable
(Actual_Ent
)
7839 Nkind
(Parent
(Actual_Ent
)) = N_Subtype_Declaration
7841 not Is_Hidden
(Defining_Identifier
(Parent
(Actual_Ent
)))
7843 Set_Is_Hidden
(Actual_Ent
, False);
7844 Set_Is_Potentially_Use_Visible
7845 (Actual_Ent
, In_Use
(Actual_Pack
));
7848 Next_Entity
(Actual_Ent
);
7852 -- If the formal is not declared with a box, reanalyze it as an
7853 -- abbreviated instantiation, to verify the matching rules of 12.7.
7854 -- The actual checks are performed after the generic associations
7855 -- have been analyzed, to guarantee the same visibility for this
7856 -- instantiation and for the actuals.
7858 -- In Ada 2005, the generic associations for the formal can include
7859 -- defaulted parameters. These are ignored during check. This
7860 -- internal instantiation is removed from the tree after conformance
7861 -- checking, because it contains formal declarations for those
7862 -- defaulted parameters, and those should not reach the back-end.
7864 if not Box_Present
(Formal
) then
7866 I_Pack
: constant Entity_Id
:=
7867 Make_Defining_Identifier
(Sloc
(Actual
),
7868 Chars
=> New_Internal_Name
('P'));
7871 Set_Is_Internal
(I_Pack
);
7874 Make_Package_Instantiation
(Sloc
(Actual
),
7875 Defining_Unit_Name
=> I_Pack
,
7878 (Get_Instance_Of
(Gen_Parent
), Sloc
(Actual
)),
7879 Generic_Associations
=>
7880 Generic_Associations
(Formal
)));
7886 end Instantiate_Formal_Package
;
7888 -----------------------------------
7889 -- Instantiate_Formal_Subprogram --
7890 -----------------------------------
7892 function Instantiate_Formal_Subprogram
7895 Analyzed_Formal
: Node_Id
) return Node_Id
7898 Formal_Sub
: constant Entity_Id
:=
7899 Defining_Unit_Name
(Specification
(Formal
));
7900 Analyzed_S
: constant Entity_Id
:=
7901 Defining_Unit_Name
(Specification
(Analyzed_Formal
));
7902 Decl_Node
: Node_Id
;
7906 function From_Parent_Scope
(Subp
: Entity_Id
) return Boolean;
7907 -- If the generic is a child unit, the parent has been installed on the
7908 -- scope stack, but a default subprogram cannot resolve to something on
7909 -- the parent because that parent is not really part of the visible
7910 -- context (it is there to resolve explicit local entities). If the
7911 -- default has resolved in this way, we remove the entity from
7912 -- immediate visibility and analyze the node again to emit an error
7913 -- message or find another visible candidate.
7915 procedure Valid_Actual_Subprogram
(Act
: Node_Id
);
7916 -- Perform legality check and raise exception on failure
7918 -----------------------
7919 -- From_Parent_Scope --
7920 -----------------------
7922 function From_Parent_Scope
(Subp
: Entity_Id
) return Boolean is
7923 Gen_Scope
: Node_Id
;
7926 Gen_Scope
:= Scope
(Analyzed_S
);
7927 while Present
(Gen_Scope
)
7928 and then Is_Child_Unit
(Gen_Scope
)
7930 if Scope
(Subp
) = Scope
(Gen_Scope
) then
7934 Gen_Scope
:= Scope
(Gen_Scope
);
7938 end From_Parent_Scope
;
7940 -----------------------------
7941 -- Valid_Actual_Subprogram --
7942 -----------------------------
7944 procedure Valid_Actual_Subprogram
(Act
: Node_Id
) is
7948 if Is_Entity_Name
(Act
) then
7949 Act_E
:= Entity
(Act
);
7951 elsif Nkind
(Act
) = N_Selected_Component
7952 and then Is_Entity_Name
(Selector_Name
(Act
))
7954 Act_E
:= Entity
(Selector_Name
(Act
));
7960 if (Present
(Act_E
) and then Is_Overloadable
(Act_E
))
7961 or else Nkind_In
(Act
, N_Attribute_Reference
,
7962 N_Indexed_Component
,
7963 N_Character_Literal
,
7964 N_Explicit_Dereference
)
7970 ("expect subprogram or entry name in instantiation of&",
7971 Instantiation_Node
, Formal_Sub
);
7972 Abandon_Instantiation
(Instantiation_Node
);
7974 end Valid_Actual_Subprogram
;
7976 -- Start of processing for Instantiate_Formal_Subprogram
7979 New_Spec
:= New_Copy_Tree
(Specification
(Formal
));
7981 -- The tree copy has created the proper instantiation sloc for the
7982 -- new specification. Use this location for all other constructed
7985 Loc
:= Sloc
(Defining_Unit_Name
(New_Spec
));
7987 -- Create new entity for the actual (New_Copy_Tree does not)
7989 Set_Defining_Unit_Name
7990 (New_Spec
, Make_Defining_Identifier
(Loc
, Chars
(Formal_Sub
)));
7992 -- Create new entities for the each of the formals in the
7993 -- specification of the renaming declaration built for the actual.
7995 if Present
(Parameter_Specifications
(New_Spec
)) then
7999 F
:= First
(Parameter_Specifications
(New_Spec
));
8000 while Present
(F
) loop
8001 Set_Defining_Identifier
(F
,
8002 Make_Defining_Identifier
(Sloc
(F
),
8003 Chars
=> Chars
(Defining_Identifier
(F
))));
8009 -- Find entity of actual. If the actual is an attribute reference, it
8010 -- cannot be resolved here (its formal is missing) but is handled
8011 -- instead in Attribute_Renaming. If the actual is overloaded, it is
8012 -- fully resolved subsequently, when the renaming declaration for the
8013 -- formal is analyzed. If it is an explicit dereference, resolve the
8014 -- prefix but not the actual itself, to prevent interpretation as call.
8016 if Present
(Actual
) then
8017 Loc
:= Sloc
(Actual
);
8018 Set_Sloc
(New_Spec
, Loc
);
8020 if Nkind
(Actual
) = N_Operator_Symbol
then
8021 Find_Direct_Name
(Actual
);
8023 elsif Nkind
(Actual
) = N_Explicit_Dereference
then
8024 Analyze
(Prefix
(Actual
));
8026 elsif Nkind
(Actual
) /= N_Attribute_Reference
then
8030 Valid_Actual_Subprogram
(Actual
);
8033 elsif Present
(Default_Name
(Formal
)) then
8034 if not Nkind_In
(Default_Name
(Formal
), N_Attribute_Reference
,
8035 N_Selected_Component
,
8036 N_Indexed_Component
,
8037 N_Character_Literal
)
8038 and then Present
(Entity
(Default_Name
(Formal
)))
8040 Nam
:= New_Occurrence_Of
(Entity
(Default_Name
(Formal
)), Loc
);
8042 Nam
:= New_Copy
(Default_Name
(Formal
));
8043 Set_Sloc
(Nam
, Loc
);
8046 elsif Box_Present
(Formal
) then
8048 -- Actual is resolved at the point of instantiation. Create an
8049 -- identifier or operator with the same name as the formal.
8051 if Nkind
(Formal_Sub
) = N_Defining_Operator_Symbol
then
8052 Nam
:= Make_Operator_Symbol
(Loc
,
8053 Chars
=> Chars
(Formal_Sub
),
8054 Strval
=> No_String
);
8056 Nam
:= Make_Identifier
(Loc
, Chars
(Formal_Sub
));
8059 elsif Nkind
(Specification
(Formal
)) = N_Procedure_Specification
8060 and then Null_Present
(Specification
(Formal
))
8062 -- Generate null body for procedure, for use in the instance
8065 Make_Subprogram_Body
(Loc
,
8066 Specification
=> New_Spec
,
8067 Declarations
=> New_List
,
8068 Handled_Statement_Sequence
=>
8069 Make_Handled_Sequence_Of_Statements
(Loc
,
8070 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
8072 Set_Is_Intrinsic_Subprogram
(Defining_Unit_Name
(New_Spec
));
8076 Error_Msg_Sloc
:= Sloc
(Scope
(Analyzed_S
));
8078 ("missing actual&", Instantiation_Node
, Formal_Sub
);
8080 ("\in instantiation of & declared#",
8081 Instantiation_Node
, Scope
(Analyzed_S
));
8082 Abandon_Instantiation
(Instantiation_Node
);
8086 Make_Subprogram_Renaming_Declaration
(Loc
,
8087 Specification
=> New_Spec
,
8090 -- If we do not have an actual and the formal specified <> then set to
8091 -- get proper default.
8093 if No
(Actual
) and then Box_Present
(Formal
) then
8094 Set_From_Default
(Decl_Node
);
8097 -- Gather possible interpretations for the actual before analyzing the
8098 -- instance. If overloaded, it will be resolved when analyzing the
8099 -- renaming declaration.
8101 if Box_Present
(Formal
)
8102 and then No
(Actual
)
8106 if Is_Child_Unit
(Scope
(Analyzed_S
))
8107 and then Present
(Entity
(Nam
))
8109 if not Is_Overloaded
(Nam
) then
8111 if From_Parent_Scope
(Entity
(Nam
)) then
8112 Set_Is_Immediately_Visible
(Entity
(Nam
), False);
8113 Set_Entity
(Nam
, Empty
);
8114 Set_Etype
(Nam
, Empty
);
8118 Set_Is_Immediately_Visible
(Entity
(Nam
));
8127 Get_First_Interp
(Nam
, I
, It
);
8129 while Present
(It
.Nam
) loop
8130 if From_Parent_Scope
(It
.Nam
) then
8134 Get_Next_Interp
(I
, It
);
8141 -- The generic instantiation freezes the actual. This can only be done
8142 -- once the actual is resolved, in the analysis of the renaming
8143 -- declaration. To make the formal subprogram entity available, we set
8144 -- Corresponding_Formal_Spec to point to the formal subprogram entity.
8145 -- This is also needed in Analyze_Subprogram_Renaming for the processing
8146 -- of formal abstract subprograms.
8148 Set_Corresponding_Formal_Spec
(Decl_Node
, Analyzed_S
);
8150 -- We cannot analyze the renaming declaration, and thus find the actual,
8151 -- until all the actuals are assembled in the instance. For subsequent
8152 -- checks of other actuals, indicate the node that will hold the
8153 -- instance of this formal.
8155 Set_Instance_Of
(Analyzed_S
, Nam
);
8157 if Nkind
(Actual
) = N_Selected_Component
8158 and then Is_Task_Type
(Etype
(Prefix
(Actual
)))
8159 and then not Is_Frozen
(Etype
(Prefix
(Actual
)))
8161 -- The renaming declaration will create a body, which must appear
8162 -- outside of the instantiation, We move the renaming declaration
8163 -- out of the instance, and create an additional renaming inside,
8164 -- to prevent freezing anomalies.
8167 Anon_Id
: constant Entity_Id
:=
8168 Make_Defining_Identifier
8169 (Loc
, New_Internal_Name
('E'));
8171 Set_Defining_Unit_Name
(New_Spec
, Anon_Id
);
8172 Insert_Before
(Instantiation_Node
, Decl_Node
);
8173 Analyze
(Decl_Node
);
8175 -- Now create renaming within the instance
8178 Make_Subprogram_Renaming_Declaration
(Loc
,
8179 Specification
=> New_Copy_Tree
(New_Spec
),
8180 Name
=> New_Occurrence_Of
(Anon_Id
, Loc
));
8182 Set_Defining_Unit_Name
(Specification
(Decl_Node
),
8183 Make_Defining_Identifier
(Loc
, Chars
(Formal_Sub
)));
8188 end Instantiate_Formal_Subprogram
;
8190 ------------------------
8191 -- Instantiate_Object --
8192 ------------------------
8194 function Instantiate_Object
8197 Analyzed_Formal
: Node_Id
) return List_Id
8199 Acc_Def
: Node_Id
:= Empty
;
8200 Act_Assoc
: constant Node_Id
:= Parent
(Actual
);
8201 Actual_Decl
: Node_Id
:= Empty
;
8202 Formal_Id
: constant Entity_Id
:= Defining_Identifier
(Formal
);
8203 Decl_Node
: Node_Id
;
8206 List
: constant List_Id
:= New_List
;
8207 Loc
: constant Source_Ptr
:= Sloc
(Actual
);
8208 Orig_Ftyp
: constant Entity_Id
:=
8209 Etype
(Defining_Identifier
(Analyzed_Formal
));
8210 Subt_Decl
: Node_Id
:= Empty
;
8211 Subt_Mark
: Node_Id
:= Empty
;
8214 if Present
(Subtype_Mark
(Formal
)) then
8215 Subt_Mark
:= Subtype_Mark
(Formal
);
8217 Check_Access_Definition
(Formal
);
8218 Acc_Def
:= Access_Definition
(Formal
);
8221 -- Sloc for error message on missing actual
8223 Error_Msg_Sloc
:= Sloc
(Scope
(Defining_Identifier
(Analyzed_Formal
)));
8225 if Get_Instance_Of
(Formal_Id
) /= Formal_Id
then
8226 Error_Msg_N
("duplicate instantiation of generic parameter", Actual
);
8229 Set_Parent
(List
, Parent
(Actual
));
8233 if Out_Present
(Formal
) then
8235 -- An IN OUT generic actual must be a name. The instantiation is a
8236 -- renaming declaration. The actual is the name being renamed. We
8237 -- use the actual directly, rather than a copy, because it is not
8238 -- used further in the list of actuals, and because a copy or a use
8239 -- of relocate_node is incorrect if the instance is nested within a
8240 -- generic. In order to simplify ASIS searches, the Generic_Parent
8241 -- field links the declaration to the generic association.
8246 Instantiation_Node
, Formal_Id
);
8248 ("\in instantiation of & declared#",
8250 Scope
(Defining_Identifier
(Analyzed_Formal
)));
8251 Abandon_Instantiation
(Instantiation_Node
);
8254 if Present
(Subt_Mark
) then
8256 Make_Object_Renaming_Declaration
(Loc
,
8257 Defining_Identifier
=> New_Copy
(Formal_Id
),
8258 Subtype_Mark
=> New_Copy_Tree
(Subt_Mark
),
8261 else pragma Assert
(Present
(Acc_Def
));
8263 Make_Object_Renaming_Declaration
(Loc
,
8264 Defining_Identifier
=> New_Copy
(Formal_Id
),
8265 Access_Definition
=> New_Copy_Tree
(Acc_Def
),
8269 Set_Corresponding_Generic_Association
(Decl_Node
, Act_Assoc
);
8271 -- The analysis of the actual may produce insert_action nodes, so
8272 -- the declaration must have a context in which to attach them.
8274 Append
(Decl_Node
, List
);
8277 -- Return if the analysis of the actual reported some error
8279 if Etype
(Actual
) = Any_Type
then
8283 -- This check is performed here because Analyze_Object_Renaming will
8284 -- not check it when Comes_From_Source is False. Note though that the
8285 -- check for the actual being the name of an object will be performed
8286 -- in Analyze_Object_Renaming.
8288 if Is_Object_Reference
(Actual
)
8289 and then Is_Dependent_Component_Of_Mutable_Object
(Actual
)
8292 ("illegal discriminant-dependent component for in out parameter",
8296 -- The actual has to be resolved in order to check that it is a
8297 -- variable (due to cases such as F(1), where F returns
8298 -- access to an array, and for overloaded prefixes).
8301 Get_Instance_Of
(Etype
(Defining_Identifier
(Analyzed_Formal
)));
8303 if Is_Private_Type
(Ftyp
)
8304 and then not Is_Private_Type
(Etype
(Actual
))
8305 and then (Base_Type
(Full_View
(Ftyp
)) = Base_Type
(Etype
(Actual
))
8306 or else Base_Type
(Etype
(Actual
)) = Ftyp
)
8308 -- If the actual has the type of the full view of the formal, or
8309 -- else a non-private subtype of the formal, then the visibility
8310 -- of the formal type has changed. Add to the actuals a subtype
8311 -- declaration that will force the exchange of views in the body
8312 -- of the instance as well.
8315 Make_Subtype_Declaration
(Loc
,
8316 Defining_Identifier
=>
8317 Make_Defining_Identifier
(Loc
, New_Internal_Name
('P')),
8318 Subtype_Indication
=> New_Occurrence_Of
(Ftyp
, Loc
));
8320 Prepend
(Subt_Decl
, List
);
8322 Prepend_Elmt
(Full_View
(Ftyp
), Exchanged_Views
);
8323 Exchange_Declarations
(Ftyp
);
8326 Resolve
(Actual
, Ftyp
);
8328 if not Denotes_Variable
(Actual
) then
8330 ("actual for& must be a variable", Actual
, Formal_Id
);
8332 elsif Base_Type
(Ftyp
) /= Base_Type
(Etype
(Actual
)) then
8334 -- Ada 2005 (AI-423): For a generic formal object of mode in out,
8335 -- the type of the actual shall resolve to a specific anonymous
8338 if Ada_Version
< Ada_05
8340 Ekind
(Base_Type
(Ftyp
)) /=
8341 E_Anonymous_Access_Type
8343 Ekind
(Base_Type
(Etype
(Actual
))) /=
8344 E_Anonymous_Access_Type
8346 Error_Msg_NE
("type of actual does not match type of&",
8351 Note_Possible_Modification
(Actual
, Sure
=> True);
8353 -- Check for instantiation of atomic/volatile actual for
8354 -- non-atomic/volatile formal (RM C.6 (12)).
8356 if Is_Atomic_Object
(Actual
)
8357 and then not Is_Atomic
(Orig_Ftyp
)
8360 ("cannot instantiate non-atomic formal object " &
8361 "with atomic actual", Actual
);
8363 elsif Is_Volatile_Object
(Actual
)
8364 and then not Is_Volatile
(Orig_Ftyp
)
8367 ("cannot instantiate non-volatile formal object " &
8368 "with volatile actual", Actual
);
8371 -- formal in-parameter
8374 -- The instantiation of a generic formal in-parameter is constant
8375 -- declaration. The actual is the expression for that declaration.
8377 if Present
(Actual
) then
8378 if Present
(Subt_Mark
) then
8380 else pragma Assert
(Present
(Acc_Def
));
8385 Make_Object_Declaration
(Loc
,
8386 Defining_Identifier
=> New_Copy
(Formal_Id
),
8387 Constant_Present
=> True,
8388 Null_Exclusion_Present
=> Null_Exclusion_Present
(Formal
),
8389 Object_Definition
=> New_Copy_Tree
(Def
),
8390 Expression
=> Actual
);
8392 Set_Corresponding_Generic_Association
(Decl_Node
, Act_Assoc
);
8394 -- A generic formal object of a tagged type is defined to be
8395 -- aliased so the new constant must also be treated as aliased.
8398 (Etype
(Defining_Identifier
(Analyzed_Formal
)))
8400 Set_Aliased_Present
(Decl_Node
);
8403 Append
(Decl_Node
, List
);
8405 -- No need to repeat (pre-)analysis of some expression nodes
8406 -- already handled in Preanalyze_Actuals.
8408 if Nkind
(Actual
) /= N_Allocator
then
8411 -- Return if the analysis of the actual reported some error
8413 if Etype
(Actual
) = Any_Type
then
8419 Formal_Object
: constant Entity_Id
:=
8420 Defining_Identifier
(Analyzed_Formal
);
8421 Formal_Type
: constant Entity_Id
:= Etype
(Formal_Object
);
8426 Typ
:= Get_Instance_Of
(Formal_Type
);
8428 Freeze_Before
(Instantiation_Node
, Typ
);
8430 -- If the actual is an aggregate, perform name resolution on
8431 -- its components (the analysis of an aggregate does not do it)
8432 -- to capture local names that may be hidden if the generic is
8435 if Nkind
(Actual
) = N_Aggregate
then
8436 Preanalyze_And_Resolve
(Actual
, Typ
);
8439 if Is_Limited_Type
(Typ
)
8440 and then not OK_For_Limited_Init
(Actual
)
8443 ("initialization not allowed for limited types", Actual
);
8444 Explain_Limited_Type
(Typ
, Actual
);
8448 elsif Present
(Default_Expression
(Formal
)) then
8450 -- Use default to construct declaration
8452 if Present
(Subt_Mark
) then
8454 else pragma Assert
(Present
(Acc_Def
));
8459 Make_Object_Declaration
(Sloc
(Formal
),
8460 Defining_Identifier
=> New_Copy
(Formal_Id
),
8461 Constant_Present
=> True,
8462 Null_Exclusion_Present
=> Null_Exclusion_Present
(Formal
),
8463 Object_Definition
=> New_Copy
(Def
),
8464 Expression
=> New_Copy_Tree
8465 (Default_Expression
(Formal
)));
8467 Append
(Decl_Node
, List
);
8468 Set_Analyzed
(Expression
(Decl_Node
), False);
8473 Instantiation_Node
, Formal_Id
);
8474 Error_Msg_NE
("\in instantiation of & declared#",
8476 Scope
(Defining_Identifier
(Analyzed_Formal
)));
8479 (Etype
(Defining_Identifier
(Analyzed_Formal
)))
8481 -- Create dummy constant declaration so that instance can be
8482 -- analyzed, to minimize cascaded visibility errors.
8484 if Present
(Subt_Mark
) then
8486 else pragma Assert
(Present
(Acc_Def
));
8491 Make_Object_Declaration
(Loc
,
8492 Defining_Identifier
=> New_Copy
(Formal_Id
),
8493 Constant_Present
=> True,
8494 Null_Exclusion_Present
=> Null_Exclusion_Present
(Formal
),
8495 Object_Definition
=> New_Copy
(Def
),
8497 Make_Attribute_Reference
(Sloc
(Formal_Id
),
8498 Attribute_Name
=> Name_First
,
8499 Prefix
=> New_Copy
(Def
)));
8501 Append
(Decl_Node
, List
);
8504 Abandon_Instantiation
(Instantiation_Node
);
8509 if Nkind
(Actual
) in N_Has_Entity
then
8510 Actual_Decl
:= Parent
(Entity
(Actual
));
8513 -- Ada 2005 (AI-423): For a formal object declaration with a null
8514 -- exclusion or an access definition that has a null exclusion: If the
8515 -- actual matching the formal object declaration denotes a generic
8516 -- formal object of another generic unit G, and the instantiation
8517 -- containing the actual occurs within the body of G or within the body
8518 -- of a generic unit declared within the declarative region of G, then
8519 -- the declaration of the formal object of G must have a null exclusion.
8520 -- Otherwise, the subtype of the actual matching the formal object
8521 -- declaration shall exclude null.
8523 if Ada_Version
>= Ada_05
8524 and then Present
(Actual_Decl
)
8526 Nkind_In
(Actual_Decl
, N_Formal_Object_Declaration
,
8527 N_Object_Declaration
)
8528 and then Nkind
(Analyzed_Formal
) = N_Formal_Object_Declaration
8529 and then not Has_Null_Exclusion
(Actual_Decl
)
8530 and then Has_Null_Exclusion
(Analyzed_Formal
)
8532 Error_Msg_Sloc
:= Sloc
(Analyzed_Formal
);
8534 ("actual must exclude null to match generic formal#", Actual
);
8538 end Instantiate_Object
;
8540 ------------------------------
8541 -- Instantiate_Package_Body --
8542 ------------------------------
8544 procedure Instantiate_Package_Body
8545 (Body_Info
: Pending_Body_Info
;
8546 Inlined_Body
: Boolean := False;
8547 Body_Optional
: Boolean := False)
8549 Act_Decl
: constant Node_Id
:= Body_Info
.Act_Decl
;
8550 Inst_Node
: constant Node_Id
:= Body_Info
.Inst_Node
;
8551 Loc
: constant Source_Ptr
:= Sloc
(Inst_Node
);
8553 Gen_Id
: constant Node_Id
:= Name
(Inst_Node
);
8554 Gen_Unit
: constant Entity_Id
:= Get_Generic_Entity
(Inst_Node
);
8555 Gen_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Gen_Unit
);
8556 Act_Spec
: constant Node_Id
:= Specification
(Act_Decl
);
8557 Act_Decl_Id
: constant Entity_Id
:= Defining_Entity
(Act_Spec
);
8559 Act_Body_Name
: Node_Id
;
8561 Gen_Body_Id
: Node_Id
;
8563 Act_Body_Id
: Entity_Id
;
8565 Parent_Installed
: Boolean := False;
8566 Save_Style_Check
: constant Boolean := Style_Check
;
8569 Gen_Body_Id
:= Corresponding_Body
(Gen_Decl
);
8571 -- The instance body may already have been processed, as the parent of
8572 -- another instance that is inlined (Load_Parent_Of_Generic).
8574 if Present
(Corresponding_Body
(Instance_Spec
(Inst_Node
))) then
8578 Expander_Mode_Save_And_Set
(Body_Info
.Expander_Status
);
8580 -- Re-establish the state of information on which checks are suppressed.
8581 -- This information was set in Body_Info at the point of instantiation,
8582 -- and now we restore it so that the instance is compiled using the
8583 -- check status at the instantiation (RM 11.5 (7.2/2), AI95-00224-01).
8585 Local_Suppress_Stack_Top
:= Body_Info
.Local_Suppress_Stack_Top
;
8586 Scope_Suppress
:= Body_Info
.Scope_Suppress
;
8588 if No
(Gen_Body_Id
) then
8589 Load_Parent_Of_Generic
8590 (Inst_Node
, Specification
(Gen_Decl
), Body_Optional
);
8591 Gen_Body_Id
:= Corresponding_Body
(Gen_Decl
);
8594 -- Establish global variable for sloc adjustment and for error recovery
8596 Instantiation_Node
:= Inst_Node
;
8598 if Present
(Gen_Body_Id
) then
8599 Save_Env
(Gen_Unit
, Act_Decl_Id
);
8600 Style_Check
:= False;
8601 Current_Sem_Unit
:= Body_Info
.Current_Sem_Unit
;
8603 Gen_Body
:= Unit_Declaration_Node
(Gen_Body_Id
);
8605 Create_Instantiation_Source
8606 (Inst_Node
, Gen_Body_Id
, False, S_Adjustment
);
8610 (Original_Node
(Gen_Body
), Empty
, Instantiating
=> True);
8612 -- Build new name (possibly qualified) for body declaration
8614 Act_Body_Id
:= New_Copy
(Act_Decl_Id
);
8616 -- Some attributes of spec entity are not inherited by body entity
8618 Set_Handler_Records
(Act_Body_Id
, No_List
);
8620 if Nkind
(Defining_Unit_Name
(Act_Spec
)) =
8621 N_Defining_Program_Unit_Name
8624 Make_Defining_Program_Unit_Name
(Loc
,
8625 Name
=> New_Copy_Tree
(Name
(Defining_Unit_Name
(Act_Spec
))),
8626 Defining_Identifier
=> Act_Body_Id
);
8628 Act_Body_Name
:= Act_Body_Id
;
8631 Set_Defining_Unit_Name
(Act_Body
, Act_Body_Name
);
8633 Set_Corresponding_Spec
(Act_Body
, Act_Decl_Id
);
8634 Check_Generic_Actuals
(Act_Decl_Id
, False);
8636 -- If it is a child unit, make the parent instance (which is an
8637 -- instance of the parent of the generic) visible. The parent
8638 -- instance is the prefix of the name of the generic unit.
8640 if Ekind
(Scope
(Gen_Unit
)) = E_Generic_Package
8641 and then Nkind
(Gen_Id
) = N_Expanded_Name
8643 Install_Parent
(Entity
(Prefix
(Gen_Id
)), In_Body
=> True);
8644 Parent_Installed
:= True;
8646 elsif Is_Child_Unit
(Gen_Unit
) then
8647 Install_Parent
(Scope
(Gen_Unit
), In_Body
=> True);
8648 Parent_Installed
:= True;
8651 -- If the instantiation is a library unit, and this is the main unit,
8652 -- then build the resulting compilation unit nodes for the instance.
8653 -- If this is a compilation unit but it is not the main unit, then it
8654 -- is the body of a unit in the context, that is being compiled
8655 -- because it is encloses some inlined unit or another generic unit
8656 -- being instantiated. In that case, this body is not part of the
8657 -- current compilation, and is not attached to the tree, but its
8658 -- parent must be set for analysis.
8660 if Nkind
(Parent
(Inst_Node
)) = N_Compilation_Unit
then
8662 -- Replace instance node with body of instance, and create new
8663 -- node for corresponding instance declaration.
8665 Build_Instance_Compilation_Unit_Nodes
8666 (Inst_Node
, Act_Body
, Act_Decl
);
8667 Analyze
(Inst_Node
);
8669 if Parent
(Inst_Node
) = Cunit
(Main_Unit
) then
8671 -- If the instance is a child unit itself, then set the scope
8672 -- of the expanded body to be the parent of the instantiation
8673 -- (ensuring that the fully qualified name will be generated
8674 -- for the elaboration subprogram).
8676 if Nkind
(Defining_Unit_Name
(Act_Spec
)) =
8677 N_Defining_Program_Unit_Name
8680 (Defining_Entity
(Inst_Node
), Scope
(Act_Decl_Id
));
8684 -- Case where instantiation is not a library unit
8687 -- If this is an early instantiation, i.e. appears textually
8688 -- before the corresponding body and must be elaborated first,
8689 -- indicate that the body instance is to be delayed.
8691 Install_Body
(Act_Body
, Inst_Node
, Gen_Body
, Gen_Decl
);
8693 -- Now analyze the body. We turn off all checks if this is an
8694 -- internal unit, since there is no reason to have checks on for
8695 -- any predefined run-time library code. All such code is designed
8696 -- to be compiled with checks off.
8698 -- Note that we do NOT apply this criterion to children of GNAT
8699 -- (or on VMS, children of DEC). The latter units must suppress
8700 -- checks explicitly if this is needed.
8702 if Is_Predefined_File_Name
8703 (Unit_File_Name
(Get_Source_Unit
(Gen_Decl
)))
8705 Analyze
(Act_Body
, Suppress
=> All_Checks
);
8711 Inherit_Context
(Gen_Body
, Inst_Node
);
8713 -- Remove the parent instances if they have been placed on the scope
8714 -- stack to compile the body.
8716 if Parent_Installed
then
8717 Remove_Parent
(In_Body
=> True);
8720 Restore_Private_Views
(Act_Decl_Id
);
8722 -- Remove the current unit from visibility if this is an instance
8723 -- that is not elaborated on the fly for inlining purposes.
8725 if not Inlined_Body
then
8726 Set_Is_Immediately_Visible
(Act_Decl_Id
, False);
8730 Style_Check
:= Save_Style_Check
;
8732 -- If we have no body, and the unit requires a body, then complain. This
8733 -- complaint is suppressed if we have detected other errors (since a
8734 -- common reason for missing the body is that it had errors).
8736 elsif Unit_Requires_Body
(Gen_Unit
)
8737 and then not Body_Optional
8739 if Serious_Errors_Detected
= 0 then
8741 ("cannot find body of generic package &", Inst_Node
, Gen_Unit
);
8743 -- Don't attempt to perform any cleanup actions if some other error
8744 -- was already detected, since this can cause blowups.
8750 -- Case of package that does not need a body
8753 -- If the instantiation of the declaration is a library unit, rewrite
8754 -- the original package instantiation as a package declaration in the
8755 -- compilation unit node.
8757 if Nkind
(Parent
(Inst_Node
)) = N_Compilation_Unit
then
8758 Set_Parent_Spec
(Act_Decl
, Parent_Spec
(Inst_Node
));
8759 Rewrite
(Inst_Node
, Act_Decl
);
8761 -- Generate elaboration entity, in case spec has elaboration code.
8762 -- This cannot be done when the instance is analyzed, because it
8763 -- is not known yet whether the body exists.
8765 Set_Elaboration_Entity_Required
(Act_Decl_Id
, False);
8766 Build_Elaboration_Entity
(Parent
(Inst_Node
), Act_Decl_Id
);
8768 -- If the instantiation is not a library unit, then append the
8769 -- declaration to the list of implicitly generated entities, unless
8770 -- it is already a list member which means that it was already
8773 elsif not Is_List_Member
(Act_Decl
) then
8774 Mark_Rewrite_Insertion
(Act_Decl
);
8775 Insert_Before
(Inst_Node
, Act_Decl
);
8779 Expander_Mode_Restore
;
8780 end Instantiate_Package_Body
;
8782 ---------------------------------
8783 -- Instantiate_Subprogram_Body --
8784 ---------------------------------
8786 procedure Instantiate_Subprogram_Body
8787 (Body_Info
: Pending_Body_Info
;
8788 Body_Optional
: Boolean := False)
8790 Act_Decl
: constant Node_Id
:= Body_Info
.Act_Decl
;
8791 Inst_Node
: constant Node_Id
:= Body_Info
.Inst_Node
;
8792 Loc
: constant Source_Ptr
:= Sloc
(Inst_Node
);
8793 Gen_Id
: constant Node_Id
:= Name
(Inst_Node
);
8794 Gen_Unit
: constant Entity_Id
:= Get_Generic_Entity
(Inst_Node
);
8795 Gen_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Gen_Unit
);
8796 Anon_Id
: constant Entity_Id
:=
8797 Defining_Unit_Name
(Specification
(Act_Decl
));
8798 Pack_Id
: constant Entity_Id
:=
8799 Defining_Unit_Name
(Parent
(Act_Decl
));
8802 Gen_Body_Id
: Node_Id
;
8804 Pack_Body
: Node_Id
;
8805 Prev_Formal
: Entity_Id
;
8807 Unit_Renaming
: Node_Id
;
8809 Parent_Installed
: Boolean := False;
8810 Save_Style_Check
: constant Boolean := Style_Check
;
8813 Gen_Body_Id
:= Corresponding_Body
(Gen_Decl
);
8815 -- Subprogram body may have been created already because of an inline
8816 -- pragma, or because of multiple elaborations of the enclosing package
8817 -- when several instances of the subprogram appear in the main unit.
8819 if Present
(Corresponding_Body
(Act_Decl
)) then
8823 Expander_Mode_Save_And_Set
(Body_Info
.Expander_Status
);
8825 -- Re-establish the state of information on which checks are suppressed.
8826 -- This information was set in Body_Info at the point of instantiation,
8827 -- and now we restore it so that the instance is compiled using the
8828 -- check status at the instantiation (RM 11.5 (7.2/2), AI95-00224-01).
8830 Local_Suppress_Stack_Top
:= Body_Info
.Local_Suppress_Stack_Top
;
8831 Scope_Suppress
:= Body_Info
.Scope_Suppress
;
8833 if No
(Gen_Body_Id
) then
8835 -- For imported generic subprogram, no body to compile, complete
8836 -- the spec entity appropriately.
8838 if Is_Imported
(Gen_Unit
) then
8839 Set_Is_Imported
(Anon_Id
);
8840 Set_First_Rep_Item
(Anon_Id
, First_Rep_Item
(Gen_Unit
));
8841 Set_Interface_Name
(Anon_Id
, Interface_Name
(Gen_Unit
));
8842 Set_Convention
(Anon_Id
, Convention
(Gen_Unit
));
8843 Set_Has_Completion
(Anon_Id
);
8846 -- For other cases, compile the body
8849 Load_Parent_Of_Generic
8850 (Inst_Node
, Specification
(Gen_Decl
), Body_Optional
);
8851 Gen_Body_Id
:= Corresponding_Body
(Gen_Decl
);
8855 Instantiation_Node
:= Inst_Node
;
8857 if Present
(Gen_Body_Id
) then
8858 Gen_Body
:= Unit_Declaration_Node
(Gen_Body_Id
);
8860 if Nkind
(Gen_Body
) = N_Subprogram_Body_Stub
then
8862 -- Either body is not present, or context is non-expanding, as
8863 -- when compiling a subunit. Mark the instance as completed, and
8864 -- diagnose a missing body when needed.
8867 and then Operating_Mode
= Generate_Code
8870 ("missing proper body for instantiation", Gen_Body
);
8873 Set_Has_Completion
(Anon_Id
);
8877 Save_Env
(Gen_Unit
, Anon_Id
);
8878 Style_Check
:= False;
8879 Current_Sem_Unit
:= Body_Info
.Current_Sem_Unit
;
8880 Create_Instantiation_Source
8888 (Original_Node
(Gen_Body
), Empty
, Instantiating
=> True);
8890 -- Create proper defining name for the body, to correspond to
8891 -- the one in the spec.
8893 Set_Defining_Unit_Name
(Specification
(Act_Body
),
8894 Make_Defining_Identifier
8895 (Sloc
(Defining_Entity
(Inst_Node
)), Chars
(Anon_Id
)));
8896 Set_Corresponding_Spec
(Act_Body
, Anon_Id
);
8897 Set_Has_Completion
(Anon_Id
);
8898 Check_Generic_Actuals
(Pack_Id
, False);
8900 -- Generate a reference to link the visible subprogram instance to
8901 -- the generic body, which for navigation purposes is the only
8902 -- available source for the instance.
8905 (Related_Instance
(Pack_Id
),
8906 Gen_Body_Id
, 'b', Set_Ref
=> False, Force
=> True);
8908 -- If it is a child unit, make the parent instance (which is an
8909 -- instance of the parent of the generic) visible. The parent
8910 -- instance is the prefix of the name of the generic unit.
8912 if Ekind
(Scope
(Gen_Unit
)) = E_Generic_Package
8913 and then Nkind
(Gen_Id
) = N_Expanded_Name
8915 Install_Parent
(Entity
(Prefix
(Gen_Id
)), In_Body
=> True);
8916 Parent_Installed
:= True;
8918 elsif Is_Child_Unit
(Gen_Unit
) then
8919 Install_Parent
(Scope
(Gen_Unit
), In_Body
=> True);
8920 Parent_Installed
:= True;
8923 -- Inside its body, a reference to the generic unit is a reference
8924 -- to the instance. The corresponding renaming is the first
8925 -- declaration in the body.
8928 Make_Subprogram_Renaming_Declaration
(Loc
,
8931 Specification
(Original_Node
(Gen_Body
)),
8933 Instantiating
=> True),
8934 Name
=> New_Occurrence_Of
(Anon_Id
, Loc
));
8936 -- If there is a formal subprogram with the same name as the unit
8937 -- itself, do not add this renaming declaration. This is a temporary
8938 -- fix for one ACVC test. ???
8940 Prev_Formal
:= First_Entity
(Pack_Id
);
8941 while Present
(Prev_Formal
) loop
8942 if Chars
(Prev_Formal
) = Chars
(Gen_Unit
)
8943 and then Is_Overloadable
(Prev_Formal
)
8948 Next_Entity
(Prev_Formal
);
8951 if Present
(Prev_Formal
) then
8952 Decls
:= New_List
(Act_Body
);
8954 Decls
:= New_List
(Unit_Renaming
, Act_Body
);
8957 -- The subprogram body is placed in the body of a dummy package body,
8958 -- whose spec contains the subprogram declaration as well as the
8959 -- renaming declarations for the generic parameters.
8961 Pack_Body
:= Make_Package_Body
(Loc
,
8962 Defining_Unit_Name
=> New_Copy
(Pack_Id
),
8963 Declarations
=> Decls
);
8965 Set_Corresponding_Spec
(Pack_Body
, Pack_Id
);
8967 -- If the instantiation is a library unit, then build resulting
8968 -- compilation unit nodes for the instance. The declaration of
8969 -- the enclosing package is the grandparent of the subprogram
8970 -- declaration. First replace the instantiation node as the unit
8971 -- of the corresponding compilation.
8973 if Nkind
(Parent
(Inst_Node
)) = N_Compilation_Unit
then
8974 if Parent
(Inst_Node
) = Cunit
(Main_Unit
) then
8975 Set_Unit
(Parent
(Inst_Node
), Inst_Node
);
8976 Build_Instance_Compilation_Unit_Nodes
8977 (Inst_Node
, Pack_Body
, Parent
(Parent
(Act_Decl
)));
8978 Analyze
(Inst_Node
);
8980 Set_Parent
(Pack_Body
, Parent
(Inst_Node
));
8981 Analyze
(Pack_Body
);
8985 Insert_Before
(Inst_Node
, Pack_Body
);
8986 Mark_Rewrite_Insertion
(Pack_Body
);
8987 Analyze
(Pack_Body
);
8989 if Expander_Active
then
8990 Freeze_Subprogram_Body
(Inst_Node
, Gen_Body
, Pack_Id
);
8994 Inherit_Context
(Gen_Body
, Inst_Node
);
8996 Restore_Private_Views
(Pack_Id
, False);
8998 if Parent_Installed
then
8999 Remove_Parent
(In_Body
=> True);
9003 Style_Check
:= Save_Style_Check
;
9005 -- Body not found. Error was emitted already. If there were no previous
9006 -- errors, this may be an instance whose scope is a premature instance.
9007 -- In that case we must insure that the (legal) program does raise
9008 -- program error if executed. We generate a subprogram body for this
9009 -- purpose. See DEC ac30vso.
9011 -- Should not reference proprietary DEC tests in comments ???
9013 elsif Serious_Errors_Detected
= 0
9014 and then Nkind
(Parent
(Inst_Node
)) /= N_Compilation_Unit
9016 if Body_Optional
then
9019 elsif Ekind
(Anon_Id
) = E_Procedure
then
9021 Make_Subprogram_Body
(Loc
,
9023 Make_Procedure_Specification
(Loc
,
9024 Defining_Unit_Name
=>
9025 Make_Defining_Identifier
(Loc
, Chars
(Anon_Id
)),
9026 Parameter_Specifications
=>
9028 (Parameter_Specifications
(Parent
(Anon_Id
)))),
9030 Declarations
=> Empty_List
,
9031 Handled_Statement_Sequence
=>
9032 Make_Handled_Sequence_Of_Statements
(Loc
,
9035 Make_Raise_Program_Error
(Loc
,
9037 PE_Access_Before_Elaboration
))));
9041 Make_Raise_Program_Error
(Loc
,
9042 Reason
=> PE_Access_Before_Elaboration
);
9044 Set_Etype
(Ret_Expr
, (Etype
(Anon_Id
)));
9045 Set_Analyzed
(Ret_Expr
);
9048 Make_Subprogram_Body
(Loc
,
9050 Make_Function_Specification
(Loc
,
9051 Defining_Unit_Name
=>
9052 Make_Defining_Identifier
(Loc
, Chars
(Anon_Id
)),
9053 Parameter_Specifications
=>
9055 (Parameter_Specifications
(Parent
(Anon_Id
))),
9056 Result_Definition
=>
9057 New_Occurrence_Of
(Etype
(Anon_Id
), Loc
)),
9059 Declarations
=> Empty_List
,
9060 Handled_Statement_Sequence
=>
9061 Make_Handled_Sequence_Of_Statements
(Loc
,
9064 (Make_Simple_Return_Statement
(Loc
, Ret_Expr
))));
9067 Pack_Body
:= Make_Package_Body
(Loc
,
9068 Defining_Unit_Name
=> New_Copy
(Pack_Id
),
9069 Declarations
=> New_List
(Act_Body
));
9071 Insert_After
(Inst_Node
, Pack_Body
);
9072 Set_Corresponding_Spec
(Pack_Body
, Pack_Id
);
9073 Analyze
(Pack_Body
);
9076 Expander_Mode_Restore
;
9077 end Instantiate_Subprogram_Body
;
9079 ----------------------
9080 -- Instantiate_Type --
9081 ----------------------
9083 function Instantiate_Type
9086 Analyzed_Formal
: Node_Id
;
9087 Actual_Decls
: List_Id
) return List_Id
9089 Gen_T
: constant Entity_Id
:= Defining_Identifier
(Formal
);
9090 A_Gen_T
: constant Entity_Id
:=
9091 Defining_Identifier
(Analyzed_Formal
);
9092 Ancestor
: Entity_Id
:= Empty
;
9093 Def
: constant Node_Id
:= Formal_Type_Definition
(Formal
);
9095 Decl_Node
: Node_Id
;
9096 Decl_Nodes
: List_Id
;
9100 procedure Validate_Array_Type_Instance
;
9101 procedure Validate_Access_Subprogram_Instance
;
9102 procedure Validate_Access_Type_Instance
;
9103 procedure Validate_Derived_Type_Instance
;
9104 procedure Validate_Derived_Interface_Type_Instance
;
9105 procedure Validate_Interface_Type_Instance
;
9106 procedure Validate_Private_Type_Instance
;
9107 -- These procedures perform validation tests for the named case
9109 function Subtypes_Match
(Gen_T
, Act_T
: Entity_Id
) return Boolean;
9110 -- Check that base types are the same and that the subtypes match
9111 -- statically. Used in several of the above.
9113 --------------------
9114 -- Subtypes_Match --
9115 --------------------
9117 function Subtypes_Match
(Gen_T
, Act_T
: Entity_Id
) return Boolean is
9118 T
: constant Entity_Id
:= Get_Instance_Of
(Gen_T
);
9121 return (Base_Type
(T
) = Base_Type
(Act_T
)
9122 and then Subtypes_Statically_Match
(T
, Act_T
))
9124 or else (Is_Class_Wide_Type
(Gen_T
)
9125 and then Is_Class_Wide_Type
(Act_T
)
9128 (Get_Instance_Of
(Root_Type
(Gen_T
)),
9132 ((Ekind
(Gen_T
) = E_Anonymous_Access_Subprogram_Type
9133 or else Ekind
(Gen_T
) = E_Anonymous_Access_Type
)
9134 and then Ekind
(Act_T
) = Ekind
(Gen_T
)
9136 Subtypes_Statically_Match
9137 (Designated_Type
(Gen_T
), Designated_Type
(Act_T
)));
9140 -----------------------------------------
9141 -- Validate_Access_Subprogram_Instance --
9142 -----------------------------------------
9144 procedure Validate_Access_Subprogram_Instance
is
9146 if not Is_Access_Type
(Act_T
)
9147 or else Ekind
(Designated_Type
(Act_T
)) /= E_Subprogram_Type
9150 ("expect access type in instantiation of &", Actual
, Gen_T
);
9151 Abandon_Instantiation
(Actual
);
9154 Check_Mode_Conformant
9155 (Designated_Type
(Act_T
),
9156 Designated_Type
(A_Gen_T
),
9160 if Ekind
(Base_Type
(Act_T
)) = E_Access_Protected_Subprogram_Type
then
9161 if Ekind
(A_Gen_T
) = E_Access_Subprogram_Type
then
9163 ("protected access type not allowed for formal &",
9167 elsif Ekind
(A_Gen_T
) = E_Access_Protected_Subprogram_Type
then
9169 ("expect protected access type for formal &",
9172 end Validate_Access_Subprogram_Instance
;
9174 -----------------------------------
9175 -- Validate_Access_Type_Instance --
9176 -----------------------------------
9178 procedure Validate_Access_Type_Instance
is
9179 Desig_Type
: constant Entity_Id
:=
9180 Find_Actual_Type
(Designated_Type
(A_Gen_T
), A_Gen_T
);
9181 Desig_Act
: Entity_Id
;
9184 if not Is_Access_Type
(Act_T
) then
9186 ("expect access type in instantiation of &", Actual
, Gen_T
);
9187 Abandon_Instantiation
(Actual
);
9190 if Is_Access_Constant
(A_Gen_T
) then
9191 if not Is_Access_Constant
(Act_T
) then
9193 ("actual type must be access-to-constant type", Actual
);
9194 Abandon_Instantiation
(Actual
);
9197 if Is_Access_Constant
(Act_T
) then
9199 ("actual type must be access-to-variable type", Actual
);
9200 Abandon_Instantiation
(Actual
);
9202 elsif Ekind
(A_Gen_T
) = E_General_Access_Type
9203 and then Ekind
(Base_Type
(Act_T
)) /= E_General_Access_Type
9205 Error_Msg_N
("actual must be general access type!", Actual
);
9206 Error_Msg_NE
("add ALL to }!", Actual
, Act_T
);
9207 Abandon_Instantiation
(Actual
);
9211 -- The designated subtypes, that is to say the subtypes introduced
9212 -- by an access type declaration (and not by a subtype declaration)
9215 Desig_Act
:= Designated_Type
(Base_Type
(Act_T
));
9217 -- The designated type may have been introduced through a limited_
9218 -- with clause, in which case retrieve the non-limited view. This
9219 -- applies to incomplete types as well as to class-wide types.
9221 if From_With_Type
(Desig_Act
) then
9222 Desig_Act
:= Available_View
(Desig_Act
);
9225 if not Subtypes_Match
9226 (Desig_Type
, Desig_Act
) then
9228 ("designated type of actual does not match that of formal &",
9230 Abandon_Instantiation
(Actual
);
9232 elsif Is_Access_Type
(Designated_Type
(Act_T
))
9233 and then Is_Constrained
(Designated_Type
(Designated_Type
(Act_T
)))
9235 Is_Constrained
(Designated_Type
(Desig_Type
))
9238 ("designated type of actual does not match that of formal &",
9240 Abandon_Instantiation
(Actual
);
9243 -- Ada 2005: null-exclusion indicators of the two types must agree
9245 if Can_Never_Be_Null
(A_Gen_T
) /= Can_Never_Be_Null
(Act_T
) then
9247 ("non null exclusion of actual and formal & do not match",
9250 end Validate_Access_Type_Instance
;
9252 ----------------------------------
9253 -- Validate_Array_Type_Instance --
9254 ----------------------------------
9256 procedure Validate_Array_Type_Instance
is
9261 function Formal_Dimensions
return Int
;
9262 -- Count number of dimensions in array type formal
9264 -----------------------
9265 -- Formal_Dimensions --
9266 -----------------------
9268 function Formal_Dimensions
return Int
is
9273 if Nkind
(Def
) = N_Constrained_Array_Definition
then
9274 Index
:= First
(Discrete_Subtype_Definitions
(Def
));
9276 Index
:= First
(Subtype_Marks
(Def
));
9279 while Present
(Index
) loop
9285 end Formal_Dimensions
;
9287 -- Start of processing for Validate_Array_Type_Instance
9290 if not Is_Array_Type
(Act_T
) then
9292 ("expect array type in instantiation of &", Actual
, Gen_T
);
9293 Abandon_Instantiation
(Actual
);
9295 elsif Nkind
(Def
) = N_Constrained_Array_Definition
then
9296 if not (Is_Constrained
(Act_T
)) then
9298 ("expect constrained array in instantiation of &",
9300 Abandon_Instantiation
(Actual
);
9304 if Is_Constrained
(Act_T
) then
9306 ("expect unconstrained array in instantiation of &",
9308 Abandon_Instantiation
(Actual
);
9312 if Formal_Dimensions
/= Number_Dimensions
(Act_T
) then
9314 ("dimensions of actual do not match formal &", Actual
, Gen_T
);
9315 Abandon_Instantiation
(Actual
);
9318 I1
:= First_Index
(A_Gen_T
);
9319 I2
:= First_Index
(Act_T
);
9320 for J
in 1 .. Formal_Dimensions
loop
9322 -- If the indices of the actual were given by a subtype_mark,
9323 -- the index was transformed into a range attribute. Retrieve
9324 -- the original type mark for checking.
9326 if Is_Entity_Name
(Original_Node
(I2
)) then
9327 T2
:= Entity
(Original_Node
(I2
));
9332 if not Subtypes_Match
9333 (Find_Actual_Type
(Etype
(I1
), A_Gen_T
), T2
)
9336 ("index types of actual do not match those of formal &",
9338 Abandon_Instantiation
(Actual
);
9345 -- Check matching subtypes. Note that there are complex visibility
9346 -- issues when the generic is a child unit and some aspect of the
9347 -- generic type is declared in a parent unit of the generic. We do
9348 -- the test to handle this special case only after a direct check
9349 -- for static matching has failed.
9352 (Component_Type
(A_Gen_T
), Component_Type
(Act_T
))
9353 or else Subtypes_Match
9354 (Find_Actual_Type
(Component_Type
(A_Gen_T
), A_Gen_T
),
9355 Component_Type
(Act_T
))
9360 ("component subtype of actual does not match that of formal &",
9362 Abandon_Instantiation
(Actual
);
9365 if Has_Aliased_Components
(A_Gen_T
)
9366 and then not Has_Aliased_Components
(Act_T
)
9369 ("actual must have aliased components to match formal type &",
9372 end Validate_Array_Type_Instance
;
9374 -----------------------------------------------
9375 -- Validate_Derived_Interface_Type_Instance --
9376 -----------------------------------------------
9378 procedure Validate_Derived_Interface_Type_Instance
is
9379 Par
: constant Entity_Id
:= Entity
(Subtype_Indication
(Def
));
9383 -- First apply interface instance checks
9385 Validate_Interface_Type_Instance
;
9387 -- Verify that immediate parent interface is an ancestor of
9391 and then not Interface_Present_In_Ancestor
(Act_T
, Par
)
9394 ("interface actual must include progenitor&", Actual
, Par
);
9397 -- Now verify that the actual includes all other ancestors of
9400 Elmt
:= First_Elmt
(Interfaces
(A_Gen_T
));
9401 while Present
(Elmt
) loop
9402 if not Interface_Present_In_Ancestor
9403 (Act_T
, Get_Instance_Of
(Node
(Elmt
)))
9406 ("interface actual must include progenitor&",
9407 Actual
, Node
(Elmt
));
9412 end Validate_Derived_Interface_Type_Instance
;
9414 ------------------------------------
9415 -- Validate_Derived_Type_Instance --
9416 ------------------------------------
9418 procedure Validate_Derived_Type_Instance
is
9419 Actual_Discr
: Entity_Id
;
9420 Ancestor_Discr
: Entity_Id
;
9423 -- If the parent type in the generic declaration is itself a previous
9424 -- formal type, then it is local to the generic and absent from the
9425 -- analyzed generic definition. In that case the ancestor is the
9426 -- instance of the formal (which must have been instantiated
9427 -- previously), unless the ancestor is itself a formal derived type.
9428 -- In this latter case (which is the subject of Corrigendum 8652/0038
9429 -- (AI-202) the ancestor of the formals is the ancestor of its
9430 -- parent. Otherwise, the analyzed generic carries the parent type.
9431 -- If the parent type is defined in a previous formal package, then
9432 -- the scope of that formal package is that of the generic type
9433 -- itself, and it has already been mapped into the corresponding type
9434 -- in the actual package.
9436 -- Common case: parent type defined outside of the generic
9438 if Is_Entity_Name
(Subtype_Mark
(Def
))
9439 and then Present
(Entity
(Subtype_Mark
(Def
)))
9441 Ancestor
:= Get_Instance_Of
(Entity
(Subtype_Mark
(Def
)));
9443 -- Check whether parent is defined in a previous formal package
9446 Scope
(Scope
(Base_Type
(Etype
(A_Gen_T
)))) = Scope
(A_Gen_T
)
9449 Get_Instance_Of
(Base_Type
(Etype
(A_Gen_T
)));
9451 -- The type may be a local derivation, or a type extension of a
9452 -- previous formal, or of a formal of a parent package.
9454 elsif Is_Derived_Type
(Get_Instance_Of
(A_Gen_T
))
9456 Ekind
(Get_Instance_Of
(A_Gen_T
)) = E_Record_Type_With_Private
9458 -- Check whether the parent is another derived formal type in the
9459 -- same generic unit.
9461 if Etype
(A_Gen_T
) /= A_Gen_T
9462 and then Is_Generic_Type
(Etype
(A_Gen_T
))
9463 and then Scope
(Etype
(A_Gen_T
)) = Scope
(A_Gen_T
)
9464 and then Etype
(Etype
(A_Gen_T
)) /= Etype
(A_Gen_T
)
9466 -- Locate ancestor of parent from the subtype declaration
9467 -- created for the actual.
9473 Decl
:= First
(Actual_Decls
);
9474 while Present
(Decl
) loop
9475 if Nkind
(Decl
) = N_Subtype_Declaration
9476 and then Chars
(Defining_Identifier
(Decl
)) =
9477 Chars
(Etype
(A_Gen_T
))
9479 Ancestor
:= Generic_Parent_Type
(Decl
);
9487 pragma Assert
(Present
(Ancestor
));
9491 Get_Instance_Of
(Base_Type
(Get_Instance_Of
(A_Gen_T
)));
9495 Ancestor
:= Get_Instance_Of
(Etype
(Base_Type
(A_Gen_T
)));
9498 -- If the formal derived type has pragma Preelaborable_Initialization
9499 -- then the actual type must have preelaborable initialization.
9501 if Known_To_Have_Preelab_Init
(A_Gen_T
)
9502 and then not Has_Preelaborable_Initialization
(Act_T
)
9505 ("actual for & must have preelaborable initialization",
9509 -- Ada 2005 (AI-251)
9511 if Ada_Version
>= Ada_05
9512 and then Is_Interface
(Ancestor
)
9514 if not Interface_Present_In_Ancestor
(Act_T
, Ancestor
) then
9516 ("(Ada 2005) expected type implementing & in instantiation",
9520 elsif not Is_Ancestor
(Base_Type
(Ancestor
), Act_T
) then
9522 ("expect type derived from & in instantiation",
9523 Actual
, First_Subtype
(Ancestor
));
9524 Abandon_Instantiation
(Actual
);
9527 -- Ada 2005 (AI-443): Synchronized formal derived type checks. Note
9528 -- that the formal type declaration has been rewritten as a private
9531 if Ada_Version
>= Ada_05
9532 and then Nkind
(Parent
(A_Gen_T
)) = N_Private_Extension_Declaration
9533 and then Synchronized_Present
(Parent
(A_Gen_T
))
9535 -- The actual must be a synchronized tagged type
9537 if not Is_Tagged_Type
(Act_T
) then
9539 ("actual of synchronized type must be tagged", Actual
);
9540 Abandon_Instantiation
(Actual
);
9542 elsif Nkind
(Parent
(Act_T
)) = N_Full_Type_Declaration
9543 and then Nkind
(Type_Definition
(Parent
(Act_T
))) =
9544 N_Derived_Type_Definition
9545 and then not Synchronized_Present
(Type_Definition
9549 ("actual of synchronized type must be synchronized", Actual
);
9550 Abandon_Instantiation
(Actual
);
9554 -- Perform atomic/volatile checks (RM C.6(12))
9556 if Is_Atomic
(Act_T
) and then not Is_Atomic
(Ancestor
) then
9558 ("cannot have atomic actual type for non-atomic formal type",
9561 elsif Is_Volatile
(Act_T
)
9562 and then not Is_Volatile
(Ancestor
)
9563 and then Is_By_Reference_Type
(Ancestor
)
9566 ("cannot have volatile actual type for non-volatile formal type",
9570 -- It should not be necessary to check for unknown discriminants on
9571 -- Formal, but for some reason Has_Unknown_Discriminants is false for
9572 -- A_Gen_T, so Is_Indefinite_Subtype incorrectly returns False. This
9573 -- needs fixing. ???
9575 if not Is_Indefinite_Subtype
(A_Gen_T
)
9576 and then not Unknown_Discriminants_Present
(Formal
)
9577 and then Is_Indefinite_Subtype
(Act_T
)
9580 ("actual subtype must be constrained", Actual
);
9581 Abandon_Instantiation
(Actual
);
9584 if not Unknown_Discriminants_Present
(Formal
) then
9585 if Is_Constrained
(Ancestor
) then
9586 if not Is_Constrained
(Act_T
) then
9588 ("actual subtype must be constrained", Actual
);
9589 Abandon_Instantiation
(Actual
);
9592 -- Ancestor is unconstrained, Check if generic formal and actual
9593 -- agree on constrainedness. The check only applies to array types
9594 -- and discriminated types.
9596 elsif Is_Constrained
(Act_T
) then
9597 if Ekind
(Ancestor
) = E_Access_Type
9599 (not Is_Constrained
(A_Gen_T
)
9600 and then Is_Composite_Type
(A_Gen_T
))
9603 ("actual subtype must be unconstrained", Actual
);
9604 Abandon_Instantiation
(Actual
);
9607 -- A class-wide type is only allowed if the formal has unknown
9610 elsif Is_Class_Wide_Type
(Act_T
)
9611 and then not Has_Unknown_Discriminants
(Ancestor
)
9614 ("actual for & cannot be a class-wide type", Actual
, Gen_T
);
9615 Abandon_Instantiation
(Actual
);
9617 -- Otherwise, the formal and actual shall have the same number
9618 -- of discriminants and each discriminant of the actual must
9619 -- correspond to a discriminant of the formal.
9621 elsif Has_Discriminants
(Act_T
)
9622 and then not Has_Unknown_Discriminants
(Act_T
)
9623 and then Has_Discriminants
(Ancestor
)
9625 Actual_Discr
:= First_Discriminant
(Act_T
);
9626 Ancestor_Discr
:= First_Discriminant
(Ancestor
);
9627 while Present
(Actual_Discr
)
9628 and then Present
(Ancestor_Discr
)
9630 if Base_Type
(Act_T
) /= Base_Type
(Ancestor
) and then
9631 No
(Corresponding_Discriminant
(Actual_Discr
))
9634 ("discriminant & does not correspond " &
9635 "to ancestor discriminant", Actual
, Actual_Discr
);
9636 Abandon_Instantiation
(Actual
);
9639 Next_Discriminant
(Actual_Discr
);
9640 Next_Discriminant
(Ancestor_Discr
);
9643 if Present
(Actual_Discr
) or else Present
(Ancestor_Discr
) then
9645 ("actual for & must have same number of discriminants",
9647 Abandon_Instantiation
(Actual
);
9650 -- This case should be caught by the earlier check for
9651 -- constrainedness, but the check here is added for completeness.
9653 elsif Has_Discriminants
(Act_T
)
9654 and then not Has_Unknown_Discriminants
(Act_T
)
9657 ("actual for & must not have discriminants", Actual
, Gen_T
);
9658 Abandon_Instantiation
(Actual
);
9660 elsif Has_Discriminants
(Ancestor
) then
9662 ("actual for & must have known discriminants", Actual
, Gen_T
);
9663 Abandon_Instantiation
(Actual
);
9666 if not Subtypes_Statically_Compatible
(Act_T
, Ancestor
) then
9668 ("constraint on actual is incompatible with formal", Actual
);
9669 Abandon_Instantiation
(Actual
);
9673 -- If the formal and actual types are abstract, check that there
9674 -- are no abstract primitives of the actual type that correspond to
9675 -- nonabstract primitives of the formal type (second sentence of
9678 if Is_Abstract_Type
(A_Gen_T
) and then Is_Abstract_Type
(Act_T
) then
9679 Check_Abstract_Primitives
: declare
9680 Gen_Prims
: constant Elist_Id
:=
9681 Primitive_Operations
(A_Gen_T
);
9683 Gen_Subp
: Entity_Id
;
9684 Anc_Subp
: Entity_Id
;
9685 Anc_Formal
: Entity_Id
;
9686 Anc_F_Type
: Entity_Id
;
9688 Act_Prims
: constant Elist_Id
:= Primitive_Operations
(Act_T
);
9690 Act_Subp
: Entity_Id
;
9691 Act_Formal
: Entity_Id
;
9692 Act_F_Type
: Entity_Id
;
9694 Subprograms_Correspond
: Boolean;
9696 function Is_Tagged_Ancestor
(T1
, T2
: Entity_Id
) return Boolean;
9697 -- Returns true if T2 is derived directly or indirectly from
9698 -- T1, including derivations from interfaces. T1 and T2 are
9699 -- required to be specific tagged base types.
9701 ------------------------
9702 -- Is_Tagged_Ancestor --
9703 ------------------------
9705 function Is_Tagged_Ancestor
(T1
, T2
: Entity_Id
) return Boolean
9707 Intfc_Elmt
: Elmt_Id
;
9710 -- The predicate is satisfied if the types are the same
9715 -- If we've reached the top of the derivation chain then
9716 -- we know that T1 is not an ancestor of T2.
9718 elsif Etype
(T2
) = T2
then
9721 -- Proceed to check T2's immediate parent
9723 elsif Is_Ancestor
(T1
, Base_Type
(Etype
(T2
))) then
9726 -- Finally, check to see if T1 is an ancestor of any of T2's
9730 Intfc_Elmt
:= First_Elmt
(Interfaces
(T2
));
9731 while Present
(Intfc_Elmt
) loop
9732 if Is_Ancestor
(T1
, Node
(Intfc_Elmt
)) then
9736 Next_Elmt
(Intfc_Elmt
);
9741 end Is_Tagged_Ancestor
;
9743 -- Start of processing for Check_Abstract_Primitives
9746 -- Loop over all of the formal derived type's primitives
9748 Gen_Elmt
:= First_Elmt
(Gen_Prims
);
9749 while Present
(Gen_Elmt
) loop
9750 Gen_Subp
:= Node
(Gen_Elmt
);
9752 -- If the primitive of the formal is not abstract, then
9753 -- determine whether there is a corresponding primitive of
9754 -- the actual type that's abstract.
9756 if not Is_Abstract_Subprogram
(Gen_Subp
) then
9757 Act_Elmt
:= First_Elmt
(Act_Prims
);
9758 while Present
(Act_Elmt
) loop
9759 Act_Subp
:= Node
(Act_Elmt
);
9761 -- If we find an abstract primitive of the actual,
9762 -- then we need to test whether it corresponds to the
9763 -- subprogram from which the generic formal primitive
9766 if Is_Abstract_Subprogram
(Act_Subp
) then
9767 Anc_Subp
:= Alias
(Gen_Subp
);
9769 -- Test whether we have a corresponding primitive
9770 -- by comparing names, kinds, formal types, and
9773 if Chars
(Anc_Subp
) = Chars
(Act_Subp
)
9774 and then Ekind
(Anc_Subp
) = Ekind
(Act_Subp
)
9776 Anc_Formal
:= First_Formal
(Anc_Subp
);
9777 Act_Formal
:= First_Formal
(Act_Subp
);
9778 while Present
(Anc_Formal
)
9779 and then Present
(Act_Formal
)
9781 Anc_F_Type
:= Etype
(Anc_Formal
);
9782 Act_F_Type
:= Etype
(Act_Formal
);
9784 if Ekind
(Anc_F_Type
)
9785 = E_Anonymous_Access_Type
9787 Anc_F_Type
:= Designated_Type
(Anc_F_Type
);
9789 if Ekind
(Act_F_Type
)
9790 = E_Anonymous_Access_Type
9793 Designated_Type
(Act_F_Type
);
9799 Ekind
(Act_F_Type
) = E_Anonymous_Access_Type
9804 Anc_F_Type
:= Base_Type
(Anc_F_Type
);
9805 Act_F_Type
:= Base_Type
(Act_F_Type
);
9807 -- If the formal is controlling, then the
9808 -- the type of the actual primitive's formal
9809 -- must be derived directly or indirectly
9810 -- from the type of the ancestor primitive's
9813 if Is_Controlling_Formal
(Anc_Formal
) then
9814 if not Is_Tagged_Ancestor
9815 (Anc_F_Type
, Act_F_Type
)
9820 -- Otherwise the types of the formals must
9823 elsif Anc_F_Type
/= Act_F_Type
then
9827 Next_Entity
(Anc_Formal
);
9828 Next_Entity
(Act_Formal
);
9831 -- If we traversed through all of the formals
9832 -- then so far the subprograms correspond, so
9833 -- now check that any result types correspond.
9836 and then No
(Act_Formal
)
9838 Subprograms_Correspond
:= True;
9840 if Ekind
(Act_Subp
) = E_Function
then
9841 Anc_F_Type
:= Etype
(Anc_Subp
);
9842 Act_F_Type
:= Etype
(Act_Subp
);
9844 if Ekind
(Anc_F_Type
)
9845 = E_Anonymous_Access_Type
9848 Designated_Type
(Anc_F_Type
);
9850 if Ekind
(Act_F_Type
)
9851 = E_Anonymous_Access_Type
9854 Designated_Type
(Act_F_Type
);
9856 Subprograms_Correspond
:= False;
9861 = E_Anonymous_Access_Type
9863 Subprograms_Correspond
:= False;
9866 Anc_F_Type
:= Base_Type
(Anc_F_Type
);
9867 Act_F_Type
:= Base_Type
(Act_F_Type
);
9869 -- Now either the result types must be
9870 -- the same or, if the result type is
9871 -- controlling, the result type of the
9872 -- actual primitive must descend from the
9873 -- result type of the ancestor primitive.
9875 if Subprograms_Correspond
9876 and then Anc_F_Type
/= Act_F_Type
9878 Has_Controlling_Result
(Anc_Subp
)
9880 not Is_Tagged_Ancestor
9881 (Anc_F_Type
, Act_F_Type
)
9883 Subprograms_Correspond
:= False;
9887 -- Found a matching subprogram belonging to
9888 -- formal ancestor type, so actual subprogram
9889 -- corresponds and this violates 3.9.3(9).
9891 if Subprograms_Correspond
then
9893 ("abstract subprogram & overrides " &
9894 "nonabstract subprogram of ancestor",
9902 Next_Elmt
(Act_Elmt
);
9906 Next_Elmt
(Gen_Elmt
);
9908 end Check_Abstract_Primitives
;
9911 -- Verify that limitedness matches. If parent is a limited
9912 -- interface then the generic formal is not unless declared
9913 -- explicitly so. If not declared limited, the actual cannot be
9914 -- limited (see AI05-0087).
9915 -- Disable check for now, limited interfaces implemented by
9916 -- protected types are common, Need to update tests ???
9918 if Is_Limited_Type
(Act_T
)
9919 and then not Is_Limited_Type
(A_Gen_T
)
9923 ("actual for non-limited & cannot be a limited type", Actual
,
9925 Explain_Limited_Type
(Act_T
, Actual
);
9926 Abandon_Instantiation
(Actual
);
9928 end Validate_Derived_Type_Instance
;
9930 --------------------------------------
9931 -- Validate_Interface_Type_Instance --
9932 --------------------------------------
9934 procedure Validate_Interface_Type_Instance
is
9936 if not Is_Interface
(Act_T
) then
9938 ("actual for formal interface type must be an interface",
9941 elsif Is_Limited_Type
(Act_T
) /= Is_Limited_Type
(A_Gen_T
)
9943 Is_Task_Interface
(A_Gen_T
) /= Is_Task_Interface
(Act_T
)
9945 Is_Protected_Interface
(A_Gen_T
) /=
9946 Is_Protected_Interface
(Act_T
)
9948 Is_Synchronized_Interface
(A_Gen_T
) /=
9949 Is_Synchronized_Interface
(Act_T
)
9952 ("actual for interface& does not match (RM 12.5.5(4))",
9955 end Validate_Interface_Type_Instance
;
9957 ------------------------------------
9958 -- Validate_Private_Type_Instance --
9959 ------------------------------------
9961 procedure Validate_Private_Type_Instance
is
9962 Formal_Discr
: Entity_Id
;
9963 Actual_Discr
: Entity_Id
;
9964 Formal_Subt
: Entity_Id
;
9967 if Is_Limited_Type
(Act_T
)
9968 and then not Is_Limited_Type
(A_Gen_T
)
9971 ("actual for non-limited & cannot be a limited type", Actual
,
9973 Explain_Limited_Type
(Act_T
, Actual
);
9974 Abandon_Instantiation
(Actual
);
9976 elsif Known_To_Have_Preelab_Init
(A_Gen_T
)
9977 and then not Has_Preelaborable_Initialization
(Act_T
)
9980 ("actual for & must have preelaborable initialization", Actual
,
9983 elsif Is_Indefinite_Subtype
(Act_T
)
9984 and then not Is_Indefinite_Subtype
(A_Gen_T
)
9985 and then Ada_Version
>= Ada_95
9988 ("actual for & must be a definite subtype", Actual
, Gen_T
);
9990 elsif not Is_Tagged_Type
(Act_T
)
9991 and then Is_Tagged_Type
(A_Gen_T
)
9994 ("actual for & must be a tagged type", Actual
, Gen_T
);
9996 elsif Has_Discriminants
(A_Gen_T
) then
9997 if not Has_Discriminants
(Act_T
) then
9999 ("actual for & must have discriminants", Actual
, Gen_T
);
10000 Abandon_Instantiation
(Actual
);
10002 elsif Is_Constrained
(Act_T
) then
10004 ("actual for & must be unconstrained", Actual
, Gen_T
);
10005 Abandon_Instantiation
(Actual
);
10008 Formal_Discr
:= First_Discriminant
(A_Gen_T
);
10009 Actual_Discr
:= First_Discriminant
(Act_T
);
10010 while Formal_Discr
/= Empty
loop
10011 if Actual_Discr
= Empty
then
10013 ("discriminants on actual do not match formal",
10015 Abandon_Instantiation
(Actual
);
10018 Formal_Subt
:= Get_Instance_Of
(Etype
(Formal_Discr
));
10020 -- Access discriminants match if designated types do
10022 if Ekind
(Base_Type
(Formal_Subt
)) = E_Anonymous_Access_Type
10023 and then (Ekind
(Base_Type
(Etype
(Actual_Discr
)))) =
10024 E_Anonymous_Access_Type
10027 (Designated_Type
(Base_Type
(Formal_Subt
))) =
10028 Designated_Type
(Base_Type
(Etype
(Actual_Discr
)))
10032 elsif Base_Type
(Formal_Subt
) /=
10033 Base_Type
(Etype
(Actual_Discr
))
10036 ("types of actual discriminants must match formal",
10038 Abandon_Instantiation
(Actual
);
10040 elsif not Subtypes_Statically_Match
10041 (Formal_Subt
, Etype
(Actual_Discr
))
10042 and then Ada_Version
>= Ada_95
10045 ("subtypes of actual discriminants must match formal",
10047 Abandon_Instantiation
(Actual
);
10050 Next_Discriminant
(Formal_Discr
);
10051 Next_Discriminant
(Actual_Discr
);
10054 if Actual_Discr
/= Empty
then
10056 ("discriminants on actual do not match formal",
10058 Abandon_Instantiation
(Actual
);
10065 end Validate_Private_Type_Instance
;
10067 -- Start of processing for Instantiate_Type
10070 if Get_Instance_Of
(A_Gen_T
) /= A_Gen_T
then
10071 Error_Msg_N
("duplicate instantiation of generic type", Actual
);
10072 return New_List
(Error
);
10074 elsif not Is_Entity_Name
(Actual
)
10075 or else not Is_Type
(Entity
(Actual
))
10078 ("expect valid subtype mark to instantiate &", Actual
, Gen_T
);
10079 Abandon_Instantiation
(Actual
);
10082 Act_T
:= Entity
(Actual
);
10084 -- Ada 2005 (AI-216): An Unchecked_Union subtype shall only be passed
10085 -- as a generic actual parameter if the corresponding formal type
10086 -- does not have a known_discriminant_part, or is a formal derived
10087 -- type that is an Unchecked_Union type.
10089 if Is_Unchecked_Union
(Base_Type
(Act_T
)) then
10090 if not Has_Discriminants
(A_Gen_T
)
10092 (Is_Derived_Type
(A_Gen_T
)
10094 Is_Unchecked_Union
(A_Gen_T
))
10098 Error_Msg_N
("Unchecked_Union cannot be the actual for a" &
10099 " discriminated formal type", Act_T
);
10104 -- Deal with fixed/floating restrictions
10106 if Is_Floating_Point_Type
(Act_T
) then
10107 Check_Restriction
(No_Floating_Point
, Actual
);
10108 elsif Is_Fixed_Point_Type
(Act_T
) then
10109 Check_Restriction
(No_Fixed_Point
, Actual
);
10112 -- Deal with error of using incomplete type as generic actual.
10113 -- This includes limited views of a type, even if the non-limited
10114 -- view may be available.
10116 if Ekind
(Act_T
) = E_Incomplete_Type
10117 or else (Is_Class_Wide_Type
(Act_T
)
10119 Ekind
(Root_Type
(Act_T
)) = E_Incomplete_Type
)
10121 if Is_Class_Wide_Type
(Act_T
)
10122 or else No
(Full_View
(Act_T
))
10124 Error_Msg_N
("premature use of incomplete type", Actual
);
10125 Abandon_Instantiation
(Actual
);
10127 Act_T
:= Full_View
(Act_T
);
10128 Set_Entity
(Actual
, Act_T
);
10130 if Has_Private_Component
(Act_T
) then
10132 ("premature use of type with private component", Actual
);
10136 -- Deal with error of premature use of private type as generic actual
10138 elsif Is_Private_Type
(Act_T
)
10139 and then Is_Private_Type
(Base_Type
(Act_T
))
10140 and then not Is_Generic_Type
(Act_T
)
10141 and then not Is_Derived_Type
(Act_T
)
10142 and then No
(Full_View
(Root_Type
(Act_T
)))
10144 Error_Msg_N
("premature use of private type", Actual
);
10146 elsif Has_Private_Component
(Act_T
) then
10148 ("premature use of type with private component", Actual
);
10151 Set_Instance_Of
(A_Gen_T
, Act_T
);
10153 -- If the type is generic, the class-wide type may also be used
10155 if Is_Tagged_Type
(A_Gen_T
)
10156 and then Is_Tagged_Type
(Act_T
)
10157 and then not Is_Class_Wide_Type
(A_Gen_T
)
10159 Set_Instance_Of
(Class_Wide_Type
(A_Gen_T
),
10160 Class_Wide_Type
(Act_T
));
10163 if not Is_Abstract_Type
(A_Gen_T
)
10164 and then Is_Abstract_Type
(Act_T
)
10167 ("actual of non-abstract formal cannot be abstract", Actual
);
10170 -- A generic scalar type is a first subtype for which we generate
10171 -- an anonymous base type. Indicate that the instance of this base
10172 -- is the base type of the actual.
10174 if Is_Scalar_Type
(A_Gen_T
) then
10175 Set_Instance_Of
(Etype
(A_Gen_T
), Etype
(Act_T
));
10179 if Error_Posted
(Act_T
) then
10182 case Nkind
(Def
) is
10183 when N_Formal_Private_Type_Definition
=>
10184 Validate_Private_Type_Instance
;
10186 when N_Formal_Derived_Type_Definition
=>
10187 Validate_Derived_Type_Instance
;
10189 when N_Formal_Discrete_Type_Definition
=>
10190 if not Is_Discrete_Type
(Act_T
) then
10192 ("expect discrete type in instantiation of&",
10194 Abandon_Instantiation
(Actual
);
10197 when N_Formal_Signed_Integer_Type_Definition
=>
10198 if not Is_Signed_Integer_Type
(Act_T
) then
10200 ("expect signed integer type in instantiation of&",
10202 Abandon_Instantiation
(Actual
);
10205 when N_Formal_Modular_Type_Definition
=>
10206 if not Is_Modular_Integer_Type
(Act_T
) then
10208 ("expect modular type in instantiation of &",
10210 Abandon_Instantiation
(Actual
);
10213 when N_Formal_Floating_Point_Definition
=>
10214 if not Is_Floating_Point_Type
(Act_T
) then
10216 ("expect float type in instantiation of &", Actual
, Gen_T
);
10217 Abandon_Instantiation
(Actual
);
10220 when N_Formal_Ordinary_Fixed_Point_Definition
=>
10221 if not Is_Ordinary_Fixed_Point_Type
(Act_T
) then
10223 ("expect ordinary fixed point type in instantiation of &",
10225 Abandon_Instantiation
(Actual
);
10228 when N_Formal_Decimal_Fixed_Point_Definition
=>
10229 if not Is_Decimal_Fixed_Point_Type
(Act_T
) then
10231 ("expect decimal type in instantiation of &",
10233 Abandon_Instantiation
(Actual
);
10236 when N_Array_Type_Definition
=>
10237 Validate_Array_Type_Instance
;
10239 when N_Access_To_Object_Definition
=>
10240 Validate_Access_Type_Instance
;
10242 when N_Access_Function_Definition |
10243 N_Access_Procedure_Definition
=>
10244 Validate_Access_Subprogram_Instance
;
10246 when N_Record_Definition
=>
10247 Validate_Interface_Type_Instance
;
10249 when N_Derived_Type_Definition
=>
10250 Validate_Derived_Interface_Type_Instance
;
10253 raise Program_Error
;
10258 Subt
:= New_Copy
(Gen_T
);
10260 -- Use adjusted sloc of subtype name as the location for other nodes in
10261 -- the subtype declaration.
10263 Loc
:= Sloc
(Subt
);
10266 Make_Subtype_Declaration
(Loc
,
10267 Defining_Identifier
=> Subt
,
10268 Subtype_Indication
=> New_Reference_To
(Act_T
, Loc
));
10270 if Is_Private_Type
(Act_T
) then
10271 Set_Has_Private_View
(Subtype_Indication
(Decl_Node
));
10273 elsif Is_Access_Type
(Act_T
)
10274 and then Is_Private_Type
(Designated_Type
(Act_T
))
10276 Set_Has_Private_View
(Subtype_Indication
(Decl_Node
));
10279 Decl_Nodes
:= New_List
(Decl_Node
);
10281 -- Flag actual derived types so their elaboration produces the
10282 -- appropriate renamings for the primitive operations of the ancestor.
10283 -- Flag actual for formal private types as well, to determine whether
10284 -- operations in the private part may override inherited operations.
10285 -- If the formal has an interface list, the ancestor is not the
10286 -- parent, but the analyzed formal that includes the interface
10287 -- operations of all its progenitors.
10289 if Nkind
(Def
) = N_Formal_Derived_Type_Definition
then
10290 if Present
(Interface_List
(Def
)) then
10291 Set_Generic_Parent_Type
(Decl_Node
, A_Gen_T
);
10293 Set_Generic_Parent_Type
(Decl_Node
, Ancestor
);
10296 elsif Nkind
(Def
) = N_Formal_Private_Type_Definition
then
10297 Set_Generic_Parent_Type
(Decl_Node
, Ancestor
);
10300 -- If the actual is a synchronized type that implements an interface,
10301 -- the primitive operations are attached to the corresponding record,
10302 -- and we have to treat it as an additional generic actual, so that its
10303 -- primitive operations become visible in the instance. The task or
10304 -- protected type itself does not carry primitive operations.
10306 if Is_Concurrent_Type
(Act_T
)
10307 and then Is_Tagged_Type
(Act_T
)
10308 and then Present
(Corresponding_Record_Type
(Act_T
))
10309 and then Present
(Ancestor
)
10310 and then Is_Interface
(Ancestor
)
10313 Corr_Rec
: constant Entity_Id
:=
10314 Corresponding_Record_Type
(Act_T
);
10315 New_Corr
: Entity_Id
;
10316 Corr_Decl
: Node_Id
;
10319 New_Corr
:= Make_Defining_Identifier
(Loc
,
10320 Chars
=> New_Internal_Name
('S'));
10322 Make_Subtype_Declaration
(Loc
,
10323 Defining_Identifier
=> New_Corr
,
10324 Subtype_Indication
=>
10325 New_Reference_To
(Corr_Rec
, Loc
));
10326 Append_To
(Decl_Nodes
, Corr_Decl
);
10328 if Ekind
(Act_T
) = E_Task_Type
then
10329 Set_Ekind
(Subt
, E_Task_Subtype
);
10331 Set_Ekind
(Subt
, E_Protected_Subtype
);
10334 Set_Corresponding_Record_Type
(Subt
, Corr_Rec
);
10335 Set_Generic_Parent_Type
(Corr_Decl
, Ancestor
);
10336 Set_Generic_Parent_Type
(Decl_Node
, Empty
);
10341 end Instantiate_Type
;
10343 -----------------------
10344 -- Is_Generic_Formal --
10345 -----------------------
10347 function Is_Generic_Formal
(E
: Entity_Id
) return Boolean is
10353 Kind
:= Nkind
(Parent
(E
));
10355 Nkind_In
(Kind
, N_Formal_Object_Declaration
,
10356 N_Formal_Package_Declaration
,
10357 N_Formal_Type_Declaration
)
10359 (Is_Formal_Subprogram
(E
)
10361 Nkind
(Parent
(Parent
(E
))) in
10362 N_Formal_Subprogram_Declaration
);
10364 end Is_Generic_Formal
;
10366 ---------------------
10367 -- Is_In_Main_Unit --
10368 ---------------------
10370 function Is_In_Main_Unit
(N
: Node_Id
) return Boolean is
10371 Unum
: constant Unit_Number_Type
:= Get_Source_Unit
(N
);
10372 Current_Unit
: Node_Id
;
10375 if Unum
= Main_Unit
then
10378 -- If the current unit is a subunit then it is either the main unit or
10379 -- is being compiled as part of the main unit.
10381 elsif Nkind
(N
) = N_Compilation_Unit
then
10382 return Nkind
(Unit
(N
)) = N_Subunit
;
10385 Current_Unit
:= Parent
(N
);
10386 while Present
(Current_Unit
)
10387 and then Nkind
(Current_Unit
) /= N_Compilation_Unit
10389 Current_Unit
:= Parent
(Current_Unit
);
10392 -- The instantiation node is in the main unit, or else the current node
10393 -- (perhaps as the result of nested instantiations) is in the main unit,
10394 -- or in the declaration of the main unit, which in this last case must
10397 return Unum
= Main_Unit
10398 or else Current_Unit
= Cunit
(Main_Unit
)
10399 or else Current_Unit
= Library_Unit
(Cunit
(Main_Unit
))
10400 or else (Present
(Library_Unit
(Current_Unit
))
10401 and then Is_In_Main_Unit
(Library_Unit
(Current_Unit
)));
10402 end Is_In_Main_Unit
;
10404 ----------------------------
10405 -- Load_Parent_Of_Generic --
10406 ----------------------------
10408 procedure Load_Parent_Of_Generic
10411 Body_Optional
: Boolean := False)
10413 Comp_Unit
: constant Node_Id
:= Cunit
(Get_Source_Unit
(Spec
));
10414 Save_Style_Check
: constant Boolean := Style_Check
;
10415 True_Parent
: Node_Id
;
10416 Inst_Node
: Node_Id
;
10418 Previous_Instances
: constant Elist_Id
:= New_Elmt_List
;
10420 procedure Collect_Previous_Instances
(Decls
: List_Id
);
10421 -- Collect all instantiations in the given list of declarations, that
10422 -- precede the generic that we need to load. If the bodies of these
10423 -- instantiations are available, we must analyze them, to ensure that
10424 -- the public symbols generated are the same when the unit is compiled
10425 -- to generate code, and when it is compiled in the context of a unit
10426 -- that needs a particular nested instance. This process is applied
10427 -- to both package and subprogram instances.
10429 --------------------------------
10430 -- Collect_Previous_Instances --
10431 --------------------------------
10433 procedure Collect_Previous_Instances
(Decls
: List_Id
) is
10437 Decl
:= First
(Decls
);
10438 while Present
(Decl
) loop
10439 if Sloc
(Decl
) >= Sloc
(Inst_Node
) then
10442 -- If Decl is an instantiation, then record it as requiring
10443 -- instantiation of the corresponding body, except if it is an
10444 -- abbreviated instantiation generated internally for conformance
10445 -- checking purposes only for the case of a formal package
10446 -- declared without a box (see Instantiate_Formal_Package). Such
10447 -- an instantiation does not generate any code (the actual code
10448 -- comes from actual) and thus does not need to be analyzed here.
10450 elsif Nkind
(Decl
) = N_Package_Instantiation
10451 and then not Is_Internal
(Defining_Entity
(Decl
))
10453 Append_Elmt
(Decl
, Previous_Instances
);
10455 -- For a subprogram instantiation, omit instantiations of
10456 -- intrinsic operations (Unchecked_Conversions, etc.) that
10459 elsif Nkind_In
(Decl
, N_Function_Instantiation
,
10460 N_Procedure_Instantiation
)
10461 and then not Is_Intrinsic_Subprogram
(Entity
(Name
(Decl
)))
10463 Append_Elmt
(Decl
, Previous_Instances
);
10465 elsif Nkind
(Decl
) = N_Package_Declaration
then
10466 Collect_Previous_Instances
10467 (Visible_Declarations
(Specification
(Decl
)));
10468 Collect_Previous_Instances
10469 (Private_Declarations
(Specification
(Decl
)));
10471 elsif Nkind
(Decl
) = N_Package_Body
then
10472 Collect_Previous_Instances
(Declarations
(Decl
));
10477 end Collect_Previous_Instances
;
10479 -- Start of processing for Load_Parent_Of_Generic
10482 if not In_Same_Source_Unit
(N
, Spec
)
10483 or else Nkind
(Unit
(Comp_Unit
)) = N_Package_Declaration
10484 or else (Nkind
(Unit
(Comp_Unit
)) = N_Package_Body
10485 and then not Is_In_Main_Unit
(Spec
))
10487 -- Find body of parent of spec, and analyze it. A special case arises
10488 -- when the parent is an instantiation, that is to say when we are
10489 -- currently instantiating a nested generic. In that case, there is
10490 -- no separate file for the body of the enclosing instance. Instead,
10491 -- the enclosing body must be instantiated as if it were a pending
10492 -- instantiation, in order to produce the body for the nested generic
10493 -- we require now. Note that in that case the generic may be defined
10494 -- in a package body, the instance defined in the same package body,
10495 -- and the original enclosing body may not be in the main unit.
10497 Inst_Node
:= Empty
;
10499 True_Parent
:= Parent
(Spec
);
10500 while Present
(True_Parent
)
10501 and then Nkind
(True_Parent
) /= N_Compilation_Unit
10503 if Nkind
(True_Parent
) = N_Package_Declaration
10505 Nkind
(Original_Node
(True_Parent
)) = N_Package_Instantiation
10507 -- Parent is a compilation unit that is an instantiation.
10508 -- Instantiation node has been replaced with package decl.
10510 Inst_Node
:= Original_Node
(True_Parent
);
10513 elsif Nkind
(True_Parent
) = N_Package_Declaration
10514 and then Present
(Generic_Parent
(Specification
(True_Parent
)))
10515 and then Nkind
(Parent
(True_Parent
)) /= N_Compilation_Unit
10517 -- Parent is an instantiation within another specification.
10518 -- Declaration for instance has been inserted before original
10519 -- instantiation node. A direct link would be preferable?
10521 Inst_Node
:= Next
(True_Parent
);
10522 while Present
(Inst_Node
)
10523 and then Nkind
(Inst_Node
) /= N_Package_Instantiation
10528 -- If the instance appears within a generic, and the generic
10529 -- unit is defined within a formal package of the enclosing
10530 -- generic, there is no generic body available, and none
10531 -- needed. A more precise test should be used ???
10533 if No
(Inst_Node
) then
10540 True_Parent
:= Parent
(True_Parent
);
10544 -- Case where we are currently instantiating a nested generic
10546 if Present
(Inst_Node
) then
10547 if Nkind
(Parent
(True_Parent
)) = N_Compilation_Unit
then
10549 -- Instantiation node and declaration of instantiated package
10550 -- were exchanged when only the declaration was needed.
10551 -- Restore instantiation node before proceeding with body.
10553 Set_Unit
(Parent
(True_Parent
), Inst_Node
);
10556 -- Now complete instantiation of enclosing body, if it appears
10557 -- in some other unit. If it appears in the current unit, the
10558 -- body will have been instantiated already.
10560 if No
(Corresponding_Body
(Instance_Spec
(Inst_Node
))) then
10562 -- We need to determine the expander mode to instantiate the
10563 -- enclosing body. Because the generic body we need may use
10564 -- global entities declared in the enclosing package (including
10565 -- aggregates) it is in general necessary to compile this body
10566 -- with expansion enabled. The exception is if we are within a
10567 -- generic package, in which case the usual generic rule
10571 Exp_Status
: Boolean := True;
10575 -- Loop through scopes looking for generic package
10577 Scop
:= Scope
(Defining_Entity
(Instance_Spec
(Inst_Node
)));
10578 while Present
(Scop
)
10579 and then Scop
/= Standard_Standard
10581 if Ekind
(Scop
) = E_Generic_Package
then
10582 Exp_Status
:= False;
10586 Scop
:= Scope
(Scop
);
10589 -- Collect previous instantiations in the unit that
10590 -- contains the desired generic.
10592 if Nkind
(Parent
(True_Parent
)) /= N_Compilation_Unit
10593 and then not Body_Optional
10597 Info
: Pending_Body_Info
;
10601 Par
:= Parent
(Inst_Node
);
10602 while Present
(Par
) loop
10603 exit when Nkind
(Parent
(Par
)) = N_Compilation_Unit
;
10604 Par
:= Parent
(Par
);
10607 pragma Assert
(Present
(Par
));
10609 if Nkind
(Par
) = N_Package_Body
then
10610 Collect_Previous_Instances
(Declarations
(Par
));
10612 elsif Nkind
(Par
) = N_Package_Declaration
then
10613 Collect_Previous_Instances
10614 (Visible_Declarations
(Specification
(Par
)));
10615 Collect_Previous_Instances
10616 (Private_Declarations
(Specification
(Par
)));
10619 -- Enclosing unit is a subprogram body, In this
10620 -- case all instance bodies are processed in order
10621 -- and there is no need to collect them separately.
10626 Decl
:= First_Elmt
(Previous_Instances
);
10627 while Present
(Decl
) loop
10629 (Inst_Node
=> Node
(Decl
),
10631 Instance_Spec
(Node
(Decl
)),
10632 Expander_Status
=> Exp_Status
,
10633 Current_Sem_Unit
=>
10634 Get_Code_Unit
(Sloc
(Node
(Decl
))),
10635 Scope_Suppress
=> Scope_Suppress
,
10636 Local_Suppress_Stack_Top
=>
10637 Local_Suppress_Stack_Top
);
10639 -- Package instance
10642 Nkind
(Node
(Decl
)) = N_Package_Instantiation
10644 Instantiate_Package_Body
10645 (Info
, Body_Optional
=> True);
10647 -- Subprogram instance
10650 -- The instance_spec is the wrapper package,
10651 -- and the subprogram declaration is the last
10652 -- declaration in the wrapper.
10656 (Visible_Declarations
10657 (Specification
(Info
.Act_Decl
)));
10659 Instantiate_Subprogram_Body
10660 (Info
, Body_Optional
=> True);
10668 Instantiate_Package_Body
10670 ((Inst_Node
=> Inst_Node
,
10671 Act_Decl
=> True_Parent
,
10672 Expander_Status
=> Exp_Status
,
10673 Current_Sem_Unit
=>
10674 Get_Code_Unit
(Sloc
(Inst_Node
)),
10675 Scope_Suppress
=> Scope_Suppress
,
10676 Local_Suppress_Stack_Top
=>
10677 Local_Suppress_Stack_Top
)),
10678 Body_Optional
=> Body_Optional
);
10682 -- Case where we are not instantiating a nested generic
10685 Opt
.Style_Check
:= False;
10686 Expander_Mode_Save_And_Set
(True);
10687 Load_Needed_Body
(Comp_Unit
, OK
);
10688 Opt
.Style_Check
:= Save_Style_Check
;
10689 Expander_Mode_Restore
;
10692 and then Unit_Requires_Body
(Defining_Entity
(Spec
))
10693 and then not Body_Optional
10696 Bname
: constant Unit_Name_Type
:=
10697 Get_Body_Name
(Get_Unit_Name
(Unit
(Comp_Unit
)));
10700 Error_Msg_Unit_1
:= Bname
;
10701 Error_Msg_N
("this instantiation requires$!", N
);
10702 Error_Msg_File_1
:= Get_File_Name
(Bname
, Subunit
=> False);
10703 Error_Msg_N
("\but file{ was not found!", N
);
10704 raise Unrecoverable_Error
;
10710 -- If loading parent of the generic caused an instantiation circularity,
10711 -- we abandon compilation at this point, because otherwise in some cases
10712 -- we get into trouble with infinite recursions after this point.
10714 if Circularity_Detected
then
10715 raise Unrecoverable_Error
;
10717 end Load_Parent_Of_Generic
;
10719 ---------------------------------
10720 -- Map_Formal_Package_Entities --
10721 ---------------------------------
10723 procedure Map_Formal_Package_Entities
(Form
: Entity_Id
; Act
: Entity_Id
) is
10728 Set_Instance_Of
(Form
, Act
);
10730 -- Traverse formal and actual package to map the corresponding entities.
10731 -- We skip over internal entities that may be generated during semantic
10732 -- analysis, and find the matching entities by name, given that they
10733 -- must appear in the same order.
10735 E1
:= First_Entity
(Form
);
10736 E2
:= First_Entity
(Act
);
10738 and then E1
/= First_Private_Entity
(Form
)
10740 -- Could this test be a single condition???
10741 -- Seems like it could, and isn't FPE (Form) a constant anyway???
10743 if not Is_Internal
(E1
)
10744 and then Present
(Parent
(E1
))
10745 and then not Is_Class_Wide_Type
(E1
)
10746 and then not Is_Internal_Name
(Chars
(E1
))
10749 and then Chars
(E2
) /= Chars
(E1
)
10757 Set_Instance_Of
(E1
, E2
);
10760 and then Is_Tagged_Type
(E2
)
10763 (Class_Wide_Type
(E1
), Class_Wide_Type
(E2
));
10766 if Is_Constrained
(E1
) then
10768 (Base_Type
(E1
), Base_Type
(E2
));
10771 if Ekind
(E1
) = E_Package
10772 and then No
(Renamed_Object
(E1
))
10774 Map_Formal_Package_Entities
(E1
, E2
);
10781 end Map_Formal_Package_Entities
;
10783 -----------------------
10784 -- Move_Freeze_Nodes --
10785 -----------------------
10787 procedure Move_Freeze_Nodes
10788 (Out_Of
: Entity_Id
;
10793 Next_Decl
: Node_Id
;
10794 Next_Node
: Node_Id
:= After
;
10797 function Is_Outer_Type
(T
: Entity_Id
) return Boolean;
10798 -- Check whether entity is declared in a scope external to that of the
10801 -------------------
10802 -- Is_Outer_Type --
10803 -------------------
10805 function Is_Outer_Type
(T
: Entity_Id
) return Boolean is
10806 Scop
: Entity_Id
:= Scope
(T
);
10809 if Scope_Depth
(Scop
) < Scope_Depth
(Out_Of
) then
10813 while Scop
/= Standard_Standard
loop
10814 if Scop
= Out_Of
then
10817 Scop
:= Scope
(Scop
);
10825 -- Start of processing for Move_Freeze_Nodes
10832 -- First remove the freeze nodes that may appear before all other
10836 while Present
(Decl
)
10837 and then Nkind
(Decl
) = N_Freeze_Entity
10838 and then Is_Outer_Type
(Entity
(Decl
))
10840 Decl
:= Remove_Head
(L
);
10841 Insert_After
(Next_Node
, Decl
);
10842 Set_Analyzed
(Decl
, False);
10847 -- Next scan the list of declarations and remove each freeze node that
10848 -- appears ahead of the current node.
10850 while Present
(Decl
) loop
10851 while Present
(Next
(Decl
))
10852 and then Nkind
(Next
(Decl
)) = N_Freeze_Entity
10853 and then Is_Outer_Type
(Entity
(Next
(Decl
)))
10855 Next_Decl
:= Remove_Next
(Decl
);
10856 Insert_After
(Next_Node
, Next_Decl
);
10857 Set_Analyzed
(Next_Decl
, False);
10858 Next_Node
:= Next_Decl
;
10861 -- If the declaration is a nested package or concurrent type, then
10862 -- recurse. Nested generic packages will have been processed from the
10865 if Nkind
(Decl
) = N_Package_Declaration
then
10866 Spec
:= Specification
(Decl
);
10868 elsif Nkind
(Decl
) = N_Task_Type_Declaration
then
10869 Spec
:= Task_Definition
(Decl
);
10871 elsif Nkind
(Decl
) = N_Protected_Type_Declaration
then
10872 Spec
:= Protected_Definition
(Decl
);
10878 if Present
(Spec
) then
10879 Move_Freeze_Nodes
(Out_Of
, Next_Node
,
10880 Visible_Declarations
(Spec
));
10881 Move_Freeze_Nodes
(Out_Of
, Next_Node
,
10882 Private_Declarations
(Spec
));
10887 end Move_Freeze_Nodes
;
10893 function Next_Assoc
(E
: Assoc_Ptr
) return Assoc_Ptr
is
10895 return Generic_Renamings
.Table
(E
).Next_In_HTable
;
10898 ------------------------
10899 -- Preanalyze_Actuals --
10900 ------------------------
10902 procedure Preanalyze_Actuals
(N
: Node_Id
) is
10905 Errs
: constant Int
:= Serious_Errors_Detected
;
10907 Cur
: Entity_Id
:= Empty
;
10908 -- Current homograph of the instance name
10911 -- Saved visibility status of the current homograph
10914 Assoc
:= First
(Generic_Associations
(N
));
10916 -- If the instance is a child unit, its name may hide an outer homonym,
10917 -- so make it invisible to perform name resolution on the actuals.
10919 if Nkind
(Defining_Unit_Name
(N
)) = N_Defining_Program_Unit_Name
10921 (Current_Entity
(Defining_Identifier
(Defining_Unit_Name
(N
))))
10923 Cur
:= Current_Entity
(Defining_Identifier
(Defining_Unit_Name
(N
)));
10925 if Is_Compilation_Unit
(Cur
) then
10926 Vis
:= Is_Immediately_Visible
(Cur
);
10927 Set_Is_Immediately_Visible
(Cur
, False);
10933 while Present
(Assoc
) loop
10934 if Nkind
(Assoc
) /= N_Others_Choice
then
10935 Act
:= Explicit_Generic_Actual_Parameter
(Assoc
);
10937 -- Within a nested instantiation, a defaulted actual is an empty
10938 -- association, so nothing to analyze. If the subprogram actual
10939 -- is an attribute, analyze prefix only, because actual is not a
10940 -- complete attribute reference.
10942 -- If actual is an allocator, analyze expression only. The full
10943 -- analysis can generate code, and if instance is a compilation
10944 -- unit we have to wait until the package instance is installed
10945 -- to have a proper place to insert this code.
10947 -- String literals may be operators, but at this point we do not
10948 -- know whether the actual is a formal subprogram or a string.
10953 elsif Nkind
(Act
) = N_Attribute_Reference
then
10954 Analyze
(Prefix
(Act
));
10956 elsif Nkind
(Act
) = N_Explicit_Dereference
then
10957 Analyze
(Prefix
(Act
));
10959 elsif Nkind
(Act
) = N_Allocator
then
10961 Expr
: constant Node_Id
:= Expression
(Act
);
10964 if Nkind
(Expr
) = N_Subtype_Indication
then
10965 Analyze
(Subtype_Mark
(Expr
));
10967 -- Analyze separately each discriminant constraint, when
10968 -- given with a named association.
10974 Constr
:= First
(Constraints
(Constraint
(Expr
)));
10975 while Present
(Constr
) loop
10976 if Nkind
(Constr
) = N_Discriminant_Association
then
10977 Analyze
(Expression
(Constr
));
10991 elsif Nkind
(Act
) /= N_Operator_Symbol
then
10995 if Errs
/= Serious_Errors_Detected
then
10997 -- Do a minimal analysis of the generic, to prevent spurious
10998 -- warnings complaining about the generic being unreferenced,
10999 -- before abandoning the instantiation.
11001 Analyze
(Name
(N
));
11003 if Is_Entity_Name
(Name
(N
))
11004 and then Etype
(Name
(N
)) /= Any_Type
11006 Generate_Reference
(Entity
(Name
(N
)), Name
(N
));
11007 Set_Is_Instantiated
(Entity
(Name
(N
)));
11010 if Present
(Cur
) then
11012 -- For the case of a child instance hiding an outer homonym,
11013 -- provide additional warning which might explain the error.
11015 Set_Is_Immediately_Visible
(Cur
, Vis
);
11016 Error_Msg_NE
("& hides outer unit with the same name?",
11017 N
, Defining_Unit_Name
(N
));
11020 Abandon_Instantiation
(Act
);
11027 if Present
(Cur
) then
11028 Set_Is_Immediately_Visible
(Cur
, Vis
);
11030 end Preanalyze_Actuals
;
11032 -------------------
11033 -- Remove_Parent --
11034 -------------------
11036 procedure Remove_Parent
(In_Body
: Boolean := False) is
11037 S
: Entity_Id
:= Current_Scope
;
11038 -- S is the scope containing the instantiation just completed. The
11039 -- scope stack contains the parent instances of the instantiation,
11040 -- followed by the original S.
11047 -- After child instantiation is complete, remove from scope stack the
11048 -- extra copy of the current scope, and then remove parent instances.
11050 if not In_Body
then
11053 while Current_Scope
/= S
loop
11054 P
:= Current_Scope
;
11055 End_Package_Scope
(Current_Scope
);
11057 if In_Open_Scopes
(P
) then
11058 E
:= First_Entity
(P
);
11059 while Present
(E
) loop
11060 Set_Is_Immediately_Visible
(E
, True);
11064 if Is_Generic_Instance
(Current_Scope
)
11065 and then P
/= Current_Scope
11067 -- We are within an instance of some sibling. Retain
11068 -- visibility of parent, for proper subsequent cleanup,
11069 -- and reinstall private declarations as well.
11071 Set_In_Private_Part
(P
);
11072 Install_Private_Declarations
(P
);
11075 -- If the ultimate parent is a top-level unit recorded in
11076 -- Instance_Parent_Unit, then reset its visibility to what
11077 -- it was before instantiation. (It's not clear what the
11078 -- purpose is of testing whether Scope (P) is In_Open_Scopes,
11079 -- but that test was present before the ultimate parent test
11082 elsif not In_Open_Scopes
(Scope
(P
))
11083 or else (P
= Instance_Parent_Unit
11084 and then not Parent_Unit_Visible
)
11086 Set_Is_Immediately_Visible
(P
, False);
11088 -- If the current scope is itself an instantiation of a generic
11089 -- nested within P, and we are in the private part of body of this
11090 -- instantiation, restore the full views of P, that were removed
11091 -- in End_Package_Scope above. This obscure case can occur when a
11092 -- subunit of a generic contains an instance of a child unit of
11093 -- its generic parent unit.
11095 elsif S
= Current_Scope
11096 and then Is_Generic_Instance
(S
)
11099 Par
: constant Entity_Id
:=
11101 (Specification
(Unit_Declaration_Node
(S
)));
11104 and then P
= Scope
(Par
)
11105 and then (In_Package_Body
(S
) or else In_Private_Part
(S
))
11107 Set_In_Private_Part
(P
);
11108 Install_Private_Declarations
(P
);
11114 -- Reset visibility of entities in the enclosing scope
11116 Set_Is_Hidden_Open_Scope
(Current_Scope
, False);
11118 Hidden
:= First_Elmt
(Hidden_Entities
);
11119 while Present
(Hidden
) loop
11120 Set_Is_Immediately_Visible
(Node
(Hidden
), True);
11121 Next_Elmt
(Hidden
);
11125 -- Each body is analyzed separately, and there is no context
11126 -- that needs preserving from one body instance to the next,
11127 -- so remove all parent scopes that have been installed.
11129 while Present
(S
) loop
11130 End_Package_Scope
(S
);
11131 Set_Is_Immediately_Visible
(S
, False);
11132 S
:= Current_Scope
;
11133 exit when S
= Standard_Standard
;
11142 procedure Restore_Env
is
11143 Saved
: Instance_Env
renames Instance_Envs
.Table
(Instance_Envs
.Last
);
11146 if No
(Current_Instantiated_Parent
.Act_Id
) then
11148 -- Restore environment after subprogram inlining
11150 Restore_Private_Views
(Empty
);
11153 Current_Instantiated_Parent
:= Saved
.Instantiated_Parent
;
11154 Exchanged_Views
:= Saved
.Exchanged_Views
;
11155 Hidden_Entities
:= Saved
.Hidden_Entities
;
11156 Current_Sem_Unit
:= Saved
.Current_Sem_Unit
;
11157 Parent_Unit_Visible
:= Saved
.Parent_Unit_Visible
;
11158 Instance_Parent_Unit
:= Saved
.Instance_Parent_Unit
;
11160 Restore_Opt_Config_Switches
(Saved
.Switches
);
11162 Instance_Envs
.Decrement_Last
;
11165 ---------------------------
11166 -- Restore_Private_Views --
11167 ---------------------------
11169 procedure Restore_Private_Views
11170 (Pack_Id
: Entity_Id
;
11171 Is_Package
: Boolean := True)
11176 Dep_Elmt
: Elmt_Id
;
11179 procedure Restore_Nested_Formal
(Formal
: Entity_Id
);
11180 -- Hide the generic formals of formal packages declared with box
11181 -- which were reachable in the current instantiation.
11183 ---------------------------
11184 -- Restore_Nested_Formal --
11185 ---------------------------
11187 procedure Restore_Nested_Formal
(Formal
: Entity_Id
) is
11191 if Present
(Renamed_Object
(Formal
))
11192 and then Denotes_Formal_Package
(Renamed_Object
(Formal
), True)
11196 elsif Present
(Associated_Formal_Package
(Formal
)) then
11197 Ent
:= First_Entity
(Formal
);
11198 while Present
(Ent
) loop
11199 exit when Ekind
(Ent
) = E_Package
11200 and then Renamed_Entity
(Ent
) = Renamed_Entity
(Formal
);
11202 Set_Is_Hidden
(Ent
);
11203 Set_Is_Potentially_Use_Visible
(Ent
, False);
11205 -- If package, then recurse
11207 if Ekind
(Ent
) = E_Package
then
11208 Restore_Nested_Formal
(Ent
);
11214 end Restore_Nested_Formal
;
11216 -- Start of processing for Restore_Private_Views
11219 M
:= First_Elmt
(Exchanged_Views
);
11220 while Present
(M
) loop
11223 -- Subtypes of types whose views have been exchanged, and that
11224 -- are defined within the instance, were not on the list of
11225 -- Private_Dependents on entry to the instance, so they have to
11226 -- be exchanged explicitly now, in order to remain consistent with
11227 -- the view of the parent type.
11229 if Ekind
(Typ
) = E_Private_Type
11230 or else Ekind
(Typ
) = E_Limited_Private_Type
11231 or else Ekind
(Typ
) = E_Record_Type_With_Private
11233 Dep_Elmt
:= First_Elmt
(Private_Dependents
(Typ
));
11234 while Present
(Dep_Elmt
) loop
11235 Dep_Typ
:= Node
(Dep_Elmt
);
11237 if Scope
(Dep_Typ
) = Pack_Id
11238 and then Present
(Full_View
(Dep_Typ
))
11240 Replace_Elmt
(Dep_Elmt
, Full_View
(Dep_Typ
));
11241 Exchange_Declarations
(Dep_Typ
);
11244 Next_Elmt
(Dep_Elmt
);
11248 Exchange_Declarations
(Node
(M
));
11252 if No
(Pack_Id
) then
11256 -- Make the generic formal parameters private, and make the formal
11257 -- types into subtypes of the actuals again.
11259 E
:= First_Entity
(Pack_Id
);
11260 while Present
(E
) loop
11261 Set_Is_Hidden
(E
, True);
11264 and then Nkind
(Parent
(E
)) = N_Subtype_Declaration
11266 Set_Is_Generic_Actual_Type
(E
, False);
11268 -- An unusual case of aliasing: the actual may also be directly
11269 -- visible in the generic, and be private there, while it is fully
11270 -- visible in the context of the instance. The internal subtype
11271 -- is private in the instance, but has full visibility like its
11272 -- parent in the enclosing scope. This enforces the invariant that
11273 -- the privacy status of all private dependents of a type coincide
11274 -- with that of the parent type. This can only happen when a
11275 -- generic child unit is instantiated within sibling.
11277 if Is_Private_Type
(E
)
11278 and then not Is_Private_Type
(Etype
(E
))
11280 Exchange_Declarations
(E
);
11283 elsif Ekind
(E
) = E_Package
then
11285 -- The end of the renaming list is the renaming of the generic
11286 -- package itself. If the instance is a subprogram, all entities
11287 -- in the corresponding package are renamings. If this entity is
11288 -- a formal package, make its own formals private as well. The
11289 -- actual in this case is itself the renaming of an instantiation.
11290 -- If the entity is not a package renaming, it is the entity
11291 -- created to validate formal package actuals: ignore.
11293 -- If the actual is itself a formal package for the enclosing
11294 -- generic, or the actual for such a formal package, it remains
11295 -- visible on exit from the instance, and therefore nothing needs
11296 -- to be done either, except to keep it accessible.
11299 and then Renamed_Object
(E
) = Pack_Id
11303 elsif Nkind
(Parent
(E
)) /= N_Package_Renaming_Declaration
then
11307 Denotes_Formal_Package
(Renamed_Object
(E
), True, Pack_Id
)
11309 Set_Is_Hidden
(E
, False);
11313 Act_P
: constant Entity_Id
:= Renamed_Object
(E
);
11317 Id
:= First_Entity
(Act_P
);
11319 and then Id
/= First_Private_Entity
(Act_P
)
11321 exit when Ekind
(Id
) = E_Package
11322 and then Renamed_Object
(Id
) = Act_P
;
11324 Set_Is_Hidden
(Id
, True);
11325 Set_Is_Potentially_Use_Visible
(Id
, In_Use
(Act_P
));
11327 if Ekind
(Id
) = E_Package
then
11328 Restore_Nested_Formal
(Id
);
11339 end Restore_Private_Views
;
11346 (Gen_Unit
: Entity_Id
;
11347 Act_Unit
: Entity_Id
)
11351 Set_Instance_Env
(Gen_Unit
, Act_Unit
);
11354 ----------------------------
11355 -- Save_Global_References --
11356 ----------------------------
11358 procedure Save_Global_References
(N
: Node_Id
) is
11359 Gen_Scope
: Entity_Id
;
11363 function Is_Global
(E
: Entity_Id
) return Boolean;
11364 -- Check whether entity is defined outside of generic unit. Examine the
11365 -- scope of an entity, and the scope of the scope, etc, until we find
11366 -- either Standard, in which case the entity is global, or the generic
11367 -- unit itself, which indicates that the entity is local. If the entity
11368 -- is the generic unit itself, as in the case of a recursive call, or
11369 -- the enclosing generic unit, if different from the current scope, then
11370 -- it is local as well, because it will be replaced at the point of
11371 -- instantiation. On the other hand, if it is a reference to a child
11372 -- unit of a common ancestor, which appears in an instantiation, it is
11373 -- global because it is used to denote a specific compilation unit at
11374 -- the time the instantiations will be analyzed.
11376 procedure Reset_Entity
(N
: Node_Id
);
11377 -- Save semantic information on global entity so that it is not resolved
11378 -- again at instantiation time.
11380 procedure Save_Entity_Descendants
(N
: Node_Id
);
11381 -- Apply Save_Global_References to the two syntactic descendants of
11382 -- non-terminal nodes that carry an Associated_Node and are processed
11383 -- through Reset_Entity. Once the global entity (if any) has been
11384 -- captured together with its type, only two syntactic descendants need
11385 -- to be traversed to complete the processing of the tree rooted at N.
11386 -- This applies to Selected_Components, Expanded_Names, and to Operator
11387 -- nodes. N can also be a character literal, identifier, or operator
11388 -- symbol node, but the call has no effect in these cases.
11390 procedure Save_Global_Defaults
(N1
, N2
: Node_Id
);
11391 -- Default actuals in nested instances must be handled specially
11392 -- because there is no link to them from the original tree. When an
11393 -- actual subprogram is given by a default, we add an explicit generic
11394 -- association for it in the instantiation node. When we save the
11395 -- global references on the name of the instance, we recover the list
11396 -- of generic associations, and add an explicit one to the original
11397 -- generic tree, through which a global actual can be preserved.
11398 -- Similarly, if a child unit is instantiated within a sibling, in the
11399 -- context of the parent, we must preserve the identifier of the parent
11400 -- so that it can be properly resolved in a subsequent instantiation.
11402 procedure Save_Global_Descendant
(D
: Union_Id
);
11403 -- Apply Save_Global_References recursively to the descendents of the
11406 procedure Save_References
(N
: Node_Id
);
11407 -- This is the recursive procedure that does the work, once the
11408 -- enclosing generic scope has been established.
11414 function Is_Global
(E
: Entity_Id
) return Boolean is
11417 function Is_Instance_Node
(Decl
: Node_Id
) return Boolean;
11418 -- Determine whether the parent node of a reference to a child unit
11419 -- denotes an instantiation or a formal package, in which case the
11420 -- reference to the child unit is global, even if it appears within
11421 -- the current scope (e.g. when the instance appears within the body
11422 -- of an ancestor).
11424 ----------------------
11425 -- Is_Instance_Node --
11426 ----------------------
11428 function Is_Instance_Node
(Decl
: Node_Id
) return Boolean is
11430 return Nkind
(Decl
) in N_Generic_Instantiation
11432 Nkind
(Original_Node
(Decl
)) = N_Formal_Package_Declaration
;
11433 end Is_Instance_Node
;
11435 -- Start of processing for Is_Global
11438 if E
= Gen_Scope
then
11441 elsif E
= Standard_Standard
then
11444 elsif Is_Child_Unit
(E
)
11445 and then (Is_Instance_Node
(Parent
(N2
))
11446 or else (Nkind
(Parent
(N2
)) = N_Expanded_Name
11447 and then N2
= Selector_Name
(Parent
(N2
))
11449 Is_Instance_Node
(Parent
(Parent
(N2
)))))
11455 while Se
/= Gen_Scope
loop
11456 if Se
= Standard_Standard
then
11471 procedure Reset_Entity
(N
: Node_Id
) is
11473 procedure Set_Global_Type
(N
: Node_Id
; N2
: Node_Id
);
11474 -- If the type of N2 is global to the generic unit. Save the type in
11475 -- the generic node.
11476 -- What does this comment mean???
11478 function Top_Ancestor
(E
: Entity_Id
) return Entity_Id
;
11479 -- Find the ultimate ancestor of the current unit. If it is not a
11480 -- generic unit, then the name of the current unit in the prefix of
11481 -- an expanded name must be replaced with its generic homonym to
11482 -- ensure that it will be properly resolved in an instance.
11484 ---------------------
11485 -- Set_Global_Type --
11486 ---------------------
11488 procedure Set_Global_Type
(N
: Node_Id
; N2
: Node_Id
) is
11489 Typ
: constant Entity_Id
:= Etype
(N2
);
11492 Set_Etype
(N
, Typ
);
11494 if Entity
(N
) /= N2
11495 and then Has_Private_View
(Entity
(N
))
11497 -- If the entity of N is not the associated node, this is a
11498 -- nested generic and it has an associated node as well, whose
11499 -- type is already the full view (see below). Indicate that the
11500 -- original node has a private view.
11502 Set_Has_Private_View
(N
);
11505 -- If not a private type, nothing else to do
11507 if not Is_Private_Type
(Typ
) then
11508 if Is_Array_Type
(Typ
)
11509 and then Is_Private_Type
(Component_Type
(Typ
))
11511 Set_Has_Private_View
(N
);
11514 -- If it is a derivation of a private type in a context where no
11515 -- full view is needed, nothing to do either.
11517 elsif No
(Full_View
(Typ
)) and then Typ
/= Etype
(Typ
) then
11520 -- Otherwise mark the type for flipping and use the full view when
11524 Set_Has_Private_View
(N
);
11526 if Present
(Full_View
(Typ
)) then
11527 Set_Etype
(N2
, Full_View
(Typ
));
11530 end Set_Global_Type
;
11536 function Top_Ancestor
(E
: Entity_Id
) return Entity_Id
is
11541 while Is_Child_Unit
(Par
) loop
11542 Par
:= Scope
(Par
);
11548 -- Start of processing for Reset_Entity
11551 N2
:= Get_Associated_Node
(N
);
11554 if Present
(E
) then
11555 if Is_Global
(E
) then
11556 Set_Global_Type
(N
, N2
);
11558 elsif Nkind
(N
) = N_Op_Concat
11559 and then Is_Generic_Type
(Etype
(N2
))
11561 (Base_Type
(Etype
(Right_Opnd
(N2
))) = Etype
(N2
)
11562 or else Base_Type
(Etype
(Left_Opnd
(N2
))) = Etype
(N2
))
11563 and then Is_Intrinsic_Subprogram
(E
)
11568 -- Entity is local. Mark generic node as unresolved.
11569 -- Note that now it does not have an entity.
11571 Set_Associated_Node
(N
, Empty
);
11572 Set_Etype
(N
, Empty
);
11575 if Nkind
(Parent
(N
)) in N_Generic_Instantiation
11576 and then N
= Name
(Parent
(N
))
11578 Save_Global_Defaults
(Parent
(N
), Parent
(N2
));
11581 elsif Nkind
(Parent
(N
)) = N_Selected_Component
11582 and then Nkind
(Parent
(N2
)) = N_Expanded_Name
11584 if Is_Global
(Entity
(Parent
(N2
))) then
11585 Change_Selected_Component_To_Expanded_Name
(Parent
(N
));
11586 Set_Associated_Node
(Parent
(N
), Parent
(N2
));
11587 Set_Global_Type
(Parent
(N
), Parent
(N2
));
11588 Save_Entity_Descendants
(N
);
11590 -- If this is a reference to the current generic entity, replace
11591 -- by the name of the generic homonym of the current package. This
11592 -- is because in an instantiation Par.P.Q will not resolve to the
11593 -- name of the instance, whose enclosing scope is not necessarily
11594 -- Par. We use the generic homonym rather that the name of the
11595 -- generic itself because it may be hidden by a local declaration.
11597 elsif In_Open_Scopes
(Entity
(Parent
(N2
)))
11599 Is_Generic_Unit
(Top_Ancestor
(Entity
(Prefix
(Parent
(N2
)))))
11601 if Ekind
(Entity
(Parent
(N2
))) = E_Generic_Package
then
11602 Rewrite
(Parent
(N
),
11603 Make_Identifier
(Sloc
(N
),
11605 Chars
(Generic_Homonym
(Entity
(Parent
(N2
))))));
11607 Rewrite
(Parent
(N
),
11608 Make_Identifier
(Sloc
(N
),
11609 Chars
=> Chars
(Selector_Name
(Parent
(N2
)))));
11613 if Nkind
(Parent
(Parent
(N
))) in N_Generic_Instantiation
11614 and then Parent
(N
) = Name
(Parent
(Parent
(N
)))
11616 Save_Global_Defaults
11617 (Parent
(Parent
(N
)), Parent
(Parent
((N2
))));
11620 -- A selected component may denote a static constant that has been
11621 -- folded. If the static constant is global to the generic, capture
11622 -- its value. Otherwise the folding will happen in any instantiation.
11624 elsif Nkind
(Parent
(N
)) = N_Selected_Component
11625 and then Nkind_In
(Parent
(N2
), N_Integer_Literal
, N_Real_Literal
)
11627 if Present
(Entity
(Original_Node
(Parent
(N2
))))
11628 and then Is_Global
(Entity
(Original_Node
(Parent
(N2
))))
11630 Rewrite
(Parent
(N
), New_Copy
(Parent
(N2
)));
11631 Set_Analyzed
(Parent
(N
), False);
11637 -- A selected component may be transformed into a parameterless
11638 -- function call. If the called entity is global, rewrite the node
11639 -- appropriately, i.e. as an extended name for the global entity.
11641 elsif Nkind
(Parent
(N
)) = N_Selected_Component
11642 and then Nkind
(Parent
(N2
)) = N_Function_Call
11643 and then N
= Selector_Name
(Parent
(N
))
11645 if No
(Parameter_Associations
(Parent
(N2
))) then
11646 if Is_Global
(Entity
(Name
(Parent
(N2
)))) then
11647 Change_Selected_Component_To_Expanded_Name
(Parent
(N
));
11648 Set_Associated_Node
(Parent
(N
), Name
(Parent
(N2
)));
11649 Set_Global_Type
(Parent
(N
), Name
(Parent
(N2
)));
11650 Save_Entity_Descendants
(N
);
11653 Set_Associated_Node
(N
, Empty
);
11654 Set_Etype
(N
, Empty
);
11657 -- In Ada 2005, X.F may be a call to a primitive operation,
11658 -- rewritten as F (X). This rewriting will be done again in an
11659 -- instance, so keep the original node. Global entities will be
11660 -- captured as for other constructs.
11666 -- Entity is local. Reset in generic unit, so that node is resolved
11667 -- anew at the point of instantiation.
11670 Set_Associated_Node
(N
, Empty
);
11671 Set_Etype
(N
, Empty
);
11675 -----------------------------
11676 -- Save_Entity_Descendants --
11677 -----------------------------
11679 procedure Save_Entity_Descendants
(N
: Node_Id
) is
11682 when N_Binary_Op
=>
11683 Save_Global_Descendant
(Union_Id
(Left_Opnd
(N
)));
11684 Save_Global_Descendant
(Union_Id
(Right_Opnd
(N
)));
11687 Save_Global_Descendant
(Union_Id
(Right_Opnd
(N
)));
11689 when N_Expanded_Name | N_Selected_Component
=>
11690 Save_Global_Descendant
(Union_Id
(Prefix
(N
)));
11691 Save_Global_Descendant
(Union_Id
(Selector_Name
(N
)));
11693 when N_Identifier | N_Character_Literal | N_Operator_Symbol
=>
11697 raise Program_Error
;
11699 end Save_Entity_Descendants
;
11701 --------------------------
11702 -- Save_Global_Defaults --
11703 --------------------------
11705 procedure Save_Global_Defaults
(N1
, N2
: Node_Id
) is
11706 Loc
: constant Source_Ptr
:= Sloc
(N1
);
11707 Assoc2
: constant List_Id
:= Generic_Associations
(N2
);
11708 Gen_Id
: constant Entity_Id
:= Get_Generic_Entity
(N2
);
11715 Actual
: Entity_Id
;
11718 Assoc1
:= Generic_Associations
(N1
);
11720 if Present
(Assoc1
) then
11721 Act1
:= First
(Assoc1
);
11724 Set_Generic_Associations
(N1
, New_List
);
11725 Assoc1
:= Generic_Associations
(N1
);
11728 if Present
(Assoc2
) then
11729 Act2
:= First
(Assoc2
);
11734 while Present
(Act1
) and then Present
(Act2
) loop
11739 -- Find the associations added for default subprograms
11741 if Present
(Act2
) then
11742 while Nkind
(Act2
) /= N_Generic_Association
11743 or else No
(Entity
(Selector_Name
(Act2
)))
11744 or else not Is_Overloadable
(Entity
(Selector_Name
(Act2
)))
11749 -- Add a similar association if the default is global. The
11750 -- renaming declaration for the actual has been analyzed, and
11751 -- its alias is the program it renames. Link the actual in the
11752 -- original generic tree with the node in the analyzed tree.
11754 while Present
(Act2
) loop
11755 Subp
:= Entity
(Selector_Name
(Act2
));
11756 Def
:= Explicit_Generic_Actual_Parameter
(Act2
);
11758 -- Following test is defence against rubbish errors
11760 if No
(Alias
(Subp
)) then
11764 -- Retrieve the resolved actual from the renaming declaration
11765 -- created for the instantiated formal.
11767 Actual
:= Entity
(Name
(Parent
(Parent
(Subp
))));
11768 Set_Entity
(Def
, Actual
);
11769 Set_Etype
(Def
, Etype
(Actual
));
11771 if Is_Global
(Actual
) then
11773 Make_Generic_Association
(Loc
,
11774 Selector_Name
=> New_Occurrence_Of
(Subp
, Loc
),
11775 Explicit_Generic_Actual_Parameter
=>
11776 New_Occurrence_Of
(Actual
, Loc
));
11778 Set_Associated_Node
11779 (Explicit_Generic_Actual_Parameter
(Ndec
), Def
);
11781 Append
(Ndec
, Assoc1
);
11783 -- If there are other defaults, add a dummy association in case
11784 -- there are other defaulted formals with the same name.
11786 elsif Present
(Next
(Act2
)) then
11788 Make_Generic_Association
(Loc
,
11789 Selector_Name
=> New_Occurrence_Of
(Subp
, Loc
),
11790 Explicit_Generic_Actual_Parameter
=> Empty
);
11792 Append
(Ndec
, Assoc1
);
11799 if Nkind
(Name
(N1
)) = N_Identifier
11800 and then Is_Child_Unit
(Gen_Id
)
11801 and then Is_Global
(Gen_Id
)
11802 and then Is_Generic_Unit
(Scope
(Gen_Id
))
11803 and then In_Open_Scopes
(Scope
(Gen_Id
))
11805 -- This is an instantiation of a child unit within a sibling,
11806 -- so that the generic parent is in scope. An eventual instance
11807 -- must occur within the scope of an instance of the parent.
11808 -- Make name in instance into an expanded name, to preserve the
11809 -- identifier of the parent, so it can be resolved subsequently.
11811 Rewrite
(Name
(N2
),
11812 Make_Expanded_Name
(Loc
,
11813 Chars
=> Chars
(Gen_Id
),
11814 Prefix
=> New_Occurrence_Of
(Scope
(Gen_Id
), Loc
),
11815 Selector_Name
=> New_Occurrence_Of
(Gen_Id
, Loc
)));
11816 Set_Entity
(Name
(N2
), Gen_Id
);
11818 Rewrite
(Name
(N1
),
11819 Make_Expanded_Name
(Loc
,
11820 Chars
=> Chars
(Gen_Id
),
11821 Prefix
=> New_Occurrence_Of
(Scope
(Gen_Id
), Loc
),
11822 Selector_Name
=> New_Occurrence_Of
(Gen_Id
, Loc
)));
11824 Set_Associated_Node
(Name
(N1
), Name
(N2
));
11825 Set_Associated_Node
(Prefix
(Name
(N1
)), Empty
);
11826 Set_Associated_Node
11827 (Selector_Name
(Name
(N1
)), Selector_Name
(Name
(N2
)));
11828 Set_Etype
(Name
(N1
), Etype
(Gen_Id
));
11831 end Save_Global_Defaults
;
11833 ----------------------------
11834 -- Save_Global_Descendant --
11835 ----------------------------
11837 procedure Save_Global_Descendant
(D
: Union_Id
) is
11841 if D
in Node_Range
then
11842 if D
= Union_Id
(Empty
) then
11845 elsif Nkind
(Node_Id
(D
)) /= N_Compilation_Unit
then
11846 Save_References
(Node_Id
(D
));
11849 elsif D
in List_Range
then
11850 if D
= Union_Id
(No_List
)
11851 or else Is_Empty_List
(List_Id
(D
))
11856 N1
:= First
(List_Id
(D
));
11857 while Present
(N1
) loop
11858 Save_References
(N1
);
11863 -- Element list or other non-node field, nothing to do
11868 end Save_Global_Descendant
;
11870 ---------------------
11871 -- Save_References --
11872 ---------------------
11874 -- This is the recursive procedure that does the work once the enclosing
11875 -- generic scope has been established. We have to treat specially a
11876 -- number of node rewritings that are required by semantic processing
11877 -- and which change the kind of nodes in the generic copy: typically
11878 -- constant-folding, replacing an operator node by a string literal, or
11879 -- a selected component by an expanded name. In each of those cases, the
11880 -- transformation is propagated to the generic unit.
11882 procedure Save_References
(N
: Node_Id
) is
11883 Loc
: constant Source_Ptr
:= Sloc
(N
);
11889 elsif Nkind_In
(N
, N_Character_Literal
, N_Operator_Symbol
) then
11890 if Nkind
(N
) = Nkind
(Get_Associated_Node
(N
)) then
11893 elsif Nkind
(N
) = N_Operator_Symbol
11894 and then Nkind
(Get_Associated_Node
(N
)) = N_String_Literal
11896 Change_Operator_Symbol_To_String_Literal
(N
);
11899 elsif Nkind
(N
) in N_Op
then
11900 if Nkind
(N
) = Nkind
(Get_Associated_Node
(N
)) then
11901 if Nkind
(N
) = N_Op_Concat
then
11902 Set_Is_Component_Left_Opnd
(N
,
11903 Is_Component_Left_Opnd
(Get_Associated_Node
(N
)));
11905 Set_Is_Component_Right_Opnd
(N
,
11906 Is_Component_Right_Opnd
(Get_Associated_Node
(N
)));
11912 -- Node may be transformed into call to a user-defined operator
11914 N2
:= Get_Associated_Node
(N
);
11916 if Nkind
(N2
) = N_Function_Call
then
11917 E
:= Entity
(Name
(N2
));
11920 and then Is_Global
(E
)
11922 Set_Etype
(N
, Etype
(N2
));
11924 Set_Associated_Node
(N
, Empty
);
11925 Set_Etype
(N
, Empty
);
11928 elsif Nkind_In
(N2
, N_Integer_Literal
,
11932 if Present
(Original_Node
(N2
))
11933 and then Nkind
(Original_Node
(N2
)) = Nkind
(N
)
11936 -- Operation was constant-folded. Whenever possible,
11937 -- recover semantic information from unfolded node,
11940 Set_Associated_Node
(N
, Original_Node
(N2
));
11942 if Nkind
(N
) = N_Op_Concat
then
11943 Set_Is_Component_Left_Opnd
(N
,
11944 Is_Component_Left_Opnd
(Get_Associated_Node
(N
)));
11945 Set_Is_Component_Right_Opnd
(N
,
11946 Is_Component_Right_Opnd
(Get_Associated_Node
(N
)));
11952 -- If original node is already modified, propagate
11953 -- constant-folding to template.
11955 Rewrite
(N
, New_Copy
(N2
));
11956 Set_Analyzed
(N
, False);
11959 elsif Nkind
(N2
) = N_Identifier
11960 and then Ekind
(Entity
(N2
)) = E_Enumeration_Literal
11962 -- Same if call was folded into a literal, but in this case
11963 -- retain the entity to avoid spurious ambiguities if it is
11964 -- overloaded at the point of instantiation or inlining.
11966 Rewrite
(N
, New_Copy
(N2
));
11967 Set_Analyzed
(N
, False);
11971 -- Complete operands check if node has not been constant-folded
11973 if Nkind
(N
) in N_Op
then
11974 Save_Entity_Descendants
(N
);
11977 elsif Nkind
(N
) = N_Identifier
then
11978 if Nkind
(N
) = Nkind
(Get_Associated_Node
(N
)) then
11980 -- If this is a discriminant reference, always save it. It is
11981 -- used in the instance to find the corresponding discriminant
11982 -- positionally rather than by name.
11984 Set_Original_Discriminant
11985 (N
, Original_Discriminant
(Get_Associated_Node
(N
)));
11989 N2
:= Get_Associated_Node
(N
);
11991 if Nkind
(N2
) = N_Function_Call
then
11992 E
:= Entity
(Name
(N2
));
11994 -- Name resolves to a call to parameterless function. If
11995 -- original entity is global, mark node as resolved.
11998 and then Is_Global
(E
)
12000 Set_Etype
(N
, Etype
(N2
));
12002 Set_Associated_Node
(N
, Empty
);
12003 Set_Etype
(N
, Empty
);
12006 elsif Nkind_In
(N2
, N_Integer_Literal
, N_Real_Literal
)
12007 and then Is_Entity_Name
(Original_Node
(N2
))
12009 -- Name resolves to named number that is constant-folded,
12010 -- We must preserve the original name for ASIS use, and
12011 -- undo the constant-folding, which will be repeated in
12014 Set_Associated_Node
(N
, Original_Node
(N2
));
12017 elsif Nkind
(N2
) = N_String_Literal
then
12019 -- Name resolves to string literal. Perform the same
12020 -- replacement in generic.
12022 Rewrite
(N
, New_Copy
(N2
));
12024 elsif Nkind
(N2
) = N_Explicit_Dereference
then
12026 -- An identifier is rewritten as a dereference if it is the
12027 -- prefix in an implicit dereference.
12029 -- Check whether corresponding entity in prefix is global
12031 if Is_Entity_Name
(Prefix
(N2
))
12032 and then Present
(Entity
(Prefix
(N2
)))
12033 and then Is_Global
(Entity
(Prefix
(N2
)))
12036 Make_Explicit_Dereference
(Loc
,
12038 New_Occurrence_Of
(Entity
(Prefix
(N2
)), Loc
)));
12039 elsif Nkind
(Prefix
(N2
)) = N_Function_Call
12040 and then Is_Global
(Entity
(Name
(Prefix
(N2
))))
12043 Make_Explicit_Dereference
(Loc
,
12044 Prefix
=> Make_Function_Call
(Loc
,
12046 New_Occurrence_Of
(Entity
(Name
(Prefix
(N2
))),
12050 Set_Associated_Node
(N
, Empty
);
12051 Set_Etype
(N
, Empty
);
12054 -- The subtype mark of a nominally unconstrained object is
12055 -- rewritten as a subtype indication using the bounds of the
12056 -- expression. Recover the original subtype mark.
12058 elsif Nkind
(N2
) = N_Subtype_Indication
12059 and then Is_Entity_Name
(Original_Node
(N2
))
12061 Set_Associated_Node
(N
, Original_Node
(N2
));
12069 elsif Nkind
(N
) in N_Entity
then
12074 Qual
: Node_Id
:= Empty
;
12075 Typ
: Entity_Id
:= Empty
;
12078 use Atree
.Unchecked_Access
;
12079 -- This code section is part of implementing an untyped tree
12080 -- traversal, so it needs direct access to node fields.
12083 if Nkind_In
(N
, N_Aggregate
, N_Extension_Aggregate
) then
12084 N2
:= Get_Associated_Node
(N
);
12091 -- In an instance within a generic, use the name of the
12092 -- actual and not the original generic parameter. If the
12093 -- actual is global in the current generic it must be
12094 -- preserved for its instantiation.
12096 if Nkind
(Parent
(Typ
)) = N_Subtype_Declaration
12098 Present
(Generic_Parent_Type
(Parent
(Typ
)))
12100 Typ
:= Base_Type
(Typ
);
12101 Set_Etype
(N2
, Typ
);
12107 or else not Is_Global
(Typ
)
12109 Set_Associated_Node
(N
, Empty
);
12111 -- If the aggregate is an actual in a call, it has been
12112 -- resolved in the current context, to some local type.
12113 -- The enclosing call may have been disambiguated by the
12114 -- aggregate, and this disambiguation might fail at
12115 -- instantiation time because the type to which the
12116 -- aggregate did resolve is not preserved. In order to
12117 -- preserve some of this information, we wrap the
12118 -- aggregate in a qualified expression, using the id of
12119 -- its type. For further disambiguation we qualify the
12120 -- type name with its scope (if visible) because both
12121 -- id's will have corresponding entities in an instance.
12122 -- This resolves most of the problems with missing type
12123 -- information on aggregates in instances.
12125 if Nkind
(N2
) = Nkind
(N
)
12127 Nkind_In
(Parent
(N2
), N_Procedure_Call_Statement
,
12129 and then Comes_From_Source
(Typ
)
12131 if Is_Immediately_Visible
(Scope
(Typ
)) then
12132 Nam
:= Make_Selected_Component
(Loc
,
12134 Make_Identifier
(Loc
, Chars
(Scope
(Typ
))),
12136 Make_Identifier
(Loc
, Chars
(Typ
)));
12138 Nam
:= Make_Identifier
(Loc
, Chars
(Typ
));
12142 Make_Qualified_Expression
(Loc
,
12143 Subtype_Mark
=> Nam
,
12144 Expression
=> Relocate_Node
(N
));
12148 Save_Global_Descendant
(Field1
(N
));
12149 Save_Global_Descendant
(Field2
(N
));
12150 Save_Global_Descendant
(Field3
(N
));
12151 Save_Global_Descendant
(Field5
(N
));
12153 if Present
(Qual
) then
12157 -- All other cases than aggregates
12160 Save_Global_Descendant
(Field1
(N
));
12161 Save_Global_Descendant
(Field2
(N
));
12162 Save_Global_Descendant
(Field3
(N
));
12163 Save_Global_Descendant
(Field4
(N
));
12164 Save_Global_Descendant
(Field5
(N
));
12168 end Save_References
;
12170 -- Start of processing for Save_Global_References
12173 Gen_Scope
:= Current_Scope
;
12175 -- If the generic unit is a child unit, references to entities in the
12176 -- parent are treated as local, because they will be resolved anew in
12177 -- the context of the instance of the parent.
12179 while Is_Child_Unit
(Gen_Scope
)
12180 and then Ekind
(Scope
(Gen_Scope
)) = E_Generic_Package
12182 Gen_Scope
:= Scope
(Gen_Scope
);
12185 Save_References
(N
);
12186 end Save_Global_References
;
12188 --------------------------------------
12189 -- Set_Copied_Sloc_For_Inlined_Body --
12190 --------------------------------------
12192 procedure Set_Copied_Sloc_For_Inlined_Body
(N
: Node_Id
; E
: Entity_Id
) is
12194 Create_Instantiation_Source
(N
, E
, True, S_Adjustment
);
12195 end Set_Copied_Sloc_For_Inlined_Body
;
12197 ---------------------
12198 -- Set_Instance_Of --
12199 ---------------------
12201 procedure Set_Instance_Of
(A
: Entity_Id
; B
: Entity_Id
) is
12203 Generic_Renamings
.Table
(Generic_Renamings
.Last
) := (A
, B
, Assoc_Null
);
12204 Generic_Renamings_HTable
.Set
(Generic_Renamings
.Last
);
12205 Generic_Renamings
.Increment_Last
;
12206 end Set_Instance_Of
;
12208 --------------------
12209 -- Set_Next_Assoc --
12210 --------------------
12212 procedure Set_Next_Assoc
(E
: Assoc_Ptr
; Next
: Assoc_Ptr
) is
12214 Generic_Renamings
.Table
(E
).Next_In_HTable
:= Next
;
12215 end Set_Next_Assoc
;
12217 -------------------
12218 -- Start_Generic --
12219 -------------------
12221 procedure Start_Generic
is
12223 -- ??? More things could be factored out in this routine.
12224 -- Should probably be done at a later stage.
12226 Generic_Flags
.Append
(Inside_A_Generic
);
12227 Inside_A_Generic
:= True;
12229 Expander_Mode_Save_And_Set
(False);
12232 ----------------------
12233 -- Set_Instance_Env --
12234 ----------------------
12236 procedure Set_Instance_Env
12237 (Gen_Unit
: Entity_Id
;
12238 Act_Unit
: Entity_Id
)
12241 -- Regardless of the current mode, predefined units are analyzed in
12242 -- the most current Ada mode, and earlier version Ada checks do not
12243 -- apply to predefined units. Nothing needs to be done for non-internal
12244 -- units. These are always analyzed in the current mode.
12246 if Is_Internal_File_Name
12247 (Fname
=> Unit_File_Name
(Get_Source_Unit
(Gen_Unit
)),
12248 Renamings_Included
=> True)
12250 Set_Opt_Config_Switches
(True, Current_Sem_Unit
= Main_Unit
);
12253 Current_Instantiated_Parent
:= (Gen_Unit
, Act_Unit
, Assoc_Null
);
12254 end Set_Instance_Env
;
12260 procedure Switch_View
(T
: Entity_Id
) is
12261 BT
: constant Entity_Id
:= Base_Type
(T
);
12262 Priv_Elmt
: Elmt_Id
:= No_Elmt
;
12263 Priv_Sub
: Entity_Id
;
12266 -- T may be private but its base type may have been exchanged through
12267 -- some other occurrence, in which case there is nothing to switch
12268 -- besides T itself. Note that a private dependent subtype of a private
12269 -- type might not have been switched even if the base type has been,
12270 -- because of the last branch of Check_Private_View (see comment there).
12272 if not Is_Private_Type
(BT
) then
12273 Prepend_Elmt
(Full_View
(T
), Exchanged_Views
);
12274 Exchange_Declarations
(T
);
12278 Priv_Elmt
:= First_Elmt
(Private_Dependents
(BT
));
12280 if Present
(Full_View
(BT
)) then
12281 Prepend_Elmt
(Full_View
(BT
), Exchanged_Views
);
12282 Exchange_Declarations
(BT
);
12285 while Present
(Priv_Elmt
) loop
12286 Priv_Sub
:= (Node
(Priv_Elmt
));
12288 -- We avoid flipping the subtype if the Etype of its full view is
12289 -- private because this would result in a malformed subtype. This
12290 -- occurs when the Etype of the subtype full view is the full view of
12291 -- the base type (and since the base types were just switched, the
12292 -- subtype is pointing to the wrong view). This is currently the case
12293 -- for tagged record types, access types (maybe more?) and needs to
12294 -- be resolved. ???
12296 if Present
(Full_View
(Priv_Sub
))
12297 and then not Is_Private_Type
(Etype
(Full_View
(Priv_Sub
)))
12299 Prepend_Elmt
(Full_View
(Priv_Sub
), Exchanged_Views
);
12300 Exchange_Declarations
(Priv_Sub
);
12303 Next_Elmt
(Priv_Elmt
);
12307 -----------------------------
12308 -- Valid_Default_Attribute --
12309 -----------------------------
12311 procedure Valid_Default_Attribute
(Nam
: Entity_Id
; Def
: Node_Id
) is
12312 Attr_Id
: constant Attribute_Id
:=
12313 Get_Attribute_Id
(Attribute_Name
(Def
));
12314 T
: constant Entity_Id
:= Entity
(Prefix
(Def
));
12315 Is_Fun
: constant Boolean := (Ekind
(Nam
) = E_Function
);
12328 F
:= First_Formal
(Nam
);
12329 while Present
(F
) loop
12330 Num_F
:= Num_F
+ 1;
12335 when Attribute_Adjacent | Attribute_Ceiling | Attribute_Copy_Sign |
12336 Attribute_Floor | Attribute_Fraction | Attribute_Machine |
12337 Attribute_Model | Attribute_Remainder | Attribute_Rounding |
12338 Attribute_Unbiased_Rounding
=>
12341 and then Is_Floating_Point_Type
(T
);
12343 when Attribute_Image | Attribute_Pred | Attribute_Succ |
12344 Attribute_Value | Attribute_Wide_Image |
12345 Attribute_Wide_Value
=>
12346 OK
:= (Is_Fun
and then Num_F
= 1 and then Is_Scalar_Type
(T
));
12348 when Attribute_Max | Attribute_Min
=>
12349 OK
:= (Is_Fun
and then Num_F
= 2 and then Is_Scalar_Type
(T
));
12351 when Attribute_Input
=>
12352 OK
:= (Is_Fun
and then Num_F
= 1);
12354 when Attribute_Output | Attribute_Read | Attribute_Write
=>
12355 OK
:= (not Is_Fun
and then Num_F
= 2);
12362 Error_Msg_N
("attribute reference has wrong profile for subprogram",
12365 end Valid_Default_Attribute
;