1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Aspects
; use Aspects
;
27 with Atree
; use Atree
;
28 with Einfo
; use Einfo
;
29 with Elists
; use Elists
;
30 with Errout
; use Errout
;
31 with Expander
; use Expander
;
32 with Exp_Disp
; use Exp_Disp
;
33 with Fname
; use Fname
;
34 with Fname
.UF
; use Fname
.UF
;
35 with Freeze
; use Freeze
;
37 with Itypes
; use Itypes
;
39 with Lib
.Load
; use Lib
.Load
;
40 with Lib
.Xref
; use Lib
.Xref
;
41 with Nlists
; use Nlists
;
42 with Namet
; use Namet
;
43 with Nmake
; use Nmake
;
45 with Rident
; use Rident
;
46 with Restrict
; use Restrict
;
47 with Rtsfind
; use Rtsfind
;
49 with Sem_Aux
; use Sem_Aux
;
50 with Sem_Cat
; use Sem_Cat
;
51 with Sem_Ch3
; use Sem_Ch3
;
52 with Sem_Ch6
; use Sem_Ch6
;
53 with Sem_Ch7
; use Sem_Ch7
;
54 with Sem_Ch8
; use Sem_Ch8
;
55 with Sem_Ch10
; use Sem_Ch10
;
56 with Sem_Ch13
; use Sem_Ch13
;
57 with Sem_Disp
; use Sem_Disp
;
58 with Sem_Elab
; use Sem_Elab
;
59 with Sem_Elim
; use Sem_Elim
;
60 with Sem_Eval
; use Sem_Eval
;
61 with Sem_Res
; use Sem_Res
;
62 with Sem_Type
; use Sem_Type
;
63 with Sem_Util
; use Sem_Util
;
64 with Sem_Warn
; use Sem_Warn
;
65 with Stand
; use Stand
;
66 with Sinfo
; use Sinfo
;
67 with Sinfo
.CN
; use Sinfo
.CN
;
68 with Sinput
; use Sinput
;
69 with Sinput
.L
; use Sinput
.L
;
70 with Snames
; use Snames
;
71 with Stringt
; use Stringt
;
72 with Uname
; use Uname
;
74 with Tbuild
; use Tbuild
;
75 with Uintp
; use Uintp
;
76 with Urealp
; use Urealp
;
80 package body Sem_Ch12
is
82 ----------------------------------------------------------
83 -- Implementation of Generic Analysis and Instantiation --
84 ----------------------------------------------------------
86 -- GNAT implements generics by macro expansion. No attempt is made to share
87 -- generic instantiations (for now). Analysis of a generic definition does
88 -- not perform any expansion action, but the expander must be called on the
89 -- tree for each instantiation, because the expansion may of course depend
90 -- on the generic actuals. All of this is best achieved as follows:
92 -- a) Semantic analysis of a generic unit is performed on a copy of the
93 -- tree for the generic unit. All tree modifications that follow analysis
94 -- do not affect the original tree. Links are kept between the original
95 -- tree and the copy, in order to recognize non-local references within
96 -- the generic, and propagate them to each instance (recall that name
97 -- resolution is done on the generic declaration: generics are not really
98 -- macros!). This is summarized in the following diagram:
100 -- .-----------. .----------.
101 -- | semantic |<--------------| generic |
103 -- | |==============>| |
104 -- |___________| global |__________|
115 -- b) Each instantiation copies the original tree, and inserts into it a
116 -- series of declarations that describe the mapping between generic formals
117 -- and actuals. For example, a generic In OUT parameter is an object
118 -- renaming of the corresponding actual, etc. Generic IN parameters are
119 -- constant declarations.
121 -- c) In order to give the right visibility for these renamings, we use
122 -- a different scheme for package and subprogram instantiations. For
123 -- packages, the list of renamings is inserted into the package
124 -- specification, before the visible declarations of the package. The
125 -- renamings are analyzed before any of the text of the instance, and are
126 -- thus visible at the right place. Furthermore, outside of the instance,
127 -- the generic parameters are visible and denote their corresponding
130 -- For subprograms, we create a container package to hold the renamings
131 -- and the subprogram instance itself. Analysis of the package makes the
132 -- renaming declarations visible to the subprogram. After analyzing the
133 -- package, the defining entity for the subprogram is touched-up so that
134 -- it appears declared in the current scope, and not inside the container
137 -- If the instantiation is a compilation unit, the container package is
138 -- given the same name as the subprogram instance. This ensures that
139 -- the elaboration procedure called by the binder, using the compilation
140 -- unit name, calls in fact the elaboration procedure for the package.
142 -- Not surprisingly, private types complicate this approach. By saving in
143 -- the original generic object the non-local references, we guarantee that
144 -- the proper entities are referenced at the point of instantiation.
145 -- However, for private types, this by itself does not insure that the
146 -- proper VIEW of the entity is used (the full type may be visible at the
147 -- point of generic definition, but not at instantiation, or vice-versa).
148 -- In order to reference the proper view, we special-case any reference
149 -- to private types in the generic object, by saving both views, one in
150 -- the generic and one in the semantic copy. At time of instantiation, we
151 -- check whether the two views are consistent, and exchange declarations if
152 -- necessary, in order to restore the correct visibility. Similarly, if
153 -- the instance view is private when the generic view was not, we perform
154 -- the exchange. After completing the instantiation, we restore the
155 -- current visibility. The flag Has_Private_View marks identifiers in the
156 -- the generic unit that require checking.
158 -- Visibility within nested generic units requires special handling.
159 -- Consider the following scheme:
161 -- type Global is ... -- outside of generic unit.
165 -- type Semi_Global is ... -- global to inner.
168 -- procedure inner (X1 : Global; X2 : Semi_Global);
170 -- procedure in2 is new inner (...); -- 4
173 -- package New_Outer is new Outer (...); -- 2
174 -- procedure New_Inner is new New_Outer.Inner (...); -- 3
176 -- The semantic analysis of Outer captures all occurrences of Global.
177 -- The semantic analysis of Inner (at 1) captures both occurrences of
178 -- Global and Semi_Global.
180 -- At point 2 (instantiation of Outer), we also produce a generic copy
181 -- of Inner, even though Inner is, at that point, not being instantiated.
182 -- (This is just part of the semantic analysis of New_Outer).
184 -- Critically, references to Global within Inner must be preserved, while
185 -- references to Semi_Global should not preserved, because they must now
186 -- resolve to an entity within New_Outer. To distinguish between these, we
187 -- use a global variable, Current_Instantiated_Parent, which is set when
188 -- performing a generic copy during instantiation (at 2). This variable is
189 -- used when performing a generic copy that is not an instantiation, but
190 -- that is nested within one, as the occurrence of 1 within 2. The analysis
191 -- of a nested generic only preserves references that are global to the
192 -- enclosing Current_Instantiated_Parent. We use the Scope_Depth value to
193 -- determine whether a reference is external to the given parent.
195 -- The instantiation at point 3 requires no special treatment. The method
196 -- works as well for further nestings of generic units, but of course the
197 -- variable Current_Instantiated_Parent must be stacked because nested
198 -- instantiations can occur, e.g. the occurrence of 4 within 2.
200 -- The instantiation of package and subprogram bodies is handled in a
201 -- similar manner, except that it is delayed until after semantic
202 -- analysis is complete. In this fashion complex cross-dependencies
203 -- between several package declarations and bodies containing generics
204 -- can be compiled which otherwise would diagnose spurious circularities.
206 -- For example, it is possible to compile two packages A and B that
207 -- have the following structure:
209 -- package A is package B is
210 -- generic ... generic ...
211 -- package G_A is package G_B is
214 -- package body A is package body B is
215 -- package N_B is new G_B (..) package N_A is new G_A (..)
217 -- The table Pending_Instantiations in package Inline is used to keep
218 -- track of body instantiations that are delayed in this manner. Inline
219 -- handles the actual calls to do the body instantiations. This activity
220 -- is part of Inline, since the processing occurs at the same point, and
221 -- for essentially the same reason, as the handling of inlined routines.
223 ----------------------------------------------
224 -- Detection of Instantiation Circularities --
225 ----------------------------------------------
227 -- If we have a chain of instantiations that is circular, this is static
228 -- error which must be detected at compile time. The detection of these
229 -- circularities is carried out at the point that we insert a generic
230 -- instance spec or body. If there is a circularity, then the analysis of
231 -- the offending spec or body will eventually result in trying to load the
232 -- same unit again, and we detect this problem as we analyze the package
233 -- instantiation for the second time.
235 -- At least in some cases after we have detected the circularity, we get
236 -- into trouble if we try to keep going. The following flag is set if a
237 -- circularity is detected, and used to abandon compilation after the
238 -- messages have been posted.
240 Circularity_Detected
: Boolean := False;
241 -- This should really be reset on encountering a new main unit, but in
242 -- practice we are not using multiple main units so it is not critical.
244 -------------------------------------------------
245 -- Formal packages and partial parametrization --
246 -------------------------------------------------
248 -- When compiling a generic, a formal package is a local instantiation. If
249 -- declared with a box, its generic formals are visible in the enclosing
250 -- generic. If declared with a partial list of actuals, those actuals that
251 -- are defaulted (covered by an Others clause, or given an explicit box
252 -- initialization) are also visible in the enclosing generic, while those
253 -- that have a corresponding actual are not.
255 -- In our source model of instantiation, the same visibility must be
256 -- present in the spec and body of an instance: the names of the formals
257 -- that are defaulted must be made visible within the instance, and made
258 -- invisible (hidden) after the instantiation is complete, so that they
259 -- are not accessible outside of the instance.
261 -- In a generic, a formal package is treated like a special instantiation.
262 -- Our Ada 95 compiler handled formals with and without box in different
263 -- ways. With partial parametrization, we use a single model for both.
264 -- We create a package declaration that consists of the specification of
265 -- the generic package, and a set of declarations that map the actuals
266 -- into local renamings, just as we do for bona fide instantiations. For
267 -- defaulted parameters and formals with a box, we copy directly the
268 -- declarations of the formal into this local package. The result is a
269 -- a package whose visible declarations may include generic formals. This
270 -- package is only used for type checking and visibility analysis, and
271 -- never reaches the back-end, so it can freely violate the placement
272 -- rules for generic formal declarations.
274 -- The list of declarations (renamings and copies of formals) is built
275 -- by Analyze_Associations, just as for regular instantiations.
277 -- At the point of instantiation, conformance checking must be applied only
278 -- to those parameters that were specified in the formal. We perform this
279 -- checking by creating another internal instantiation, this one including
280 -- only the renamings and the formals (the rest of the package spec is not
281 -- relevant to conformance checking). We can then traverse two lists: the
282 -- list of actuals in the instance that corresponds to the formal package,
283 -- and the list of actuals produced for this bogus instantiation. We apply
284 -- the conformance rules to those actuals that are not defaulted (i.e.
285 -- which still appear as generic formals.
287 -- When we compile an instance body we must make the right parameters
288 -- visible again. The predicate Is_Generic_Formal indicates which of the
289 -- formals should have its Is_Hidden flag reset.
291 -----------------------
292 -- Local subprograms --
293 -----------------------
295 procedure Abandon_Instantiation
(N
: Node_Id
);
296 pragma No_Return
(Abandon_Instantiation
);
297 -- Posts an error message "instantiation abandoned" at the indicated node
298 -- and then raises the exception Instantiation_Error to do it.
300 procedure Analyze_Formal_Array_Type
301 (T
: in out Entity_Id
;
303 -- A formal array type is treated like an array type declaration, and
304 -- invokes Array_Type_Declaration (sem_ch3) whose first parameter is
305 -- in-out, because in the case of an anonymous type the entity is
306 -- actually created in the procedure.
308 -- The following procedures treat other kinds of formal parameters
310 procedure Analyze_Formal_Derived_Interface_Type
315 procedure Analyze_Formal_Derived_Type
320 procedure Analyze_Formal_Interface_Type
325 -- The following subprograms create abbreviated declarations for formal
326 -- scalar types. We introduce an anonymous base of the proper class for
327 -- each of them, and define the formals as constrained first subtypes of
328 -- their bases. The bounds are expressions that are non-static in the
331 procedure Analyze_Formal_Decimal_Fixed_Point_Type
332 (T
: Entity_Id
; Def
: Node_Id
);
333 procedure Analyze_Formal_Discrete_Type
(T
: Entity_Id
; Def
: Node_Id
);
334 procedure Analyze_Formal_Floating_Type
(T
: Entity_Id
; Def
: Node_Id
);
335 procedure Analyze_Formal_Signed_Integer_Type
(T
: Entity_Id
; Def
: Node_Id
);
336 procedure Analyze_Formal_Modular_Type
(T
: Entity_Id
; Def
: Node_Id
);
337 procedure Analyze_Formal_Ordinary_Fixed_Point_Type
338 (T
: Entity_Id
; Def
: Node_Id
);
340 procedure Analyze_Formal_Private_Type
344 -- Creates a new private type, which does not require completion
346 procedure Analyze_Formal_Incomplete_Type
(T
: Entity_Id
; Def
: Node_Id
);
347 -- Ada 2012: Creates a new incomplete type whose actual does not freeze
349 procedure Analyze_Generic_Formal_Part
(N
: Node_Id
);
350 -- Analyze generic formal part
352 procedure Analyze_Generic_Access_Type
(T
: Entity_Id
; Def
: Node_Id
);
353 -- Create a new access type with the given designated type
355 function Analyze_Associations
358 F_Copy
: List_Id
) return List_Id
;
359 -- At instantiation time, build the list of associations between formals
360 -- and actuals. Each association becomes a renaming declaration for the
361 -- formal entity. F_Copy is the analyzed list of formals in the generic
362 -- copy. It is used to apply legality checks to the actuals. I_Node is the
363 -- instantiation node itself.
365 procedure Analyze_Subprogram_Instantiation
369 procedure Build_Instance_Compilation_Unit_Nodes
373 -- This procedure is used in the case where the generic instance of a
374 -- subprogram body or package body is a library unit. In this case, the
375 -- original library unit node for the generic instantiation must be
376 -- replaced by the resulting generic body, and a link made to a new
377 -- compilation unit node for the generic declaration. The argument N is
378 -- the original generic instantiation. Act_Body and Act_Decl are the body
379 -- and declaration of the instance (either package body and declaration
380 -- nodes or subprogram body and declaration nodes depending on the case).
381 -- On return, the node N has been rewritten with the actual body.
383 procedure Check_Access_Definition
(N
: Node_Id
);
384 -- Subsidiary routine to null exclusion processing. Perform an assertion
385 -- check on Ada version and the presence of an access definition in N.
387 procedure Check_Formal_Packages
(P_Id
: Entity_Id
);
388 -- Apply the following to all formal packages in generic associations
390 procedure Check_Formal_Package_Instance
391 (Formal_Pack
: Entity_Id
;
392 Actual_Pack
: Entity_Id
);
393 -- Verify that the actuals of the actual instance match the actuals of
394 -- the template for a formal package that is not declared with a box.
396 procedure Check_Forward_Instantiation
(Decl
: Node_Id
);
397 -- If the generic is a local entity and the corresponding body has not
398 -- been seen yet, flag enclosing packages to indicate that it will be
399 -- elaborated after the generic body. Subprograms declared in the same
400 -- package cannot be inlined by the front-end because front-end inlining
401 -- requires a strict linear order of elaboration.
403 function Check_Hidden_Primitives
(Assoc_List
: List_Id
) return Elist_Id
;
404 -- Check if some association between formals and actuals requires to make
405 -- visible primitives of a tagged type, and make those primitives visible.
406 -- Return the list of primitives whose visibility is modified (to restore
407 -- their visibility later through Restore_Hidden_Primitives). If no
408 -- candidate is found then return No_Elist.
410 procedure Check_Hidden_Child_Unit
412 Gen_Unit
: Entity_Id
;
413 Act_Decl_Id
: Entity_Id
);
414 -- If the generic unit is an implicit child instance within a parent
415 -- instance, we need to make an explicit test that it is not hidden by
416 -- a child instance of the same name and parent.
418 procedure Check_Generic_Actuals
419 (Instance
: Entity_Id
;
420 Is_Formal_Box
: Boolean);
421 -- Similar to previous one. Check the actuals in the instantiation,
422 -- whose views can change between the point of instantiation and the point
423 -- of instantiation of the body. In addition, mark the generic renamings
424 -- as generic actuals, so that they are not compatible with other actuals.
425 -- Recurse on an actual that is a formal package whose declaration has
428 function Contains_Instance_Of
431 N
: Node_Id
) return Boolean;
432 -- Inner is instantiated within the generic Outer. Check whether Inner
433 -- directly or indirectly contains an instance of Outer or of one of its
434 -- parents, in the case of a subunit. Each generic unit holds a list of
435 -- the entities instantiated within (at any depth). This procedure
436 -- determines whether the set of such lists contains a cycle, i.e. an
437 -- illegal circular instantiation.
439 function Denotes_Formal_Package
441 On_Exit
: Boolean := False;
442 Instance
: Entity_Id
:= Empty
) return Boolean;
443 -- Returns True if E is a formal package of an enclosing generic, or
444 -- the actual for such a formal in an enclosing instantiation. If such
445 -- a package is used as a formal in an nested generic, or as an actual
446 -- in a nested instantiation, the visibility of ITS formals should not
447 -- be modified. When called from within Restore_Private_Views, the flag
448 -- On_Exit is true, to indicate that the search for a possible enclosing
449 -- instance should ignore the current one. In that case Instance denotes
450 -- the declaration for which this is an actual. This declaration may be
451 -- an instantiation in the source, or the internal instantiation that
452 -- corresponds to the actual for a formal package.
454 function Earlier
(N1
, N2
: Node_Id
) return Boolean;
455 -- Yields True if N1 and N2 appear in the same compilation unit,
456 -- ignoring subunits, and if N1 is to the left of N2 in a left-to-right
457 -- traversal of the tree for the unit. Used to determine the placement
458 -- of freeze nodes for instance bodies that may depend on other instances.
460 function Find_Actual_Type
462 Gen_Type
: Entity_Id
) return Entity_Id
;
463 -- When validating the actual types of a child instance, check whether
464 -- the formal is a formal type of the parent unit, and retrieve the current
465 -- actual for it. Typ is the entity in the analyzed formal type declaration
466 -- (component or index type of an array type, or designated type of an
467 -- access formal) and Gen_Type is the enclosing analyzed formal array
468 -- or access type. The desired actual may be a formal of a parent, or may
469 -- be declared in a formal package of a parent. In both cases it is a
470 -- generic actual type because it appears within a visible instance.
471 -- Finally, it may be declared in a parent unit without being a formal
472 -- of that unit, in which case it must be retrieved by visibility.
473 -- Ambiguities may still arise if two homonyms are declared in two formal
474 -- packages, and the prefix of the formal type may be needed to resolve
475 -- the ambiguity in the instance ???
477 function In_Same_Declarative_Part
479 Inst
: Node_Id
) return Boolean;
480 -- True if the instantiation Inst and the given freeze_node F_Node appear
481 -- within the same declarative part, ignoring subunits, but with no inter-
482 -- vening subprograms or concurrent units. Used to find the proper plave
483 -- for the freeze node of an instance, when the generic is declared in a
484 -- previous instance. If predicate is true, the freeze node of the instance
485 -- can be placed after the freeze node of the previous instance, Otherwise
486 -- it has to be placed at the end of the current declarative part.
488 function In_Main_Context
(E
: Entity_Id
) return Boolean;
489 -- Check whether an instantiation is in the context of the main unit.
490 -- Used to determine whether its body should be elaborated to allow
491 -- front-end inlining.
493 procedure Set_Instance_Env
494 (Gen_Unit
: Entity_Id
;
495 Act_Unit
: Entity_Id
);
496 -- Save current instance on saved environment, to be used to determine
497 -- the global status of entities in nested instances. Part of Save_Env.
498 -- called after verifying that the generic unit is legal for the instance,
499 -- The procedure also examines whether the generic unit is a predefined
500 -- unit, in order to set configuration switches accordingly. As a result
501 -- the procedure must be called after analyzing and freezing the actuals.
503 procedure Set_Instance_Of
(A
: Entity_Id
; B
: Entity_Id
);
504 -- Associate analyzed generic parameter with corresponding
505 -- instance. Used for semantic checks at instantiation time.
507 function Has_Been_Exchanged
(E
: Entity_Id
) return Boolean;
508 -- Traverse the Exchanged_Views list to see if a type was private
509 -- and has already been flipped during this phase of instantiation.
511 procedure Hide_Current_Scope
;
512 -- When instantiating a generic child unit, the parent context must be
513 -- present, but the instance and all entities that may be generated
514 -- must be inserted in the current scope. We leave the current scope
515 -- on the stack, but make its entities invisible to avoid visibility
516 -- problems. This is reversed at the end of the instantiation. This is
517 -- not done for the instantiation of the bodies, which only require the
518 -- instances of the generic parents to be in scope.
520 procedure Install_Body
525 -- If the instantiation happens textually before the body of the generic,
526 -- the instantiation of the body must be analyzed after the generic body,
527 -- and not at the point of instantiation. Such early instantiations can
528 -- happen if the generic and the instance appear in a package declaration
529 -- because the generic body can only appear in the corresponding package
530 -- body. Early instantiations can also appear if generic, instance and
531 -- body are all in the declarative part of a subprogram or entry. Entities
532 -- of packages that are early instantiations are delayed, and their freeze
533 -- node appears after the generic body.
535 procedure Insert_Freeze_Node_For_Instance
538 -- N denotes a package or a subprogram instantiation and F_Node is the
539 -- associated freeze node. Insert the freeze node before the first source
540 -- body which follows immediately after N. If no such body is found, the
541 -- freeze node is inserted at the end of the declarative region which
544 procedure Freeze_Subprogram_Body
545 (Inst_Node
: Node_Id
;
547 Pack_Id
: Entity_Id
);
548 -- The generic body may appear textually after the instance, including
549 -- in the proper body of a stub, or within a different package instance.
550 -- Given that the instance can only be elaborated after the generic, we
551 -- place freeze_nodes for the instance and/or for packages that may enclose
552 -- the instance and the generic, so that the back-end can establish the
553 -- proper order of elaboration.
556 -- Establish environment for subsequent instantiation. Separated from
557 -- Save_Env because data-structures for visibility handling must be
558 -- initialized before call to Check_Generic_Child_Unit.
560 procedure Install_Formal_Packages
(Par
: Entity_Id
);
561 -- Install the visible part of any formal of the parent that is a formal
562 -- package. Note that for the case of a formal package with a box, this
563 -- includes the formal part of the formal package (12.7(10/2)).
565 procedure Install_Parent
(P
: Entity_Id
; In_Body
: Boolean := False);
566 -- When compiling an instance of a child unit the parent (which is
567 -- itself an instance) is an enclosing scope that must be made
568 -- immediately visible. This procedure is also used to install the non-
569 -- generic parent of a generic child unit when compiling its body, so
570 -- that full views of types in the parent are made visible.
572 procedure Remove_Parent
(In_Body
: Boolean := False);
573 -- Reverse effect after instantiation of child is complete
575 procedure Install_Hidden_Primitives
576 (Prims_List
: in out Elist_Id
;
579 -- Remove suffix 'P' from hidden primitives of Act_T to match the
580 -- visibility of primitives of Gen_T. The list of primitives to which
581 -- the suffix is removed is added to Prims_List to restore them later.
583 procedure Restore_Hidden_Primitives
(Prims_List
: in out Elist_Id
);
584 -- Restore suffix 'P' to primitives of Prims_List and leave Prims_List
587 procedure Inline_Instance_Body
589 Gen_Unit
: Entity_Id
;
591 -- If front-end inlining is requested, instantiate the package body,
592 -- and preserve the visibility of its compilation unit, to insure
593 -- that successive instantiations succeed.
595 -- The functions Instantiate_XXX perform various legality checks and build
596 -- the declarations for instantiated generic parameters. In all of these
597 -- Formal is the entity in the generic unit, Actual is the entity of
598 -- expression in the generic associations, and Analyzed_Formal is the
599 -- formal in the generic copy, which contains the semantic information to
600 -- be used to validate the actual.
602 function Instantiate_Object
605 Analyzed_Formal
: Node_Id
) return List_Id
;
607 function Instantiate_Type
610 Analyzed_Formal
: Node_Id
;
611 Actual_Decls
: List_Id
) return List_Id
;
613 function Instantiate_Formal_Subprogram
616 Analyzed_Formal
: Node_Id
) return Node_Id
;
618 function Instantiate_Formal_Package
621 Analyzed_Formal
: Node_Id
) return List_Id
;
622 -- If the formal package is declared with a box, special visibility rules
623 -- apply to its formals: they are in the visible part of the package. This
624 -- is true in the declarative region of the formal package, that is to say
625 -- in the enclosing generic or instantiation. For an instantiation, the
626 -- parameters of the formal package are made visible in an explicit step.
627 -- Furthermore, if the actual has a visible USE clause, these formals must
628 -- be made potentially use-visible as well. On exit from the enclosing
629 -- instantiation, the reverse must be done.
631 -- For a formal package declared without a box, there are conformance rules
632 -- that apply to the actuals in the generic declaration and the actuals of
633 -- the actual package in the enclosing instantiation. The simplest way to
634 -- apply these rules is to repeat the instantiation of the formal package
635 -- in the context of the enclosing instance, and compare the generic
636 -- associations of this instantiation with those of the actual package.
637 -- This internal instantiation only needs to contain the renamings of the
638 -- formals: the visible and private declarations themselves need not be
641 -- In Ada 2005, the formal package may be only partially parameterized.
642 -- In that case the visibility step must make visible those actuals whose
643 -- corresponding formals were given with a box. A final complication
644 -- involves inherited operations from formal derived types, which must
645 -- be visible if the type is.
647 function Is_In_Main_Unit
(N
: Node_Id
) return Boolean;
648 -- Test if given node is in the main unit
650 procedure Load_Parent_Of_Generic
653 Body_Optional
: Boolean := False);
654 -- If the generic appears in a separate non-generic library unit, load the
655 -- corresponding body to retrieve the body of the generic. N is the node
656 -- for the generic instantiation, Spec is the generic package declaration.
658 -- Body_Optional is a flag that indicates that the body is being loaded to
659 -- ensure that temporaries are generated consistently when there are other
660 -- instances in the current declarative part that precede the one being
661 -- loaded. In that case a missing body is acceptable.
663 procedure Inherit_Context
(Gen_Decl
: Node_Id
; Inst
: Node_Id
);
664 -- Add the context clause of the unit containing a generic unit to a
665 -- compilation unit that is, or contains, an instantiation.
667 function Get_Associated_Node
(N
: Node_Id
) return Node_Id
;
668 -- In order to propagate semantic information back from the analyzed copy
669 -- to the original generic, we maintain links between selected nodes in the
670 -- generic and their corresponding copies. At the end of generic analysis,
671 -- the routine Save_Global_References traverses the generic tree, examines
672 -- the semantic information, and preserves the links to those nodes that
673 -- contain global information. At instantiation, the information from the
674 -- associated node is placed on the new copy, so that name resolution is
677 -- Three kinds of source nodes have associated nodes:
679 -- a) those that can reference (denote) entities, that is identifiers,
680 -- character literals, expanded_names, operator symbols, operators,
681 -- and attribute reference nodes. These nodes have an Entity field
682 -- and are the set of nodes that are in N_Has_Entity.
684 -- b) aggregates (N_Aggregate and N_Extension_Aggregate)
686 -- c) selected components (N_Selected_Component)
688 -- For the first class, the associated node preserves the entity if it is
689 -- global. If the generic contains nested instantiations, the associated
690 -- node itself has been recopied, and a chain of them must be followed.
692 -- For aggregates, the associated node allows retrieval of the type, which
693 -- may otherwise not appear in the generic. The view of this type may be
694 -- different between generic and instantiation, and the full view can be
695 -- installed before the instantiation is analyzed. For aggregates of type
696 -- extensions, the same view exchange may have to be performed for some of
697 -- the ancestor types, if their view is private at the point of
700 -- Nodes that are selected components in the parse tree may be rewritten
701 -- as expanded names after resolution, and must be treated as potential
702 -- entity holders, which is why they also have an Associated_Node.
704 -- Nodes that do not come from source, such as freeze nodes, do not appear
705 -- in the generic tree, and need not have an associated node.
707 -- The associated node is stored in the Associated_Node field. Note that
708 -- this field overlaps Entity, which is fine, because the whole point is
709 -- that we don't need or want the normal Entity field in this situation.
711 procedure Map_Formal_Package_Entities
(Form
: Entity_Id
; Act
: Entity_Id
);
712 -- Within the generic part, entities in the formal package are
713 -- visible. To validate subsequent type declarations, indicate
714 -- the correspondence between the entities in the analyzed formal,
715 -- and the entities in the actual package. There are three packages
716 -- involved in the instantiation of a formal package: the parent
717 -- generic P1 which appears in the generic declaration, the fake
718 -- instantiation P2 which appears in the analyzed generic, and whose
719 -- visible entities may be used in subsequent formals, and the actual
720 -- P3 in the instance. To validate subsequent formals, me indicate
721 -- that the entities in P2 are mapped into those of P3. The mapping of
722 -- entities has to be done recursively for nested packages.
724 procedure Move_Freeze_Nodes
728 -- Freeze nodes can be generated in the analysis of a generic unit, but
729 -- will not be seen by the back-end. It is necessary to move those nodes
730 -- to the enclosing scope if they freeze an outer entity. We place them
731 -- at the end of the enclosing generic package, which is semantically
734 procedure Preanalyze_Actuals
(N
: Node_Id
);
735 -- Analyze actuals to perform name resolution. Full resolution is done
736 -- later, when the expected types are known, but names have to be captured
737 -- before installing parents of generics, that are not visible for the
738 -- actuals themselves.
740 function True_Parent
(N
: Node_Id
) return Node_Id
;
741 -- For a subunit, return parent of corresponding stub
743 procedure Valid_Default_Attribute
(Nam
: Entity_Id
; Def
: Node_Id
);
744 -- Verify that an attribute that appears as the default for a formal
745 -- subprogram is a function or procedure with the correct profile.
747 -------------------------------------------
748 -- Data Structures for Generic Renamings --
749 -------------------------------------------
751 -- The map Generic_Renamings associates generic entities with their
752 -- corresponding actuals. Currently used to validate type instances. It
753 -- will eventually be used for all generic parameters to eliminate the
754 -- need for overload resolution in the instance.
756 type Assoc_Ptr
is new Int
;
758 Assoc_Null
: constant Assoc_Ptr
:= -1;
763 Next_In_HTable
: Assoc_Ptr
;
766 package Generic_Renamings
is new Table
.Table
767 (Table_Component_Type
=> Assoc
,
768 Table_Index_Type
=> Assoc_Ptr
,
769 Table_Low_Bound
=> 0,
771 Table_Increment
=> 100,
772 Table_Name
=> "Generic_Renamings");
774 -- Variable to hold enclosing instantiation. When the environment is
775 -- saved for a subprogram inlining, the corresponding Act_Id is empty.
777 Current_Instantiated_Parent
: Assoc
:= (Empty
, Empty
, Assoc_Null
);
779 -- Hash table for associations
781 HTable_Size
: constant := 37;
782 type HTable_Range
is range 0 .. HTable_Size
- 1;
784 procedure Set_Next_Assoc
(E
: Assoc_Ptr
; Next
: Assoc_Ptr
);
785 function Next_Assoc
(E
: Assoc_Ptr
) return Assoc_Ptr
;
786 function Get_Gen_Id
(E
: Assoc_Ptr
) return Entity_Id
;
787 function Hash
(F
: Entity_Id
) return HTable_Range
;
789 package Generic_Renamings_HTable
is new GNAT
.HTable
.Static_HTable
(
790 Header_Num
=> HTable_Range
,
792 Elmt_Ptr
=> Assoc_Ptr
,
793 Null_Ptr
=> Assoc_Null
,
794 Set_Next
=> Set_Next_Assoc
,
797 Get_Key
=> Get_Gen_Id
,
801 Exchanged_Views
: Elist_Id
;
802 -- This list holds the private views that have been exchanged during
803 -- instantiation to restore the visibility of the generic declaration.
804 -- (see comments above). After instantiation, the current visibility is
805 -- reestablished by means of a traversal of this list.
807 Hidden_Entities
: Elist_Id
;
808 -- This list holds the entities of the current scope that are removed
809 -- from immediate visibility when instantiating a child unit. Their
810 -- visibility is restored in Remove_Parent.
812 -- Because instantiations can be recursive, the following must be saved
813 -- on entry and restored on exit from an instantiation (spec or body).
814 -- This is done by the two procedures Save_Env and Restore_Env. For
815 -- package and subprogram instantiations (but not for the body instances)
816 -- the action of Save_Env is done in two steps: Init_Env is called before
817 -- Check_Generic_Child_Unit, because setting the parent instances requires
818 -- that the visibility data structures be properly initialized. Once the
819 -- generic is unit is validated, Set_Instance_Env completes Save_Env.
821 Parent_Unit_Visible
: Boolean := False;
822 -- Parent_Unit_Visible is used when the generic is a child unit, and
823 -- indicates whether the ultimate parent of the generic is visible in the
824 -- instantiation environment. It is used to reset the visibility of the
825 -- parent at the end of the instantiation (see Remove_Parent).
827 Instance_Parent_Unit
: Entity_Id
:= Empty
;
828 -- This records the ultimate parent unit of an instance of a generic
829 -- child unit and is used in conjunction with Parent_Unit_Visible to
830 -- indicate the unit to which the Parent_Unit_Visible flag corresponds.
832 type Instance_Env
is record
833 Instantiated_Parent
: Assoc
;
834 Exchanged_Views
: Elist_Id
;
835 Hidden_Entities
: Elist_Id
;
836 Current_Sem_Unit
: Unit_Number_Type
;
837 Parent_Unit_Visible
: Boolean := False;
838 Instance_Parent_Unit
: Entity_Id
:= Empty
;
839 Switches
: Config_Switches_Type
;
842 package Instance_Envs
is new Table
.Table
(
843 Table_Component_Type
=> Instance_Env
,
844 Table_Index_Type
=> Int
,
845 Table_Low_Bound
=> 0,
847 Table_Increment
=> 100,
848 Table_Name
=> "Instance_Envs");
850 procedure Restore_Private_Views
851 (Pack_Id
: Entity_Id
;
852 Is_Package
: Boolean := True);
853 -- Restore the private views of external types, and unmark the generic
854 -- renamings of actuals, so that they become compatible subtypes again.
855 -- For subprograms, Pack_Id is the package constructed to hold the
858 procedure Switch_View
(T
: Entity_Id
);
859 -- Switch the partial and full views of a type and its private
860 -- dependents (i.e. its subtypes and derived types).
862 ------------------------------------
863 -- Structures for Error Reporting --
864 ------------------------------------
866 Instantiation_Node
: Node_Id
;
867 -- Used by subprograms that validate instantiation of formal parameters
868 -- where there might be no actual on which to place the error message.
869 -- Also used to locate the instantiation node for generic subunits.
871 Instantiation_Error
: exception;
872 -- When there is a semantic error in the generic parameter matching,
873 -- there is no point in continuing the instantiation, because the
874 -- number of cascaded errors is unpredictable. This exception aborts
875 -- the instantiation process altogether.
877 S_Adjustment
: Sloc_Adjustment
;
878 -- Offset created for each node in an instantiation, in order to keep
879 -- track of the source position of the instantiation in each of its nodes.
880 -- A subsequent semantic error or warning on a construct of the instance
881 -- points to both places: the original generic node, and the point of
882 -- instantiation. See Sinput and Sinput.L for additional details.
884 ------------------------------------------------------------
885 -- Data structure for keeping track when inside a Generic --
886 ------------------------------------------------------------
888 -- The following table is used to save values of the Inside_A_Generic
889 -- flag (see spec of Sem) when they are saved by Start_Generic.
891 package Generic_Flags
is new Table
.Table
(
892 Table_Component_Type
=> Boolean,
893 Table_Index_Type
=> Int
,
894 Table_Low_Bound
=> 0,
896 Table_Increment
=> 200,
897 Table_Name
=> "Generic_Flags");
899 ---------------------------
900 -- Abandon_Instantiation --
901 ---------------------------
903 procedure Abandon_Instantiation
(N
: Node_Id
) is
905 Error_Msg_N
("\instantiation abandoned!", N
);
906 raise Instantiation_Error
;
907 end Abandon_Instantiation
;
909 --------------------------
910 -- Analyze_Associations --
911 --------------------------
913 function Analyze_Associations
916 F_Copy
: List_Id
) return List_Id
918 Actual_Types
: constant Elist_Id
:= New_Elmt_List
;
919 Assoc
: constant List_Id
:= New_List
;
920 Default_Actuals
: constant Elist_Id
:= New_Elmt_List
;
921 Gen_Unit
: constant Entity_Id
:=
922 Defining_Entity
(Parent
(F_Copy
));
927 Next_Formal
: Node_Id
;
928 Analyzed_Formal
: Node_Id
;
931 First_Named
: Node_Id
:= Empty
;
933 Default_Formals
: constant List_Id
:= New_List
;
934 -- If an Others_Choice is present, some of the formals may be defaulted.
935 -- To simplify the treatment of visibility in an instance, we introduce
936 -- individual defaults for each such formal. These defaults are
937 -- appended to the list of associations and replace the Others_Choice.
939 Found_Assoc
: Node_Id
;
940 -- Association for the current formal being match. Empty if there are
941 -- no remaining actuals, or if there is no named association with the
942 -- name of the formal.
944 Is_Named_Assoc
: Boolean;
945 Num_Matched
: Int
:= 0;
946 Num_Actuals
: Int
:= 0;
948 Others_Present
: Boolean := False;
949 Others_Choice
: Node_Id
:= Empty
;
950 -- In Ada 2005, indicates partial parametrization of a formal
951 -- package. As usual an other association must be last in the list.
953 procedure Check_Overloaded_Formal_Subprogram
(Formal
: Entity_Id
);
954 -- Apply RM 12.3 (9): if a formal subprogram is overloaded, the instance
955 -- cannot have a named association for it. AI05-0025 extends this rule
956 -- to formals of formal packages by AI05-0025, and it also applies to
957 -- box-initialized formals.
959 function Matching_Actual
961 A_F
: Entity_Id
) return Node_Id
;
962 -- Find actual that corresponds to a given a formal parameter. If the
963 -- actuals are positional, return the next one, if any. If the actuals
964 -- are named, scan the parameter associations to find the right one.
965 -- A_F is the corresponding entity in the analyzed generic,which is
966 -- placed on the selector name for ASIS use.
968 -- In Ada 2005, a named association may be given with a box, in which
969 -- case Matching_Actual sets Found_Assoc to the generic association,
970 -- but return Empty for the actual itself. In this case the code below
971 -- creates a corresponding declaration for the formal.
973 function Partial_Parametrization
return Boolean;
974 -- Ada 2005: if no match is found for a given formal, check if the
975 -- association for it includes a box, or whether the associations
976 -- include an Others clause.
978 procedure Process_Default
(F
: Entity_Id
);
979 -- Add a copy of the declaration of generic formal F to the list of
980 -- associations, and add an explicit box association for F if there
981 -- is none yet, and the default comes from an Others_Choice.
983 procedure Set_Analyzed_Formal
;
984 -- Find the node in the generic copy that corresponds to a given formal.
985 -- The semantic information on this node is used to perform legality
986 -- checks on the actuals. Because semantic analysis can introduce some
987 -- anonymous entities or modify the declaration node itself, the
988 -- correspondence between the two lists is not one-one. In addition to
989 -- anonymous types, the presence a formal equality will introduce an
990 -- implicit declaration for the corresponding inequality.
992 ----------------------------------------
993 -- Check_Overloaded_Formal_Subprogram --
994 ----------------------------------------
996 procedure Check_Overloaded_Formal_Subprogram
(Formal
: Entity_Id
) is
997 Temp_Formal
: Entity_Id
;
1000 Temp_Formal
:= First
(Formals
);
1001 while Present
(Temp_Formal
) loop
1002 if Nkind
(Temp_Formal
) in N_Formal_Subprogram_Declaration
1003 and then Temp_Formal
/= Formal
1005 Chars
(Defining_Unit_Name
(Specification
(Formal
))) =
1006 Chars
(Defining_Unit_Name
(Specification
(Temp_Formal
)))
1008 if Present
(Found_Assoc
) then
1010 ("named association not allowed for overloaded formal",
1015 ("named association not allowed for overloaded formal",
1019 Abandon_Instantiation
(Instantiation_Node
);
1024 end Check_Overloaded_Formal_Subprogram
;
1026 ---------------------
1027 -- Matching_Actual --
1028 ---------------------
1030 function Matching_Actual
1032 A_F
: Entity_Id
) return Node_Id
1038 Is_Named_Assoc
:= False;
1040 -- End of list of purely positional parameters
1042 if No
(Actual
) or else Nkind
(Actual
) = N_Others_Choice
then
1043 Found_Assoc
:= Empty
;
1046 -- Case of positional parameter corresponding to current formal
1048 elsif No
(Selector_Name
(Actual
)) then
1049 Found_Assoc
:= Actual
;
1050 Act
:= Explicit_Generic_Actual_Parameter
(Actual
);
1051 Num_Matched
:= Num_Matched
+ 1;
1054 -- Otherwise scan list of named actuals to find the one with the
1055 -- desired name. All remaining actuals have explicit names.
1058 Is_Named_Assoc
:= True;
1059 Found_Assoc
:= Empty
;
1063 while Present
(Actual
) loop
1064 if Chars
(Selector_Name
(Actual
)) = Chars
(F
) then
1065 Set_Entity
(Selector_Name
(Actual
), A_F
);
1066 Set_Etype
(Selector_Name
(Actual
), Etype
(A_F
));
1067 Generate_Reference
(A_F
, Selector_Name
(Actual
));
1068 Found_Assoc
:= Actual
;
1069 Act
:= Explicit_Generic_Actual_Parameter
(Actual
);
1070 Num_Matched
:= Num_Matched
+ 1;
1078 -- Reset for subsequent searches. In most cases the named
1079 -- associations are in order. If they are not, we reorder them
1080 -- to avoid scanning twice the same actual. This is not just a
1081 -- question of efficiency: there may be multiple defaults with
1082 -- boxes that have the same name. In a nested instantiation we
1083 -- insert actuals for those defaults, and cannot rely on their
1084 -- names to disambiguate them.
1086 if Actual
= First_Named
then
1089 elsif Present
(Actual
) then
1090 Insert_Before
(First_Named
, Remove_Next
(Prev
));
1093 Actual
:= First_Named
;
1096 if Is_Entity_Name
(Act
) and then Present
(Entity
(Act
)) then
1097 Set_Used_As_Generic_Actual
(Entity
(Act
));
1101 end Matching_Actual
;
1103 -----------------------------
1104 -- Partial_Parametrization --
1105 -----------------------------
1107 function Partial_Parametrization
return Boolean is
1109 return Others_Present
1110 or else (Present
(Found_Assoc
) and then Box_Present
(Found_Assoc
));
1111 end Partial_Parametrization
;
1113 ---------------------
1114 -- Process_Default --
1115 ---------------------
1117 procedure Process_Default
(F
: Entity_Id
) is
1118 Loc
: constant Source_Ptr
:= Sloc
(I_Node
);
1119 F_Id
: constant Entity_Id
:= Defining_Entity
(F
);
1125 -- Append copy of formal declaration to associations, and create new
1126 -- defining identifier for it.
1128 Decl
:= New_Copy_Tree
(F
);
1129 Id
:= Make_Defining_Identifier
(Sloc
(F_Id
), Chars
(F_Id
));
1131 if Nkind
(F
) in N_Formal_Subprogram_Declaration
then
1132 Set_Defining_Unit_Name
(Specification
(Decl
), Id
);
1135 Set_Defining_Identifier
(Decl
, Id
);
1138 Append
(Decl
, Assoc
);
1140 if No
(Found_Assoc
) then
1142 Make_Generic_Association
(Loc
,
1143 Selector_Name
=> New_Occurrence_Of
(Id
, Loc
),
1144 Explicit_Generic_Actual_Parameter
=> Empty
);
1145 Set_Box_Present
(Default
);
1146 Append
(Default
, Default_Formals
);
1148 end Process_Default
;
1150 -------------------------
1151 -- Set_Analyzed_Formal --
1152 -------------------------
1154 procedure Set_Analyzed_Formal
is
1158 while Present
(Analyzed_Formal
) loop
1159 Kind
:= Nkind
(Analyzed_Formal
);
1161 case Nkind
(Formal
) is
1163 when N_Formal_Subprogram_Declaration
=>
1164 exit when Kind
in N_Formal_Subprogram_Declaration
1167 (Defining_Unit_Name
(Specification
(Formal
))) =
1169 (Defining_Unit_Name
(Specification
(Analyzed_Formal
)));
1171 when N_Formal_Package_Declaration
=>
1172 exit when Nkind_In
(Kind
, N_Formal_Package_Declaration
,
1173 N_Generic_Package_Declaration
,
1174 N_Package_Declaration
);
1176 when N_Use_Package_Clause | N_Use_Type_Clause
=> exit;
1180 -- Skip freeze nodes, and nodes inserted to replace
1181 -- unrecognized pragmas.
1184 Kind
not in N_Formal_Subprogram_Declaration
1185 and then not Nkind_In
(Kind
, N_Subprogram_Declaration
,
1189 and then Chars
(Defining_Identifier
(Formal
)) =
1190 Chars
(Defining_Identifier
(Analyzed_Formal
));
1193 Next
(Analyzed_Formal
);
1195 end Set_Analyzed_Formal
;
1197 -- Start of processing for Analyze_Associations
1200 Actuals
:= Generic_Associations
(I_Node
);
1202 if Present
(Actuals
) then
1204 -- Check for an Others choice, indicating a partial parametrization
1205 -- for a formal package.
1207 Actual
:= First
(Actuals
);
1208 while Present
(Actual
) loop
1209 if Nkind
(Actual
) = N_Others_Choice
then
1210 Others_Present
:= True;
1211 Others_Choice
:= Actual
;
1213 if Present
(Next
(Actual
)) then
1214 Error_Msg_N
("others must be last association", Actual
);
1217 -- This subprogram is used both for formal packages and for
1218 -- instantiations. For the latter, associations must all be
1221 if Nkind
(I_Node
) /= N_Formal_Package_Declaration
1222 and then Comes_From_Source
(I_Node
)
1225 ("others association not allowed in an instance",
1229 -- In any case, nothing to do after the others association
1233 elsif Box_Present
(Actual
)
1234 and then Comes_From_Source
(I_Node
)
1235 and then Nkind
(I_Node
) /= N_Formal_Package_Declaration
1238 ("box association not allowed in an instance", Actual
);
1244 -- If named associations are present, save first named association
1245 -- (it may of course be Empty) to facilitate subsequent name search.
1247 First_Named
:= First
(Actuals
);
1248 while Present
(First_Named
)
1249 and then Nkind
(First_Named
) /= N_Others_Choice
1250 and then No
(Selector_Name
(First_Named
))
1252 Num_Actuals
:= Num_Actuals
+ 1;
1257 Named
:= First_Named
;
1258 while Present
(Named
) loop
1259 if Nkind
(Named
) /= N_Others_Choice
1260 and then No
(Selector_Name
(Named
))
1262 Error_Msg_N
("invalid positional actual after named one", Named
);
1263 Abandon_Instantiation
(Named
);
1266 -- A named association may lack an actual parameter, if it was
1267 -- introduced for a default subprogram that turns out to be local
1268 -- to the outer instantiation.
1270 if Nkind
(Named
) /= N_Others_Choice
1271 and then Present
(Explicit_Generic_Actual_Parameter
(Named
))
1273 Num_Actuals
:= Num_Actuals
+ 1;
1279 if Present
(Formals
) then
1280 Formal
:= First_Non_Pragma
(Formals
);
1281 Analyzed_Formal
:= First_Non_Pragma
(F_Copy
);
1283 if Present
(Actuals
) then
1284 Actual
:= First
(Actuals
);
1286 -- All formals should have default values
1292 while Present
(Formal
) loop
1293 Set_Analyzed_Formal
;
1294 Next_Formal
:= Next_Non_Pragma
(Formal
);
1296 case Nkind
(Formal
) is
1297 when N_Formal_Object_Declaration
=>
1300 Defining_Identifier
(Formal
),
1301 Defining_Identifier
(Analyzed_Formal
));
1303 if No
(Match
) and then Partial_Parametrization
then
1304 Process_Default
(Formal
);
1307 (Instantiate_Object
(Formal
, Match
, Analyzed_Formal
),
1311 when N_Formal_Type_Declaration
=>
1314 Defining_Identifier
(Formal
),
1315 Defining_Identifier
(Analyzed_Formal
));
1318 if Partial_Parametrization
then
1319 Process_Default
(Formal
);
1322 Error_Msg_Sloc
:= Sloc
(Gen_Unit
);
1326 Defining_Identifier
(Formal
));
1327 Error_Msg_NE
("\in instantiation of & declared#",
1328 Instantiation_Node
, Gen_Unit
);
1329 Abandon_Instantiation
(Instantiation_Node
);
1336 (Formal
, Match
, Analyzed_Formal
, Assoc
),
1339 -- An instantiation is a freeze point for the actuals,
1340 -- unless this is a rewritten formal package, or the
1341 -- formal is an Ada 2012 formal incomplete type.
1343 if Nkind
(I_Node
) /= N_Formal_Package_Declaration
1345 Ekind
(Defining_Identifier
(Analyzed_Formal
)) /=
1348 Append_Elmt
(Entity
(Match
), Actual_Types
);
1352 -- A remote access-to-class-wide type is not a legal actual
1353 -- for a generic formal of an access type (E.2.2(17)).
1355 if Nkind
(Analyzed_Formal
) = N_Formal_Type_Declaration
1357 Nkind
(Formal_Type_Definition
(Analyzed_Formal
)) =
1358 N_Access_To_Object_Definition
1360 Validate_Remote_Access_To_Class_Wide_Type
(Match
);
1363 when N_Formal_Subprogram_Declaration
=>
1366 Defining_Unit_Name
(Specification
(Formal
)),
1367 Defining_Unit_Name
(Specification
(Analyzed_Formal
)));
1369 -- If the formal subprogram has the same name as another
1370 -- formal subprogram of the generic, then a named
1371 -- association is illegal (12.3(9)). Exclude named
1372 -- associations that are generated for a nested instance.
1375 and then Is_Named_Assoc
1376 and then Comes_From_Source
(Found_Assoc
)
1378 Check_Overloaded_Formal_Subprogram
(Formal
);
1381 -- If there is no corresponding actual, this may be case of
1382 -- partial parametrization, or else the formal has a default
1386 and then Partial_Parametrization
1388 Process_Default
(Formal
);
1389 if Nkind
(I_Node
) = N_Formal_Package_Declaration
then
1390 Check_Overloaded_Formal_Subprogram
(Formal
);
1395 Instantiate_Formal_Subprogram
1396 (Formal
, Match
, Analyzed_Formal
));
1399 -- If this is a nested generic, preserve default for later
1403 and then Box_Present
(Formal
)
1406 (Defining_Unit_Name
(Specification
(Last
(Assoc
))),
1410 when N_Formal_Package_Declaration
=>
1413 Defining_Identifier
(Formal
),
1414 Defining_Identifier
(Original_Node
(Analyzed_Formal
)));
1417 if Partial_Parametrization
then
1418 Process_Default
(Formal
);
1421 Error_Msg_Sloc
:= Sloc
(Gen_Unit
);
1424 Instantiation_Node
, Defining_Identifier
(Formal
));
1425 Error_Msg_NE
("\in instantiation of & declared#",
1426 Instantiation_Node
, Gen_Unit
);
1428 Abandon_Instantiation
(Instantiation_Node
);
1434 (Instantiate_Formal_Package
1435 (Formal
, Match
, Analyzed_Formal
),
1439 -- For use type and use package appearing in the generic part,
1440 -- we have already copied them, so we can just move them where
1441 -- they belong (we mustn't recopy them since this would mess up
1442 -- the Sloc values).
1444 when N_Use_Package_Clause |
1445 N_Use_Type_Clause
=>
1446 if Nkind
(Original_Node
(I_Node
)) =
1447 N_Formal_Package_Declaration
1449 Append
(New_Copy_Tree
(Formal
), Assoc
);
1452 Append
(Formal
, Assoc
);
1456 raise Program_Error
;
1460 Formal
:= Next_Formal
;
1461 Next_Non_Pragma
(Analyzed_Formal
);
1464 if Num_Actuals
> Num_Matched
then
1465 Error_Msg_Sloc
:= Sloc
(Gen_Unit
);
1467 if Present
(Selector_Name
(Actual
)) then
1469 ("unmatched actual&",
1470 Actual
, Selector_Name
(Actual
));
1471 Error_Msg_NE
("\in instantiation of& declared#",
1475 ("unmatched actual in instantiation of& declared#",
1480 elsif Present
(Actuals
) then
1482 ("too many actuals in generic instantiation", Instantiation_Node
);
1486 Elmt
: Elmt_Id
:= First_Elmt
(Actual_Types
);
1488 while Present
(Elmt
) loop
1489 Freeze_Before
(I_Node
, Node
(Elmt
));
1494 -- If there are default subprograms, normalize the tree by adding
1495 -- explicit associations for them. This is required if the instance
1496 -- appears within a generic.
1504 Elmt
:= First_Elmt
(Default_Actuals
);
1505 while Present
(Elmt
) loop
1506 if No
(Actuals
) then
1507 Actuals
:= New_List
;
1508 Set_Generic_Associations
(I_Node
, Actuals
);
1511 Subp
:= Node
(Elmt
);
1513 Make_Generic_Association
(Sloc
(Subp
),
1514 Selector_Name
=> New_Occurrence_Of
(Subp
, Sloc
(Subp
)),
1515 Explicit_Generic_Actual_Parameter
=>
1516 New_Occurrence_Of
(Subp
, Sloc
(Subp
)));
1517 Mark_Rewrite_Insertion
(New_D
);
1518 Append_To
(Actuals
, New_D
);
1523 -- If this is a formal package, normalize the parameter list by adding
1524 -- explicit box associations for the formals that are covered by an
1527 if not Is_Empty_List
(Default_Formals
) then
1528 Append_List
(Default_Formals
, Formals
);
1532 end Analyze_Associations
;
1534 -------------------------------
1535 -- Analyze_Formal_Array_Type --
1536 -------------------------------
1538 procedure Analyze_Formal_Array_Type
1539 (T
: in out Entity_Id
;
1545 -- Treated like a non-generic array declaration, with additional
1550 if Nkind
(Def
) = N_Constrained_Array_Definition
then
1551 DSS
:= First
(Discrete_Subtype_Definitions
(Def
));
1552 while Present
(DSS
) loop
1553 if Nkind_In
(DSS
, N_Subtype_Indication
,
1555 N_Attribute_Reference
)
1557 Error_Msg_N
("only a subtype mark is allowed in a formal", DSS
);
1564 Array_Type_Declaration
(T
, Def
);
1565 Set_Is_Generic_Type
(Base_Type
(T
));
1567 if Ekind
(Component_Type
(T
)) = E_Incomplete_Type
1568 and then No
(Full_View
(Component_Type
(T
)))
1570 Error_Msg_N
("premature usage of incomplete type", Def
);
1572 -- Check that range constraint is not allowed on the component type
1573 -- of a generic formal array type (AARM 12.5.3(3))
1575 elsif Is_Internal
(Component_Type
(T
))
1576 and then Present
(Subtype_Indication
(Component_Definition
(Def
)))
1577 and then Nkind
(Original_Node
1578 (Subtype_Indication
(Component_Definition
(Def
)))) =
1579 N_Subtype_Indication
1582 ("in a formal, a subtype indication can only be "
1583 & "a subtype mark (RM 12.5.3(3))",
1584 Subtype_Indication
(Component_Definition
(Def
)));
1587 end Analyze_Formal_Array_Type
;
1589 ---------------------------------------------
1590 -- Analyze_Formal_Decimal_Fixed_Point_Type --
1591 ---------------------------------------------
1593 -- As for other generic types, we create a valid type representation with
1594 -- legal but arbitrary attributes, whose values are never considered
1595 -- static. For all scalar types we introduce an anonymous base type, with
1596 -- the same attributes. We choose the corresponding integer type to be
1597 -- Standard_Integer.
1598 -- Here and in other similar routines, the Sloc of the generated internal
1599 -- type must be the same as the sloc of the defining identifier of the
1600 -- formal type declaration, to provide proper source navigation.
1602 procedure Analyze_Formal_Decimal_Fixed_Point_Type
1606 Loc
: constant Source_Ptr
:= Sloc
(Def
);
1608 Base
: constant Entity_Id
:=
1610 (E_Decimal_Fixed_Point_Type
,
1612 Sloc
(Defining_Identifier
(Parent
(Def
))), 'G');
1614 Int_Base
: constant Entity_Id
:= Standard_Integer
;
1615 Delta_Val
: constant Ureal
:= Ureal_1
;
1616 Digs_Val
: constant Uint
:= Uint_6
;
1621 Set_Etype
(Base
, Base
);
1622 Set_Size_Info
(Base
, Int_Base
);
1623 Set_RM_Size
(Base
, RM_Size
(Int_Base
));
1624 Set_First_Rep_Item
(Base
, First_Rep_Item
(Int_Base
));
1625 Set_Digits_Value
(Base
, Digs_Val
);
1626 Set_Delta_Value
(Base
, Delta_Val
);
1627 Set_Small_Value
(Base
, Delta_Val
);
1628 Set_Scalar_Range
(Base
,
1630 Low_Bound
=> Make_Real_Literal
(Loc
, Ureal_1
),
1631 High_Bound
=> Make_Real_Literal
(Loc
, Ureal_1
)));
1633 Set_Is_Generic_Type
(Base
);
1634 Set_Parent
(Base
, Parent
(Def
));
1636 Set_Ekind
(T
, E_Decimal_Fixed_Point_Subtype
);
1637 Set_Etype
(T
, Base
);
1638 Set_Size_Info
(T
, Int_Base
);
1639 Set_RM_Size
(T
, RM_Size
(Int_Base
));
1640 Set_First_Rep_Item
(T
, First_Rep_Item
(Int_Base
));
1641 Set_Digits_Value
(T
, Digs_Val
);
1642 Set_Delta_Value
(T
, Delta_Val
);
1643 Set_Small_Value
(T
, Delta_Val
);
1644 Set_Scalar_Range
(T
, Scalar_Range
(Base
));
1645 Set_Is_Constrained
(T
);
1647 Check_Restriction
(No_Fixed_Point
, Def
);
1648 end Analyze_Formal_Decimal_Fixed_Point_Type
;
1650 -------------------------------------------
1651 -- Analyze_Formal_Derived_Interface_Type --
1652 -------------------------------------------
1654 procedure Analyze_Formal_Derived_Interface_Type
1659 Loc
: constant Source_Ptr
:= Sloc
(Def
);
1662 -- Rewrite as a type declaration of a derived type. This ensures that
1663 -- the interface list and primitive operations are properly captured.
1666 Make_Full_Type_Declaration
(Loc
,
1667 Defining_Identifier
=> T
,
1668 Type_Definition
=> Def
));
1670 Set_Is_Generic_Type
(T
);
1671 end Analyze_Formal_Derived_Interface_Type
;
1673 ---------------------------------
1674 -- Analyze_Formal_Derived_Type --
1675 ---------------------------------
1677 procedure Analyze_Formal_Derived_Type
1682 Loc
: constant Source_Ptr
:= Sloc
(Def
);
1683 Unk_Disc
: constant Boolean := Unknown_Discriminants_Present
(N
);
1687 Set_Is_Generic_Type
(T
);
1689 if Private_Present
(Def
) then
1691 Make_Private_Extension_Declaration
(Loc
,
1692 Defining_Identifier
=> T
,
1693 Discriminant_Specifications
=> Discriminant_Specifications
(N
),
1694 Unknown_Discriminants_Present
=> Unk_Disc
,
1695 Subtype_Indication
=> Subtype_Mark
(Def
),
1696 Interface_List
=> Interface_List
(Def
));
1698 Set_Abstract_Present
(New_N
, Abstract_Present
(Def
));
1699 Set_Limited_Present
(New_N
, Limited_Present
(Def
));
1700 Set_Synchronized_Present
(New_N
, Synchronized_Present
(Def
));
1704 Make_Full_Type_Declaration
(Loc
,
1705 Defining_Identifier
=> T
,
1706 Discriminant_Specifications
=>
1707 Discriminant_Specifications
(Parent
(T
)),
1709 Make_Derived_Type_Definition
(Loc
,
1710 Subtype_Indication
=> Subtype_Mark
(Def
)));
1712 Set_Abstract_Present
1713 (Type_Definition
(New_N
), Abstract_Present
(Def
));
1715 (Type_Definition
(New_N
), Limited_Present
(Def
));
1722 if not Is_Composite_Type
(T
) then
1724 ("unknown discriminants not allowed for elementary types", N
);
1726 Set_Has_Unknown_Discriminants
(T
);
1727 Set_Is_Constrained
(T
, False);
1731 -- If the parent type has a known size, so does the formal, which makes
1732 -- legal representation clauses that involve the formal.
1734 Set_Size_Known_At_Compile_Time
1735 (T
, Size_Known_At_Compile_Time
(Entity
(Subtype_Mark
(Def
))));
1736 end Analyze_Formal_Derived_Type
;
1738 ----------------------------------
1739 -- Analyze_Formal_Discrete_Type --
1740 ----------------------------------
1742 -- The operations defined for a discrete types are those of an enumeration
1743 -- type. The size is set to an arbitrary value, for use in analyzing the
1746 procedure Analyze_Formal_Discrete_Type
(T
: Entity_Id
; Def
: Node_Id
) is
1747 Loc
: constant Source_Ptr
:= Sloc
(Def
);
1751 Base
: constant Entity_Id
:=
1753 (E_Floating_Point_Type
, Current_Scope
,
1754 Sloc
(Defining_Identifier
(Parent
(Def
))), 'G');
1758 Set_Ekind
(T
, E_Enumeration_Subtype
);
1759 Set_Etype
(T
, Base
);
1762 Set_Is_Generic_Type
(T
);
1763 Set_Is_Constrained
(T
);
1765 -- For semantic analysis, the bounds of the type must be set to some
1766 -- non-static value. The simplest is to create attribute nodes for those
1767 -- bounds, that refer to the type itself. These bounds are never
1768 -- analyzed but serve as place-holders.
1771 Make_Attribute_Reference
(Loc
,
1772 Attribute_Name
=> Name_First
,
1773 Prefix
=> New_Reference_To
(T
, Loc
));
1777 Make_Attribute_Reference
(Loc
,
1778 Attribute_Name
=> Name_Last
,
1779 Prefix
=> New_Reference_To
(T
, Loc
));
1782 Set_Scalar_Range
(T
,
1787 Set_Ekind
(Base
, E_Enumeration_Type
);
1788 Set_Etype
(Base
, Base
);
1789 Init_Size
(Base
, 8);
1790 Init_Alignment
(Base
);
1791 Set_Is_Generic_Type
(Base
);
1792 Set_Scalar_Range
(Base
, Scalar_Range
(T
));
1793 Set_Parent
(Base
, Parent
(Def
));
1794 end Analyze_Formal_Discrete_Type
;
1796 ----------------------------------
1797 -- Analyze_Formal_Floating_Type --
1798 ---------------------------------
1800 procedure Analyze_Formal_Floating_Type
(T
: Entity_Id
; Def
: Node_Id
) is
1801 Base
: constant Entity_Id
:=
1803 (E_Floating_Point_Type
, Current_Scope
,
1804 Sloc
(Defining_Identifier
(Parent
(Def
))), 'G');
1807 -- The various semantic attributes are taken from the predefined type
1808 -- Float, just so that all of them are initialized. Their values are
1809 -- never used because no constant folding or expansion takes place in
1810 -- the generic itself.
1813 Set_Ekind
(T
, E_Floating_Point_Subtype
);
1814 Set_Etype
(T
, Base
);
1815 Set_Size_Info
(T
, (Standard_Float
));
1816 Set_RM_Size
(T
, RM_Size
(Standard_Float
));
1817 Set_Digits_Value
(T
, Digits_Value
(Standard_Float
));
1818 Set_Scalar_Range
(T
, Scalar_Range
(Standard_Float
));
1819 Set_Is_Constrained
(T
);
1821 Set_Is_Generic_Type
(Base
);
1822 Set_Etype
(Base
, Base
);
1823 Set_Size_Info
(Base
, (Standard_Float
));
1824 Set_RM_Size
(Base
, RM_Size
(Standard_Float
));
1825 Set_Digits_Value
(Base
, Digits_Value
(Standard_Float
));
1826 Set_Scalar_Range
(Base
, Scalar_Range
(Standard_Float
));
1827 Set_Parent
(Base
, Parent
(Def
));
1829 Check_Restriction
(No_Floating_Point
, Def
);
1830 end Analyze_Formal_Floating_Type
;
1832 -----------------------------------
1833 -- Analyze_Formal_Interface_Type;--
1834 -----------------------------------
1836 procedure Analyze_Formal_Interface_Type
1841 Loc
: constant Source_Ptr
:= Sloc
(N
);
1846 Make_Full_Type_Declaration
(Loc
,
1847 Defining_Identifier
=> T
,
1848 Type_Definition
=> Def
);
1852 Set_Is_Generic_Type
(T
);
1853 end Analyze_Formal_Interface_Type
;
1855 ---------------------------------
1856 -- Analyze_Formal_Modular_Type --
1857 ---------------------------------
1859 procedure Analyze_Formal_Modular_Type
(T
: Entity_Id
; Def
: Node_Id
) is
1861 -- Apart from their entity kind, generic modular types are treated like
1862 -- signed integer types, and have the same attributes.
1864 Analyze_Formal_Signed_Integer_Type
(T
, Def
);
1865 Set_Ekind
(T
, E_Modular_Integer_Subtype
);
1866 Set_Ekind
(Etype
(T
), E_Modular_Integer_Type
);
1868 end Analyze_Formal_Modular_Type
;
1870 ---------------------------------------
1871 -- Analyze_Formal_Object_Declaration --
1872 ---------------------------------------
1874 procedure Analyze_Formal_Object_Declaration
(N
: Node_Id
) is
1875 E
: constant Node_Id
:= Default_Expression
(N
);
1876 Id
: constant Node_Id
:= Defining_Identifier
(N
);
1883 -- Determine the mode of the formal object
1885 if Out_Present
(N
) then
1886 K
:= E_Generic_In_Out_Parameter
;
1888 if not In_Present
(N
) then
1889 Error_Msg_N
("formal generic objects cannot have mode OUT", N
);
1893 K
:= E_Generic_In_Parameter
;
1896 if Present
(Subtype_Mark
(N
)) then
1897 Find_Type
(Subtype_Mark
(N
));
1898 T
:= Entity
(Subtype_Mark
(N
));
1900 -- Verify that there is no redundant null exclusion
1902 if Null_Exclusion_Present
(N
) then
1903 if not Is_Access_Type
(T
) then
1905 ("null exclusion can only apply to an access type", N
);
1907 elsif Can_Never_Be_Null
(T
) then
1909 ("`NOT NULL` not allowed (& already excludes null)",
1914 -- Ada 2005 (AI-423): Formal object with an access definition
1917 Check_Access_Definition
(N
);
1918 T
:= Access_Definition
1920 N
=> Access_Definition
(N
));
1923 if Ekind
(T
) = E_Incomplete_Type
then
1925 Error_Node
: Node_Id
;
1928 if Present
(Subtype_Mark
(N
)) then
1929 Error_Node
:= Subtype_Mark
(N
);
1931 Check_Access_Definition
(N
);
1932 Error_Node
:= Access_Definition
(N
);
1935 Error_Msg_N
("premature usage of incomplete type", Error_Node
);
1939 if K
= E_Generic_In_Parameter
then
1941 -- Ada 2005 (AI-287): Limited aggregates allowed in generic formals
1943 if Ada_Version
< Ada_2005
and then Is_Limited_Type
(T
) then
1945 ("generic formal of mode IN must not be of limited type", N
);
1946 Explain_Limited_Type
(T
, N
);
1949 if Is_Abstract_Type
(T
) then
1951 ("generic formal of mode IN must not be of abstract type", N
);
1955 Preanalyze_Spec_Expression
(E
, T
);
1957 if Is_Limited_Type
(T
) and then not OK_For_Limited_Init
(T
, E
) then
1959 ("initialization not allowed for limited types", E
);
1960 Explain_Limited_Type
(T
, E
);
1967 -- Case of generic IN OUT parameter
1970 -- If the formal has an unconstrained type, construct its actual
1971 -- subtype, as is done for subprogram formals. In this fashion, all
1972 -- its uses can refer to specific bounds.
1977 if (Is_Array_Type
(T
)
1978 and then not Is_Constrained
(T
))
1980 (Ekind
(T
) = E_Record_Type
1981 and then Has_Discriminants
(T
))
1984 Non_Freezing_Ref
: constant Node_Id
:=
1985 New_Reference_To
(Id
, Sloc
(Id
));
1989 -- Make sure the actual subtype doesn't generate bogus freezing
1991 Set_Must_Not_Freeze
(Non_Freezing_Ref
);
1992 Decl
:= Build_Actual_Subtype
(T
, Non_Freezing_Ref
);
1993 Insert_Before_And_Analyze
(N
, Decl
);
1994 Set_Actual_Subtype
(Id
, Defining_Identifier
(Decl
));
1997 Set_Actual_Subtype
(Id
, T
);
2002 ("initialization not allowed for `IN OUT` formals", N
);
2006 if Has_Aspects
(N
) then
2007 Analyze_Aspect_Specifications
(N
, Id
);
2009 end Analyze_Formal_Object_Declaration
;
2011 ----------------------------------------------
2012 -- Analyze_Formal_Ordinary_Fixed_Point_Type --
2013 ----------------------------------------------
2015 procedure Analyze_Formal_Ordinary_Fixed_Point_Type
2019 Loc
: constant Source_Ptr
:= Sloc
(Def
);
2020 Base
: constant Entity_Id
:=
2022 (E_Ordinary_Fixed_Point_Type
, Current_Scope
,
2023 Sloc
(Defining_Identifier
(Parent
(Def
))), 'G');
2026 -- The semantic attributes are set for completeness only, their values
2027 -- will never be used, since all properties of the type are non-static.
2030 Set_Ekind
(T
, E_Ordinary_Fixed_Point_Subtype
);
2031 Set_Etype
(T
, Base
);
2032 Set_Size_Info
(T
, Standard_Integer
);
2033 Set_RM_Size
(T
, RM_Size
(Standard_Integer
));
2034 Set_Small_Value
(T
, Ureal_1
);
2035 Set_Delta_Value
(T
, Ureal_1
);
2036 Set_Scalar_Range
(T
,
2038 Low_Bound
=> Make_Real_Literal
(Loc
, Ureal_1
),
2039 High_Bound
=> Make_Real_Literal
(Loc
, Ureal_1
)));
2040 Set_Is_Constrained
(T
);
2042 Set_Is_Generic_Type
(Base
);
2043 Set_Etype
(Base
, Base
);
2044 Set_Size_Info
(Base
, Standard_Integer
);
2045 Set_RM_Size
(Base
, RM_Size
(Standard_Integer
));
2046 Set_Small_Value
(Base
, Ureal_1
);
2047 Set_Delta_Value
(Base
, Ureal_1
);
2048 Set_Scalar_Range
(Base
, Scalar_Range
(T
));
2049 Set_Parent
(Base
, Parent
(Def
));
2051 Check_Restriction
(No_Fixed_Point
, Def
);
2052 end Analyze_Formal_Ordinary_Fixed_Point_Type
;
2054 ----------------------------------------
2055 -- Analyze_Formal_Package_Declaration --
2056 ----------------------------------------
2058 procedure Analyze_Formal_Package_Declaration
(N
: Node_Id
) is
2059 Loc
: constant Source_Ptr
:= Sloc
(N
);
2060 Pack_Id
: constant Entity_Id
:= Defining_Identifier
(N
);
2062 Gen_Id
: constant Node_Id
:= Name
(N
);
2064 Gen_Unit
: Entity_Id
;
2066 Parent_Installed
: Boolean := False;
2068 Parent_Instance
: Entity_Id
;
2069 Renaming_In_Par
: Entity_Id
;
2070 Associations
: Boolean := True;
2072 Vis_Prims_List
: Elist_Id
:= No_Elist
;
2073 -- List of primitives made temporarily visible in the instantiation
2074 -- to match the visibility of the formal type
2076 function Build_Local_Package
return Node_Id
;
2077 -- The formal package is rewritten so that its parameters are replaced
2078 -- with corresponding declarations. For parameters with bona fide
2079 -- associations these declarations are created by Analyze_Associations
2080 -- as for a regular instantiation. For boxed parameters, we preserve
2081 -- the formal declarations and analyze them, in order to introduce
2082 -- entities of the right kind in the environment of the formal.
2084 -------------------------
2085 -- Build_Local_Package --
2086 -------------------------
2088 function Build_Local_Package
return Node_Id
is
2090 Pack_Decl
: Node_Id
;
2093 -- Within the formal, the name of the generic package is a renaming
2094 -- of the formal (as for a regular instantiation).
2097 Make_Package_Declaration
(Loc
,
2100 (Specification
(Original_Node
(Gen_Decl
)),
2101 Empty
, Instantiating
=> True));
2103 Renaming
:= Make_Package_Renaming_Declaration
(Loc
,
2104 Defining_Unit_Name
=>
2105 Make_Defining_Identifier
(Loc
, Chars
(Gen_Unit
)),
2106 Name
=> New_Occurrence_Of
(Formal
, Loc
));
2108 if Nkind
(Gen_Id
) = N_Identifier
2109 and then Chars
(Gen_Id
) = Chars
(Pack_Id
)
2112 ("& is hidden within declaration of instance", Gen_Id
, Gen_Unit
);
2115 -- If the formal is declared with a box, or with an others choice,
2116 -- create corresponding declarations for all entities in the formal
2117 -- part, so that names with the proper types are available in the
2118 -- specification of the formal package.
2120 -- On the other hand, if there are no associations, then all the
2121 -- formals must have defaults, and this will be checked by the
2122 -- call to Analyze_Associations.
2125 or else Nkind
(First
(Generic_Associations
(N
))) = N_Others_Choice
2128 Formal_Decl
: Node_Id
;
2131 -- TBA : for a formal package, need to recurse ???
2136 (Generic_Formal_Declarations
(Original_Node
(Gen_Decl
)));
2137 while Present
(Formal_Decl
) loop
2139 (Decls
, Copy_Generic_Node
(Formal_Decl
, Empty
, True));
2144 -- If generic associations are present, use Analyze_Associations to
2145 -- create the proper renaming declarations.
2149 Act_Tree
: constant Node_Id
:=
2151 (Original_Node
(Gen_Decl
), Empty
,
2152 Instantiating
=> True);
2155 Generic_Renamings
.Set_Last
(0);
2156 Generic_Renamings_HTable
.Reset
;
2157 Instantiation_Node
:= N
;
2160 Analyze_Associations
2161 (I_Node
=> Original_Node
(N
),
2162 Formals
=> Generic_Formal_Declarations
(Act_Tree
),
2163 F_Copy
=> Generic_Formal_Declarations
(Gen_Decl
));
2165 Vis_Prims_List
:= Check_Hidden_Primitives
(Decls
);
2169 Append
(Renaming
, To
=> Decls
);
2171 -- Add generated declarations ahead of local declarations in
2174 if No
(Visible_Declarations
(Specification
(Pack_Decl
))) then
2175 Set_Visible_Declarations
(Specification
(Pack_Decl
), Decls
);
2178 (First
(Visible_Declarations
(Specification
(Pack_Decl
))),
2183 end Build_Local_Package
;
2185 -- Start of processing for Analyze_Formal_Package_Declaration
2188 Text_IO_Kludge
(Gen_Id
);
2191 Check_Generic_Child_Unit
(Gen_Id
, Parent_Installed
);
2192 Gen_Unit
:= Entity
(Gen_Id
);
2194 -- Check for a formal package that is a package renaming
2196 if Present
(Renamed_Object
(Gen_Unit
)) then
2198 -- Indicate that unit is used, before replacing it with renamed
2199 -- entity for use below.
2201 if In_Extended_Main_Source_Unit
(N
) then
2202 Set_Is_Instantiated
(Gen_Unit
);
2203 Generate_Reference
(Gen_Unit
, N
);
2206 Gen_Unit
:= Renamed_Object
(Gen_Unit
);
2209 if Ekind
(Gen_Unit
) /= E_Generic_Package
then
2210 Error_Msg_N
("expect generic package name", Gen_Id
);
2214 elsif Gen_Unit
= Current_Scope
then
2216 ("generic package cannot be used as a formal package of itself",
2221 elsif In_Open_Scopes
(Gen_Unit
) then
2222 if Is_Compilation_Unit
(Gen_Unit
)
2223 and then Is_Child_Unit
(Current_Scope
)
2225 -- Special-case the error when the formal is a parent, and
2226 -- continue analysis to minimize cascaded errors.
2229 ("generic parent cannot be used as formal package "
2230 & "of a child unit",
2235 ("generic package cannot be used as a formal package "
2243 -- Check that name of formal package does not hide name of generic,
2244 -- or its leading prefix. This check must be done separately because
2245 -- the name of the generic has already been analyzed.
2248 Gen_Name
: Entity_Id
;
2252 while Nkind
(Gen_Name
) = N_Expanded_Name
loop
2253 Gen_Name
:= Prefix
(Gen_Name
);
2256 if Chars
(Gen_Name
) = Chars
(Pack_Id
) then
2258 ("& is hidden within declaration of formal package",
2264 or else No
(Generic_Associations
(N
))
2265 or else Nkind
(First
(Generic_Associations
(N
))) = N_Others_Choice
2267 Associations
:= False;
2270 -- If there are no generic associations, the generic parameters appear
2271 -- as local entities and are instantiated like them. We copy the generic
2272 -- package declaration as if it were an instantiation, and analyze it
2273 -- like a regular package, except that we treat the formals as
2274 -- additional visible components.
2276 Gen_Decl
:= Unit_Declaration_Node
(Gen_Unit
);
2278 if In_Extended_Main_Source_Unit
(N
) then
2279 Set_Is_Instantiated
(Gen_Unit
);
2280 Generate_Reference
(Gen_Unit
, N
);
2283 Formal
:= New_Copy
(Pack_Id
);
2284 Create_Instantiation_Source
(N
, Gen_Unit
, False, S_Adjustment
);
2287 -- Make local generic without formals. The formals will be replaced
2288 -- with internal declarations.
2290 New_N
:= Build_Local_Package
;
2292 -- If there are errors in the parameter list, Analyze_Associations
2293 -- raises Instantiation_Error. Patch the declaration to prevent
2294 -- further exception propagation.
2297 when Instantiation_Error
=>
2299 Enter_Name
(Formal
);
2300 Set_Ekind
(Formal
, E_Variable
);
2301 Set_Etype
(Formal
, Any_Type
);
2302 Restore_Hidden_Primitives
(Vis_Prims_List
);
2304 if Parent_Installed
then
2312 Set_Defining_Unit_Name
(Specification
(New_N
), Formal
);
2313 Set_Generic_Parent
(Specification
(N
), Gen_Unit
);
2314 Set_Instance_Env
(Gen_Unit
, Formal
);
2315 Set_Is_Generic_Instance
(Formal
);
2317 Enter_Name
(Formal
);
2318 Set_Ekind
(Formal
, E_Package
);
2319 Set_Etype
(Formal
, Standard_Void_Type
);
2320 Set_Inner_Instances
(Formal
, New_Elmt_List
);
2321 Push_Scope
(Formal
);
2323 if Is_Child_Unit
(Gen_Unit
)
2324 and then Parent_Installed
2326 -- Similarly, we have to make the name of the formal visible in the
2327 -- parent instance, to resolve properly fully qualified names that
2328 -- may appear in the generic unit. The parent instance has been
2329 -- placed on the scope stack ahead of the current scope.
2331 Parent_Instance
:= Scope_Stack
.Table
(Scope_Stack
.Last
- 1).Entity
;
2334 Make_Defining_Identifier
(Loc
, Chars
(Gen_Unit
));
2335 Set_Ekind
(Renaming_In_Par
, E_Package
);
2336 Set_Etype
(Renaming_In_Par
, Standard_Void_Type
);
2337 Set_Scope
(Renaming_In_Par
, Parent_Instance
);
2338 Set_Parent
(Renaming_In_Par
, Parent
(Formal
));
2339 Set_Renamed_Object
(Renaming_In_Par
, Formal
);
2340 Append_Entity
(Renaming_In_Par
, Parent_Instance
);
2343 Analyze
(Specification
(N
));
2345 -- The formals for which associations are provided are not visible
2346 -- outside of the formal package. The others are still declared by a
2347 -- formal parameter declaration.
2349 -- If there are no associations, the only local entity to hide is the
2350 -- generated package renaming itself.
2356 E
:= First_Entity
(Formal
);
2357 while Present
(E
) loop
2359 and then not Is_Generic_Formal
(E
)
2364 if Ekind
(E
) = E_Package
2365 and then Renamed_Entity
(E
) = Formal
2375 End_Package_Scope
(Formal
);
2376 Restore_Hidden_Primitives
(Vis_Prims_List
);
2378 if Parent_Installed
then
2384 -- Inside the generic unit, the formal package is a regular package, but
2385 -- no body is needed for it. Note that after instantiation, the defining
2386 -- unit name we need is in the new tree and not in the original (see
2387 -- Package_Instantiation). A generic formal package is an instance, and
2388 -- can be used as an actual for an inner instance.
2390 Set_Has_Completion
(Formal
, True);
2392 -- Add semantic information to the original defining identifier.
2395 Set_Ekind
(Pack_Id
, E_Package
);
2396 Set_Etype
(Pack_Id
, Standard_Void_Type
);
2397 Set_Scope
(Pack_Id
, Scope
(Formal
));
2398 Set_Has_Completion
(Pack_Id
, True);
2401 if Has_Aspects
(N
) then
2402 Analyze_Aspect_Specifications
(N
, Pack_Id
);
2404 end Analyze_Formal_Package_Declaration
;
2406 ---------------------------------
2407 -- Analyze_Formal_Private_Type --
2408 ---------------------------------
2410 procedure Analyze_Formal_Private_Type
2416 New_Private_Type
(N
, T
, Def
);
2418 -- Set the size to an arbitrary but legal value
2420 Set_Size_Info
(T
, Standard_Integer
);
2421 Set_RM_Size
(T
, RM_Size
(Standard_Integer
));
2422 end Analyze_Formal_Private_Type
;
2424 ------------------------------------
2425 -- Analyze_Formal_Incomplete_Type --
2426 ------------------------------------
2428 procedure Analyze_Formal_Incomplete_Type
2434 Set_Ekind
(T
, E_Incomplete_Type
);
2436 Set_Private_Dependents
(T
, New_Elmt_List
);
2438 if Tagged_Present
(Def
) then
2439 Set_Is_Tagged_Type
(T
);
2440 Make_Class_Wide_Type
(T
);
2441 Set_Direct_Primitive_Operations
(T
, New_Elmt_List
);
2443 end Analyze_Formal_Incomplete_Type
;
2445 ----------------------------------------
2446 -- Analyze_Formal_Signed_Integer_Type --
2447 ----------------------------------------
2449 procedure Analyze_Formal_Signed_Integer_Type
2453 Base
: constant Entity_Id
:=
2455 (E_Signed_Integer_Type
,
2457 Sloc
(Defining_Identifier
(Parent
(Def
))), 'G');
2462 Set_Ekind
(T
, E_Signed_Integer_Subtype
);
2463 Set_Etype
(T
, Base
);
2464 Set_Size_Info
(T
, Standard_Integer
);
2465 Set_RM_Size
(T
, RM_Size
(Standard_Integer
));
2466 Set_Scalar_Range
(T
, Scalar_Range
(Standard_Integer
));
2467 Set_Is_Constrained
(T
);
2469 Set_Is_Generic_Type
(Base
);
2470 Set_Size_Info
(Base
, Standard_Integer
);
2471 Set_RM_Size
(Base
, RM_Size
(Standard_Integer
));
2472 Set_Etype
(Base
, Base
);
2473 Set_Scalar_Range
(Base
, Scalar_Range
(Standard_Integer
));
2474 Set_Parent
(Base
, Parent
(Def
));
2475 end Analyze_Formal_Signed_Integer_Type
;
2477 -------------------------------------------
2478 -- Analyze_Formal_Subprogram_Declaration --
2479 -------------------------------------------
2481 procedure Analyze_Formal_Subprogram_Declaration
(N
: Node_Id
) is
2482 Spec
: constant Node_Id
:= Specification
(N
);
2483 Def
: constant Node_Id
:= Default_Name
(N
);
2484 Nam
: constant Entity_Id
:= Defining_Unit_Name
(Spec
);
2492 if Nkind
(Nam
) = N_Defining_Program_Unit_Name
then
2493 Error_Msg_N
("name of formal subprogram must be a direct name", Nam
);
2497 Analyze_Subprogram_Declaration
(N
);
2498 Set_Is_Formal_Subprogram
(Nam
);
2499 Set_Has_Completion
(Nam
);
2501 if Nkind
(N
) = N_Formal_Abstract_Subprogram_Declaration
then
2502 Set_Is_Abstract_Subprogram
(Nam
);
2503 Set_Is_Dispatching_Operation
(Nam
);
2506 Ctrl_Type
: constant Entity_Id
:= Find_Dispatching_Type
(Nam
);
2508 if No
(Ctrl_Type
) then
2510 ("abstract formal subprogram must have a controlling type",
2513 Check_Controlling_Formals
(Ctrl_Type
, Nam
);
2518 -- Default name is resolved at the point of instantiation
2520 if Box_Present
(N
) then
2523 -- Else default is bound at the point of generic declaration
2525 elsif Present
(Def
) then
2526 if Nkind
(Def
) = N_Operator_Symbol
then
2527 Find_Direct_Name
(Def
);
2529 elsif Nkind
(Def
) /= N_Attribute_Reference
then
2533 -- For an attribute reference, analyze the prefix and verify
2534 -- that it has the proper profile for the subprogram.
2536 Analyze
(Prefix
(Def
));
2537 Valid_Default_Attribute
(Nam
, Def
);
2541 -- Default name may be overloaded, in which case the interpretation
2542 -- with the correct profile must be selected, as for a renaming.
2543 -- If the definition is an indexed component, it must denote a
2544 -- member of an entry family. If it is a selected component, it
2545 -- can be a protected operation.
2547 if Etype
(Def
) = Any_Type
then
2550 elsif Nkind
(Def
) = N_Selected_Component
then
2551 if not Is_Overloadable
(Entity
(Selector_Name
(Def
))) then
2552 Error_Msg_N
("expect valid subprogram name as default", Def
);
2555 elsif Nkind
(Def
) = N_Indexed_Component
then
2556 if Is_Entity_Name
(Prefix
(Def
)) then
2557 if Ekind
(Entity
(Prefix
(Def
))) /= E_Entry_Family
then
2558 Error_Msg_N
("expect valid subprogram name as default", Def
);
2561 elsif Nkind
(Prefix
(Def
)) = N_Selected_Component
then
2562 if Ekind
(Entity
(Selector_Name
(Prefix
(Def
)))) /=
2565 Error_Msg_N
("expect valid subprogram name as default", Def
);
2569 Error_Msg_N
("expect valid subprogram name as default", Def
);
2573 elsif Nkind
(Def
) = N_Character_Literal
then
2575 -- Needs some type checks: subprogram should be parameterless???
2577 Resolve
(Def
, (Etype
(Nam
)));
2579 elsif not Is_Entity_Name
(Def
)
2580 or else not Is_Overloadable
(Entity
(Def
))
2582 Error_Msg_N
("expect valid subprogram name as default", Def
);
2585 elsif not Is_Overloaded
(Def
) then
2586 Subp
:= Entity
(Def
);
2589 Error_Msg_N
("premature usage of formal subprogram", Def
);
2591 elsif not Entity_Matches_Spec
(Subp
, Nam
) then
2592 Error_Msg_N
("no visible entity matches specification", Def
);
2595 -- More than one interpretation, so disambiguate as for a renaming
2600 I1
: Interp_Index
:= 0;
2606 Get_First_Interp
(Def
, I
, It
);
2607 while Present
(It
.Nam
) loop
2608 if Entity_Matches_Spec
(It
.Nam
, Nam
) then
2609 if Subp
/= Any_Id
then
2610 It1
:= Disambiguate
(Def
, I1
, I
, Etype
(Subp
));
2612 if It1
= No_Interp
then
2613 Error_Msg_N
("ambiguous default subprogram", Def
);
2626 Get_Next_Interp
(I
, It
);
2630 if Subp
/= Any_Id
then
2632 -- Subprogram found, generate reference to it
2634 Set_Entity
(Def
, Subp
);
2635 Generate_Reference
(Subp
, Def
);
2638 Error_Msg_N
("premature usage of formal subprogram", Def
);
2640 elsif Ekind
(Subp
) /= E_Operator
then
2641 Check_Mode_Conformant
(Subp
, Nam
);
2645 Error_Msg_N
("no visible subprogram matches specification", N
);
2651 if Has_Aspects
(N
) then
2652 Analyze_Aspect_Specifications
(N
, Nam
);
2655 end Analyze_Formal_Subprogram_Declaration
;
2657 -------------------------------------
2658 -- Analyze_Formal_Type_Declaration --
2659 -------------------------------------
2661 procedure Analyze_Formal_Type_Declaration
(N
: Node_Id
) is
2662 Def
: constant Node_Id
:= Formal_Type_Definition
(N
);
2666 T
:= Defining_Identifier
(N
);
2668 if Present
(Discriminant_Specifications
(N
))
2669 and then Nkind
(Def
) /= N_Formal_Private_Type_Definition
2672 ("discriminants not allowed for this formal type", T
);
2675 -- Enter the new name, and branch to specific routine
2678 when N_Formal_Private_Type_Definition
=>
2679 Analyze_Formal_Private_Type
(N
, T
, Def
);
2681 when N_Formal_Derived_Type_Definition
=>
2682 Analyze_Formal_Derived_Type
(N
, T
, Def
);
2684 when N_Formal_Incomplete_Type_Definition
=>
2685 Analyze_Formal_Incomplete_Type
(T
, Def
);
2687 when N_Formal_Discrete_Type_Definition
=>
2688 Analyze_Formal_Discrete_Type
(T
, Def
);
2690 when N_Formal_Signed_Integer_Type_Definition
=>
2691 Analyze_Formal_Signed_Integer_Type
(T
, Def
);
2693 when N_Formal_Modular_Type_Definition
=>
2694 Analyze_Formal_Modular_Type
(T
, Def
);
2696 when N_Formal_Floating_Point_Definition
=>
2697 Analyze_Formal_Floating_Type
(T
, Def
);
2699 when N_Formal_Ordinary_Fixed_Point_Definition
=>
2700 Analyze_Formal_Ordinary_Fixed_Point_Type
(T
, Def
);
2702 when N_Formal_Decimal_Fixed_Point_Definition
=>
2703 Analyze_Formal_Decimal_Fixed_Point_Type
(T
, Def
);
2705 when N_Array_Type_Definition
=>
2706 Analyze_Formal_Array_Type
(T
, Def
);
2708 when N_Access_To_Object_Definition |
2709 N_Access_Function_Definition |
2710 N_Access_Procedure_Definition
=>
2711 Analyze_Generic_Access_Type
(T
, Def
);
2713 -- Ada 2005: a interface declaration is encoded as an abstract
2714 -- record declaration or a abstract type derivation.
2716 when N_Record_Definition
=>
2717 Analyze_Formal_Interface_Type
(N
, T
, Def
);
2719 when N_Derived_Type_Definition
=>
2720 Analyze_Formal_Derived_Interface_Type
(N
, T
, Def
);
2726 raise Program_Error
;
2730 Set_Is_Generic_Type
(T
);
2732 if Has_Aspects
(N
) then
2733 Analyze_Aspect_Specifications
(N
, T
);
2735 end Analyze_Formal_Type_Declaration
;
2737 ------------------------------------
2738 -- Analyze_Function_Instantiation --
2739 ------------------------------------
2741 procedure Analyze_Function_Instantiation
(N
: Node_Id
) is
2743 Analyze_Subprogram_Instantiation
(N
, E_Function
);
2744 end Analyze_Function_Instantiation
;
2746 ---------------------------------
2747 -- Analyze_Generic_Access_Type --
2748 ---------------------------------
2750 procedure Analyze_Generic_Access_Type
(T
: Entity_Id
; Def
: Node_Id
) is
2754 if Nkind
(Def
) = N_Access_To_Object_Definition
then
2755 Access_Type_Declaration
(T
, Def
);
2757 if Is_Incomplete_Or_Private_Type
(Designated_Type
(T
))
2758 and then No
(Full_View
(Designated_Type
(T
)))
2759 and then not Is_Generic_Type
(Designated_Type
(T
))
2761 Error_Msg_N
("premature usage of incomplete type", Def
);
2763 elsif not Is_Entity_Name
(Subtype_Indication
(Def
)) then
2765 ("only a subtype mark is allowed in a formal", Def
);
2769 Access_Subprogram_Declaration
(T
, Def
);
2771 end Analyze_Generic_Access_Type
;
2773 ---------------------------------
2774 -- Analyze_Generic_Formal_Part --
2775 ---------------------------------
2777 procedure Analyze_Generic_Formal_Part
(N
: Node_Id
) is
2778 Gen_Parm_Decl
: Node_Id
;
2781 -- The generic formals are processed in the scope of the generic unit,
2782 -- where they are immediately visible. The scope is installed by the
2785 Gen_Parm_Decl
:= First
(Generic_Formal_Declarations
(N
));
2787 while Present
(Gen_Parm_Decl
) loop
2788 Analyze
(Gen_Parm_Decl
);
2789 Next
(Gen_Parm_Decl
);
2792 Generate_Reference_To_Generic_Formals
(Current_Scope
);
2793 end Analyze_Generic_Formal_Part
;
2795 ------------------------------------------
2796 -- Analyze_Generic_Package_Declaration --
2797 ------------------------------------------
2799 procedure Analyze_Generic_Package_Declaration
(N
: Node_Id
) is
2800 Loc
: constant Source_Ptr
:= Sloc
(N
);
2803 Save_Parent
: Node_Id
;
2805 Decls
: constant List_Id
:=
2806 Visible_Declarations
(Specification
(N
));
2810 Check_SPARK_Restriction
("generic is not allowed", N
);
2812 -- We introduce a renaming of the enclosing package, to have a usable
2813 -- entity as the prefix of an expanded name for a local entity of the
2814 -- form Par.P.Q, where P is the generic package. This is because a local
2815 -- entity named P may hide it, so that the usual visibility rules in
2816 -- the instance will not resolve properly.
2819 Make_Package_Renaming_Declaration
(Loc
,
2820 Defining_Unit_Name
=>
2821 Make_Defining_Identifier
(Loc
,
2822 Chars
=> New_External_Name
(Chars
(Defining_Entity
(N
)), "GH")),
2823 Name
=> Make_Identifier
(Loc
, Chars
(Defining_Entity
(N
))));
2825 if Present
(Decls
) then
2826 Decl
:= First
(Decls
);
2827 while Present
(Decl
)
2828 and then Nkind
(Decl
) = N_Pragma
2833 if Present
(Decl
) then
2834 Insert_Before
(Decl
, Renaming
);
2836 Append
(Renaming
, Visible_Declarations
(Specification
(N
)));
2840 Set_Visible_Declarations
(Specification
(N
), New_List
(Renaming
));
2843 -- Create copy of generic unit, and save for instantiation. If the unit
2844 -- is a child unit, do not copy the specifications for the parent, which
2845 -- are not part of the generic tree.
2847 Save_Parent
:= Parent_Spec
(N
);
2848 Set_Parent_Spec
(N
, Empty
);
2850 New_N
:= Copy_Generic_Node
(N
, Empty
, Instantiating
=> False);
2851 Set_Parent_Spec
(New_N
, Save_Parent
);
2853 Id
:= Defining_Entity
(N
);
2854 Generate_Definition
(Id
);
2856 -- Expansion is not applied to generic units
2861 Set_Ekind
(Id
, E_Generic_Package
);
2862 Set_Etype
(Id
, Standard_Void_Type
);
2864 Enter_Generic_Scope
(Id
);
2865 Set_Inner_Instances
(Id
, New_Elmt_List
);
2867 Set_Categorization_From_Pragmas
(N
);
2868 Set_Is_Pure
(Id
, Is_Pure
(Current_Scope
));
2870 -- Link the declaration of the generic homonym in the generic copy to
2871 -- the package it renames, so that it is always resolved properly.
2873 Set_Generic_Homonym
(Id
, Defining_Unit_Name
(Renaming
));
2874 Set_Entity
(Associated_Node
(Name
(Renaming
)), Id
);
2876 -- For a library unit, we have reconstructed the entity for the unit,
2877 -- and must reset it in the library tables.
2879 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
2880 Set_Cunit_Entity
(Current_Sem_Unit
, Id
);
2883 Analyze_Generic_Formal_Part
(N
);
2885 -- After processing the generic formals, analysis proceeds as for a
2886 -- non-generic package.
2888 Analyze
(Specification
(N
));
2890 Validate_Categorization_Dependency
(N
, Id
);
2894 End_Package_Scope
(Id
);
2895 Exit_Generic_Scope
(Id
);
2897 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
2898 Move_Freeze_Nodes
(Id
, N
, Visible_Declarations
(Specification
(N
)));
2899 Move_Freeze_Nodes
(Id
, N
, Private_Declarations
(Specification
(N
)));
2900 Move_Freeze_Nodes
(Id
, N
, Generic_Formal_Declarations
(N
));
2903 Set_Body_Required
(Parent
(N
), Unit_Requires_Body
(Id
));
2904 Validate_RT_RAT_Component
(N
);
2906 -- If this is a spec without a body, check that generic parameters
2909 if not Body_Required
(Parent
(N
)) then
2910 Check_References
(Id
);
2914 if Has_Aspects
(N
) then
2915 Analyze_Aspect_Specifications
(N
, Id
);
2917 end Analyze_Generic_Package_Declaration
;
2919 --------------------------------------------
2920 -- Analyze_Generic_Subprogram_Declaration --
2921 --------------------------------------------
2923 procedure Analyze_Generic_Subprogram_Declaration
(N
: Node_Id
) is
2928 Result_Type
: Entity_Id
;
2929 Save_Parent
: Node_Id
;
2933 Check_SPARK_Restriction
("generic is not allowed", N
);
2935 -- Create copy of generic unit, and save for instantiation. If the unit
2936 -- is a child unit, do not copy the specifications for the parent, which
2937 -- are not part of the generic tree.
2939 Save_Parent
:= Parent_Spec
(N
);
2940 Set_Parent_Spec
(N
, Empty
);
2942 New_N
:= Copy_Generic_Node
(N
, Empty
, Instantiating
=> False);
2943 Set_Parent_Spec
(New_N
, Save_Parent
);
2946 -- The aspect specifications are not attached to the tree, and must
2947 -- be copied and attached to the generic copy explicitly.
2949 if Present
(Aspect_Specifications
(New_N
)) then
2951 Aspects
: constant List_Id
:= Aspect_Specifications
(N
);
2953 Set_Has_Aspects
(N
, False);
2954 Move_Aspects
(New_N
, N
);
2955 Set_Has_Aspects
(Original_Node
(N
), False);
2956 Set_Aspect_Specifications
(Original_Node
(N
), Aspects
);
2960 Spec
:= Specification
(N
);
2961 Id
:= Defining_Entity
(Spec
);
2962 Generate_Definition
(Id
);
2963 Set_Contract
(Id
, Make_Contract
(Sloc
(Id
)));
2965 if Nkind
(Id
) = N_Defining_Operator_Symbol
then
2967 ("operator symbol not allowed for generic subprogram", Id
);
2974 Set_Scope_Depth_Value
(Id
, Scope_Depth
(Current_Scope
) + 1);
2976 Enter_Generic_Scope
(Id
);
2977 Set_Inner_Instances
(Id
, New_Elmt_List
);
2978 Set_Is_Pure
(Id
, Is_Pure
(Current_Scope
));
2980 Analyze_Generic_Formal_Part
(N
);
2982 Formals
:= Parameter_Specifications
(Spec
);
2984 if Present
(Formals
) then
2985 Process_Formals
(Formals
, Spec
);
2988 if Nkind
(Spec
) = N_Function_Specification
then
2989 Set_Ekind
(Id
, E_Generic_Function
);
2991 if Nkind
(Result_Definition
(Spec
)) = N_Access_Definition
then
2992 Result_Type
:= Access_Definition
(Spec
, Result_Definition
(Spec
));
2993 Set_Etype
(Id
, Result_Type
);
2995 -- Check restriction imposed by AI05-073: a generic function
2996 -- cannot return an abstract type or an access to such.
2998 -- This is a binding interpretation should it apply to earlier
2999 -- versions of Ada as well as Ada 2012???
3001 if Is_Abstract_Type
(Designated_Type
(Result_Type
))
3002 and then Ada_Version
>= Ada_2012
3004 Error_Msg_N
("generic function cannot have an access result"
3005 & " that designates an abstract type", Spec
);
3009 Find_Type
(Result_Definition
(Spec
));
3010 Typ
:= Entity
(Result_Definition
(Spec
));
3012 if Is_Abstract_Type
(Typ
)
3013 and then Ada_Version
>= Ada_2012
3016 ("generic function cannot have abstract result type", Spec
);
3019 -- If a null exclusion is imposed on the result type, then create
3020 -- a null-excluding itype (an access subtype) and use it as the
3021 -- function's Etype.
3023 if Is_Access_Type
(Typ
)
3024 and then Null_Exclusion_Present
(Spec
)
3027 Create_Null_Excluding_Itype
3029 Related_Nod
=> Spec
,
3030 Scope_Id
=> Defining_Unit_Name
(Spec
)));
3032 Set_Etype
(Id
, Typ
);
3037 Set_Ekind
(Id
, E_Generic_Procedure
);
3038 Set_Etype
(Id
, Standard_Void_Type
);
3041 -- For a library unit, we have reconstructed the entity for the unit,
3042 -- and must reset it in the library tables. We also make sure that
3043 -- Body_Required is set properly in the original compilation unit node.
3045 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
3046 Set_Cunit_Entity
(Current_Sem_Unit
, Id
);
3047 Set_Body_Required
(Parent
(N
), Unit_Requires_Body
(Id
));
3050 Set_Categorization_From_Pragmas
(N
);
3051 Validate_Categorization_Dependency
(N
, Id
);
3053 Save_Global_References
(Original_Node
(N
));
3055 -- To capture global references, analyze the expressions of aspects,
3056 -- and propagate information to original tree. Note that in this case
3057 -- analysis of attributes is not delayed until the freeze point.
3059 -- It seems very hard to recreate the proper visibility of the generic
3060 -- subprogram at a later point because the analysis of an aspect may
3061 -- create pragmas after the generic copies have been made ???
3063 if Has_Aspects
(N
) then
3068 Aspect
:= First
(Aspect_Specifications
(N
));
3069 while Present
(Aspect
) loop
3070 if Get_Aspect_Id
(Chars
(Identifier
(Aspect
)))
3073 Analyze
(Expression
(Aspect
));
3078 Aspect
:= First
(Aspect_Specifications
(Original_Node
(N
)));
3079 while Present
(Aspect
) loop
3080 Save_Global_References
(Expression
(Aspect
));
3088 Exit_Generic_Scope
(Id
);
3089 Generate_Reference_To_Formals
(Id
);
3091 List_Inherited_Pre_Post_Aspects
(Id
);
3092 end Analyze_Generic_Subprogram_Declaration
;
3094 -----------------------------------
3095 -- Analyze_Package_Instantiation --
3096 -----------------------------------
3098 procedure Analyze_Package_Instantiation
(N
: Node_Id
) is
3099 Loc
: constant Source_Ptr
:= Sloc
(N
);
3100 Gen_Id
: constant Node_Id
:= Name
(N
);
3103 Act_Decl_Name
: Node_Id
;
3104 Act_Decl_Id
: Entity_Id
;
3109 Gen_Unit
: Entity_Id
;
3111 Is_Actual_Pack
: constant Boolean :=
3112 Is_Internal
(Defining_Entity
(N
));
3114 Env_Installed
: Boolean := False;
3115 Parent_Installed
: Boolean := False;
3116 Renaming_List
: List_Id
;
3117 Unit_Renaming
: Node_Id
;
3118 Needs_Body
: Boolean;
3119 Inline_Now
: Boolean := False;
3121 Save_Style_Check
: constant Boolean := Style_Check
;
3122 -- Save style check mode for restore on exit
3124 procedure Delay_Descriptors
(E
: Entity_Id
);
3125 -- Delay generation of subprogram descriptors for given entity
3127 function Might_Inline_Subp
return Boolean;
3128 -- If inlining is active and the generic contains inlined subprograms,
3129 -- we instantiate the body. This may cause superfluous instantiations,
3130 -- but it is simpler than detecting the need for the body at the point
3131 -- of inlining, when the context of the instance is not available.
3133 -----------------------
3134 -- Delay_Descriptors --
3135 -----------------------
3137 procedure Delay_Descriptors
(E
: Entity_Id
) is
3139 if not Delay_Subprogram_Descriptors
(E
) then
3140 Set_Delay_Subprogram_Descriptors
(E
);
3141 Pending_Descriptor
.Append
(E
);
3143 end Delay_Descriptors
;
3145 -----------------------
3146 -- Might_Inline_Subp --
3147 -----------------------
3149 function Might_Inline_Subp
return Boolean is
3153 if not Inline_Processing_Required
then
3157 E
:= First_Entity
(Gen_Unit
);
3158 while Present
(E
) loop
3159 if Is_Subprogram
(E
)
3160 and then Is_Inlined
(E
)
3170 end Might_Inline_Subp
;
3172 -- Local declarations
3174 Vis_Prims_List
: Elist_Id
:= No_Elist
;
3175 -- List of primitives made temporarily visible in the instantiation
3176 -- to match the visibility of the formal type
3178 -- Start of processing for Analyze_Package_Instantiation
3181 Check_SPARK_Restriction
("generic is not allowed", N
);
3183 -- Very first thing: apply the special kludge for Text_IO processing
3184 -- in case we are instantiating one of the children of [Wide_]Text_IO.
3186 Text_IO_Kludge
(Name
(N
));
3188 -- Make node global for error reporting
3190 Instantiation_Node
:= N
;
3192 -- Turn off style checking in instances. If the check is enabled on the
3193 -- generic unit, a warning in an instance would just be noise. If not
3194 -- enabled on the generic, then a warning in an instance is just wrong.
3196 Style_Check
:= False;
3198 -- Case of instantiation of a generic package
3200 if Nkind
(N
) = N_Package_Instantiation
then
3201 Act_Decl_Id
:= New_Copy
(Defining_Entity
(N
));
3202 Set_Comes_From_Source
(Act_Decl_Id
, True);
3204 if Nkind
(Defining_Unit_Name
(N
)) = N_Defining_Program_Unit_Name
then
3206 Make_Defining_Program_Unit_Name
(Loc
,
3207 Name
=> New_Copy_Tree
(Name
(Defining_Unit_Name
(N
))),
3208 Defining_Identifier
=> Act_Decl_Id
);
3210 Act_Decl_Name
:= Act_Decl_Id
;
3213 -- Case of instantiation of a formal package
3216 Act_Decl_Id
:= Defining_Identifier
(N
);
3217 Act_Decl_Name
:= Act_Decl_Id
;
3220 Generate_Definition
(Act_Decl_Id
);
3221 Preanalyze_Actuals
(N
);
3224 Env_Installed
:= True;
3226 -- Reset renaming map for formal types. The mapping is established
3227 -- when analyzing the generic associations, but some mappings are
3228 -- inherited from formal packages of parent units, and these are
3229 -- constructed when the parents are installed.
3231 Generic_Renamings
.Set_Last
(0);
3232 Generic_Renamings_HTable
.Reset
;
3234 Check_Generic_Child_Unit
(Gen_Id
, Parent_Installed
);
3235 Gen_Unit
:= Entity
(Gen_Id
);
3237 -- Verify that it is the name of a generic package
3239 -- A visibility glitch: if the instance is a child unit and the generic
3240 -- is the generic unit of a parent instance (i.e. both the parent and
3241 -- the child units are instances of the same package) the name now
3242 -- denotes the renaming within the parent, not the intended generic
3243 -- unit. See if there is a homonym that is the desired generic. The
3244 -- renaming declaration must be visible inside the instance of the
3245 -- child, but not when analyzing the name in the instantiation itself.
3247 if Ekind
(Gen_Unit
) = E_Package
3248 and then Present
(Renamed_Entity
(Gen_Unit
))
3249 and then In_Open_Scopes
(Renamed_Entity
(Gen_Unit
))
3250 and then Is_Generic_Instance
(Renamed_Entity
(Gen_Unit
))
3251 and then Present
(Homonym
(Gen_Unit
))
3253 Gen_Unit
:= Homonym
(Gen_Unit
);
3256 if Etype
(Gen_Unit
) = Any_Type
then
3260 elsif Ekind
(Gen_Unit
) /= E_Generic_Package
then
3262 -- Ada 2005 (AI-50217): Cannot use instance in limited with_clause
3264 if From_With_Type
(Gen_Unit
) then
3266 ("cannot instantiate a limited withed package", Gen_Id
);
3269 ("expect name of generic package in instantiation", Gen_Id
);
3276 if In_Extended_Main_Source_Unit
(N
) then
3277 Set_Is_Instantiated
(Gen_Unit
);
3278 Generate_Reference
(Gen_Unit
, N
);
3280 if Present
(Renamed_Object
(Gen_Unit
)) then
3281 Set_Is_Instantiated
(Renamed_Object
(Gen_Unit
));
3282 Generate_Reference
(Renamed_Object
(Gen_Unit
), N
);
3286 if Nkind
(Gen_Id
) = N_Identifier
3287 and then Chars
(Gen_Unit
) = Chars
(Defining_Entity
(N
))
3290 ("& is hidden within declaration of instance", Gen_Id
, Gen_Unit
);
3292 elsif Nkind
(Gen_Id
) = N_Expanded_Name
3293 and then Is_Child_Unit
(Gen_Unit
)
3294 and then Nkind
(Prefix
(Gen_Id
)) = N_Identifier
3295 and then Chars
(Act_Decl_Id
) = Chars
(Prefix
(Gen_Id
))
3298 ("& is hidden within declaration of instance ", Prefix
(Gen_Id
));
3301 Set_Entity
(Gen_Id
, Gen_Unit
);
3303 -- If generic is a renaming, get original generic unit
3305 if Present
(Renamed_Object
(Gen_Unit
))
3306 and then Ekind
(Renamed_Object
(Gen_Unit
)) = E_Generic_Package
3308 Gen_Unit
:= Renamed_Object
(Gen_Unit
);
3311 -- Verify that there are no circular instantiations
3313 if In_Open_Scopes
(Gen_Unit
) then
3314 Error_Msg_NE
("instantiation of & within itself", N
, Gen_Unit
);
3318 elsif Contains_Instance_Of
(Gen_Unit
, Current_Scope
, Gen_Id
) then
3319 Error_Msg_Node_2
:= Current_Scope
;
3321 ("circular Instantiation: & instantiated in &!", N
, Gen_Unit
);
3322 Circularity_Detected
:= True;
3327 Gen_Decl
:= Unit_Declaration_Node
(Gen_Unit
);
3329 -- Initialize renamings map, for error checking, and the list that
3330 -- holds private entities whose views have changed between generic
3331 -- definition and instantiation. If this is the instance created to
3332 -- validate an actual package, the instantiation environment is that
3333 -- of the enclosing instance.
3335 Create_Instantiation_Source
(N
, Gen_Unit
, False, S_Adjustment
);
3337 -- Copy original generic tree, to produce text for instantiation
3341 (Original_Node
(Gen_Decl
), Empty
, Instantiating
=> True);
3343 Act_Spec
:= Specification
(Act_Tree
);
3345 -- If this is the instance created to validate an actual package,
3346 -- only the formals matter, do not examine the package spec itself.
3348 if Is_Actual_Pack
then
3349 Set_Visible_Declarations
(Act_Spec
, New_List
);
3350 Set_Private_Declarations
(Act_Spec
, New_List
);
3354 Analyze_Associations
3356 Formals
=> Generic_Formal_Declarations
(Act_Tree
),
3357 F_Copy
=> Generic_Formal_Declarations
(Gen_Decl
));
3359 Vis_Prims_List
:= Check_Hidden_Primitives
(Renaming_List
);
3361 Set_Instance_Env
(Gen_Unit
, Act_Decl_Id
);
3362 Set_Defining_Unit_Name
(Act_Spec
, Act_Decl_Name
);
3363 Set_Is_Generic_Instance
(Act_Decl_Id
);
3365 Set_Generic_Parent
(Act_Spec
, Gen_Unit
);
3367 -- References to the generic in its own declaration or its body are
3368 -- references to the instance. Add a renaming declaration for the
3369 -- generic unit itself. This declaration, as well as the renaming
3370 -- declarations for the generic formals, must remain private to the
3371 -- unit: the formals, because this is the language semantics, and
3372 -- the unit because its use is an artifact of the implementation.
3375 Make_Package_Renaming_Declaration
(Loc
,
3376 Defining_Unit_Name
=>
3377 Make_Defining_Identifier
(Loc
, Chars
(Gen_Unit
)),
3378 Name
=> New_Reference_To
(Act_Decl_Id
, Loc
));
3380 Append
(Unit_Renaming
, Renaming_List
);
3382 -- The renaming declarations are the first local declarations of
3385 if Is_Non_Empty_List
(Visible_Declarations
(Act_Spec
)) then
3387 (First
(Visible_Declarations
(Act_Spec
)), Renaming_List
);
3389 Set_Visible_Declarations
(Act_Spec
, Renaming_List
);
3393 Make_Package_Declaration
(Loc
,
3394 Specification
=> Act_Spec
);
3396 -- Save the instantiation node, for subsequent instantiation of the
3397 -- body, if there is one and we are generating code for the current
3398 -- unit. Mark the unit as having a body, to avoid a premature error
3401 -- We instantiate the body if we are generating code, if we are
3402 -- generating cross-reference information, or if we are building
3403 -- trees for ASIS use.
3406 Enclosing_Body_Present
: Boolean := False;
3407 -- If the generic unit is not a compilation unit, then a body may
3408 -- be present in its parent even if none is required. We create a
3409 -- tentative pending instantiation for the body, which will be
3410 -- discarded if none is actually present.
3415 if Scope
(Gen_Unit
) /= Standard_Standard
3416 and then not Is_Child_Unit
(Gen_Unit
)
3418 Scop
:= Scope
(Gen_Unit
);
3420 while Present
(Scop
)
3421 and then Scop
/= Standard_Standard
3423 if Unit_Requires_Body
(Scop
) then
3424 Enclosing_Body_Present
:= True;
3427 elsif In_Open_Scopes
(Scop
)
3428 and then In_Package_Body
(Scop
)
3430 Enclosing_Body_Present
:= True;
3434 exit when Is_Compilation_Unit
(Scop
);
3435 Scop
:= Scope
(Scop
);
3439 -- If front-end inlining is enabled, and this is a unit for which
3440 -- code will be generated, we instantiate the body at once.
3442 -- This is done if the instance is not the main unit, and if the
3443 -- generic is not a child unit of another generic, to avoid scope
3444 -- problems and the reinstallation of parent instances.
3447 and then (not Is_Child_Unit
(Gen_Unit
)
3448 or else not Is_Generic_Unit
(Scope
(Gen_Unit
)))
3449 and then Might_Inline_Subp
3450 and then not Is_Actual_Pack
3452 if Front_End_Inlining
3453 and then (Is_In_Main_Unit
(N
)
3454 or else In_Main_Context
(Current_Scope
))
3455 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit
3459 -- In configurable_run_time mode we force the inlining of
3460 -- predefined subprograms marked Inline_Always, to minimize
3461 -- the use of the run-time library.
3463 elsif Is_Predefined_File_Name
3464 (Unit_File_Name
(Get_Source_Unit
(Gen_Decl
)))
3465 and then Configurable_Run_Time_Mode
3466 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit
3471 -- If the current scope is itself an instance within a child
3472 -- unit, there will be duplications in the scope stack, and the
3473 -- unstacking mechanism in Inline_Instance_Body will fail.
3474 -- This loses some rare cases of optimization, and might be
3475 -- improved some day, if we can find a proper abstraction for
3476 -- "the complete compilation context" that can be saved and
3479 if Is_Generic_Instance
(Current_Scope
) then
3481 Curr_Unit
: constant Entity_Id
:=
3482 Cunit_Entity
(Current_Sem_Unit
);
3484 if Curr_Unit
/= Current_Scope
3485 and then Is_Child_Unit
(Curr_Unit
)
3487 Inline_Now
:= False;
3494 (Unit_Requires_Body
(Gen_Unit
)
3495 or else Enclosing_Body_Present
3496 or else Present
(Corresponding_Body
(Gen_Decl
)))
3497 and then (Is_In_Main_Unit
(N
)
3498 or else Might_Inline_Subp
)
3499 and then not Is_Actual_Pack
3500 and then not Inline_Now
3501 and then not Alfa_Mode
3502 and then (Operating_Mode
= Generate_Code
3503 or else (Operating_Mode
= Check_Semantics
3504 and then ASIS_Mode
));
3506 -- If front_end_inlining is enabled, do not instantiate body if
3507 -- within a generic context.
3509 if (Front_End_Inlining
3510 and then not Expander_Active
)
3511 or else Is_Generic_Unit
(Cunit_Entity
(Main_Unit
))
3513 Needs_Body
:= False;
3516 -- If the current context is generic, and the package being
3517 -- instantiated is declared within a formal package, there is no
3518 -- body to instantiate until the enclosing generic is instantiated
3519 -- and there is an actual for the formal package. If the formal
3520 -- package has parameters, we build a regular package instance for
3521 -- it, that precedes the original formal package declaration.
3523 if In_Open_Scopes
(Scope
(Scope
(Gen_Unit
))) then
3525 Decl
: constant Node_Id
:=
3527 (Unit_Declaration_Node
(Scope
(Gen_Unit
)));
3529 if Nkind
(Decl
) = N_Formal_Package_Declaration
3530 or else (Nkind
(Decl
) = N_Package_Declaration
3531 and then Is_List_Member
(Decl
)
3532 and then Present
(Next
(Decl
))
3534 Nkind
(Next
(Decl
)) =
3535 N_Formal_Package_Declaration
)
3537 Needs_Body
:= False;
3543 -- Note that we generate the instance body even when generating
3544 -- calling stubs for an RCI unit: it may be required e.g. if it
3545 -- provides stream attributes for some type used in the profile of a
3546 -- remote subprogram. If the instantiation is within the visible part
3547 -- of the RCI, then calling stubs for any relevant subprogram will
3548 -- be inserted immediately after the subprogram declaration, and
3549 -- will take precedence over the subsequent (original) body. (The
3550 -- stub and original body will be complete homographs, but this is
3551 -- permitted in an instance).
3553 -- Could we do better and remove the original subprogram body in that
3558 -- Here is a defence against a ludicrous number of instantiations
3559 -- caused by a circular set of instantiation attempts.
3561 if Pending_Instantiations
.Last
>
3562 Hostparm
.Max_Instantiations
3564 Error_Msg_N
("too many instantiations", N
);
3565 raise Unrecoverable_Error
;
3568 -- Indicate that the enclosing scopes contain an instantiation,
3569 -- and that cleanup actions should be delayed until after the
3570 -- instance body is expanded.
3572 Check_Forward_Instantiation
(Gen_Decl
);
3573 if Nkind
(N
) = N_Package_Instantiation
then
3575 Enclosing_Master
: Entity_Id
;
3578 -- Loop to search enclosing masters
3580 Enclosing_Master
:= Current_Scope
;
3581 Scope_Loop
: while Enclosing_Master
/= Standard_Standard
loop
3582 if Ekind
(Enclosing_Master
) = E_Package
then
3583 if Is_Compilation_Unit
(Enclosing_Master
) then
3584 if In_Package_Body
(Enclosing_Master
) then
3586 (Body_Entity
(Enclosing_Master
));
3595 Enclosing_Master
:= Scope
(Enclosing_Master
);
3598 elsif Is_Generic_Unit
(Enclosing_Master
)
3599 or else Ekind
(Enclosing_Master
) = E_Void
3601 -- Cleanup actions will eventually be performed on the
3602 -- enclosing subprogram or package instance, if any.
3603 -- Enclosing scope is void in the formal part of a
3604 -- generic subprogram.
3609 if Ekind
(Enclosing_Master
) = E_Entry
3611 Ekind
(Scope
(Enclosing_Master
)) = E_Protected_Type
3613 if not Expander_Active
then
3617 Protected_Body_Subprogram
(Enclosing_Master
);
3621 Set_Delay_Cleanups
(Enclosing_Master
);
3623 while Ekind
(Enclosing_Master
) = E_Block
loop
3624 Enclosing_Master
:= Scope
(Enclosing_Master
);
3627 if Is_Subprogram
(Enclosing_Master
) then
3628 Delay_Descriptors
(Enclosing_Master
);
3630 elsif Is_Task_Type
(Enclosing_Master
) then
3632 TBP
: constant Node_Id
:=
3633 Get_Task_Body_Procedure
3636 if Present
(TBP
) then
3637 Delay_Descriptors
(TBP
);
3638 Set_Delay_Cleanups
(TBP
);
3645 end loop Scope_Loop
;
3648 -- Make entry in table
3650 Pending_Instantiations
.Append
3652 Act_Decl
=> Act_Decl
,
3653 Expander_Status
=> Expander_Active
,
3654 Current_Sem_Unit
=> Current_Sem_Unit
,
3655 Scope_Suppress
=> Scope_Suppress
,
3656 Local_Suppress_Stack_Top
=> Local_Suppress_Stack_Top
,
3657 Version
=> Ada_Version
));
3661 Set_Categorization_From_Pragmas
(Act_Decl
);
3663 if Parent_Installed
then
3667 Set_Instance_Spec
(N
, Act_Decl
);
3669 -- If not a compilation unit, insert the package declaration before
3670 -- the original instantiation node.
3672 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
3673 Mark_Rewrite_Insertion
(Act_Decl
);
3674 Insert_Before
(N
, Act_Decl
);
3677 -- For an instantiation that is a compilation unit, place declaration
3678 -- on current node so context is complete for analysis (including
3679 -- nested instantiations). If this is the main unit, the declaration
3680 -- eventually replaces the instantiation node. If the instance body
3681 -- is created later, it replaces the instance node, and the
3682 -- declaration is attached to it (see
3683 -- Build_Instance_Compilation_Unit_Nodes).
3686 if Cunit_Entity
(Current_Sem_Unit
) = Defining_Entity
(N
) then
3688 -- The entity for the current unit is the newly created one,
3689 -- and all semantic information is attached to it.
3691 Set_Cunit_Entity
(Current_Sem_Unit
, Act_Decl_Id
);
3693 -- If this is the main unit, replace the main entity as well
3695 if Current_Sem_Unit
= Main_Unit
then
3696 Main_Unit_Entity
:= Act_Decl_Id
;
3700 Set_Unit
(Parent
(N
), Act_Decl
);
3701 Set_Parent_Spec
(Act_Decl
, Parent_Spec
(N
));
3702 Set_Package_Instantiation
(Act_Decl_Id
, N
);
3704 Set_Unit
(Parent
(N
), N
);
3705 Set_Body_Required
(Parent
(N
), False);
3707 -- We never need elaboration checks on instantiations, since by
3708 -- definition, the body instantiation is elaborated at the same
3709 -- time as the spec instantiation.
3711 Set_Suppress_Elaboration_Warnings
(Act_Decl_Id
);
3712 Set_Kill_Elaboration_Checks
(Act_Decl_Id
);
3715 Check_Elab_Instantiation
(N
);
3717 if ABE_Is_Certain
(N
) and then Needs_Body
then
3718 Pending_Instantiations
.Decrement_Last
;
3721 Check_Hidden_Child_Unit
(N
, Gen_Unit
, Act_Decl_Id
);
3723 Set_First_Private_Entity
(Defining_Unit_Name
(Unit_Renaming
),
3724 First_Private_Entity
(Act_Decl_Id
));
3726 -- If the instantiation will receive a body, the unit will be
3727 -- transformed into a package body, and receive its own elaboration
3728 -- entity. Otherwise, the nature of the unit is now a package
3731 if Nkind
(Parent
(N
)) = N_Compilation_Unit
3732 and then not Needs_Body
3734 Rewrite
(N
, Act_Decl
);
3737 if Present
(Corresponding_Body
(Gen_Decl
))
3738 or else Unit_Requires_Body
(Gen_Unit
)
3740 Set_Has_Completion
(Act_Decl_Id
);
3743 Check_Formal_Packages
(Act_Decl_Id
);
3745 Restore_Hidden_Primitives
(Vis_Prims_List
);
3746 Restore_Private_Views
(Act_Decl_Id
);
3748 Inherit_Context
(Gen_Decl
, N
);
3750 if Parent_Installed
then
3755 Env_Installed
:= False;
3758 Validate_Categorization_Dependency
(N
, Act_Decl_Id
);
3760 -- There used to be a check here to prevent instantiations in local
3761 -- contexts if the No_Local_Allocators restriction was active. This
3762 -- check was removed by a binding interpretation in AI-95-00130/07,
3763 -- but we retain the code for documentation purposes.
3765 -- if Ekind (Act_Decl_Id) /= E_Void
3766 -- and then not Is_Library_Level_Entity (Act_Decl_Id)
3768 -- Check_Restriction (No_Local_Allocators, N);
3772 Inline_Instance_Body
(N
, Gen_Unit
, Act_Decl
);
3775 -- The following is a tree patch for ASIS: ASIS needs separate nodes to
3776 -- be used as defining identifiers for a formal package and for the
3777 -- corresponding expanded package.
3779 if Nkind
(N
) = N_Formal_Package_Declaration
then
3780 Act_Decl_Id
:= New_Copy
(Defining_Entity
(N
));
3781 Set_Comes_From_Source
(Act_Decl_Id
, True);
3782 Set_Is_Generic_Instance
(Act_Decl_Id
, False);
3783 Set_Defining_Identifier
(N
, Act_Decl_Id
);
3786 Style_Check
:= Save_Style_Check
;
3789 if Has_Aspects
(N
) then
3790 Analyze_Aspect_Specifications
(N
, Act_Decl_Id
);
3794 when Instantiation_Error
=>
3795 if Parent_Installed
then
3799 if Env_Installed
then
3803 Style_Check
:= Save_Style_Check
;
3804 end Analyze_Package_Instantiation
;
3806 --------------------------
3807 -- Inline_Instance_Body --
3808 --------------------------
3810 procedure Inline_Instance_Body
3812 Gen_Unit
: Entity_Id
;
3816 Gen_Comp
: constant Entity_Id
:=
3817 Cunit_Entity
(Get_Source_Unit
(Gen_Unit
));
3818 Curr_Comp
: constant Node_Id
:= Cunit
(Current_Sem_Unit
);
3819 Curr_Scope
: Entity_Id
:= Empty
;
3820 Curr_Unit
: constant Entity_Id
:= Cunit_Entity
(Current_Sem_Unit
);
3821 Removed
: Boolean := False;
3822 Num_Scopes
: Int
:= 0;
3824 Scope_Stack_Depth
: constant Int
:=
3825 Scope_Stack
.Last
- Scope_Stack
.First
+ 1;
3827 Use_Clauses
: array (1 .. Scope_Stack_Depth
) of Node_Id
;
3828 Instances
: array (1 .. Scope_Stack_Depth
) of Entity_Id
;
3829 Inner_Scopes
: array (1 .. Scope_Stack_Depth
) of Entity_Id
;
3830 Num_Inner
: Int
:= 0;
3831 N_Instances
: Int
:= 0;
3835 -- Case of generic unit defined in another unit. We must remove the
3836 -- complete context of the current unit to install that of the generic.
3838 if Gen_Comp
/= Cunit_Entity
(Current_Sem_Unit
) then
3840 -- Add some comments for the following two loops ???
3843 while Present
(S
) and then S
/= Standard_Standard
loop
3845 Num_Scopes
:= Num_Scopes
+ 1;
3847 Use_Clauses
(Num_Scopes
) :=
3849 (Scope_Stack
.Last
- Num_Scopes
+ 1).
3851 End_Use_Clauses
(Use_Clauses
(Num_Scopes
));
3853 exit when Scope_Stack
.Last
- Num_Scopes
+ 1 = Scope_Stack
.First
3854 or else Scope_Stack
.Table
3855 (Scope_Stack
.Last
- Num_Scopes
).Entity
3859 exit when Is_Generic_Instance
(S
)
3860 and then (In_Package_Body
(S
)
3861 or else Ekind
(S
) = E_Procedure
3862 or else Ekind
(S
) = E_Function
);
3866 Vis
:= Is_Immediately_Visible
(Gen_Comp
);
3868 -- Find and save all enclosing instances
3873 and then S
/= Standard_Standard
3875 if Is_Generic_Instance
(S
) then
3876 N_Instances
:= N_Instances
+ 1;
3877 Instances
(N_Instances
) := S
;
3879 exit when In_Package_Body
(S
);
3885 -- Remove context of current compilation unit, unless we are within a
3886 -- nested package instantiation, in which case the context has been
3887 -- removed previously.
3889 -- If current scope is the body of a child unit, remove context of
3890 -- spec as well. If an enclosing scope is an instance body, the
3891 -- context has already been removed, but the entities in the body
3892 -- must be made invisible as well.
3897 and then S
/= Standard_Standard
3899 if Is_Generic_Instance
(S
)
3900 and then (In_Package_Body
(S
)
3901 or else Ekind
(S
) = E_Procedure
3902 or else Ekind
(S
) = E_Function
)
3904 -- We still have to remove the entities of the enclosing
3905 -- instance from direct visibility.
3910 E
:= First_Entity
(S
);
3911 while Present
(E
) loop
3912 Set_Is_Immediately_Visible
(E
, False);
3921 or else (Ekind
(Curr_Unit
) = E_Package_Body
3922 and then S
= Spec_Entity
(Curr_Unit
))
3923 or else (Ekind
(Curr_Unit
) = E_Subprogram_Body
3926 (Unit_Declaration_Node
(Curr_Unit
)))
3930 -- Remove entities in current scopes from visibility, so that
3931 -- instance body is compiled in a clean environment.
3933 Save_Scope_Stack
(Handle_Use
=> False);
3935 if Is_Child_Unit
(S
) then
3937 -- Remove child unit from stack, as well as inner scopes.
3938 -- Removing the context of a child unit removes parent units
3941 while Current_Scope
/= S
loop
3942 Num_Inner
:= Num_Inner
+ 1;
3943 Inner_Scopes
(Num_Inner
) := Current_Scope
;
3948 Remove_Context
(Curr_Comp
);
3952 Remove_Context
(Curr_Comp
);
3955 if Ekind
(Curr_Unit
) = E_Package_Body
then
3956 Remove_Context
(Library_Unit
(Curr_Comp
));
3962 pragma Assert
(Num_Inner
< Num_Scopes
);
3964 Push_Scope
(Standard_Standard
);
3965 Scope_Stack
.Table
(Scope_Stack
.Last
).Is_Active_Stack_Base
:= True;
3966 Instantiate_Package_Body
3969 Act_Decl
=> Act_Decl
,
3970 Expander_Status
=> Expander_Active
,
3971 Current_Sem_Unit
=> Current_Sem_Unit
,
3972 Scope_Suppress
=> Scope_Suppress
,
3973 Local_Suppress_Stack_Top
=> Local_Suppress_Stack_Top
,
3974 Version
=> Ada_Version
)),
3975 Inlined_Body
=> True);
3981 Set_Is_Immediately_Visible
(Gen_Comp
, Vis
);
3983 -- Reset Generic_Instance flag so that use clauses can be installed
3984 -- in the proper order. (See Use_One_Package for effect of enclosing
3985 -- instances on processing of use clauses).
3987 for J
in 1 .. N_Instances
loop
3988 Set_Is_Generic_Instance
(Instances
(J
), False);
3992 Install_Context
(Curr_Comp
);
3994 if Present
(Curr_Scope
)
3995 and then Is_Child_Unit
(Curr_Scope
)
3997 Push_Scope
(Curr_Scope
);
3998 Set_Is_Immediately_Visible
(Curr_Scope
);
4000 -- Finally, restore inner scopes as well
4002 for J
in reverse 1 .. Num_Inner
loop
4003 Push_Scope
(Inner_Scopes
(J
));
4007 Restore_Scope_Stack
(Handle_Use
=> False);
4009 if Present
(Curr_Scope
)
4011 (In_Private_Part
(Curr_Scope
)
4012 or else In_Package_Body
(Curr_Scope
))
4014 -- Install private declaration of ancestor units, which are
4015 -- currently available. Restore_Scope_Stack and Install_Context
4016 -- only install the visible part of parents.
4021 Par
:= Scope
(Curr_Scope
);
4022 while (Present
(Par
))
4023 and then Par
/= Standard_Standard
4025 Install_Private_Declarations
(Par
);
4032 -- Restore use clauses. For a child unit, use clauses in the parents
4033 -- are restored when installing the context, so only those in inner
4034 -- scopes (and those local to the child unit itself) need to be
4035 -- installed explicitly.
4037 if Is_Child_Unit
(Curr_Unit
)
4040 for J
in reverse 1 .. Num_Inner
+ 1 loop
4041 Scope_Stack
.Table
(Scope_Stack
.Last
- J
+ 1).First_Use_Clause
:=
4043 Install_Use_Clauses
(Use_Clauses
(J
));
4047 for J
in reverse 1 .. Num_Scopes
loop
4048 Scope_Stack
.Table
(Scope_Stack
.Last
- J
+ 1).First_Use_Clause
:=
4050 Install_Use_Clauses
(Use_Clauses
(J
));
4054 -- Restore status of instances. If one of them is a body, make
4055 -- its local entities visible again.
4062 for J
in 1 .. N_Instances
loop
4063 Inst
:= Instances
(J
);
4064 Set_Is_Generic_Instance
(Inst
, True);
4066 if In_Package_Body
(Inst
)
4067 or else Ekind
(S
) = E_Procedure
4068 or else Ekind
(S
) = E_Function
4070 E
:= First_Entity
(Instances
(J
));
4071 while Present
(E
) loop
4072 Set_Is_Immediately_Visible
(E
);
4079 -- If generic unit is in current unit, current context is correct
4082 Instantiate_Package_Body
4085 Act_Decl
=> Act_Decl
,
4086 Expander_Status
=> Expander_Active
,
4087 Current_Sem_Unit
=> Current_Sem_Unit
,
4088 Scope_Suppress
=> Scope_Suppress
,
4089 Local_Suppress_Stack_Top
=> Local_Suppress_Stack_Top
,
4090 Version
=> Ada_Version
)),
4091 Inlined_Body
=> True);
4093 end Inline_Instance_Body
;
4095 -------------------------------------
4096 -- Analyze_Procedure_Instantiation --
4097 -------------------------------------
4099 procedure Analyze_Procedure_Instantiation
(N
: Node_Id
) is
4101 Analyze_Subprogram_Instantiation
(N
, E_Procedure
);
4102 end Analyze_Procedure_Instantiation
;
4104 -----------------------------------
4105 -- Need_Subprogram_Instance_Body --
4106 -----------------------------------
4108 function Need_Subprogram_Instance_Body
4110 Subp
: Entity_Id
) return Boolean
4113 if (Is_In_Main_Unit
(N
)
4114 or else Is_Inlined
(Subp
)
4115 or else Is_Inlined
(Alias
(Subp
)))
4116 and then (Operating_Mode
= Generate_Code
4117 or else (Operating_Mode
= Check_Semantics
4118 and then ASIS_Mode
))
4119 and then (Full_Expander_Active
or else ASIS_Mode
)
4120 and then not ABE_Is_Certain
(N
)
4121 and then not Is_Eliminated
(Subp
)
4123 Pending_Instantiations
.Append
4125 Act_Decl
=> Unit_Declaration_Node
(Subp
),
4126 Expander_Status
=> Expander_Active
,
4127 Current_Sem_Unit
=> Current_Sem_Unit
,
4128 Scope_Suppress
=> Scope_Suppress
,
4129 Local_Suppress_Stack_Top
=> Local_Suppress_Stack_Top
,
4130 Version
=> Ada_Version
));
4136 end Need_Subprogram_Instance_Body
;
4138 --------------------------------------
4139 -- Analyze_Subprogram_Instantiation --
4140 --------------------------------------
4142 procedure Analyze_Subprogram_Instantiation
4146 Loc
: constant Source_Ptr
:= Sloc
(N
);
4147 Gen_Id
: constant Node_Id
:= Name
(N
);
4149 Anon_Id
: constant Entity_Id
:=
4150 Make_Defining_Identifier
(Sloc
(Defining_Entity
(N
)),
4151 Chars
=> New_External_Name
4152 (Chars
(Defining_Entity
(N
)), 'R'));
4154 Act_Decl_Id
: Entity_Id
;
4159 Env_Installed
: Boolean := False;
4160 Gen_Unit
: Entity_Id
;
4162 Pack_Id
: Entity_Id
;
4163 Parent_Installed
: Boolean := False;
4164 Renaming_List
: List_Id
;
4166 Save_Style_Check
: constant Boolean := Style_Check
;
4167 -- Save style check mode for restore on exit
4169 procedure Analyze_Instance_And_Renamings
;
4170 -- The instance must be analyzed in a context that includes the mappings
4171 -- of generic parameters into actuals. We create a package declaration
4172 -- for this purpose, and a subprogram with an internal name within the
4173 -- package. The subprogram instance is simply an alias for the internal
4174 -- subprogram, declared in the current scope.
4176 ------------------------------------
4177 -- Analyze_Instance_And_Renamings --
4178 ------------------------------------
4180 procedure Analyze_Instance_And_Renamings
is
4181 Def_Ent
: constant Entity_Id
:= Defining_Entity
(N
);
4182 Pack_Decl
: Node_Id
;
4185 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
4187 -- For the case of a compilation unit, the container package has
4188 -- the same name as the instantiation, to insure that the binder
4189 -- calls the elaboration procedure with the right name. Copy the
4190 -- entity of the instance, which may have compilation level flags
4191 -- (e.g. Is_Child_Unit) set.
4193 Pack_Id
:= New_Copy
(Def_Ent
);
4196 -- Otherwise we use the name of the instantiation concatenated
4197 -- with its source position to ensure uniqueness if there are
4198 -- several instantiations with the same name.
4201 Make_Defining_Identifier
(Loc
,
4202 Chars
=> New_External_Name
4203 (Related_Id
=> Chars
(Def_Ent
),
4205 Suffix_Index
=> Source_Offset
(Sloc
(Def_Ent
))));
4208 Pack_Decl
:= Make_Package_Declaration
(Loc
,
4209 Specification
=> Make_Package_Specification
(Loc
,
4210 Defining_Unit_Name
=> Pack_Id
,
4211 Visible_Declarations
=> Renaming_List
,
4212 End_Label
=> Empty
));
4214 Set_Instance_Spec
(N
, Pack_Decl
);
4215 Set_Is_Generic_Instance
(Pack_Id
);
4216 Set_Debug_Info_Needed
(Pack_Id
);
4218 -- Case of not a compilation unit
4220 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
4221 Mark_Rewrite_Insertion
(Pack_Decl
);
4222 Insert_Before
(N
, Pack_Decl
);
4223 Set_Has_Completion
(Pack_Id
);
4225 -- Case of an instantiation that is a compilation unit
4227 -- Place declaration on current node so context is complete for
4228 -- analysis (including nested instantiations), and for use in a
4229 -- context_clause (see Analyze_With_Clause).
4232 Set_Unit
(Parent
(N
), Pack_Decl
);
4233 Set_Parent_Spec
(Pack_Decl
, Parent_Spec
(N
));
4236 Analyze
(Pack_Decl
);
4237 Check_Formal_Packages
(Pack_Id
);
4238 Set_Is_Generic_Instance
(Pack_Id
, False);
4240 -- Why do we clear Is_Generic_Instance??? We set it 20 lines
4243 -- Body of the enclosing package is supplied when instantiating the
4244 -- subprogram body, after semantic analysis is completed.
4246 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
4248 -- Remove package itself from visibility, so it does not
4249 -- conflict with subprogram.
4251 Set_Name_Entity_Id
(Chars
(Pack_Id
), Homonym
(Pack_Id
));
4253 -- Set name and scope of internal subprogram so that the proper
4254 -- external name will be generated. The proper scope is the scope
4255 -- of the wrapper package. We need to generate debugging info for
4256 -- the internal subprogram, so set flag accordingly.
4258 Set_Chars
(Anon_Id
, Chars
(Defining_Entity
(N
)));
4259 Set_Scope
(Anon_Id
, Scope
(Pack_Id
));
4261 -- Mark wrapper package as referenced, to avoid spurious warnings
4262 -- if the instantiation appears in various with_ clauses of
4263 -- subunits of the main unit.
4265 Set_Referenced
(Pack_Id
);
4268 Set_Is_Generic_Instance
(Anon_Id
);
4269 Set_Debug_Info_Needed
(Anon_Id
);
4270 Act_Decl_Id
:= New_Copy
(Anon_Id
);
4272 Set_Parent
(Act_Decl_Id
, Parent
(Anon_Id
));
4273 Set_Chars
(Act_Decl_Id
, Chars
(Defining_Entity
(N
)));
4274 Set_Sloc
(Act_Decl_Id
, Sloc
(Defining_Entity
(N
)));
4275 Set_Comes_From_Source
(Act_Decl_Id
, True);
4277 -- The signature may involve types that are not frozen yet, but the
4278 -- subprogram will be frozen at the point the wrapper package is
4279 -- frozen, so it does not need its own freeze node. In fact, if one
4280 -- is created, it might conflict with the freezing actions from the
4283 Set_Has_Delayed_Freeze
(Anon_Id
, False);
4285 -- If the instance is a child unit, mark the Id accordingly. Mark
4286 -- the anonymous entity as well, which is the real subprogram and
4287 -- which is used when the instance appears in a context clause.
4288 -- Similarly, propagate the Is_Eliminated flag to handle properly
4289 -- nested eliminated subprograms.
4291 Set_Is_Child_Unit
(Act_Decl_Id
, Is_Child_Unit
(Defining_Entity
(N
)));
4292 Set_Is_Child_Unit
(Anon_Id
, Is_Child_Unit
(Defining_Entity
(N
)));
4293 New_Overloaded_Entity
(Act_Decl_Id
);
4294 Check_Eliminated
(Act_Decl_Id
);
4295 Set_Is_Eliminated
(Anon_Id
, Is_Eliminated
(Act_Decl_Id
));
4297 -- In compilation unit case, kill elaboration checks on the
4298 -- instantiation, since they are never needed -- the body is
4299 -- instantiated at the same point as the spec.
4301 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
4302 Set_Suppress_Elaboration_Warnings
(Act_Decl_Id
);
4303 Set_Kill_Elaboration_Checks
(Act_Decl_Id
);
4304 Set_Is_Compilation_Unit
(Anon_Id
);
4306 Set_Cunit_Entity
(Current_Sem_Unit
, Pack_Id
);
4309 -- The instance is not a freezing point for the new subprogram
4311 Set_Is_Frozen
(Act_Decl_Id
, False);
4313 if Nkind
(Defining_Entity
(N
)) = N_Defining_Operator_Symbol
then
4314 Valid_Operator_Definition
(Act_Decl_Id
);
4317 Set_Alias
(Act_Decl_Id
, Anon_Id
);
4318 Set_Parent
(Act_Decl_Id
, Parent
(Anon_Id
));
4319 Set_Has_Completion
(Act_Decl_Id
);
4320 Set_Related_Instance
(Pack_Id
, Act_Decl_Id
);
4322 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
4323 Set_Body_Required
(Parent
(N
), False);
4325 end Analyze_Instance_And_Renamings
;
4329 Vis_Prims_List
: Elist_Id
:= No_Elist
;
4330 -- List of primitives made temporarily visible in the instantiation
4331 -- to match the visibility of the formal type
4333 -- Start of processing for Analyze_Subprogram_Instantiation
4336 Check_SPARK_Restriction
("generic is not allowed", N
);
4338 -- Very first thing: apply the special kludge for Text_IO processing
4339 -- in case we are instantiating one of the children of [Wide_]Text_IO.
4340 -- Of course such an instantiation is bogus (these are packages, not
4341 -- subprograms), but we get a better error message if we do this.
4343 Text_IO_Kludge
(Gen_Id
);
4345 -- Make node global for error reporting
4347 Instantiation_Node
:= N
;
4349 -- Turn off style checking in instances. If the check is enabled on the
4350 -- generic unit, a warning in an instance would just be noise. If not
4351 -- enabled on the generic, then a warning in an instance is just wrong.
4353 Style_Check
:= False;
4355 Preanalyze_Actuals
(N
);
4358 Env_Installed
:= True;
4359 Check_Generic_Child_Unit
(Gen_Id
, Parent_Installed
);
4360 Gen_Unit
:= Entity
(Gen_Id
);
4362 Generate_Reference
(Gen_Unit
, Gen_Id
);
4364 if Nkind
(Gen_Id
) = N_Identifier
4365 and then Chars
(Gen_Unit
) = Chars
(Defining_Entity
(N
))
4368 ("& is hidden within declaration of instance", Gen_Id
, Gen_Unit
);
4371 if Etype
(Gen_Unit
) = Any_Type
then
4376 -- Verify that it is a generic subprogram of the right kind, and that
4377 -- it does not lead to a circular instantiation.
4379 if not Ekind_In
(Gen_Unit
, E_Generic_Procedure
, E_Generic_Function
) then
4380 Error_Msg_N
("expect generic subprogram in instantiation", Gen_Id
);
4382 elsif In_Open_Scopes
(Gen_Unit
) then
4383 Error_Msg_NE
("instantiation of & within itself", N
, Gen_Unit
);
4385 elsif K
= E_Procedure
4386 and then Ekind
(Gen_Unit
) /= E_Generic_Procedure
4388 if Ekind
(Gen_Unit
) = E_Generic_Function
then
4390 ("cannot instantiate generic function as procedure", Gen_Id
);
4393 ("expect name of generic procedure in instantiation", Gen_Id
);
4396 elsif K
= E_Function
4397 and then Ekind
(Gen_Unit
) /= E_Generic_Function
4399 if Ekind
(Gen_Unit
) = E_Generic_Procedure
then
4401 ("cannot instantiate generic procedure as function", Gen_Id
);
4404 ("expect name of generic function in instantiation", Gen_Id
);
4408 Set_Entity
(Gen_Id
, Gen_Unit
);
4409 Set_Is_Instantiated
(Gen_Unit
);
4411 if In_Extended_Main_Source_Unit
(N
) then
4412 Generate_Reference
(Gen_Unit
, N
);
4415 -- If renaming, get original unit
4417 if Present
(Renamed_Object
(Gen_Unit
))
4418 and then (Ekind
(Renamed_Object
(Gen_Unit
)) = E_Generic_Procedure
4420 Ekind
(Renamed_Object
(Gen_Unit
)) = E_Generic_Function
)
4422 Gen_Unit
:= Renamed_Object
(Gen_Unit
);
4423 Set_Is_Instantiated
(Gen_Unit
);
4424 Generate_Reference
(Gen_Unit
, N
);
4427 if Contains_Instance_Of
(Gen_Unit
, Current_Scope
, Gen_Id
) then
4428 Error_Msg_Node_2
:= Current_Scope
;
4430 ("circular Instantiation: & instantiated in &!", N
, Gen_Unit
);
4431 Circularity_Detected
:= True;
4432 Restore_Hidden_Primitives
(Vis_Prims_List
);
4436 Gen_Decl
:= Unit_Declaration_Node
(Gen_Unit
);
4438 -- Initialize renamings map, for error checking
4440 Generic_Renamings
.Set_Last
(0);
4441 Generic_Renamings_HTable
.Reset
;
4443 Create_Instantiation_Source
(N
, Gen_Unit
, False, S_Adjustment
);
4445 -- Copy original generic tree, to produce text for instantiation
4449 (Original_Node
(Gen_Decl
), Empty
, Instantiating
=> True);
4451 -- Inherit overriding indicator from instance node
4453 Act_Spec
:= Specification
(Act_Tree
);
4454 Set_Must_Override
(Act_Spec
, Must_Override
(N
));
4455 Set_Must_Not_Override
(Act_Spec
, Must_Not_Override
(N
));
4458 Analyze_Associations
4460 Formals
=> Generic_Formal_Declarations
(Act_Tree
),
4461 F_Copy
=> Generic_Formal_Declarations
(Gen_Decl
));
4463 Vis_Prims_List
:= Check_Hidden_Primitives
(Renaming_List
);
4465 -- The subprogram itself cannot contain a nested instance, so the
4466 -- current parent is left empty.
4468 Set_Instance_Env
(Gen_Unit
, Empty
);
4470 -- Build the subprogram declaration, which does not appear in the
4471 -- generic template, and give it a sloc consistent with that of the
4474 Set_Defining_Unit_Name
(Act_Spec
, Anon_Id
);
4475 Set_Generic_Parent
(Act_Spec
, Gen_Unit
);
4477 Make_Subprogram_Declaration
(Sloc
(Act_Spec
),
4478 Specification
=> Act_Spec
);
4480 -- The aspects have been copied previously, but they have to be
4481 -- linked explicitly to the new subprogram declaration. Explicit
4482 -- pre/postconditions on the instance are analyzed below, in a
4485 Move_Aspects
(Act_Tree
, Act_Decl
);
4486 Set_Categorization_From_Pragmas
(Act_Decl
);
4488 if Parent_Installed
then
4492 Append
(Act_Decl
, Renaming_List
);
4493 Analyze_Instance_And_Renamings
;
4495 -- If the generic is marked Import (Intrinsic), then so is the
4496 -- instance. This indicates that there is no body to instantiate. If
4497 -- generic is marked inline, so it the instance, and the anonymous
4498 -- subprogram it renames. If inlined, or else if inlining is enabled
4499 -- for the compilation, we generate the instance body even if it is
4500 -- not within the main unit.
4502 if Is_Intrinsic_Subprogram
(Gen_Unit
) then
4503 Set_Is_Intrinsic_Subprogram
(Anon_Id
);
4504 Set_Is_Intrinsic_Subprogram
(Act_Decl_Id
);
4506 if Chars
(Gen_Unit
) = Name_Unchecked_Conversion
then
4507 Validate_Unchecked_Conversion
(N
, Act_Decl_Id
);
4511 -- Inherit convention from generic unit. Intrinsic convention, as for
4512 -- an instance of unchecked conversion, is not inherited because an
4513 -- explicit Ada instance has been created.
4515 if Has_Convention_Pragma
(Gen_Unit
)
4516 and then Convention
(Gen_Unit
) /= Convention_Intrinsic
4518 Set_Convention
(Act_Decl_Id
, Convention
(Gen_Unit
));
4519 Set_Is_Exported
(Act_Decl_Id
, Is_Exported
(Gen_Unit
));
4522 Generate_Definition
(Act_Decl_Id
);
4523 Set_Contract
(Anon_Id
, Make_Contract
(Sloc
(Anon_Id
))); -- ??? needed?
4524 Set_Contract
(Act_Decl_Id
, Make_Contract
(Sloc
(Act_Decl_Id
)));
4526 -- Inherit all inlining-related flags which apply to the generic in
4527 -- the subprogram and its declaration.
4529 Set_Is_Inlined
(Act_Decl_Id
, Is_Inlined
(Gen_Unit
));
4530 Set_Is_Inlined
(Anon_Id
, Is_Inlined
(Gen_Unit
));
4532 Set_Has_Pragma_Inline
(Act_Decl_Id
, Has_Pragma_Inline
(Gen_Unit
));
4533 Set_Has_Pragma_Inline
(Anon_Id
, Has_Pragma_Inline
(Gen_Unit
));
4535 Set_Has_Pragma_Inline_Always
4536 (Act_Decl_Id
, Has_Pragma_Inline_Always
(Gen_Unit
));
4537 Set_Has_Pragma_Inline_Always
4538 (Anon_Id
, Has_Pragma_Inline_Always
(Gen_Unit
));
4540 if not Is_Intrinsic_Subprogram
(Gen_Unit
) then
4541 Check_Elab_Instantiation
(N
);
4544 if Is_Dispatching_Operation
(Act_Decl_Id
)
4545 and then Ada_Version
>= Ada_2005
4551 Formal
:= First_Formal
(Act_Decl_Id
);
4552 while Present
(Formal
) loop
4553 if Ekind
(Etype
(Formal
)) = E_Anonymous_Access_Type
4554 and then Is_Controlling_Formal
(Formal
)
4555 and then not Can_Never_Be_Null
(Formal
)
4557 Error_Msg_NE
("access parameter& is controlling,",
4560 ("\corresponding parameter of & must be"
4561 & " explicitly null-excluding", N
, Gen_Id
);
4564 Next_Formal
(Formal
);
4569 Check_Hidden_Child_Unit
(N
, Gen_Unit
, Act_Decl_Id
);
4571 Validate_Categorization_Dependency
(N
, Act_Decl_Id
);
4573 if not Is_Intrinsic_Subprogram
(Act_Decl_Id
) then
4574 Inherit_Context
(Gen_Decl
, N
);
4576 Restore_Private_Views
(Pack_Id
, False);
4578 -- If the context requires a full instantiation, mark node for
4579 -- subsequent construction of the body.
4581 if Need_Subprogram_Instance_Body
(N
, Act_Decl_Id
) then
4583 Check_Forward_Instantiation
(Gen_Decl
);
4585 -- The wrapper package is always delayed, because it does not
4586 -- constitute a freeze point, but to insure that the freeze
4587 -- node is placed properly, it is created directly when
4588 -- instantiating the body (otherwise the freeze node might
4589 -- appear to early for nested instantiations).
4591 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
then
4593 -- For ASIS purposes, indicate that the wrapper package has
4594 -- replaced the instantiation node.
4596 Rewrite
(N
, Unit
(Parent
(N
)));
4597 Set_Unit
(Parent
(N
), N
);
4600 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
then
4602 -- Replace instance node for library-level instantiations of
4603 -- intrinsic subprograms, for ASIS use.
4605 Rewrite
(N
, Unit
(Parent
(N
)));
4606 Set_Unit
(Parent
(N
), N
);
4609 if Parent_Installed
then
4613 Restore_Hidden_Primitives
(Vis_Prims_List
);
4615 Env_Installed
:= False;
4616 Generic_Renamings
.Set_Last
(0);
4617 Generic_Renamings_HTable
.Reset
;
4620 Style_Check
:= Save_Style_Check
;
4623 if Has_Aspects
(N
) then
4624 Analyze_Aspect_Specifications
(N
, Act_Decl_Id
);
4628 when Instantiation_Error
=>
4629 if Parent_Installed
then
4633 if Env_Installed
then
4637 Style_Check
:= Save_Style_Check
;
4638 end Analyze_Subprogram_Instantiation
;
4640 -------------------------
4641 -- Get_Associated_Node --
4642 -------------------------
4644 function Get_Associated_Node
(N
: Node_Id
) return Node_Id
is
4648 Assoc
:= Associated_Node
(N
);
4650 if Nkind
(Assoc
) /= Nkind
(N
) then
4653 elsif Nkind_In
(Assoc
, N_Aggregate
, N_Extension_Aggregate
) then
4657 -- If the node is part of an inner generic, it may itself have been
4658 -- remapped into a further generic copy. Associated_Node is otherwise
4659 -- used for the entity of the node, and will be of a different node
4660 -- kind, or else N has been rewritten as a literal or function call.
4662 while Present
(Associated_Node
(Assoc
))
4663 and then Nkind
(Associated_Node
(Assoc
)) = Nkind
(Assoc
)
4665 Assoc
:= Associated_Node
(Assoc
);
4668 -- Follow and additional link in case the final node was rewritten.
4669 -- This can only happen with nested generic units.
4671 if (Nkind
(Assoc
) = N_Identifier
or else Nkind
(Assoc
) in N_Op
)
4672 and then Present
(Associated_Node
(Assoc
))
4673 and then (Nkind_In
(Associated_Node
(Assoc
), N_Function_Call
,
4674 N_Explicit_Dereference
,
4679 Assoc
:= Associated_Node
(Assoc
);
4684 end Get_Associated_Node
;
4686 -------------------------------------------
4687 -- Build_Instance_Compilation_Unit_Nodes --
4688 -------------------------------------------
4690 procedure Build_Instance_Compilation_Unit_Nodes
4695 Decl_Cunit
: Node_Id
;
4696 Body_Cunit
: Node_Id
;
4698 New_Main
: constant Entity_Id
:= Defining_Entity
(Act_Decl
);
4699 Old_Main
: constant Entity_Id
:= Cunit_Entity
(Main_Unit
);
4702 -- A new compilation unit node is built for the instance declaration
4705 Make_Compilation_Unit
(Sloc
(N
),
4706 Context_Items
=> Empty_List
,
4709 Make_Compilation_Unit_Aux
(Sloc
(N
)));
4711 Set_Parent_Spec
(Act_Decl
, Parent_Spec
(N
));
4713 -- The new compilation unit is linked to its body, but both share the
4714 -- same file, so we do not set Body_Required on the new unit so as not
4715 -- to create a spurious dependency on a non-existent body in the ali.
4716 -- This simplifies CodePeer unit traversal.
4718 -- We use the original instantiation compilation unit as the resulting
4719 -- compilation unit of the instance, since this is the main unit.
4721 Rewrite
(N
, Act_Body
);
4722 Body_Cunit
:= Parent
(N
);
4724 -- The two compilation unit nodes are linked by the Library_Unit field
4726 Set_Library_Unit
(Decl_Cunit
, Body_Cunit
);
4727 Set_Library_Unit
(Body_Cunit
, Decl_Cunit
);
4729 -- Preserve the private nature of the package if needed
4731 Set_Private_Present
(Decl_Cunit
, Private_Present
(Body_Cunit
));
4733 -- If the instance is not the main unit, its context, categorization
4734 -- and elaboration entity are not relevant to the compilation.
4736 if Body_Cunit
/= Cunit
(Main_Unit
) then
4737 Make_Instance_Unit
(Body_Cunit
, In_Main
=> False);
4741 -- The context clause items on the instantiation, which are now attached
4742 -- to the body compilation unit (since the body overwrote the original
4743 -- instantiation node), semantically belong on the spec, so copy them
4744 -- there. It's harmless to leave them on the body as well. In fact one
4745 -- could argue that they belong in both places.
4747 Citem
:= First
(Context_Items
(Body_Cunit
));
4748 while Present
(Citem
) loop
4749 Append
(New_Copy
(Citem
), Context_Items
(Decl_Cunit
));
4753 -- Propagate categorization flags on packages, so that they appear in
4754 -- the ali file for the spec of the unit.
4756 if Ekind
(New_Main
) = E_Package
then
4757 Set_Is_Pure
(Old_Main
, Is_Pure
(New_Main
));
4758 Set_Is_Preelaborated
(Old_Main
, Is_Preelaborated
(New_Main
));
4759 Set_Is_Remote_Types
(Old_Main
, Is_Remote_Types
(New_Main
));
4760 Set_Is_Shared_Passive
(Old_Main
, Is_Shared_Passive
(New_Main
));
4761 Set_Is_Remote_Call_Interface
4762 (Old_Main
, Is_Remote_Call_Interface
(New_Main
));
4765 -- Make entry in Units table, so that binder can generate call to
4766 -- elaboration procedure for body, if any.
4768 Make_Instance_Unit
(Body_Cunit
, In_Main
=> True);
4769 Main_Unit_Entity
:= New_Main
;
4770 Set_Cunit_Entity
(Main_Unit
, Main_Unit_Entity
);
4772 -- Build elaboration entity, since the instance may certainly generate
4773 -- elaboration code requiring a flag for protection.
4775 Build_Elaboration_Entity
(Decl_Cunit
, New_Main
);
4776 end Build_Instance_Compilation_Unit_Nodes
;
4778 -----------------------------
4779 -- Check_Access_Definition --
4780 -----------------------------
4782 procedure Check_Access_Definition
(N
: Node_Id
) is
4785 (Ada_Version
>= Ada_2005
4786 and then Present
(Access_Definition
(N
)));
4788 end Check_Access_Definition
;
4790 -----------------------------------
4791 -- Check_Formal_Package_Instance --
4792 -----------------------------------
4794 -- If the formal has specific parameters, they must match those of the
4795 -- actual. Both of them are instances, and the renaming declarations for
4796 -- their formal parameters appear in the same order in both. The analyzed
4797 -- formal has been analyzed in the context of the current instance.
4799 procedure Check_Formal_Package_Instance
4800 (Formal_Pack
: Entity_Id
;
4801 Actual_Pack
: Entity_Id
)
4803 E1
: Entity_Id
:= First_Entity
(Actual_Pack
);
4804 E2
: Entity_Id
:= First_Entity
(Formal_Pack
);
4809 procedure Check_Mismatch
(B
: Boolean);
4810 -- Common error routine for mismatch between the parameters of the
4811 -- actual instance and those of the formal package.
4813 function Same_Instantiated_Constant
(E1
, E2
: Entity_Id
) return Boolean;
4814 -- The formal may come from a nested formal package, and the actual may
4815 -- have been constant-folded. To determine whether the two denote the
4816 -- same entity we may have to traverse several definitions to recover
4817 -- the ultimate entity that they refer to.
4819 function Same_Instantiated_Variable
(E1
, E2
: Entity_Id
) return Boolean;
4820 -- Similarly, if the formal comes from a nested formal package, the
4821 -- actual may designate the formal through multiple renamings, which
4822 -- have to be followed to determine the original variable in question.
4824 --------------------
4825 -- Check_Mismatch --
4826 --------------------
4828 procedure Check_Mismatch
(B
: Boolean) is
4829 Kind
: constant Node_Kind
:= Nkind
(Parent
(E2
));
4832 if Kind
= N_Formal_Type_Declaration
then
4835 elsif Nkind_In
(Kind
, N_Formal_Object_Declaration
,
4836 N_Formal_Package_Declaration
)
4837 or else Kind
in N_Formal_Subprogram_Declaration
4843 ("actual for & in actual instance does not match formal",
4844 Parent
(Actual_Pack
), E1
);
4848 --------------------------------
4849 -- Same_Instantiated_Constant --
4850 --------------------------------
4852 function Same_Instantiated_Constant
4853 (E1
, E2
: Entity_Id
) return Boolean
4859 while Present
(Ent
) loop
4863 elsif Ekind
(Ent
) /= E_Constant
then
4866 elsif Is_Entity_Name
(Constant_Value
(Ent
)) then
4867 if Entity
(Constant_Value
(Ent
)) = E1
then
4870 Ent
:= Entity
(Constant_Value
(Ent
));
4873 -- The actual may be a constant that has been folded. Recover
4876 elsif Is_Entity_Name
(Original_Node
(Constant_Value
(Ent
))) then
4877 Ent
:= Entity
(Original_Node
(Constant_Value
(Ent
)));
4884 end Same_Instantiated_Constant
;
4886 --------------------------------
4887 -- Same_Instantiated_Variable --
4888 --------------------------------
4890 function Same_Instantiated_Variable
4891 (E1
, E2
: Entity_Id
) return Boolean
4893 function Original_Entity
(E
: Entity_Id
) return Entity_Id
;
4894 -- Follow chain of renamings to the ultimate ancestor
4896 ---------------------
4897 -- Original_Entity --
4898 ---------------------
4900 function Original_Entity
(E
: Entity_Id
) return Entity_Id
is
4905 while Nkind
(Parent
(Orig
)) = N_Object_Renaming_Declaration
4906 and then Present
(Renamed_Object
(Orig
))
4907 and then Is_Entity_Name
(Renamed_Object
(Orig
))
4909 Orig
:= Entity
(Renamed_Object
(Orig
));
4913 end Original_Entity
;
4915 -- Start of processing for Same_Instantiated_Variable
4918 return Ekind
(E1
) = Ekind
(E2
)
4919 and then Original_Entity
(E1
) = Original_Entity
(E2
);
4920 end Same_Instantiated_Variable
;
4922 -- Start of processing for Check_Formal_Package_Instance
4926 and then Present
(E2
)
4928 exit when Ekind
(E1
) = E_Package
4929 and then Renamed_Entity
(E1
) = Renamed_Entity
(Actual_Pack
);
4931 -- If the formal is the renaming of the formal package, this
4932 -- is the end of its formal part, which may occur before the
4933 -- end of the formal part in the actual in the presence of
4934 -- defaulted parameters in the formal package.
4936 exit when Nkind
(Parent
(E2
)) = N_Package_Renaming_Declaration
4937 and then Renamed_Entity
(E2
) = Scope
(E2
);
4939 -- The analysis of the actual may generate additional internal
4940 -- entities. If the formal is defaulted, there is no corresponding
4941 -- analysis and the internal entities must be skipped, until we
4942 -- find corresponding entities again.
4944 if Comes_From_Source
(E2
)
4945 and then not Comes_From_Source
(E1
)
4946 and then Chars
(E1
) /= Chars
(E2
)
4949 and then Chars
(E1
) /= Chars
(E2
)
4958 -- If the formal entity comes from a formal declaration, it was
4959 -- defaulted in the formal package, and no check is needed on it.
4961 elsif Nkind
(Parent
(E2
)) = N_Formal_Object_Declaration
then
4964 elsif Is_Type
(E1
) then
4966 -- Subtypes must statically match. E1, E2 are the local entities
4967 -- that are subtypes of the actuals. Itypes generated for other
4968 -- parameters need not be checked, the check will be performed
4969 -- on the parameters themselves.
4971 -- If E2 is a formal type declaration, it is a defaulted parameter
4972 -- and needs no checking.
4974 if not Is_Itype
(E1
)
4975 and then not Is_Itype
(E2
)
4979 or else Etype
(E1
) /= Etype
(E2
)
4980 or else not Subtypes_Statically_Match
(E1
, E2
));
4983 elsif Ekind
(E1
) = E_Constant
then
4985 -- IN parameters must denote the same static value, or the same
4986 -- constant, or the literal null.
4988 Expr1
:= Expression
(Parent
(E1
));
4990 if Ekind
(E2
) /= E_Constant
then
4991 Check_Mismatch
(True);
4994 Expr2
:= Expression
(Parent
(E2
));
4997 if Is_Static_Expression
(Expr1
) then
4999 if not Is_Static_Expression
(Expr2
) then
5000 Check_Mismatch
(True);
5002 elsif Is_Discrete_Type
(Etype
(E1
)) then
5004 V1
: constant Uint
:= Expr_Value
(Expr1
);
5005 V2
: constant Uint
:= Expr_Value
(Expr2
);
5007 Check_Mismatch
(V1
/= V2
);
5010 elsif Is_Real_Type
(Etype
(E1
)) then
5012 V1
: constant Ureal
:= Expr_Value_R
(Expr1
);
5013 V2
: constant Ureal
:= Expr_Value_R
(Expr2
);
5015 Check_Mismatch
(V1
/= V2
);
5018 elsif Is_String_Type
(Etype
(E1
))
5019 and then Nkind
(Expr1
) = N_String_Literal
5021 if Nkind
(Expr2
) /= N_String_Literal
then
5022 Check_Mismatch
(True);
5025 (not String_Equal
(Strval
(Expr1
), Strval
(Expr2
)));
5029 elsif Is_Entity_Name
(Expr1
) then
5030 if Is_Entity_Name
(Expr2
) then
5031 if Entity
(Expr1
) = Entity
(Expr2
) then
5035 (not Same_Instantiated_Constant
5036 (Entity
(Expr1
), Entity
(Expr2
)));
5039 Check_Mismatch
(True);
5042 elsif Is_Entity_Name
(Original_Node
(Expr1
))
5043 and then Is_Entity_Name
(Expr2
)
5045 Same_Instantiated_Constant
5046 (Entity
(Original_Node
(Expr1
)), Entity
(Expr2
))
5050 elsif Nkind
(Expr1
) = N_Null
then
5051 Check_Mismatch
(Nkind
(Expr1
) /= N_Null
);
5054 Check_Mismatch
(True);
5057 elsif Ekind
(E1
) = E_Variable
then
5058 Check_Mismatch
(not Same_Instantiated_Variable
(E1
, E2
));
5060 elsif Ekind
(E1
) = E_Package
then
5062 (Ekind
(E1
) /= Ekind
(E2
)
5063 or else Renamed_Object
(E1
) /= Renamed_Object
(E2
));
5065 elsif Is_Overloadable
(E1
) then
5067 -- Verify that the actual subprograms match. Note that actuals
5068 -- that are attributes are rewritten as subprograms. If the
5069 -- subprogram in the formal package is defaulted, no check is
5070 -- needed. Note that this can only happen in Ada 2005 when the
5071 -- formal package can be partially parameterized.
5073 if Nkind
(Unit_Declaration_Node
(E1
)) =
5074 N_Subprogram_Renaming_Declaration
5075 and then From_Default
(Unit_Declaration_Node
(E1
))
5081 (Ekind
(E2
) /= Ekind
(E1
) or else (Alias
(E1
)) /= Alias
(E2
));
5085 raise Program_Error
;
5092 end Check_Formal_Package_Instance
;
5094 ---------------------------
5095 -- Check_Formal_Packages --
5096 ---------------------------
5098 procedure Check_Formal_Packages
(P_Id
: Entity_Id
) is
5100 Formal_P
: Entity_Id
;
5103 -- Iterate through the declarations in the instance, looking for package
5104 -- renaming declarations that denote instances of formal packages. Stop
5105 -- when we find the renaming of the current package itself. The
5106 -- declaration for a formal package without a box is followed by an
5107 -- internal entity that repeats the instantiation.
5109 E
:= First_Entity
(P_Id
);
5110 while Present
(E
) loop
5111 if Ekind
(E
) = E_Package
then
5112 if Renamed_Object
(E
) = P_Id
then
5115 elsif Nkind
(Parent
(E
)) /= N_Package_Renaming_Declaration
then
5118 elsif not Box_Present
(Parent
(Associated_Formal_Package
(E
))) then
5119 Formal_P
:= Next_Entity
(E
);
5120 Check_Formal_Package_Instance
(Formal_P
, E
);
5122 -- After checking, remove the internal validating package. It
5123 -- is only needed for semantic checks, and as it may contain
5124 -- generic formal declarations it should not reach gigi.
5126 Remove
(Unit_Declaration_Node
(Formal_P
));
5132 end Check_Formal_Packages
;
5134 ---------------------------------
5135 -- Check_Forward_Instantiation --
5136 ---------------------------------
5138 procedure Check_Forward_Instantiation
(Decl
: Node_Id
) is
5140 Gen_Comp
: Entity_Id
:= Cunit_Entity
(Get_Source_Unit
(Decl
));
5143 -- The instantiation appears before the generic body if we are in the
5144 -- scope of the unit containing the generic, either in its spec or in
5145 -- the package body, and before the generic body.
5147 if Ekind
(Gen_Comp
) = E_Package_Body
then
5148 Gen_Comp
:= Spec_Entity
(Gen_Comp
);
5151 if In_Open_Scopes
(Gen_Comp
)
5152 and then No
(Corresponding_Body
(Decl
))
5157 and then not Is_Compilation_Unit
(S
)
5158 and then not Is_Child_Unit
(S
)
5160 if Ekind
(S
) = E_Package
then
5161 Set_Has_Forward_Instantiation
(S
);
5167 end Check_Forward_Instantiation
;
5169 ---------------------------
5170 -- Check_Generic_Actuals --
5171 ---------------------------
5173 -- The visibility of the actuals may be different between the point of
5174 -- generic instantiation and the instantiation of the body.
5176 procedure Check_Generic_Actuals
5177 (Instance
: Entity_Id
;
5178 Is_Formal_Box
: Boolean)
5183 function Denotes_Previous_Actual
(Typ
: Entity_Id
) return Boolean;
5184 -- For a formal that is an array type, the component type is often a
5185 -- previous formal in the same unit. The privacy status of the component
5186 -- type will have been examined earlier in the traversal of the
5187 -- corresponding actuals, and this status should not be modified for the
5188 -- array type itself.
5190 -- To detect this case we have to rescan the list of formals, which
5191 -- is usually short enough to ignore the resulting inefficiency.
5193 -----------------------------
5194 -- Denotes_Previous_Actual --
5195 -----------------------------
5197 function Denotes_Previous_Actual
(Typ
: Entity_Id
) return Boolean is
5201 Prev
:= First_Entity
(Instance
);
5202 while Present
(Prev
) loop
5204 and then Nkind
(Parent
(Prev
)) = N_Subtype_Declaration
5205 and then Is_Entity_Name
(Subtype_Indication
(Parent
(Prev
)))
5206 and then Entity
(Subtype_Indication
(Parent
(Prev
))) = Typ
5219 end Denotes_Previous_Actual
;
5221 -- Start of processing for Check_Generic_Actuals
5224 E
:= First_Entity
(Instance
);
5225 while Present
(E
) loop
5227 and then Nkind
(Parent
(E
)) = N_Subtype_Declaration
5228 and then Scope
(Etype
(E
)) /= Instance
5229 and then Is_Entity_Name
(Subtype_Indication
(Parent
(E
)))
5231 if Is_Array_Type
(E
)
5232 and then Denotes_Previous_Actual
(Component_Type
(E
))
5236 Check_Private_View
(Subtype_Indication
(Parent
(E
)));
5239 Set_Is_Generic_Actual_Type
(E
, True);
5240 Set_Is_Hidden
(E
, False);
5241 Set_Is_Potentially_Use_Visible
(E
,
5244 -- We constructed the generic actual type as a subtype of the
5245 -- supplied type. This means that it normally would not inherit
5246 -- subtype specific attributes of the actual, which is wrong for
5247 -- the generic case.
5249 Astype
:= Ancestor_Subtype
(E
);
5253 -- This can happen when E is an itype that is the full view of
5254 -- a private type completed, e.g. with a constrained array. In
5255 -- that case, use the first subtype, which will carry size
5256 -- information. The base type itself is unconstrained and will
5259 Astype
:= First_Subtype
(E
);
5262 Set_Size_Info
(E
, (Astype
));
5263 Set_RM_Size
(E
, RM_Size
(Astype
));
5264 Set_First_Rep_Item
(E
, First_Rep_Item
(Astype
));
5266 if Is_Discrete_Or_Fixed_Point_Type
(E
) then
5267 Set_RM_Size
(E
, RM_Size
(Astype
));
5269 -- In nested instances, the base type of an access actual
5270 -- may itself be private, and need to be exchanged.
5272 elsif Is_Access_Type
(E
)
5273 and then Is_Private_Type
(Etype
(E
))
5276 (New_Occurrence_Of
(Etype
(E
), Sloc
(Instance
)));
5279 elsif Ekind
(E
) = E_Package
then
5281 -- If this is the renaming for the current instance, we're done.
5282 -- Otherwise it is a formal package. If the corresponding formal
5283 -- was declared with a box, the (instantiations of the) generic
5284 -- formal part are also visible. Otherwise, ignore the entity
5285 -- created to validate the actuals.
5287 if Renamed_Object
(E
) = Instance
then
5290 elsif Nkind
(Parent
(E
)) /= N_Package_Renaming_Declaration
then
5293 -- The visibility of a formal of an enclosing generic is already
5296 elsif Denotes_Formal_Package
(E
) then
5299 elsif Present
(Associated_Formal_Package
(E
))
5300 and then not Is_Generic_Formal
(E
)
5302 if Box_Present
(Parent
(Associated_Formal_Package
(E
))) then
5303 Check_Generic_Actuals
(Renamed_Object
(E
), True);
5306 Check_Generic_Actuals
(Renamed_Object
(E
), False);
5309 Set_Is_Hidden
(E
, False);
5312 -- If this is a subprogram instance (in a wrapper package) the
5313 -- actual is fully visible.
5315 elsif Is_Wrapper_Package
(Instance
) then
5316 Set_Is_Hidden
(E
, False);
5318 -- If the formal package is declared with a box, or if the formal
5319 -- parameter is defaulted, it is visible in the body.
5322 or else Is_Visible_Formal
(E
)
5324 Set_Is_Hidden
(E
, False);
5327 if Ekind
(E
) = E_Constant
then
5329 -- If the type of the actual is a private type declared in the
5330 -- enclosing scope of the generic unit, the body of the generic
5331 -- sees the full view of the type (because it has to appear in
5332 -- the corresponding package body). If the type is private now,
5333 -- exchange views to restore the proper visiblity in the instance.
5336 Typ
: constant Entity_Id
:= Base_Type
(Etype
(E
));
5337 -- The type of the actual
5342 Parent_Scope
: Entity_Id
;
5343 -- The enclosing scope of the generic unit
5346 if Is_Wrapper_Package
(Instance
) then
5350 (Unit_Declaration_Node
5351 (Related_Instance
(Instance
))));
5355 (Specification
(Unit_Declaration_Node
(Instance
)));
5358 Parent_Scope
:= Scope
(Gen_Id
);
5360 -- The exchange is only needed if the generic is defined
5361 -- within a package which is not a common ancestor of the
5362 -- scope of the instance, and is not already in scope.
5364 if Is_Private_Type
(Typ
)
5365 and then Scope
(Typ
) = Parent_Scope
5366 and then Scope
(Instance
) /= Parent_Scope
5367 and then Ekind
(Parent_Scope
) = E_Package
5368 and then not Is_Child_Unit
(Gen_Id
)
5372 -- If the type of the entity is a subtype, it may also
5373 -- have to be made visible, together with the base type
5374 -- of its full view, after exchange.
5376 if Is_Private_Type
(Etype
(E
)) then
5377 Switch_View
(Etype
(E
));
5378 Switch_View
(Base_Type
(Etype
(E
)));
5386 end Check_Generic_Actuals
;
5388 ------------------------------
5389 -- Check_Generic_Child_Unit --
5390 ------------------------------
5392 procedure Check_Generic_Child_Unit
5394 Parent_Installed
: in out Boolean)
5396 Loc
: constant Source_Ptr
:= Sloc
(Gen_Id
);
5397 Gen_Par
: Entity_Id
:= Empty
;
5399 Inst_Par
: Entity_Id
;
5402 function Find_Generic_Child
5404 Id
: Node_Id
) return Entity_Id
;
5405 -- Search generic parent for possible child unit with the given name
5407 function In_Enclosing_Instance
return Boolean;
5408 -- Within an instance of the parent, the child unit may be denoted
5409 -- by a simple name, or an abbreviated expanded name. Examine enclosing
5410 -- scopes to locate a possible parent instantiation.
5412 ------------------------
5413 -- Find_Generic_Child --
5414 ------------------------
5416 function Find_Generic_Child
5418 Id
: Node_Id
) return Entity_Id
5423 -- If entity of name is already set, instance has already been
5424 -- resolved, e.g. in an enclosing instantiation.
5426 if Present
(Entity
(Id
)) then
5427 if Scope
(Entity
(Id
)) = Scop
then
5434 E
:= First_Entity
(Scop
);
5435 while Present
(E
) loop
5436 if Chars
(E
) = Chars
(Id
)
5437 and then Is_Child_Unit
(E
)
5439 if Is_Child_Unit
(E
)
5440 and then not Is_Visible_Child_Unit
(E
)
5443 ("generic child unit& is not visible", Gen_Id
, E
);
5455 end Find_Generic_Child
;
5457 ---------------------------
5458 -- In_Enclosing_Instance --
5459 ---------------------------
5461 function In_Enclosing_Instance
return Boolean is
5462 Enclosing_Instance
: Node_Id
;
5463 Instance_Decl
: Node_Id
;
5466 -- We do not inline any call that contains instantiations, except
5467 -- for instantiations of Unchecked_Conversion, so if we are within
5468 -- an inlined body the current instance does not require parents.
5470 if In_Inlined_Body
then
5471 pragma Assert
(Chars
(Gen_Id
) = Name_Unchecked_Conversion
);
5475 -- Loop to check enclosing scopes
5477 Enclosing_Instance
:= Current_Scope
;
5478 while Present
(Enclosing_Instance
) loop
5479 Instance_Decl
:= Unit_Declaration_Node
(Enclosing_Instance
);
5481 if Ekind
(Enclosing_Instance
) = E_Package
5482 and then Is_Generic_Instance
(Enclosing_Instance
)
5484 (Generic_Parent
(Specification
(Instance_Decl
)))
5486 -- Check whether the generic we are looking for is a child of
5489 E
:= Find_Generic_Child
5490 (Generic_Parent
(Specification
(Instance_Decl
)), Gen_Id
);
5491 exit when Present
(E
);
5497 Enclosing_Instance
:= Scope
(Enclosing_Instance
);
5509 Make_Expanded_Name
(Loc
,
5511 Prefix
=> New_Occurrence_Of
(Enclosing_Instance
, Loc
),
5512 Selector_Name
=> New_Occurrence_Of
(E
, Loc
)));
5514 Set_Entity
(Gen_Id
, E
);
5515 Set_Etype
(Gen_Id
, Etype
(E
));
5516 Parent_Installed
:= False; -- Already in scope.
5519 end In_Enclosing_Instance
;
5521 -- Start of processing for Check_Generic_Child_Unit
5524 -- If the name of the generic is given by a selected component, it may
5525 -- be the name of a generic child unit, and the prefix is the name of an
5526 -- instance of the parent, in which case the child unit must be visible.
5527 -- If this instance is not in scope, it must be placed there and removed
5528 -- after instantiation, because what is being instantiated is not the
5529 -- original child, but the corresponding child present in the instance
5532 -- If the child is instantiated within the parent, it can be given by
5533 -- a simple name. In this case the instance is already in scope, but
5534 -- the child generic must be recovered from the generic parent as well.
5536 if Nkind
(Gen_Id
) = N_Selected_Component
then
5537 S
:= Selector_Name
(Gen_Id
);
5538 Analyze
(Prefix
(Gen_Id
));
5539 Inst_Par
:= Entity
(Prefix
(Gen_Id
));
5541 if Ekind
(Inst_Par
) = E_Package
5542 and then Present
(Renamed_Object
(Inst_Par
))
5544 Inst_Par
:= Renamed_Object
(Inst_Par
);
5547 if Ekind
(Inst_Par
) = E_Package
then
5548 if Nkind
(Parent
(Inst_Par
)) = N_Package_Specification
then
5549 Gen_Par
:= Generic_Parent
(Parent
(Inst_Par
));
5551 elsif Nkind
(Parent
(Inst_Par
)) = N_Defining_Program_Unit_Name
5553 Nkind
(Parent
(Parent
(Inst_Par
))) = N_Package_Specification
5555 Gen_Par
:= Generic_Parent
(Parent
(Parent
(Inst_Par
)));
5558 elsif Ekind
(Inst_Par
) = E_Generic_Package
5559 and then Nkind
(Parent
(Gen_Id
)) = N_Formal_Package_Declaration
5561 -- A formal package may be a real child package, and not the
5562 -- implicit instance within a parent. In this case the child is
5563 -- not visible and has to be retrieved explicitly as well.
5565 Gen_Par
:= Inst_Par
;
5568 if Present
(Gen_Par
) then
5570 -- The prefix denotes an instantiation. The entity itself may be a
5571 -- nested generic, or a child unit.
5573 E
:= Find_Generic_Child
(Gen_Par
, S
);
5576 Change_Selected_Component_To_Expanded_Name
(Gen_Id
);
5577 Set_Entity
(Gen_Id
, E
);
5578 Set_Etype
(Gen_Id
, Etype
(E
));
5580 Set_Etype
(S
, Etype
(E
));
5582 -- Indicate that this is a reference to the parent
5584 if In_Extended_Main_Source_Unit
(Gen_Id
) then
5585 Set_Is_Instantiated
(Inst_Par
);
5588 -- A common mistake is to replicate the naming scheme of a
5589 -- hierarchy by instantiating a generic child directly, rather
5590 -- than the implicit child in a parent instance:
5592 -- generic .. package Gpar is ..
5593 -- generic .. package Gpar.Child is ..
5594 -- package Par is new Gpar ();
5597 -- package Par.Child is new Gpar.Child ();
5598 -- rather than Par.Child
5600 -- In this case the instantiation is within Par, which is an
5601 -- instance, but Gpar does not denote Par because we are not IN
5602 -- the instance of Gpar, so this is illegal. The test below
5603 -- recognizes this particular case.
5605 if Is_Child_Unit
(E
)
5606 and then not Comes_From_Source
(Entity
(Prefix
(Gen_Id
)))
5607 and then (not In_Instance
5608 or else Nkind
(Parent
(Parent
(Gen_Id
))) =
5612 ("prefix of generic child unit must be instance of parent",
5616 if not In_Open_Scopes
(Inst_Par
)
5617 and then Nkind
(Parent
(Gen_Id
)) not in
5618 N_Generic_Renaming_Declaration
5620 Install_Parent
(Inst_Par
);
5621 Parent_Installed
:= True;
5623 elsif In_Open_Scopes
(Inst_Par
) then
5625 -- If the parent is already installed, install the actuals
5626 -- for its formal packages. This is necessary when the
5627 -- child instance is a child of the parent instance:
5628 -- in this case, the parent is placed on the scope stack
5629 -- but the formal packages are not made visible.
5631 Install_Formal_Packages
(Inst_Par
);
5635 -- If the generic parent does not contain an entity that
5636 -- corresponds to the selector, the instance doesn't either.
5637 -- Analyzing the node will yield the appropriate error message.
5638 -- If the entity is not a child unit, then it is an inner
5639 -- generic in the parent.
5647 if Is_Child_Unit
(Entity
(Gen_Id
))
5649 Nkind
(Parent
(Gen_Id
)) not in N_Generic_Renaming_Declaration
5650 and then not In_Open_Scopes
(Inst_Par
)
5652 Install_Parent
(Inst_Par
);
5653 Parent_Installed
:= True;
5655 -- The generic unit may be the renaming of the implicit child
5656 -- present in an instance. In that case the parent instance is
5657 -- obtained from the name of the renamed entity.
5659 elsif Ekind
(Entity
(Gen_Id
)) = E_Generic_Package
5660 and then Present
(Renamed_Entity
(Entity
(Gen_Id
)))
5661 and then Is_Child_Unit
(Renamed_Entity
(Entity
(Gen_Id
)))
5664 Renamed_Package
: constant Node_Id
:=
5665 Name
(Parent
(Entity
(Gen_Id
)));
5667 if Nkind
(Renamed_Package
) = N_Expanded_Name
then
5668 Inst_Par
:= Entity
(Prefix
(Renamed_Package
));
5669 Install_Parent
(Inst_Par
);
5670 Parent_Installed
:= True;
5676 elsif Nkind
(Gen_Id
) = N_Expanded_Name
then
5678 -- Entity already present, analyze prefix, whose meaning may be
5679 -- an instance in the current context. If it is an instance of
5680 -- a relative within another, the proper parent may still have
5681 -- to be installed, if they are not of the same generation.
5683 Analyze
(Prefix
(Gen_Id
));
5685 -- In the unlikely case that a local declaration hides the name
5686 -- of the parent package, locate it on the homonym chain. If the
5687 -- context is an instance of the parent, the renaming entity is
5690 Inst_Par
:= Entity
(Prefix
(Gen_Id
));
5691 while Present
(Inst_Par
)
5692 and then not Is_Package_Or_Generic_Package
(Inst_Par
)
5694 Inst_Par
:= Homonym
(Inst_Par
);
5697 pragma Assert
(Present
(Inst_Par
));
5698 Set_Entity
(Prefix
(Gen_Id
), Inst_Par
);
5700 if In_Enclosing_Instance
then
5703 elsif Present
(Entity
(Gen_Id
))
5704 and then Is_Child_Unit
(Entity
(Gen_Id
))
5705 and then not In_Open_Scopes
(Inst_Par
)
5707 Install_Parent
(Inst_Par
);
5708 Parent_Installed
:= True;
5711 elsif In_Enclosing_Instance
then
5713 -- The child unit is found in some enclosing scope
5720 -- If this is the renaming of the implicit child in a parent
5721 -- instance, recover the parent name and install it.
5723 if Is_Entity_Name
(Gen_Id
) then
5724 E
:= Entity
(Gen_Id
);
5726 if Is_Generic_Unit
(E
)
5727 and then Nkind
(Parent
(E
)) in N_Generic_Renaming_Declaration
5728 and then Is_Child_Unit
(Renamed_Object
(E
))
5729 and then Is_Generic_Unit
(Scope
(Renamed_Object
(E
)))
5730 and then Nkind
(Name
(Parent
(E
))) = N_Expanded_Name
5733 New_Copy_Tree
(Name
(Parent
(E
))));
5734 Inst_Par
:= Entity
(Prefix
(Gen_Id
));
5736 if not In_Open_Scopes
(Inst_Par
) then
5737 Install_Parent
(Inst_Par
);
5738 Parent_Installed
:= True;
5741 -- If it is a child unit of a non-generic parent, it may be
5742 -- use-visible and given by a direct name. Install parent as
5745 elsif Is_Generic_Unit
(E
)
5746 and then Is_Child_Unit
(E
)
5748 Nkind
(Parent
(Gen_Id
)) not in N_Generic_Renaming_Declaration
5749 and then not Is_Generic_Unit
(Scope
(E
))
5751 if not In_Open_Scopes
(Scope
(E
)) then
5752 Install_Parent
(Scope
(E
));
5753 Parent_Installed
:= True;
5758 end Check_Generic_Child_Unit
;
5760 -----------------------------
5761 -- Check_Hidden_Child_Unit --
5762 -----------------------------
5764 procedure Check_Hidden_Child_Unit
5766 Gen_Unit
: Entity_Id
;
5767 Act_Decl_Id
: Entity_Id
)
5769 Gen_Id
: constant Node_Id
:= Name
(N
);
5772 if Is_Child_Unit
(Gen_Unit
)
5773 and then Is_Child_Unit
(Act_Decl_Id
)
5774 and then Nkind
(Gen_Id
) = N_Expanded_Name
5775 and then Entity
(Prefix
(Gen_Id
)) = Scope
(Act_Decl_Id
)
5776 and then Chars
(Gen_Unit
) = Chars
(Act_Decl_Id
)
5778 Error_Msg_Node_2
:= Scope
(Act_Decl_Id
);
5780 ("generic unit & is implicitly declared in &",
5781 Defining_Unit_Name
(N
), Gen_Unit
);
5782 Error_Msg_N
("\instance must have different name",
5783 Defining_Unit_Name
(N
));
5785 end Check_Hidden_Child_Unit
;
5787 ------------------------
5788 -- Check_Private_View --
5789 ------------------------
5791 procedure Check_Private_View
(N
: Node_Id
) is
5792 T
: constant Entity_Id
:= Etype
(N
);
5796 -- Exchange views if the type was not private in the generic but is
5797 -- private at the point of instantiation. Do not exchange views if
5798 -- the scope of the type is in scope. This can happen if both generic
5799 -- and instance are sibling units, or if type is defined in a parent.
5800 -- In this case the visibility of the type will be correct for all
5804 BT
:= Base_Type
(T
);
5806 if Is_Private_Type
(T
)
5807 and then not Has_Private_View
(N
)
5808 and then Present
(Full_View
(T
))
5809 and then not In_Open_Scopes
(Scope
(T
))
5811 -- In the generic, the full type was visible. Save the private
5812 -- entity, for subsequent exchange.
5816 elsif Has_Private_View
(N
)
5817 and then not Is_Private_Type
(T
)
5818 and then not Has_Been_Exchanged
(T
)
5819 and then Etype
(Get_Associated_Node
(N
)) /= T
5821 -- Only the private declaration was visible in the generic. If
5822 -- the type appears in a subtype declaration, the subtype in the
5823 -- instance must have a view compatible with that of its parent,
5824 -- which must be exchanged (see corresponding code in Restore_
5825 -- Private_Views). Otherwise, if the type is defined in a parent
5826 -- unit, leave full visibility within instance, which is safe.
5828 if In_Open_Scopes
(Scope
(Base_Type
(T
)))
5829 and then not Is_Private_Type
(Base_Type
(T
))
5830 and then Comes_From_Source
(Base_Type
(T
))
5834 elsif Nkind
(Parent
(N
)) = N_Subtype_Declaration
5835 or else not In_Private_Part
(Scope
(Base_Type
(T
)))
5837 Prepend_Elmt
(T
, Exchanged_Views
);
5838 Exchange_Declarations
(Etype
(Get_Associated_Node
(N
)));
5841 -- For composite types with inconsistent representation exchange
5842 -- component types accordingly.
5844 elsif Is_Access_Type
(T
)
5845 and then Is_Private_Type
(Designated_Type
(T
))
5846 and then not Has_Private_View
(N
)
5847 and then Present
(Full_View
(Designated_Type
(T
)))
5849 Switch_View
(Designated_Type
(T
));
5851 elsif Is_Array_Type
(T
) then
5852 if Is_Private_Type
(Component_Type
(T
))
5853 and then not Has_Private_View
(N
)
5854 and then Present
(Full_View
(Component_Type
(T
)))
5856 Switch_View
(Component_Type
(T
));
5859 -- The normal exchange mechanism relies on the setting of a
5860 -- flag on the reference in the generic. However, an additional
5861 -- mechanism is needed for types that are not explicitly mentioned
5862 -- in the generic, but may be needed in expanded code in the
5863 -- instance. This includes component types of arrays and
5864 -- designated types of access types. This processing must also
5865 -- include the index types of arrays which we take care of here.
5872 Indx
:= First_Index
(T
);
5873 Typ
:= Base_Type
(Etype
(Indx
));
5874 while Present
(Indx
) loop
5875 if Is_Private_Type
(Typ
)
5876 and then Present
(Full_View
(Typ
))
5885 elsif Is_Private_Type
(T
)
5886 and then Present
(Full_View
(T
))
5887 and then Is_Array_Type
(Full_View
(T
))
5888 and then Is_Private_Type
(Component_Type
(Full_View
(T
)))
5892 -- Finally, a non-private subtype may have a private base type, which
5893 -- must be exchanged for consistency. This can happen when a package
5894 -- body is instantiated, when the scope stack is empty but in fact
5895 -- the subtype and the base type are declared in an enclosing scope.
5897 -- Note that in this case we introduce an inconsistency in the view
5898 -- set, because we switch the base type BT, but there could be some
5899 -- private dependent subtypes of BT which remain unswitched. Such
5900 -- subtypes might need to be switched at a later point (see specific
5901 -- provision for that case in Switch_View).
5903 elsif not Is_Private_Type
(T
)
5904 and then not Has_Private_View
(N
)
5905 and then Is_Private_Type
(BT
)
5906 and then Present
(Full_View
(BT
))
5907 and then not Is_Generic_Type
(BT
)
5908 and then not In_Open_Scopes
(BT
)
5910 Prepend_Elmt
(Full_View
(BT
), Exchanged_Views
);
5911 Exchange_Declarations
(BT
);
5914 end Check_Private_View
;
5916 -----------------------------
5917 -- Check_Hidden_Primitives --
5918 -----------------------------
5920 function Check_Hidden_Primitives
(Assoc_List
: List_Id
) return Elist_Id
is
5923 Result
: Elist_Id
:= No_Elist
;
5926 if No
(Assoc_List
) then
5930 -- Traverse the list of associations between formals and actuals
5931 -- searching for renamings of tagged types
5933 Actual
:= First
(Assoc_List
);
5934 while Present
(Actual
) loop
5935 if Nkind
(Actual
) = N_Subtype_Declaration
then
5936 Gen_T
:= Generic_Parent_Type
(Actual
);
5939 and then Is_Tagged_Type
(Gen_T
)
5941 -- Traverse the list of primitives of the actual types
5942 -- searching for hidden primitives that are visible in the
5943 -- corresponding generic formal; leave them visible and
5944 -- append them to Result to restore their decoration later.
5946 Install_Hidden_Primitives
5947 (Prims_List
=> Result
,
5949 Act_T
=> Entity
(Subtype_Indication
(Actual
)));
5957 end Check_Hidden_Primitives
;
5959 --------------------------
5960 -- Contains_Instance_Of --
5961 --------------------------
5963 function Contains_Instance_Of
5966 N
: Node_Id
) return Boolean
5974 -- Verify that there are no circular instantiations. We check whether
5975 -- the unit contains an instance of the current scope or some enclosing
5976 -- scope (in case one of the instances appears in a subunit). Longer
5977 -- circularities involving subunits might seem too pathological to
5978 -- consider, but they were not too pathological for the authors of
5979 -- DEC bc30vsq, so we loop over all enclosing scopes, and mark all
5980 -- enclosing generic scopes as containing an instance.
5983 -- Within a generic subprogram body, the scope is not generic, to
5984 -- allow for recursive subprograms. Use the declaration to determine
5985 -- whether this is a generic unit.
5987 if Ekind
(Scop
) = E_Generic_Package
5988 or else (Is_Subprogram
(Scop
)
5989 and then Nkind
(Unit_Declaration_Node
(Scop
)) =
5990 N_Generic_Subprogram_Declaration
)
5992 Elmt
:= First_Elmt
(Inner_Instances
(Inner
));
5994 while Present
(Elmt
) loop
5995 if Node
(Elmt
) = Scop
then
5996 Error_Msg_Node_2
:= Inner
;
5998 ("circular Instantiation: & instantiated within &!",
6002 elsif Node
(Elmt
) = Inner
then
6005 elsif Contains_Instance_Of
(Node
(Elmt
), Scop
, N
) then
6006 Error_Msg_Node_2
:= Inner
;
6008 ("circular Instantiation: & instantiated within &!",
6016 -- Indicate that Inner is being instantiated within Scop
6018 Append_Elmt
(Inner
, Inner_Instances
(Scop
));
6021 if Scop
= Standard_Standard
then
6024 Scop
:= Scope
(Scop
);
6029 end Contains_Instance_Of
;
6031 -----------------------
6032 -- Copy_Generic_Node --
6033 -----------------------
6035 function Copy_Generic_Node
6037 Parent_Id
: Node_Id
;
6038 Instantiating
: Boolean) return Node_Id
6043 function Copy_Generic_Descendant
(D
: Union_Id
) return Union_Id
;
6044 -- Check the given value of one of the Fields referenced by the
6045 -- current node to determine whether to copy it recursively. The
6046 -- field may hold a Node_Id, a List_Id, or an Elist_Id, or a plain
6047 -- value (Sloc, Uint, Char) in which case it need not be copied.
6049 procedure Copy_Descendants
;
6050 -- Common utility for various nodes
6052 function Copy_Generic_Elist
(E
: Elist_Id
) return Elist_Id
;
6053 -- Make copy of element list
6055 function Copy_Generic_List
6057 Parent_Id
: Node_Id
) return List_Id
;
6058 -- Apply Copy_Node recursively to the members of a node list
6060 function In_Defining_Unit_Name
(Nam
: Node_Id
) return Boolean;
6061 -- True if an identifier is part of the defining program unit name
6062 -- of a child unit. The entity of such an identifier must be kept
6063 -- (for ASIS use) even though as the name of an enclosing generic
6064 -- it would otherwise not be preserved in the generic tree.
6066 ----------------------
6067 -- Copy_Descendants --
6068 ----------------------
6070 procedure Copy_Descendants
is
6072 use Atree
.Unchecked_Access
;
6073 -- This code section is part of the implementation of an untyped
6074 -- tree traversal, so it needs direct access to node fields.
6077 Set_Field1
(New_N
, Copy_Generic_Descendant
(Field1
(N
)));
6078 Set_Field2
(New_N
, Copy_Generic_Descendant
(Field2
(N
)));
6079 Set_Field3
(New_N
, Copy_Generic_Descendant
(Field3
(N
)));
6080 Set_Field4
(New_N
, Copy_Generic_Descendant
(Field4
(N
)));
6081 Set_Field5
(New_N
, Copy_Generic_Descendant
(Field5
(N
)));
6082 end Copy_Descendants
;
6084 -----------------------------
6085 -- Copy_Generic_Descendant --
6086 -----------------------------
6088 function Copy_Generic_Descendant
(D
: Union_Id
) return Union_Id
is
6090 if D
= Union_Id
(Empty
) then
6093 elsif D
in Node_Range
then
6095 (Copy_Generic_Node
(Node_Id
(D
), New_N
, Instantiating
));
6097 elsif D
in List_Range
then
6098 return Union_Id
(Copy_Generic_List
(List_Id
(D
), New_N
));
6100 elsif D
in Elist_Range
then
6101 return Union_Id
(Copy_Generic_Elist
(Elist_Id
(D
)));
6103 -- Nothing else is copyable (e.g. Uint values), return as is
6108 end Copy_Generic_Descendant
;
6110 ------------------------
6111 -- Copy_Generic_Elist --
6112 ------------------------
6114 function Copy_Generic_Elist
(E
: Elist_Id
) return Elist_Id
is
6121 M
:= First_Elmt
(E
);
6122 while Present
(M
) loop
6124 (Copy_Generic_Node
(Node
(M
), Empty
, Instantiating
), L
);
6133 end Copy_Generic_Elist
;
6135 -----------------------
6136 -- Copy_Generic_List --
6137 -----------------------
6139 function Copy_Generic_List
6141 Parent_Id
: Node_Id
) return List_Id
6149 Set_Parent
(New_L
, Parent_Id
);
6152 while Present
(N
) loop
6153 Append
(Copy_Generic_Node
(N
, Empty
, Instantiating
), New_L
);
6162 end Copy_Generic_List
;
6164 ---------------------------
6165 -- In_Defining_Unit_Name --
6166 ---------------------------
6168 function In_Defining_Unit_Name
(Nam
: Node_Id
) return Boolean is
6170 return Present
(Parent
(Nam
))
6171 and then (Nkind
(Parent
(Nam
)) = N_Defining_Program_Unit_Name
6173 (Nkind
(Parent
(Nam
)) = N_Expanded_Name
6174 and then In_Defining_Unit_Name
(Parent
(Nam
))));
6175 end In_Defining_Unit_Name
;
6177 -- Start of processing for Copy_Generic_Node
6184 New_N
:= New_Copy
(N
);
6186 -- Copy aspects if present
6188 if Has_Aspects
(N
) then
6189 Set_Has_Aspects
(New_N
, False);
6190 Set_Aspect_Specifications
6191 (New_N
, Copy_Generic_List
(Aspect_Specifications
(N
), Parent_Id
));
6194 if Instantiating
then
6195 Adjust_Instantiation_Sloc
(New_N
, S_Adjustment
);
6198 if not Is_List_Member
(N
) then
6199 Set_Parent
(New_N
, Parent_Id
);
6202 -- If defining identifier, then all fields have been copied already
6204 if Nkind
(New_N
) in N_Entity
then
6207 -- Special casing for identifiers and other entity names and operators
6209 elsif Nkind_In
(New_N
, N_Identifier
,
6210 N_Character_Literal
,
6213 or else Nkind
(New_N
) in N_Op
6215 if not Instantiating
then
6217 -- Link both nodes in order to assign subsequently the entity of
6218 -- the copy to the original node, in case this is a global
6221 Set_Associated_Node
(N
, New_N
);
6223 -- If we are within an instantiation, this is a nested generic
6224 -- that has already been analyzed at the point of definition. We
6225 -- must preserve references that were global to the enclosing
6226 -- parent at that point. Other occurrences, whether global or
6227 -- local to the current generic, must be resolved anew, so we
6228 -- reset the entity in the generic copy. A global reference has a
6229 -- smaller depth than the parent, or else the same depth in case
6230 -- both are distinct compilation units.
6231 -- A child unit is implicitly declared within the enclosing parent
6232 -- but is in fact global to it, and must be preserved.
6234 -- It is also possible for Current_Instantiated_Parent to be
6235 -- defined, and for this not to be a nested generic, namely if the
6236 -- unit is loaded through Rtsfind. In that case, the entity of
6237 -- New_N is only a link to the associated node, and not a defining
6240 -- The entities for parent units in the defining_program_unit of a
6241 -- generic child unit are established when the context of the unit
6242 -- is first analyzed, before the generic copy is made. They are
6243 -- preserved in the copy for use in ASIS queries.
6245 Ent
:= Entity
(New_N
);
6247 if No
(Current_Instantiated_Parent
.Gen_Id
) then
6249 or else Nkind
(Ent
) /= N_Defining_Identifier
6250 or else not In_Defining_Unit_Name
(N
)
6252 Set_Associated_Node
(New_N
, Empty
);
6257 not Nkind_In
(Ent
, N_Defining_Identifier
,
6258 N_Defining_Character_Literal
,
6259 N_Defining_Operator_Symbol
)
6260 or else No
(Scope
(Ent
))
6262 (Scope
(Ent
) = Current_Instantiated_Parent
.Gen_Id
6263 and then not Is_Child_Unit
(Ent
))
6265 (Scope_Depth
(Scope
(Ent
)) >
6266 Scope_Depth
(Current_Instantiated_Parent
.Gen_Id
)
6268 Get_Source_Unit
(Ent
) =
6269 Get_Source_Unit
(Current_Instantiated_Parent
.Gen_Id
))
6271 Set_Associated_Node
(New_N
, Empty
);
6274 -- Case of instantiating identifier or some other name or operator
6277 -- If the associated node is still defined, the entity in it is
6278 -- global, and must be copied to the instance. If this copy is
6279 -- being made for a body to inline, it is applied to an
6280 -- instantiated tree, and the entity is already present and must
6281 -- be also preserved.
6284 Assoc
: constant Node_Id
:= Get_Associated_Node
(N
);
6287 if Present
(Assoc
) then
6288 if Nkind
(Assoc
) = Nkind
(N
) then
6289 Set_Entity
(New_N
, Entity
(Assoc
));
6290 Check_Private_View
(N
);
6292 elsif Nkind
(Assoc
) = N_Function_Call
then
6293 Set_Entity
(New_N
, Entity
(Name
(Assoc
)));
6295 elsif Nkind_In
(Assoc
, N_Defining_Identifier
,
6296 N_Defining_Character_Literal
,
6297 N_Defining_Operator_Symbol
)
6298 and then Expander_Active
6300 -- Inlining case: we are copying a tree that contains
6301 -- global entities, which are preserved in the copy to be
6302 -- used for subsequent inlining.
6307 Set_Entity
(New_N
, Empty
);
6313 -- For expanded name, we must copy the Prefix and Selector_Name
6315 if Nkind
(N
) = N_Expanded_Name
then
6317 (New_N
, Copy_Generic_Node
(Prefix
(N
), New_N
, Instantiating
));
6319 Set_Selector_Name
(New_N
,
6320 Copy_Generic_Node
(Selector_Name
(N
), New_N
, Instantiating
));
6322 -- For operators, we must copy the right operand
6324 elsif Nkind
(N
) in N_Op
then
6325 Set_Right_Opnd
(New_N
,
6326 Copy_Generic_Node
(Right_Opnd
(N
), New_N
, Instantiating
));
6328 -- And for binary operators, the left operand as well
6330 if Nkind
(N
) in N_Binary_Op
then
6331 Set_Left_Opnd
(New_N
,
6332 Copy_Generic_Node
(Left_Opnd
(N
), New_N
, Instantiating
));
6336 -- Special casing for stubs
6338 elsif Nkind
(N
) in N_Body_Stub
then
6340 -- In any case, we must copy the specification or defining
6341 -- identifier as appropriate.
6343 if Nkind
(N
) = N_Subprogram_Body_Stub
then
6344 Set_Specification
(New_N
,
6345 Copy_Generic_Node
(Specification
(N
), New_N
, Instantiating
));
6348 Set_Defining_Identifier
(New_N
,
6350 (Defining_Identifier
(N
), New_N
, Instantiating
));
6353 -- If we are not instantiating, then this is where we load and
6354 -- analyze subunits, i.e. at the point where the stub occurs. A
6355 -- more permissive system might defer this analysis to the point
6356 -- of instantiation, but this seems to complicated for now.
6358 if not Instantiating
then
6360 Subunit_Name
: constant Unit_Name_Type
:= Get_Unit_Name
(N
);
6362 Unum
: Unit_Number_Type
;
6366 -- Make sure that, if it is a subunit of the main unit that is
6367 -- preprocessed and if -gnateG is specified, the preprocessed
6368 -- file will be written.
6370 Lib
.Analysing_Subunit_Of_Main
:=
6371 Lib
.In_Extended_Main_Source_Unit
(N
);
6374 (Load_Name
=> Subunit_Name
,
6378 Lib
.Analysing_Subunit_Of_Main
:= False;
6380 -- If the proper body is not found, a warning message will be
6381 -- emitted when analyzing the stub, or later at the point
6382 -- of instantiation. Here we just leave the stub as is.
6384 if Unum
= No_Unit
then
6385 Subunits_Missing
:= True;
6386 goto Subunit_Not_Found
;
6389 Subunit
:= Cunit
(Unum
);
6391 if Nkind
(Unit
(Subunit
)) /= N_Subunit
then
6393 ("found child unit instead of expected SEPARATE subunit",
6395 Error_Msg_Sloc
:= Sloc
(N
);
6396 Error_Msg_N
("\to complete stub #", Subunit
);
6397 goto Subunit_Not_Found
;
6400 -- We must create a generic copy of the subunit, in order to
6401 -- perform semantic analysis on it, and we must replace the
6402 -- stub in the original generic unit with the subunit, in order
6403 -- to preserve non-local references within.
6405 -- Only the proper body needs to be copied. Library_Unit and
6406 -- context clause are simply inherited by the generic copy.
6407 -- Note that the copy (which may be recursive if there are
6408 -- nested subunits) must be done first, before attaching it to
6409 -- the enclosing generic.
6413 (Proper_Body
(Unit
(Subunit
)),
6414 Empty
, Instantiating
=> False);
6416 -- Now place the original proper body in the original generic
6417 -- unit. This is a body, not a compilation unit.
6419 Rewrite
(N
, Proper_Body
(Unit
(Subunit
)));
6420 Set_Is_Compilation_Unit
(Defining_Entity
(N
), False);
6421 Set_Was_Originally_Stub
(N
);
6423 -- Finally replace the body of the subunit with its copy, and
6424 -- make this new subunit into the library unit of the generic
6425 -- copy, which does not have stubs any longer.
6427 Set_Proper_Body
(Unit
(Subunit
), New_Body
);
6428 Set_Library_Unit
(New_N
, Subunit
);
6429 Inherit_Context
(Unit
(Subunit
), N
);
6432 -- If we are instantiating, this must be an error case, since
6433 -- otherwise we would have replaced the stub node by the proper body
6434 -- that corresponds. So just ignore it in the copy (i.e. we have
6435 -- copied it, and that is good enough).
6441 <<Subunit_Not_Found
>> null;
6443 -- If the node is a compilation unit, it is the subunit of a stub, which
6444 -- has been loaded already (see code below). In this case, the library
6445 -- unit field of N points to the parent unit (which is a compilation
6446 -- unit) and need not (and cannot!) be copied.
6448 -- When the proper body of the stub is analyzed, the library_unit link
6449 -- is used to establish the proper context (see sem_ch10).
6451 -- The other fields of a compilation unit are copied as usual
6453 elsif Nkind
(N
) = N_Compilation_Unit
then
6455 -- This code can only be executed when not instantiating, because in
6456 -- the copy made for an instantiation, the compilation unit node has
6457 -- disappeared at the point that a stub is replaced by its proper
6460 pragma Assert
(not Instantiating
);
6462 Set_Context_Items
(New_N
,
6463 Copy_Generic_List
(Context_Items
(N
), New_N
));
6466 Copy_Generic_Node
(Unit
(N
), New_N
, False));
6468 Set_First_Inlined_Subprogram
(New_N
,
6470 (First_Inlined_Subprogram
(N
), New_N
, False));
6472 Set_Aux_Decls_Node
(New_N
,
6473 Copy_Generic_Node
(Aux_Decls_Node
(N
), New_N
, False));
6475 -- For an assignment node, the assignment is known to be semantically
6476 -- legal if we are instantiating the template. This avoids incorrect
6477 -- diagnostics in generated code.
6479 elsif Nkind
(N
) = N_Assignment_Statement
then
6481 -- Copy name and expression fields in usual manner
6484 Copy_Generic_Node
(Name
(N
), New_N
, Instantiating
));
6486 Set_Expression
(New_N
,
6487 Copy_Generic_Node
(Expression
(N
), New_N
, Instantiating
));
6489 if Instantiating
then
6490 Set_Assignment_OK
(Name
(New_N
), True);
6493 elsif Nkind_In
(N
, N_Aggregate
, N_Extension_Aggregate
) then
6494 if not Instantiating
then
6495 Set_Associated_Node
(N
, New_N
);
6498 if Present
(Get_Associated_Node
(N
))
6499 and then Nkind
(Get_Associated_Node
(N
)) = Nkind
(N
)
6501 -- In the generic the aggregate has some composite type. If at
6502 -- the point of instantiation the type has a private view,
6503 -- install the full view (and that of its ancestors, if any).
6506 T
: Entity_Id
:= (Etype
(Get_Associated_Node
(New_N
)));
6511 and then Is_Private_Type
(T
)
6517 and then Is_Tagged_Type
(T
)
6518 and then Is_Derived_Type
(T
)
6520 Rt
:= Root_Type
(T
);
6525 if Is_Private_Type
(T
) then
6536 -- Do not copy the associated node, which points to the generic copy
6537 -- of the aggregate.
6540 use Atree
.Unchecked_Access
;
6541 -- This code section is part of the implementation of an untyped
6542 -- tree traversal, so it needs direct access to node fields.
6545 Set_Field1
(New_N
, Copy_Generic_Descendant
(Field1
(N
)));
6546 Set_Field2
(New_N
, Copy_Generic_Descendant
(Field2
(N
)));
6547 Set_Field3
(New_N
, Copy_Generic_Descendant
(Field3
(N
)));
6548 Set_Field5
(New_N
, Copy_Generic_Descendant
(Field5
(N
)));
6551 -- Allocators do not have an identifier denoting the access type, so we
6552 -- must locate it through the expression to check whether the views are
6555 elsif Nkind
(N
) = N_Allocator
6556 and then Nkind
(Expression
(N
)) = N_Qualified_Expression
6557 and then Is_Entity_Name
(Subtype_Mark
(Expression
(N
)))
6558 and then Instantiating
6561 T
: constant Node_Id
:=
6562 Get_Associated_Node
(Subtype_Mark
(Expression
(N
)));
6568 -- Retrieve the allocator node in the generic copy
6570 Acc_T
:= Etype
(Parent
(Parent
(T
)));
6572 and then Is_Private_Type
(Acc_T
)
6574 Switch_View
(Acc_T
);
6581 -- For a proper body, we must catch the case of a proper body that
6582 -- replaces a stub. This represents the point at which a separate
6583 -- compilation unit, and hence template file, may be referenced, so we
6584 -- must make a new source instantiation entry for the template of the
6585 -- subunit, and ensure that all nodes in the subunit are adjusted using
6586 -- this new source instantiation entry.
6588 elsif Nkind
(N
) in N_Proper_Body
then
6590 Save_Adjustment
: constant Sloc_Adjustment
:= S_Adjustment
;
6593 if Instantiating
and then Was_Originally_Stub
(N
) then
6594 Create_Instantiation_Source
6595 (Instantiation_Node
,
6596 Defining_Entity
(N
),
6601 -- Now copy the fields of the proper body, using the new
6602 -- adjustment factor if one was needed as per test above.
6606 -- Restore the original adjustment factor in case changed
6608 S_Adjustment
:= Save_Adjustment
;
6611 -- Don't copy Ident or Comment pragmas, since the comment belongs to the
6612 -- generic unit, not to the instantiating unit.
6614 elsif Nkind
(N
) = N_Pragma
and then Instantiating
then
6616 Prag_Id
: constant Pragma_Id
:= Get_Pragma_Id
(N
);
6618 if Prag_Id
= Pragma_Ident
or else Prag_Id
= Pragma_Comment
then
6619 New_N
:= Make_Null_Statement
(Sloc
(N
));
6626 elsif Nkind_In
(N
, N_Integer_Literal
, N_Real_Literal
) then
6628 -- No descendant fields need traversing
6632 elsif Nkind
(N
) = N_String_Literal
6633 and then Present
(Etype
(N
))
6634 and then Instantiating
6636 -- If the string is declared in an outer scope, the string_literal
6637 -- subtype created for it may have the wrong scope. We force the
6638 -- reanalysis of the constant to generate a new itype in the proper
6641 Set_Etype
(New_N
, Empty
);
6642 Set_Analyzed
(New_N
, False);
6644 -- For the remaining nodes, copy their descendants recursively
6649 if Instantiating
and then Nkind
(N
) = N_Subprogram_Body
then
6650 Set_Generic_Parent
(Specification
(New_N
), N
);
6652 -- Should preserve Corresponding_Spec??? (12.3(14))
6657 end Copy_Generic_Node
;
6659 ----------------------------
6660 -- Denotes_Formal_Package --
6661 ----------------------------
6663 function Denotes_Formal_Package
6665 On_Exit
: Boolean := False;
6666 Instance
: Entity_Id
:= Empty
) return Boolean
6669 Scop
: constant Entity_Id
:= Scope
(Pack
);
6672 function Is_Actual_Of_Previous_Formal
(P
: Entity_Id
) return Boolean;
6673 -- The package in question may be an actual for a previous formal
6674 -- package P of the current instance, so examine its actuals as well.
6675 -- This must be recursive over other formal packages.
6677 ----------------------------------
6678 -- Is_Actual_Of_Previous_Formal --
6679 ----------------------------------
6681 function Is_Actual_Of_Previous_Formal
(P
: Entity_Id
) return Boolean is
6685 E1
:= First_Entity
(P
);
6686 while Present
(E1
) and then E1
/= Instance
loop
6687 if Ekind
(E1
) = E_Package
6688 and then Nkind
(Parent
(E1
)) = N_Package_Renaming_Declaration
6690 if Renamed_Object
(E1
) = Pack
then
6693 elsif E1
= P
or else Renamed_Object
(E1
) = P
then
6696 elsif Is_Actual_Of_Previous_Formal
(E1
) then
6705 end Is_Actual_Of_Previous_Formal
;
6707 -- Start of processing for Denotes_Formal_Package
6713 (Instance_Envs
.Last
).Instantiated_Parent
.Act_Id
;
6715 Par
:= Current_Instantiated_Parent
.Act_Id
;
6718 if Ekind
(Scop
) = E_Generic_Package
6719 or else Nkind
(Unit_Declaration_Node
(Scop
)) =
6720 N_Generic_Subprogram_Declaration
6724 elsif Nkind
(Original_Node
(Unit_Declaration_Node
(Pack
))) =
6725 N_Formal_Package_Declaration
6733 -- Check whether this package is associated with a formal package of
6734 -- the enclosing instantiation. Iterate over the list of renamings.
6736 E
:= First_Entity
(Par
);
6737 while Present
(E
) loop
6738 if Ekind
(E
) /= E_Package
6739 or else Nkind
(Parent
(E
)) /= N_Package_Renaming_Declaration
6743 elsif Renamed_Object
(E
) = Par
then
6746 elsif Renamed_Object
(E
) = Pack
then
6749 elsif Is_Actual_Of_Previous_Formal
(E
) then
6759 end Denotes_Formal_Package
;
6765 procedure End_Generic
is
6767 -- ??? More things could be factored out in this routine. Should
6768 -- probably be done at a later stage.
6770 Inside_A_Generic
:= Generic_Flags
.Table
(Generic_Flags
.Last
);
6771 Generic_Flags
.Decrement_Last
;
6773 Expander_Mode_Restore
;
6780 function Earlier
(N1
, N2
: Node_Id
) return Boolean is
6786 procedure Find_Depth
(P
: in out Node_Id
; D
: in out Integer);
6787 -- Find distance from given node to enclosing compilation unit
6793 procedure Find_Depth
(P
: in out Node_Id
; D
: in out Integer) is
6796 and then Nkind
(P
) /= N_Compilation_Unit
6798 P
:= True_Parent
(P
);
6803 -- Start of processing for Earlier
6806 Find_Depth
(P1
, D1
);
6807 Find_Depth
(P2
, D2
);
6817 P1
:= True_Parent
(P1
);
6822 P2
:= True_Parent
(P2
);
6826 -- At this point P1 and P2 are at the same distance from the root.
6827 -- We examine their parents until we find a common declarative list,
6828 -- at which point we can establish their relative placement by
6829 -- comparing their ultimate slocs. If we reach the root, N1 and N2
6830 -- do not descend from the same declarative list (e.g. one is nested
6831 -- in the declarative part and the other is in a block in the
6832 -- statement part) and the earlier one is already frozen.
6834 while not Is_List_Member
(P1
)
6835 or else not Is_List_Member
(P2
)
6836 or else List_Containing
(P1
) /= List_Containing
(P2
)
6838 P1
:= True_Parent
(P1
);
6839 P2
:= True_Parent
(P2
);
6841 if Nkind
(Parent
(P1
)) = N_Subunit
then
6842 P1
:= Corresponding_Stub
(Parent
(P1
));
6845 if Nkind
(Parent
(P2
)) = N_Subunit
then
6846 P2
:= Corresponding_Stub
(Parent
(P2
));
6854 -- If the sloc positions are different the result is unambiguous. If
6855 -- the slocs are identical, one of them must not come from source, which
6856 -- is the case for freeze nodes, whose sloc is unrelated to the point
6857 -- point at which they are inserted in the tree. The source node is the
6858 -- earlier one in the tree.
6860 if Top_Level_Location
(Sloc
(P1
)) < Top_Level_Location
(Sloc
(P2
)) then
6864 Top_Level_Location
(Sloc
(P1
)) > Top_Level_Location
(Sloc
(P2
))
6869 return Comes_From_Source
(P1
);
6873 ----------------------
6874 -- Find_Actual_Type --
6875 ----------------------
6877 function Find_Actual_Type
6879 Gen_Type
: Entity_Id
) return Entity_Id
6881 Gen_Scope
: constant Entity_Id
:= Scope
(Gen_Type
);
6885 -- Special processing only applies to child units
6887 if not Is_Child_Unit
(Gen_Scope
) then
6888 return Get_Instance_Of
(Typ
);
6890 -- If designated or component type is itself a formal of the child unit,
6891 -- its instance is available.
6893 elsif Scope
(Typ
) = Gen_Scope
then
6894 return Get_Instance_Of
(Typ
);
6896 -- If the array or access type is not declared in the parent unit,
6897 -- no special processing needed.
6899 elsif not Is_Generic_Type
(Typ
)
6900 and then Scope
(Gen_Scope
) /= Scope
(Typ
)
6902 return Get_Instance_Of
(Typ
);
6904 -- Otherwise, retrieve designated or component type by visibility
6907 T
:= Current_Entity
(Typ
);
6908 while Present
(T
) loop
6909 if In_Open_Scopes
(Scope
(T
)) then
6912 elsif Is_Generic_Actual_Type
(T
) then
6921 end Find_Actual_Type
;
6923 ----------------------------
6924 -- Freeze_Subprogram_Body --
6925 ----------------------------
6927 procedure Freeze_Subprogram_Body
6928 (Inst_Node
: Node_Id
;
6930 Pack_Id
: Entity_Id
)
6932 Gen_Unit
: constant Entity_Id
:= Get_Generic_Entity
(Inst_Node
);
6933 Par
: constant Entity_Id
:= Scope
(Gen_Unit
);
6939 function Enclosing_Body
(N
: Node_Id
) return Node_Id
;
6940 -- Find innermost package body that encloses the given node, and which
6941 -- is not a compilation unit. Freeze nodes for the instance, or for its
6942 -- enclosing body, may be inserted after the enclosing_body of the
6945 function Package_Freeze_Node
(B
: Node_Id
) return Node_Id
;
6946 -- Find entity for given package body, and locate or create a freeze
6949 --------------------
6950 -- Enclosing_Body --
6951 --------------------
6953 function Enclosing_Body
(N
: Node_Id
) return Node_Id
is
6954 P
: Node_Id
:= Parent
(N
);
6958 and then Nkind
(Parent
(P
)) /= N_Compilation_Unit
6960 if Nkind
(P
) = N_Package_Body
then
6962 if Nkind
(Parent
(P
)) = N_Subunit
then
6963 return Corresponding_Stub
(Parent
(P
));
6969 P
:= True_Parent
(P
);
6975 -------------------------
6976 -- Package_Freeze_Node --
6977 -------------------------
6979 function Package_Freeze_Node
(B
: Node_Id
) return Node_Id
is
6983 if Nkind
(B
) = N_Package_Body
then
6984 Id
:= Corresponding_Spec
(B
);
6986 else pragma Assert
(Nkind
(B
) = N_Package_Body_Stub
);
6987 Id
:= Corresponding_Spec
(Proper_Body
(Unit
(Library_Unit
(B
))));
6990 Ensure_Freeze_Node
(Id
);
6991 return Freeze_Node
(Id
);
6992 end Package_Freeze_Node
;
6994 -- Start of processing of Freeze_Subprogram_Body
6997 -- If the instance and the generic body appear within the same unit, and
6998 -- the instance precedes the generic, the freeze node for the instance
6999 -- must appear after that of the generic. If the generic is nested
7000 -- within another instance I2, then current instance must be frozen
7001 -- after I2. In both cases, the freeze nodes are those of enclosing
7002 -- packages. Otherwise, the freeze node is placed at the end of the
7003 -- current declarative part.
7005 Enc_G
:= Enclosing_Body
(Gen_Body
);
7006 Enc_I
:= Enclosing_Body
(Inst_Node
);
7007 Ensure_Freeze_Node
(Pack_Id
);
7008 F_Node
:= Freeze_Node
(Pack_Id
);
7010 if Is_Generic_Instance
(Par
)
7011 and then Present
(Freeze_Node
(Par
))
7012 and then In_Same_Declarative_Part
(Freeze_Node
(Par
), Inst_Node
)
7014 -- The parent was a premature instantiation. Insert freeze node at
7015 -- the end the current declarative part.
7017 if ABE_Is_Certain
(Get_Package_Instantiation_Node
(Par
)) then
7018 Insert_Freeze_Node_For_Instance
(Inst_Node
, F_Node
);
7020 -- Handle the following case:
7022 -- package Parent_Inst is new ...
7025 -- procedure P ... -- this body freezes Parent_Inst
7027 -- package Inst is new ...
7029 -- In this particular scenario, the freeze node for Inst must be
7030 -- inserted in the same manner as that of Parent_Inst - before the
7031 -- next source body or at the end of the declarative list (body not
7032 -- available). If body P did not exist and Parent_Inst was frozen
7033 -- after Inst, either by a body following Inst or at the end of the
7034 -- declarative region, the freeze node for Inst must be inserted
7035 -- after that of Parent_Inst. This relation is established by
7036 -- comparing the Slocs of Parent_Inst freeze node and Inst.
7038 elsif List_Containing
(Get_Package_Instantiation_Node
(Par
)) =
7039 List_Containing
(Inst_Node
)
7040 and then Sloc
(Freeze_Node
(Par
)) < Sloc
(Inst_Node
)
7042 Insert_Freeze_Node_For_Instance
(Inst_Node
, F_Node
);
7045 Insert_After
(Freeze_Node
(Par
), F_Node
);
7048 -- The body enclosing the instance should be frozen after the body that
7049 -- includes the generic, because the body of the instance may make
7050 -- references to entities therein. If the two are not in the same
7051 -- declarative part, or if the one enclosing the instance is frozen
7052 -- already, freeze the instance at the end of the current declarative
7055 elsif Is_Generic_Instance
(Par
)
7056 and then Present
(Freeze_Node
(Par
))
7057 and then Present
(Enc_I
)
7059 if In_Same_Declarative_Part
(Freeze_Node
(Par
), Enc_I
)
7061 (Nkind
(Enc_I
) = N_Package_Body
7063 In_Same_Declarative_Part
(Freeze_Node
(Par
), Parent
(Enc_I
)))
7065 -- The enclosing package may contain several instances. Rather
7066 -- than computing the earliest point at which to insert its freeze
7067 -- node, we place it at the end of the declarative part of the
7068 -- parent of the generic.
7070 Insert_Freeze_Node_For_Instance
7071 (Freeze_Node
(Par
), Package_Freeze_Node
(Enc_I
));
7074 Insert_Freeze_Node_For_Instance
(Inst_Node
, F_Node
);
7076 elsif Present
(Enc_G
)
7077 and then Present
(Enc_I
)
7078 and then Enc_G
/= Enc_I
7079 and then Earlier
(Inst_Node
, Gen_Body
)
7081 if Nkind
(Enc_G
) = N_Package_Body
then
7082 E_G_Id
:= Corresponding_Spec
(Enc_G
);
7083 else pragma Assert
(Nkind
(Enc_G
) = N_Package_Body_Stub
);
7085 Corresponding_Spec
(Proper_Body
(Unit
(Library_Unit
(Enc_G
))));
7088 -- Freeze package that encloses instance, and place node after
7089 -- package that encloses generic. If enclosing package is already
7090 -- frozen we have to assume it is at the proper place. This may be a
7091 -- potential ABE that requires dynamic checking. Do not add a freeze
7092 -- node if the package that encloses the generic is inside the body
7093 -- that encloses the instance, because the freeze node would be in
7094 -- the wrong scope. Additional contortions needed if the bodies are
7095 -- within a subunit.
7098 Enclosing_Body
: Node_Id
;
7101 if Nkind
(Enc_I
) = N_Package_Body_Stub
then
7102 Enclosing_Body
:= Proper_Body
(Unit
(Library_Unit
(Enc_I
)));
7104 Enclosing_Body
:= Enc_I
;
7107 if Parent
(List_Containing
(Enc_G
)) /= Enclosing_Body
then
7108 Insert_Freeze_Node_For_Instance
7109 (Enc_G
, Package_Freeze_Node
(Enc_I
));
7113 -- Freeze enclosing subunit before instance
7115 Ensure_Freeze_Node
(E_G_Id
);
7117 if not Is_List_Member
(Freeze_Node
(E_G_Id
)) then
7118 Insert_After
(Enc_G
, Freeze_Node
(E_G_Id
));
7121 Insert_Freeze_Node_For_Instance
(Inst_Node
, F_Node
);
7124 -- If none of the above, insert freeze node at the end of the current
7125 -- declarative part.
7127 Insert_Freeze_Node_For_Instance
(Inst_Node
, F_Node
);
7129 end Freeze_Subprogram_Body
;
7135 function Get_Gen_Id
(E
: Assoc_Ptr
) return Entity_Id
is
7137 return Generic_Renamings
.Table
(E
).Gen_Id
;
7140 ---------------------
7141 -- Get_Instance_Of --
7142 ---------------------
7144 function Get_Instance_Of
(A
: Entity_Id
) return Entity_Id
is
7145 Res
: constant Assoc_Ptr
:= Generic_Renamings_HTable
.Get
(A
);
7148 if Res
/= Assoc_Null
then
7149 return Generic_Renamings
.Table
(Res
).Act_Id
;
7151 -- On exit, entity is not instantiated: not a generic parameter, or
7152 -- else parameter of an inner generic unit.
7156 end Get_Instance_Of
;
7158 ------------------------------------
7159 -- Get_Package_Instantiation_Node --
7160 ------------------------------------
7162 function Get_Package_Instantiation_Node
(A
: Entity_Id
) return Node_Id
is
7163 Decl
: Node_Id
:= Unit_Declaration_Node
(A
);
7167 -- If the Package_Instantiation attribute has been set on the package
7168 -- entity, then use it directly when it (or its Original_Node) refers
7169 -- to an N_Package_Instantiation node. In principle it should be
7170 -- possible to have this field set in all cases, which should be
7171 -- investigated, and would allow this function to be significantly
7174 Inst
:= Package_Instantiation
(A
);
7176 if Present
(Inst
) then
7177 if Nkind
(Inst
) = N_Package_Instantiation
then
7180 elsif Nkind
(Original_Node
(Inst
)) = N_Package_Instantiation
then
7181 return Original_Node
(Inst
);
7185 -- If the instantiation is a compilation unit that does not need body
7186 -- then the instantiation node has been rewritten as a package
7187 -- declaration for the instance, and we return the original node.
7189 -- If it is a compilation unit and the instance node has not been
7190 -- rewritten, then it is still the unit of the compilation. Finally, if
7191 -- a body is present, this is a parent of the main unit whose body has
7192 -- been compiled for inlining purposes, and the instantiation node has
7193 -- been rewritten with the instance body.
7195 -- Otherwise the instantiation node appears after the declaration. If
7196 -- the entity is a formal package, the declaration may have been
7197 -- rewritten as a generic declaration (in the case of a formal with box)
7198 -- or left as a formal package declaration if it has actuals, and is
7199 -- found with a forward search.
7201 if Nkind
(Parent
(Decl
)) = N_Compilation_Unit
then
7202 if Nkind
(Decl
) = N_Package_Declaration
7203 and then Present
(Corresponding_Body
(Decl
))
7205 Decl
:= Unit_Declaration_Node
(Corresponding_Body
(Decl
));
7208 if Nkind
(Original_Node
(Decl
)) = N_Package_Instantiation
then
7209 return Original_Node
(Decl
);
7211 return Unit
(Parent
(Decl
));
7214 elsif Nkind
(Decl
) = N_Package_Declaration
7215 and then Nkind
(Original_Node
(Decl
)) = N_Formal_Package_Declaration
7217 return Original_Node
(Decl
);
7220 Inst
:= Next
(Decl
);
7221 while not Nkind_In
(Inst
, N_Package_Instantiation
,
7222 N_Formal_Package_Declaration
)
7229 end Get_Package_Instantiation_Node
;
7231 ------------------------
7232 -- Has_Been_Exchanged --
7233 ------------------------
7235 function Has_Been_Exchanged
(E
: Entity_Id
) return Boolean is
7239 Next
:= First_Elmt
(Exchanged_Views
);
7240 while Present
(Next
) loop
7241 if Full_View
(Node
(Next
)) = E
then
7249 end Has_Been_Exchanged
;
7255 function Hash
(F
: Entity_Id
) return HTable_Range
is
7257 return HTable_Range
(F
mod HTable_Size
);
7260 ------------------------
7261 -- Hide_Current_Scope --
7262 ------------------------
7264 procedure Hide_Current_Scope
is
7265 C
: constant Entity_Id
:= Current_Scope
;
7269 Set_Is_Hidden_Open_Scope
(C
);
7271 E
:= First_Entity
(C
);
7272 while Present
(E
) loop
7273 if Is_Immediately_Visible
(E
) then
7274 Set_Is_Immediately_Visible
(E
, False);
7275 Append_Elmt
(E
, Hidden_Entities
);
7281 -- Make the scope name invisible as well. This is necessary, but might
7282 -- conflict with calls to Rtsfind later on, in case the scope is a
7283 -- predefined one. There is no clean solution to this problem, so for
7284 -- now we depend on the user not redefining Standard itself in one of
7285 -- the parent units.
7287 if Is_Immediately_Visible
(C
) and then C
/= Standard_Standard
then
7288 Set_Is_Immediately_Visible
(C
, False);
7289 Append_Elmt
(C
, Hidden_Entities
);
7292 end Hide_Current_Scope
;
7298 procedure Init_Env
is
7299 Saved
: Instance_Env
;
7302 Saved
.Instantiated_Parent
:= Current_Instantiated_Parent
;
7303 Saved
.Exchanged_Views
:= Exchanged_Views
;
7304 Saved
.Hidden_Entities
:= Hidden_Entities
;
7305 Saved
.Current_Sem_Unit
:= Current_Sem_Unit
;
7306 Saved
.Parent_Unit_Visible
:= Parent_Unit_Visible
;
7307 Saved
.Instance_Parent_Unit
:= Instance_Parent_Unit
;
7309 -- Save configuration switches. These may be reset if the unit is a
7310 -- predefined unit, and the current mode is not Ada 2005.
7312 Save_Opt_Config_Switches
(Saved
.Switches
);
7314 Instance_Envs
.Append
(Saved
);
7316 Exchanged_Views
:= New_Elmt_List
;
7317 Hidden_Entities
:= New_Elmt_List
;
7319 -- Make dummy entry for Instantiated parent. If generic unit is legal,
7320 -- this is set properly in Set_Instance_Env.
7322 Current_Instantiated_Parent
:=
7323 (Current_Scope
, Current_Scope
, Assoc_Null
);
7326 ------------------------------
7327 -- In_Same_Declarative_Part --
7328 ------------------------------
7330 function In_Same_Declarative_Part
7332 Inst
: Node_Id
) return Boolean
7334 Decls
: constant Node_Id
:= Parent
(F_Node
);
7335 Nod
: Node_Id
:= Parent
(Inst
);
7338 while Present
(Nod
) loop
7342 elsif Nkind_In
(Nod
, N_Subprogram_Body
,
7344 N_Package_Declaration
,
7351 elsif Nkind
(Nod
) = N_Subunit
then
7352 Nod
:= Corresponding_Stub
(Nod
);
7354 elsif Nkind
(Nod
) = N_Compilation_Unit
then
7358 Nod
:= Parent
(Nod
);
7363 end In_Same_Declarative_Part
;
7365 ---------------------
7366 -- In_Main_Context --
7367 ---------------------
7369 function In_Main_Context
(E
: Entity_Id
) return Boolean is
7375 if not Is_Compilation_Unit
(E
)
7376 or else Ekind
(E
) /= E_Package
7377 or else In_Private_Part
(E
)
7382 Context
:= Context_Items
(Cunit
(Main_Unit
));
7384 Clause
:= First
(Context
);
7385 while Present
(Clause
) loop
7386 if Nkind
(Clause
) = N_With_Clause
then
7387 Nam
:= Name
(Clause
);
7389 -- If the current scope is part of the context of the main unit,
7390 -- analysis of the corresponding with_clause is not complete, and
7391 -- the entity is not set. We use the Chars field directly, which
7392 -- might produce false positives in rare cases, but guarantees
7393 -- that we produce all the instance bodies we will need.
7395 if (Is_Entity_Name
(Nam
) and then Chars
(Nam
) = Chars
(E
))
7396 or else (Nkind
(Nam
) = N_Selected_Component
7397 and then Chars
(Selector_Name
(Nam
)) = Chars
(E
))
7407 end In_Main_Context
;
7409 ---------------------
7410 -- Inherit_Context --
7411 ---------------------
7413 procedure Inherit_Context
(Gen_Decl
: Node_Id
; Inst
: Node_Id
) is
7414 Current_Context
: List_Id
;
7415 Current_Unit
: Node_Id
;
7420 if Nkind
(Parent
(Gen_Decl
)) = N_Compilation_Unit
then
7422 -- The inherited context is attached to the enclosing compilation
7423 -- unit. This is either the main unit, or the declaration for the
7424 -- main unit (in case the instantiation appears within the package
7425 -- declaration and the main unit is its body).
7427 Current_Unit
:= Parent
(Inst
);
7428 while Present
(Current_Unit
)
7429 and then Nkind
(Current_Unit
) /= N_Compilation_Unit
7431 Current_Unit
:= Parent
(Current_Unit
);
7434 Current_Context
:= Context_Items
(Current_Unit
);
7436 Item
:= First
(Context_Items
(Parent
(Gen_Decl
)));
7437 while Present
(Item
) loop
7438 if Nkind
(Item
) = N_With_Clause
then
7440 -- Take care to prevent direct cyclic with's, which can happen
7441 -- if the generic body with's the current unit. Such a case
7442 -- would result in binder errors (or run-time errors if the
7443 -- -gnatE switch is in effect), but we want to prevent it here,
7444 -- because Sem.Walk_Library_Items doesn't like cycles. Note
7445 -- that we don't bother to detect indirect cycles.
7447 if Library_Unit
(Item
) /= Current_Unit
then
7448 New_I
:= New_Copy
(Item
);
7449 Set_Implicit_With
(New_I
, True);
7450 Append
(New_I
, Current_Context
);
7457 end Inherit_Context
;
7463 procedure Initialize
is
7465 Generic_Renamings
.Init
;
7468 Generic_Renamings_HTable
.Reset
;
7469 Circularity_Detected
:= False;
7470 Exchanged_Views
:= No_Elist
;
7471 Hidden_Entities
:= No_Elist
;
7474 -------------------------------------
7475 -- Insert_Freeze_Node_For_Instance --
7476 -------------------------------------
7478 procedure Insert_Freeze_Node_For_Instance
7482 Inst
: constant Entity_Id
:= Entity
(F_Node
);
7487 function Previous_Instance
(Gen
: Entity_Id
) return Entity_Id
;
7488 -- Find the local instance, if any, that declares the generic that is
7489 -- being instantiated. If present, the freeze node for this instance
7490 -- must follow the freeze node for the previous instance.
7492 -----------------------
7493 -- Previous_Instance --
7494 -----------------------
7496 function Previous_Instance
(Gen
: Entity_Id
) return Entity_Id
is
7501 and then S
/= Standard_Standard
7503 if Is_Generic_Instance
(S
)
7504 and then In_Same_Source_Unit
(S
, N
)
7511 end Previous_Instance
;
7514 if not Is_List_Member
(F_Node
) then
7515 Decls
:= List_Containing
(N
);
7516 Par_N
:= Parent
(Decls
);
7519 -- If this is a package instance, check whether the generic is
7520 -- declared in a previous instance and the current instance is
7521 -- not within the previous one.
7523 if Present
(Generic_Parent
(Parent
(Inst
)))
7524 and then Is_In_Main_Unit
(N
)
7527 Par_I
: constant Entity_Id
:=
7528 Previous_Instance
(Generic_Parent
(Parent
(Inst
)));
7533 and then Earlier
(N
, Freeze_Node
(Par_I
))
7535 Scop
:= Scope
(Inst
);
7537 -- If the current instance is within the one that contains
7538 -- the generic, the freeze node for the current one must
7539 -- appear in the current declarative part. Ditto, if the
7540 -- current instance is within another package instance. In
7541 -- both of these cases the freeze node of the previous
7542 -- instance is not relevant.
7544 while Present
(Scop
)
7545 and then Scop
/= Standard_Standard
7547 exit when Scop
= Par_I
7548 or else Is_Generic_Instance
(Scop
);
7549 Scop
:= Scope
(Scop
);
7552 -- Previous instance encloses current instance
7554 if Scop
= Par_I
then
7557 -- Current instance is within an unrelated instance
7559 elsif Is_Generic_Instance
(Scop
) then
7563 Insert_After
(Freeze_Node
(Par_I
), F_Node
);
7570 -- When the instantiation occurs in a package declaration, append the
7571 -- freeze node to the private declarations (if any).
7573 if Nkind
(Par_N
) = N_Package_Specification
7574 and then Decls
= Visible_Declarations
(Par_N
)
7575 and then Present
(Private_Declarations
(Par_N
))
7576 and then not Is_Empty_List
(Private_Declarations
(Par_N
))
7578 Decls
:= Private_Declarations
(Par_N
);
7579 Decl
:= First
(Decls
);
7582 -- Determine the proper freeze point of a package instantiation. We
7583 -- adhere to the general rule of a package or subprogram body causing
7584 -- freezing of anything before it in the same declarative region. In
7585 -- this case, the proper freeze point of a package instantiation is
7586 -- before the first source body which follows, or before a stub.
7587 -- This ensures that entities coming from the instance are already
7588 -- frozen and usable in source bodies.
7590 if Nkind
(Par_N
) /= N_Package_Declaration
7591 and then Ekind
(Inst
) = E_Package
7592 and then Is_Generic_Instance
(Inst
)
7594 not In_Same_Source_Unit
(Generic_Parent
(Parent
(Inst
)), Inst
)
7596 while Present
(Decl
) loop
7597 if (Nkind
(Decl
) in N_Unit_Body
7599 Nkind
(Decl
) in N_Body_Stub
)
7600 and then Comes_From_Source
(Decl
)
7602 Insert_Before
(Decl
, F_Node
);
7610 -- In a package declaration, or if no previous body, insert at end
7613 Set_Sloc
(F_Node
, Sloc
(Last
(Decls
)));
7614 Insert_After
(Last
(Decls
), F_Node
);
7616 end Insert_Freeze_Node_For_Instance
;
7622 procedure Install_Body
7623 (Act_Body
: Node_Id
;
7628 Act_Id
: constant Entity_Id
:= Corresponding_Spec
(Act_Body
);
7629 Act_Unit
: constant Node_Id
:= Unit
(Cunit
(Get_Source_Unit
(N
)));
7630 Gen_Id
: constant Entity_Id
:= Corresponding_Spec
(Gen_Body
);
7631 Par
: constant Entity_Id
:= Scope
(Gen_Id
);
7632 Gen_Unit
: constant Node_Id
:=
7633 Unit
(Cunit
(Get_Source_Unit
(Gen_Decl
)));
7634 Orig_Body
: Node_Id
:= Gen_Body
;
7636 Body_Unit
: Node_Id
;
7638 Must_Delay
: Boolean;
7640 function Enclosing_Subp
(Id
: Entity_Id
) return Entity_Id
;
7641 -- Find subprogram (if any) that encloses instance and/or generic body
7643 function True_Sloc
(N
: Node_Id
) return Source_Ptr
;
7644 -- If the instance is nested inside a generic unit, the Sloc of the
7645 -- instance indicates the place of the original definition, not the
7646 -- point of the current enclosing instance. Pending a better usage of
7647 -- Slocs to indicate instantiation places, we determine the place of
7648 -- origin of a node by finding the maximum sloc of any ancestor node.
7649 -- Why is this not equivalent to Top_Level_Location ???
7651 --------------------
7652 -- Enclosing_Subp --
7653 --------------------
7655 function Enclosing_Subp
(Id
: Entity_Id
) return Entity_Id
is
7656 Scop
: Entity_Id
:= Scope
(Id
);
7659 while Scop
/= Standard_Standard
7660 and then not Is_Overloadable
(Scop
)
7662 Scop
:= Scope
(Scop
);
7672 function True_Sloc
(N
: Node_Id
) return Source_Ptr
is
7679 while Present
(N1
) and then N1
/= Act_Unit
loop
7680 if Sloc
(N1
) > Res
then
7690 -- Start of processing for Install_Body
7694 -- If the body is a subunit, the freeze point is the corresponding stub
7695 -- in the current compilation, not the subunit itself.
7697 if Nkind
(Parent
(Gen_Body
)) = N_Subunit
then
7698 Orig_Body
:= Corresponding_Stub
(Parent
(Gen_Body
));
7700 Orig_Body
:= Gen_Body
;
7703 Body_Unit
:= Unit
(Cunit
(Get_Source_Unit
(Orig_Body
)));
7705 -- If the instantiation and the generic definition appear in the same
7706 -- package declaration, this is an early instantiation. If they appear
7707 -- in the same declarative part, it is an early instantiation only if
7708 -- the generic body appears textually later, and the generic body is
7709 -- also in the main unit.
7711 -- If instance is nested within a subprogram, and the generic body is
7712 -- not, the instance is delayed because the enclosing body is. If
7713 -- instance and body are within the same scope, or the same sub-
7714 -- program body, indicate explicitly that the instance is delayed.
7717 (Gen_Unit
= Act_Unit
7718 and then (Nkind_In
(Gen_Unit
, N_Package_Declaration
,
7719 N_Generic_Package_Declaration
)
7720 or else (Gen_Unit
= Body_Unit
7721 and then True_Sloc
(N
) < Sloc
(Orig_Body
)))
7722 and then Is_In_Main_Unit
(Gen_Unit
)
7723 and then (Scope
(Act_Id
) = Scope
(Gen_Id
)
7725 Enclosing_Subp
(Act_Id
) = Enclosing_Subp
(Gen_Id
)));
7727 -- If this is an early instantiation, the freeze node is placed after
7728 -- the generic body. Otherwise, if the generic appears in an instance,
7729 -- we cannot freeze the current instance until the outer one is frozen.
7730 -- This is only relevant if the current instance is nested within some
7731 -- inner scope not itself within the outer instance. If this scope is
7732 -- a package body in the same declarative part as the outer instance,
7733 -- then that body needs to be frozen after the outer instance. Finally,
7734 -- if no delay is needed, we place the freeze node at the end of the
7735 -- current declarative part.
7737 if Expander_Active
then
7738 Ensure_Freeze_Node
(Act_Id
);
7739 F_Node
:= Freeze_Node
(Act_Id
);
7742 Insert_After
(Orig_Body
, F_Node
);
7744 elsif Is_Generic_Instance
(Par
)
7745 and then Present
(Freeze_Node
(Par
))
7746 and then Scope
(Act_Id
) /= Par
7748 -- Freeze instance of inner generic after instance of enclosing
7751 if In_Same_Declarative_Part
(Freeze_Node
(Par
), N
) then
7753 -- Handle the following case:
7755 -- package Parent_Inst is new ...
7758 -- procedure P ... -- this body freezes Parent_Inst
7760 -- package Inst is new ...
7762 -- In this particular scenario, the freeze node for Inst must
7763 -- be inserted in the same manner as that of Parent_Inst -
7764 -- before the next source body or at the end of the declarative
7765 -- list (body not available). If body P did not exist and
7766 -- Parent_Inst was frozen after Inst, either by a body
7767 -- following Inst or at the end of the declarative region, the
7768 -- freeze node for Inst must be inserted after that of
7769 -- Parent_Inst. This relation is established by comparing the
7770 -- Slocs of Parent_Inst freeze node and Inst.
7772 if List_Containing
(Get_Package_Instantiation_Node
(Par
)) =
7774 and then Sloc
(Freeze_Node
(Par
)) < Sloc
(N
)
7776 Insert_Freeze_Node_For_Instance
(N
, F_Node
);
7778 Insert_After
(Freeze_Node
(Par
), F_Node
);
7781 -- Freeze package enclosing instance of inner generic after
7782 -- instance of enclosing generic.
7784 elsif Nkind
(Parent
(N
)) = N_Package_Body
7785 and then In_Same_Declarative_Part
(Freeze_Node
(Par
), Parent
(N
))
7788 Enclosing
: constant Entity_Id
:=
7789 Corresponding_Spec
(Parent
(N
));
7792 Insert_Freeze_Node_For_Instance
(N
, F_Node
);
7793 Ensure_Freeze_Node
(Enclosing
);
7795 if not Is_List_Member
(Freeze_Node
(Enclosing
)) then
7797 -- The enclosing context is a subunit, insert the freeze
7798 -- node after the stub.
7800 if Nkind
(Parent
(Parent
(N
))) = N_Subunit
then
7801 Insert_Freeze_Node_For_Instance
7802 (Corresponding_Stub
(Parent
(Parent
(N
))),
7803 Freeze_Node
(Enclosing
));
7805 -- The parent instance has been frozen before the body of
7806 -- the enclosing package, insert the freeze node after
7809 elsif List_Containing
(Freeze_Node
(Par
)) =
7810 List_Containing
(Parent
(N
))
7811 and then Sloc
(Freeze_Node
(Par
)) < Sloc
(Parent
(N
))
7813 Insert_Freeze_Node_For_Instance
7814 (Parent
(N
), Freeze_Node
(Enclosing
));
7818 (Freeze_Node
(Par
), Freeze_Node
(Enclosing
));
7824 Insert_Freeze_Node_For_Instance
(N
, F_Node
);
7828 Insert_Freeze_Node_For_Instance
(N
, F_Node
);
7832 Set_Is_Frozen
(Act_Id
);
7833 Insert_Before
(N
, Act_Body
);
7834 Mark_Rewrite_Insertion
(Act_Body
);
7837 -----------------------------
7838 -- Install_Formal_Packages --
7839 -----------------------------
7841 procedure Install_Formal_Packages
(Par
: Entity_Id
) is
7844 Gen_E
: Entity_Id
:= Empty
;
7847 E
:= First_Entity
(Par
);
7849 -- In we are installing an instance parent, locate the formal packages
7850 -- of its generic parent.
7852 if Is_Generic_Instance
(Par
) then
7853 Gen
:= Generic_Parent
(Specification
(Unit_Declaration_Node
(Par
)));
7854 Gen_E
:= First_Entity
(Gen
);
7857 while Present
(E
) loop
7858 if Ekind
(E
) = E_Package
7859 and then Nkind
(Parent
(E
)) = N_Package_Renaming_Declaration
7861 -- If this is the renaming for the parent instance, done
7863 if Renamed_Object
(E
) = Par
then
7866 -- The visibility of a formal of an enclosing generic is already
7869 elsif Denotes_Formal_Package
(E
) then
7872 elsif Present
(Associated_Formal_Package
(E
)) then
7873 Check_Generic_Actuals
(Renamed_Object
(E
), True);
7874 Set_Is_Hidden
(E
, False);
7876 -- Find formal package in generic unit that corresponds to
7877 -- (instance of) formal package in instance.
7879 while Present
(Gen_E
) and then Chars
(Gen_E
) /= Chars
(E
) loop
7880 Next_Entity
(Gen_E
);
7883 if Present
(Gen_E
) then
7884 Map_Formal_Package_Entities
(Gen_E
, E
);
7890 if Present
(Gen_E
) then
7891 Next_Entity
(Gen_E
);
7894 end Install_Formal_Packages
;
7896 --------------------
7897 -- Install_Parent --
7898 --------------------
7900 procedure Install_Parent
(P
: Entity_Id
; In_Body
: Boolean := False) is
7901 Ancestors
: constant Elist_Id
:= New_Elmt_List
;
7902 S
: constant Entity_Id
:= Current_Scope
;
7903 Inst_Par
: Entity_Id
;
7904 First_Par
: Entity_Id
;
7905 Inst_Node
: Node_Id
;
7906 Gen_Par
: Entity_Id
;
7907 First_Gen
: Entity_Id
;
7910 procedure Install_Noninstance_Specs
(Par
: Entity_Id
);
7911 -- Install the scopes of noninstance parent units ending with Par
7913 procedure Install_Spec
(Par
: Entity_Id
);
7914 -- The child unit is within the declarative part of the parent, so
7915 -- the declarations within the parent are immediately visible.
7917 -------------------------------
7918 -- Install_Noninstance_Specs --
7919 -------------------------------
7921 procedure Install_Noninstance_Specs
(Par
: Entity_Id
) is
7924 and then Par
/= Standard_Standard
7925 and then not In_Open_Scopes
(Par
)
7927 Install_Noninstance_Specs
(Scope
(Par
));
7930 end Install_Noninstance_Specs
;
7936 procedure Install_Spec
(Par
: Entity_Id
) is
7937 Spec
: constant Node_Id
:=
7938 Specification
(Unit_Declaration_Node
(Par
));
7941 -- If this parent of the child instance is a top-level unit,
7942 -- then record the unit and its visibility for later resetting
7943 -- in Remove_Parent. We exclude units that are generic instances,
7944 -- as we only want to record this information for the ultimate
7945 -- top-level noninstance parent (is that always correct???).
7947 if Scope
(Par
) = Standard_Standard
7948 and then not Is_Generic_Instance
(Par
)
7950 Parent_Unit_Visible
:= Is_Immediately_Visible
(Par
);
7951 Instance_Parent_Unit
:= Par
;
7954 -- Open the parent scope and make it and its declarations visible.
7955 -- If this point is not within a body, then only the visible
7956 -- declarations should be made visible, and installation of the
7957 -- private declarations is deferred until the appropriate point
7958 -- within analysis of the spec being instantiated (see the handling
7959 -- of parent visibility in Analyze_Package_Specification). This is
7960 -- relaxed in the case where the parent unit is Ada.Tags, to avoid
7961 -- private view problems that occur when compiling instantiations of
7962 -- a generic child of that package (Generic_Dispatching_Constructor).
7963 -- If the instance freezes a tagged type, inlinings of operations
7964 -- from Ada.Tags may need the full view of type Tag. If inlining took
7965 -- proper account of establishing visibility of inlined subprograms'
7966 -- parents then it should be possible to remove this
7967 -- special check. ???
7970 Set_Is_Immediately_Visible
(Par
);
7971 Install_Visible_Declarations
(Par
);
7972 Set_Use
(Visible_Declarations
(Spec
));
7974 if In_Body
or else Is_RTU
(Par
, Ada_Tags
) then
7975 Install_Private_Declarations
(Par
);
7976 Set_Use
(Private_Declarations
(Spec
));
7980 -- Start of processing for Install_Parent
7983 -- We need to install the parent instance to compile the instantiation
7984 -- of the child, but the child instance must appear in the current
7985 -- scope. Given that we cannot place the parent above the current scope
7986 -- in the scope stack, we duplicate the current scope and unstack both
7987 -- after the instantiation is complete.
7989 -- If the parent is itself the instantiation of a child unit, we must
7990 -- also stack the instantiation of its parent, and so on. Each such
7991 -- ancestor is the prefix of the name in a prior instantiation.
7993 -- If this is a nested instance, the parent unit itself resolves to
7994 -- a renaming of the parent instance, whose declaration we need.
7996 -- Finally, the parent may be a generic (not an instance) when the
7997 -- child unit appears as a formal package.
8001 if Present
(Renamed_Entity
(Inst_Par
)) then
8002 Inst_Par
:= Renamed_Entity
(Inst_Par
);
8005 First_Par
:= Inst_Par
;
8008 Generic_Parent
(Specification
(Unit_Declaration_Node
(Inst_Par
)));
8010 First_Gen
:= Gen_Par
;
8012 while Present
(Gen_Par
)
8013 and then Is_Child_Unit
(Gen_Par
)
8015 -- Load grandparent instance as well
8017 Inst_Node
:= Get_Package_Instantiation_Node
(Inst_Par
);
8019 if Nkind
(Name
(Inst_Node
)) = N_Expanded_Name
then
8020 Inst_Par
:= Entity
(Prefix
(Name
(Inst_Node
)));
8022 if Present
(Renamed_Entity
(Inst_Par
)) then
8023 Inst_Par
:= Renamed_Entity
(Inst_Par
);
8028 (Specification
(Unit_Declaration_Node
(Inst_Par
)));
8030 if Present
(Gen_Par
) then
8031 Prepend_Elmt
(Inst_Par
, Ancestors
);
8034 -- Parent is not the name of an instantiation
8036 Install_Noninstance_Specs
(Inst_Par
);
8048 if Present
(First_Gen
) then
8049 Append_Elmt
(First_Par
, Ancestors
);
8052 Install_Noninstance_Specs
(First_Par
);
8055 if not Is_Empty_Elmt_List
(Ancestors
) then
8056 Elmt
:= First_Elmt
(Ancestors
);
8058 while Present
(Elmt
) loop
8059 Install_Spec
(Node
(Elmt
));
8060 Install_Formal_Packages
(Node
(Elmt
));
8071 -------------------------------
8072 -- Install_Hidden_Primitives --
8073 -------------------------------
8075 procedure Install_Hidden_Primitives
8076 (Prims_List
: in out Elist_Id
;
8081 List
: Elist_Id
:= No_Elist
;
8082 Prim_G_Elmt
: Elmt_Id
;
8083 Prim_A_Elmt
: Elmt_Id
;
8088 -- No action needed in case of serious errors because we cannot trust
8089 -- in the order of primitives
8091 if Serious_Errors_Detected
> 0 then
8094 -- No action possible if we don't have available the list of primitive
8098 or else not Is_Record_Type
(Gen_T
)
8099 or else not Is_Tagged_Type
(Gen_T
)
8100 or else not Is_Record_Type
(Act_T
)
8101 or else not Is_Tagged_Type
(Act_T
)
8105 -- There is no need to handle interface types since their primitives
8108 elsif Is_Interface
(Gen_T
) then
8112 Prim_G_Elmt
:= First_Elmt
(Primitive_Operations
(Gen_T
));
8114 if not Is_Class_Wide_Type
(Act_T
) then
8115 Prim_A_Elmt
:= First_Elmt
(Primitive_Operations
(Act_T
));
8117 Prim_A_Elmt
:= First_Elmt
(Primitive_Operations
(Root_Type
(Act_T
)));
8121 -- Skip predefined primitives in the generic formal
8123 while Present
(Prim_G_Elmt
)
8124 and then Is_Predefined_Dispatching_Operation
(Node
(Prim_G_Elmt
))
8126 Next_Elmt
(Prim_G_Elmt
);
8129 -- Skip predefined primitives in the generic actual
8131 while Present
(Prim_A_Elmt
)
8132 and then Is_Predefined_Dispatching_Operation
(Node
(Prim_A_Elmt
))
8134 Next_Elmt
(Prim_A_Elmt
);
8137 exit when No
(Prim_G_Elmt
) or else No
(Prim_A_Elmt
);
8139 Prim_G
:= Node
(Prim_G_Elmt
);
8140 Prim_A
:= Node
(Prim_A_Elmt
);
8142 -- There is no need to handle interface primitives because their
8143 -- primitives are not hidden
8145 exit when Present
(Interface_Alias
(Prim_G
));
8147 -- Here we install one hidden primitive
8149 if Chars
(Prim_G
) /= Chars
(Prim_A
)
8150 and then Has_Suffix
(Prim_A
, 'P')
8151 and then Remove_Suffix
(Prim_A
, 'P') = Chars
(Prim_G
)
8153 Set_Chars
(Prim_A
, Chars
(Prim_G
));
8155 if List
= No_Elist
then
8156 List
:= New_Elmt_List
;
8159 Append_Elmt
(Prim_A
, List
);
8162 Next_Elmt
(Prim_A_Elmt
);
8163 Next_Elmt
(Prim_G_Elmt
);
8166 -- Append the elements to the list of temporarily visible primitives
8167 -- avoiding duplicates.
8169 if Present
(List
) then
8170 if No
(Prims_List
) then
8171 Prims_List
:= New_Elmt_List
;
8174 Elmt
:= First_Elmt
(List
);
8175 while Present
(Elmt
) loop
8176 Append_Unique_Elmt
(Node
(Elmt
), Prims_List
);
8180 end Install_Hidden_Primitives
;
8182 -------------------------------
8183 -- Restore_Hidden_Primitives --
8184 -------------------------------
8186 procedure Restore_Hidden_Primitives
(Prims_List
: in out Elist_Id
) is
8187 Prim_Elmt
: Elmt_Id
;
8191 if Prims_List
/= No_Elist
then
8192 Prim_Elmt
:= First_Elmt
(Prims_List
);
8194 while Present
(Prim_Elmt
) loop
8195 Prim
:= Node
(Prim_Elmt
);
8196 Set_Chars
(Prim
, Add_Suffix
(Prim
, 'P'));
8198 Next_Elmt
(Prim_Elmt
);
8201 Prims_List
:= No_Elist
;
8203 end Restore_Hidden_Primitives
;
8205 --------------------------------
8206 -- Instantiate_Formal_Package --
8207 --------------------------------
8209 function Instantiate_Formal_Package
8212 Analyzed_Formal
: Node_Id
) return List_Id
8214 Loc
: constant Source_Ptr
:= Sloc
(Actual
);
8215 Actual_Pack
: Entity_Id
;
8216 Formal_Pack
: Entity_Id
;
8217 Gen_Parent
: Entity_Id
;
8220 Parent_Spec
: Node_Id
;
8222 procedure Find_Matching_Actual
8224 Act
: in out Entity_Id
);
8225 -- We need to associate each formal entity in the formal package
8226 -- with the corresponding entity in the actual package. The actual
8227 -- package has been analyzed and possibly expanded, and as a result
8228 -- there is no one-to-one correspondence between the two lists (for
8229 -- example, the actual may include subtypes, itypes, and inherited
8230 -- primitive operations, interspersed among the renaming declarations
8231 -- for the actuals) . We retrieve the corresponding actual by name
8232 -- because each actual has the same name as the formal, and they do
8233 -- appear in the same order.
8235 function Get_Formal_Entity
(N
: Node_Id
) return Entity_Id
;
8236 -- Retrieve entity of defining entity of generic formal parameter.
8237 -- Only the declarations of formals need to be considered when
8238 -- linking them to actuals, but the declarative list may include
8239 -- internal entities generated during analysis, and those are ignored.
8241 procedure Match_Formal_Entity
8242 (Formal_Node
: Node_Id
;
8243 Formal_Ent
: Entity_Id
;
8244 Actual_Ent
: Entity_Id
);
8245 -- Associates the formal entity with the actual. In the case
8246 -- where Formal_Ent is a formal package, this procedure iterates
8247 -- through all of its formals and enters associations between the
8248 -- actuals occurring in the formal package's corresponding actual
8249 -- package (given by Actual_Ent) and the formal package's formal
8250 -- parameters. This procedure recurses if any of the parameters is
8251 -- itself a package.
8253 function Is_Instance_Of
8254 (Act_Spec
: Entity_Id
;
8255 Gen_Anc
: Entity_Id
) return Boolean;
8256 -- The actual can be an instantiation of a generic within another
8257 -- instance, in which case there is no direct link from it to the
8258 -- original generic ancestor. In that case, we recognize that the
8259 -- ultimate ancestor is the same by examining names and scopes.
8261 procedure Process_Nested_Formal
(Formal
: Entity_Id
);
8262 -- If the current formal is declared with a box, its own formals are
8263 -- visible in the instance, as they were in the generic, and their
8264 -- Hidden flag must be reset. If some of these formals are themselves
8265 -- packages declared with a box, the processing must be recursive.
8267 --------------------------
8268 -- Find_Matching_Actual --
8269 --------------------------
8271 procedure Find_Matching_Actual
8273 Act
: in out Entity_Id
)
8275 Formal_Ent
: Entity_Id
;
8278 case Nkind
(Original_Node
(F
)) is
8279 when N_Formal_Object_Declaration |
8280 N_Formal_Type_Declaration
=>
8281 Formal_Ent
:= Defining_Identifier
(F
);
8283 while Chars
(Act
) /= Chars
(Formal_Ent
) loop
8287 when N_Formal_Subprogram_Declaration |
8288 N_Formal_Package_Declaration |
8289 N_Package_Declaration |
8290 N_Generic_Package_Declaration
=>
8291 Formal_Ent
:= Defining_Entity
(F
);
8293 while Chars
(Act
) /= Chars
(Formal_Ent
) loop
8298 raise Program_Error
;
8300 end Find_Matching_Actual
;
8302 -------------------------
8303 -- Match_Formal_Entity --
8304 -------------------------
8306 procedure Match_Formal_Entity
8307 (Formal_Node
: Node_Id
;
8308 Formal_Ent
: Entity_Id
;
8309 Actual_Ent
: Entity_Id
)
8311 Act_Pkg
: Entity_Id
;
8314 Set_Instance_Of
(Formal_Ent
, Actual_Ent
);
8316 if Ekind
(Actual_Ent
) = E_Package
then
8318 -- Record associations for each parameter
8320 Act_Pkg
:= Actual_Ent
;
8323 A_Ent
: Entity_Id
:= First_Entity
(Act_Pkg
);
8332 -- Retrieve the actual given in the formal package declaration
8334 Actual
:= Entity
(Name
(Original_Node
(Formal_Node
)));
8336 -- The actual in the formal package declaration may be a
8337 -- renamed generic package, in which case we want to retrieve
8338 -- the original generic in order to traverse its formal part.
8340 if Present
(Renamed_Entity
(Actual
)) then
8341 Gen_Decl
:= Unit_Declaration_Node
(Renamed_Entity
(Actual
));
8343 Gen_Decl
:= Unit_Declaration_Node
(Actual
);
8346 Formals
:= Generic_Formal_Declarations
(Gen_Decl
);
8348 if Present
(Formals
) then
8349 F_Node
:= First_Non_Pragma
(Formals
);
8354 while Present
(A_Ent
)
8355 and then Present
(F_Node
)
8356 and then A_Ent
/= First_Private_Entity
(Act_Pkg
)
8358 F_Ent
:= Get_Formal_Entity
(F_Node
);
8360 if Present
(F_Ent
) then
8362 -- This is a formal of the original package. Record
8363 -- association and recurse.
8365 Find_Matching_Actual
(F_Node
, A_Ent
);
8366 Match_Formal_Entity
(F_Node
, F_Ent
, A_Ent
);
8367 Next_Entity
(A_Ent
);
8370 Next_Non_Pragma
(F_Node
);
8374 end Match_Formal_Entity
;
8376 -----------------------
8377 -- Get_Formal_Entity --
8378 -----------------------
8380 function Get_Formal_Entity
(N
: Node_Id
) return Entity_Id
is
8381 Kind
: constant Node_Kind
:= Nkind
(Original_Node
(N
));
8384 when N_Formal_Object_Declaration
=>
8385 return Defining_Identifier
(N
);
8387 when N_Formal_Type_Declaration
=>
8388 return Defining_Identifier
(N
);
8390 when N_Formal_Subprogram_Declaration
=>
8391 return Defining_Unit_Name
(Specification
(N
));
8393 when N_Formal_Package_Declaration
=>
8394 return Defining_Identifier
(Original_Node
(N
));
8396 when N_Generic_Package_Declaration
=>
8397 return Defining_Identifier
(Original_Node
(N
));
8399 -- All other declarations are introduced by semantic analysis and
8400 -- have no match in the actual.
8405 end Get_Formal_Entity
;
8407 --------------------
8408 -- Is_Instance_Of --
8409 --------------------
8411 function Is_Instance_Of
8412 (Act_Spec
: Entity_Id
;
8413 Gen_Anc
: Entity_Id
) return Boolean
8415 Gen_Par
: constant Entity_Id
:= Generic_Parent
(Act_Spec
);
8418 if No
(Gen_Par
) then
8421 -- Simplest case: the generic parent of the actual is the formal
8423 elsif Gen_Par
= Gen_Anc
then
8426 elsif Chars
(Gen_Par
) /= Chars
(Gen_Anc
) then
8429 -- The actual may be obtained through several instantiations. Its
8430 -- scope must itself be an instance of a generic declared in the
8431 -- same scope as the formal. Any other case is detected above.
8433 elsif not Is_Generic_Instance
(Scope
(Gen_Par
)) then
8437 return Generic_Parent
(Parent
(Scope
(Gen_Par
))) = Scope
(Gen_Anc
);
8441 ---------------------------
8442 -- Process_Nested_Formal --
8443 ---------------------------
8445 procedure Process_Nested_Formal
(Formal
: Entity_Id
) is
8449 if Present
(Associated_Formal_Package
(Formal
))
8450 and then Box_Present
(Parent
(Associated_Formal_Package
(Formal
)))
8452 Ent
:= First_Entity
(Formal
);
8453 while Present
(Ent
) loop
8454 Set_Is_Hidden
(Ent
, False);
8455 Set_Is_Visible_Formal
(Ent
);
8456 Set_Is_Potentially_Use_Visible
8457 (Ent
, Is_Potentially_Use_Visible
(Formal
));
8459 if Ekind
(Ent
) = E_Package
then
8460 exit when Renamed_Entity
(Ent
) = Renamed_Entity
(Formal
);
8461 Process_Nested_Formal
(Ent
);
8467 end Process_Nested_Formal
;
8469 -- Start of processing for Instantiate_Formal_Package
8474 if not Is_Entity_Name
(Actual
)
8475 or else Ekind
(Entity
(Actual
)) /= E_Package
8478 ("expect package instance to instantiate formal", Actual
);
8479 Abandon_Instantiation
(Actual
);
8480 raise Program_Error
;
8483 Actual_Pack
:= Entity
(Actual
);
8484 Set_Is_Instantiated
(Actual_Pack
);
8486 -- The actual may be a renamed package, or an outer generic formal
8487 -- package whose instantiation is converted into a renaming.
8489 if Present
(Renamed_Object
(Actual_Pack
)) then
8490 Actual_Pack
:= Renamed_Object
(Actual_Pack
);
8493 if Nkind
(Analyzed_Formal
) = N_Formal_Package_Declaration
then
8494 Gen_Parent
:= Get_Instance_Of
(Entity
(Name
(Analyzed_Formal
)));
8495 Formal_Pack
:= Defining_Identifier
(Analyzed_Formal
);
8498 Generic_Parent
(Specification
(Analyzed_Formal
));
8500 Defining_Unit_Name
(Specification
(Analyzed_Formal
));
8503 if Nkind
(Parent
(Actual_Pack
)) = N_Defining_Program_Unit_Name
then
8504 Parent_Spec
:= Specification
(Unit_Declaration_Node
(Actual_Pack
));
8506 Parent_Spec
:= Parent
(Actual_Pack
);
8509 if Gen_Parent
= Any_Id
then
8511 ("previous error in declaration of formal package", Actual
);
8512 Abandon_Instantiation
(Actual
);
8515 Is_Instance_Of
(Parent_Spec
, Get_Instance_Of
(Gen_Parent
))
8521 ("actual parameter must be instance of&", Actual
, Gen_Parent
);
8522 Abandon_Instantiation
(Actual
);
8525 Set_Instance_Of
(Defining_Identifier
(Formal
), Actual_Pack
);
8526 Map_Formal_Package_Entities
(Formal_Pack
, Actual_Pack
);
8529 Make_Package_Renaming_Declaration
(Loc
,
8530 Defining_Unit_Name
=> New_Copy
(Defining_Identifier
(Formal
)),
8531 Name
=> New_Reference_To
(Actual_Pack
, Loc
));
8533 Set_Associated_Formal_Package
(Defining_Unit_Name
(Nod
),
8534 Defining_Identifier
(Formal
));
8535 Decls
:= New_List
(Nod
);
8537 -- If the formal F has a box, then the generic declarations are
8538 -- visible in the generic G. In an instance of G, the corresponding
8539 -- entities in the actual for F (which are the actuals for the
8540 -- instantiation of the generic that F denotes) must also be made
8541 -- visible for analysis of the current instance. On exit from the
8542 -- current instance, those entities are made private again. If the
8543 -- actual is currently in use, these entities are also use-visible.
8545 -- The loop through the actual entities also steps through the formal
8546 -- entities and enters associations from formals to actuals into the
8547 -- renaming map. This is necessary to properly handle checking of
8548 -- actual parameter associations for later formals that depend on
8549 -- actuals declared in the formal package.
8551 -- In Ada 2005, partial parametrization requires that we make visible
8552 -- the actuals corresponding to formals that were defaulted in the
8553 -- formal package. There formals are identified because they remain
8554 -- formal generics within the formal package, rather than being
8555 -- renamings of the actuals supplied.
8558 Gen_Decl
: constant Node_Id
:=
8559 Unit_Declaration_Node
(Gen_Parent
);
8560 Formals
: constant List_Id
:=
8561 Generic_Formal_Declarations
(Gen_Decl
);
8563 Actual_Ent
: Entity_Id
;
8564 Actual_Of_Formal
: Node_Id
;
8565 Formal_Node
: Node_Id
;
8566 Formal_Ent
: Entity_Id
;
8569 if Present
(Formals
) then
8570 Formal_Node
:= First_Non_Pragma
(Formals
);
8572 Formal_Node
:= Empty
;
8575 Actual_Ent
:= First_Entity
(Actual_Pack
);
8577 First
(Visible_Declarations
(Specification
(Analyzed_Formal
)));
8578 while Present
(Actual_Ent
)
8579 and then Actual_Ent
/= First_Private_Entity
(Actual_Pack
)
8581 if Present
(Formal_Node
) then
8582 Formal_Ent
:= Get_Formal_Entity
(Formal_Node
);
8584 if Present
(Formal_Ent
) then
8585 Find_Matching_Actual
(Formal_Node
, Actual_Ent
);
8587 (Formal_Node
, Formal_Ent
, Actual_Ent
);
8589 -- We iterate at the same time over the actuals of the
8590 -- local package created for the formal, to determine
8591 -- which one of the formals of the original generic were
8592 -- defaulted in the formal. The corresponding actual
8593 -- entities are visible in the enclosing instance.
8595 if Box_Present
(Formal
)
8597 (Present
(Actual_Of_Formal
)
8600 (Get_Formal_Entity
(Actual_Of_Formal
)))
8602 Set_Is_Hidden
(Actual_Ent
, False);
8603 Set_Is_Visible_Formal
(Actual_Ent
);
8604 Set_Is_Potentially_Use_Visible
8605 (Actual_Ent
, In_Use
(Actual_Pack
));
8607 if Ekind
(Actual_Ent
) = E_Package
then
8608 Process_Nested_Formal
(Actual_Ent
);
8612 Set_Is_Hidden
(Actual_Ent
);
8613 Set_Is_Potentially_Use_Visible
(Actual_Ent
, False);
8617 Next_Non_Pragma
(Formal_Node
);
8618 Next
(Actual_Of_Formal
);
8621 -- No further formals to match, but the generic part may
8622 -- contain inherited operation that are not hidden in the
8623 -- enclosing instance.
8625 Next_Entity
(Actual_Ent
);
8629 -- Inherited subprograms generated by formal derived types are
8630 -- also visible if the types are.
8632 Actual_Ent
:= First_Entity
(Actual_Pack
);
8633 while Present
(Actual_Ent
)
8634 and then Actual_Ent
/= First_Private_Entity
(Actual_Pack
)
8636 if Is_Overloadable
(Actual_Ent
)
8638 Nkind
(Parent
(Actual_Ent
)) = N_Subtype_Declaration
8640 not Is_Hidden
(Defining_Identifier
(Parent
(Actual_Ent
)))
8642 Set_Is_Hidden
(Actual_Ent
, False);
8643 Set_Is_Potentially_Use_Visible
8644 (Actual_Ent
, In_Use
(Actual_Pack
));
8647 Next_Entity
(Actual_Ent
);
8651 -- If the formal is not declared with a box, reanalyze it as an
8652 -- abbreviated instantiation, to verify the matching rules of 12.7.
8653 -- The actual checks are performed after the generic associations
8654 -- have been analyzed, to guarantee the same visibility for this
8655 -- instantiation and for the actuals.
8657 -- In Ada 2005, the generic associations for the formal can include
8658 -- defaulted parameters. These are ignored during check. This
8659 -- internal instantiation is removed from the tree after conformance
8660 -- checking, because it contains formal declarations for those
8661 -- defaulted parameters, and those should not reach the back-end.
8663 if not Box_Present
(Formal
) then
8665 I_Pack
: constant Entity_Id
:=
8666 Make_Temporary
(Sloc
(Actual
), 'P');
8669 Set_Is_Internal
(I_Pack
);
8672 Make_Package_Instantiation
(Sloc
(Actual
),
8673 Defining_Unit_Name
=> I_Pack
,
8676 (Get_Instance_Of
(Gen_Parent
), Sloc
(Actual
)),
8677 Generic_Associations
=>
8678 Generic_Associations
(Formal
)));
8684 end Instantiate_Formal_Package
;
8686 -----------------------------------
8687 -- Instantiate_Formal_Subprogram --
8688 -----------------------------------
8690 function Instantiate_Formal_Subprogram
8693 Analyzed_Formal
: Node_Id
) return Node_Id
8696 Formal_Sub
: constant Entity_Id
:=
8697 Defining_Unit_Name
(Specification
(Formal
));
8698 Analyzed_S
: constant Entity_Id
:=
8699 Defining_Unit_Name
(Specification
(Analyzed_Formal
));
8700 Decl_Node
: Node_Id
;
8704 function From_Parent_Scope
(Subp
: Entity_Id
) return Boolean;
8705 -- If the generic is a child unit, the parent has been installed on the
8706 -- scope stack, but a default subprogram cannot resolve to something on
8707 -- the parent because that parent is not really part of the visible
8708 -- context (it is there to resolve explicit local entities). If the
8709 -- default has resolved in this way, we remove the entity from
8710 -- immediate visibility and analyze the node again to emit an error
8711 -- message or find another visible candidate.
8713 procedure Valid_Actual_Subprogram
(Act
: Node_Id
);
8714 -- Perform legality check and raise exception on failure
8716 -----------------------
8717 -- From_Parent_Scope --
8718 -----------------------
8720 function From_Parent_Scope
(Subp
: Entity_Id
) return Boolean is
8721 Gen_Scope
: Node_Id
;
8724 Gen_Scope
:= Scope
(Analyzed_S
);
8725 while Present
(Gen_Scope
)
8726 and then Is_Child_Unit
(Gen_Scope
)
8728 if Scope
(Subp
) = Scope
(Gen_Scope
) then
8732 Gen_Scope
:= Scope
(Gen_Scope
);
8736 end From_Parent_Scope
;
8738 -----------------------------
8739 -- Valid_Actual_Subprogram --
8740 -----------------------------
8742 procedure Valid_Actual_Subprogram
(Act
: Node_Id
) is
8746 if Is_Entity_Name
(Act
) then
8747 Act_E
:= Entity
(Act
);
8749 elsif Nkind
(Act
) = N_Selected_Component
8750 and then Is_Entity_Name
(Selector_Name
(Act
))
8752 Act_E
:= Entity
(Selector_Name
(Act
));
8758 if (Present
(Act_E
) and then Is_Overloadable
(Act_E
))
8759 or else Nkind_In
(Act
, N_Attribute_Reference
,
8760 N_Indexed_Component
,
8761 N_Character_Literal
,
8762 N_Explicit_Dereference
)
8768 ("expect subprogram or entry name in instantiation of&",
8769 Instantiation_Node
, Formal_Sub
);
8770 Abandon_Instantiation
(Instantiation_Node
);
8772 end Valid_Actual_Subprogram
;
8774 -- Start of processing for Instantiate_Formal_Subprogram
8777 New_Spec
:= New_Copy_Tree
(Specification
(Formal
));
8779 -- The tree copy has created the proper instantiation sloc for the
8780 -- new specification. Use this location for all other constructed
8783 Loc
:= Sloc
(Defining_Unit_Name
(New_Spec
));
8785 -- Create new entity for the actual (New_Copy_Tree does not)
8787 Set_Defining_Unit_Name
8788 (New_Spec
, Make_Defining_Identifier
(Loc
, Chars
(Formal_Sub
)));
8790 -- Create new entities for the each of the formals in the
8791 -- specification of the renaming declaration built for the actual.
8793 if Present
(Parameter_Specifications
(New_Spec
)) then
8797 F
:= First
(Parameter_Specifications
(New_Spec
));
8798 while Present
(F
) loop
8799 Set_Defining_Identifier
(F
,
8800 Make_Defining_Identifier
(Sloc
(F
),
8801 Chars
=> Chars
(Defining_Identifier
(F
))));
8807 -- Find entity of actual. If the actual is an attribute reference, it
8808 -- cannot be resolved here (its formal is missing) but is handled
8809 -- instead in Attribute_Renaming. If the actual is overloaded, it is
8810 -- fully resolved subsequently, when the renaming declaration for the
8811 -- formal is analyzed. If it is an explicit dereference, resolve the
8812 -- prefix but not the actual itself, to prevent interpretation as call.
8814 if Present
(Actual
) then
8815 Loc
:= Sloc
(Actual
);
8816 Set_Sloc
(New_Spec
, Loc
);
8818 if Nkind
(Actual
) = N_Operator_Symbol
then
8819 Find_Direct_Name
(Actual
);
8821 elsif Nkind
(Actual
) = N_Explicit_Dereference
then
8822 Analyze
(Prefix
(Actual
));
8824 elsif Nkind
(Actual
) /= N_Attribute_Reference
then
8828 Valid_Actual_Subprogram
(Actual
);
8831 elsif Present
(Default_Name
(Formal
)) then
8832 if not Nkind_In
(Default_Name
(Formal
), N_Attribute_Reference
,
8833 N_Selected_Component
,
8834 N_Indexed_Component
,
8835 N_Character_Literal
)
8836 and then Present
(Entity
(Default_Name
(Formal
)))
8838 Nam
:= New_Occurrence_Of
(Entity
(Default_Name
(Formal
)), Loc
);
8840 Nam
:= New_Copy
(Default_Name
(Formal
));
8841 Set_Sloc
(Nam
, Loc
);
8844 elsif Box_Present
(Formal
) then
8846 -- Actual is resolved at the point of instantiation. Create an
8847 -- identifier or operator with the same name as the formal.
8849 if Nkind
(Formal_Sub
) = N_Defining_Operator_Symbol
then
8850 Nam
:= Make_Operator_Symbol
(Loc
,
8851 Chars
=> Chars
(Formal_Sub
),
8852 Strval
=> No_String
);
8854 Nam
:= Make_Identifier
(Loc
, Chars
(Formal_Sub
));
8857 elsif Nkind
(Specification
(Formal
)) = N_Procedure_Specification
8858 and then Null_Present
(Specification
(Formal
))
8860 -- Generate null body for procedure, for use in the instance
8863 Make_Subprogram_Body
(Loc
,
8864 Specification
=> New_Spec
,
8865 Declarations
=> New_List
,
8866 Handled_Statement_Sequence
=>
8867 Make_Handled_Sequence_Of_Statements
(Loc
,
8868 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
8870 Set_Is_Intrinsic_Subprogram
(Defining_Unit_Name
(New_Spec
));
8874 Error_Msg_Sloc
:= Sloc
(Scope
(Analyzed_S
));
8876 ("missing actual&", Instantiation_Node
, Formal_Sub
);
8878 ("\in instantiation of & declared#",
8879 Instantiation_Node
, Scope
(Analyzed_S
));
8880 Abandon_Instantiation
(Instantiation_Node
);
8884 Make_Subprogram_Renaming_Declaration
(Loc
,
8885 Specification
=> New_Spec
,
8888 -- If we do not have an actual and the formal specified <> then set to
8889 -- get proper default.
8891 if No
(Actual
) and then Box_Present
(Formal
) then
8892 Set_From_Default
(Decl_Node
);
8895 -- Gather possible interpretations for the actual before analyzing the
8896 -- instance. If overloaded, it will be resolved when analyzing the
8897 -- renaming declaration.
8899 if Box_Present
(Formal
)
8900 and then No
(Actual
)
8904 if Is_Child_Unit
(Scope
(Analyzed_S
))
8905 and then Present
(Entity
(Nam
))
8907 if not Is_Overloaded
(Nam
) then
8909 if From_Parent_Scope
(Entity
(Nam
)) then
8910 Set_Is_Immediately_Visible
(Entity
(Nam
), False);
8911 Set_Entity
(Nam
, Empty
);
8912 Set_Etype
(Nam
, Empty
);
8916 Set_Is_Immediately_Visible
(Entity
(Nam
));
8925 Get_First_Interp
(Nam
, I
, It
);
8927 while Present
(It
.Nam
) loop
8928 if From_Parent_Scope
(It
.Nam
) then
8932 Get_Next_Interp
(I
, It
);
8939 -- The generic instantiation freezes the actual. This can only be done
8940 -- once the actual is resolved, in the analysis of the renaming
8941 -- declaration. To make the formal subprogram entity available, we set
8942 -- Corresponding_Formal_Spec to point to the formal subprogram entity.
8943 -- This is also needed in Analyze_Subprogram_Renaming for the processing
8944 -- of formal abstract subprograms.
8946 Set_Corresponding_Formal_Spec
(Decl_Node
, Analyzed_S
);
8948 -- We cannot analyze the renaming declaration, and thus find the actual,
8949 -- until all the actuals are assembled in the instance. For subsequent
8950 -- checks of other actuals, indicate the node that will hold the
8951 -- instance of this formal.
8953 Set_Instance_Of
(Analyzed_S
, Nam
);
8955 if Nkind
(Actual
) = N_Selected_Component
8956 and then Is_Task_Type
(Etype
(Prefix
(Actual
)))
8957 and then not Is_Frozen
(Etype
(Prefix
(Actual
)))
8959 -- The renaming declaration will create a body, which must appear
8960 -- outside of the instantiation, We move the renaming declaration
8961 -- out of the instance, and create an additional renaming inside,
8962 -- to prevent freezing anomalies.
8965 Anon_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E');
8968 Set_Defining_Unit_Name
(New_Spec
, Anon_Id
);
8969 Insert_Before
(Instantiation_Node
, Decl_Node
);
8970 Analyze
(Decl_Node
);
8972 -- Now create renaming within the instance
8975 Make_Subprogram_Renaming_Declaration
(Loc
,
8976 Specification
=> New_Copy_Tree
(New_Spec
),
8977 Name
=> New_Occurrence_Of
(Anon_Id
, Loc
));
8979 Set_Defining_Unit_Name
(Specification
(Decl_Node
),
8980 Make_Defining_Identifier
(Loc
, Chars
(Formal_Sub
)));
8985 end Instantiate_Formal_Subprogram
;
8987 ------------------------
8988 -- Instantiate_Object --
8989 ------------------------
8991 function Instantiate_Object
8994 Analyzed_Formal
: Node_Id
) return List_Id
8996 Gen_Obj
: constant Entity_Id
:= Defining_Identifier
(Formal
);
8997 A_Gen_Obj
: constant Entity_Id
:=
8998 Defining_Identifier
(Analyzed_Formal
);
8999 Acc_Def
: Node_Id
:= Empty
;
9000 Act_Assoc
: constant Node_Id
:= Parent
(Actual
);
9001 Actual_Decl
: Node_Id
:= Empty
;
9002 Decl_Node
: Node_Id
;
9005 List
: constant List_Id
:= New_List
;
9006 Loc
: constant Source_Ptr
:= Sloc
(Actual
);
9007 Orig_Ftyp
: constant Entity_Id
:= Etype
(A_Gen_Obj
);
9008 Subt_Decl
: Node_Id
:= Empty
;
9009 Subt_Mark
: Node_Id
:= Empty
;
9012 if Present
(Subtype_Mark
(Formal
)) then
9013 Subt_Mark
:= Subtype_Mark
(Formal
);
9015 Check_Access_Definition
(Formal
);
9016 Acc_Def
:= Access_Definition
(Formal
);
9019 -- Sloc for error message on missing actual
9021 Error_Msg_Sloc
:= Sloc
(Scope
(A_Gen_Obj
));
9023 if Get_Instance_Of
(Gen_Obj
) /= Gen_Obj
then
9024 Error_Msg_N
("duplicate instantiation of generic parameter", Actual
);
9027 Set_Parent
(List
, Parent
(Actual
));
9031 if Out_Present
(Formal
) then
9033 -- An IN OUT generic actual must be a name. The instantiation is a
9034 -- renaming declaration. The actual is the name being renamed. We
9035 -- use the actual directly, rather than a copy, because it is not
9036 -- used further in the list of actuals, and because a copy or a use
9037 -- of relocate_node is incorrect if the instance is nested within a
9038 -- generic. In order to simplify ASIS searches, the Generic_Parent
9039 -- field links the declaration to the generic association.
9044 Instantiation_Node
, Gen_Obj
);
9046 ("\in instantiation of & declared#",
9047 Instantiation_Node
, Scope
(A_Gen_Obj
));
9048 Abandon_Instantiation
(Instantiation_Node
);
9051 if Present
(Subt_Mark
) then
9053 Make_Object_Renaming_Declaration
(Loc
,
9054 Defining_Identifier
=> New_Copy
(Gen_Obj
),
9055 Subtype_Mark
=> New_Copy_Tree
(Subt_Mark
),
9058 else pragma Assert
(Present
(Acc_Def
));
9060 Make_Object_Renaming_Declaration
(Loc
,
9061 Defining_Identifier
=> New_Copy
(Gen_Obj
),
9062 Access_Definition
=> New_Copy_Tree
(Acc_Def
),
9066 Set_Corresponding_Generic_Association
(Decl_Node
, Act_Assoc
);
9068 -- The analysis of the actual may produce insert_action nodes, so
9069 -- the declaration must have a context in which to attach them.
9071 Append
(Decl_Node
, List
);
9074 -- Return if the analysis of the actual reported some error
9076 if Etype
(Actual
) = Any_Type
then
9080 -- This check is performed here because Analyze_Object_Renaming will
9081 -- not check it when Comes_From_Source is False. Note though that the
9082 -- check for the actual being the name of an object will be performed
9083 -- in Analyze_Object_Renaming.
9085 if Is_Object_Reference
(Actual
)
9086 and then Is_Dependent_Component_Of_Mutable_Object
(Actual
)
9089 ("illegal discriminant-dependent component for in out parameter",
9093 -- The actual has to be resolved in order to check that it is a
9094 -- variable (due to cases such as F (1), where F returns access to an
9095 -- array, and for overloaded prefixes).
9097 Ftyp
:= Get_Instance_Of
(Etype
(A_Gen_Obj
));
9099 -- If the type of the formal is not itself a formal, and the
9100 -- current unit is a child unit, the formal type must be declared
9101 -- in a parent, and must be retrieved by visibility.
9104 and then Is_Generic_Unit
(Scope
(Ftyp
))
9105 and then Is_Child_Unit
(Scope
(A_Gen_Obj
))
9108 Temp
: constant Node_Id
:=
9109 New_Copy_Tree
(Subtype_Mark
(Analyzed_Formal
));
9111 Set_Entity
(Temp
, Empty
);
9113 Ftyp
:= Entity
(Temp
);
9117 if Is_Private_Type
(Ftyp
)
9118 and then not Is_Private_Type
(Etype
(Actual
))
9119 and then (Base_Type
(Full_View
(Ftyp
)) = Base_Type
(Etype
(Actual
))
9120 or else Base_Type
(Etype
(Actual
)) = Ftyp
)
9122 -- If the actual has the type of the full view of the formal, or
9123 -- else a non-private subtype of the formal, then the visibility
9124 -- of the formal type has changed. Add to the actuals a subtype
9125 -- declaration that will force the exchange of views in the body
9126 -- of the instance as well.
9129 Make_Subtype_Declaration
(Loc
,
9130 Defining_Identifier
=> Make_Temporary
(Loc
, 'P'),
9131 Subtype_Indication
=> New_Occurrence_Of
(Ftyp
, Loc
));
9133 Prepend
(Subt_Decl
, List
);
9135 Prepend_Elmt
(Full_View
(Ftyp
), Exchanged_Views
);
9136 Exchange_Declarations
(Ftyp
);
9139 Resolve
(Actual
, Ftyp
);
9141 if not Denotes_Variable
(Actual
) then
9143 ("actual for& must be a variable", Actual
, Gen_Obj
);
9145 elsif Base_Type
(Ftyp
) /= Base_Type
(Etype
(Actual
)) then
9147 -- Ada 2005 (AI-423): For a generic formal object of mode in out,
9148 -- the type of the actual shall resolve to a specific anonymous
9151 if Ada_Version
< Ada_2005
9153 Ekind
(Base_Type
(Ftyp
)) /=
9154 E_Anonymous_Access_Type
9156 Ekind
(Base_Type
(Etype
(Actual
))) /=
9157 E_Anonymous_Access_Type
9159 Error_Msg_NE
("type of actual does not match type of&",
9164 Note_Possible_Modification
(Actual
, Sure
=> True);
9166 -- Check for instantiation of atomic/volatile actual for
9167 -- non-atomic/volatile formal (RM C.6 (12)).
9169 if Is_Atomic_Object
(Actual
)
9170 and then not Is_Atomic
(Orig_Ftyp
)
9173 ("cannot instantiate non-atomic formal object " &
9174 "with atomic actual", Actual
);
9176 elsif Is_Volatile_Object
(Actual
)
9177 and then not Is_Volatile
(Orig_Ftyp
)
9180 ("cannot instantiate non-volatile formal object " &
9181 "with volatile actual", Actual
);
9184 -- Formal in-parameter
9187 -- The instantiation of a generic formal in-parameter is constant
9188 -- declaration. The actual is the expression for that declaration.
9190 if Present
(Actual
) then
9191 if Present
(Subt_Mark
) then
9193 else pragma Assert
(Present
(Acc_Def
));
9198 Make_Object_Declaration
(Loc
,
9199 Defining_Identifier
=> New_Copy
(Gen_Obj
),
9200 Constant_Present
=> True,
9201 Null_Exclusion_Present
=> Null_Exclusion_Present
(Formal
),
9202 Object_Definition
=> New_Copy_Tree
(Def
),
9203 Expression
=> Actual
);
9205 Set_Corresponding_Generic_Association
(Decl_Node
, Act_Assoc
);
9207 -- A generic formal object of a tagged type is defined to be
9208 -- aliased so the new constant must also be treated as aliased.
9210 if Is_Tagged_Type
(Etype
(A_Gen_Obj
)) then
9211 Set_Aliased_Present
(Decl_Node
);
9214 Append
(Decl_Node
, List
);
9216 -- No need to repeat (pre-)analysis of some expression nodes
9217 -- already handled in Preanalyze_Actuals.
9219 if Nkind
(Actual
) /= N_Allocator
then
9222 -- Return if the analysis of the actual reported some error
9224 if Etype
(Actual
) = Any_Type
then
9230 Formal_Type
: constant Entity_Id
:= Etype
(A_Gen_Obj
);
9234 Typ
:= Get_Instance_Of
(Formal_Type
);
9236 Freeze_Before
(Instantiation_Node
, Typ
);
9238 -- If the actual is an aggregate, perform name resolution on
9239 -- its components (the analysis of an aggregate does not do it)
9240 -- to capture local names that may be hidden if the generic is
9243 if Nkind
(Actual
) = N_Aggregate
then
9244 Preanalyze_And_Resolve
(Actual
, Typ
);
9247 if Is_Limited_Type
(Typ
)
9248 and then not OK_For_Limited_Init
(Typ
, Actual
)
9251 ("initialization not allowed for limited types", Actual
);
9252 Explain_Limited_Type
(Typ
, Actual
);
9256 elsif Present
(Default_Expression
(Formal
)) then
9258 -- Use default to construct declaration
9260 if Present
(Subt_Mark
) then
9262 else pragma Assert
(Present
(Acc_Def
));
9267 Make_Object_Declaration
(Sloc
(Formal
),
9268 Defining_Identifier
=> New_Copy
(Gen_Obj
),
9269 Constant_Present
=> True,
9270 Null_Exclusion_Present
=> Null_Exclusion_Present
(Formal
),
9271 Object_Definition
=> New_Copy
(Def
),
9272 Expression
=> New_Copy_Tree
9273 (Default_Expression
(Formal
)));
9275 Append
(Decl_Node
, List
);
9276 Set_Analyzed
(Expression
(Decl_Node
), False);
9281 Instantiation_Node
, Gen_Obj
);
9282 Error_Msg_NE
("\in instantiation of & declared#",
9283 Instantiation_Node
, Scope
(A_Gen_Obj
));
9285 if Is_Scalar_Type
(Etype
(A_Gen_Obj
)) then
9287 -- Create dummy constant declaration so that instance can be
9288 -- analyzed, to minimize cascaded visibility errors.
9290 if Present
(Subt_Mark
) then
9292 else pragma Assert
(Present
(Acc_Def
));
9297 Make_Object_Declaration
(Loc
,
9298 Defining_Identifier
=> New_Copy
(Gen_Obj
),
9299 Constant_Present
=> True,
9300 Null_Exclusion_Present
=> Null_Exclusion_Present
(Formal
),
9301 Object_Definition
=> New_Copy
(Def
),
9303 Make_Attribute_Reference
(Sloc
(Gen_Obj
),
9304 Attribute_Name
=> Name_First
,
9305 Prefix
=> New_Copy
(Def
)));
9307 Append
(Decl_Node
, List
);
9310 Abandon_Instantiation
(Instantiation_Node
);
9315 if Nkind
(Actual
) in N_Has_Entity
then
9316 Actual_Decl
:= Parent
(Entity
(Actual
));
9319 -- Ada 2005 (AI-423): For a formal object declaration with a null
9320 -- exclusion or an access definition that has a null exclusion: If the
9321 -- actual matching the formal object declaration denotes a generic
9322 -- formal object of another generic unit G, and the instantiation
9323 -- containing the actual occurs within the body of G or within the body
9324 -- of a generic unit declared within the declarative region of G, then
9325 -- the declaration of the formal object of G must have a null exclusion.
9326 -- Otherwise, the subtype of the actual matching the formal object
9327 -- declaration shall exclude null.
9329 if Ada_Version
>= Ada_2005
9330 and then Present
(Actual_Decl
)
9332 Nkind_In
(Actual_Decl
, N_Formal_Object_Declaration
,
9333 N_Object_Declaration
)
9334 and then Nkind
(Analyzed_Formal
) = N_Formal_Object_Declaration
9335 and then not Has_Null_Exclusion
(Actual_Decl
)
9336 and then Has_Null_Exclusion
(Analyzed_Formal
)
9338 Error_Msg_Sloc
:= Sloc
(Analyzed_Formal
);
9340 ("actual must exclude null to match generic formal#", Actual
);
9344 end Instantiate_Object
;
9346 ------------------------------
9347 -- Instantiate_Package_Body --
9348 ------------------------------
9350 procedure Instantiate_Package_Body
9351 (Body_Info
: Pending_Body_Info
;
9352 Inlined_Body
: Boolean := False;
9353 Body_Optional
: Boolean := False)
9355 Act_Decl
: constant Node_Id
:= Body_Info
.Act_Decl
;
9356 Inst_Node
: constant Node_Id
:= Body_Info
.Inst_Node
;
9357 Loc
: constant Source_Ptr
:= Sloc
(Inst_Node
);
9359 Gen_Id
: constant Node_Id
:= Name
(Inst_Node
);
9360 Gen_Unit
: constant Entity_Id
:= Get_Generic_Entity
(Inst_Node
);
9361 Gen_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Gen_Unit
);
9362 Act_Spec
: constant Node_Id
:= Specification
(Act_Decl
);
9363 Act_Decl_Id
: constant Entity_Id
:= Defining_Entity
(Act_Spec
);
9365 Act_Body_Name
: Node_Id
;
9367 Gen_Body_Id
: Node_Id
;
9369 Act_Body_Id
: Entity_Id
;
9371 Parent_Installed
: Boolean := False;
9372 Save_Style_Check
: constant Boolean := Style_Check
;
9374 Par_Ent
: Entity_Id
:= Empty
;
9375 Par_Vis
: Boolean := False;
9377 Vis_Prims_List
: Elist_Id
:= No_Elist
;
9378 -- List of primitives made temporarily visible in the instantiation
9379 -- to match the visibility of the formal type
9382 Gen_Body_Id
:= Corresponding_Body
(Gen_Decl
);
9384 -- The instance body may already have been processed, as the parent of
9385 -- another instance that is inlined (Load_Parent_Of_Generic).
9387 if Present
(Corresponding_Body
(Instance_Spec
(Inst_Node
))) then
9391 Expander_Mode_Save_And_Set
(Body_Info
.Expander_Status
);
9393 -- Re-establish the state of information on which checks are suppressed.
9394 -- This information was set in Body_Info at the point of instantiation,
9395 -- and now we restore it so that the instance is compiled using the
9396 -- check status at the instantiation (RM 11.5 (7.2/2), AI95-00224-01).
9398 Local_Suppress_Stack_Top
:= Body_Info
.Local_Suppress_Stack_Top
;
9399 Scope_Suppress
:= Body_Info
.Scope_Suppress
;
9400 Opt
.Ada_Version
:= Body_Info
.Version
;
9402 if No
(Gen_Body_Id
) then
9403 Load_Parent_Of_Generic
9404 (Inst_Node
, Specification
(Gen_Decl
), Body_Optional
);
9405 Gen_Body_Id
:= Corresponding_Body
(Gen_Decl
);
9408 -- Establish global variable for sloc adjustment and for error recovery
9410 Instantiation_Node
:= Inst_Node
;
9412 if Present
(Gen_Body_Id
) then
9413 Save_Env
(Gen_Unit
, Act_Decl_Id
);
9414 Style_Check
:= False;
9415 Current_Sem_Unit
:= Body_Info
.Current_Sem_Unit
;
9417 Gen_Body
:= Unit_Declaration_Node
(Gen_Body_Id
);
9419 Create_Instantiation_Source
9420 (Inst_Node
, Gen_Body_Id
, False, S_Adjustment
);
9424 (Original_Node
(Gen_Body
), Empty
, Instantiating
=> True);
9426 -- Build new name (possibly qualified) for body declaration
9428 Act_Body_Id
:= New_Copy
(Act_Decl_Id
);
9430 -- Some attributes of spec entity are not inherited by body entity
9432 Set_Handler_Records
(Act_Body_Id
, No_List
);
9434 if Nkind
(Defining_Unit_Name
(Act_Spec
)) =
9435 N_Defining_Program_Unit_Name
9438 Make_Defining_Program_Unit_Name
(Loc
,
9439 Name
=> New_Copy_Tree
(Name
(Defining_Unit_Name
(Act_Spec
))),
9440 Defining_Identifier
=> Act_Body_Id
);
9442 Act_Body_Name
:= Act_Body_Id
;
9445 Set_Defining_Unit_Name
(Act_Body
, Act_Body_Name
);
9447 Set_Corresponding_Spec
(Act_Body
, Act_Decl_Id
);
9448 Check_Generic_Actuals
(Act_Decl_Id
, False);
9450 -- Install primitives hidden at the point of the instantiation but
9451 -- visible when processing the generic formals
9457 E
:= First_Entity
(Act_Decl_Id
);
9458 while Present
(E
) loop
9460 and then Is_Generic_Actual_Type
(E
)
9461 and then Is_Tagged_Type
(E
)
9463 Install_Hidden_Primitives
9464 (Prims_List
=> Vis_Prims_List
,
9465 Gen_T
=> Generic_Parent_Type
(Parent
(E
)),
9473 -- If it is a child unit, make the parent instance (which is an
9474 -- instance of the parent of the generic) visible. The parent
9475 -- instance is the prefix of the name of the generic unit.
9477 if Ekind
(Scope
(Gen_Unit
)) = E_Generic_Package
9478 and then Nkind
(Gen_Id
) = N_Expanded_Name
9480 Par_Ent
:= Entity
(Prefix
(Gen_Id
));
9481 Par_Vis
:= Is_Immediately_Visible
(Par_Ent
);
9482 Install_Parent
(Par_Ent
, In_Body
=> True);
9483 Parent_Installed
:= True;
9485 elsif Is_Child_Unit
(Gen_Unit
) then
9486 Par_Ent
:= Scope
(Gen_Unit
);
9487 Par_Vis
:= Is_Immediately_Visible
(Par_Ent
);
9488 Install_Parent
(Par_Ent
, In_Body
=> True);
9489 Parent_Installed
:= True;
9492 -- If the instantiation is a library unit, and this is the main unit,
9493 -- then build the resulting compilation unit nodes for the instance.
9494 -- If this is a compilation unit but it is not the main unit, then it
9495 -- is the body of a unit in the context, that is being compiled
9496 -- because it is encloses some inlined unit or another generic unit
9497 -- being instantiated. In that case, this body is not part of the
9498 -- current compilation, and is not attached to the tree, but its
9499 -- parent must be set for analysis.
9501 if Nkind
(Parent
(Inst_Node
)) = N_Compilation_Unit
then
9503 -- Replace instance node with body of instance, and create new
9504 -- node for corresponding instance declaration.
9506 Build_Instance_Compilation_Unit_Nodes
9507 (Inst_Node
, Act_Body
, Act_Decl
);
9508 Analyze
(Inst_Node
);
9510 if Parent
(Inst_Node
) = Cunit
(Main_Unit
) then
9512 -- If the instance is a child unit itself, then set the scope
9513 -- of the expanded body to be the parent of the instantiation
9514 -- (ensuring that the fully qualified name will be generated
9515 -- for the elaboration subprogram).
9517 if Nkind
(Defining_Unit_Name
(Act_Spec
)) =
9518 N_Defining_Program_Unit_Name
9521 (Defining_Entity
(Inst_Node
), Scope
(Act_Decl_Id
));
9525 -- Case where instantiation is not a library unit
9528 -- If this is an early instantiation, i.e. appears textually
9529 -- before the corresponding body and must be elaborated first,
9530 -- indicate that the body instance is to be delayed.
9532 Install_Body
(Act_Body
, Inst_Node
, Gen_Body
, Gen_Decl
);
9534 -- Now analyze the body. We turn off all checks if this is an
9535 -- internal unit, since there is no reason to have checks on for
9536 -- any predefined run-time library code. All such code is designed
9537 -- to be compiled with checks off.
9539 -- Note that we do NOT apply this criterion to children of GNAT
9540 -- (or on VMS, children of DEC). The latter units must suppress
9541 -- checks explicitly if this is needed.
9543 if Is_Predefined_File_Name
9544 (Unit_File_Name
(Get_Source_Unit
(Gen_Decl
)))
9546 Analyze
(Act_Body
, Suppress
=> All_Checks
);
9552 Inherit_Context
(Gen_Body
, Inst_Node
);
9554 -- Remove the parent instances if they have been placed on the scope
9555 -- stack to compile the body.
9557 if Parent_Installed
then
9558 Remove_Parent
(In_Body
=> True);
9560 -- Restore the previous visibility of the parent
9562 Set_Is_Immediately_Visible
(Par_Ent
, Par_Vis
);
9565 Restore_Hidden_Primitives
(Vis_Prims_List
);
9566 Restore_Private_Views
(Act_Decl_Id
);
9568 -- Remove the current unit from visibility if this is an instance
9569 -- that is not elaborated on the fly for inlining purposes.
9571 if not Inlined_Body
then
9572 Set_Is_Immediately_Visible
(Act_Decl_Id
, False);
9576 Style_Check
:= Save_Style_Check
;
9578 -- If we have no body, and the unit requires a body, then complain. This
9579 -- complaint is suppressed if we have detected other errors (since a
9580 -- common reason for missing the body is that it had errors).
9581 -- In CodePeer mode, a warning has been emitted already, no need for
9582 -- further messages.
9584 elsif Unit_Requires_Body
(Gen_Unit
)
9585 and then not Body_Optional
9587 if CodePeer_Mode
then
9590 elsif Serious_Errors_Detected
= 0 then
9592 ("cannot find body of generic package &", Inst_Node
, Gen_Unit
);
9594 -- Don't attempt to perform any cleanup actions if some other error
9595 -- was already detected, since this can cause blowups.
9601 -- Case of package that does not need a body
9604 -- If the instantiation of the declaration is a library unit, rewrite
9605 -- the original package instantiation as a package declaration in the
9606 -- compilation unit node.
9608 if Nkind
(Parent
(Inst_Node
)) = N_Compilation_Unit
then
9609 Set_Parent_Spec
(Act_Decl
, Parent_Spec
(Inst_Node
));
9610 Rewrite
(Inst_Node
, Act_Decl
);
9612 -- Generate elaboration entity, in case spec has elaboration code.
9613 -- This cannot be done when the instance is analyzed, because it
9614 -- is not known yet whether the body exists.
9616 Set_Elaboration_Entity_Required
(Act_Decl_Id
, False);
9617 Build_Elaboration_Entity
(Parent
(Inst_Node
), Act_Decl_Id
);
9619 -- If the instantiation is not a library unit, then append the
9620 -- declaration to the list of implicitly generated entities, unless
9621 -- it is already a list member which means that it was already
9624 elsif not Is_List_Member
(Act_Decl
) then
9625 Mark_Rewrite_Insertion
(Act_Decl
);
9626 Insert_Before
(Inst_Node
, Act_Decl
);
9630 Expander_Mode_Restore
;
9631 end Instantiate_Package_Body
;
9633 ---------------------------------
9634 -- Instantiate_Subprogram_Body --
9635 ---------------------------------
9637 procedure Instantiate_Subprogram_Body
9638 (Body_Info
: Pending_Body_Info
;
9639 Body_Optional
: Boolean := False)
9641 Act_Decl
: constant Node_Id
:= Body_Info
.Act_Decl
;
9642 Inst_Node
: constant Node_Id
:= Body_Info
.Inst_Node
;
9643 Loc
: constant Source_Ptr
:= Sloc
(Inst_Node
);
9644 Gen_Id
: constant Node_Id
:= Name
(Inst_Node
);
9645 Gen_Unit
: constant Entity_Id
:= Get_Generic_Entity
(Inst_Node
);
9646 Gen_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Gen_Unit
);
9647 Anon_Id
: constant Entity_Id
:=
9648 Defining_Unit_Name
(Specification
(Act_Decl
));
9649 Pack_Id
: constant Entity_Id
:=
9650 Defining_Unit_Name
(Parent
(Act_Decl
));
9653 Gen_Body_Id
: Node_Id
;
9655 Pack_Body
: Node_Id
;
9656 Prev_Formal
: Entity_Id
;
9658 Unit_Renaming
: Node_Id
;
9660 Parent_Installed
: Boolean := False;
9661 Save_Style_Check
: constant Boolean := Style_Check
;
9663 Par_Ent
: Entity_Id
:= Empty
;
9664 Par_Vis
: Boolean := False;
9667 Gen_Body_Id
:= Corresponding_Body
(Gen_Decl
);
9669 -- Subprogram body may have been created already because of an inline
9670 -- pragma, or because of multiple elaborations of the enclosing package
9671 -- when several instances of the subprogram appear in the main unit.
9673 if Present
(Corresponding_Body
(Act_Decl
)) then
9677 Expander_Mode_Save_And_Set
(Body_Info
.Expander_Status
);
9679 -- Re-establish the state of information on which checks are suppressed.
9680 -- This information was set in Body_Info at the point of instantiation,
9681 -- and now we restore it so that the instance is compiled using the
9682 -- check status at the instantiation (RM 11.5 (7.2/2), AI95-00224-01).
9684 Local_Suppress_Stack_Top
:= Body_Info
.Local_Suppress_Stack_Top
;
9685 Scope_Suppress
:= Body_Info
.Scope_Suppress
;
9686 Opt
.Ada_Version
:= Body_Info
.Version
;
9688 if No
(Gen_Body_Id
) then
9690 -- For imported generic subprogram, no body to compile, complete
9691 -- the spec entity appropriately.
9693 if Is_Imported
(Gen_Unit
) then
9694 Set_Is_Imported
(Anon_Id
);
9695 Set_First_Rep_Item
(Anon_Id
, First_Rep_Item
(Gen_Unit
));
9696 Set_Interface_Name
(Anon_Id
, Interface_Name
(Gen_Unit
));
9697 Set_Convention
(Anon_Id
, Convention
(Gen_Unit
));
9698 Set_Has_Completion
(Anon_Id
);
9701 -- For other cases, compile the body
9704 Load_Parent_Of_Generic
9705 (Inst_Node
, Specification
(Gen_Decl
), Body_Optional
);
9706 Gen_Body_Id
:= Corresponding_Body
(Gen_Decl
);
9710 Instantiation_Node
:= Inst_Node
;
9712 if Present
(Gen_Body_Id
) then
9713 Gen_Body
:= Unit_Declaration_Node
(Gen_Body_Id
);
9715 if Nkind
(Gen_Body
) = N_Subprogram_Body_Stub
then
9717 -- Either body is not present, or context is non-expanding, as
9718 -- when compiling a subunit. Mark the instance as completed, and
9719 -- diagnose a missing body when needed.
9722 and then Operating_Mode
= Generate_Code
9725 ("missing proper body for instantiation", Gen_Body
);
9728 Set_Has_Completion
(Anon_Id
);
9732 Save_Env
(Gen_Unit
, Anon_Id
);
9733 Style_Check
:= False;
9734 Current_Sem_Unit
:= Body_Info
.Current_Sem_Unit
;
9735 Create_Instantiation_Source
9743 (Original_Node
(Gen_Body
), Empty
, Instantiating
=> True);
9745 -- Create proper defining name for the body, to correspond to
9746 -- the one in the spec.
9748 Set_Defining_Unit_Name
(Specification
(Act_Body
),
9749 Make_Defining_Identifier
9750 (Sloc
(Defining_Entity
(Inst_Node
)), Chars
(Anon_Id
)));
9751 Set_Corresponding_Spec
(Act_Body
, Anon_Id
);
9752 Set_Has_Completion
(Anon_Id
);
9753 Check_Generic_Actuals
(Pack_Id
, False);
9755 -- Generate a reference to link the visible subprogram instance to
9756 -- the generic body, which for navigation purposes is the only
9757 -- available source for the instance.
9760 (Related_Instance
(Pack_Id
),
9761 Gen_Body_Id
, 'b', Set_Ref
=> False, Force
=> True);
9763 -- If it is a child unit, make the parent instance (which is an
9764 -- instance of the parent of the generic) visible. The parent
9765 -- instance is the prefix of the name of the generic unit.
9767 if Ekind
(Scope
(Gen_Unit
)) = E_Generic_Package
9768 and then Nkind
(Gen_Id
) = N_Expanded_Name
9770 Par_Ent
:= Entity
(Prefix
(Gen_Id
));
9771 Par_Vis
:= Is_Immediately_Visible
(Par_Ent
);
9772 Install_Parent
(Par_Ent
, In_Body
=> True);
9773 Parent_Installed
:= True;
9775 elsif Is_Child_Unit
(Gen_Unit
) then
9776 Par_Ent
:= Scope
(Gen_Unit
);
9777 Par_Vis
:= Is_Immediately_Visible
(Par_Ent
);
9778 Install_Parent
(Par_Ent
, In_Body
=> True);
9779 Parent_Installed
:= True;
9782 -- Inside its body, a reference to the generic unit is a reference
9783 -- to the instance. The corresponding renaming is the first
9784 -- declaration in the body.
9787 Make_Subprogram_Renaming_Declaration
(Loc
,
9790 Specification
(Original_Node
(Gen_Body
)),
9792 Instantiating
=> True),
9793 Name
=> New_Occurrence_Of
(Anon_Id
, Loc
));
9795 -- If there is a formal subprogram with the same name as the unit
9796 -- itself, do not add this renaming declaration. This is a temporary
9797 -- fix for one ACVC test. ???
9799 Prev_Formal
:= First_Entity
(Pack_Id
);
9800 while Present
(Prev_Formal
) loop
9801 if Chars
(Prev_Formal
) = Chars
(Gen_Unit
)
9802 and then Is_Overloadable
(Prev_Formal
)
9807 Next_Entity
(Prev_Formal
);
9810 if Present
(Prev_Formal
) then
9811 Decls
:= New_List
(Act_Body
);
9813 Decls
:= New_List
(Unit_Renaming
, Act_Body
);
9816 -- The subprogram body is placed in the body of a dummy package body,
9817 -- whose spec contains the subprogram declaration as well as the
9818 -- renaming declarations for the generic parameters.
9820 Pack_Body
:= Make_Package_Body
(Loc
,
9821 Defining_Unit_Name
=> New_Copy
(Pack_Id
),
9822 Declarations
=> Decls
);
9824 Set_Corresponding_Spec
(Pack_Body
, Pack_Id
);
9826 -- If the instantiation is a library unit, then build resulting
9827 -- compilation unit nodes for the instance. The declaration of
9828 -- the enclosing package is the grandparent of the subprogram
9829 -- declaration. First replace the instantiation node as the unit
9830 -- of the corresponding compilation.
9832 if Nkind
(Parent
(Inst_Node
)) = N_Compilation_Unit
then
9833 if Parent
(Inst_Node
) = Cunit
(Main_Unit
) then
9834 Set_Unit
(Parent
(Inst_Node
), Inst_Node
);
9835 Build_Instance_Compilation_Unit_Nodes
9836 (Inst_Node
, Pack_Body
, Parent
(Parent
(Act_Decl
)));
9837 Analyze
(Inst_Node
);
9839 Set_Parent
(Pack_Body
, Parent
(Inst_Node
));
9840 Analyze
(Pack_Body
);
9844 Insert_Before
(Inst_Node
, Pack_Body
);
9845 Mark_Rewrite_Insertion
(Pack_Body
);
9846 Analyze
(Pack_Body
);
9848 if Expander_Active
then
9849 Freeze_Subprogram_Body
(Inst_Node
, Gen_Body
, Pack_Id
);
9853 Inherit_Context
(Gen_Body
, Inst_Node
);
9855 Restore_Private_Views
(Pack_Id
, False);
9857 if Parent_Installed
then
9858 Remove_Parent
(In_Body
=> True);
9860 -- Restore the previous visibility of the parent
9862 Set_Is_Immediately_Visible
(Par_Ent
, Par_Vis
);
9866 Style_Check
:= Save_Style_Check
;
9868 -- Body not found. Error was emitted already. If there were no previous
9869 -- errors, this may be an instance whose scope is a premature instance.
9870 -- In that case we must insure that the (legal) program does raise
9871 -- program error if executed. We generate a subprogram body for this
9872 -- purpose. See DEC ac30vso.
9874 -- Should not reference proprietary DEC tests in comments ???
9876 elsif Serious_Errors_Detected
= 0
9877 and then Nkind
(Parent
(Inst_Node
)) /= N_Compilation_Unit
9879 if Body_Optional
then
9882 elsif Ekind
(Anon_Id
) = E_Procedure
then
9884 Make_Subprogram_Body
(Loc
,
9886 Make_Procedure_Specification
(Loc
,
9887 Defining_Unit_Name
=>
9888 Make_Defining_Identifier
(Loc
, Chars
(Anon_Id
)),
9889 Parameter_Specifications
=>
9891 (Parameter_Specifications
(Parent
(Anon_Id
)))),
9893 Declarations
=> Empty_List
,
9894 Handled_Statement_Sequence
=>
9895 Make_Handled_Sequence_Of_Statements
(Loc
,
9898 Make_Raise_Program_Error
(Loc
,
9900 PE_Access_Before_Elaboration
))));
9904 Make_Raise_Program_Error
(Loc
,
9905 Reason
=> PE_Access_Before_Elaboration
);
9907 Set_Etype
(Ret_Expr
, (Etype
(Anon_Id
)));
9908 Set_Analyzed
(Ret_Expr
);
9911 Make_Subprogram_Body
(Loc
,
9913 Make_Function_Specification
(Loc
,
9914 Defining_Unit_Name
=>
9915 Make_Defining_Identifier
(Loc
, Chars
(Anon_Id
)),
9916 Parameter_Specifications
=>
9918 (Parameter_Specifications
(Parent
(Anon_Id
))),
9919 Result_Definition
=>
9920 New_Occurrence_Of
(Etype
(Anon_Id
), Loc
)),
9922 Declarations
=> Empty_List
,
9923 Handled_Statement_Sequence
=>
9924 Make_Handled_Sequence_Of_Statements
(Loc
,
9927 (Make_Simple_Return_Statement
(Loc
, Ret_Expr
))));
9930 Pack_Body
:= Make_Package_Body
(Loc
,
9931 Defining_Unit_Name
=> New_Copy
(Pack_Id
),
9932 Declarations
=> New_List
(Act_Body
));
9934 Insert_After
(Inst_Node
, Pack_Body
);
9935 Set_Corresponding_Spec
(Pack_Body
, Pack_Id
);
9936 Analyze
(Pack_Body
);
9939 Expander_Mode_Restore
;
9940 end Instantiate_Subprogram_Body
;
9942 ----------------------
9943 -- Instantiate_Type --
9944 ----------------------
9946 function Instantiate_Type
9949 Analyzed_Formal
: Node_Id
;
9950 Actual_Decls
: List_Id
) return List_Id
9952 Gen_T
: constant Entity_Id
:= Defining_Identifier
(Formal
);
9953 A_Gen_T
: constant Entity_Id
:=
9954 Defining_Identifier
(Analyzed_Formal
);
9955 Ancestor
: Entity_Id
:= Empty
;
9956 Def
: constant Node_Id
:= Formal_Type_Definition
(Formal
);
9958 Decl_Node
: Node_Id
;
9959 Decl_Nodes
: List_Id
;
9963 procedure Validate_Array_Type_Instance
;
9964 procedure Validate_Access_Subprogram_Instance
;
9965 procedure Validate_Access_Type_Instance
;
9966 procedure Validate_Derived_Type_Instance
;
9967 procedure Validate_Derived_Interface_Type_Instance
;
9968 procedure Validate_Discriminated_Formal_Type
;
9969 procedure Validate_Interface_Type_Instance
;
9970 procedure Validate_Private_Type_Instance
;
9971 procedure Validate_Incomplete_Type_Instance
;
9972 -- These procedures perform validation tests for the named case.
9973 -- Validate_Discriminated_Formal_Type is shared by formal private
9974 -- types and Ada 2012 formal incomplete types.
9976 function Subtypes_Match
(Gen_T
, Act_T
: Entity_Id
) return Boolean;
9977 -- Check that base types are the same and that the subtypes match
9978 -- statically. Used in several of the above.
9980 --------------------
9981 -- Subtypes_Match --
9982 --------------------
9984 function Subtypes_Match
(Gen_T
, Act_T
: Entity_Id
) return Boolean is
9985 T
: constant Entity_Id
:= Get_Instance_Of
(Gen_T
);
9988 return (Base_Type
(T
) = Base_Type
(Act_T
)
9989 and then Subtypes_Statically_Match
(T
, Act_T
))
9991 or else (Is_Class_Wide_Type
(Gen_T
)
9992 and then Is_Class_Wide_Type
(Act_T
)
9995 (Get_Instance_Of
(Root_Type
(Gen_T
)),
9999 ((Ekind
(Gen_T
) = E_Anonymous_Access_Subprogram_Type
10000 or else Ekind
(Gen_T
) = E_Anonymous_Access_Type
)
10001 and then Ekind
(Act_T
) = Ekind
(Gen_T
)
10003 Subtypes_Statically_Match
10004 (Designated_Type
(Gen_T
), Designated_Type
(Act_T
)));
10005 end Subtypes_Match
;
10007 -----------------------------------------
10008 -- Validate_Access_Subprogram_Instance --
10009 -----------------------------------------
10011 procedure Validate_Access_Subprogram_Instance
is
10013 if not Is_Access_Type
(Act_T
)
10014 or else Ekind
(Designated_Type
(Act_T
)) /= E_Subprogram_Type
10017 ("expect access type in instantiation of &", Actual
, Gen_T
);
10018 Abandon_Instantiation
(Actual
);
10021 Check_Mode_Conformant
10022 (Designated_Type
(Act_T
),
10023 Designated_Type
(A_Gen_T
),
10027 if Ekind
(Base_Type
(Act_T
)) = E_Access_Protected_Subprogram_Type
then
10028 if Ekind
(A_Gen_T
) = E_Access_Subprogram_Type
then
10030 ("protected access type not allowed for formal &",
10034 elsif Ekind
(A_Gen_T
) = E_Access_Protected_Subprogram_Type
then
10036 ("expect protected access type for formal &",
10039 end Validate_Access_Subprogram_Instance
;
10041 -----------------------------------
10042 -- Validate_Access_Type_Instance --
10043 -----------------------------------
10045 procedure Validate_Access_Type_Instance
is
10046 Desig_Type
: constant Entity_Id
:=
10047 Find_Actual_Type
(Designated_Type
(A_Gen_T
), A_Gen_T
);
10048 Desig_Act
: Entity_Id
;
10051 if not Is_Access_Type
(Act_T
) then
10053 ("expect access type in instantiation of &", Actual
, Gen_T
);
10054 Abandon_Instantiation
(Actual
);
10057 if Is_Access_Constant
(A_Gen_T
) then
10058 if not Is_Access_Constant
(Act_T
) then
10060 ("actual type must be access-to-constant type", Actual
);
10061 Abandon_Instantiation
(Actual
);
10064 if Is_Access_Constant
(Act_T
) then
10066 ("actual type must be access-to-variable type", Actual
);
10067 Abandon_Instantiation
(Actual
);
10069 elsif Ekind
(A_Gen_T
) = E_General_Access_Type
10070 and then Ekind
(Base_Type
(Act_T
)) /= E_General_Access_Type
10072 Error_Msg_N
-- CODEFIX
10073 ("actual must be general access type!", Actual
);
10074 Error_Msg_NE
-- CODEFIX
10075 ("add ALL to }!", Actual
, Act_T
);
10076 Abandon_Instantiation
(Actual
);
10080 -- The designated subtypes, that is to say the subtypes introduced
10081 -- by an access type declaration (and not by a subtype declaration)
10084 Desig_Act
:= Designated_Type
(Base_Type
(Act_T
));
10086 -- The designated type may have been introduced through a limited_
10087 -- with clause, in which case retrieve the non-limited view. This
10088 -- applies to incomplete types as well as to class-wide types.
10090 if From_With_Type
(Desig_Act
) then
10091 Desig_Act
:= Available_View
(Desig_Act
);
10094 if not Subtypes_Match
10095 (Desig_Type
, Desig_Act
) then
10097 ("designated type of actual does not match that of formal &",
10099 Abandon_Instantiation
(Actual
);
10101 elsif Is_Access_Type
(Designated_Type
(Act_T
))
10102 and then Is_Constrained
(Designated_Type
(Designated_Type
(Act_T
)))
10104 Is_Constrained
(Designated_Type
(Desig_Type
))
10107 ("designated type of actual does not match that of formal &",
10109 Abandon_Instantiation
(Actual
);
10112 -- Ada 2005: null-exclusion indicators of the two types must agree
10114 if Can_Never_Be_Null
(A_Gen_T
) /= Can_Never_Be_Null
(Act_T
) then
10116 ("non null exclusion of actual and formal & do not match",
10119 end Validate_Access_Type_Instance
;
10121 ----------------------------------
10122 -- Validate_Array_Type_Instance --
10123 ----------------------------------
10125 procedure Validate_Array_Type_Instance
is
10130 function Formal_Dimensions
return Int
;
10131 -- Count number of dimensions in array type formal
10133 -----------------------
10134 -- Formal_Dimensions --
10135 -----------------------
10137 function Formal_Dimensions
return Int
is
10142 if Nkind
(Def
) = N_Constrained_Array_Definition
then
10143 Index
:= First
(Discrete_Subtype_Definitions
(Def
));
10145 Index
:= First
(Subtype_Marks
(Def
));
10148 while Present
(Index
) loop
10150 Next_Index
(Index
);
10154 end Formal_Dimensions
;
10156 -- Start of processing for Validate_Array_Type_Instance
10159 if not Is_Array_Type
(Act_T
) then
10161 ("expect array type in instantiation of &", Actual
, Gen_T
);
10162 Abandon_Instantiation
(Actual
);
10164 elsif Nkind
(Def
) = N_Constrained_Array_Definition
then
10165 if not (Is_Constrained
(Act_T
)) then
10167 ("expect constrained array in instantiation of &",
10169 Abandon_Instantiation
(Actual
);
10173 if Is_Constrained
(Act_T
) then
10175 ("expect unconstrained array in instantiation of &",
10177 Abandon_Instantiation
(Actual
);
10181 if Formal_Dimensions
/= Number_Dimensions
(Act_T
) then
10183 ("dimensions of actual do not match formal &", Actual
, Gen_T
);
10184 Abandon_Instantiation
(Actual
);
10187 I1
:= First_Index
(A_Gen_T
);
10188 I2
:= First_Index
(Act_T
);
10189 for J
in 1 .. Formal_Dimensions
loop
10191 -- If the indexes of the actual were given by a subtype_mark,
10192 -- the index was transformed into a range attribute. Retrieve
10193 -- the original type mark for checking.
10195 if Is_Entity_Name
(Original_Node
(I2
)) then
10196 T2
:= Entity
(Original_Node
(I2
));
10201 if not Subtypes_Match
10202 (Find_Actual_Type
(Etype
(I1
), A_Gen_T
), T2
)
10205 ("index types of actual do not match those of formal &",
10207 Abandon_Instantiation
(Actual
);
10214 -- Check matching subtypes. Note that there are complex visibility
10215 -- issues when the generic is a child unit and some aspect of the
10216 -- generic type is declared in a parent unit of the generic. We do
10217 -- the test to handle this special case only after a direct check
10218 -- for static matching has failed.
10221 (Component_Type
(A_Gen_T
), Component_Type
(Act_T
))
10222 or else Subtypes_Match
10223 (Find_Actual_Type
(Component_Type
(A_Gen_T
), A_Gen_T
),
10224 Component_Type
(Act_T
))
10229 ("component subtype of actual does not match that of formal &",
10231 Abandon_Instantiation
(Actual
);
10234 if Has_Aliased_Components
(A_Gen_T
)
10235 and then not Has_Aliased_Components
(Act_T
)
10238 ("actual must have aliased components to match formal type &",
10241 end Validate_Array_Type_Instance
;
10243 -----------------------------------------------
10244 -- Validate_Derived_Interface_Type_Instance --
10245 -----------------------------------------------
10247 procedure Validate_Derived_Interface_Type_Instance
is
10248 Par
: constant Entity_Id
:= Entity
(Subtype_Indication
(Def
));
10252 -- First apply interface instance checks
10254 Validate_Interface_Type_Instance
;
10256 -- Verify that immediate parent interface is an ancestor of
10260 and then not Interface_Present_In_Ancestor
(Act_T
, Par
)
10263 ("interface actual must include progenitor&", Actual
, Par
);
10266 -- Now verify that the actual includes all other ancestors of
10269 Elmt
:= First_Elmt
(Interfaces
(A_Gen_T
));
10270 while Present
(Elmt
) loop
10271 if not Interface_Present_In_Ancestor
10272 (Act_T
, Get_Instance_Of
(Node
(Elmt
)))
10275 ("interface actual must include progenitor&",
10276 Actual
, Node
(Elmt
));
10281 end Validate_Derived_Interface_Type_Instance
;
10283 ------------------------------------
10284 -- Validate_Derived_Type_Instance --
10285 ------------------------------------
10287 procedure Validate_Derived_Type_Instance
is
10288 Actual_Discr
: Entity_Id
;
10289 Ancestor_Discr
: Entity_Id
;
10292 -- If the parent type in the generic declaration is itself a previous
10293 -- formal type, then it is local to the generic and absent from the
10294 -- analyzed generic definition. In that case the ancestor is the
10295 -- instance of the formal (which must have been instantiated
10296 -- previously), unless the ancestor is itself a formal derived type.
10297 -- In this latter case (which is the subject of Corrigendum 8652/0038
10298 -- (AI-202) the ancestor of the formals is the ancestor of its
10299 -- parent. Otherwise, the analyzed generic carries the parent type.
10300 -- If the parent type is defined in a previous formal package, then
10301 -- the scope of that formal package is that of the generic type
10302 -- itself, and it has already been mapped into the corresponding type
10303 -- in the actual package.
10305 -- Common case: parent type defined outside of the generic
10307 if Is_Entity_Name
(Subtype_Mark
(Def
))
10308 and then Present
(Entity
(Subtype_Mark
(Def
)))
10310 Ancestor
:= Get_Instance_Of
(Entity
(Subtype_Mark
(Def
)));
10312 -- Check whether parent is defined in a previous formal package
10315 Scope
(Scope
(Base_Type
(Etype
(A_Gen_T
)))) = Scope
(A_Gen_T
)
10318 Get_Instance_Of
(Base_Type
(Etype
(A_Gen_T
)));
10320 -- The type may be a local derivation, or a type extension of a
10321 -- previous formal, or of a formal of a parent package.
10323 elsif Is_Derived_Type
(Get_Instance_Of
(A_Gen_T
))
10325 Ekind
(Get_Instance_Of
(A_Gen_T
)) = E_Record_Type_With_Private
10327 -- Check whether the parent is another derived formal type in the
10328 -- same generic unit.
10330 if Etype
(A_Gen_T
) /= A_Gen_T
10331 and then Is_Generic_Type
(Etype
(A_Gen_T
))
10332 and then Scope
(Etype
(A_Gen_T
)) = Scope
(A_Gen_T
)
10333 and then Etype
(Etype
(A_Gen_T
)) /= Etype
(A_Gen_T
)
10335 -- Locate ancestor of parent from the subtype declaration
10336 -- created for the actual.
10342 Decl
:= First
(Actual_Decls
);
10343 while Present
(Decl
) loop
10344 if Nkind
(Decl
) = N_Subtype_Declaration
10345 and then Chars
(Defining_Identifier
(Decl
)) =
10346 Chars
(Etype
(A_Gen_T
))
10348 Ancestor
:= Generic_Parent_Type
(Decl
);
10356 pragma Assert
(Present
(Ancestor
));
10360 Get_Instance_Of
(Base_Type
(Get_Instance_Of
(A_Gen_T
)));
10364 Ancestor
:= Get_Instance_Of
(Etype
(Base_Type
(A_Gen_T
)));
10367 -- If the formal derived type has pragma Preelaborable_Initialization
10368 -- then the actual type must have preelaborable initialization.
10370 if Known_To_Have_Preelab_Init
(A_Gen_T
)
10371 and then not Has_Preelaborable_Initialization
(Act_T
)
10374 ("actual for & must have preelaborable initialization",
10378 -- Ada 2005 (AI-251)
10380 if Ada_Version
>= Ada_2005
10381 and then Is_Interface
(Ancestor
)
10383 if not Interface_Present_In_Ancestor
(Act_T
, Ancestor
) then
10385 ("(Ada 2005) expected type implementing & in instantiation",
10389 elsif not Is_Ancestor
(Base_Type
(Ancestor
), Act_T
) then
10391 ("expect type derived from & in instantiation",
10392 Actual
, First_Subtype
(Ancestor
));
10393 Abandon_Instantiation
(Actual
);
10396 -- Ada 2005 (AI-443): Synchronized formal derived type checks. Note
10397 -- that the formal type declaration has been rewritten as a private
10400 if Ada_Version
>= Ada_2005
10401 and then Nkind
(Parent
(A_Gen_T
)) = N_Private_Extension_Declaration
10402 and then Synchronized_Present
(Parent
(A_Gen_T
))
10404 -- The actual must be a synchronized tagged type
10406 if not Is_Tagged_Type
(Act_T
) then
10408 ("actual of synchronized type must be tagged", Actual
);
10409 Abandon_Instantiation
(Actual
);
10411 elsif Nkind
(Parent
(Act_T
)) = N_Full_Type_Declaration
10412 and then Nkind
(Type_Definition
(Parent
(Act_T
))) =
10413 N_Derived_Type_Definition
10414 and then not Synchronized_Present
(Type_Definition
10418 ("actual of synchronized type must be synchronized", Actual
);
10419 Abandon_Instantiation
(Actual
);
10423 -- Perform atomic/volatile checks (RM C.6(12)). Note that AI05-0218-1
10424 -- removes the second instance of the phrase "or allow pass by copy".
10426 if Is_Atomic
(Act_T
) and then not Is_Atomic
(Ancestor
) then
10428 ("cannot have atomic actual type for non-atomic formal type",
10431 elsif Is_Volatile
(Act_T
) and then not Is_Volatile
(Ancestor
) then
10433 ("cannot have volatile actual type for non-volatile formal type",
10437 -- It should not be necessary to check for unknown discriminants on
10438 -- Formal, but for some reason Has_Unknown_Discriminants is false for
10439 -- A_Gen_T, so Is_Indefinite_Subtype incorrectly returns False. This
10440 -- needs fixing. ???
10442 if not Is_Indefinite_Subtype
(A_Gen_T
)
10443 and then not Unknown_Discriminants_Present
(Formal
)
10444 and then Is_Indefinite_Subtype
(Act_T
)
10447 ("actual subtype must be constrained", Actual
);
10448 Abandon_Instantiation
(Actual
);
10451 if not Unknown_Discriminants_Present
(Formal
) then
10452 if Is_Constrained
(Ancestor
) then
10453 if not Is_Constrained
(Act_T
) then
10455 ("actual subtype must be constrained", Actual
);
10456 Abandon_Instantiation
(Actual
);
10459 -- Ancestor is unconstrained, Check if generic formal and actual
10460 -- agree on constrainedness. The check only applies to array types
10461 -- and discriminated types.
10463 elsif Is_Constrained
(Act_T
) then
10464 if Ekind
(Ancestor
) = E_Access_Type
10466 (not Is_Constrained
(A_Gen_T
)
10467 and then Is_Composite_Type
(A_Gen_T
))
10470 ("actual subtype must be unconstrained", Actual
);
10471 Abandon_Instantiation
(Actual
);
10474 -- A class-wide type is only allowed if the formal has unknown
10477 elsif Is_Class_Wide_Type
(Act_T
)
10478 and then not Has_Unknown_Discriminants
(Ancestor
)
10481 ("actual for & cannot be a class-wide type", Actual
, Gen_T
);
10482 Abandon_Instantiation
(Actual
);
10484 -- Otherwise, the formal and actual shall have the same number
10485 -- of discriminants and each discriminant of the actual must
10486 -- correspond to a discriminant of the formal.
10488 elsif Has_Discriminants
(Act_T
)
10489 and then not Has_Unknown_Discriminants
(Act_T
)
10490 and then Has_Discriminants
(Ancestor
)
10492 Actual_Discr
:= First_Discriminant
(Act_T
);
10493 Ancestor_Discr
:= First_Discriminant
(Ancestor
);
10494 while Present
(Actual_Discr
)
10495 and then Present
(Ancestor_Discr
)
10497 if Base_Type
(Act_T
) /= Base_Type
(Ancestor
) and then
10498 No
(Corresponding_Discriminant
(Actual_Discr
))
10501 ("discriminant & does not correspond " &
10502 "to ancestor discriminant", Actual
, Actual_Discr
);
10503 Abandon_Instantiation
(Actual
);
10506 Next_Discriminant
(Actual_Discr
);
10507 Next_Discriminant
(Ancestor_Discr
);
10510 if Present
(Actual_Discr
) or else Present
(Ancestor_Discr
) then
10512 ("actual for & must have same number of discriminants",
10514 Abandon_Instantiation
(Actual
);
10517 -- This case should be caught by the earlier check for
10518 -- constrainedness, but the check here is added for completeness.
10520 elsif Has_Discriminants
(Act_T
)
10521 and then not Has_Unknown_Discriminants
(Act_T
)
10524 ("actual for & must not have discriminants", Actual
, Gen_T
);
10525 Abandon_Instantiation
(Actual
);
10527 elsif Has_Discriminants
(Ancestor
) then
10529 ("actual for & must have known discriminants", Actual
, Gen_T
);
10530 Abandon_Instantiation
(Actual
);
10533 if not Subtypes_Statically_Compatible
(Act_T
, Ancestor
) then
10535 ("constraint on actual is incompatible with formal", Actual
);
10536 Abandon_Instantiation
(Actual
);
10540 -- If the formal and actual types are abstract, check that there
10541 -- are no abstract primitives of the actual type that correspond to
10542 -- nonabstract primitives of the formal type (second sentence of
10545 if Is_Abstract_Type
(A_Gen_T
) and then Is_Abstract_Type
(Act_T
) then
10546 Check_Abstract_Primitives
: declare
10547 Gen_Prims
: constant Elist_Id
:=
10548 Primitive_Operations
(A_Gen_T
);
10549 Gen_Elmt
: Elmt_Id
;
10550 Gen_Subp
: Entity_Id
;
10551 Anc_Subp
: Entity_Id
;
10552 Anc_Formal
: Entity_Id
;
10553 Anc_F_Type
: Entity_Id
;
10555 Act_Prims
: constant Elist_Id
:= Primitive_Operations
(Act_T
);
10556 Act_Elmt
: Elmt_Id
;
10557 Act_Subp
: Entity_Id
;
10558 Act_Formal
: Entity_Id
;
10559 Act_F_Type
: Entity_Id
;
10561 Subprograms_Correspond
: Boolean;
10563 function Is_Tagged_Ancestor
(T1
, T2
: Entity_Id
) return Boolean;
10564 -- Returns true if T2 is derived directly or indirectly from
10565 -- T1, including derivations from interfaces. T1 and T2 are
10566 -- required to be specific tagged base types.
10568 ------------------------
10569 -- Is_Tagged_Ancestor --
10570 ------------------------
10572 function Is_Tagged_Ancestor
(T1
, T2
: Entity_Id
) return Boolean
10574 Intfc_Elmt
: Elmt_Id
;
10577 -- The predicate is satisfied if the types are the same
10582 -- If we've reached the top of the derivation chain then
10583 -- we know that T1 is not an ancestor of T2.
10585 elsif Etype
(T2
) = T2
then
10588 -- Proceed to check T2's immediate parent
10590 elsif Is_Ancestor
(T1
, Base_Type
(Etype
(T2
))) then
10593 -- Finally, check to see if T1 is an ancestor of any of T2's
10597 Intfc_Elmt
:= First_Elmt
(Interfaces
(T2
));
10598 while Present
(Intfc_Elmt
) loop
10599 if Is_Ancestor
(T1
, Node
(Intfc_Elmt
)) then
10603 Next_Elmt
(Intfc_Elmt
);
10608 end Is_Tagged_Ancestor
;
10610 -- Start of processing for Check_Abstract_Primitives
10613 -- Loop over all of the formal derived type's primitives
10615 Gen_Elmt
:= First_Elmt
(Gen_Prims
);
10616 while Present
(Gen_Elmt
) loop
10617 Gen_Subp
:= Node
(Gen_Elmt
);
10619 -- If the primitive of the formal is not abstract, then
10620 -- determine whether there is a corresponding primitive of
10621 -- the actual type that's abstract.
10623 if not Is_Abstract_Subprogram
(Gen_Subp
) then
10624 Act_Elmt
:= First_Elmt
(Act_Prims
);
10625 while Present
(Act_Elmt
) loop
10626 Act_Subp
:= Node
(Act_Elmt
);
10628 -- If we find an abstract primitive of the actual,
10629 -- then we need to test whether it corresponds to the
10630 -- subprogram from which the generic formal primitive
10633 if Is_Abstract_Subprogram
(Act_Subp
) then
10634 Anc_Subp
:= Alias
(Gen_Subp
);
10636 -- Test whether we have a corresponding primitive
10637 -- by comparing names, kinds, formal types, and
10640 if Chars
(Anc_Subp
) = Chars
(Act_Subp
)
10641 and then Ekind
(Anc_Subp
) = Ekind
(Act_Subp
)
10643 Anc_Formal
:= First_Formal
(Anc_Subp
);
10644 Act_Formal
:= First_Formal
(Act_Subp
);
10645 while Present
(Anc_Formal
)
10646 and then Present
(Act_Formal
)
10648 Anc_F_Type
:= Etype
(Anc_Formal
);
10649 Act_F_Type
:= Etype
(Act_Formal
);
10651 if Ekind
(Anc_F_Type
)
10652 = E_Anonymous_Access_Type
10654 Anc_F_Type
:= Designated_Type
(Anc_F_Type
);
10656 if Ekind
(Act_F_Type
)
10657 = E_Anonymous_Access_Type
10660 Designated_Type
(Act_F_Type
);
10666 Ekind
(Act_F_Type
) = E_Anonymous_Access_Type
10671 Anc_F_Type
:= Base_Type
(Anc_F_Type
);
10672 Act_F_Type
:= Base_Type
(Act_F_Type
);
10674 -- If the formal is controlling, then the
10675 -- the type of the actual primitive's formal
10676 -- must be derived directly or indirectly
10677 -- from the type of the ancestor primitive's
10680 if Is_Controlling_Formal
(Anc_Formal
) then
10681 if not Is_Tagged_Ancestor
10682 (Anc_F_Type
, Act_F_Type
)
10687 -- Otherwise the types of the formals must
10690 elsif Anc_F_Type
/= Act_F_Type
then
10694 Next_Entity
(Anc_Formal
);
10695 Next_Entity
(Act_Formal
);
10698 -- If we traversed through all of the formals
10699 -- then so far the subprograms correspond, so
10700 -- now check that any result types correspond.
10702 if No
(Anc_Formal
) and then No
(Act_Formal
) then
10703 Subprograms_Correspond
:= True;
10705 if Ekind
(Act_Subp
) = E_Function
then
10706 Anc_F_Type
:= Etype
(Anc_Subp
);
10707 Act_F_Type
:= Etype
(Act_Subp
);
10709 if Ekind
(Anc_F_Type
)
10710 = E_Anonymous_Access_Type
10713 Designated_Type
(Anc_F_Type
);
10715 if Ekind
(Act_F_Type
)
10716 = E_Anonymous_Access_Type
10719 Designated_Type
(Act_F_Type
);
10721 Subprograms_Correspond
:= False;
10726 = E_Anonymous_Access_Type
10728 Subprograms_Correspond
:= False;
10731 Anc_F_Type
:= Base_Type
(Anc_F_Type
);
10732 Act_F_Type
:= Base_Type
(Act_F_Type
);
10734 -- Now either the result types must be
10735 -- the same or, if the result type is
10736 -- controlling, the result type of the
10737 -- actual primitive must descend from the
10738 -- result type of the ancestor primitive.
10740 if Subprograms_Correspond
10741 and then Anc_F_Type
/= Act_F_Type
10743 Has_Controlling_Result
(Anc_Subp
)
10745 not Is_Tagged_Ancestor
10746 (Anc_F_Type
, Act_F_Type
)
10748 Subprograms_Correspond
:= False;
10752 -- Found a matching subprogram belonging to
10753 -- formal ancestor type, so actual subprogram
10754 -- corresponds and this violates 3.9.3(9).
10756 if Subprograms_Correspond
then
10758 ("abstract subprogram & overrides " &
10759 "nonabstract subprogram of ancestor",
10767 Next_Elmt
(Act_Elmt
);
10771 Next_Elmt
(Gen_Elmt
);
10773 end Check_Abstract_Primitives
;
10776 -- Verify that limitedness matches. If parent is a limited
10777 -- interface then the generic formal is not unless declared
10778 -- explicitly so. If not declared limited, the actual cannot be
10779 -- limited (see AI05-0087).
10781 -- Even though this AI is a binding interpretation, we enable the
10782 -- check only in Ada 2012 mode, because this improper construct
10783 -- shows up in user code and in existing B-tests.
10785 if Is_Limited_Type
(Act_T
)
10786 and then not Is_Limited_Type
(A_Gen_T
)
10787 and then Ada_Version
>= Ada_2012
10789 if In_Instance
then
10793 ("actual for non-limited & cannot be a limited type", Actual
,
10795 Explain_Limited_Type
(Act_T
, Actual
);
10796 Abandon_Instantiation
(Actual
);
10799 end Validate_Derived_Type_Instance
;
10801 ----------------------------------------
10802 -- Validate_Discriminated_Formal_Type --
10803 ----------------------------------------
10805 procedure Validate_Discriminated_Formal_Type
is
10806 Formal_Discr
: Entity_Id
;
10807 Actual_Discr
: Entity_Id
;
10808 Formal_Subt
: Entity_Id
;
10811 if Has_Discriminants
(A_Gen_T
) then
10812 if not Has_Discriminants
(Act_T
) then
10814 ("actual for & must have discriminants", Actual
, Gen_T
);
10815 Abandon_Instantiation
(Actual
);
10817 elsif Is_Constrained
(Act_T
) then
10819 ("actual for & must be unconstrained", Actual
, Gen_T
);
10820 Abandon_Instantiation
(Actual
);
10823 Formal_Discr
:= First_Discriminant
(A_Gen_T
);
10824 Actual_Discr
:= First_Discriminant
(Act_T
);
10825 while Formal_Discr
/= Empty
loop
10826 if Actual_Discr
= Empty
then
10828 ("discriminants on actual do not match formal",
10830 Abandon_Instantiation
(Actual
);
10833 Formal_Subt
:= Get_Instance_Of
(Etype
(Formal_Discr
));
10835 -- Access discriminants match if designated types do
10837 if Ekind
(Base_Type
(Formal_Subt
)) = E_Anonymous_Access_Type
10838 and then (Ekind
(Base_Type
(Etype
(Actual_Discr
)))) =
10839 E_Anonymous_Access_Type
10842 (Designated_Type
(Base_Type
(Formal_Subt
))) =
10843 Designated_Type
(Base_Type
(Etype
(Actual_Discr
)))
10847 elsif Base_Type
(Formal_Subt
) /=
10848 Base_Type
(Etype
(Actual_Discr
))
10851 ("types of actual discriminants must match formal",
10853 Abandon_Instantiation
(Actual
);
10855 elsif not Subtypes_Statically_Match
10856 (Formal_Subt
, Etype
(Actual_Discr
))
10857 and then Ada_Version
>= Ada_95
10860 ("subtypes of actual discriminants must match formal",
10862 Abandon_Instantiation
(Actual
);
10865 Next_Discriminant
(Formal_Discr
);
10866 Next_Discriminant
(Actual_Discr
);
10869 if Actual_Discr
/= Empty
then
10871 ("discriminants on actual do not match formal",
10873 Abandon_Instantiation
(Actual
);
10877 end Validate_Discriminated_Formal_Type
;
10879 ---------------------------------------
10880 -- Validate_Incomplete_Type_Instance --
10881 ---------------------------------------
10883 procedure Validate_Incomplete_Type_Instance
is
10885 if not Is_Tagged_Type
(Act_T
)
10886 and then Is_Tagged_Type
(A_Gen_T
)
10889 ("actual for & must be a tagged type", Actual
, Gen_T
);
10892 Validate_Discriminated_Formal_Type
;
10893 end Validate_Incomplete_Type_Instance
;
10895 --------------------------------------
10896 -- Validate_Interface_Type_Instance --
10897 --------------------------------------
10899 procedure Validate_Interface_Type_Instance
is
10901 if not Is_Interface
(Act_T
) then
10903 ("actual for formal interface type must be an interface",
10906 elsif Is_Limited_Type
(Act_T
) /= Is_Limited_Type
(A_Gen_T
)
10908 Is_Task_Interface
(A_Gen_T
) /= Is_Task_Interface
(Act_T
)
10910 Is_Protected_Interface
(A_Gen_T
) /=
10911 Is_Protected_Interface
(Act_T
)
10913 Is_Synchronized_Interface
(A_Gen_T
) /=
10914 Is_Synchronized_Interface
(Act_T
)
10917 ("actual for interface& does not match (RM 12.5.5(4))",
10920 end Validate_Interface_Type_Instance
;
10922 ------------------------------------
10923 -- Validate_Private_Type_Instance --
10924 ------------------------------------
10926 procedure Validate_Private_Type_Instance
is
10928 if Is_Limited_Type
(Act_T
)
10929 and then not Is_Limited_Type
(A_Gen_T
)
10931 if In_Instance
then
10935 ("actual for non-limited & cannot be a limited type", Actual
,
10937 Explain_Limited_Type
(Act_T
, Actual
);
10938 Abandon_Instantiation
(Actual
);
10941 elsif Known_To_Have_Preelab_Init
(A_Gen_T
)
10942 and then not Has_Preelaborable_Initialization
(Act_T
)
10945 ("actual for & must have preelaborable initialization", Actual
,
10948 elsif Is_Indefinite_Subtype
(Act_T
)
10949 and then not Is_Indefinite_Subtype
(A_Gen_T
)
10950 and then Ada_Version
>= Ada_95
10953 ("actual for & must be a definite subtype", Actual
, Gen_T
);
10955 elsif not Is_Tagged_Type
(Act_T
)
10956 and then Is_Tagged_Type
(A_Gen_T
)
10959 ("actual for & must be a tagged type", Actual
, Gen_T
);
10962 Validate_Discriminated_Formal_Type
;
10964 end Validate_Private_Type_Instance
;
10966 -- Start of processing for Instantiate_Type
10969 if Get_Instance_Of
(A_Gen_T
) /= A_Gen_T
then
10970 Error_Msg_N
("duplicate instantiation of generic type", Actual
);
10971 return New_List
(Error
);
10973 elsif not Is_Entity_Name
(Actual
)
10974 or else not Is_Type
(Entity
(Actual
))
10977 ("expect valid subtype mark to instantiate &", Actual
, Gen_T
);
10978 Abandon_Instantiation
(Actual
);
10981 Act_T
:= Entity
(Actual
);
10983 -- Ada 2005 (AI-216): An Unchecked_Union subtype shall only be passed
10984 -- as a generic actual parameter if the corresponding formal type
10985 -- does not have a known_discriminant_part, or is a formal derived
10986 -- type that is an Unchecked_Union type.
10988 if Is_Unchecked_Union
(Base_Type
(Act_T
)) then
10989 if not Has_Discriminants
(A_Gen_T
)
10991 (Is_Derived_Type
(A_Gen_T
)
10993 Is_Unchecked_Union
(A_Gen_T
))
10997 Error_Msg_N
("Unchecked_Union cannot be the actual for a" &
10998 " discriminated formal type", Act_T
);
11003 -- Deal with fixed/floating restrictions
11005 if Is_Floating_Point_Type
(Act_T
) then
11006 Check_Restriction
(No_Floating_Point
, Actual
);
11007 elsif Is_Fixed_Point_Type
(Act_T
) then
11008 Check_Restriction
(No_Fixed_Point
, Actual
);
11011 -- Deal with error of using incomplete type as generic actual.
11012 -- This includes limited views of a type, even if the non-limited
11013 -- view may be available.
11015 if Ekind
(Act_T
) = E_Incomplete_Type
11016 or else (Is_Class_Wide_Type
(Act_T
)
11018 Ekind
(Root_Type
(Act_T
)) = E_Incomplete_Type
)
11020 -- If the formal is an incomplete type, the actual can be
11021 -- incomplete as well.
11023 if Ekind
(A_Gen_T
) = E_Incomplete_Type
then
11026 elsif Is_Class_Wide_Type
(Act_T
)
11027 or else No
(Full_View
(Act_T
))
11029 Error_Msg_N
("premature use of incomplete type", Actual
);
11030 Abandon_Instantiation
(Actual
);
11032 Act_T
:= Full_View
(Act_T
);
11033 Set_Entity
(Actual
, Act_T
);
11035 if Has_Private_Component
(Act_T
) then
11037 ("premature use of type with private component", Actual
);
11041 -- Deal with error of premature use of private type as generic actual
11043 elsif Is_Private_Type
(Act_T
)
11044 and then Is_Private_Type
(Base_Type
(Act_T
))
11045 and then not Is_Generic_Type
(Act_T
)
11046 and then not Is_Derived_Type
(Act_T
)
11047 and then No
(Full_View
(Root_Type
(Act_T
)))
11049 -- If the formal is an incomplete type, the actual can be
11050 -- private or incomplete as well.
11052 if Ekind
(A_Gen_T
) = E_Incomplete_Type
then
11055 Error_Msg_N
("premature use of private type", Actual
);
11058 elsif Has_Private_Component
(Act_T
) then
11060 ("premature use of type with private component", Actual
);
11063 Set_Instance_Of
(A_Gen_T
, Act_T
);
11065 -- If the type is generic, the class-wide type may also be used
11067 if Is_Tagged_Type
(A_Gen_T
)
11068 and then Is_Tagged_Type
(Act_T
)
11069 and then not Is_Class_Wide_Type
(A_Gen_T
)
11071 Set_Instance_Of
(Class_Wide_Type
(A_Gen_T
),
11072 Class_Wide_Type
(Act_T
));
11075 if not Is_Abstract_Type
(A_Gen_T
)
11076 and then Is_Abstract_Type
(Act_T
)
11079 ("actual of non-abstract formal cannot be abstract", Actual
);
11082 -- A generic scalar type is a first subtype for which we generate
11083 -- an anonymous base type. Indicate that the instance of this base
11084 -- is the base type of the actual.
11086 if Is_Scalar_Type
(A_Gen_T
) then
11087 Set_Instance_Of
(Etype
(A_Gen_T
), Etype
(Act_T
));
11091 if Error_Posted
(Act_T
) then
11094 case Nkind
(Def
) is
11095 when N_Formal_Private_Type_Definition
=>
11096 Validate_Private_Type_Instance
;
11098 when N_Formal_Incomplete_Type_Definition
=>
11099 Validate_Incomplete_Type_Instance
;
11101 when N_Formal_Derived_Type_Definition
=>
11102 Validate_Derived_Type_Instance
;
11104 when N_Formal_Discrete_Type_Definition
=>
11105 if not Is_Discrete_Type
(Act_T
) then
11107 ("expect discrete type in instantiation of&",
11109 Abandon_Instantiation
(Actual
);
11112 when N_Formal_Signed_Integer_Type_Definition
=>
11113 if not Is_Signed_Integer_Type
(Act_T
) then
11115 ("expect signed integer type in instantiation of&",
11117 Abandon_Instantiation
(Actual
);
11120 when N_Formal_Modular_Type_Definition
=>
11121 if not Is_Modular_Integer_Type
(Act_T
) then
11123 ("expect modular type in instantiation of &",
11125 Abandon_Instantiation
(Actual
);
11128 when N_Formal_Floating_Point_Definition
=>
11129 if not Is_Floating_Point_Type
(Act_T
) then
11131 ("expect float type in instantiation of &", Actual
, Gen_T
);
11132 Abandon_Instantiation
(Actual
);
11135 when N_Formal_Ordinary_Fixed_Point_Definition
=>
11136 if not Is_Ordinary_Fixed_Point_Type
(Act_T
) then
11138 ("expect ordinary fixed point type in instantiation of &",
11140 Abandon_Instantiation
(Actual
);
11143 when N_Formal_Decimal_Fixed_Point_Definition
=>
11144 if not Is_Decimal_Fixed_Point_Type
(Act_T
) then
11146 ("expect decimal type in instantiation of &",
11148 Abandon_Instantiation
(Actual
);
11151 when N_Array_Type_Definition
=>
11152 Validate_Array_Type_Instance
;
11154 when N_Access_To_Object_Definition
=>
11155 Validate_Access_Type_Instance
;
11157 when N_Access_Function_Definition |
11158 N_Access_Procedure_Definition
=>
11159 Validate_Access_Subprogram_Instance
;
11161 when N_Record_Definition
=>
11162 Validate_Interface_Type_Instance
;
11164 when N_Derived_Type_Definition
=>
11165 Validate_Derived_Interface_Type_Instance
;
11168 raise Program_Error
;
11173 Subt
:= New_Copy
(Gen_T
);
11175 -- Use adjusted sloc of subtype name as the location for other nodes in
11176 -- the subtype declaration.
11178 Loc
:= Sloc
(Subt
);
11181 Make_Subtype_Declaration
(Loc
,
11182 Defining_Identifier
=> Subt
,
11183 Subtype_Indication
=> New_Reference_To
(Act_T
, Loc
));
11185 if Is_Private_Type
(Act_T
) then
11186 Set_Has_Private_View
(Subtype_Indication
(Decl_Node
));
11188 elsif Is_Access_Type
(Act_T
)
11189 and then Is_Private_Type
(Designated_Type
(Act_T
))
11191 Set_Has_Private_View
(Subtype_Indication
(Decl_Node
));
11194 Decl_Nodes
:= New_List
(Decl_Node
);
11196 -- Flag actual derived types so their elaboration produces the
11197 -- appropriate renamings for the primitive operations of the ancestor.
11198 -- Flag actual for formal private types as well, to determine whether
11199 -- operations in the private part may override inherited operations.
11200 -- If the formal has an interface list, the ancestor is not the
11201 -- parent, but the analyzed formal that includes the interface
11202 -- operations of all its progenitors.
11204 -- Same treatment for formal private types, so we can check whether the
11205 -- type is tagged limited when validating derivations in the private
11206 -- part. (See AI05-096).
11208 if Nkind
(Def
) = N_Formal_Derived_Type_Definition
then
11209 if Present
(Interface_List
(Def
)) then
11210 Set_Generic_Parent_Type
(Decl_Node
, A_Gen_T
);
11212 Set_Generic_Parent_Type
(Decl_Node
, Ancestor
);
11215 elsif Nkind_In
(Def
,
11216 N_Formal_Private_Type_Definition
,
11217 N_Formal_Incomplete_Type_Definition
)
11219 Set_Generic_Parent_Type
(Decl_Node
, A_Gen_T
);
11222 -- If the actual is a synchronized type that implements an interface,
11223 -- the primitive operations are attached to the corresponding record,
11224 -- and we have to treat it as an additional generic actual, so that its
11225 -- primitive operations become visible in the instance. The task or
11226 -- protected type itself does not carry primitive operations.
11228 if Is_Concurrent_Type
(Act_T
)
11229 and then Is_Tagged_Type
(Act_T
)
11230 and then Present
(Corresponding_Record_Type
(Act_T
))
11231 and then Present
(Ancestor
)
11232 and then Is_Interface
(Ancestor
)
11235 Corr_Rec
: constant Entity_Id
:=
11236 Corresponding_Record_Type
(Act_T
);
11237 New_Corr
: Entity_Id
;
11238 Corr_Decl
: Node_Id
;
11241 New_Corr
:= Make_Temporary
(Loc
, 'S');
11243 Make_Subtype_Declaration
(Loc
,
11244 Defining_Identifier
=> New_Corr
,
11245 Subtype_Indication
=>
11246 New_Reference_To
(Corr_Rec
, Loc
));
11247 Append_To
(Decl_Nodes
, Corr_Decl
);
11249 if Ekind
(Act_T
) = E_Task_Type
then
11250 Set_Ekind
(Subt
, E_Task_Subtype
);
11252 Set_Ekind
(Subt
, E_Protected_Subtype
);
11255 Set_Corresponding_Record_Type
(Subt
, Corr_Rec
);
11256 Set_Generic_Parent_Type
(Corr_Decl
, Ancestor
);
11257 Set_Generic_Parent_Type
(Decl_Node
, Empty
);
11262 end Instantiate_Type
;
11264 ---------------------
11265 -- Is_In_Main_Unit --
11266 ---------------------
11268 function Is_In_Main_Unit
(N
: Node_Id
) return Boolean is
11269 Unum
: constant Unit_Number_Type
:= Get_Source_Unit
(N
);
11270 Current_Unit
: Node_Id
;
11273 if Unum
= Main_Unit
then
11276 -- If the current unit is a subunit then it is either the main unit or
11277 -- is being compiled as part of the main unit.
11279 elsif Nkind
(N
) = N_Compilation_Unit
then
11280 return Nkind
(Unit
(N
)) = N_Subunit
;
11283 Current_Unit
:= Parent
(N
);
11284 while Present
(Current_Unit
)
11285 and then Nkind
(Current_Unit
) /= N_Compilation_Unit
11287 Current_Unit
:= Parent
(Current_Unit
);
11290 -- The instantiation node is in the main unit, or else the current node
11291 -- (perhaps as the result of nested instantiations) is in the main unit,
11292 -- or in the declaration of the main unit, which in this last case must
11295 return Unum
= Main_Unit
11296 or else Current_Unit
= Cunit
(Main_Unit
)
11297 or else Current_Unit
= Library_Unit
(Cunit
(Main_Unit
))
11298 or else (Present
(Library_Unit
(Current_Unit
))
11299 and then Is_In_Main_Unit
(Library_Unit
(Current_Unit
)));
11300 end Is_In_Main_Unit
;
11302 ----------------------------
11303 -- Load_Parent_Of_Generic --
11304 ----------------------------
11306 procedure Load_Parent_Of_Generic
11309 Body_Optional
: Boolean := False)
11311 Comp_Unit
: constant Node_Id
:= Cunit
(Get_Source_Unit
(Spec
));
11312 Save_Style_Check
: constant Boolean := Style_Check
;
11313 True_Parent
: Node_Id
;
11314 Inst_Node
: Node_Id
;
11316 Previous_Instances
: constant Elist_Id
:= New_Elmt_List
;
11318 procedure Collect_Previous_Instances
(Decls
: List_Id
);
11319 -- Collect all instantiations in the given list of declarations, that
11320 -- precede the generic that we need to load. If the bodies of these
11321 -- instantiations are available, we must analyze them, to ensure that
11322 -- the public symbols generated are the same when the unit is compiled
11323 -- to generate code, and when it is compiled in the context of a unit
11324 -- that needs a particular nested instance. This process is applied to
11325 -- both package and subprogram instances.
11327 --------------------------------
11328 -- Collect_Previous_Instances --
11329 --------------------------------
11331 procedure Collect_Previous_Instances
(Decls
: List_Id
) is
11335 Decl
:= First
(Decls
);
11336 while Present
(Decl
) loop
11337 if Sloc
(Decl
) >= Sloc
(Inst_Node
) then
11340 -- If Decl is an instantiation, then record it as requiring
11341 -- instantiation of the corresponding body, except if it is an
11342 -- abbreviated instantiation generated internally for conformance
11343 -- checking purposes only for the case of a formal package
11344 -- declared without a box (see Instantiate_Formal_Package). Such
11345 -- an instantiation does not generate any code (the actual code
11346 -- comes from actual) and thus does not need to be analyzed here.
11347 -- If the instantiation appears with a generic package body it is
11348 -- not analyzed here either.
11350 elsif Nkind
(Decl
) = N_Package_Instantiation
11351 and then not Is_Internal
(Defining_Entity
(Decl
))
11353 Append_Elmt
(Decl
, Previous_Instances
);
11355 -- For a subprogram instantiation, omit instantiations intrinsic
11356 -- operations (Unchecked_Conversions, etc.) that have no bodies.
11358 elsif Nkind_In
(Decl
, N_Function_Instantiation
,
11359 N_Procedure_Instantiation
)
11360 and then not Is_Intrinsic_Subprogram
(Entity
(Name
(Decl
)))
11362 Append_Elmt
(Decl
, Previous_Instances
);
11364 elsif Nkind
(Decl
) = N_Package_Declaration
then
11365 Collect_Previous_Instances
11366 (Visible_Declarations
(Specification
(Decl
)));
11367 Collect_Previous_Instances
11368 (Private_Declarations
(Specification
(Decl
)));
11370 -- Previous non-generic bodies may contain instances as well
11372 elsif Nkind
(Decl
) = N_Package_Body
11373 and then Ekind
(Corresponding_Spec
(Decl
)) /= E_Generic_Package
11375 Collect_Previous_Instances
(Declarations
(Decl
));
11377 elsif Nkind
(Decl
) = N_Subprogram_Body
11378 and then not Acts_As_Spec
(Decl
)
11379 and then not Is_Generic_Subprogram
(Corresponding_Spec
(Decl
))
11381 Collect_Previous_Instances
(Declarations
(Decl
));
11386 end Collect_Previous_Instances
;
11388 -- Start of processing for Load_Parent_Of_Generic
11391 if not In_Same_Source_Unit
(N
, Spec
)
11392 or else Nkind
(Unit
(Comp_Unit
)) = N_Package_Declaration
11393 or else (Nkind
(Unit
(Comp_Unit
)) = N_Package_Body
11394 and then not Is_In_Main_Unit
(Spec
))
11396 -- Find body of parent of spec, and analyze it. A special case arises
11397 -- when the parent is an instantiation, that is to say when we are
11398 -- currently instantiating a nested generic. In that case, there is
11399 -- no separate file for the body of the enclosing instance. Instead,
11400 -- the enclosing body must be instantiated as if it were a pending
11401 -- instantiation, in order to produce the body for the nested generic
11402 -- we require now. Note that in that case the generic may be defined
11403 -- in a package body, the instance defined in the same package body,
11404 -- and the original enclosing body may not be in the main unit.
11406 Inst_Node
:= Empty
;
11408 True_Parent
:= Parent
(Spec
);
11409 while Present
(True_Parent
)
11410 and then Nkind
(True_Parent
) /= N_Compilation_Unit
11412 if Nkind
(True_Parent
) = N_Package_Declaration
11414 Nkind
(Original_Node
(True_Parent
)) = N_Package_Instantiation
11416 -- Parent is a compilation unit that is an instantiation.
11417 -- Instantiation node has been replaced with package decl.
11419 Inst_Node
:= Original_Node
(True_Parent
);
11422 elsif Nkind
(True_Parent
) = N_Package_Declaration
11423 and then Present
(Generic_Parent
(Specification
(True_Parent
)))
11424 and then Nkind
(Parent
(True_Parent
)) /= N_Compilation_Unit
11426 -- Parent is an instantiation within another specification.
11427 -- Declaration for instance has been inserted before original
11428 -- instantiation node. A direct link would be preferable?
11430 Inst_Node
:= Next
(True_Parent
);
11431 while Present
(Inst_Node
)
11432 and then Nkind
(Inst_Node
) /= N_Package_Instantiation
11437 -- If the instance appears within a generic, and the generic
11438 -- unit is defined within a formal package of the enclosing
11439 -- generic, there is no generic body available, and none
11440 -- needed. A more precise test should be used ???
11442 if No
(Inst_Node
) then
11449 True_Parent
:= Parent
(True_Parent
);
11453 -- Case where we are currently instantiating a nested generic
11455 if Present
(Inst_Node
) then
11456 if Nkind
(Parent
(True_Parent
)) = N_Compilation_Unit
then
11458 -- Instantiation node and declaration of instantiated package
11459 -- were exchanged when only the declaration was needed.
11460 -- Restore instantiation node before proceeding with body.
11462 Set_Unit
(Parent
(True_Parent
), Inst_Node
);
11465 -- Now complete instantiation of enclosing body, if it appears in
11466 -- some other unit. If it appears in the current unit, the body
11467 -- will have been instantiated already.
11469 if No
(Corresponding_Body
(Instance_Spec
(Inst_Node
))) then
11471 -- We need to determine the expander mode to instantiate the
11472 -- enclosing body. Because the generic body we need may use
11473 -- global entities declared in the enclosing package (including
11474 -- aggregates) it is in general necessary to compile this body
11475 -- with expansion enabled, except if we are within a generic
11476 -- package, in which case the usual generic rule applies.
11479 Exp_Status
: Boolean := True;
11483 -- Loop through scopes looking for generic package
11485 Scop
:= Scope
(Defining_Entity
(Instance_Spec
(Inst_Node
)));
11486 while Present
(Scop
)
11487 and then Scop
/= Standard_Standard
11489 if Ekind
(Scop
) = E_Generic_Package
then
11490 Exp_Status
:= False;
11494 Scop
:= Scope
(Scop
);
11497 -- Collect previous instantiations in the unit that contains
11498 -- the desired generic.
11500 if Nkind
(Parent
(True_Parent
)) /= N_Compilation_Unit
11501 and then not Body_Optional
11505 Info
: Pending_Body_Info
;
11509 Par
:= Parent
(Inst_Node
);
11510 while Present
(Par
) loop
11511 exit when Nkind
(Parent
(Par
)) = N_Compilation_Unit
;
11512 Par
:= Parent
(Par
);
11515 pragma Assert
(Present
(Par
));
11517 if Nkind
(Par
) = N_Package_Body
then
11518 Collect_Previous_Instances
(Declarations
(Par
));
11520 elsif Nkind
(Par
) = N_Package_Declaration
then
11521 Collect_Previous_Instances
11522 (Visible_Declarations
(Specification
(Par
)));
11523 Collect_Previous_Instances
11524 (Private_Declarations
(Specification
(Par
)));
11527 -- Enclosing unit is a subprogram body. In this
11528 -- case all instance bodies are processed in order
11529 -- and there is no need to collect them separately.
11534 Decl
:= First_Elmt
(Previous_Instances
);
11535 while Present
(Decl
) loop
11537 (Inst_Node
=> Node
(Decl
),
11539 Instance_Spec
(Node
(Decl
)),
11540 Expander_Status
=> Exp_Status
,
11541 Current_Sem_Unit
=>
11542 Get_Code_Unit
(Sloc
(Node
(Decl
))),
11543 Scope_Suppress
=> Scope_Suppress
,
11544 Local_Suppress_Stack_Top
=>
11545 Local_Suppress_Stack_Top
,
11546 Version
=> Ada_Version
);
11548 -- Package instance
11551 Nkind
(Node
(Decl
)) = N_Package_Instantiation
11553 Instantiate_Package_Body
11554 (Info
, Body_Optional
=> True);
11556 -- Subprogram instance
11559 -- The instance_spec is the wrapper package,
11560 -- and the subprogram declaration is the last
11561 -- declaration in the wrapper.
11565 (Visible_Declarations
11566 (Specification
(Info
.Act_Decl
)));
11568 Instantiate_Subprogram_Body
11569 (Info
, Body_Optional
=> True);
11577 Instantiate_Package_Body
11579 ((Inst_Node
=> Inst_Node
,
11580 Act_Decl
=> True_Parent
,
11581 Expander_Status
=> Exp_Status
,
11582 Current_Sem_Unit
=>
11583 Get_Code_Unit
(Sloc
(Inst_Node
)),
11584 Scope_Suppress
=> Scope_Suppress
,
11585 Local_Suppress_Stack_Top
=>
11586 Local_Suppress_Stack_Top
,
11587 Version
=> Ada_Version
)),
11588 Body_Optional
=> Body_Optional
);
11592 -- Case where we are not instantiating a nested generic
11595 Opt
.Style_Check
:= False;
11596 Expander_Mode_Save_And_Set
(True);
11597 Load_Needed_Body
(Comp_Unit
, OK
);
11598 Opt
.Style_Check
:= Save_Style_Check
;
11599 Expander_Mode_Restore
;
11602 and then Unit_Requires_Body
(Defining_Entity
(Spec
))
11603 and then not Body_Optional
11606 Bname
: constant Unit_Name_Type
:=
11607 Get_Body_Name
(Get_Unit_Name
(Unit
(Comp_Unit
)));
11610 -- In CodePeer mode, the missing body may make the analysis
11611 -- incomplete, but we do not treat it as fatal.
11613 if CodePeer_Mode
then
11617 Error_Msg_Unit_1
:= Bname
;
11618 Error_Msg_N
("this instantiation requires$!", N
);
11619 Error_Msg_File_1
:=
11620 Get_File_Name
(Bname
, Subunit
=> False);
11621 Error_Msg_N
("\but file{ was not found!", N
);
11622 raise Unrecoverable_Error
;
11629 -- If loading parent of the generic caused an instantiation circularity,
11630 -- we abandon compilation at this point, because otherwise in some cases
11631 -- we get into trouble with infinite recursions after this point.
11633 if Circularity_Detected
then
11634 raise Unrecoverable_Error
;
11636 end Load_Parent_Of_Generic
;
11638 ---------------------------------
11639 -- Map_Formal_Package_Entities --
11640 ---------------------------------
11642 procedure Map_Formal_Package_Entities
(Form
: Entity_Id
; Act
: Entity_Id
) is
11647 Set_Instance_Of
(Form
, Act
);
11649 -- Traverse formal and actual package to map the corresponding entities.
11650 -- We skip over internal entities that may be generated during semantic
11651 -- analysis, and find the matching entities by name, given that they
11652 -- must appear in the same order.
11654 E1
:= First_Entity
(Form
);
11655 E2
:= First_Entity
(Act
);
11656 while Present
(E1
) and then E1
/= First_Private_Entity
(Form
) loop
11657 -- Could this test be a single condition???
11658 -- Seems like it could, and isn't FPE (Form) a constant anyway???
11660 if not Is_Internal
(E1
)
11661 and then Present
(Parent
(E1
))
11662 and then not Is_Class_Wide_Type
(E1
)
11663 and then not Is_Internal_Name
(Chars
(E1
))
11665 while Present
(E2
) and then Chars
(E2
) /= Chars
(E1
) loop
11672 Set_Instance_Of
(E1
, E2
);
11674 if Is_Type
(E1
) and then Is_Tagged_Type
(E2
) then
11675 Set_Instance_Of
(Class_Wide_Type
(E1
), Class_Wide_Type
(E2
));
11678 if Is_Constrained
(E1
) then
11679 Set_Instance_Of
(Base_Type
(E1
), Base_Type
(E2
));
11682 if Ekind
(E1
) = E_Package
and then No
(Renamed_Object
(E1
)) then
11683 Map_Formal_Package_Entities
(E1
, E2
);
11690 end Map_Formal_Package_Entities
;
11692 -----------------------
11693 -- Move_Freeze_Nodes --
11694 -----------------------
11696 procedure Move_Freeze_Nodes
11697 (Out_Of
: Entity_Id
;
11702 Next_Decl
: Node_Id
;
11703 Next_Node
: Node_Id
:= After
;
11706 function Is_Outer_Type
(T
: Entity_Id
) return Boolean;
11707 -- Check whether entity is declared in a scope external to that of the
11710 -------------------
11711 -- Is_Outer_Type --
11712 -------------------
11714 function Is_Outer_Type
(T
: Entity_Id
) return Boolean is
11715 Scop
: Entity_Id
:= Scope
(T
);
11718 if Scope_Depth
(Scop
) < Scope_Depth
(Out_Of
) then
11722 while Scop
/= Standard_Standard
loop
11723 if Scop
= Out_Of
then
11726 Scop
:= Scope
(Scop
);
11734 -- Start of processing for Move_Freeze_Nodes
11741 -- First remove the freeze nodes that may appear before all other
11745 while Present
(Decl
)
11746 and then Nkind
(Decl
) = N_Freeze_Entity
11747 and then Is_Outer_Type
(Entity
(Decl
))
11749 Decl
:= Remove_Head
(L
);
11750 Insert_After
(Next_Node
, Decl
);
11751 Set_Analyzed
(Decl
, False);
11756 -- Next scan the list of declarations and remove each freeze node that
11757 -- appears ahead of the current node.
11759 while Present
(Decl
) loop
11760 while Present
(Next
(Decl
))
11761 and then Nkind
(Next
(Decl
)) = N_Freeze_Entity
11762 and then Is_Outer_Type
(Entity
(Next
(Decl
)))
11764 Next_Decl
:= Remove_Next
(Decl
);
11765 Insert_After
(Next_Node
, Next_Decl
);
11766 Set_Analyzed
(Next_Decl
, False);
11767 Next_Node
:= Next_Decl
;
11770 -- If the declaration is a nested package or concurrent type, then
11771 -- recurse. Nested generic packages will have been processed from the
11774 case Nkind
(Decl
) is
11775 when N_Package_Declaration
=>
11776 Spec
:= Specification
(Decl
);
11778 when N_Task_Type_Declaration
=>
11779 Spec
:= Task_Definition
(Decl
);
11781 when N_Protected_Type_Declaration
=>
11782 Spec
:= Protected_Definition
(Decl
);
11788 if Present
(Spec
) then
11789 Move_Freeze_Nodes
(Out_Of
, Next_Node
, Visible_Declarations
(Spec
));
11790 Move_Freeze_Nodes
(Out_Of
, Next_Node
, Private_Declarations
(Spec
));
11795 end Move_Freeze_Nodes
;
11801 function Next_Assoc
(E
: Assoc_Ptr
) return Assoc_Ptr
is
11803 return Generic_Renamings
.Table
(E
).Next_In_HTable
;
11806 ------------------------
11807 -- Preanalyze_Actuals --
11808 ------------------------
11810 procedure Preanalyze_Actuals
(N
: Node_Id
) is
11813 Errs
: constant Int
:= Serious_Errors_Detected
;
11815 Cur
: Entity_Id
:= Empty
;
11816 -- Current homograph of the instance name
11819 -- Saved visibility status of the current homograph
11822 Assoc
:= First
(Generic_Associations
(N
));
11824 -- If the instance is a child unit, its name may hide an outer homonym,
11825 -- so make it invisible to perform name resolution on the actuals.
11827 if Nkind
(Defining_Unit_Name
(N
)) = N_Defining_Program_Unit_Name
11829 (Current_Entity
(Defining_Identifier
(Defining_Unit_Name
(N
))))
11831 Cur
:= Current_Entity
(Defining_Identifier
(Defining_Unit_Name
(N
)));
11833 if Is_Compilation_Unit
(Cur
) then
11834 Vis
:= Is_Immediately_Visible
(Cur
);
11835 Set_Is_Immediately_Visible
(Cur
, False);
11841 while Present
(Assoc
) loop
11842 if Nkind
(Assoc
) /= N_Others_Choice
then
11843 Act
:= Explicit_Generic_Actual_Parameter
(Assoc
);
11845 -- Within a nested instantiation, a defaulted actual is an empty
11846 -- association, so nothing to analyze. If the subprogram actual
11847 -- is an attribute, analyze prefix only, because actual is not a
11848 -- complete attribute reference.
11850 -- If actual is an allocator, analyze expression only. The full
11851 -- analysis can generate code, and if instance is a compilation
11852 -- unit we have to wait until the package instance is installed
11853 -- to have a proper place to insert this code.
11855 -- String literals may be operators, but at this point we do not
11856 -- know whether the actual is a formal subprogram or a string.
11861 elsif Nkind
(Act
) = N_Attribute_Reference
then
11862 Analyze
(Prefix
(Act
));
11864 elsif Nkind
(Act
) = N_Explicit_Dereference
then
11865 Analyze
(Prefix
(Act
));
11867 elsif Nkind
(Act
) = N_Allocator
then
11869 Expr
: constant Node_Id
:= Expression
(Act
);
11872 if Nkind
(Expr
) = N_Subtype_Indication
then
11873 Analyze
(Subtype_Mark
(Expr
));
11875 -- Analyze separately each discriminant constraint, when
11876 -- given with a named association.
11882 Constr
:= First
(Constraints
(Constraint
(Expr
)));
11883 while Present
(Constr
) loop
11884 if Nkind
(Constr
) = N_Discriminant_Association
then
11885 Analyze
(Expression
(Constr
));
11899 elsif Nkind
(Act
) /= N_Operator_Symbol
then
11903 if Errs
/= Serious_Errors_Detected
then
11905 -- Do a minimal analysis of the generic, to prevent spurious
11906 -- warnings complaining about the generic being unreferenced,
11907 -- before abandoning the instantiation.
11909 Analyze
(Name
(N
));
11911 if Is_Entity_Name
(Name
(N
))
11912 and then Etype
(Name
(N
)) /= Any_Type
11914 Generate_Reference
(Entity
(Name
(N
)), Name
(N
));
11915 Set_Is_Instantiated
(Entity
(Name
(N
)));
11918 if Present
(Cur
) then
11920 -- For the case of a child instance hiding an outer homonym,
11921 -- provide additional warning which might explain the error.
11923 Set_Is_Immediately_Visible
(Cur
, Vis
);
11924 Error_Msg_NE
("& hides outer unit with the same name?",
11925 N
, Defining_Unit_Name
(N
));
11928 Abandon_Instantiation
(Act
);
11935 if Present
(Cur
) then
11936 Set_Is_Immediately_Visible
(Cur
, Vis
);
11938 end Preanalyze_Actuals
;
11940 -------------------
11941 -- Remove_Parent --
11942 -------------------
11944 procedure Remove_Parent
(In_Body
: Boolean := False) is
11945 S
: Entity_Id
:= Current_Scope
;
11946 -- S is the scope containing the instantiation just completed. The scope
11947 -- stack contains the parent instances of the instantiation, followed by
11956 -- After child instantiation is complete, remove from scope stack the
11957 -- extra copy of the current scope, and then remove parent instances.
11959 if not In_Body
then
11962 while Current_Scope
/= S
loop
11963 P
:= Current_Scope
;
11964 End_Package_Scope
(Current_Scope
);
11966 if In_Open_Scopes
(P
) then
11967 E
:= First_Entity
(P
);
11968 while Present
(E
) loop
11969 Set_Is_Immediately_Visible
(E
, True);
11973 -- If instantiation is declared in a block, it is the enclosing
11974 -- scope that might be a parent instance. Note that only one
11975 -- block can be involved, because the parent instances have
11976 -- been installed within it.
11978 if Ekind
(P
) = E_Block
then
11979 Cur_P
:= Scope
(P
);
11984 if Is_Generic_Instance
(Cur_P
) and then P
/= Current_Scope
then
11985 -- We are within an instance of some sibling. Retain
11986 -- visibility of parent, for proper subsequent cleanup, and
11987 -- reinstall private declarations as well.
11989 Set_In_Private_Part
(P
);
11990 Install_Private_Declarations
(P
);
11993 -- If the ultimate parent is a top-level unit recorded in
11994 -- Instance_Parent_Unit, then reset its visibility to what it was
11995 -- before instantiation. (It's not clear what the purpose is of
11996 -- testing whether Scope (P) is In_Open_Scopes, but that test was
11997 -- present before the ultimate parent test was added.???)
11999 elsif not In_Open_Scopes
(Scope
(P
))
12000 or else (P
= Instance_Parent_Unit
12001 and then not Parent_Unit_Visible
)
12003 Set_Is_Immediately_Visible
(P
, False);
12005 -- If the current scope is itself an instantiation of a generic
12006 -- nested within P, and we are in the private part of body of this
12007 -- instantiation, restore the full views of P, that were removed
12008 -- in End_Package_Scope above. This obscure case can occur when a
12009 -- subunit of a generic contains an instance of a child unit of
12010 -- its generic parent unit.
12012 elsif S
= Current_Scope
and then Is_Generic_Instance
(S
) then
12014 Par
: constant Entity_Id
:=
12016 (Specification
(Unit_Declaration_Node
(S
)));
12019 and then P
= Scope
(Par
)
12020 and then (In_Package_Body
(S
) or else In_Private_Part
(S
))
12022 Set_In_Private_Part
(P
);
12023 Install_Private_Declarations
(P
);
12029 -- Reset visibility of entities in the enclosing scope
12031 Set_Is_Hidden_Open_Scope
(Current_Scope
, False);
12033 Hidden
:= First_Elmt
(Hidden_Entities
);
12034 while Present
(Hidden
) loop
12035 Set_Is_Immediately_Visible
(Node
(Hidden
), True);
12036 Next_Elmt
(Hidden
);
12040 -- Each body is analyzed separately, and there is no context that
12041 -- needs preserving from one body instance to the next, so remove all
12042 -- parent scopes that have been installed.
12044 while Present
(S
) loop
12045 End_Package_Scope
(S
);
12046 Set_Is_Immediately_Visible
(S
, False);
12047 S
:= Current_Scope
;
12048 exit when S
= Standard_Standard
;
12057 procedure Restore_Env
is
12058 Saved
: Instance_Env
renames Instance_Envs
.Table
(Instance_Envs
.Last
);
12061 if No
(Current_Instantiated_Parent
.Act_Id
) then
12062 -- Restore environment after subprogram inlining
12064 Restore_Private_Views
(Empty
);
12067 Current_Instantiated_Parent
:= Saved
.Instantiated_Parent
;
12068 Exchanged_Views
:= Saved
.Exchanged_Views
;
12069 Hidden_Entities
:= Saved
.Hidden_Entities
;
12070 Current_Sem_Unit
:= Saved
.Current_Sem_Unit
;
12071 Parent_Unit_Visible
:= Saved
.Parent_Unit_Visible
;
12072 Instance_Parent_Unit
:= Saved
.Instance_Parent_Unit
;
12074 Restore_Opt_Config_Switches
(Saved
.Switches
);
12076 Instance_Envs
.Decrement_Last
;
12079 ---------------------------
12080 -- Restore_Private_Views --
12081 ---------------------------
12083 procedure Restore_Private_Views
12084 (Pack_Id
: Entity_Id
;
12085 Is_Package
: Boolean := True)
12090 Dep_Elmt
: Elmt_Id
;
12093 procedure Restore_Nested_Formal
(Formal
: Entity_Id
);
12094 -- Hide the generic formals of formal packages declared with box which
12095 -- were reachable in the current instantiation.
12097 ---------------------------
12098 -- Restore_Nested_Formal --
12099 ---------------------------
12101 procedure Restore_Nested_Formal
(Formal
: Entity_Id
) is
12105 if Present
(Renamed_Object
(Formal
))
12106 and then Denotes_Formal_Package
(Renamed_Object
(Formal
), True)
12110 elsif Present
(Associated_Formal_Package
(Formal
)) then
12111 Ent
:= First_Entity
(Formal
);
12112 while Present
(Ent
) loop
12113 exit when Ekind
(Ent
) = E_Package
12114 and then Renamed_Entity
(Ent
) = Renamed_Entity
(Formal
);
12116 Set_Is_Hidden
(Ent
);
12117 Set_Is_Potentially_Use_Visible
(Ent
, False);
12119 -- If package, then recurse
12121 if Ekind
(Ent
) = E_Package
then
12122 Restore_Nested_Formal
(Ent
);
12128 end Restore_Nested_Formal
;
12130 -- Start of processing for Restore_Private_Views
12133 M
:= First_Elmt
(Exchanged_Views
);
12134 while Present
(M
) loop
12137 -- Subtypes of types whose views have been exchanged, and that are
12138 -- defined within the instance, were not on the Private_Dependents
12139 -- list on entry to the instance, so they have to be exchanged
12140 -- explicitly now, in order to remain consistent with the view of the
12143 if Ekind_In
(Typ
, E_Private_Type
,
12144 E_Limited_Private_Type
,
12145 E_Record_Type_With_Private
)
12147 Dep_Elmt
:= First_Elmt
(Private_Dependents
(Typ
));
12148 while Present
(Dep_Elmt
) loop
12149 Dep_Typ
:= Node
(Dep_Elmt
);
12151 if Scope
(Dep_Typ
) = Pack_Id
12152 and then Present
(Full_View
(Dep_Typ
))
12154 Replace_Elmt
(Dep_Elmt
, Full_View
(Dep_Typ
));
12155 Exchange_Declarations
(Dep_Typ
);
12158 Next_Elmt
(Dep_Elmt
);
12162 Exchange_Declarations
(Node
(M
));
12166 if No
(Pack_Id
) then
12170 -- Make the generic formal parameters private, and make the formal types
12171 -- into subtypes of the actuals again.
12173 E
:= First_Entity
(Pack_Id
);
12174 while Present
(E
) loop
12175 Set_Is_Hidden
(E
, True);
12178 and then Nkind
(Parent
(E
)) = N_Subtype_Declaration
12180 Set_Is_Generic_Actual_Type
(E
, False);
12182 -- An unusual case of aliasing: the actual may also be directly
12183 -- visible in the generic, and be private there, while it is fully
12184 -- visible in the context of the instance. The internal subtype
12185 -- is private in the instance but has full visibility like its
12186 -- parent in the enclosing scope. This enforces the invariant that
12187 -- the privacy status of all private dependents of a type coincide
12188 -- with that of the parent type. This can only happen when a
12189 -- generic child unit is instantiated within a sibling.
12191 if Is_Private_Type
(E
)
12192 and then not Is_Private_Type
(Etype
(E
))
12194 Exchange_Declarations
(E
);
12197 elsif Ekind
(E
) = E_Package
then
12199 -- The end of the renaming list is the renaming of the generic
12200 -- package itself. If the instance is a subprogram, all entities
12201 -- in the corresponding package are renamings. If this entity is
12202 -- a formal package, make its own formals private as well. The
12203 -- actual in this case is itself the renaming of an instantiation.
12204 -- If the entity is not a package renaming, it is the entity
12205 -- created to validate formal package actuals: ignore it.
12207 -- If the actual is itself a formal package for the enclosing
12208 -- generic, or the actual for such a formal package, it remains
12209 -- visible on exit from the instance, and therefore nothing needs
12210 -- to be done either, except to keep it accessible.
12212 if Is_Package
and then Renamed_Object
(E
) = Pack_Id
then
12215 elsif Nkind
(Parent
(E
)) /= N_Package_Renaming_Declaration
then
12219 Denotes_Formal_Package
(Renamed_Object
(E
), True, Pack_Id
)
12221 Set_Is_Hidden
(E
, False);
12225 Act_P
: constant Entity_Id
:= Renamed_Object
(E
);
12229 Id
:= First_Entity
(Act_P
);
12231 and then Id
/= First_Private_Entity
(Act_P
)
12233 exit when Ekind
(Id
) = E_Package
12234 and then Renamed_Object
(Id
) = Act_P
;
12236 Set_Is_Hidden
(Id
, True);
12237 Set_Is_Potentially_Use_Visible
(Id
, In_Use
(Act_P
));
12239 if Ekind
(Id
) = E_Package
then
12240 Restore_Nested_Formal
(Id
);
12251 end Restore_Private_Views
;
12258 (Gen_Unit
: Entity_Id
;
12259 Act_Unit
: Entity_Id
)
12263 Set_Instance_Env
(Gen_Unit
, Act_Unit
);
12266 ----------------------------
12267 -- Save_Global_References --
12268 ----------------------------
12270 procedure Save_Global_References
(N
: Node_Id
) is
12271 Gen_Scope
: Entity_Id
;
12275 function Is_Global
(E
: Entity_Id
) return Boolean;
12276 -- Check whether entity is defined outside of generic unit. Examine the
12277 -- scope of an entity, and the scope of the scope, etc, until we find
12278 -- either Standard, in which case the entity is global, or the generic
12279 -- unit itself, which indicates that the entity is local. If the entity
12280 -- is the generic unit itself, as in the case of a recursive call, or
12281 -- the enclosing generic unit, if different from the current scope, then
12282 -- it is local as well, because it will be replaced at the point of
12283 -- instantiation. On the other hand, if it is a reference to a child
12284 -- unit of a common ancestor, which appears in an instantiation, it is
12285 -- global because it is used to denote a specific compilation unit at
12286 -- the time the instantiations will be analyzed.
12288 procedure Reset_Entity
(N
: Node_Id
);
12289 -- Save semantic information on global entity so that it is not resolved
12290 -- again at instantiation time.
12292 procedure Save_Entity_Descendants
(N
: Node_Id
);
12293 -- Apply Save_Global_References to the two syntactic descendants of
12294 -- non-terminal nodes that carry an Associated_Node and are processed
12295 -- through Reset_Entity. Once the global entity (if any) has been
12296 -- captured together with its type, only two syntactic descendants need
12297 -- to be traversed to complete the processing of the tree rooted at N.
12298 -- This applies to Selected_Components, Expanded_Names, and to Operator
12299 -- nodes. N can also be a character literal, identifier, or operator
12300 -- symbol node, but the call has no effect in these cases.
12302 procedure Save_Global_Defaults
(N1
, N2
: Node_Id
);
12303 -- Default actuals in nested instances must be handled specially
12304 -- because there is no link to them from the original tree. When an
12305 -- actual subprogram is given by a default, we add an explicit generic
12306 -- association for it in the instantiation node. When we save the
12307 -- global references on the name of the instance, we recover the list
12308 -- of generic associations, and add an explicit one to the original
12309 -- generic tree, through which a global actual can be preserved.
12310 -- Similarly, if a child unit is instantiated within a sibling, in the
12311 -- context of the parent, we must preserve the identifier of the parent
12312 -- so that it can be properly resolved in a subsequent instantiation.
12314 procedure Save_Global_Descendant
(D
: Union_Id
);
12315 -- Apply Save_Global_References recursively to the descendents of the
12318 procedure Save_References
(N
: Node_Id
);
12319 -- This is the recursive procedure that does the work, once the
12320 -- enclosing generic scope has been established.
12326 function Is_Global
(E
: Entity_Id
) return Boolean is
12329 function Is_Instance_Node
(Decl
: Node_Id
) return Boolean;
12330 -- Determine whether the parent node of a reference to a child unit
12331 -- denotes an instantiation or a formal package, in which case the
12332 -- reference to the child unit is global, even if it appears within
12333 -- the current scope (e.g. when the instance appears within the body
12334 -- of an ancestor).
12336 ----------------------
12337 -- Is_Instance_Node --
12338 ----------------------
12340 function Is_Instance_Node
(Decl
: Node_Id
) return Boolean is
12342 return Nkind
(Decl
) in N_Generic_Instantiation
12344 Nkind
(Original_Node
(Decl
)) = N_Formal_Package_Declaration
;
12345 end Is_Instance_Node
;
12347 -- Start of processing for Is_Global
12350 if E
= Gen_Scope
then
12353 elsif E
= Standard_Standard
then
12356 elsif Is_Child_Unit
(E
)
12357 and then (Is_Instance_Node
(Parent
(N2
))
12358 or else (Nkind
(Parent
(N2
)) = N_Expanded_Name
12359 and then N2
= Selector_Name
(Parent
(N2
))
12361 Is_Instance_Node
(Parent
(Parent
(N2
)))))
12367 while Se
/= Gen_Scope
loop
12368 if Se
= Standard_Standard
then
12383 procedure Reset_Entity
(N
: Node_Id
) is
12385 procedure Set_Global_Type
(N
: Node_Id
; N2
: Node_Id
);
12386 -- If the type of N2 is global to the generic unit. Save the type in
12387 -- the generic node.
12388 -- What does this comment mean???
12390 function Top_Ancestor
(E
: Entity_Id
) return Entity_Id
;
12391 -- Find the ultimate ancestor of the current unit. If it is not a
12392 -- generic unit, then the name of the current unit in the prefix of
12393 -- an expanded name must be replaced with its generic homonym to
12394 -- ensure that it will be properly resolved in an instance.
12396 ---------------------
12397 -- Set_Global_Type --
12398 ---------------------
12400 procedure Set_Global_Type
(N
: Node_Id
; N2
: Node_Id
) is
12401 Typ
: constant Entity_Id
:= Etype
(N2
);
12404 Set_Etype
(N
, Typ
);
12406 if Entity
(N
) /= N2
12407 and then Has_Private_View
(Entity
(N
))
12409 -- If the entity of N is not the associated node, this is a
12410 -- nested generic and it has an associated node as well, whose
12411 -- type is already the full view (see below). Indicate that the
12412 -- original node has a private view.
12414 Set_Has_Private_View
(N
);
12417 -- If not a private type, nothing else to do
12419 if not Is_Private_Type
(Typ
) then
12420 if Is_Array_Type
(Typ
)
12421 and then Is_Private_Type
(Component_Type
(Typ
))
12423 Set_Has_Private_View
(N
);
12426 -- If it is a derivation of a private type in a context where no
12427 -- full view is needed, nothing to do either.
12429 elsif No
(Full_View
(Typ
)) and then Typ
/= Etype
(Typ
) then
12432 -- Otherwise mark the type for flipping and use the full view when
12436 Set_Has_Private_View
(N
);
12438 if Present
(Full_View
(Typ
)) then
12439 Set_Etype
(N2
, Full_View
(Typ
));
12442 end Set_Global_Type
;
12448 function Top_Ancestor
(E
: Entity_Id
) return Entity_Id
is
12453 while Is_Child_Unit
(Par
) loop
12454 Par
:= Scope
(Par
);
12460 -- Start of processing for Reset_Entity
12463 N2
:= Get_Associated_Node
(N
);
12466 if Present
(E
) then
12468 -- If the node is an entry call to an entry in an enclosing task,
12469 -- it is rewritten as a selected component. No global entity to
12470 -- preserve in this case, since the expansion will be redone in
12473 if not Nkind_In
(E
, N_Defining_Identifier
,
12474 N_Defining_Character_Literal
,
12475 N_Defining_Operator_Symbol
)
12477 Set_Associated_Node
(N
, Empty
);
12478 Set_Etype
(N
, Empty
);
12482 -- If the entity is an itype created as a subtype of an access
12483 -- type with a null exclusion restore source entity for proper
12484 -- visibility. The itype will be created anew in the instance.
12487 and then Ekind
(E
) = E_Access_Subtype
12488 and then Is_Entity_Name
(N
)
12489 and then Chars
(Etype
(E
)) = Chars
(N
)
12492 Set_Entity
(N2
, E
);
12496 if Is_Global
(E
) then
12497 Set_Global_Type
(N
, N2
);
12499 elsif Nkind
(N
) = N_Op_Concat
12500 and then Is_Generic_Type
(Etype
(N2
))
12501 and then (Base_Type
(Etype
(Right_Opnd
(N2
))) = Etype
(N2
)
12503 Base_Type
(Etype
(Left_Opnd
(N2
))) = Etype
(N2
))
12504 and then Is_Intrinsic_Subprogram
(E
)
12509 -- Entity is local. Mark generic node as unresolved.
12510 -- Note that now it does not have an entity.
12512 Set_Associated_Node
(N
, Empty
);
12513 Set_Etype
(N
, Empty
);
12516 if Nkind
(Parent
(N
)) in N_Generic_Instantiation
12517 and then N
= Name
(Parent
(N
))
12519 Save_Global_Defaults
(Parent
(N
), Parent
(N2
));
12522 elsif Nkind
(Parent
(N
)) = N_Selected_Component
12523 and then Nkind
(Parent
(N2
)) = N_Expanded_Name
12525 if Is_Global
(Entity
(Parent
(N2
))) then
12526 Change_Selected_Component_To_Expanded_Name
(Parent
(N
));
12527 Set_Associated_Node
(Parent
(N
), Parent
(N2
));
12528 Set_Global_Type
(Parent
(N
), Parent
(N2
));
12529 Save_Entity_Descendants
(N
);
12531 -- If this is a reference to the current generic entity, replace
12532 -- by the name of the generic homonym of the current package. This
12533 -- is because in an instantiation Par.P.Q will not resolve to the
12534 -- name of the instance, whose enclosing scope is not necessarily
12535 -- Par. We use the generic homonym rather that the name of the
12536 -- generic itself because it may be hidden by a local declaration.
12538 elsif In_Open_Scopes
(Entity
(Parent
(N2
)))
12540 Is_Generic_Unit
(Top_Ancestor
(Entity
(Prefix
(Parent
(N2
)))))
12542 if Ekind
(Entity
(Parent
(N2
))) = E_Generic_Package
then
12543 Rewrite
(Parent
(N
),
12544 Make_Identifier
(Sloc
(N
),
12546 Chars
(Generic_Homonym
(Entity
(Parent
(N2
))))));
12548 Rewrite
(Parent
(N
),
12549 Make_Identifier
(Sloc
(N
),
12550 Chars
=> Chars
(Selector_Name
(Parent
(N2
)))));
12554 if Nkind
(Parent
(Parent
(N
))) in N_Generic_Instantiation
12555 and then Parent
(N
) = Name
(Parent
(Parent
(N
)))
12557 Save_Global_Defaults
12558 (Parent
(Parent
(N
)), Parent
(Parent
((N2
))));
12561 -- A selected component may denote a static constant that has been
12562 -- folded. If the static constant is global to the generic, capture
12563 -- its value. Otherwise the folding will happen in any instantiation.
12565 elsif Nkind
(Parent
(N
)) = N_Selected_Component
12566 and then Nkind_In
(Parent
(N2
), N_Integer_Literal
, N_Real_Literal
)
12568 if Present
(Entity
(Original_Node
(Parent
(N2
))))
12569 and then Is_Global
(Entity
(Original_Node
(Parent
(N2
))))
12571 Rewrite
(Parent
(N
), New_Copy
(Parent
(N2
)));
12572 Set_Analyzed
(Parent
(N
), False);
12578 -- A selected component may be transformed into a parameterless
12579 -- function call. If the called entity is global, rewrite the node
12580 -- appropriately, i.e. as an extended name for the global entity.
12582 elsif Nkind
(Parent
(N
)) = N_Selected_Component
12583 and then Nkind
(Parent
(N2
)) = N_Function_Call
12584 and then N
= Selector_Name
(Parent
(N
))
12586 if No
(Parameter_Associations
(Parent
(N2
))) then
12587 if Is_Global
(Entity
(Name
(Parent
(N2
)))) then
12588 Change_Selected_Component_To_Expanded_Name
(Parent
(N
));
12589 Set_Associated_Node
(Parent
(N
), Name
(Parent
(N2
)));
12590 Set_Global_Type
(Parent
(N
), Name
(Parent
(N2
)));
12591 Save_Entity_Descendants
(N
);
12594 Set_Associated_Node
(N
, Empty
);
12595 Set_Etype
(N
, Empty
);
12598 -- In Ada 2005, X.F may be a call to a primitive operation,
12599 -- rewritten as F (X). This rewriting will be done again in an
12600 -- instance, so keep the original node. Global entities will be
12601 -- captured as for other constructs.
12607 -- Entity is local. Reset in generic unit, so that node is resolved
12608 -- anew at the point of instantiation.
12611 Set_Associated_Node
(N
, Empty
);
12612 Set_Etype
(N
, Empty
);
12616 -----------------------------
12617 -- Save_Entity_Descendants --
12618 -----------------------------
12620 procedure Save_Entity_Descendants
(N
: Node_Id
) is
12623 when N_Binary_Op
=>
12624 Save_Global_Descendant
(Union_Id
(Left_Opnd
(N
)));
12625 Save_Global_Descendant
(Union_Id
(Right_Opnd
(N
)));
12628 Save_Global_Descendant
(Union_Id
(Right_Opnd
(N
)));
12630 when N_Expanded_Name | N_Selected_Component
=>
12631 Save_Global_Descendant
(Union_Id
(Prefix
(N
)));
12632 Save_Global_Descendant
(Union_Id
(Selector_Name
(N
)));
12634 when N_Identifier | N_Character_Literal | N_Operator_Symbol
=>
12638 raise Program_Error
;
12640 end Save_Entity_Descendants
;
12642 --------------------------
12643 -- Save_Global_Defaults --
12644 --------------------------
12646 procedure Save_Global_Defaults
(N1
, N2
: Node_Id
) is
12647 Loc
: constant Source_Ptr
:= Sloc
(N1
);
12648 Assoc2
: constant List_Id
:= Generic_Associations
(N2
);
12649 Gen_Id
: constant Entity_Id
:= Get_Generic_Entity
(N2
);
12656 Actual
: Entity_Id
;
12659 Assoc1
:= Generic_Associations
(N1
);
12661 if Present
(Assoc1
) then
12662 Act1
:= First
(Assoc1
);
12665 Set_Generic_Associations
(N1
, New_List
);
12666 Assoc1
:= Generic_Associations
(N1
);
12669 if Present
(Assoc2
) then
12670 Act2
:= First
(Assoc2
);
12675 while Present
(Act1
) and then Present
(Act2
) loop
12680 -- Find the associations added for default subprograms
12682 if Present
(Act2
) then
12683 while Nkind
(Act2
) /= N_Generic_Association
12684 or else No
(Entity
(Selector_Name
(Act2
)))
12685 or else not Is_Overloadable
(Entity
(Selector_Name
(Act2
)))
12690 -- Add a similar association if the default is global. The
12691 -- renaming declaration for the actual has been analyzed, and
12692 -- its alias is the program it renames. Link the actual in the
12693 -- original generic tree with the node in the analyzed tree.
12695 while Present
(Act2
) loop
12696 Subp
:= Entity
(Selector_Name
(Act2
));
12697 Def
:= Explicit_Generic_Actual_Parameter
(Act2
);
12699 -- Following test is defence against rubbish errors
12701 if No
(Alias
(Subp
)) then
12705 -- Retrieve the resolved actual from the renaming declaration
12706 -- created for the instantiated formal.
12708 Actual
:= Entity
(Name
(Parent
(Parent
(Subp
))));
12709 Set_Entity
(Def
, Actual
);
12710 Set_Etype
(Def
, Etype
(Actual
));
12712 if Is_Global
(Actual
) then
12714 Make_Generic_Association
(Loc
,
12715 Selector_Name
=> New_Occurrence_Of
(Subp
, Loc
),
12716 Explicit_Generic_Actual_Parameter
=>
12717 New_Occurrence_Of
(Actual
, Loc
));
12719 Set_Associated_Node
12720 (Explicit_Generic_Actual_Parameter
(Ndec
), Def
);
12722 Append
(Ndec
, Assoc1
);
12724 -- If there are other defaults, add a dummy association in case
12725 -- there are other defaulted formals with the same name.
12727 elsif Present
(Next
(Act2
)) then
12729 Make_Generic_Association
(Loc
,
12730 Selector_Name
=> New_Occurrence_Of
(Subp
, Loc
),
12731 Explicit_Generic_Actual_Parameter
=> Empty
);
12733 Append
(Ndec
, Assoc1
);
12740 if Nkind
(Name
(N1
)) = N_Identifier
12741 and then Is_Child_Unit
(Gen_Id
)
12742 and then Is_Global
(Gen_Id
)
12743 and then Is_Generic_Unit
(Scope
(Gen_Id
))
12744 and then In_Open_Scopes
(Scope
(Gen_Id
))
12746 -- This is an instantiation of a child unit within a sibling, so
12747 -- that the generic parent is in scope. An eventual instance must
12748 -- occur within the scope of an instance of the parent. Make name
12749 -- in instance into an expanded name, to preserve the identifier
12750 -- of the parent, so it can be resolved subsequently.
12752 Rewrite
(Name
(N2
),
12753 Make_Expanded_Name
(Loc
,
12754 Chars
=> Chars
(Gen_Id
),
12755 Prefix
=> New_Occurrence_Of
(Scope
(Gen_Id
), Loc
),
12756 Selector_Name
=> New_Occurrence_Of
(Gen_Id
, Loc
)));
12757 Set_Entity
(Name
(N2
), Gen_Id
);
12759 Rewrite
(Name
(N1
),
12760 Make_Expanded_Name
(Loc
,
12761 Chars
=> Chars
(Gen_Id
),
12762 Prefix
=> New_Occurrence_Of
(Scope
(Gen_Id
), Loc
),
12763 Selector_Name
=> New_Occurrence_Of
(Gen_Id
, Loc
)));
12765 Set_Associated_Node
(Name
(N1
), Name
(N2
));
12766 Set_Associated_Node
(Prefix
(Name
(N1
)), Empty
);
12767 Set_Associated_Node
12768 (Selector_Name
(Name
(N1
)), Selector_Name
(Name
(N2
)));
12769 Set_Etype
(Name
(N1
), Etype
(Gen_Id
));
12772 end Save_Global_Defaults
;
12774 ----------------------------
12775 -- Save_Global_Descendant --
12776 ----------------------------
12778 procedure Save_Global_Descendant
(D
: Union_Id
) is
12782 if D
in Node_Range
then
12783 if D
= Union_Id
(Empty
) then
12786 elsif Nkind
(Node_Id
(D
)) /= N_Compilation_Unit
then
12787 Save_References
(Node_Id
(D
));
12790 elsif D
in List_Range
then
12791 if D
= Union_Id
(No_List
)
12792 or else Is_Empty_List
(List_Id
(D
))
12797 N1
:= First
(List_Id
(D
));
12798 while Present
(N1
) loop
12799 Save_References
(N1
);
12804 -- Element list or other non-node field, nothing to do
12809 end Save_Global_Descendant
;
12811 ---------------------
12812 -- Save_References --
12813 ---------------------
12815 -- This is the recursive procedure that does the work once the enclosing
12816 -- generic scope has been established. We have to treat specially a
12817 -- number of node rewritings that are required by semantic processing
12818 -- and which change the kind of nodes in the generic copy: typically
12819 -- constant-folding, replacing an operator node by a string literal, or
12820 -- a selected component by an expanded name. In each of those cases, the
12821 -- transformation is propagated to the generic unit.
12823 procedure Save_References
(N
: Node_Id
) is
12824 Loc
: constant Source_Ptr
:= Sloc
(N
);
12830 elsif Nkind_In
(N
, N_Character_Literal
, N_Operator_Symbol
) then
12831 if Nkind
(N
) = Nkind
(Get_Associated_Node
(N
)) then
12834 elsif Nkind
(N
) = N_Operator_Symbol
12835 and then Nkind
(Get_Associated_Node
(N
)) = N_String_Literal
12837 Change_Operator_Symbol_To_String_Literal
(N
);
12840 elsif Nkind
(N
) in N_Op
then
12841 if Nkind
(N
) = Nkind
(Get_Associated_Node
(N
)) then
12842 if Nkind
(N
) = N_Op_Concat
then
12843 Set_Is_Component_Left_Opnd
(N
,
12844 Is_Component_Left_Opnd
(Get_Associated_Node
(N
)));
12846 Set_Is_Component_Right_Opnd
(N
,
12847 Is_Component_Right_Opnd
(Get_Associated_Node
(N
)));
12853 -- Node may be transformed into call to a user-defined operator
12855 N2
:= Get_Associated_Node
(N
);
12857 if Nkind
(N2
) = N_Function_Call
then
12858 E
:= Entity
(Name
(N2
));
12861 and then Is_Global
(E
)
12863 Set_Etype
(N
, Etype
(N2
));
12865 Set_Associated_Node
(N
, Empty
);
12866 Set_Etype
(N
, Empty
);
12869 elsif Nkind_In
(N2
, N_Integer_Literal
,
12873 if Present
(Original_Node
(N2
))
12874 and then Nkind
(Original_Node
(N2
)) = Nkind
(N
)
12877 -- Operation was constant-folded. Whenever possible,
12878 -- recover semantic information from unfolded node,
12881 Set_Associated_Node
(N
, Original_Node
(N2
));
12883 if Nkind
(N
) = N_Op_Concat
then
12884 Set_Is_Component_Left_Opnd
(N
,
12885 Is_Component_Left_Opnd
(Get_Associated_Node
(N
)));
12886 Set_Is_Component_Right_Opnd
(N
,
12887 Is_Component_Right_Opnd
(Get_Associated_Node
(N
)));
12893 -- If original node is already modified, propagate
12894 -- constant-folding to template.
12896 Rewrite
(N
, New_Copy
(N2
));
12897 Set_Analyzed
(N
, False);
12900 elsif Nkind
(N2
) = N_Identifier
12901 and then Ekind
(Entity
(N2
)) = E_Enumeration_Literal
12903 -- Same if call was folded into a literal, but in this case
12904 -- retain the entity to avoid spurious ambiguities if it is
12905 -- overloaded at the point of instantiation or inlining.
12907 Rewrite
(N
, New_Copy
(N2
));
12908 Set_Analyzed
(N
, False);
12912 -- Complete operands check if node has not been constant-folded
12914 if Nkind
(N
) in N_Op
then
12915 Save_Entity_Descendants
(N
);
12918 elsif Nkind
(N
) = N_Identifier
then
12919 if Nkind
(N
) = Nkind
(Get_Associated_Node
(N
)) then
12921 -- If this is a discriminant reference, always save it. It is
12922 -- used in the instance to find the corresponding discriminant
12923 -- positionally rather than by name.
12925 Set_Original_Discriminant
12926 (N
, Original_Discriminant
(Get_Associated_Node
(N
)));
12930 N2
:= Get_Associated_Node
(N
);
12932 if Nkind
(N2
) = N_Function_Call
then
12933 E
:= Entity
(Name
(N2
));
12935 -- Name resolves to a call to parameterless function. If
12936 -- original entity is global, mark node as resolved.
12939 and then Is_Global
(E
)
12941 Set_Etype
(N
, Etype
(N2
));
12943 Set_Associated_Node
(N
, Empty
);
12944 Set_Etype
(N
, Empty
);
12947 elsif Nkind_In
(N2
, N_Integer_Literal
, N_Real_Literal
)
12948 and then Is_Entity_Name
(Original_Node
(N2
))
12950 -- Name resolves to named number that is constant-folded,
12951 -- We must preserve the original name for ASIS use, and
12952 -- undo the constant-folding, which will be repeated in
12955 Set_Associated_Node
(N
, Original_Node
(N2
));
12958 elsif Nkind
(N2
) = N_String_Literal
then
12960 -- Name resolves to string literal. Perform the same
12961 -- replacement in generic.
12963 Rewrite
(N
, New_Copy
(N2
));
12965 elsif Nkind
(N2
) = N_Explicit_Dereference
then
12967 -- An identifier is rewritten as a dereference if it is the
12968 -- prefix in an implicit dereference (call or attribute).
12969 -- The analysis of an instantiation will expand the node
12970 -- again, so we preserve the original tree but link it to
12971 -- the resolved entity in case it is global.
12973 if Is_Entity_Name
(Prefix
(N2
))
12974 and then Present
(Entity
(Prefix
(N2
)))
12975 and then Is_Global
(Entity
(Prefix
(N2
)))
12977 Set_Associated_Node
(N
, Prefix
(N2
));
12979 elsif Nkind
(Prefix
(N2
)) = N_Function_Call
12980 and then Is_Global
(Entity
(Name
(Prefix
(N2
))))
12983 Make_Explicit_Dereference
(Loc
,
12984 Prefix
=> Make_Function_Call
(Loc
,
12986 New_Occurrence_Of
(Entity
(Name
(Prefix
(N2
))),
12990 Set_Associated_Node
(N
, Empty
);
12991 Set_Etype
(N
, Empty
);
12994 -- The subtype mark of a nominally unconstrained object is
12995 -- rewritten as a subtype indication using the bounds of the
12996 -- expression. Recover the original subtype mark.
12998 elsif Nkind
(N2
) = N_Subtype_Indication
12999 and then Is_Entity_Name
(Original_Node
(N2
))
13001 Set_Associated_Node
(N
, Original_Node
(N2
));
13009 elsif Nkind
(N
) in N_Entity
then
13014 Qual
: Node_Id
:= Empty
;
13015 Typ
: Entity_Id
:= Empty
;
13018 use Atree
.Unchecked_Access
;
13019 -- This code section is part of implementing an untyped tree
13020 -- traversal, so it needs direct access to node fields.
13023 if Nkind_In
(N
, N_Aggregate
, N_Extension_Aggregate
) then
13024 N2
:= Get_Associated_Node
(N
);
13031 -- In an instance within a generic, use the name of the
13032 -- actual and not the original generic parameter. If the
13033 -- actual is global in the current generic it must be
13034 -- preserved for its instantiation.
13036 if Nkind
(Parent
(Typ
)) = N_Subtype_Declaration
13038 Present
(Generic_Parent_Type
(Parent
(Typ
)))
13040 Typ
:= Base_Type
(Typ
);
13041 Set_Etype
(N2
, Typ
);
13047 or else not Is_Global
(Typ
)
13049 Set_Associated_Node
(N
, Empty
);
13051 -- If the aggregate is an actual in a call, it has been
13052 -- resolved in the current context, to some local type.
13053 -- The enclosing call may have been disambiguated by the
13054 -- aggregate, and this disambiguation might fail at
13055 -- instantiation time because the type to which the
13056 -- aggregate did resolve is not preserved. In order to
13057 -- preserve some of this information, we wrap the
13058 -- aggregate in a qualified expression, using the id of
13059 -- its type. For further disambiguation we qualify the
13060 -- type name with its scope (if visible) because both
13061 -- id's will have corresponding entities in an instance.
13062 -- This resolves most of the problems with missing type
13063 -- information on aggregates in instances.
13065 if Nkind
(N2
) = Nkind
(N
)
13067 Nkind_In
(Parent
(N2
), N_Procedure_Call_Statement
,
13069 and then Comes_From_Source
(Typ
)
13071 if Is_Immediately_Visible
(Scope
(Typ
)) then
13072 Nam
:= Make_Selected_Component
(Loc
,
13074 Make_Identifier
(Loc
, Chars
(Scope
(Typ
))),
13076 Make_Identifier
(Loc
, Chars
(Typ
)));
13078 Nam
:= Make_Identifier
(Loc
, Chars
(Typ
));
13082 Make_Qualified_Expression
(Loc
,
13083 Subtype_Mark
=> Nam
,
13084 Expression
=> Relocate_Node
(N
));
13088 Save_Global_Descendant
(Field1
(N
));
13089 Save_Global_Descendant
(Field2
(N
));
13090 Save_Global_Descendant
(Field3
(N
));
13091 Save_Global_Descendant
(Field5
(N
));
13093 if Present
(Qual
) then
13097 -- All other cases than aggregates
13100 Save_Global_Descendant
(Field1
(N
));
13101 Save_Global_Descendant
(Field2
(N
));
13102 Save_Global_Descendant
(Field3
(N
));
13103 Save_Global_Descendant
(Field4
(N
));
13104 Save_Global_Descendant
(Field5
(N
));
13109 -- If a node has aspects, references within their expressions must
13110 -- be saved separately, given that they are not directly in the
13113 if Has_Aspects
(N
) then
13117 Aspect
:= First
(Aspect_Specifications
(N
));
13118 while Present
(Aspect
) loop
13119 Save_Global_References
(Expression
(Aspect
));
13124 end Save_References
;
13126 -- Start of processing for Save_Global_References
13129 Gen_Scope
:= Current_Scope
;
13131 -- If the generic unit is a child unit, references to entities in the
13132 -- parent are treated as local, because they will be resolved anew in
13133 -- the context of the instance of the parent.
13135 while Is_Child_Unit
(Gen_Scope
)
13136 and then Ekind
(Scope
(Gen_Scope
)) = E_Generic_Package
13138 Gen_Scope
:= Scope
(Gen_Scope
);
13141 Save_References
(N
);
13142 end Save_Global_References
;
13144 --------------------------------------
13145 -- Set_Copied_Sloc_For_Inlined_Body --
13146 --------------------------------------
13148 procedure Set_Copied_Sloc_For_Inlined_Body
(N
: Node_Id
; E
: Entity_Id
) is
13150 Create_Instantiation_Source
(N
, E
, True, S_Adjustment
);
13151 end Set_Copied_Sloc_For_Inlined_Body
;
13153 ---------------------
13154 -- Set_Instance_Of --
13155 ---------------------
13157 procedure Set_Instance_Of
(A
: Entity_Id
; B
: Entity_Id
) is
13159 Generic_Renamings
.Table
(Generic_Renamings
.Last
) := (A
, B
, Assoc_Null
);
13160 Generic_Renamings_HTable
.Set
(Generic_Renamings
.Last
);
13161 Generic_Renamings
.Increment_Last
;
13162 end Set_Instance_Of
;
13164 --------------------
13165 -- Set_Next_Assoc --
13166 --------------------
13168 procedure Set_Next_Assoc
(E
: Assoc_Ptr
; Next
: Assoc_Ptr
) is
13170 Generic_Renamings
.Table
(E
).Next_In_HTable
:= Next
;
13171 end Set_Next_Assoc
;
13173 -------------------
13174 -- Start_Generic --
13175 -------------------
13177 procedure Start_Generic
is
13179 -- ??? More things could be factored out in this routine.
13180 -- Should probably be done at a later stage.
13182 Generic_Flags
.Append
(Inside_A_Generic
);
13183 Inside_A_Generic
:= True;
13185 Expander_Mode_Save_And_Set
(False);
13188 ----------------------
13189 -- Set_Instance_Env --
13190 ----------------------
13192 procedure Set_Instance_Env
13193 (Gen_Unit
: Entity_Id
;
13194 Act_Unit
: Entity_Id
)
13197 -- Regardless of the current mode, predefined units are analyzed in the
13198 -- most current Ada mode, and earlier version Ada checks do not apply
13199 -- to predefined units. Nothing needs to be done for non-internal units.
13200 -- These are always analyzed in the current mode.
13202 if Is_Internal_File_Name
13203 (Fname
=> Unit_File_Name
(Get_Source_Unit
(Gen_Unit
)),
13204 Renamings_Included
=> True)
13206 Set_Opt_Config_Switches
(True, Current_Sem_Unit
= Main_Unit
);
13209 Current_Instantiated_Parent
:=
13210 (Gen_Id
=> Gen_Unit
,
13211 Act_Id
=> Act_Unit
,
13212 Next_In_HTable
=> Assoc_Null
);
13213 end Set_Instance_Env
;
13219 procedure Switch_View
(T
: Entity_Id
) is
13220 BT
: constant Entity_Id
:= Base_Type
(T
);
13221 Priv_Elmt
: Elmt_Id
:= No_Elmt
;
13222 Priv_Sub
: Entity_Id
;
13225 -- T may be private but its base type may have been exchanged through
13226 -- some other occurrence, in which case there is nothing to switch
13227 -- besides T itself. Note that a private dependent subtype of a private
13228 -- type might not have been switched even if the base type has been,
13229 -- because of the last branch of Check_Private_View (see comment there).
13231 if not Is_Private_Type
(BT
) then
13232 Prepend_Elmt
(Full_View
(T
), Exchanged_Views
);
13233 Exchange_Declarations
(T
);
13237 Priv_Elmt
:= First_Elmt
(Private_Dependents
(BT
));
13239 if Present
(Full_View
(BT
)) then
13240 Prepend_Elmt
(Full_View
(BT
), Exchanged_Views
);
13241 Exchange_Declarations
(BT
);
13244 while Present
(Priv_Elmt
) loop
13245 Priv_Sub
:= (Node
(Priv_Elmt
));
13247 -- We avoid flipping the subtype if the Etype of its full view is
13248 -- private because this would result in a malformed subtype. This
13249 -- occurs when the Etype of the subtype full view is the full view of
13250 -- the base type (and since the base types were just switched, the
13251 -- subtype is pointing to the wrong view). This is currently the case
13252 -- for tagged record types, access types (maybe more?) and needs to
13253 -- be resolved. ???
13255 if Present
(Full_View
(Priv_Sub
))
13256 and then not Is_Private_Type
(Etype
(Full_View
(Priv_Sub
)))
13258 Prepend_Elmt
(Full_View
(Priv_Sub
), Exchanged_Views
);
13259 Exchange_Declarations
(Priv_Sub
);
13262 Next_Elmt
(Priv_Elmt
);
13270 function True_Parent
(N
: Node_Id
) return Node_Id
is
13272 if Nkind
(Parent
(N
)) = N_Subunit
then
13273 return Parent
(Corresponding_Stub
(Parent
(N
)));
13279 -----------------------------
13280 -- Valid_Default_Attribute --
13281 -----------------------------
13283 procedure Valid_Default_Attribute
(Nam
: Entity_Id
; Def
: Node_Id
) is
13284 Attr_Id
: constant Attribute_Id
:=
13285 Get_Attribute_Id
(Attribute_Name
(Def
));
13286 T
: constant Entity_Id
:= Entity
(Prefix
(Def
));
13287 Is_Fun
: constant Boolean := (Ekind
(Nam
) = E_Function
);
13300 F
:= First_Formal
(Nam
);
13301 while Present
(F
) loop
13302 Num_F
:= Num_F
+ 1;
13307 when Attribute_Adjacent | Attribute_Ceiling | Attribute_Copy_Sign |
13308 Attribute_Floor | Attribute_Fraction | Attribute_Machine |
13309 Attribute_Model | Attribute_Remainder | Attribute_Rounding |
13310 Attribute_Unbiased_Rounding
=>
13313 and then Is_Floating_Point_Type
(T
);
13315 when Attribute_Image | Attribute_Pred | Attribute_Succ |
13316 Attribute_Value | Attribute_Wide_Image |
13317 Attribute_Wide_Value
=>
13318 OK
:= (Is_Fun
and then Num_F
= 1 and then Is_Scalar_Type
(T
));
13320 when Attribute_Max | Attribute_Min
=>
13321 OK
:= (Is_Fun
and then Num_F
= 2 and then Is_Scalar_Type
(T
));
13323 when Attribute_Input
=>
13324 OK
:= (Is_Fun
and then Num_F
= 1);
13326 when Attribute_Output | Attribute_Read | Attribute_Write
=>
13327 OK
:= (not Is_Fun
and then Num_F
= 2);
13334 Error_Msg_N
("attribute reference has wrong profile for subprogram",
13337 end Valid_Default_Attribute
;