1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2012, 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 Debug
; use Debug
;
29 with Einfo
; use Einfo
;
30 with Elists
; use Elists
;
31 with Errout
; use Errout
;
32 with Expander
; use Expander
;
33 with Exp_Disp
; use Exp_Disp
;
34 with Fname
; use Fname
;
35 with Fname
.UF
; use Fname
.UF
;
36 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_Dim
; use Sem_Dim
;
58 with Sem_Disp
; use Sem_Disp
;
59 with Sem_Elab
; use Sem_Elab
;
60 with Sem_Elim
; use Sem_Elim
;
61 with Sem_Eval
; use Sem_Eval
;
62 with Sem_Prag
; use Sem_Prag
;
63 with Sem_Res
; use Sem_Res
;
64 with Sem_Type
; use Sem_Type
;
65 with Sem_Util
; use Sem_Util
;
66 with Sem_Warn
; use Sem_Warn
;
67 with Stand
; use Stand
;
68 with Sinfo
; use Sinfo
;
69 with Sinfo
.CN
; use Sinfo
.CN
;
70 with Sinput
; use Sinput
;
71 with Sinput
.L
; use Sinput
.L
;
72 with Snames
; use Snames
;
73 with Stringt
; use Stringt
;
74 with Uname
; use Uname
;
76 with Tbuild
; use Tbuild
;
77 with Uintp
; use Uintp
;
78 with Urealp
; use Urealp
;
82 package body Sem_Ch12
is
84 ----------------------------------------------------------
85 -- Implementation of Generic Analysis and Instantiation --
86 ----------------------------------------------------------
88 -- GNAT implements generics by macro expansion. No attempt is made to share
89 -- generic instantiations (for now). Analysis of a generic definition does
90 -- not perform any expansion action, but the expander must be called on the
91 -- tree for each instantiation, because the expansion may of course depend
92 -- on the generic actuals. All of this is best achieved as follows:
94 -- a) Semantic analysis of a generic unit is performed on a copy of the
95 -- tree for the generic unit. All tree modifications that follow analysis
96 -- do not affect the original tree. Links are kept between the original
97 -- tree and the copy, in order to recognize non-local references within
98 -- the generic, and propagate them to each instance (recall that name
99 -- resolution is done on the generic declaration: generics are not really
100 -- macros!). This is summarized in the following diagram:
102 -- .-----------. .----------.
103 -- | semantic |<--------------| generic |
105 -- | |==============>| |
106 -- |___________| global |__________|
117 -- b) Each instantiation copies the original tree, and inserts into it a
118 -- series of declarations that describe the mapping between generic formals
119 -- and actuals. For example, a generic In OUT parameter is an object
120 -- renaming of the corresponding actual, etc. Generic IN parameters are
121 -- constant declarations.
123 -- c) In order to give the right visibility for these renamings, we use
124 -- a different scheme for package and subprogram instantiations. For
125 -- packages, the list of renamings is inserted into the package
126 -- specification, before the visible declarations of the package. The
127 -- renamings are analyzed before any of the text of the instance, and are
128 -- thus visible at the right place. Furthermore, outside of the instance,
129 -- the generic parameters are visible and denote their corresponding
132 -- For subprograms, we create a container package to hold the renamings
133 -- and the subprogram instance itself. Analysis of the package makes the
134 -- renaming declarations visible to the subprogram. After analyzing the
135 -- package, the defining entity for the subprogram is touched-up so that
136 -- it appears declared in the current scope, and not inside the container
139 -- If the instantiation is a compilation unit, the container package is
140 -- given the same name as the subprogram instance. This ensures that
141 -- the elaboration procedure called by the binder, using the compilation
142 -- unit name, calls in fact the elaboration procedure for the package.
144 -- Not surprisingly, private types complicate this approach. By saving in
145 -- the original generic object the non-local references, we guarantee that
146 -- the proper entities are referenced at the point of instantiation.
147 -- However, for private types, this by itself does not insure that the
148 -- proper VIEW of the entity is used (the full type may be visible at the
149 -- point of generic definition, but not at instantiation, or vice-versa).
150 -- In order to reference the proper view, we special-case any reference
151 -- to private types in the generic object, by saving both views, one in
152 -- the generic and one in the semantic copy. At time of instantiation, we
153 -- check whether the two views are consistent, and exchange declarations if
154 -- necessary, in order to restore the correct visibility. Similarly, if
155 -- the instance view is private when the generic view was not, we perform
156 -- the exchange. After completing the instantiation, we restore the
157 -- current visibility. The flag Has_Private_View marks identifiers in the
158 -- the generic unit that require checking.
160 -- Visibility within nested generic units requires special handling.
161 -- Consider the following scheme:
163 -- type Global is ... -- outside of generic unit.
167 -- type Semi_Global is ... -- global to inner.
170 -- procedure inner (X1 : Global; X2 : Semi_Global);
172 -- procedure in2 is new inner (...); -- 4
175 -- package New_Outer is new Outer (...); -- 2
176 -- procedure New_Inner is new New_Outer.Inner (...); -- 3
178 -- The semantic analysis of Outer captures all occurrences of Global.
179 -- The semantic analysis of Inner (at 1) captures both occurrences of
180 -- Global and Semi_Global.
182 -- At point 2 (instantiation of Outer), we also produce a generic copy
183 -- of Inner, even though Inner is, at that point, not being instantiated.
184 -- (This is just part of the semantic analysis of New_Outer).
186 -- Critically, references to Global within Inner must be preserved, while
187 -- references to Semi_Global should not preserved, because they must now
188 -- resolve to an entity within New_Outer. To distinguish between these, we
189 -- use a global variable, Current_Instantiated_Parent, which is set when
190 -- performing a generic copy during instantiation (at 2). This variable is
191 -- used when performing a generic copy that is not an instantiation, but
192 -- that is nested within one, as the occurrence of 1 within 2. The analysis
193 -- of a nested generic only preserves references that are global to the
194 -- enclosing Current_Instantiated_Parent. We use the Scope_Depth value to
195 -- determine whether a reference is external to the given parent.
197 -- The instantiation at point 3 requires no special treatment. The method
198 -- works as well for further nestings of generic units, but of course the
199 -- variable Current_Instantiated_Parent must be stacked because nested
200 -- instantiations can occur, e.g. the occurrence of 4 within 2.
202 -- The instantiation of package and subprogram bodies is handled in a
203 -- similar manner, except that it is delayed until after semantic
204 -- analysis is complete. In this fashion complex cross-dependencies
205 -- between several package declarations and bodies containing generics
206 -- can be compiled which otherwise would diagnose spurious circularities.
208 -- For example, it is possible to compile two packages A and B that
209 -- have the following structure:
211 -- package A is package B is
212 -- generic ... generic ...
213 -- package G_A is package G_B is
216 -- package body A is package body B is
217 -- package N_B is new G_B (..) package N_A is new G_A (..)
219 -- The table Pending_Instantiations in package Inline is used to keep
220 -- track of body instantiations that are delayed in this manner. Inline
221 -- handles the actual calls to do the body instantiations. This activity
222 -- is part of Inline, since the processing occurs at the same point, and
223 -- for essentially the same reason, as the handling of inlined routines.
225 ----------------------------------------------
226 -- Detection of Instantiation Circularities --
227 ----------------------------------------------
229 -- If we have a chain of instantiations that is circular, this is static
230 -- error which must be detected at compile time. The detection of these
231 -- circularities is carried out at the point that we insert a generic
232 -- instance spec or body. If there is a circularity, then the analysis of
233 -- the offending spec or body will eventually result in trying to load the
234 -- same unit again, and we detect this problem as we analyze the package
235 -- instantiation for the second time.
237 -- At least in some cases after we have detected the circularity, we get
238 -- into trouble if we try to keep going. The following flag is set if a
239 -- circularity is detected, and used to abandon compilation after the
240 -- messages have been posted.
242 Circularity_Detected
: Boolean := False;
243 -- This should really be reset on encountering a new main unit, but in
244 -- practice we are not using multiple main units so it is not critical.
246 -------------------------------------------------
247 -- Formal packages and partial parametrization --
248 -------------------------------------------------
250 -- When compiling a generic, a formal package is a local instantiation. If
251 -- declared with a box, its generic formals are visible in the enclosing
252 -- generic. If declared with a partial list of actuals, those actuals that
253 -- are defaulted (covered by an Others clause, or given an explicit box
254 -- initialization) are also visible in the enclosing generic, while those
255 -- that have a corresponding actual are not.
257 -- In our source model of instantiation, the same visibility must be
258 -- present in the spec and body of an instance: the names of the formals
259 -- that are defaulted must be made visible within the instance, and made
260 -- invisible (hidden) after the instantiation is complete, so that they
261 -- are not accessible outside of the instance.
263 -- In a generic, a formal package is treated like a special instantiation.
264 -- Our Ada 95 compiler handled formals with and without box in different
265 -- ways. With partial parametrization, we use a single model for both.
266 -- We create a package declaration that consists of the specification of
267 -- the generic package, and a set of declarations that map the actuals
268 -- into local renamings, just as we do for bona fide instantiations. For
269 -- defaulted parameters and formals with a box, we copy directly the
270 -- declarations of the formal into this local package. The result is a
271 -- a package whose visible declarations may include generic formals. This
272 -- package is only used for type checking and visibility analysis, and
273 -- never reaches the back-end, so it can freely violate the placement
274 -- rules for generic formal declarations.
276 -- The list of declarations (renamings and copies of formals) is built
277 -- by Analyze_Associations, just as for regular instantiations.
279 -- At the point of instantiation, conformance checking must be applied only
280 -- to those parameters that were specified in the formal. We perform this
281 -- checking by creating another internal instantiation, this one including
282 -- only the renamings and the formals (the rest of the package spec is not
283 -- relevant to conformance checking). We can then traverse two lists: the
284 -- list of actuals in the instance that corresponds to the formal package,
285 -- and the list of actuals produced for this bogus instantiation. We apply
286 -- the conformance rules to those actuals that are not defaulted (i.e.
287 -- which still appear as generic formals.
289 -- When we compile an instance body we must make the right parameters
290 -- visible again. The predicate Is_Generic_Formal indicates which of the
291 -- formals should have its Is_Hidden flag reset.
293 -----------------------
294 -- Local subprograms --
295 -----------------------
297 procedure Abandon_Instantiation
(N
: Node_Id
);
298 pragma No_Return
(Abandon_Instantiation
);
299 -- Posts an error message "instantiation abandoned" at the indicated node
300 -- and then raises the exception Instantiation_Error to do it.
302 procedure Analyze_Formal_Array_Type
303 (T
: in out Entity_Id
;
305 -- A formal array type is treated like an array type declaration, and
306 -- invokes Array_Type_Declaration (sem_ch3) whose first parameter is
307 -- in-out, because in the case of an anonymous type the entity is
308 -- actually created in the procedure.
310 -- The following procedures treat other kinds of formal parameters
312 procedure Analyze_Formal_Derived_Interface_Type
317 procedure Analyze_Formal_Derived_Type
322 procedure Analyze_Formal_Interface_Type
327 -- The following subprograms create abbreviated declarations for formal
328 -- scalar types. We introduce an anonymous base of the proper class for
329 -- each of them, and define the formals as constrained first subtypes of
330 -- their bases. The bounds are expressions that are non-static in the
333 procedure Analyze_Formal_Decimal_Fixed_Point_Type
334 (T
: Entity_Id
; Def
: Node_Id
);
335 procedure Analyze_Formal_Discrete_Type
(T
: Entity_Id
; Def
: Node_Id
);
336 procedure Analyze_Formal_Floating_Type
(T
: Entity_Id
; Def
: Node_Id
);
337 procedure Analyze_Formal_Signed_Integer_Type
(T
: Entity_Id
; Def
: Node_Id
);
338 procedure Analyze_Formal_Modular_Type
(T
: Entity_Id
; Def
: Node_Id
);
339 procedure Analyze_Formal_Ordinary_Fixed_Point_Type
340 (T
: Entity_Id
; Def
: Node_Id
);
342 procedure Analyze_Formal_Private_Type
346 -- Creates a new private type, which does not require completion
348 procedure Analyze_Formal_Incomplete_Type
(T
: Entity_Id
; Def
: Node_Id
);
349 -- Ada 2012: Creates a new incomplete type whose actual does not freeze
351 procedure Analyze_Generic_Formal_Part
(N
: Node_Id
);
352 -- Analyze generic formal part
354 procedure Analyze_Generic_Access_Type
(T
: Entity_Id
; Def
: Node_Id
);
355 -- Create a new access type with the given designated type
357 function Analyze_Associations
360 F_Copy
: List_Id
) return List_Id
;
361 -- At instantiation time, build the list of associations between formals
362 -- and actuals. Each association becomes a renaming declaration for the
363 -- formal entity. F_Copy is the analyzed list of formals in the generic
364 -- copy. It is used to apply legality checks to the actuals. I_Node is the
365 -- instantiation node itself.
367 procedure Analyze_Subprogram_Instantiation
371 procedure Build_Instance_Compilation_Unit_Nodes
375 -- This procedure is used in the case where the generic instance of a
376 -- subprogram body or package body is a library unit. In this case, the
377 -- original library unit node for the generic instantiation must be
378 -- replaced by the resulting generic body, and a link made to a new
379 -- compilation unit node for the generic declaration. The argument N is
380 -- the original generic instantiation. Act_Body and Act_Decl are the body
381 -- and declaration of the instance (either package body and declaration
382 -- nodes or subprogram body and declaration nodes depending on the case).
383 -- On return, the node N has been rewritten with the actual body.
385 procedure Check_Access_Definition
(N
: Node_Id
);
386 -- Subsidiary routine to null exclusion processing. Perform an assertion
387 -- check on Ada version and the presence of an access definition in N.
389 procedure Check_Formal_Packages
(P_Id
: Entity_Id
);
390 -- Apply the following to all formal packages in generic associations
392 procedure Check_Formal_Package_Instance
393 (Formal_Pack
: Entity_Id
;
394 Actual_Pack
: Entity_Id
);
395 -- Verify that the actuals of the actual instance match the actuals of
396 -- the template for a formal package that is not declared with a box.
398 procedure Check_Forward_Instantiation
(Decl
: Node_Id
);
399 -- If the generic is a local entity and the corresponding body has not
400 -- been seen yet, flag enclosing packages to indicate that it will be
401 -- elaborated after the generic body. Subprograms declared in the same
402 -- package cannot be inlined by the front-end because front-end inlining
403 -- requires a strict linear order of elaboration.
405 function Check_Hidden_Primitives
(Assoc_List
: List_Id
) return Elist_Id
;
406 -- Check if some association between formals and actuals requires to make
407 -- visible primitives of a tagged type, and make those primitives visible.
408 -- Return the list of primitives whose visibility is modified (to restore
409 -- their visibility later through Restore_Hidden_Primitives). If no
410 -- candidate is found then return No_Elist.
412 procedure Check_Hidden_Child_Unit
414 Gen_Unit
: Entity_Id
;
415 Act_Decl_Id
: Entity_Id
);
416 -- If the generic unit is an implicit child instance within a parent
417 -- instance, we need to make an explicit test that it is not hidden by
418 -- a child instance of the same name and parent.
420 procedure Check_Generic_Actuals
421 (Instance
: Entity_Id
;
422 Is_Formal_Box
: Boolean);
423 -- Similar to previous one. Check the actuals in the instantiation,
424 -- whose views can change between the point of instantiation and the point
425 -- of instantiation of the body. In addition, mark the generic renamings
426 -- as generic actuals, so that they are not compatible with other actuals.
427 -- Recurse on an actual that is a formal package whose declaration has
430 function Contains_Instance_Of
433 N
: Node_Id
) return Boolean;
434 -- Inner is instantiated within the generic Outer. Check whether Inner
435 -- directly or indirectly contains an instance of Outer or of one of its
436 -- parents, in the case of a subunit. Each generic unit holds a list of
437 -- the entities instantiated within (at any depth). This procedure
438 -- determines whether the set of such lists contains a cycle, i.e. an
439 -- illegal circular instantiation.
441 function Denotes_Formal_Package
443 On_Exit
: Boolean := False;
444 Instance
: Entity_Id
:= Empty
) return Boolean;
445 -- Returns True if E is a formal package of an enclosing generic, or
446 -- the actual for such a formal in an enclosing instantiation. If such
447 -- a package is used as a formal in an nested generic, or as an actual
448 -- in a nested instantiation, the visibility of ITS formals should not
449 -- be modified. When called from within Restore_Private_Views, the flag
450 -- On_Exit is true, to indicate that the search for a possible enclosing
451 -- instance should ignore the current one. In that case Instance denotes
452 -- the declaration for which this is an actual. This declaration may be
453 -- an instantiation in the source, or the internal instantiation that
454 -- corresponds to the actual for a formal package.
456 function Earlier
(N1
, N2
: Node_Id
) return Boolean;
457 -- Yields True if N1 and N2 appear in the same compilation unit,
458 -- ignoring subunits, and if N1 is to the left of N2 in a left-to-right
459 -- traversal of the tree for the unit. Used to determine the placement
460 -- of freeze nodes for instance bodies that may depend on other instances.
462 function Find_Actual_Type
464 Gen_Type
: Entity_Id
) return Entity_Id
;
465 -- When validating the actual types of a child instance, check whether
466 -- the formal is a formal type of the parent unit, and retrieve the current
467 -- actual for it. Typ is the entity in the analyzed formal type declaration
468 -- (component or index type of an array type, or designated type of an
469 -- access formal) and Gen_Type is the enclosing analyzed formal array
470 -- or access type. The desired actual may be a formal of a parent, or may
471 -- be declared in a formal package of a parent. In both cases it is a
472 -- generic actual type because it appears within a visible instance.
473 -- Finally, it may be declared in a parent unit without being a formal
474 -- of that unit, in which case it must be retrieved by visibility.
475 -- Ambiguities may still arise if two homonyms are declared in two formal
476 -- packages, and the prefix of the formal type may be needed to resolve
477 -- the ambiguity in the instance ???
479 function In_Same_Declarative_Part
481 Inst
: Node_Id
) return Boolean;
482 -- True if the instantiation Inst and the given freeze_node F_Node appear
483 -- within the same declarative part, ignoring subunits, but with no inter-
484 -- vening subprograms or concurrent units. Used to find the proper plave
485 -- for the freeze node of an instance, when the generic is declared in a
486 -- previous instance. If predicate is true, the freeze node of the instance
487 -- can be placed after the freeze node of the previous instance, Otherwise
488 -- it has to be placed at the end of the current declarative part.
490 function In_Main_Context
(E
: Entity_Id
) return Boolean;
491 -- Check whether an instantiation is in the context of the main unit.
492 -- Used to determine whether its body should be elaborated to allow
493 -- front-end inlining.
495 procedure Set_Instance_Env
496 (Gen_Unit
: Entity_Id
;
497 Act_Unit
: Entity_Id
);
498 -- Save current instance on saved environment, to be used to determine
499 -- the global status of entities in nested instances. Part of Save_Env.
500 -- called after verifying that the generic unit is legal for the instance,
501 -- The procedure also examines whether the generic unit is a predefined
502 -- unit, in order to set configuration switches accordingly. As a result
503 -- the procedure must be called after analyzing and freezing the actuals.
505 procedure Set_Instance_Of
(A
: Entity_Id
; B
: Entity_Id
);
506 -- Associate analyzed generic parameter with corresponding
507 -- instance. Used for semantic checks at instantiation time.
509 function Has_Been_Exchanged
(E
: Entity_Id
) return Boolean;
510 -- Traverse the Exchanged_Views list to see if a type was private
511 -- and has already been flipped during this phase of instantiation.
513 procedure Hide_Current_Scope
;
514 -- When instantiating a generic child unit, the parent context must be
515 -- present, but the instance and all entities that may be generated
516 -- must be inserted in the current scope. We leave the current scope
517 -- on the stack, but make its entities invisible to avoid visibility
518 -- problems. This is reversed at the end of the instantiation. This is
519 -- not done for the instantiation of the bodies, which only require the
520 -- instances of the generic parents to be in scope.
522 procedure Install_Body
527 -- If the instantiation happens textually before the body of the generic,
528 -- the instantiation of the body must be analyzed after the generic body,
529 -- and not at the point of instantiation. Such early instantiations can
530 -- happen if the generic and the instance appear in a package declaration
531 -- because the generic body can only appear in the corresponding package
532 -- body. Early instantiations can also appear if generic, instance and
533 -- body are all in the declarative part of a subprogram or entry. Entities
534 -- of packages that are early instantiations are delayed, and their freeze
535 -- node appears after the generic body.
537 procedure Insert_Freeze_Node_For_Instance
540 -- N denotes a package or a subprogram instantiation and F_Node is the
541 -- associated freeze node. Insert the freeze node before the first source
542 -- body which follows immediately after N. If no such body is found, the
543 -- freeze node is inserted at the end of the declarative region which
546 procedure Freeze_Subprogram_Body
547 (Inst_Node
: Node_Id
;
549 Pack_Id
: Entity_Id
);
550 -- The generic body may appear textually after the instance, including
551 -- in the proper body of a stub, or within a different package instance.
552 -- Given that the instance can only be elaborated after the generic, we
553 -- place freeze_nodes for the instance and/or for packages that may enclose
554 -- the instance and the generic, so that the back-end can establish the
555 -- proper order of elaboration.
558 -- Establish environment for subsequent instantiation. Separated from
559 -- Save_Env because data-structures for visibility handling must be
560 -- initialized before call to Check_Generic_Child_Unit.
562 procedure Install_Formal_Packages
(Par
: Entity_Id
);
563 -- Install the visible part of any formal of the parent that is a formal
564 -- package. Note that for the case of a formal package with a box, this
565 -- includes the formal part of the formal package (12.7(10/2)).
567 procedure Install_Parent
(P
: Entity_Id
; In_Body
: Boolean := False);
568 -- When compiling an instance of a child unit the parent (which is
569 -- itself an instance) is an enclosing scope that must be made
570 -- immediately visible. This procedure is also used to install the non-
571 -- generic parent of a generic child unit when compiling its body, so
572 -- that full views of types in the parent are made visible.
574 procedure Remove_Parent
(In_Body
: Boolean := False);
575 -- Reverse effect after instantiation of child is complete
577 procedure Install_Hidden_Primitives
578 (Prims_List
: in out Elist_Id
;
581 -- Remove suffix 'P' from hidden primitives of Act_T to match the
582 -- visibility of primitives of Gen_T. The list of primitives to which
583 -- the suffix is removed is added to Prims_List to restore them later.
585 procedure Restore_Hidden_Primitives
(Prims_List
: in out Elist_Id
);
586 -- Restore suffix 'P' to primitives of Prims_List and leave Prims_List
589 procedure Inline_Instance_Body
591 Gen_Unit
: Entity_Id
;
593 -- If front-end inlining is requested, instantiate the package body,
594 -- and preserve the visibility of its compilation unit, to insure
595 -- that successive instantiations succeed.
597 -- The functions Instantiate_XXX perform various legality checks and build
598 -- the declarations for instantiated generic parameters. In all of these
599 -- Formal is the entity in the generic unit, Actual is the entity of
600 -- expression in the generic associations, and Analyzed_Formal is the
601 -- formal in the generic copy, which contains the semantic information to
602 -- be used to validate the actual.
604 function Instantiate_Object
607 Analyzed_Formal
: Node_Id
) return List_Id
;
609 function Instantiate_Type
612 Analyzed_Formal
: Node_Id
;
613 Actual_Decls
: List_Id
) return List_Id
;
615 function Instantiate_Formal_Subprogram
618 Analyzed_Formal
: Node_Id
) return Node_Id
;
620 function Instantiate_Formal_Package
623 Analyzed_Formal
: Node_Id
) return List_Id
;
624 -- If the formal package is declared with a box, special visibility rules
625 -- apply to its formals: they are in the visible part of the package. This
626 -- is true in the declarative region of the formal package, that is to say
627 -- in the enclosing generic or instantiation. For an instantiation, the
628 -- parameters of the formal package are made visible in an explicit step.
629 -- Furthermore, if the actual has a visible USE clause, these formals must
630 -- be made potentially use-visible as well. On exit from the enclosing
631 -- instantiation, the reverse must be done.
633 -- For a formal package declared without a box, there are conformance rules
634 -- that apply to the actuals in the generic declaration and the actuals of
635 -- the actual package in the enclosing instantiation. The simplest way to
636 -- apply these rules is to repeat the instantiation of the formal package
637 -- in the context of the enclosing instance, and compare the generic
638 -- associations of this instantiation with those of the actual package.
639 -- This internal instantiation only needs to contain the renamings of the
640 -- formals: the visible and private declarations themselves need not be
643 -- In Ada 2005, the formal package may be only partially parameterized.
644 -- In that case the visibility step must make visible those actuals whose
645 -- corresponding formals were given with a box. A final complication
646 -- involves inherited operations from formal derived types, which must
647 -- be visible if the type is.
649 function Is_In_Main_Unit
(N
: Node_Id
) return Boolean;
650 -- Test if given node is in the main unit
652 procedure Load_Parent_Of_Generic
655 Body_Optional
: Boolean := False);
656 -- If the generic appears in a separate non-generic library unit, load the
657 -- corresponding body to retrieve the body of the generic. N is the node
658 -- for the generic instantiation, Spec is the generic package declaration.
660 -- Body_Optional is a flag that indicates that the body is being loaded to
661 -- ensure that temporaries are generated consistently when there are other
662 -- instances in the current declarative part that precede the one being
663 -- loaded. In that case a missing body is acceptable.
665 procedure Inherit_Context
(Gen_Decl
: Node_Id
; Inst
: Node_Id
);
666 -- Add the context clause of the unit containing a generic unit to a
667 -- compilation unit that is, or contains, an instantiation.
669 function Get_Associated_Node
(N
: Node_Id
) return Node_Id
;
670 -- In order to propagate semantic information back from the analyzed copy
671 -- to the original generic, we maintain links between selected nodes in the
672 -- generic and their corresponding copies. At the end of generic analysis,
673 -- the routine Save_Global_References traverses the generic tree, examines
674 -- the semantic information, and preserves the links to those nodes that
675 -- contain global information. At instantiation, the information from the
676 -- associated node is placed on the new copy, so that name resolution is
679 -- Three kinds of source nodes have associated nodes:
681 -- a) those that can reference (denote) entities, that is identifiers,
682 -- character literals, expanded_names, operator symbols, operators,
683 -- and attribute reference nodes. These nodes have an Entity field
684 -- and are the set of nodes that are in N_Has_Entity.
686 -- b) aggregates (N_Aggregate and N_Extension_Aggregate)
688 -- c) selected components (N_Selected_Component)
690 -- For the first class, the associated node preserves the entity if it is
691 -- global. If the generic contains nested instantiations, the associated
692 -- node itself has been recopied, and a chain of them must be followed.
694 -- For aggregates, the associated node allows retrieval of the type, which
695 -- may otherwise not appear in the generic. The view of this type may be
696 -- different between generic and instantiation, and the full view can be
697 -- installed before the instantiation is analyzed. For aggregates of type
698 -- extensions, the same view exchange may have to be performed for some of
699 -- the ancestor types, if their view is private at the point of
702 -- Nodes that are selected components in the parse tree may be rewritten
703 -- as expanded names after resolution, and must be treated as potential
704 -- entity holders, which is why they also have an Associated_Node.
706 -- Nodes that do not come from source, such as freeze nodes, do not appear
707 -- in the generic tree, and need not have an associated node.
709 -- The associated node is stored in the Associated_Node field. Note that
710 -- this field overlaps Entity, which is fine, because the whole point is
711 -- that we don't need or want the normal Entity field in this situation.
713 procedure Map_Formal_Package_Entities
(Form
: Entity_Id
; Act
: Entity_Id
);
714 -- Within the generic part, entities in the formal package are
715 -- visible. To validate subsequent type declarations, indicate
716 -- the correspondence between the entities in the analyzed formal,
717 -- and the entities in the actual package. There are three packages
718 -- involved in the instantiation of a formal package: the parent
719 -- generic P1 which appears in the generic declaration, the fake
720 -- instantiation P2 which appears in the analyzed generic, and whose
721 -- visible entities may be used in subsequent formals, and the actual
722 -- P3 in the instance. To validate subsequent formals, me indicate
723 -- that the entities in P2 are mapped into those of P3. The mapping of
724 -- entities has to be done recursively for nested packages.
726 procedure Move_Freeze_Nodes
730 -- Freeze nodes can be generated in the analysis of a generic unit, but
731 -- will not be seen by the back-end. It is necessary to move those nodes
732 -- to the enclosing scope if they freeze an outer entity. We place them
733 -- at the end of the enclosing generic package, which is semantically
736 procedure Preanalyze_Actuals
(N
: Node_Id
);
737 -- Analyze actuals to perform name resolution. Full resolution is done
738 -- later, when the expected types are known, but names have to be captured
739 -- before installing parents of generics, that are not visible for the
740 -- actuals themselves.
742 function True_Parent
(N
: Node_Id
) return Node_Id
;
743 -- For a subunit, return parent of corresponding stub, else return
746 procedure Valid_Default_Attribute
(Nam
: Entity_Id
; Def
: Node_Id
);
747 -- Verify that an attribute that appears as the default for a formal
748 -- subprogram is a function or procedure with the correct profile.
750 -------------------------------------------
751 -- Data Structures for Generic Renamings --
752 -------------------------------------------
754 -- The map Generic_Renamings associates generic entities with their
755 -- corresponding actuals. Currently used to validate type instances. It
756 -- will eventually be used for all generic parameters to eliminate the
757 -- need for overload resolution in the instance.
759 type Assoc_Ptr
is new Int
;
761 Assoc_Null
: constant Assoc_Ptr
:= -1;
766 Next_In_HTable
: Assoc_Ptr
;
769 package Generic_Renamings
is new Table
.Table
770 (Table_Component_Type
=> Assoc
,
771 Table_Index_Type
=> Assoc_Ptr
,
772 Table_Low_Bound
=> 0,
774 Table_Increment
=> 100,
775 Table_Name
=> "Generic_Renamings");
777 -- Variable to hold enclosing instantiation. When the environment is
778 -- saved for a subprogram inlining, the corresponding Act_Id is empty.
780 Current_Instantiated_Parent
: Assoc
:= (Empty
, Empty
, Assoc_Null
);
782 -- Hash table for associations
784 HTable_Size
: constant := 37;
785 type HTable_Range
is range 0 .. HTable_Size
- 1;
787 procedure Set_Next_Assoc
(E
: Assoc_Ptr
; Next
: Assoc_Ptr
);
788 function Next_Assoc
(E
: Assoc_Ptr
) return Assoc_Ptr
;
789 function Get_Gen_Id
(E
: Assoc_Ptr
) return Entity_Id
;
790 function Hash
(F
: Entity_Id
) return HTable_Range
;
792 package Generic_Renamings_HTable
is new GNAT
.HTable
.Static_HTable
(
793 Header_Num
=> HTable_Range
,
795 Elmt_Ptr
=> Assoc_Ptr
,
796 Null_Ptr
=> Assoc_Null
,
797 Set_Next
=> Set_Next_Assoc
,
800 Get_Key
=> Get_Gen_Id
,
804 Exchanged_Views
: Elist_Id
;
805 -- This list holds the private views that have been exchanged during
806 -- instantiation to restore the visibility of the generic declaration.
807 -- (see comments above). After instantiation, the current visibility is
808 -- reestablished by means of a traversal of this list.
810 Hidden_Entities
: Elist_Id
;
811 -- This list holds the entities of the current scope that are removed
812 -- from immediate visibility when instantiating a child unit. Their
813 -- visibility is restored in Remove_Parent.
815 -- Because instantiations can be recursive, the following must be saved
816 -- on entry and restored on exit from an instantiation (spec or body).
817 -- This is done by the two procedures Save_Env and Restore_Env. For
818 -- package and subprogram instantiations (but not for the body instances)
819 -- the action of Save_Env is done in two steps: Init_Env is called before
820 -- Check_Generic_Child_Unit, because setting the parent instances requires
821 -- that the visibility data structures be properly initialized. Once the
822 -- generic is unit is validated, Set_Instance_Env completes Save_Env.
824 Parent_Unit_Visible
: Boolean := False;
825 -- Parent_Unit_Visible is used when the generic is a child unit, and
826 -- indicates whether the ultimate parent of the generic is visible in the
827 -- instantiation environment. It is used to reset the visibility of the
828 -- parent at the end of the instantiation (see Remove_Parent).
830 Instance_Parent_Unit
: Entity_Id
:= Empty
;
831 -- This records the ultimate parent unit of an instance of a generic
832 -- child unit and is used in conjunction with Parent_Unit_Visible to
833 -- indicate the unit to which the Parent_Unit_Visible flag corresponds.
835 type Instance_Env
is record
836 Instantiated_Parent
: Assoc
;
837 Exchanged_Views
: Elist_Id
;
838 Hidden_Entities
: Elist_Id
;
839 Current_Sem_Unit
: Unit_Number_Type
;
840 Parent_Unit_Visible
: Boolean := False;
841 Instance_Parent_Unit
: Entity_Id
:= Empty
;
842 Switches
: Config_Switches_Type
;
845 package Instance_Envs
is new Table
.Table
(
846 Table_Component_Type
=> Instance_Env
,
847 Table_Index_Type
=> Int
,
848 Table_Low_Bound
=> 0,
850 Table_Increment
=> 100,
851 Table_Name
=> "Instance_Envs");
853 procedure Restore_Private_Views
854 (Pack_Id
: Entity_Id
;
855 Is_Package
: Boolean := True);
856 -- Restore the private views of external types, and unmark the generic
857 -- renamings of actuals, so that they become compatible subtypes again.
858 -- For subprograms, Pack_Id is the package constructed to hold the
861 procedure Switch_View
(T
: Entity_Id
);
862 -- Switch the partial and full views of a type and its private
863 -- dependents (i.e. its subtypes and derived types).
865 ------------------------------------
866 -- Structures for Error Reporting --
867 ------------------------------------
869 Instantiation_Node
: Node_Id
;
870 -- Used by subprograms that validate instantiation of formal parameters
871 -- where there might be no actual on which to place the error message.
872 -- Also used to locate the instantiation node for generic subunits.
874 Instantiation_Error
: exception;
875 -- When there is a semantic error in the generic parameter matching,
876 -- there is no point in continuing the instantiation, because the
877 -- number of cascaded errors is unpredictable. This exception aborts
878 -- the instantiation process altogether.
880 S_Adjustment
: Sloc_Adjustment
;
881 -- Offset created for each node in an instantiation, in order to keep
882 -- track of the source position of the instantiation in each of its nodes.
883 -- A subsequent semantic error or warning on a construct of the instance
884 -- points to both places: the original generic node, and the point of
885 -- instantiation. See Sinput and Sinput.L for additional details.
887 ------------------------------------------------------------
888 -- Data structure for keeping track when inside a Generic --
889 ------------------------------------------------------------
891 -- The following table is used to save values of the Inside_A_Generic
892 -- flag (see spec of Sem) when they are saved by Start_Generic.
894 package Generic_Flags
is new Table
.Table
(
895 Table_Component_Type
=> Boolean,
896 Table_Index_Type
=> Int
,
897 Table_Low_Bound
=> 0,
899 Table_Increment
=> 200,
900 Table_Name
=> "Generic_Flags");
902 ---------------------------
903 -- Abandon_Instantiation --
904 ---------------------------
906 procedure Abandon_Instantiation
(N
: Node_Id
) is
908 Error_Msg_N
("\instantiation abandoned!", N
);
909 raise Instantiation_Error
;
910 end Abandon_Instantiation
;
912 --------------------------
913 -- Analyze_Associations --
914 --------------------------
916 function Analyze_Associations
919 F_Copy
: List_Id
) return List_Id
921 Actuals_To_Freeze
: constant Elist_Id
:= New_Elmt_List
;
922 Assoc
: constant List_Id
:= New_List
;
923 Default_Actuals
: constant Elist_Id
:= New_Elmt_List
;
924 Gen_Unit
: constant Entity_Id
:=
925 Defining_Entity
(Parent
(F_Copy
));
929 Analyzed_Formal
: Node_Id
;
930 First_Named
: Node_Id
:= Empty
;
934 Saved_Formal
: Node_Id
;
936 Default_Formals
: constant List_Id
:= New_List
;
937 -- If an Others_Choice is present, some of the formals may be defaulted.
938 -- To simplify the treatment of visibility in an instance, we introduce
939 -- individual defaults for each such formal. These defaults are
940 -- appended to the list of associations and replace the Others_Choice.
942 Found_Assoc
: Node_Id
;
943 -- Association for the current formal being match. Empty if there are
944 -- no remaining actuals, or if there is no named association with the
945 -- name of the formal.
947 Is_Named_Assoc
: Boolean;
948 Num_Matched
: Int
:= 0;
949 Num_Actuals
: Int
:= 0;
951 Others_Present
: Boolean := False;
952 Others_Choice
: Node_Id
:= Empty
;
953 -- In Ada 2005, indicates partial parametrization of a formal
954 -- package. As usual an other association must be last in the list.
956 procedure Check_Overloaded_Formal_Subprogram
(Formal
: Entity_Id
);
957 -- Apply RM 12.3 (9): if a formal subprogram is overloaded, the instance
958 -- cannot have a named association for it. AI05-0025 extends this rule
959 -- to formals of formal packages by AI05-0025, and it also applies to
960 -- box-initialized formals.
962 function Has_Fully_Defined_Profile
(Subp
: Entity_Id
) return Boolean;
963 -- Determine whether the parameter types and the return type of Subp
964 -- are fully defined at the point of instantiation.
966 function Matching_Actual
968 A_F
: Entity_Id
) return Node_Id
;
969 -- Find actual that corresponds to a given a formal parameter. If the
970 -- actuals are positional, return the next one, if any. If the actuals
971 -- are named, scan the parameter associations to find the right one.
972 -- A_F is the corresponding entity in the analyzed generic,which is
973 -- placed on the selector name for ASIS use.
975 -- In Ada 2005, a named association may be given with a box, in which
976 -- case Matching_Actual sets Found_Assoc to the generic association,
977 -- but return Empty for the actual itself. In this case the code below
978 -- creates a corresponding declaration for the formal.
980 function Partial_Parametrization
return Boolean;
981 -- Ada 2005: if no match is found for a given formal, check if the
982 -- association for it includes a box, or whether the associations
983 -- include an Others clause.
985 procedure Process_Default
(F
: Entity_Id
);
986 -- Add a copy of the declaration of generic formal F to the list of
987 -- associations, and add an explicit box association for F if there
988 -- is none yet, and the default comes from an Others_Choice.
990 function Renames_Standard_Subprogram
(Subp
: Entity_Id
) return Boolean;
991 -- Determine whether Subp renames one of the subprograms defined in the
992 -- generated package Standard.
994 procedure Set_Analyzed_Formal
;
995 -- Find the node in the generic copy that corresponds to a given formal.
996 -- The semantic information on this node is used to perform legality
997 -- checks on the actuals. Because semantic analysis can introduce some
998 -- anonymous entities or modify the declaration node itself, the
999 -- correspondence between the two lists is not one-one. In addition to
1000 -- anonymous types, the presence a formal equality will introduce an
1001 -- implicit declaration for the corresponding inequality.
1003 ----------------------------------------
1004 -- Check_Overloaded_Formal_Subprogram --
1005 ----------------------------------------
1007 procedure Check_Overloaded_Formal_Subprogram
(Formal
: Entity_Id
) is
1008 Temp_Formal
: Entity_Id
;
1011 Temp_Formal
:= First
(Formals
);
1012 while Present
(Temp_Formal
) loop
1013 if Nkind
(Temp_Formal
) in N_Formal_Subprogram_Declaration
1014 and then Temp_Formal
/= Formal
1016 Chars
(Defining_Unit_Name
(Specification
(Formal
))) =
1017 Chars
(Defining_Unit_Name
(Specification
(Temp_Formal
)))
1019 if Present
(Found_Assoc
) then
1021 ("named association not allowed for overloaded formal",
1026 ("named association not allowed for overloaded formal",
1030 Abandon_Instantiation
(Instantiation_Node
);
1035 end Check_Overloaded_Formal_Subprogram
;
1037 -------------------------------
1038 -- Has_Fully_Defined_Profile --
1039 -------------------------------
1041 function Has_Fully_Defined_Profile
(Subp
: Entity_Id
) return Boolean is
1042 function Is_Fully_Defined_Type
(Typ
: Entity_Id
) return Boolean;
1043 -- Determine whethet type Typ is fully defined
1045 ---------------------------
1046 -- Is_Fully_Defined_Type --
1047 ---------------------------
1049 function Is_Fully_Defined_Type
(Typ
: Entity_Id
) return Boolean is
1051 -- A private type without a full view is not fully defined
1053 if Is_Private_Type
(Typ
)
1054 and then No
(Full_View
(Typ
))
1058 -- An incomplete type is never fully defined
1060 elsif Is_Incomplete_Type
(Typ
) then
1063 -- All other types are fully defined
1068 end Is_Fully_Defined_Type
;
1070 -- Local declarations
1074 -- Start of processing for Has_Fully_Defined_Profile
1077 -- Check the parameters
1079 Param
:= First_Formal
(Subp
);
1080 while Present
(Param
) loop
1081 if not Is_Fully_Defined_Type
(Etype
(Param
)) then
1085 Next_Formal
(Param
);
1088 -- Check the return type
1090 return Is_Fully_Defined_Type
(Etype
(Subp
));
1091 end Has_Fully_Defined_Profile
;
1093 ---------------------
1094 -- Matching_Actual --
1095 ---------------------
1097 function Matching_Actual
1099 A_F
: Entity_Id
) return Node_Id
1105 Is_Named_Assoc
:= False;
1107 -- End of list of purely positional parameters
1109 if No
(Actual
) or else Nkind
(Actual
) = N_Others_Choice
then
1110 Found_Assoc
:= Empty
;
1113 -- Case of positional parameter corresponding to current formal
1115 elsif No
(Selector_Name
(Actual
)) then
1116 Found_Assoc
:= Actual
;
1117 Act
:= Explicit_Generic_Actual_Parameter
(Actual
);
1118 Num_Matched
:= Num_Matched
+ 1;
1121 -- Otherwise scan list of named actuals to find the one with the
1122 -- desired name. All remaining actuals have explicit names.
1125 Is_Named_Assoc
:= True;
1126 Found_Assoc
:= Empty
;
1130 while Present
(Actual
) loop
1131 if Chars
(Selector_Name
(Actual
)) = Chars
(F
) then
1132 Set_Entity
(Selector_Name
(Actual
), A_F
);
1133 Set_Etype
(Selector_Name
(Actual
), Etype
(A_F
));
1134 Generate_Reference
(A_F
, Selector_Name
(Actual
));
1135 Found_Assoc
:= Actual
;
1136 Act
:= Explicit_Generic_Actual_Parameter
(Actual
);
1137 Num_Matched
:= Num_Matched
+ 1;
1145 -- Reset for subsequent searches. In most cases the named
1146 -- associations are in order. If they are not, we reorder them
1147 -- to avoid scanning twice the same actual. This is not just a
1148 -- question of efficiency: there may be multiple defaults with
1149 -- boxes that have the same name. In a nested instantiation we
1150 -- insert actuals for those defaults, and cannot rely on their
1151 -- names to disambiguate them.
1153 if Actual
= First_Named
then
1156 elsif Present
(Actual
) then
1157 Insert_Before
(First_Named
, Remove_Next
(Prev
));
1160 Actual
:= First_Named
;
1163 if Is_Entity_Name
(Act
) and then Present
(Entity
(Act
)) then
1164 Set_Used_As_Generic_Actual
(Entity
(Act
));
1168 end Matching_Actual
;
1170 -----------------------------
1171 -- Partial_Parametrization --
1172 -----------------------------
1174 function Partial_Parametrization
return Boolean is
1176 return Others_Present
1177 or else (Present
(Found_Assoc
) and then Box_Present
(Found_Assoc
));
1178 end Partial_Parametrization
;
1180 ---------------------
1181 -- Process_Default --
1182 ---------------------
1184 procedure Process_Default
(F
: Entity_Id
) is
1185 Loc
: constant Source_Ptr
:= Sloc
(I_Node
);
1186 F_Id
: constant Entity_Id
:= Defining_Entity
(F
);
1192 -- Append copy of formal declaration to associations, and create new
1193 -- defining identifier for it.
1195 Decl
:= New_Copy_Tree
(F
);
1196 Id
:= Make_Defining_Identifier
(Sloc
(F_Id
), Chars
(F_Id
));
1198 if Nkind
(F
) in N_Formal_Subprogram_Declaration
then
1199 Set_Defining_Unit_Name
(Specification
(Decl
), Id
);
1202 Set_Defining_Identifier
(Decl
, Id
);
1205 Append
(Decl
, Assoc
);
1207 if No
(Found_Assoc
) then
1209 Make_Generic_Association
(Loc
,
1210 Selector_Name
=> New_Occurrence_Of
(Id
, Loc
),
1211 Explicit_Generic_Actual_Parameter
=> Empty
);
1212 Set_Box_Present
(Default
);
1213 Append
(Default
, Default_Formals
);
1215 end Process_Default
;
1217 ---------------------------------
1218 -- Renames_Standard_Subprogram --
1219 ---------------------------------
1221 function Renames_Standard_Subprogram
(Subp
: Entity_Id
) return Boolean is
1226 while Present
(Id
) loop
1227 if Scope
(Id
) = Standard_Standard
then
1235 end Renames_Standard_Subprogram
;
1237 -------------------------
1238 -- Set_Analyzed_Formal --
1239 -------------------------
1241 procedure Set_Analyzed_Formal
is
1245 while Present
(Analyzed_Formal
) loop
1246 Kind
:= Nkind
(Analyzed_Formal
);
1248 case Nkind
(Formal
) is
1250 when N_Formal_Subprogram_Declaration
=>
1251 exit when Kind
in N_Formal_Subprogram_Declaration
1254 (Defining_Unit_Name
(Specification
(Formal
))) =
1256 (Defining_Unit_Name
(Specification
(Analyzed_Formal
)));
1258 when N_Formal_Package_Declaration
=>
1259 exit when Nkind_In
(Kind
, N_Formal_Package_Declaration
,
1260 N_Generic_Package_Declaration
,
1261 N_Package_Declaration
);
1263 when N_Use_Package_Clause | N_Use_Type_Clause
=> exit;
1267 -- Skip freeze nodes, and nodes inserted to replace
1268 -- unrecognized pragmas.
1271 Kind
not in N_Formal_Subprogram_Declaration
1272 and then not Nkind_In
(Kind
, N_Subprogram_Declaration
,
1276 and then Chars
(Defining_Identifier
(Formal
)) =
1277 Chars
(Defining_Identifier
(Analyzed_Formal
));
1280 Next
(Analyzed_Formal
);
1282 end Set_Analyzed_Formal
;
1284 -- Start of processing for Analyze_Associations
1287 Actuals
:= Generic_Associations
(I_Node
);
1289 if Present
(Actuals
) then
1291 -- Check for an Others choice, indicating a partial parametrization
1292 -- for a formal package.
1294 Actual
:= First
(Actuals
);
1295 while Present
(Actual
) loop
1296 if Nkind
(Actual
) = N_Others_Choice
then
1297 Others_Present
:= True;
1298 Others_Choice
:= Actual
;
1300 if Present
(Next
(Actual
)) then
1301 Error_Msg_N
("others must be last association", Actual
);
1304 -- This subprogram is used both for formal packages and for
1305 -- instantiations. For the latter, associations must all be
1308 if Nkind
(I_Node
) /= N_Formal_Package_Declaration
1309 and then Comes_From_Source
(I_Node
)
1312 ("others association not allowed in an instance",
1316 -- In any case, nothing to do after the others association
1320 elsif Box_Present
(Actual
)
1321 and then Comes_From_Source
(I_Node
)
1322 and then Nkind
(I_Node
) /= N_Formal_Package_Declaration
1325 ("box association not allowed in an instance", Actual
);
1331 -- If named associations are present, save first named association
1332 -- (it may of course be Empty) to facilitate subsequent name search.
1334 First_Named
:= First
(Actuals
);
1335 while Present
(First_Named
)
1336 and then Nkind
(First_Named
) /= N_Others_Choice
1337 and then No
(Selector_Name
(First_Named
))
1339 Num_Actuals
:= Num_Actuals
+ 1;
1344 Named
:= First_Named
;
1345 while Present
(Named
) loop
1346 if Nkind
(Named
) /= N_Others_Choice
1347 and then No
(Selector_Name
(Named
))
1349 Error_Msg_N
("invalid positional actual after named one", Named
);
1350 Abandon_Instantiation
(Named
);
1353 -- A named association may lack an actual parameter, if it was
1354 -- introduced for a default subprogram that turns out to be local
1355 -- to the outer instantiation.
1357 if Nkind
(Named
) /= N_Others_Choice
1358 and then Present
(Explicit_Generic_Actual_Parameter
(Named
))
1360 Num_Actuals
:= Num_Actuals
+ 1;
1366 if Present
(Formals
) then
1367 Formal
:= First_Non_Pragma
(Formals
);
1368 Analyzed_Formal
:= First_Non_Pragma
(F_Copy
);
1370 if Present
(Actuals
) then
1371 Actual
:= First
(Actuals
);
1373 -- All formals should have default values
1379 while Present
(Formal
) loop
1380 Set_Analyzed_Formal
;
1381 Saved_Formal
:= Next_Non_Pragma
(Formal
);
1383 case Nkind
(Formal
) is
1384 when N_Formal_Object_Declaration
=>
1387 Defining_Identifier
(Formal
),
1388 Defining_Identifier
(Analyzed_Formal
));
1390 if No
(Match
) and then Partial_Parametrization
then
1391 Process_Default
(Formal
);
1394 (Instantiate_Object
(Formal
, Match
, Analyzed_Formal
),
1398 when N_Formal_Type_Declaration
=>
1401 Defining_Identifier
(Formal
),
1402 Defining_Identifier
(Analyzed_Formal
));
1405 if Partial_Parametrization
then
1406 Process_Default
(Formal
);
1409 Error_Msg_Sloc
:= Sloc
(Gen_Unit
);
1413 Defining_Identifier
(Formal
));
1414 Error_Msg_NE
("\in instantiation of & declared#",
1415 Instantiation_Node
, Gen_Unit
);
1416 Abandon_Instantiation
(Instantiation_Node
);
1423 (Formal
, Match
, Analyzed_Formal
, Assoc
),
1426 -- An instantiation is a freeze point for the actuals,
1427 -- unless this is a rewritten formal package, or the
1428 -- formal is an Ada 2012 formal incomplete type.
1430 if Nkind
(I_Node
) = N_Formal_Package_Declaration
1432 (Ada_Version
>= Ada_2012
1434 Ekind
(Defining_Identifier
(Analyzed_Formal
)) =
1440 Append_Elmt
(Entity
(Match
), Actuals_To_Freeze
);
1444 -- A remote access-to-class-wide type is not a legal actual
1445 -- for a generic formal of an access type (E.2.2(17/2)).
1446 -- In GNAT an exception to this rule is introduced when
1447 -- the formal is marked as remote using implementation
1448 -- defined aspect/pragma Remote_Access_Type. In that case
1449 -- the actual must be remote as well.
1451 if Nkind
(Analyzed_Formal
) = N_Formal_Type_Declaration
1453 Nkind
(Formal_Type_Definition
(Analyzed_Formal
)) =
1454 N_Access_To_Object_Definition
1457 Formal_Ent
: constant Entity_Id
:=
1458 Defining_Identifier
(Analyzed_Formal
);
1460 if Is_Remote_Access_To_Class_Wide_Type
(Entity
(Match
))
1461 = Is_Remote_Types
(Formal_Ent
)
1463 -- Remoteness of formal and actual match
1467 elsif Is_Remote_Types
(Formal_Ent
) then
1469 -- Remote formal, non-remote actual
1472 ("actual for& must be remote", Match
, Formal_Ent
);
1475 -- Non-remote formal, remote actual
1478 ("actual for& may not be remote",
1484 when N_Formal_Subprogram_Declaration
=>
1487 (Defining_Unit_Name
(Specification
(Formal
)),
1488 Defining_Unit_Name
(Specification
(Analyzed_Formal
)));
1490 -- If the formal subprogram has the same name as another
1491 -- formal subprogram of the generic, then a named
1492 -- association is illegal (12.3(9)). Exclude named
1493 -- associations that are generated for a nested instance.
1496 and then Is_Named_Assoc
1497 and then Comes_From_Source
(Found_Assoc
)
1499 Check_Overloaded_Formal_Subprogram
(Formal
);
1502 -- If there is no corresponding actual, this may be case of
1503 -- partial parametrization, or else the formal has a default
1506 if No
(Match
) and then Partial_Parametrization
then
1507 Process_Default
(Formal
);
1509 if Nkind
(I_Node
) = N_Formal_Package_Declaration
then
1510 Check_Overloaded_Formal_Subprogram
(Formal
);
1515 Instantiate_Formal_Subprogram
1516 (Formal
, Match
, Analyzed_Formal
));
1518 -- An instantiation is a freeze point for the actuals,
1519 -- unless this is a rewritten formal package.
1521 if Nkind
(I_Node
) /= N_Formal_Package_Declaration
1522 and then Nkind
(Match
) = N_Identifier
1523 and then Is_Subprogram
(Entity
(Match
))
1525 -- The actual subprogram may rename a routine defined
1526 -- in Standard. Avoid freezing such renamings because
1527 -- subprograms coming from Standard cannot be frozen.
1530 not Renames_Standard_Subprogram
(Entity
(Match
))
1532 -- If the actual subprogram comes from a different
1533 -- unit, it is already frozen, either by a body in
1534 -- that unit or by the end of the declarative part
1535 -- of the unit. This check avoids the freezing of
1536 -- subprograms defined in Standard which are used
1537 -- as generic actuals.
1539 and then In_Same_Code_Unit
(Entity
(Match
), I_Node
)
1540 and then Has_Fully_Defined_Profile
(Entity
(Match
))
1542 -- Mark the subprogram as having a delayed freeze
1543 -- since this may be an out-of-order action.
1545 Set_Has_Delayed_Freeze
(Entity
(Match
));
1546 Append_Elmt
(Entity
(Match
), Actuals_To_Freeze
);
1550 -- If this is a nested generic, preserve default for later
1554 and then Box_Present
(Formal
)
1557 (Defining_Unit_Name
(Specification
(Last
(Assoc
))),
1561 when N_Formal_Package_Declaration
=>
1564 Defining_Identifier
(Formal
),
1565 Defining_Identifier
(Original_Node
(Analyzed_Formal
)));
1568 if Partial_Parametrization
then
1569 Process_Default
(Formal
);
1572 Error_Msg_Sloc
:= Sloc
(Gen_Unit
);
1575 Instantiation_Node
, Defining_Identifier
(Formal
));
1576 Error_Msg_NE
("\in instantiation of & declared#",
1577 Instantiation_Node
, Gen_Unit
);
1579 Abandon_Instantiation
(Instantiation_Node
);
1585 (Instantiate_Formal_Package
1586 (Formal
, Match
, Analyzed_Formal
),
1590 -- For use type and use package appearing in the generic part,
1591 -- we have already copied them, so we can just move them where
1592 -- they belong (we mustn't recopy them since this would mess up
1593 -- the Sloc values).
1595 when N_Use_Package_Clause |
1596 N_Use_Type_Clause
=>
1597 if Nkind
(Original_Node
(I_Node
)) =
1598 N_Formal_Package_Declaration
1600 Append
(New_Copy_Tree
(Formal
), Assoc
);
1603 Append
(Formal
, Assoc
);
1607 raise Program_Error
;
1611 Formal
:= Saved_Formal
;
1612 Next_Non_Pragma
(Analyzed_Formal
);
1615 if Num_Actuals
> Num_Matched
then
1616 Error_Msg_Sloc
:= Sloc
(Gen_Unit
);
1618 if Present
(Selector_Name
(Actual
)) then
1620 ("unmatched actual&",
1621 Actual
, Selector_Name
(Actual
));
1622 Error_Msg_NE
("\in instantiation of& declared#",
1626 ("unmatched actual in instantiation of& declared#",
1631 elsif Present
(Actuals
) then
1633 ("too many actuals in generic instantiation", Instantiation_Node
);
1636 -- An instantiation freezes all generic actuals. The only exceptions
1637 -- to this are incomplete types and subprograms which are not fully
1638 -- defined at the point of instantiation.
1641 Elmt
: Elmt_Id
:= First_Elmt
(Actuals_To_Freeze
);
1643 while Present
(Elmt
) loop
1644 Freeze_Before
(I_Node
, Node
(Elmt
));
1649 -- If there are default subprograms, normalize the tree by adding
1650 -- explicit associations for them. This is required if the instance
1651 -- appears within a generic.
1659 Elmt
:= First_Elmt
(Default_Actuals
);
1660 while Present
(Elmt
) loop
1661 if No
(Actuals
) then
1662 Actuals
:= New_List
;
1663 Set_Generic_Associations
(I_Node
, Actuals
);
1666 Subp
:= Node
(Elmt
);
1668 Make_Generic_Association
(Sloc
(Subp
),
1669 Selector_Name
=> New_Occurrence_Of
(Subp
, Sloc
(Subp
)),
1670 Explicit_Generic_Actual_Parameter
=>
1671 New_Occurrence_Of
(Subp
, Sloc
(Subp
)));
1672 Mark_Rewrite_Insertion
(New_D
);
1673 Append_To
(Actuals
, New_D
);
1678 -- If this is a formal package, normalize the parameter list by adding
1679 -- explicit box associations for the formals that are covered by an
1682 if not Is_Empty_List
(Default_Formals
) then
1683 Append_List
(Default_Formals
, Formals
);
1687 end Analyze_Associations
;
1689 -------------------------------
1690 -- Analyze_Formal_Array_Type --
1691 -------------------------------
1693 procedure Analyze_Formal_Array_Type
1694 (T
: in out Entity_Id
;
1700 -- Treated like a non-generic array declaration, with additional
1705 if Nkind
(Def
) = N_Constrained_Array_Definition
then
1706 DSS
:= First
(Discrete_Subtype_Definitions
(Def
));
1707 while Present
(DSS
) loop
1708 if Nkind_In
(DSS
, N_Subtype_Indication
,
1710 N_Attribute_Reference
)
1712 Error_Msg_N
("only a subtype mark is allowed in a formal", DSS
);
1719 Array_Type_Declaration
(T
, Def
);
1720 Set_Is_Generic_Type
(Base_Type
(T
));
1722 if Ekind
(Component_Type
(T
)) = E_Incomplete_Type
1723 and then No
(Full_View
(Component_Type
(T
)))
1725 Error_Msg_N
("premature usage of incomplete type", Def
);
1727 -- Check that range constraint is not allowed on the component type
1728 -- of a generic formal array type (AARM 12.5.3(3))
1730 elsif Is_Internal
(Component_Type
(T
))
1731 and then Present
(Subtype_Indication
(Component_Definition
(Def
)))
1732 and then Nkind
(Original_Node
1733 (Subtype_Indication
(Component_Definition
(Def
)))) =
1734 N_Subtype_Indication
1737 ("in a formal, a subtype indication can only be "
1738 & "a subtype mark (RM 12.5.3(3))",
1739 Subtype_Indication
(Component_Definition
(Def
)));
1742 end Analyze_Formal_Array_Type
;
1744 ---------------------------------------------
1745 -- Analyze_Formal_Decimal_Fixed_Point_Type --
1746 ---------------------------------------------
1748 -- As for other generic types, we create a valid type representation with
1749 -- legal but arbitrary attributes, whose values are never considered
1750 -- static. For all scalar types we introduce an anonymous base type, with
1751 -- the same attributes. We choose the corresponding integer type to be
1752 -- Standard_Integer.
1753 -- Here and in other similar routines, the Sloc of the generated internal
1754 -- type must be the same as the sloc of the defining identifier of the
1755 -- formal type declaration, to provide proper source navigation.
1757 procedure Analyze_Formal_Decimal_Fixed_Point_Type
1761 Loc
: constant Source_Ptr
:= Sloc
(Def
);
1763 Base
: constant Entity_Id
:=
1765 (E_Decimal_Fixed_Point_Type
,
1767 Sloc
(Defining_Identifier
(Parent
(Def
))), 'G');
1769 Int_Base
: constant Entity_Id
:= Standard_Integer
;
1770 Delta_Val
: constant Ureal
:= Ureal_1
;
1771 Digs_Val
: constant Uint
:= Uint_6
;
1776 Set_Etype
(Base
, Base
);
1777 Set_Size_Info
(Base
, Int_Base
);
1778 Set_RM_Size
(Base
, RM_Size
(Int_Base
));
1779 Set_First_Rep_Item
(Base
, First_Rep_Item
(Int_Base
));
1780 Set_Digits_Value
(Base
, Digs_Val
);
1781 Set_Delta_Value
(Base
, Delta_Val
);
1782 Set_Small_Value
(Base
, Delta_Val
);
1783 Set_Scalar_Range
(Base
,
1785 Low_Bound
=> Make_Real_Literal
(Loc
, Ureal_1
),
1786 High_Bound
=> Make_Real_Literal
(Loc
, Ureal_1
)));
1788 Set_Is_Generic_Type
(Base
);
1789 Set_Parent
(Base
, Parent
(Def
));
1791 Set_Ekind
(T
, E_Decimal_Fixed_Point_Subtype
);
1792 Set_Etype
(T
, Base
);
1793 Set_Size_Info
(T
, Int_Base
);
1794 Set_RM_Size
(T
, RM_Size
(Int_Base
));
1795 Set_First_Rep_Item
(T
, First_Rep_Item
(Int_Base
));
1796 Set_Digits_Value
(T
, Digs_Val
);
1797 Set_Delta_Value
(T
, Delta_Val
);
1798 Set_Small_Value
(T
, Delta_Val
);
1799 Set_Scalar_Range
(T
, Scalar_Range
(Base
));
1800 Set_Is_Constrained
(T
);
1802 Check_Restriction
(No_Fixed_Point
, Def
);
1803 end Analyze_Formal_Decimal_Fixed_Point_Type
;
1805 -------------------------------------------
1806 -- Analyze_Formal_Derived_Interface_Type --
1807 -------------------------------------------
1809 procedure Analyze_Formal_Derived_Interface_Type
1814 Loc
: constant Source_Ptr
:= Sloc
(Def
);
1817 -- Rewrite as a type declaration of a derived type. This ensures that
1818 -- the interface list and primitive operations are properly captured.
1821 Make_Full_Type_Declaration
(Loc
,
1822 Defining_Identifier
=> T
,
1823 Type_Definition
=> Def
));
1825 Set_Is_Generic_Type
(T
);
1826 end Analyze_Formal_Derived_Interface_Type
;
1828 ---------------------------------
1829 -- Analyze_Formal_Derived_Type --
1830 ---------------------------------
1832 procedure Analyze_Formal_Derived_Type
1837 Loc
: constant Source_Ptr
:= Sloc
(Def
);
1838 Unk_Disc
: constant Boolean := Unknown_Discriminants_Present
(N
);
1842 Set_Is_Generic_Type
(T
);
1844 if Private_Present
(Def
) then
1846 Make_Private_Extension_Declaration
(Loc
,
1847 Defining_Identifier
=> T
,
1848 Discriminant_Specifications
=> Discriminant_Specifications
(N
),
1849 Unknown_Discriminants_Present
=> Unk_Disc
,
1850 Subtype_Indication
=> Subtype_Mark
(Def
),
1851 Interface_List
=> Interface_List
(Def
));
1853 Set_Abstract_Present
(New_N
, Abstract_Present
(Def
));
1854 Set_Limited_Present
(New_N
, Limited_Present
(Def
));
1855 Set_Synchronized_Present
(New_N
, Synchronized_Present
(Def
));
1859 Make_Full_Type_Declaration
(Loc
,
1860 Defining_Identifier
=> T
,
1861 Discriminant_Specifications
=>
1862 Discriminant_Specifications
(Parent
(T
)),
1864 Make_Derived_Type_Definition
(Loc
,
1865 Subtype_Indication
=> Subtype_Mark
(Def
)));
1867 Set_Abstract_Present
1868 (Type_Definition
(New_N
), Abstract_Present
(Def
));
1870 (Type_Definition
(New_N
), Limited_Present
(Def
));
1877 if not Is_Composite_Type
(T
) then
1879 ("unknown discriminants not allowed for elementary types", N
);
1881 Set_Has_Unknown_Discriminants
(T
);
1882 Set_Is_Constrained
(T
, False);
1886 -- If the parent type has a known size, so does the formal, which makes
1887 -- legal representation clauses that involve the formal.
1889 Set_Size_Known_At_Compile_Time
1890 (T
, Size_Known_At_Compile_Time
(Entity
(Subtype_Mark
(Def
))));
1891 end Analyze_Formal_Derived_Type
;
1893 ----------------------------------
1894 -- Analyze_Formal_Discrete_Type --
1895 ----------------------------------
1897 -- The operations defined for a discrete types are those of an enumeration
1898 -- type. The size is set to an arbitrary value, for use in analyzing the
1901 procedure Analyze_Formal_Discrete_Type
(T
: Entity_Id
; Def
: Node_Id
) is
1902 Loc
: constant Source_Ptr
:= Sloc
(Def
);
1906 Base
: constant Entity_Id
:=
1908 (E_Floating_Point_Type
, Current_Scope
,
1909 Sloc
(Defining_Identifier
(Parent
(Def
))), 'G');
1913 Set_Ekind
(T
, E_Enumeration_Subtype
);
1914 Set_Etype
(T
, Base
);
1917 Set_Is_Generic_Type
(T
);
1918 Set_Is_Constrained
(T
);
1920 -- For semantic analysis, the bounds of the type must be set to some
1921 -- non-static value. The simplest is to create attribute nodes for those
1922 -- bounds, that refer to the type itself. These bounds are never
1923 -- analyzed but serve as place-holders.
1926 Make_Attribute_Reference
(Loc
,
1927 Attribute_Name
=> Name_First
,
1928 Prefix
=> New_Reference_To
(T
, Loc
));
1932 Make_Attribute_Reference
(Loc
,
1933 Attribute_Name
=> Name_Last
,
1934 Prefix
=> New_Reference_To
(T
, Loc
));
1937 Set_Scalar_Range
(T
,
1942 Set_Ekind
(Base
, E_Enumeration_Type
);
1943 Set_Etype
(Base
, Base
);
1944 Init_Size
(Base
, 8);
1945 Init_Alignment
(Base
);
1946 Set_Is_Generic_Type
(Base
);
1947 Set_Scalar_Range
(Base
, Scalar_Range
(T
));
1948 Set_Parent
(Base
, Parent
(Def
));
1949 end Analyze_Formal_Discrete_Type
;
1951 ----------------------------------
1952 -- Analyze_Formal_Floating_Type --
1953 ---------------------------------
1955 procedure Analyze_Formal_Floating_Type
(T
: Entity_Id
; Def
: Node_Id
) is
1956 Base
: constant Entity_Id
:=
1958 (E_Floating_Point_Type
, Current_Scope
,
1959 Sloc
(Defining_Identifier
(Parent
(Def
))), 'G');
1962 -- The various semantic attributes are taken from the predefined type
1963 -- Float, just so that all of them are initialized. Their values are
1964 -- never used because no constant folding or expansion takes place in
1965 -- the generic itself.
1968 Set_Ekind
(T
, E_Floating_Point_Subtype
);
1969 Set_Etype
(T
, Base
);
1970 Set_Size_Info
(T
, (Standard_Float
));
1971 Set_RM_Size
(T
, RM_Size
(Standard_Float
));
1972 Set_Digits_Value
(T
, Digits_Value
(Standard_Float
));
1973 Set_Scalar_Range
(T
, Scalar_Range
(Standard_Float
));
1974 Set_Is_Constrained
(T
);
1976 Set_Is_Generic_Type
(Base
);
1977 Set_Etype
(Base
, Base
);
1978 Set_Size_Info
(Base
, (Standard_Float
));
1979 Set_RM_Size
(Base
, RM_Size
(Standard_Float
));
1980 Set_Digits_Value
(Base
, Digits_Value
(Standard_Float
));
1981 Set_Scalar_Range
(Base
, Scalar_Range
(Standard_Float
));
1982 Set_Parent
(Base
, Parent
(Def
));
1984 Check_Restriction
(No_Floating_Point
, Def
);
1985 end Analyze_Formal_Floating_Type
;
1987 -----------------------------------
1988 -- Analyze_Formal_Interface_Type;--
1989 -----------------------------------
1991 procedure Analyze_Formal_Interface_Type
1996 Loc
: constant Source_Ptr
:= Sloc
(N
);
2001 Make_Full_Type_Declaration
(Loc
,
2002 Defining_Identifier
=> T
,
2003 Type_Definition
=> Def
);
2007 Set_Is_Generic_Type
(T
);
2008 end Analyze_Formal_Interface_Type
;
2010 ---------------------------------
2011 -- Analyze_Formal_Modular_Type --
2012 ---------------------------------
2014 procedure Analyze_Formal_Modular_Type
(T
: Entity_Id
; Def
: Node_Id
) is
2016 -- Apart from their entity kind, generic modular types are treated like
2017 -- signed integer types, and have the same attributes.
2019 Analyze_Formal_Signed_Integer_Type
(T
, Def
);
2020 Set_Ekind
(T
, E_Modular_Integer_Subtype
);
2021 Set_Ekind
(Etype
(T
), E_Modular_Integer_Type
);
2023 end Analyze_Formal_Modular_Type
;
2025 ---------------------------------------
2026 -- Analyze_Formal_Object_Declaration --
2027 ---------------------------------------
2029 procedure Analyze_Formal_Object_Declaration
(N
: Node_Id
) is
2030 E
: constant Node_Id
:= Default_Expression
(N
);
2031 Id
: constant Node_Id
:= Defining_Identifier
(N
);
2038 -- Determine the mode of the formal object
2040 if Out_Present
(N
) then
2041 K
:= E_Generic_In_Out_Parameter
;
2043 if not In_Present
(N
) then
2044 Error_Msg_N
("formal generic objects cannot have mode OUT", N
);
2048 K
:= E_Generic_In_Parameter
;
2051 if Present
(Subtype_Mark
(N
)) then
2052 Find_Type
(Subtype_Mark
(N
));
2053 T
:= Entity
(Subtype_Mark
(N
));
2055 -- Verify that there is no redundant null exclusion
2057 if Null_Exclusion_Present
(N
) then
2058 if not Is_Access_Type
(T
) then
2060 ("null exclusion can only apply to an access type", N
);
2062 elsif Can_Never_Be_Null
(T
) then
2064 ("`NOT NULL` not allowed (& already excludes null)",
2069 -- Ada 2005 (AI-423): Formal object with an access definition
2072 Check_Access_Definition
(N
);
2073 T
:= Access_Definition
2075 N
=> Access_Definition
(N
));
2078 if Ekind
(T
) = E_Incomplete_Type
then
2080 Error_Node
: Node_Id
;
2083 if Present
(Subtype_Mark
(N
)) then
2084 Error_Node
:= Subtype_Mark
(N
);
2086 Check_Access_Definition
(N
);
2087 Error_Node
:= Access_Definition
(N
);
2090 Error_Msg_N
("premature usage of incomplete type", Error_Node
);
2094 if K
= E_Generic_In_Parameter
then
2096 -- Ada 2005 (AI-287): Limited aggregates allowed in generic formals
2098 if Ada_Version
< Ada_2005
and then Is_Limited_Type
(T
) then
2100 ("generic formal of mode IN must not be of limited type", N
);
2101 Explain_Limited_Type
(T
, N
);
2104 if Is_Abstract_Type
(T
) then
2106 ("generic formal of mode IN must not be of abstract type", N
);
2110 Preanalyze_Spec_Expression
(E
, T
);
2112 if Is_Limited_Type
(T
) and then not OK_For_Limited_Init
(T
, E
) then
2114 ("initialization not allowed for limited types", E
);
2115 Explain_Limited_Type
(T
, E
);
2122 -- Case of generic IN OUT parameter
2125 -- If the formal has an unconstrained type, construct its actual
2126 -- subtype, as is done for subprogram formals. In this fashion, all
2127 -- its uses can refer to specific bounds.
2132 if (Is_Array_Type
(T
)
2133 and then not Is_Constrained
(T
))
2135 (Ekind
(T
) = E_Record_Type
2136 and then Has_Discriminants
(T
))
2139 Non_Freezing_Ref
: constant Node_Id
:=
2140 New_Reference_To
(Id
, Sloc
(Id
));
2144 -- Make sure the actual subtype doesn't generate bogus freezing
2146 Set_Must_Not_Freeze
(Non_Freezing_Ref
);
2147 Decl
:= Build_Actual_Subtype
(T
, Non_Freezing_Ref
);
2148 Insert_Before_And_Analyze
(N
, Decl
);
2149 Set_Actual_Subtype
(Id
, Defining_Identifier
(Decl
));
2152 Set_Actual_Subtype
(Id
, T
);
2157 ("initialization not allowed for `IN OUT` formals", N
);
2161 if Has_Aspects
(N
) then
2162 Analyze_Aspect_Specifications
(N
, Id
);
2164 end Analyze_Formal_Object_Declaration
;
2166 ----------------------------------------------
2167 -- Analyze_Formal_Ordinary_Fixed_Point_Type --
2168 ----------------------------------------------
2170 procedure Analyze_Formal_Ordinary_Fixed_Point_Type
2174 Loc
: constant Source_Ptr
:= Sloc
(Def
);
2175 Base
: constant Entity_Id
:=
2177 (E_Ordinary_Fixed_Point_Type
, Current_Scope
,
2178 Sloc
(Defining_Identifier
(Parent
(Def
))), 'G');
2181 -- The semantic attributes are set for completeness only, their values
2182 -- will never be used, since all properties of the type are non-static.
2185 Set_Ekind
(T
, E_Ordinary_Fixed_Point_Subtype
);
2186 Set_Etype
(T
, Base
);
2187 Set_Size_Info
(T
, Standard_Integer
);
2188 Set_RM_Size
(T
, RM_Size
(Standard_Integer
));
2189 Set_Small_Value
(T
, Ureal_1
);
2190 Set_Delta_Value
(T
, Ureal_1
);
2191 Set_Scalar_Range
(T
,
2193 Low_Bound
=> Make_Real_Literal
(Loc
, Ureal_1
),
2194 High_Bound
=> Make_Real_Literal
(Loc
, Ureal_1
)));
2195 Set_Is_Constrained
(T
);
2197 Set_Is_Generic_Type
(Base
);
2198 Set_Etype
(Base
, Base
);
2199 Set_Size_Info
(Base
, Standard_Integer
);
2200 Set_RM_Size
(Base
, RM_Size
(Standard_Integer
));
2201 Set_Small_Value
(Base
, Ureal_1
);
2202 Set_Delta_Value
(Base
, Ureal_1
);
2203 Set_Scalar_Range
(Base
, Scalar_Range
(T
));
2204 Set_Parent
(Base
, Parent
(Def
));
2206 Check_Restriction
(No_Fixed_Point
, Def
);
2207 end Analyze_Formal_Ordinary_Fixed_Point_Type
;
2209 ----------------------------------------
2210 -- Analyze_Formal_Package_Declaration --
2211 ----------------------------------------
2213 procedure Analyze_Formal_Package_Declaration
(N
: Node_Id
) is
2214 Loc
: constant Source_Ptr
:= Sloc
(N
);
2215 Pack_Id
: constant Entity_Id
:= Defining_Identifier
(N
);
2217 Gen_Id
: constant Node_Id
:= Name
(N
);
2219 Gen_Unit
: Entity_Id
;
2221 Parent_Installed
: Boolean := False;
2223 Parent_Instance
: Entity_Id
;
2224 Renaming_In_Par
: Entity_Id
;
2225 Associations
: Boolean := True;
2227 Vis_Prims_List
: Elist_Id
:= No_Elist
;
2228 -- List of primitives made temporarily visible in the instantiation
2229 -- to match the visibility of the formal type
2231 function Build_Local_Package
return Node_Id
;
2232 -- The formal package is rewritten so that its parameters are replaced
2233 -- with corresponding declarations. For parameters with bona fide
2234 -- associations these declarations are created by Analyze_Associations
2235 -- as for a regular instantiation. For boxed parameters, we preserve
2236 -- the formal declarations and analyze them, in order to introduce
2237 -- entities of the right kind in the environment of the formal.
2239 -------------------------
2240 -- Build_Local_Package --
2241 -------------------------
2243 function Build_Local_Package
return Node_Id
is
2245 Pack_Decl
: Node_Id
;
2248 -- Within the formal, the name of the generic package is a renaming
2249 -- of the formal (as for a regular instantiation).
2252 Make_Package_Declaration
(Loc
,
2255 (Specification
(Original_Node
(Gen_Decl
)),
2256 Empty
, Instantiating
=> True));
2258 Renaming
:= Make_Package_Renaming_Declaration
(Loc
,
2259 Defining_Unit_Name
=>
2260 Make_Defining_Identifier
(Loc
, Chars
(Gen_Unit
)),
2261 Name
=> New_Occurrence_Of
(Formal
, Loc
));
2263 if Nkind
(Gen_Id
) = N_Identifier
2264 and then Chars
(Gen_Id
) = Chars
(Pack_Id
)
2267 ("& is hidden within declaration of instance", Gen_Id
, Gen_Unit
);
2270 -- If the formal is declared with a box, or with an others choice,
2271 -- create corresponding declarations for all entities in the formal
2272 -- part, so that names with the proper types are available in the
2273 -- specification of the formal package.
2275 -- On the other hand, if there are no associations, then all the
2276 -- formals must have defaults, and this will be checked by the
2277 -- call to Analyze_Associations.
2280 or else Nkind
(First
(Generic_Associations
(N
))) = N_Others_Choice
2283 Formal_Decl
: Node_Id
;
2286 -- TBA : for a formal package, need to recurse ???
2291 (Generic_Formal_Declarations
(Original_Node
(Gen_Decl
)));
2292 while Present
(Formal_Decl
) loop
2294 (Decls
, Copy_Generic_Node
(Formal_Decl
, Empty
, True));
2299 -- If generic associations are present, use Analyze_Associations to
2300 -- create the proper renaming declarations.
2304 Act_Tree
: constant Node_Id
:=
2306 (Original_Node
(Gen_Decl
), Empty
,
2307 Instantiating
=> True);
2310 Generic_Renamings
.Set_Last
(0);
2311 Generic_Renamings_HTable
.Reset
;
2312 Instantiation_Node
:= N
;
2315 Analyze_Associations
2316 (I_Node
=> Original_Node
(N
),
2317 Formals
=> Generic_Formal_Declarations
(Act_Tree
),
2318 F_Copy
=> Generic_Formal_Declarations
(Gen_Decl
));
2320 Vis_Prims_List
:= Check_Hidden_Primitives
(Decls
);
2324 Append
(Renaming
, To
=> Decls
);
2326 -- Add generated declarations ahead of local declarations in
2329 if No
(Visible_Declarations
(Specification
(Pack_Decl
))) then
2330 Set_Visible_Declarations
(Specification
(Pack_Decl
), Decls
);
2333 (First
(Visible_Declarations
(Specification
(Pack_Decl
))),
2338 end Build_Local_Package
;
2340 -- Start of processing for Analyze_Formal_Package_Declaration
2343 Text_IO_Kludge
(Gen_Id
);
2346 Check_Generic_Child_Unit
(Gen_Id
, Parent_Installed
);
2347 Gen_Unit
:= Entity
(Gen_Id
);
2349 -- Check for a formal package that is a package renaming
2351 if Present
(Renamed_Object
(Gen_Unit
)) then
2353 -- Indicate that unit is used, before replacing it with renamed
2354 -- entity for use below.
2356 if In_Extended_Main_Source_Unit
(N
) then
2357 Set_Is_Instantiated
(Gen_Unit
);
2358 Generate_Reference
(Gen_Unit
, N
);
2361 Gen_Unit
:= Renamed_Object
(Gen_Unit
);
2364 if Ekind
(Gen_Unit
) /= E_Generic_Package
then
2365 Error_Msg_N
("expect generic package name", Gen_Id
);
2369 elsif Gen_Unit
= Current_Scope
then
2371 ("generic package cannot be used as a formal package of itself",
2376 elsif In_Open_Scopes
(Gen_Unit
) then
2377 if Is_Compilation_Unit
(Gen_Unit
)
2378 and then Is_Child_Unit
(Current_Scope
)
2380 -- Special-case the error when the formal is a parent, and
2381 -- continue analysis to minimize cascaded errors.
2384 ("generic parent cannot be used as formal package "
2385 & "of a child unit",
2390 ("generic package cannot be used as a formal package "
2398 -- Check that name of formal package does not hide name of generic,
2399 -- or its leading prefix. This check must be done separately because
2400 -- the name of the generic has already been analyzed.
2403 Gen_Name
: Entity_Id
;
2407 while Nkind
(Gen_Name
) = N_Expanded_Name
loop
2408 Gen_Name
:= Prefix
(Gen_Name
);
2411 if Chars
(Gen_Name
) = Chars
(Pack_Id
) then
2413 ("& is hidden within declaration of formal package",
2419 or else No
(Generic_Associations
(N
))
2420 or else Nkind
(First
(Generic_Associations
(N
))) = N_Others_Choice
2422 Associations
:= False;
2425 -- If there are no generic associations, the generic parameters appear
2426 -- as local entities and are instantiated like them. We copy the generic
2427 -- package declaration as if it were an instantiation, and analyze it
2428 -- like a regular package, except that we treat the formals as
2429 -- additional visible components.
2431 Gen_Decl
:= Unit_Declaration_Node
(Gen_Unit
);
2433 if In_Extended_Main_Source_Unit
(N
) then
2434 Set_Is_Instantiated
(Gen_Unit
);
2435 Generate_Reference
(Gen_Unit
, N
);
2438 Formal
:= New_Copy
(Pack_Id
);
2439 Create_Instantiation_Source
(N
, Gen_Unit
, False, S_Adjustment
);
2442 -- Make local generic without formals. The formals will be replaced
2443 -- with internal declarations.
2445 New_N
:= Build_Local_Package
;
2447 -- If there are errors in the parameter list, Analyze_Associations
2448 -- raises Instantiation_Error. Patch the declaration to prevent
2449 -- further exception propagation.
2452 when Instantiation_Error
=>
2454 Enter_Name
(Formal
);
2455 Set_Ekind
(Formal
, E_Variable
);
2456 Set_Etype
(Formal
, Any_Type
);
2457 Restore_Hidden_Primitives
(Vis_Prims_List
);
2459 if Parent_Installed
then
2467 Set_Defining_Unit_Name
(Specification
(New_N
), Formal
);
2468 Set_Generic_Parent
(Specification
(N
), Gen_Unit
);
2469 Set_Instance_Env
(Gen_Unit
, Formal
);
2470 Set_Is_Generic_Instance
(Formal
);
2472 Enter_Name
(Formal
);
2473 Set_Ekind
(Formal
, E_Package
);
2474 Set_Etype
(Formal
, Standard_Void_Type
);
2475 Set_Inner_Instances
(Formal
, New_Elmt_List
);
2476 Push_Scope
(Formal
);
2478 if Is_Child_Unit
(Gen_Unit
)
2479 and then Parent_Installed
2481 -- Similarly, we have to make the name of the formal visible in the
2482 -- parent instance, to resolve properly fully qualified names that
2483 -- may appear in the generic unit. The parent instance has been
2484 -- placed on the scope stack ahead of the current scope.
2486 Parent_Instance
:= Scope_Stack
.Table
(Scope_Stack
.Last
- 1).Entity
;
2489 Make_Defining_Identifier
(Loc
, Chars
(Gen_Unit
));
2490 Set_Ekind
(Renaming_In_Par
, E_Package
);
2491 Set_Etype
(Renaming_In_Par
, Standard_Void_Type
);
2492 Set_Scope
(Renaming_In_Par
, Parent_Instance
);
2493 Set_Parent
(Renaming_In_Par
, Parent
(Formal
));
2494 Set_Renamed_Object
(Renaming_In_Par
, Formal
);
2495 Append_Entity
(Renaming_In_Par
, Parent_Instance
);
2498 Analyze
(Specification
(N
));
2500 -- The formals for which associations are provided are not visible
2501 -- outside of the formal package. The others are still declared by a
2502 -- formal parameter declaration.
2504 -- If there are no associations, the only local entity to hide is the
2505 -- generated package renaming itself.
2511 E
:= First_Entity
(Formal
);
2512 while Present
(E
) loop
2514 and then not Is_Generic_Formal
(E
)
2519 if Ekind
(E
) = E_Package
2520 and then Renamed_Entity
(E
) = Formal
2530 End_Package_Scope
(Formal
);
2531 Restore_Hidden_Primitives
(Vis_Prims_List
);
2533 if Parent_Installed
then
2539 -- Inside the generic unit, the formal package is a regular package, but
2540 -- no body is needed for it. Note that after instantiation, the defining
2541 -- unit name we need is in the new tree and not in the original (see
2542 -- Package_Instantiation). A generic formal package is an instance, and
2543 -- can be used as an actual for an inner instance.
2545 Set_Has_Completion
(Formal
, True);
2547 -- Add semantic information to the original defining identifier.
2550 Set_Ekind
(Pack_Id
, E_Package
);
2551 Set_Etype
(Pack_Id
, Standard_Void_Type
);
2552 Set_Scope
(Pack_Id
, Scope
(Formal
));
2553 Set_Has_Completion
(Pack_Id
, True);
2556 if Has_Aspects
(N
) then
2557 Analyze_Aspect_Specifications
(N
, Pack_Id
);
2559 end Analyze_Formal_Package_Declaration
;
2561 ---------------------------------
2562 -- Analyze_Formal_Private_Type --
2563 ---------------------------------
2565 procedure Analyze_Formal_Private_Type
2571 New_Private_Type
(N
, T
, Def
);
2573 -- Set the size to an arbitrary but legal value
2575 Set_Size_Info
(T
, Standard_Integer
);
2576 Set_RM_Size
(T
, RM_Size
(Standard_Integer
));
2577 end Analyze_Formal_Private_Type
;
2579 ------------------------------------
2580 -- Analyze_Formal_Incomplete_Type --
2581 ------------------------------------
2583 procedure Analyze_Formal_Incomplete_Type
2589 Set_Ekind
(T
, E_Incomplete_Type
);
2591 Set_Private_Dependents
(T
, New_Elmt_List
);
2593 if Tagged_Present
(Def
) then
2594 Set_Is_Tagged_Type
(T
);
2595 Make_Class_Wide_Type
(T
);
2596 Set_Direct_Primitive_Operations
(T
, New_Elmt_List
);
2598 end Analyze_Formal_Incomplete_Type
;
2600 ----------------------------------------
2601 -- Analyze_Formal_Signed_Integer_Type --
2602 ----------------------------------------
2604 procedure Analyze_Formal_Signed_Integer_Type
2608 Base
: constant Entity_Id
:=
2610 (E_Signed_Integer_Type
,
2612 Sloc
(Defining_Identifier
(Parent
(Def
))), 'G');
2617 Set_Ekind
(T
, E_Signed_Integer_Subtype
);
2618 Set_Etype
(T
, Base
);
2619 Set_Size_Info
(T
, Standard_Integer
);
2620 Set_RM_Size
(T
, RM_Size
(Standard_Integer
));
2621 Set_Scalar_Range
(T
, Scalar_Range
(Standard_Integer
));
2622 Set_Is_Constrained
(T
);
2624 Set_Is_Generic_Type
(Base
);
2625 Set_Size_Info
(Base
, Standard_Integer
);
2626 Set_RM_Size
(Base
, RM_Size
(Standard_Integer
));
2627 Set_Etype
(Base
, Base
);
2628 Set_Scalar_Range
(Base
, Scalar_Range
(Standard_Integer
));
2629 Set_Parent
(Base
, Parent
(Def
));
2630 end Analyze_Formal_Signed_Integer_Type
;
2632 -------------------------------------------
2633 -- Analyze_Formal_Subprogram_Declaration --
2634 -------------------------------------------
2636 procedure Analyze_Formal_Subprogram_Declaration
(N
: Node_Id
) is
2637 Spec
: constant Node_Id
:= Specification
(N
);
2638 Def
: constant Node_Id
:= Default_Name
(N
);
2639 Nam
: constant Entity_Id
:= Defining_Unit_Name
(Spec
);
2647 if Nkind
(Nam
) = N_Defining_Program_Unit_Name
then
2648 Error_Msg_N
("name of formal subprogram must be a direct name", Nam
);
2652 Analyze_Subprogram_Declaration
(N
);
2653 Set_Is_Formal_Subprogram
(Nam
);
2654 Set_Has_Completion
(Nam
);
2656 if Nkind
(N
) = N_Formal_Abstract_Subprogram_Declaration
then
2657 Set_Is_Abstract_Subprogram
(Nam
);
2658 Set_Is_Dispatching_Operation
(Nam
);
2661 Ctrl_Type
: constant Entity_Id
:= Find_Dispatching_Type
(Nam
);
2663 if No
(Ctrl_Type
) then
2665 ("abstract formal subprogram must have a controlling type",
2668 elsif Ada_Version
>= Ada_2012
2669 and then Is_Incomplete_Type
(Ctrl_Type
)
2672 ("controlling type of abstract formal subprogram cannot " &
2673 "be incomplete type", N
, Ctrl_Type
);
2676 Check_Controlling_Formals
(Ctrl_Type
, Nam
);
2681 -- Default name is resolved at the point of instantiation
2683 if Box_Present
(N
) then
2686 -- Else default is bound at the point of generic declaration
2688 elsif Present
(Def
) then
2689 if Nkind
(Def
) = N_Operator_Symbol
then
2690 Find_Direct_Name
(Def
);
2692 elsif Nkind
(Def
) /= N_Attribute_Reference
then
2696 -- For an attribute reference, analyze the prefix and verify
2697 -- that it has the proper profile for the subprogram.
2699 Analyze
(Prefix
(Def
));
2700 Valid_Default_Attribute
(Nam
, Def
);
2704 -- Default name may be overloaded, in which case the interpretation
2705 -- with the correct profile must be selected, as for a renaming.
2706 -- If the definition is an indexed component, it must denote a
2707 -- member of an entry family. If it is a selected component, it
2708 -- can be a protected operation.
2710 if Etype
(Def
) = Any_Type
then
2713 elsif Nkind
(Def
) = N_Selected_Component
then
2714 if not Is_Overloadable
(Entity
(Selector_Name
(Def
))) then
2715 Error_Msg_N
("expect valid subprogram name as default", Def
);
2718 elsif Nkind
(Def
) = N_Indexed_Component
then
2719 if Is_Entity_Name
(Prefix
(Def
)) then
2720 if Ekind
(Entity
(Prefix
(Def
))) /= E_Entry_Family
then
2721 Error_Msg_N
("expect valid subprogram name as default", Def
);
2724 elsif Nkind
(Prefix
(Def
)) = N_Selected_Component
then
2725 if Ekind
(Entity
(Selector_Name
(Prefix
(Def
)))) /=
2728 Error_Msg_N
("expect valid subprogram name as default", Def
);
2732 Error_Msg_N
("expect valid subprogram name as default", Def
);
2736 elsif Nkind
(Def
) = N_Character_Literal
then
2738 -- Needs some type checks: subprogram should be parameterless???
2740 Resolve
(Def
, (Etype
(Nam
)));
2742 elsif not Is_Entity_Name
(Def
)
2743 or else not Is_Overloadable
(Entity
(Def
))
2745 Error_Msg_N
("expect valid subprogram name as default", Def
);
2748 elsif not Is_Overloaded
(Def
) then
2749 Subp
:= Entity
(Def
);
2752 Error_Msg_N
("premature usage of formal subprogram", Def
);
2754 elsif not Entity_Matches_Spec
(Subp
, Nam
) then
2755 Error_Msg_N
("no visible entity matches specification", Def
);
2758 -- More than one interpretation, so disambiguate as for a renaming
2763 I1
: Interp_Index
:= 0;
2769 Get_First_Interp
(Def
, I
, It
);
2770 while Present
(It
.Nam
) loop
2771 if Entity_Matches_Spec
(It
.Nam
, Nam
) then
2772 if Subp
/= Any_Id
then
2773 It1
:= Disambiguate
(Def
, I1
, I
, Etype
(Subp
));
2775 if It1
= No_Interp
then
2776 Error_Msg_N
("ambiguous default subprogram", Def
);
2789 Get_Next_Interp
(I
, It
);
2793 if Subp
/= Any_Id
then
2795 -- Subprogram found, generate reference to it
2797 Set_Entity
(Def
, Subp
);
2798 Generate_Reference
(Subp
, Def
);
2801 Error_Msg_N
("premature usage of formal subprogram", Def
);
2803 elsif Ekind
(Subp
) /= E_Operator
then
2804 Check_Mode_Conformant
(Subp
, Nam
);
2808 Error_Msg_N
("no visible subprogram matches specification", N
);
2814 if Has_Aspects
(N
) then
2815 Analyze_Aspect_Specifications
(N
, Nam
);
2818 end Analyze_Formal_Subprogram_Declaration
;
2820 -------------------------------------
2821 -- Analyze_Formal_Type_Declaration --
2822 -------------------------------------
2824 procedure Analyze_Formal_Type_Declaration
(N
: Node_Id
) is
2825 Def
: constant Node_Id
:= Formal_Type_Definition
(N
);
2829 T
:= Defining_Identifier
(N
);
2831 if Present
(Discriminant_Specifications
(N
))
2832 and then Nkind
(Def
) /= N_Formal_Private_Type_Definition
2835 ("discriminants not allowed for this formal type", T
);
2838 -- Enter the new name, and branch to specific routine
2841 when N_Formal_Private_Type_Definition
=>
2842 Analyze_Formal_Private_Type
(N
, T
, Def
);
2844 when N_Formal_Derived_Type_Definition
=>
2845 Analyze_Formal_Derived_Type
(N
, T
, Def
);
2847 when N_Formal_Incomplete_Type_Definition
=>
2848 Analyze_Formal_Incomplete_Type
(T
, Def
);
2850 when N_Formal_Discrete_Type_Definition
=>
2851 Analyze_Formal_Discrete_Type
(T
, Def
);
2853 when N_Formal_Signed_Integer_Type_Definition
=>
2854 Analyze_Formal_Signed_Integer_Type
(T
, Def
);
2856 when N_Formal_Modular_Type_Definition
=>
2857 Analyze_Formal_Modular_Type
(T
, Def
);
2859 when N_Formal_Floating_Point_Definition
=>
2860 Analyze_Formal_Floating_Type
(T
, Def
);
2862 when N_Formal_Ordinary_Fixed_Point_Definition
=>
2863 Analyze_Formal_Ordinary_Fixed_Point_Type
(T
, Def
);
2865 when N_Formal_Decimal_Fixed_Point_Definition
=>
2866 Analyze_Formal_Decimal_Fixed_Point_Type
(T
, Def
);
2868 when N_Array_Type_Definition
=>
2869 Analyze_Formal_Array_Type
(T
, Def
);
2871 when N_Access_To_Object_Definition |
2872 N_Access_Function_Definition |
2873 N_Access_Procedure_Definition
=>
2874 Analyze_Generic_Access_Type
(T
, Def
);
2876 -- Ada 2005: a interface declaration is encoded as an abstract
2877 -- record declaration or a abstract type derivation.
2879 when N_Record_Definition
=>
2880 Analyze_Formal_Interface_Type
(N
, T
, Def
);
2882 when N_Derived_Type_Definition
=>
2883 Analyze_Formal_Derived_Interface_Type
(N
, T
, Def
);
2889 raise Program_Error
;
2893 Set_Is_Generic_Type
(T
);
2895 if Has_Aspects
(N
) then
2896 Analyze_Aspect_Specifications
(N
, T
);
2898 end Analyze_Formal_Type_Declaration
;
2900 ------------------------------------
2901 -- Analyze_Function_Instantiation --
2902 ------------------------------------
2904 procedure Analyze_Function_Instantiation
(N
: Node_Id
) is
2906 Analyze_Subprogram_Instantiation
(N
, E_Function
);
2907 end Analyze_Function_Instantiation
;
2909 ---------------------------------
2910 -- Analyze_Generic_Access_Type --
2911 ---------------------------------
2913 procedure Analyze_Generic_Access_Type
(T
: Entity_Id
; Def
: Node_Id
) is
2917 if Nkind
(Def
) = N_Access_To_Object_Definition
then
2918 Access_Type_Declaration
(T
, Def
);
2920 if Is_Incomplete_Or_Private_Type
(Designated_Type
(T
))
2921 and then No
(Full_View
(Designated_Type
(T
)))
2922 and then not Is_Generic_Type
(Designated_Type
(T
))
2924 Error_Msg_N
("premature usage of incomplete type", Def
);
2926 elsif not Is_Entity_Name
(Subtype_Indication
(Def
)) then
2928 ("only a subtype mark is allowed in a formal", Def
);
2932 Access_Subprogram_Declaration
(T
, Def
);
2934 end Analyze_Generic_Access_Type
;
2936 ---------------------------------
2937 -- Analyze_Generic_Formal_Part --
2938 ---------------------------------
2940 procedure Analyze_Generic_Formal_Part
(N
: Node_Id
) is
2941 Gen_Parm_Decl
: Node_Id
;
2944 -- The generic formals are processed in the scope of the generic unit,
2945 -- where they are immediately visible. The scope is installed by the
2948 Gen_Parm_Decl
:= First
(Generic_Formal_Declarations
(N
));
2950 while Present
(Gen_Parm_Decl
) loop
2951 Analyze
(Gen_Parm_Decl
);
2952 Next
(Gen_Parm_Decl
);
2955 Generate_Reference_To_Generic_Formals
(Current_Scope
);
2956 end Analyze_Generic_Formal_Part
;
2958 ------------------------------------------
2959 -- Analyze_Generic_Package_Declaration --
2960 ------------------------------------------
2962 procedure Analyze_Generic_Package_Declaration
(N
: Node_Id
) is
2963 Loc
: constant Source_Ptr
:= Sloc
(N
);
2966 Save_Parent
: Node_Id
;
2968 Decls
: constant List_Id
:=
2969 Visible_Declarations
(Specification
(N
));
2973 Check_SPARK_Restriction
("generic is not allowed", N
);
2975 -- We introduce a renaming of the enclosing package, to have a usable
2976 -- entity as the prefix of an expanded name for a local entity of the
2977 -- form Par.P.Q, where P is the generic package. This is because a local
2978 -- entity named P may hide it, so that the usual visibility rules in
2979 -- the instance will not resolve properly.
2982 Make_Package_Renaming_Declaration
(Loc
,
2983 Defining_Unit_Name
=>
2984 Make_Defining_Identifier
(Loc
,
2985 Chars
=> New_External_Name
(Chars
(Defining_Entity
(N
)), "GH")),
2986 Name
=> Make_Identifier
(Loc
, Chars
(Defining_Entity
(N
))));
2988 if Present
(Decls
) then
2989 Decl
:= First
(Decls
);
2990 while Present
(Decl
)
2991 and then Nkind
(Decl
) = N_Pragma
2996 if Present
(Decl
) then
2997 Insert_Before
(Decl
, Renaming
);
2999 Append
(Renaming
, Visible_Declarations
(Specification
(N
)));
3003 Set_Visible_Declarations
(Specification
(N
), New_List
(Renaming
));
3006 -- Create copy of generic unit, and save for instantiation. If the unit
3007 -- is a child unit, do not copy the specifications for the parent, which
3008 -- are not part of the generic tree.
3010 Save_Parent
:= Parent_Spec
(N
);
3011 Set_Parent_Spec
(N
, Empty
);
3013 New_N
:= Copy_Generic_Node
(N
, Empty
, Instantiating
=> False);
3014 Set_Parent_Spec
(New_N
, Save_Parent
);
3016 Id
:= Defining_Entity
(N
);
3017 Generate_Definition
(Id
);
3019 -- Expansion is not applied to generic units
3024 Set_Ekind
(Id
, E_Generic_Package
);
3025 Set_Etype
(Id
, Standard_Void_Type
);
3027 Enter_Generic_Scope
(Id
);
3028 Set_Inner_Instances
(Id
, New_Elmt_List
);
3030 Set_Categorization_From_Pragmas
(N
);
3031 Set_Is_Pure
(Id
, Is_Pure
(Current_Scope
));
3033 -- Link the declaration of the generic homonym in the generic copy to
3034 -- the package it renames, so that it is always resolved properly.
3036 Set_Generic_Homonym
(Id
, Defining_Unit_Name
(Renaming
));
3037 Set_Entity
(Associated_Node
(Name
(Renaming
)), Id
);
3039 -- For a library unit, we have reconstructed the entity for the unit,
3040 -- and must reset it in the library tables.
3042 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
3043 Set_Cunit_Entity
(Current_Sem_Unit
, Id
);
3046 Analyze_Generic_Formal_Part
(N
);
3048 -- After processing the generic formals, analysis proceeds as for a
3049 -- non-generic package.
3051 Analyze
(Specification
(N
));
3053 Validate_Categorization_Dependency
(N
, Id
);
3057 End_Package_Scope
(Id
);
3058 Exit_Generic_Scope
(Id
);
3060 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
3061 Move_Freeze_Nodes
(Id
, N
, Visible_Declarations
(Specification
(N
)));
3062 Move_Freeze_Nodes
(Id
, N
, Private_Declarations
(Specification
(N
)));
3063 Move_Freeze_Nodes
(Id
, N
, Generic_Formal_Declarations
(N
));
3066 Set_Body_Required
(Parent
(N
), Unit_Requires_Body
(Id
));
3067 Validate_RT_RAT_Component
(N
);
3069 -- If this is a spec without a body, check that generic parameters
3072 if not Body_Required
(Parent
(N
)) then
3073 Check_References
(Id
);
3077 if Has_Aspects
(N
) then
3078 Analyze_Aspect_Specifications
(N
, Id
);
3080 end Analyze_Generic_Package_Declaration
;
3082 --------------------------------------------
3083 -- Analyze_Generic_Subprogram_Declaration --
3084 --------------------------------------------
3086 procedure Analyze_Generic_Subprogram_Declaration
(N
: Node_Id
) is
3091 Result_Type
: Entity_Id
;
3092 Save_Parent
: Node_Id
;
3096 Check_SPARK_Restriction
("generic is not allowed", N
);
3098 -- Create copy of generic unit, and save for instantiation. If the unit
3099 -- is a child unit, do not copy the specifications for the parent, which
3100 -- are not part of the generic tree.
3102 Save_Parent
:= Parent_Spec
(N
);
3103 Set_Parent_Spec
(N
, Empty
);
3105 New_N
:= Copy_Generic_Node
(N
, Empty
, Instantiating
=> False);
3106 Set_Parent_Spec
(New_N
, Save_Parent
);
3109 -- The aspect specifications are not attached to the tree, and must
3110 -- be copied and attached to the generic copy explicitly.
3112 if Present
(Aspect_Specifications
(New_N
)) then
3114 Aspects
: constant List_Id
:= Aspect_Specifications
(N
);
3116 Set_Has_Aspects
(N
, False);
3117 Move_Aspects
(New_N
, N
);
3118 Set_Has_Aspects
(Original_Node
(N
), False);
3119 Set_Aspect_Specifications
(Original_Node
(N
), Aspects
);
3123 Spec
:= Specification
(N
);
3124 Id
:= Defining_Entity
(Spec
);
3125 Generate_Definition
(Id
);
3126 Set_Contract
(Id
, Make_Contract
(Sloc
(Id
)));
3128 if Nkind
(Id
) = N_Defining_Operator_Symbol
then
3130 ("operator symbol not allowed for generic subprogram", Id
);
3137 Set_Scope_Depth_Value
(Id
, Scope_Depth
(Current_Scope
) + 1);
3139 Enter_Generic_Scope
(Id
);
3140 Set_Inner_Instances
(Id
, New_Elmt_List
);
3141 Set_Is_Pure
(Id
, Is_Pure
(Current_Scope
));
3143 Analyze_Generic_Formal_Part
(N
);
3145 Formals
:= Parameter_Specifications
(Spec
);
3147 if Present
(Formals
) then
3148 Process_Formals
(Formals
, Spec
);
3151 if Nkind
(Spec
) = N_Function_Specification
then
3152 Set_Ekind
(Id
, E_Generic_Function
);
3154 if Nkind
(Result_Definition
(Spec
)) = N_Access_Definition
then
3155 Result_Type
:= Access_Definition
(Spec
, Result_Definition
(Spec
));
3156 Set_Etype
(Id
, Result_Type
);
3158 -- Check restriction imposed by AI05-073: a generic function
3159 -- cannot return an abstract type or an access to such.
3161 -- This is a binding interpretation should it apply to earlier
3162 -- versions of Ada as well as Ada 2012???
3164 if Is_Abstract_Type
(Designated_Type
(Result_Type
))
3165 and then Ada_Version
>= Ada_2012
3167 Error_Msg_N
("generic function cannot have an access result"
3168 & " that designates an abstract type", Spec
);
3172 Find_Type
(Result_Definition
(Spec
));
3173 Typ
:= Entity
(Result_Definition
(Spec
));
3175 if Is_Abstract_Type
(Typ
)
3176 and then Ada_Version
>= Ada_2012
3179 ("generic function cannot have abstract result type", Spec
);
3182 -- If a null exclusion is imposed on the result type, then create
3183 -- a null-excluding itype (an access subtype) and use it as the
3184 -- function's Etype.
3186 if Is_Access_Type
(Typ
)
3187 and then Null_Exclusion_Present
(Spec
)
3190 Create_Null_Excluding_Itype
3192 Related_Nod
=> Spec
,
3193 Scope_Id
=> Defining_Unit_Name
(Spec
)));
3195 Set_Etype
(Id
, Typ
);
3200 Set_Ekind
(Id
, E_Generic_Procedure
);
3201 Set_Etype
(Id
, Standard_Void_Type
);
3204 -- For a library unit, we have reconstructed the entity for the unit,
3205 -- and must reset it in the library tables. We also make sure that
3206 -- Body_Required is set properly in the original compilation unit node.
3208 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
3209 Set_Cunit_Entity
(Current_Sem_Unit
, Id
);
3210 Set_Body_Required
(Parent
(N
), Unit_Requires_Body
(Id
));
3213 Set_Categorization_From_Pragmas
(N
);
3214 Validate_Categorization_Dependency
(N
, Id
);
3216 Save_Global_References
(Original_Node
(N
));
3218 -- For ASIS purposes, convert any postcondition, precondition pragmas
3219 -- into aspects, if N is not a compilation unit by itself, in order to
3220 -- enable the analysis of expressions inside the corresponding PPC
3223 if ASIS_Mode
and then Is_List_Member
(N
) then
3224 Make_Aspect_For_PPC_In_Gen_Sub_Decl
(N
);
3227 -- To capture global references, analyze the expressions of aspects,
3228 -- and propagate information to original tree. Note that in this case
3229 -- analysis of attributes is not delayed until the freeze point.
3231 -- It seems very hard to recreate the proper visibility of the generic
3232 -- subprogram at a later point because the analysis of an aspect may
3233 -- create pragmas after the generic copies have been made ???
3235 if Has_Aspects
(N
) then
3240 Aspect
:= First
(Aspect_Specifications
(N
));
3241 while Present
(Aspect
) loop
3242 if Get_Aspect_Id
(Chars
(Identifier
(Aspect
)))
3245 Analyze
(Expression
(Aspect
));
3250 Aspect
:= First
(Aspect_Specifications
(Original_Node
(N
)));
3251 while Present
(Aspect
) loop
3252 Save_Global_References
(Expression
(Aspect
));
3260 Exit_Generic_Scope
(Id
);
3261 Generate_Reference_To_Formals
(Id
);
3263 List_Inherited_Pre_Post_Aspects
(Id
);
3264 end Analyze_Generic_Subprogram_Declaration
;
3266 -----------------------------------
3267 -- Analyze_Package_Instantiation --
3268 -----------------------------------
3270 procedure Analyze_Package_Instantiation
(N
: Node_Id
) is
3271 Loc
: constant Source_Ptr
:= Sloc
(N
);
3272 Gen_Id
: constant Node_Id
:= Name
(N
);
3275 Act_Decl_Name
: Node_Id
;
3276 Act_Decl_Id
: Entity_Id
;
3281 Gen_Unit
: Entity_Id
;
3283 Is_Actual_Pack
: constant Boolean :=
3284 Is_Internal
(Defining_Entity
(N
));
3286 Env_Installed
: Boolean := False;
3287 Parent_Installed
: Boolean := False;
3288 Renaming_List
: List_Id
;
3289 Unit_Renaming
: Node_Id
;
3290 Needs_Body
: Boolean;
3291 Inline_Now
: Boolean := False;
3293 Save_Style_Check
: constant Boolean := Style_Check
;
3294 -- Save style check mode for restore on exit
3296 procedure Delay_Descriptors
(E
: Entity_Id
);
3297 -- Delay generation of subprogram descriptors for given entity
3299 function Might_Inline_Subp
return Boolean;
3300 -- If inlining is active and the generic contains inlined subprograms,
3301 -- we instantiate the body. This may cause superfluous instantiations,
3302 -- but it is simpler than detecting the need for the body at the point
3303 -- of inlining, when the context of the instance is not available.
3305 function Must_Inline_Subp
return Boolean;
3306 -- If inlining is active and the generic contains inlined subprograms,
3307 -- return True if some of the inlined subprograms must be inlined by
3310 -----------------------
3311 -- Delay_Descriptors --
3312 -----------------------
3314 procedure Delay_Descriptors
(E
: Entity_Id
) is
3316 if not Delay_Subprogram_Descriptors
(E
) then
3317 Set_Delay_Subprogram_Descriptors
(E
);
3318 Pending_Descriptor
.Append
(E
);
3320 end Delay_Descriptors
;
3322 -----------------------
3323 -- Might_Inline_Subp --
3324 -----------------------
3326 function Might_Inline_Subp
return Boolean is
3330 if not Inline_Processing_Required
then
3334 E
:= First_Entity
(Gen_Unit
);
3335 while Present
(E
) loop
3336 if Is_Subprogram
(E
)
3337 and then Is_Inlined
(E
)
3347 end Might_Inline_Subp
;
3349 ----------------------
3350 -- Must_Inline_Subp --
3351 ----------------------
3353 function Must_Inline_Subp
return Boolean is
3357 if not Inline_Processing_Required
then
3361 E
:= First_Entity
(Gen_Unit
);
3362 while Present
(E
) loop
3363 if Is_Subprogram
(E
)
3364 and then Is_Inlined
(E
)
3365 and then Must_Inline
(E
)
3375 end Must_Inline_Subp
;
3377 -- Local declarations
3379 Vis_Prims_List
: Elist_Id
:= No_Elist
;
3380 -- List of primitives made temporarily visible in the instantiation
3381 -- to match the visibility of the formal type
3383 -- Start of processing for Analyze_Package_Instantiation
3386 Check_SPARK_Restriction
("generic is not allowed", N
);
3388 -- Very first thing: apply the special kludge for Text_IO processing
3389 -- in case we are instantiating one of the children of [Wide_]Text_IO.
3391 Text_IO_Kludge
(Name
(N
));
3393 -- Make node global for error reporting
3395 Instantiation_Node
:= N
;
3397 -- Turn off style checking in instances. If the check is enabled on the
3398 -- generic unit, a warning in an instance would just be noise. If not
3399 -- enabled on the generic, then a warning in an instance is just wrong.
3401 Style_Check
:= False;
3403 -- Case of instantiation of a generic package
3405 if Nkind
(N
) = N_Package_Instantiation
then
3406 Act_Decl_Id
:= New_Copy
(Defining_Entity
(N
));
3407 Set_Comes_From_Source
(Act_Decl_Id
, True);
3409 if Nkind
(Defining_Unit_Name
(N
)) = N_Defining_Program_Unit_Name
then
3411 Make_Defining_Program_Unit_Name
(Loc
,
3412 Name
=> New_Copy_Tree
(Name
(Defining_Unit_Name
(N
))),
3413 Defining_Identifier
=> Act_Decl_Id
);
3415 Act_Decl_Name
:= Act_Decl_Id
;
3418 -- Case of instantiation of a formal package
3421 Act_Decl_Id
:= Defining_Identifier
(N
);
3422 Act_Decl_Name
:= Act_Decl_Id
;
3425 Generate_Definition
(Act_Decl_Id
);
3426 Preanalyze_Actuals
(N
);
3429 Env_Installed
:= True;
3431 -- Reset renaming map for formal types. The mapping is established
3432 -- when analyzing the generic associations, but some mappings are
3433 -- inherited from formal packages of parent units, and these are
3434 -- constructed when the parents are installed.
3436 Generic_Renamings
.Set_Last
(0);
3437 Generic_Renamings_HTable
.Reset
;
3439 Check_Generic_Child_Unit
(Gen_Id
, Parent_Installed
);
3440 Gen_Unit
:= Entity
(Gen_Id
);
3442 -- Verify that it is the name of a generic package
3444 -- A visibility glitch: if the instance is a child unit and the generic
3445 -- is the generic unit of a parent instance (i.e. both the parent and
3446 -- the child units are instances of the same package) the name now
3447 -- denotes the renaming within the parent, not the intended generic
3448 -- unit. See if there is a homonym that is the desired generic. The
3449 -- renaming declaration must be visible inside the instance of the
3450 -- child, but not when analyzing the name in the instantiation itself.
3452 if Ekind
(Gen_Unit
) = E_Package
3453 and then Present
(Renamed_Entity
(Gen_Unit
))
3454 and then In_Open_Scopes
(Renamed_Entity
(Gen_Unit
))
3455 and then Is_Generic_Instance
(Renamed_Entity
(Gen_Unit
))
3456 and then Present
(Homonym
(Gen_Unit
))
3458 Gen_Unit
:= Homonym
(Gen_Unit
);
3461 if Etype
(Gen_Unit
) = Any_Type
then
3465 elsif Ekind
(Gen_Unit
) /= E_Generic_Package
then
3467 -- Ada 2005 (AI-50217): Cannot use instance in limited with_clause
3469 if From_With_Type
(Gen_Unit
) then
3471 ("cannot instantiate a limited withed package", Gen_Id
);
3474 ("expect name of generic package in instantiation", Gen_Id
);
3481 if In_Extended_Main_Source_Unit
(N
) then
3482 Set_Is_Instantiated
(Gen_Unit
);
3483 Generate_Reference
(Gen_Unit
, N
);
3485 if Present
(Renamed_Object
(Gen_Unit
)) then
3486 Set_Is_Instantiated
(Renamed_Object
(Gen_Unit
));
3487 Generate_Reference
(Renamed_Object
(Gen_Unit
), N
);
3491 if Nkind
(Gen_Id
) = N_Identifier
3492 and then Chars
(Gen_Unit
) = Chars
(Defining_Entity
(N
))
3495 ("& is hidden within declaration of instance", Gen_Id
, Gen_Unit
);
3497 elsif Nkind
(Gen_Id
) = N_Expanded_Name
3498 and then Is_Child_Unit
(Gen_Unit
)
3499 and then Nkind
(Prefix
(Gen_Id
)) = N_Identifier
3500 and then Chars
(Act_Decl_Id
) = Chars
(Prefix
(Gen_Id
))
3503 ("& is hidden within declaration of instance ", Prefix
(Gen_Id
));
3506 Set_Entity
(Gen_Id
, Gen_Unit
);
3508 -- If generic is a renaming, get original generic unit
3510 if Present
(Renamed_Object
(Gen_Unit
))
3511 and then Ekind
(Renamed_Object
(Gen_Unit
)) = E_Generic_Package
3513 Gen_Unit
:= Renamed_Object
(Gen_Unit
);
3516 -- Verify that there are no circular instantiations
3518 if In_Open_Scopes
(Gen_Unit
) then
3519 Error_Msg_NE
("instantiation of & within itself", N
, Gen_Unit
);
3523 elsif Contains_Instance_Of
(Gen_Unit
, Current_Scope
, Gen_Id
) then
3524 Error_Msg_Node_2
:= Current_Scope
;
3526 ("circular Instantiation: & instantiated in &!", N
, Gen_Unit
);
3527 Circularity_Detected
:= True;
3532 Gen_Decl
:= Unit_Declaration_Node
(Gen_Unit
);
3534 -- Initialize renamings map, for error checking, and the list that
3535 -- holds private entities whose views have changed between generic
3536 -- definition and instantiation. If this is the instance created to
3537 -- validate an actual package, the instantiation environment is that
3538 -- of the enclosing instance.
3540 Create_Instantiation_Source
(N
, Gen_Unit
, False, S_Adjustment
);
3542 -- Copy original generic tree, to produce text for instantiation
3546 (Original_Node
(Gen_Decl
), Empty
, Instantiating
=> True);
3548 Act_Spec
:= Specification
(Act_Tree
);
3550 -- If this is the instance created to validate an actual package,
3551 -- only the formals matter, do not examine the package spec itself.
3553 if Is_Actual_Pack
then
3554 Set_Visible_Declarations
(Act_Spec
, New_List
);
3555 Set_Private_Declarations
(Act_Spec
, New_List
);
3559 Analyze_Associations
3561 Formals
=> Generic_Formal_Declarations
(Act_Tree
),
3562 F_Copy
=> Generic_Formal_Declarations
(Gen_Decl
));
3564 Vis_Prims_List
:= Check_Hidden_Primitives
(Renaming_List
);
3566 Set_Instance_Env
(Gen_Unit
, Act_Decl_Id
);
3567 Set_Defining_Unit_Name
(Act_Spec
, Act_Decl_Name
);
3568 Set_Is_Generic_Instance
(Act_Decl_Id
);
3570 Set_Generic_Parent
(Act_Spec
, Gen_Unit
);
3572 -- References to the generic in its own declaration or its body are
3573 -- references to the instance. Add a renaming declaration for the
3574 -- generic unit itself. This declaration, as well as the renaming
3575 -- declarations for the generic formals, must remain private to the
3576 -- unit: the formals, because this is the language semantics, and
3577 -- the unit because its use is an artifact of the implementation.
3580 Make_Package_Renaming_Declaration
(Loc
,
3581 Defining_Unit_Name
=>
3582 Make_Defining_Identifier
(Loc
, Chars
(Gen_Unit
)),
3583 Name
=> New_Reference_To
(Act_Decl_Id
, Loc
));
3585 Append
(Unit_Renaming
, Renaming_List
);
3587 -- The renaming declarations are the first local declarations of
3590 if Is_Non_Empty_List
(Visible_Declarations
(Act_Spec
)) then
3592 (First
(Visible_Declarations
(Act_Spec
)), Renaming_List
);
3594 Set_Visible_Declarations
(Act_Spec
, Renaming_List
);
3598 Make_Package_Declaration
(Loc
,
3599 Specification
=> Act_Spec
);
3601 -- Save the instantiation node, for subsequent instantiation of the
3602 -- body, if there is one and we are generating code for the current
3603 -- unit. Mark the unit as having a body, to avoid a premature error
3606 -- We instantiate the body if we are generating code, if we are
3607 -- generating cross-reference information, or if we are building
3608 -- trees for ASIS use.
3611 Enclosing_Body_Present
: Boolean := False;
3612 -- If the generic unit is not a compilation unit, then a body may
3613 -- be present in its parent even if none is required. We create a
3614 -- tentative pending instantiation for the body, which will be
3615 -- discarded if none is actually present.
3620 if Scope
(Gen_Unit
) /= Standard_Standard
3621 and then not Is_Child_Unit
(Gen_Unit
)
3623 Scop
:= Scope
(Gen_Unit
);
3625 while Present
(Scop
)
3626 and then Scop
/= Standard_Standard
3628 if Unit_Requires_Body
(Scop
) then
3629 Enclosing_Body_Present
:= True;
3632 elsif In_Open_Scopes
(Scop
)
3633 and then In_Package_Body
(Scop
)
3635 Enclosing_Body_Present
:= True;
3639 exit when Is_Compilation_Unit
(Scop
);
3640 Scop
:= Scope
(Scop
);
3644 -- If front-end inlining is enabled, and this is a unit for which
3645 -- code will be generated, we instantiate the body at once.
3647 -- This is done if the instance is not the main unit, and if the
3648 -- generic is not a child unit of another generic, to avoid scope
3649 -- problems and the reinstallation of parent instances.
3652 and then (not Is_Child_Unit
(Gen_Unit
)
3653 or else not Is_Generic_Unit
(Scope
(Gen_Unit
)))
3654 and then Might_Inline_Subp
3655 and then not Is_Actual_Pack
3657 if not Debug_Flag_Dot_K
3658 and then Front_End_Inlining
3659 and then (Is_In_Main_Unit
(N
)
3660 or else In_Main_Context
(Current_Scope
))
3661 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit
3665 elsif Debug_Flag_Dot_K
3666 and then Must_Inline_Subp
3667 and then (Is_In_Main_Unit
(N
)
3668 or else In_Main_Context
(Current_Scope
))
3669 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit
3673 -- In configurable_run_time mode we force the inlining of
3674 -- predefined subprograms marked Inline_Always, to minimize
3675 -- the use of the run-time library.
3677 elsif Is_Predefined_File_Name
3678 (Unit_File_Name
(Get_Source_Unit
(Gen_Decl
)))
3679 and then Configurable_Run_Time_Mode
3680 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit
3685 -- If the current scope is itself an instance within a child
3686 -- unit, there will be duplications in the scope stack, and the
3687 -- unstacking mechanism in Inline_Instance_Body will fail.
3688 -- This loses some rare cases of optimization, and might be
3689 -- improved some day, if we can find a proper abstraction for
3690 -- "the complete compilation context" that can be saved and
3693 if Is_Generic_Instance
(Current_Scope
) then
3695 Curr_Unit
: constant Entity_Id
:=
3696 Cunit_Entity
(Current_Sem_Unit
);
3698 if Curr_Unit
/= Current_Scope
3699 and then Is_Child_Unit
(Curr_Unit
)
3701 Inline_Now
:= False;
3708 (Unit_Requires_Body
(Gen_Unit
)
3709 or else Enclosing_Body_Present
3710 or else Present
(Corresponding_Body
(Gen_Decl
)))
3711 and then (Is_In_Main_Unit
(N
)
3712 or else Might_Inline_Subp
)
3713 and then not Is_Actual_Pack
3714 and then not Inline_Now
3715 and then (Operating_Mode
= Generate_Code
3716 or else (Operating_Mode
= Check_Semantics
3717 and then ASIS_Mode
));
3719 -- If front_end_inlining is enabled, do not instantiate body if
3720 -- within a generic context.
3722 if (Front_End_Inlining
3723 and then not Expander_Active
)
3724 or else Is_Generic_Unit
(Cunit_Entity
(Main_Unit
))
3726 Needs_Body
:= False;
3729 -- If the current context is generic, and the package being
3730 -- instantiated is declared within a formal package, there is no
3731 -- body to instantiate until the enclosing generic is instantiated
3732 -- and there is an actual for the formal package. If the formal
3733 -- package has parameters, we build a regular package instance for
3734 -- it, that precedes the original formal package declaration.
3736 if In_Open_Scopes
(Scope
(Scope
(Gen_Unit
))) then
3738 Decl
: constant Node_Id
:=
3740 (Unit_Declaration_Node
(Scope
(Gen_Unit
)));
3742 if Nkind
(Decl
) = N_Formal_Package_Declaration
3743 or else (Nkind
(Decl
) = N_Package_Declaration
3744 and then Is_List_Member
(Decl
)
3745 and then Present
(Next
(Decl
))
3747 Nkind
(Next
(Decl
)) =
3748 N_Formal_Package_Declaration
)
3750 Needs_Body
:= False;
3756 -- For RCI unit calling stubs, we omit the instance body if the
3757 -- instance is the RCI library unit itself.
3759 -- However there is a special case for nested instances: in this case
3760 -- we do generate the instance body, as it might be required, e.g.
3761 -- because it provides stream attributes for some type used in the
3762 -- profile of a remote subprogram. This is consistent with 12.3(12),
3763 -- which indicates that the instance body occurs at the place of the
3764 -- instantiation, and thus is part of the RCI declaration, which is
3765 -- present on all client partitions (this is E.2.3(18)).
3767 -- Note that AI12-0002 may make it illegal at some point to have
3768 -- stream attributes defined in an RCI unit, in which case this
3769 -- special case will become unnecessary. In the meantime, there
3770 -- is known application code in production that depends on this
3771 -- being possible, so we definitely cannot eliminate the body in
3772 -- the case of nested instances for the time being.
3774 -- When we generate a nested instance body, calling stubs for any
3775 -- relevant subprogram will be be inserted immediately after the
3776 -- subprogram declarations, and will take precedence over the
3777 -- subsequent (original) body. (The stub and original body will be
3778 -- complete homographs, but this is permitted in an instance).
3779 -- (Could we do better and remove the original body???)
3781 if Distribution_Stub_Mode
= Generate_Caller_Stub_Body
3782 and then Comes_From_Source
(N
)
3783 and then Nkind
(Parent
(N
)) = N_Compilation_Unit
3785 Needs_Body
:= False;
3790 -- Here is a defence against a ludicrous number of instantiations
3791 -- caused by a circular set of instantiation attempts.
3793 if Pending_Instantiations
.Last
> Maximum_Instantiations
then
3794 Error_Msg_Uint_1
:= UI_From_Int
(Maximum_Instantiations
);
3795 Error_Msg_N
("too many instantiations, exceeds max of^", N
);
3796 Error_Msg_N
("\limit can be changed using -gnateinn switch", N
);
3797 raise Unrecoverable_Error
;
3800 -- Indicate that the enclosing scopes contain an instantiation,
3801 -- and that cleanup actions should be delayed until after the
3802 -- instance body is expanded.
3804 Check_Forward_Instantiation
(Gen_Decl
);
3805 if Nkind
(N
) = N_Package_Instantiation
then
3807 Enclosing_Master
: Entity_Id
;
3810 -- Loop to search enclosing masters
3812 Enclosing_Master
:= Current_Scope
;
3813 Scope_Loop
: while Enclosing_Master
/= Standard_Standard
loop
3814 if Ekind
(Enclosing_Master
) = E_Package
then
3815 if Is_Compilation_Unit
(Enclosing_Master
) then
3816 if In_Package_Body
(Enclosing_Master
) then
3818 (Body_Entity
(Enclosing_Master
));
3827 Enclosing_Master
:= Scope
(Enclosing_Master
);
3830 elsif Is_Generic_Unit
(Enclosing_Master
)
3831 or else Ekind
(Enclosing_Master
) = E_Void
3833 -- Cleanup actions will eventually be performed on the
3834 -- enclosing subprogram or package instance, if any.
3835 -- Enclosing scope is void in the formal part of a
3836 -- generic subprogram.
3841 if Ekind
(Enclosing_Master
) = E_Entry
3843 Ekind
(Scope
(Enclosing_Master
)) = E_Protected_Type
3845 if not Expander_Active
then
3849 Protected_Body_Subprogram
(Enclosing_Master
);
3853 Set_Delay_Cleanups
(Enclosing_Master
);
3855 while Ekind
(Enclosing_Master
) = E_Block
loop
3856 Enclosing_Master
:= Scope
(Enclosing_Master
);
3859 if Is_Subprogram
(Enclosing_Master
) then
3860 Delay_Descriptors
(Enclosing_Master
);
3862 elsif Is_Task_Type
(Enclosing_Master
) then
3864 TBP
: constant Node_Id
:=
3865 Get_Task_Body_Procedure
3868 if Present
(TBP
) then
3869 Delay_Descriptors
(TBP
);
3870 Set_Delay_Cleanups
(TBP
);
3877 end loop Scope_Loop
;
3880 -- Make entry in table
3882 Pending_Instantiations
.Append
3884 Act_Decl
=> Act_Decl
,
3885 Expander_Status
=> Expander_Active
,
3886 Current_Sem_Unit
=> Current_Sem_Unit
,
3887 Scope_Suppress
=> Scope_Suppress
,
3888 Local_Suppress_Stack_Top
=> Local_Suppress_Stack_Top
,
3889 Version
=> Ada_Version
));
3893 Set_Categorization_From_Pragmas
(Act_Decl
);
3895 if Parent_Installed
then
3899 Set_Instance_Spec
(N
, Act_Decl
);
3901 -- If not a compilation unit, insert the package declaration before
3902 -- the original instantiation node.
3904 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
3905 Mark_Rewrite_Insertion
(Act_Decl
);
3906 Insert_Before
(N
, Act_Decl
);
3909 -- For an instantiation that is a compilation unit, place
3910 -- declaration on current node so context is complete for analysis
3911 -- (including nested instantiations). If this is the main unit,
3912 -- the declaration eventually replaces the instantiation node.
3913 -- If the instance body is created later, it replaces the
3914 -- instance node, and the declaration is attached to it
3915 -- (see Build_Instance_Compilation_Unit_Nodes).
3918 if Cunit_Entity
(Current_Sem_Unit
) = Defining_Entity
(N
) then
3920 -- The entity for the current unit is the newly created one,
3921 -- and all semantic information is attached to it.
3923 Set_Cunit_Entity
(Current_Sem_Unit
, Act_Decl_Id
);
3925 -- If this is the main unit, replace the main entity as well
3927 if Current_Sem_Unit
= Main_Unit
then
3928 Main_Unit_Entity
:= Act_Decl_Id
;
3932 Set_Unit
(Parent
(N
), Act_Decl
);
3933 Set_Parent_Spec
(Act_Decl
, Parent_Spec
(N
));
3934 Set_Package_Instantiation
(Act_Decl_Id
, N
);
3936 Set_Unit
(Parent
(N
), N
);
3937 Set_Body_Required
(Parent
(N
), False);
3939 -- We never need elaboration checks on instantiations, since by
3940 -- definition, the body instantiation is elaborated at the same
3941 -- time as the spec instantiation.
3943 Set_Suppress_Elaboration_Warnings
(Act_Decl_Id
);
3944 Set_Kill_Elaboration_Checks
(Act_Decl_Id
);
3947 Check_Elab_Instantiation
(N
);
3949 if ABE_Is_Certain
(N
) and then Needs_Body
then
3950 Pending_Instantiations
.Decrement_Last
;
3953 Check_Hidden_Child_Unit
(N
, Gen_Unit
, Act_Decl_Id
);
3955 Set_First_Private_Entity
(Defining_Unit_Name
(Unit_Renaming
),
3956 First_Private_Entity
(Act_Decl_Id
));
3958 -- If the instantiation will receive a body, the unit will be
3959 -- transformed into a package body, and receive its own elaboration
3960 -- entity. Otherwise, the nature of the unit is now a package
3963 if Nkind
(Parent
(N
)) = N_Compilation_Unit
3964 and then not Needs_Body
3966 Rewrite
(N
, Act_Decl
);
3969 if Present
(Corresponding_Body
(Gen_Decl
))
3970 or else Unit_Requires_Body
(Gen_Unit
)
3972 Set_Has_Completion
(Act_Decl_Id
);
3975 Check_Formal_Packages
(Act_Decl_Id
);
3977 Restore_Hidden_Primitives
(Vis_Prims_List
);
3978 Restore_Private_Views
(Act_Decl_Id
);
3980 Inherit_Context
(Gen_Decl
, N
);
3982 if Parent_Installed
then
3987 Env_Installed
:= False;
3990 Validate_Categorization_Dependency
(N
, Act_Decl_Id
);
3992 -- There used to be a check here to prevent instantiations in local
3993 -- contexts if the No_Local_Allocators restriction was active. This
3994 -- check was removed by a binding interpretation in AI-95-00130/07,
3995 -- but we retain the code for documentation purposes.
3997 -- if Ekind (Act_Decl_Id) /= E_Void
3998 -- and then not Is_Library_Level_Entity (Act_Decl_Id)
4000 -- Check_Restriction (No_Local_Allocators, N);
4004 Inline_Instance_Body
(N
, Gen_Unit
, Act_Decl
);
4007 -- The following is a tree patch for ASIS: ASIS needs separate nodes to
4008 -- be used as defining identifiers for a formal package and for the
4009 -- corresponding expanded package.
4011 if Nkind
(N
) = N_Formal_Package_Declaration
then
4012 Act_Decl_Id
:= New_Copy
(Defining_Entity
(N
));
4013 Set_Comes_From_Source
(Act_Decl_Id
, True);
4014 Set_Is_Generic_Instance
(Act_Decl_Id
, False);
4015 Set_Defining_Identifier
(N
, Act_Decl_Id
);
4018 Style_Check
:= Save_Style_Check
;
4020 -- Check that if N is an instantiation of System.Dim_Float_IO or
4021 -- System.Dim_Integer_IO, the formal type has a dimension system.
4023 if Nkind
(N
) = N_Package_Instantiation
4024 and then Is_Dim_IO_Package_Instantiation
(N
)
4027 Assoc
: constant Node_Id
:= First
(Generic_Associations
(N
));
4029 if not Has_Dimension_System
4030 (Etype
(Explicit_Generic_Actual_Parameter
(Assoc
)))
4032 Error_Msg_N
("type with a dimension system expected", Assoc
);
4038 if Has_Aspects
(N
) then
4039 Analyze_Aspect_Specifications
(N
, Act_Decl_Id
);
4043 when Instantiation_Error
=>
4044 if Parent_Installed
then
4048 if Env_Installed
then
4052 Style_Check
:= Save_Style_Check
;
4053 end Analyze_Package_Instantiation
;
4055 --------------------------
4056 -- Inline_Instance_Body --
4057 --------------------------
4059 procedure Inline_Instance_Body
4061 Gen_Unit
: Entity_Id
;
4065 Gen_Comp
: constant Entity_Id
:=
4066 Cunit_Entity
(Get_Source_Unit
(Gen_Unit
));
4067 Curr_Comp
: constant Node_Id
:= Cunit
(Current_Sem_Unit
);
4068 Curr_Scope
: Entity_Id
:= Empty
;
4069 Curr_Unit
: constant Entity_Id
:= Cunit_Entity
(Current_Sem_Unit
);
4070 Removed
: Boolean := False;
4071 Num_Scopes
: Int
:= 0;
4073 Scope_Stack_Depth
: constant Int
:=
4074 Scope_Stack
.Last
- Scope_Stack
.First
+ 1;
4076 Use_Clauses
: array (1 .. Scope_Stack_Depth
) of Node_Id
;
4077 Instances
: array (1 .. Scope_Stack_Depth
) of Entity_Id
;
4078 Inner_Scopes
: array (1 .. Scope_Stack_Depth
) of Entity_Id
;
4079 Num_Inner
: Int
:= 0;
4080 N_Instances
: Int
:= 0;
4084 -- Case of generic unit defined in another unit. We must remove the
4085 -- complete context of the current unit to install that of the generic.
4087 if Gen_Comp
/= Cunit_Entity
(Current_Sem_Unit
) then
4089 -- Add some comments for the following two loops ???
4092 while Present
(S
) and then S
/= Standard_Standard
loop
4094 Num_Scopes
:= Num_Scopes
+ 1;
4096 Use_Clauses
(Num_Scopes
) :=
4098 (Scope_Stack
.Last
- Num_Scopes
+ 1).
4100 End_Use_Clauses
(Use_Clauses
(Num_Scopes
));
4102 exit when Scope_Stack
.Last
- Num_Scopes
+ 1 = Scope_Stack
.First
4103 or else Scope_Stack
.Table
4104 (Scope_Stack
.Last
- Num_Scopes
).Entity
4108 exit when Is_Generic_Instance
(S
)
4109 and then (In_Package_Body
(S
)
4110 or else Ekind
(S
) = E_Procedure
4111 or else Ekind
(S
) = E_Function
);
4115 Vis
:= Is_Immediately_Visible
(Gen_Comp
);
4117 -- Find and save all enclosing instances
4122 and then S
/= Standard_Standard
4124 if Is_Generic_Instance
(S
) then
4125 N_Instances
:= N_Instances
+ 1;
4126 Instances
(N_Instances
) := S
;
4128 exit when In_Package_Body
(S
);
4134 -- Remove context of current compilation unit, unless we are within a
4135 -- nested package instantiation, in which case the context has been
4136 -- removed previously.
4138 -- If current scope is the body of a child unit, remove context of
4139 -- spec as well. If an enclosing scope is an instance body, the
4140 -- context has already been removed, but the entities in the body
4141 -- must be made invisible as well.
4146 and then S
/= Standard_Standard
4148 if Is_Generic_Instance
(S
)
4149 and then (In_Package_Body
(S
)
4150 or else Ekind
(S
) = E_Procedure
4151 or else Ekind
(S
) = E_Function
)
4153 -- We still have to remove the entities of the enclosing
4154 -- instance from direct visibility.
4159 E
:= First_Entity
(S
);
4160 while Present
(E
) loop
4161 Set_Is_Immediately_Visible
(E
, False);
4170 or else (Ekind
(Curr_Unit
) = E_Package_Body
4171 and then S
= Spec_Entity
(Curr_Unit
))
4172 or else (Ekind
(Curr_Unit
) = E_Subprogram_Body
4175 (Unit_Declaration_Node
(Curr_Unit
)))
4179 -- Remove entities in current scopes from visibility, so that
4180 -- instance body is compiled in a clean environment.
4182 Save_Scope_Stack
(Handle_Use
=> False);
4184 if Is_Child_Unit
(S
) then
4186 -- Remove child unit from stack, as well as inner scopes.
4187 -- Removing the context of a child unit removes parent units
4190 while Current_Scope
/= S
loop
4191 Num_Inner
:= Num_Inner
+ 1;
4192 Inner_Scopes
(Num_Inner
) := Current_Scope
;
4197 Remove_Context
(Curr_Comp
);
4201 Remove_Context
(Curr_Comp
);
4204 if Ekind
(Curr_Unit
) = E_Package_Body
then
4205 Remove_Context
(Library_Unit
(Curr_Comp
));
4211 pragma Assert
(Num_Inner
< Num_Scopes
);
4213 Push_Scope
(Standard_Standard
);
4214 Scope_Stack
.Table
(Scope_Stack
.Last
).Is_Active_Stack_Base
:= True;
4215 Instantiate_Package_Body
4218 Act_Decl
=> Act_Decl
,
4219 Expander_Status
=> Expander_Active
,
4220 Current_Sem_Unit
=> Current_Sem_Unit
,
4221 Scope_Suppress
=> Scope_Suppress
,
4222 Local_Suppress_Stack_Top
=> Local_Suppress_Stack_Top
,
4223 Version
=> Ada_Version
)),
4224 Inlined_Body
=> True);
4230 Set_Is_Immediately_Visible
(Gen_Comp
, Vis
);
4232 -- Reset Generic_Instance flag so that use clauses can be installed
4233 -- in the proper order. (See Use_One_Package for effect of enclosing
4234 -- instances on processing of use clauses).
4236 for J
in 1 .. N_Instances
loop
4237 Set_Is_Generic_Instance
(Instances
(J
), False);
4241 Install_Context
(Curr_Comp
);
4243 if Present
(Curr_Scope
)
4244 and then Is_Child_Unit
(Curr_Scope
)
4246 Push_Scope
(Curr_Scope
);
4247 Set_Is_Immediately_Visible
(Curr_Scope
);
4249 -- Finally, restore inner scopes as well
4251 for J
in reverse 1 .. Num_Inner
loop
4252 Push_Scope
(Inner_Scopes
(J
));
4256 Restore_Scope_Stack
(Handle_Use
=> False);
4258 if Present
(Curr_Scope
)
4260 (In_Private_Part
(Curr_Scope
)
4261 or else In_Package_Body
(Curr_Scope
))
4263 -- Install private declaration of ancestor units, which are
4264 -- currently available. Restore_Scope_Stack and Install_Context
4265 -- only install the visible part of parents.
4270 Par
:= Scope
(Curr_Scope
);
4271 while (Present
(Par
))
4272 and then Par
/= Standard_Standard
4274 Install_Private_Declarations
(Par
);
4281 -- Restore use clauses. For a child unit, use clauses in the parents
4282 -- are restored when installing the context, so only those in inner
4283 -- scopes (and those local to the child unit itself) need to be
4284 -- installed explicitly.
4286 if Is_Child_Unit
(Curr_Unit
)
4289 for J
in reverse 1 .. Num_Inner
+ 1 loop
4290 Scope_Stack
.Table
(Scope_Stack
.Last
- J
+ 1).First_Use_Clause
:=
4292 Install_Use_Clauses
(Use_Clauses
(J
));
4296 for J
in reverse 1 .. Num_Scopes
loop
4297 Scope_Stack
.Table
(Scope_Stack
.Last
- J
+ 1).First_Use_Clause
:=
4299 Install_Use_Clauses
(Use_Clauses
(J
));
4303 -- Restore status of instances. If one of them is a body, make
4304 -- its local entities visible again.
4311 for J
in 1 .. N_Instances
loop
4312 Inst
:= Instances
(J
);
4313 Set_Is_Generic_Instance
(Inst
, True);
4315 if In_Package_Body
(Inst
)
4316 or else Ekind
(S
) = E_Procedure
4317 or else Ekind
(S
) = E_Function
4319 E
:= First_Entity
(Instances
(J
));
4320 while Present
(E
) loop
4321 Set_Is_Immediately_Visible
(E
);
4328 -- If generic unit is in current unit, current context is correct
4331 Instantiate_Package_Body
4334 Act_Decl
=> Act_Decl
,
4335 Expander_Status
=> Expander_Active
,
4336 Current_Sem_Unit
=> Current_Sem_Unit
,
4337 Scope_Suppress
=> Scope_Suppress
,
4338 Local_Suppress_Stack_Top
=> Local_Suppress_Stack_Top
,
4339 Version
=> Ada_Version
)),
4340 Inlined_Body
=> True);
4342 end Inline_Instance_Body
;
4344 -------------------------------------
4345 -- Analyze_Procedure_Instantiation --
4346 -------------------------------------
4348 procedure Analyze_Procedure_Instantiation
(N
: Node_Id
) is
4350 Analyze_Subprogram_Instantiation
(N
, E_Procedure
);
4351 end Analyze_Procedure_Instantiation
;
4353 -----------------------------------
4354 -- Need_Subprogram_Instance_Body --
4355 -----------------------------------
4357 function Need_Subprogram_Instance_Body
4359 Subp
: Entity_Id
) return Boolean
4362 if (Is_In_Main_Unit
(N
)
4363 or else Is_Inlined
(Subp
)
4364 or else Is_Inlined
(Alias
(Subp
)))
4365 and then (Operating_Mode
= Generate_Code
4366 or else (Operating_Mode
= Check_Semantics
4367 and then ASIS_Mode
))
4368 and then (Full_Expander_Active
or else ASIS_Mode
)
4369 and then not ABE_Is_Certain
(N
)
4370 and then not Is_Eliminated
(Subp
)
4372 Pending_Instantiations
.Append
4374 Act_Decl
=> Unit_Declaration_Node
(Subp
),
4375 Expander_Status
=> Expander_Active
,
4376 Current_Sem_Unit
=> Current_Sem_Unit
,
4377 Scope_Suppress
=> Scope_Suppress
,
4378 Local_Suppress_Stack_Top
=> Local_Suppress_Stack_Top
,
4379 Version
=> Ada_Version
));
4385 end Need_Subprogram_Instance_Body
;
4387 --------------------------------------
4388 -- Analyze_Subprogram_Instantiation --
4389 --------------------------------------
4391 procedure Analyze_Subprogram_Instantiation
4395 Loc
: constant Source_Ptr
:= Sloc
(N
);
4396 Gen_Id
: constant Node_Id
:= Name
(N
);
4398 Anon_Id
: constant Entity_Id
:=
4399 Make_Defining_Identifier
(Sloc
(Defining_Entity
(N
)),
4400 Chars
=> New_External_Name
4401 (Chars
(Defining_Entity
(N
)), 'R'));
4403 Act_Decl_Id
: Entity_Id
;
4408 Env_Installed
: Boolean := False;
4409 Gen_Unit
: Entity_Id
;
4411 Pack_Id
: Entity_Id
;
4412 Parent_Installed
: Boolean := False;
4413 Renaming_List
: List_Id
;
4415 procedure Analyze_Instance_And_Renamings
;
4416 -- The instance must be analyzed in a context that includes the mappings
4417 -- of generic parameters into actuals. We create a package declaration
4418 -- for this purpose, and a subprogram with an internal name within the
4419 -- package. The subprogram instance is simply an alias for the internal
4420 -- subprogram, declared in the current scope.
4422 ------------------------------------
4423 -- Analyze_Instance_And_Renamings --
4424 ------------------------------------
4426 procedure Analyze_Instance_And_Renamings
is
4427 Def_Ent
: constant Entity_Id
:= Defining_Entity
(N
);
4428 Pack_Decl
: Node_Id
;
4431 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
4433 -- For the case of a compilation unit, the container package has
4434 -- the same name as the instantiation, to insure that the binder
4435 -- calls the elaboration procedure with the right name. Copy the
4436 -- entity of the instance, which may have compilation level flags
4437 -- (e.g. Is_Child_Unit) set.
4439 Pack_Id
:= New_Copy
(Def_Ent
);
4442 -- Otherwise we use the name of the instantiation concatenated
4443 -- with its source position to ensure uniqueness if there are
4444 -- several instantiations with the same name.
4447 Make_Defining_Identifier
(Loc
,
4448 Chars
=> New_External_Name
4449 (Related_Id
=> Chars
(Def_Ent
),
4451 Suffix_Index
=> Source_Offset
(Sloc
(Def_Ent
))));
4454 Pack_Decl
:= Make_Package_Declaration
(Loc
,
4455 Specification
=> Make_Package_Specification
(Loc
,
4456 Defining_Unit_Name
=> Pack_Id
,
4457 Visible_Declarations
=> Renaming_List
,
4458 End_Label
=> Empty
));
4460 Set_Instance_Spec
(N
, Pack_Decl
);
4461 Set_Is_Generic_Instance
(Pack_Id
);
4462 Set_Debug_Info_Needed
(Pack_Id
);
4464 -- Case of not a compilation unit
4466 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
4467 Mark_Rewrite_Insertion
(Pack_Decl
);
4468 Insert_Before
(N
, Pack_Decl
);
4469 Set_Has_Completion
(Pack_Id
);
4471 -- Case of an instantiation that is a compilation unit
4473 -- Place declaration on current node so context is complete for
4474 -- analysis (including nested instantiations), and for use in a
4475 -- context_clause (see Analyze_With_Clause).
4478 Set_Unit
(Parent
(N
), Pack_Decl
);
4479 Set_Parent_Spec
(Pack_Decl
, Parent_Spec
(N
));
4482 Analyze
(Pack_Decl
);
4483 Check_Formal_Packages
(Pack_Id
);
4484 Set_Is_Generic_Instance
(Pack_Id
, False);
4486 -- Why do we clear Is_Generic_Instance??? We set it 20 lines
4489 -- Body of the enclosing package is supplied when instantiating the
4490 -- subprogram body, after semantic analysis is completed.
4492 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
4494 -- Remove package itself from visibility, so it does not
4495 -- conflict with subprogram.
4497 Set_Name_Entity_Id
(Chars
(Pack_Id
), Homonym
(Pack_Id
));
4499 -- Set name and scope of internal subprogram so that the proper
4500 -- external name will be generated. The proper scope is the scope
4501 -- of the wrapper package. We need to generate debugging info for
4502 -- the internal subprogram, so set flag accordingly.
4504 Set_Chars
(Anon_Id
, Chars
(Defining_Entity
(N
)));
4505 Set_Scope
(Anon_Id
, Scope
(Pack_Id
));
4507 -- Mark wrapper package as referenced, to avoid spurious warnings
4508 -- if the instantiation appears in various with_ clauses of
4509 -- subunits of the main unit.
4511 Set_Referenced
(Pack_Id
);
4514 Set_Is_Generic_Instance
(Anon_Id
);
4515 Set_Debug_Info_Needed
(Anon_Id
);
4516 Act_Decl_Id
:= New_Copy
(Anon_Id
);
4518 Set_Parent
(Act_Decl_Id
, Parent
(Anon_Id
));
4519 Set_Chars
(Act_Decl_Id
, Chars
(Defining_Entity
(N
)));
4520 Set_Sloc
(Act_Decl_Id
, Sloc
(Defining_Entity
(N
)));
4521 Set_Comes_From_Source
(Act_Decl_Id
, True);
4523 -- The signature may involve types that are not frozen yet, but the
4524 -- subprogram will be frozen at the point the wrapper package is
4525 -- frozen, so it does not need its own freeze node. In fact, if one
4526 -- is created, it might conflict with the freezing actions from the
4529 Set_Has_Delayed_Freeze
(Anon_Id
, False);
4531 -- If the instance is a child unit, mark the Id accordingly. Mark
4532 -- the anonymous entity as well, which is the real subprogram and
4533 -- which is used when the instance appears in a context clause.
4534 -- Similarly, propagate the Is_Eliminated flag to handle properly
4535 -- nested eliminated subprograms.
4537 Set_Is_Child_Unit
(Act_Decl_Id
, Is_Child_Unit
(Defining_Entity
(N
)));
4538 Set_Is_Child_Unit
(Anon_Id
, Is_Child_Unit
(Defining_Entity
(N
)));
4539 New_Overloaded_Entity
(Act_Decl_Id
);
4540 Check_Eliminated
(Act_Decl_Id
);
4541 Set_Is_Eliminated
(Anon_Id
, Is_Eliminated
(Act_Decl_Id
));
4543 -- In compilation unit case, kill elaboration checks on the
4544 -- instantiation, since they are never needed -- the body is
4545 -- instantiated at the same point as the spec.
4547 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
4548 Set_Suppress_Elaboration_Warnings
(Act_Decl_Id
);
4549 Set_Kill_Elaboration_Checks
(Act_Decl_Id
);
4550 Set_Is_Compilation_Unit
(Anon_Id
);
4552 Set_Cunit_Entity
(Current_Sem_Unit
, Pack_Id
);
4555 -- The instance is not a freezing point for the new subprogram
4557 Set_Is_Frozen
(Act_Decl_Id
, False);
4559 if Nkind
(Defining_Entity
(N
)) = N_Defining_Operator_Symbol
then
4560 Valid_Operator_Definition
(Act_Decl_Id
);
4563 Set_Alias
(Act_Decl_Id
, Anon_Id
);
4564 Set_Parent
(Act_Decl_Id
, Parent
(Anon_Id
));
4565 Set_Has_Completion
(Act_Decl_Id
);
4566 Set_Related_Instance
(Pack_Id
, Act_Decl_Id
);
4568 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
4569 Set_Body_Required
(Parent
(N
), False);
4571 end Analyze_Instance_And_Renamings
;
4575 Vis_Prims_List
: Elist_Id
:= No_Elist
;
4576 -- List of primitives made temporarily visible in the instantiation
4577 -- to match the visibility of the formal type
4579 -- Start of processing for Analyze_Subprogram_Instantiation
4582 Check_SPARK_Restriction
("generic is not allowed", N
);
4584 -- Very first thing: apply the special kludge for Text_IO processing
4585 -- in case we are instantiating one of the children of [Wide_]Text_IO.
4586 -- Of course such an instantiation is bogus (these are packages, not
4587 -- subprograms), but we get a better error message if we do this.
4589 Text_IO_Kludge
(Gen_Id
);
4591 -- Make node global for error reporting
4593 Instantiation_Node
:= N
;
4595 -- For package instantiations we turn off style checks, because they
4596 -- will have been emitted in the generic. For subprogram instantiations
4597 -- we want to apply at least the check on overriding indicators so we
4598 -- do not modify the style check status.
4600 -- The renaming declarations for the actuals do not come from source and
4601 -- will not generate spurious warnings.
4603 Preanalyze_Actuals
(N
);
4606 Env_Installed
:= True;
4607 Check_Generic_Child_Unit
(Gen_Id
, Parent_Installed
);
4608 Gen_Unit
:= Entity
(Gen_Id
);
4610 Generate_Reference
(Gen_Unit
, Gen_Id
);
4612 if Nkind
(Gen_Id
) = N_Identifier
4613 and then Chars
(Gen_Unit
) = Chars
(Defining_Entity
(N
))
4616 ("& is hidden within declaration of instance", Gen_Id
, Gen_Unit
);
4619 if Etype
(Gen_Unit
) = Any_Type
then
4624 -- Verify that it is a generic subprogram of the right kind, and that
4625 -- it does not lead to a circular instantiation.
4627 if not Ekind_In
(Gen_Unit
, E_Generic_Procedure
, E_Generic_Function
) then
4628 Error_Msg_N
("expect generic subprogram in instantiation", Gen_Id
);
4630 elsif In_Open_Scopes
(Gen_Unit
) then
4631 Error_Msg_NE
("instantiation of & within itself", N
, Gen_Unit
);
4633 elsif K
= E_Procedure
4634 and then Ekind
(Gen_Unit
) /= E_Generic_Procedure
4636 if Ekind
(Gen_Unit
) = E_Generic_Function
then
4638 ("cannot instantiate generic function as procedure", Gen_Id
);
4641 ("expect name of generic procedure in instantiation", Gen_Id
);
4644 elsif K
= E_Function
4645 and then Ekind
(Gen_Unit
) /= E_Generic_Function
4647 if Ekind
(Gen_Unit
) = E_Generic_Procedure
then
4649 ("cannot instantiate generic procedure as function", Gen_Id
);
4652 ("expect name of generic function in instantiation", Gen_Id
);
4656 Set_Entity
(Gen_Id
, Gen_Unit
);
4657 Set_Is_Instantiated
(Gen_Unit
);
4659 if In_Extended_Main_Source_Unit
(N
) then
4660 Generate_Reference
(Gen_Unit
, N
);
4663 -- If renaming, get original unit
4665 if Present
(Renamed_Object
(Gen_Unit
))
4666 and then (Ekind
(Renamed_Object
(Gen_Unit
)) = E_Generic_Procedure
4668 Ekind
(Renamed_Object
(Gen_Unit
)) = E_Generic_Function
)
4670 Gen_Unit
:= Renamed_Object
(Gen_Unit
);
4671 Set_Is_Instantiated
(Gen_Unit
);
4672 Generate_Reference
(Gen_Unit
, N
);
4675 if Contains_Instance_Of
(Gen_Unit
, Current_Scope
, Gen_Id
) then
4676 Error_Msg_Node_2
:= Current_Scope
;
4678 ("circular Instantiation: & instantiated in &!", N
, Gen_Unit
);
4679 Circularity_Detected
:= True;
4680 Restore_Hidden_Primitives
(Vis_Prims_List
);
4684 Gen_Decl
:= Unit_Declaration_Node
(Gen_Unit
);
4686 -- Initialize renamings map, for error checking
4688 Generic_Renamings
.Set_Last
(0);
4689 Generic_Renamings_HTable
.Reset
;
4691 Create_Instantiation_Source
(N
, Gen_Unit
, False, S_Adjustment
);
4693 -- Copy original generic tree, to produce text for instantiation
4697 (Original_Node
(Gen_Decl
), Empty
, Instantiating
=> True);
4699 -- Inherit overriding indicator from instance node
4701 Act_Spec
:= Specification
(Act_Tree
);
4702 Set_Must_Override
(Act_Spec
, Must_Override
(N
));
4703 Set_Must_Not_Override
(Act_Spec
, Must_Not_Override
(N
));
4706 Analyze_Associations
4708 Formals
=> Generic_Formal_Declarations
(Act_Tree
),
4709 F_Copy
=> Generic_Formal_Declarations
(Gen_Decl
));
4711 Vis_Prims_List
:= Check_Hidden_Primitives
(Renaming_List
);
4713 -- The subprogram itself cannot contain a nested instance, so the
4714 -- current parent is left empty.
4716 Set_Instance_Env
(Gen_Unit
, Empty
);
4718 -- Build the subprogram declaration, which does not appear in the
4719 -- generic template, and give it a sloc consistent with that of the
4722 Set_Defining_Unit_Name
(Act_Spec
, Anon_Id
);
4723 Set_Generic_Parent
(Act_Spec
, Gen_Unit
);
4725 Make_Subprogram_Declaration
(Sloc
(Act_Spec
),
4726 Specification
=> Act_Spec
);
4728 -- The aspects have been copied previously, but they have to be
4729 -- linked explicitly to the new subprogram declaration. Explicit
4730 -- pre/postconditions on the instance are analyzed below, in a
4733 Move_Aspects
(Act_Tree
, Act_Decl
);
4734 Set_Categorization_From_Pragmas
(Act_Decl
);
4736 if Parent_Installed
then
4740 Append
(Act_Decl
, Renaming_List
);
4741 Analyze_Instance_And_Renamings
;
4743 -- If the generic is marked Import (Intrinsic), then so is the
4744 -- instance. This indicates that there is no body to instantiate. If
4745 -- generic is marked inline, so it the instance, and the anonymous
4746 -- subprogram it renames. If inlined, or else if inlining is enabled
4747 -- for the compilation, we generate the instance body even if it is
4748 -- not within the main unit.
4750 if Is_Intrinsic_Subprogram
(Gen_Unit
) then
4751 Set_Is_Intrinsic_Subprogram
(Anon_Id
);
4752 Set_Is_Intrinsic_Subprogram
(Act_Decl_Id
);
4754 if Chars
(Gen_Unit
) = Name_Unchecked_Conversion
then
4755 Validate_Unchecked_Conversion
(N
, Act_Decl_Id
);
4759 -- Inherit convention from generic unit. Intrinsic convention, as for
4760 -- an instance of unchecked conversion, is not inherited because an
4761 -- explicit Ada instance has been created.
4763 if Has_Convention_Pragma
(Gen_Unit
)
4764 and then Convention
(Gen_Unit
) /= Convention_Intrinsic
4766 Set_Convention
(Act_Decl_Id
, Convention
(Gen_Unit
));
4767 Set_Is_Exported
(Act_Decl_Id
, Is_Exported
(Gen_Unit
));
4770 Generate_Definition
(Act_Decl_Id
);
4771 -- Set_Contract (Anon_Id, Make_Contract (Sloc (Anon_Id)));
4773 Set_Contract
(Act_Decl_Id
, Make_Contract
(Sloc
(Act_Decl_Id
)));
4775 -- Inherit all inlining-related flags which apply to the generic in
4776 -- the subprogram and its declaration.
4778 Set_Is_Inlined
(Act_Decl_Id
, Is_Inlined
(Gen_Unit
));
4779 Set_Is_Inlined
(Anon_Id
, Is_Inlined
(Gen_Unit
));
4781 Set_Has_Pragma_Inline
(Act_Decl_Id
, Has_Pragma_Inline
(Gen_Unit
));
4782 Set_Has_Pragma_Inline
(Anon_Id
, Has_Pragma_Inline
(Gen_Unit
));
4784 Set_Has_Pragma_Inline_Always
4785 (Act_Decl_Id
, Has_Pragma_Inline_Always
(Gen_Unit
));
4786 Set_Has_Pragma_Inline_Always
4787 (Anon_Id
, Has_Pragma_Inline_Always
(Gen_Unit
));
4789 if not Is_Intrinsic_Subprogram
(Gen_Unit
) then
4790 Check_Elab_Instantiation
(N
);
4793 if Is_Dispatching_Operation
(Act_Decl_Id
)
4794 and then Ada_Version
>= Ada_2005
4800 Formal
:= First_Formal
(Act_Decl_Id
);
4801 while Present
(Formal
) loop
4802 if Ekind
(Etype
(Formal
)) = E_Anonymous_Access_Type
4803 and then Is_Controlling_Formal
(Formal
)
4804 and then not Can_Never_Be_Null
(Formal
)
4806 Error_Msg_NE
("access parameter& is controlling,",
4809 ("\corresponding parameter of & must be"
4810 & " explicitly null-excluding", N
, Gen_Id
);
4813 Next_Formal
(Formal
);
4818 Check_Hidden_Child_Unit
(N
, Gen_Unit
, Act_Decl_Id
);
4820 Validate_Categorization_Dependency
(N
, Act_Decl_Id
);
4822 if not Is_Intrinsic_Subprogram
(Act_Decl_Id
) then
4823 Inherit_Context
(Gen_Decl
, N
);
4825 Restore_Private_Views
(Pack_Id
, False);
4827 -- If the context requires a full instantiation, mark node for
4828 -- subsequent construction of the body.
4830 if Need_Subprogram_Instance_Body
(N
, Act_Decl_Id
) then
4832 Check_Forward_Instantiation
(Gen_Decl
);
4834 -- The wrapper package is always delayed, because it does not
4835 -- constitute a freeze point, but to insure that the freeze
4836 -- node is placed properly, it is created directly when
4837 -- instantiating the body (otherwise the freeze node might
4838 -- appear to early for nested instantiations).
4840 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
then
4842 -- For ASIS purposes, indicate that the wrapper package has
4843 -- replaced the instantiation node.
4845 Rewrite
(N
, Unit
(Parent
(N
)));
4846 Set_Unit
(Parent
(N
), N
);
4849 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
then
4851 -- Replace instance node for library-level instantiations of
4852 -- intrinsic subprograms, for ASIS use.
4854 Rewrite
(N
, Unit
(Parent
(N
)));
4855 Set_Unit
(Parent
(N
), N
);
4858 if Parent_Installed
then
4862 Restore_Hidden_Primitives
(Vis_Prims_List
);
4864 Env_Installed
:= False;
4865 Generic_Renamings
.Set_Last
(0);
4866 Generic_Renamings_HTable
.Reset
;
4870 if Has_Aspects
(N
) then
4871 Analyze_Aspect_Specifications
(N
, Act_Decl_Id
);
4875 when Instantiation_Error
=>
4876 if Parent_Installed
then
4880 if Env_Installed
then
4883 end Analyze_Subprogram_Instantiation
;
4885 -------------------------
4886 -- Get_Associated_Node --
4887 -------------------------
4889 function Get_Associated_Node
(N
: Node_Id
) return Node_Id
is
4893 Assoc
:= Associated_Node
(N
);
4895 if Nkind
(Assoc
) /= Nkind
(N
) then
4898 elsif Nkind_In
(Assoc
, N_Aggregate
, N_Extension_Aggregate
) then
4902 -- If the node is part of an inner generic, it may itself have been
4903 -- remapped into a further generic copy. Associated_Node is otherwise
4904 -- used for the entity of the node, and will be of a different node
4905 -- kind, or else N has been rewritten as a literal or function call.
4907 while Present
(Associated_Node
(Assoc
))
4908 and then Nkind
(Associated_Node
(Assoc
)) = Nkind
(Assoc
)
4910 Assoc
:= Associated_Node
(Assoc
);
4913 -- Follow and additional link in case the final node was rewritten.
4914 -- This can only happen with nested generic units.
4916 if (Nkind
(Assoc
) = N_Identifier
or else Nkind
(Assoc
) in N_Op
)
4917 and then Present
(Associated_Node
(Assoc
))
4918 and then (Nkind_In
(Associated_Node
(Assoc
), N_Function_Call
,
4919 N_Explicit_Dereference
,
4924 Assoc
:= Associated_Node
(Assoc
);
4929 end Get_Associated_Node
;
4931 -------------------------------------------
4932 -- Build_Instance_Compilation_Unit_Nodes --
4933 -------------------------------------------
4935 procedure Build_Instance_Compilation_Unit_Nodes
4940 Decl_Cunit
: Node_Id
;
4941 Body_Cunit
: Node_Id
;
4943 New_Main
: constant Entity_Id
:= Defining_Entity
(Act_Decl
);
4944 Old_Main
: constant Entity_Id
:= Cunit_Entity
(Main_Unit
);
4947 -- A new compilation unit node is built for the instance declaration
4950 Make_Compilation_Unit
(Sloc
(N
),
4951 Context_Items
=> Empty_List
,
4954 Make_Compilation_Unit_Aux
(Sloc
(N
)));
4956 Set_Parent_Spec
(Act_Decl
, Parent_Spec
(N
));
4958 -- The new compilation unit is linked to its body, but both share the
4959 -- same file, so we do not set Body_Required on the new unit so as not
4960 -- to create a spurious dependency on a non-existent body in the ali.
4961 -- This simplifies CodePeer unit traversal.
4963 -- We use the original instantiation compilation unit as the resulting
4964 -- compilation unit of the instance, since this is the main unit.
4966 Rewrite
(N
, Act_Body
);
4967 Body_Cunit
:= Parent
(N
);
4969 -- The two compilation unit nodes are linked by the Library_Unit field
4971 Set_Library_Unit
(Decl_Cunit
, Body_Cunit
);
4972 Set_Library_Unit
(Body_Cunit
, Decl_Cunit
);
4974 -- Preserve the private nature of the package if needed
4976 Set_Private_Present
(Decl_Cunit
, Private_Present
(Body_Cunit
));
4978 -- If the instance is not the main unit, its context, categorization
4979 -- and elaboration entity are not relevant to the compilation.
4981 if Body_Cunit
/= Cunit
(Main_Unit
) then
4982 Make_Instance_Unit
(Body_Cunit
, In_Main
=> False);
4986 -- The context clause items on the instantiation, which are now attached
4987 -- to the body compilation unit (since the body overwrote the original
4988 -- instantiation node), semantically belong on the spec, so copy them
4989 -- there. It's harmless to leave them on the body as well. In fact one
4990 -- could argue that they belong in both places.
4992 Citem
:= First
(Context_Items
(Body_Cunit
));
4993 while Present
(Citem
) loop
4994 Append
(New_Copy
(Citem
), Context_Items
(Decl_Cunit
));
4998 -- Propagate categorization flags on packages, so that they appear in
4999 -- the ali file for the spec of the unit.
5001 if Ekind
(New_Main
) = E_Package
then
5002 Set_Is_Pure
(Old_Main
, Is_Pure
(New_Main
));
5003 Set_Is_Preelaborated
(Old_Main
, Is_Preelaborated
(New_Main
));
5004 Set_Is_Remote_Types
(Old_Main
, Is_Remote_Types
(New_Main
));
5005 Set_Is_Shared_Passive
(Old_Main
, Is_Shared_Passive
(New_Main
));
5006 Set_Is_Remote_Call_Interface
5007 (Old_Main
, Is_Remote_Call_Interface
(New_Main
));
5010 -- Make entry in Units table, so that binder can generate call to
5011 -- elaboration procedure for body, if any.
5013 Make_Instance_Unit
(Body_Cunit
, In_Main
=> True);
5014 Main_Unit_Entity
:= New_Main
;
5015 Set_Cunit_Entity
(Main_Unit
, Main_Unit_Entity
);
5017 -- Build elaboration entity, since the instance may certainly generate
5018 -- elaboration code requiring a flag for protection.
5020 Build_Elaboration_Entity
(Decl_Cunit
, New_Main
);
5021 end Build_Instance_Compilation_Unit_Nodes
;
5023 -----------------------------
5024 -- Check_Access_Definition --
5025 -----------------------------
5027 procedure Check_Access_Definition
(N
: Node_Id
) is
5030 (Ada_Version
>= Ada_2005
5031 and then Present
(Access_Definition
(N
)));
5033 end Check_Access_Definition
;
5035 -----------------------------------
5036 -- Check_Formal_Package_Instance --
5037 -----------------------------------
5039 -- If the formal has specific parameters, they must match those of the
5040 -- actual. Both of them are instances, and the renaming declarations for
5041 -- their formal parameters appear in the same order in both. The analyzed
5042 -- formal has been analyzed in the context of the current instance.
5044 procedure Check_Formal_Package_Instance
5045 (Formal_Pack
: Entity_Id
;
5046 Actual_Pack
: Entity_Id
)
5048 E1
: Entity_Id
:= First_Entity
(Actual_Pack
);
5049 E2
: Entity_Id
:= First_Entity
(Formal_Pack
);
5054 procedure Check_Mismatch
(B
: Boolean);
5055 -- Common error routine for mismatch between the parameters of the
5056 -- actual instance and those of the formal package.
5058 function Same_Instantiated_Constant
(E1
, E2
: Entity_Id
) return Boolean;
5059 -- The formal may come from a nested formal package, and the actual may
5060 -- have been constant-folded. To determine whether the two denote the
5061 -- same entity we may have to traverse several definitions to recover
5062 -- the ultimate entity that they refer to.
5064 function Same_Instantiated_Variable
(E1
, E2
: Entity_Id
) return Boolean;
5065 -- Similarly, if the formal comes from a nested formal package, the
5066 -- actual may designate the formal through multiple renamings, which
5067 -- have to be followed to determine the original variable in question.
5069 --------------------
5070 -- Check_Mismatch --
5071 --------------------
5073 procedure Check_Mismatch
(B
: Boolean) is
5074 Kind
: constant Node_Kind
:= Nkind
(Parent
(E2
));
5077 if Kind
= N_Formal_Type_Declaration
then
5080 elsif Nkind_In
(Kind
, N_Formal_Object_Declaration
,
5081 N_Formal_Package_Declaration
)
5082 or else Kind
in N_Formal_Subprogram_Declaration
5088 ("actual for & in actual instance does not match formal",
5089 Parent
(Actual_Pack
), E1
);
5093 --------------------------------
5094 -- Same_Instantiated_Constant --
5095 --------------------------------
5097 function Same_Instantiated_Constant
5098 (E1
, E2
: Entity_Id
) return Boolean
5104 while Present
(Ent
) loop
5108 elsif Ekind
(Ent
) /= E_Constant
then
5111 elsif Is_Entity_Name
(Constant_Value
(Ent
)) then
5112 if Entity
(Constant_Value
(Ent
)) = E1
then
5115 Ent
:= Entity
(Constant_Value
(Ent
));
5118 -- The actual may be a constant that has been folded. Recover
5121 elsif Is_Entity_Name
(Original_Node
(Constant_Value
(Ent
))) then
5122 Ent
:= Entity
(Original_Node
(Constant_Value
(Ent
)));
5129 end Same_Instantiated_Constant
;
5131 --------------------------------
5132 -- Same_Instantiated_Variable --
5133 --------------------------------
5135 function Same_Instantiated_Variable
5136 (E1
, E2
: Entity_Id
) return Boolean
5138 function Original_Entity
(E
: Entity_Id
) return Entity_Id
;
5139 -- Follow chain of renamings to the ultimate ancestor
5141 ---------------------
5142 -- Original_Entity --
5143 ---------------------
5145 function Original_Entity
(E
: Entity_Id
) return Entity_Id
is
5150 while Nkind
(Parent
(Orig
)) = N_Object_Renaming_Declaration
5151 and then Present
(Renamed_Object
(Orig
))
5152 and then Is_Entity_Name
(Renamed_Object
(Orig
))
5154 Orig
:= Entity
(Renamed_Object
(Orig
));
5158 end Original_Entity
;
5160 -- Start of processing for Same_Instantiated_Variable
5163 return Ekind
(E1
) = Ekind
(E2
)
5164 and then Original_Entity
(E1
) = Original_Entity
(E2
);
5165 end Same_Instantiated_Variable
;
5167 -- Start of processing for Check_Formal_Package_Instance
5171 and then Present
(E2
)
5173 exit when Ekind
(E1
) = E_Package
5174 and then Renamed_Entity
(E1
) = Renamed_Entity
(Actual_Pack
);
5176 -- If the formal is the renaming of the formal package, this
5177 -- is the end of its formal part, which may occur before the
5178 -- end of the formal part in the actual in the presence of
5179 -- defaulted parameters in the formal package.
5181 exit when Nkind
(Parent
(E2
)) = N_Package_Renaming_Declaration
5182 and then Renamed_Entity
(E2
) = Scope
(E2
);
5184 -- The analysis of the actual may generate additional internal
5185 -- entities. If the formal is defaulted, there is no corresponding
5186 -- analysis and the internal entities must be skipped, until we
5187 -- find corresponding entities again.
5189 if Comes_From_Source
(E2
)
5190 and then not Comes_From_Source
(E1
)
5191 and then Chars
(E1
) /= Chars
(E2
)
5194 and then Chars
(E1
) /= Chars
(E2
)
5203 -- If the formal entity comes from a formal declaration, it was
5204 -- defaulted in the formal package, and no check is needed on it.
5206 elsif Nkind
(Parent
(E2
)) = N_Formal_Object_Declaration
then
5209 elsif Is_Type
(E1
) then
5211 -- Subtypes must statically match. E1, E2 are the local entities
5212 -- that are subtypes of the actuals. Itypes generated for other
5213 -- parameters need not be checked, the check will be performed
5214 -- on the parameters themselves.
5216 -- If E2 is a formal type declaration, it is a defaulted parameter
5217 -- and needs no checking.
5219 if not Is_Itype
(E1
)
5220 and then not Is_Itype
(E2
)
5224 or else Etype
(E1
) /= Etype
(E2
)
5225 or else not Subtypes_Statically_Match
(E1
, E2
));
5228 elsif Ekind
(E1
) = E_Constant
then
5230 -- IN parameters must denote the same static value, or the same
5231 -- constant, or the literal null.
5233 Expr1
:= Expression
(Parent
(E1
));
5235 if Ekind
(E2
) /= E_Constant
then
5236 Check_Mismatch
(True);
5239 Expr2
:= Expression
(Parent
(E2
));
5242 if Is_Static_Expression
(Expr1
) then
5244 if not Is_Static_Expression
(Expr2
) then
5245 Check_Mismatch
(True);
5247 elsif Is_Discrete_Type
(Etype
(E1
)) then
5249 V1
: constant Uint
:= Expr_Value
(Expr1
);
5250 V2
: constant Uint
:= Expr_Value
(Expr2
);
5252 Check_Mismatch
(V1
/= V2
);
5255 elsif Is_Real_Type
(Etype
(E1
)) then
5257 V1
: constant Ureal
:= Expr_Value_R
(Expr1
);
5258 V2
: constant Ureal
:= Expr_Value_R
(Expr2
);
5260 Check_Mismatch
(V1
/= V2
);
5263 elsif Is_String_Type
(Etype
(E1
))
5264 and then Nkind
(Expr1
) = N_String_Literal
5266 if Nkind
(Expr2
) /= N_String_Literal
then
5267 Check_Mismatch
(True);
5270 (not String_Equal
(Strval
(Expr1
), Strval
(Expr2
)));
5274 elsif Is_Entity_Name
(Expr1
) then
5275 if Is_Entity_Name
(Expr2
) then
5276 if Entity
(Expr1
) = Entity
(Expr2
) then
5280 (not Same_Instantiated_Constant
5281 (Entity
(Expr1
), Entity
(Expr2
)));
5284 Check_Mismatch
(True);
5287 elsif Is_Entity_Name
(Original_Node
(Expr1
))
5288 and then Is_Entity_Name
(Expr2
)
5290 Same_Instantiated_Constant
5291 (Entity
(Original_Node
(Expr1
)), Entity
(Expr2
))
5295 elsif Nkind
(Expr1
) = N_Null
then
5296 Check_Mismatch
(Nkind
(Expr1
) /= N_Null
);
5299 Check_Mismatch
(True);
5302 elsif Ekind
(E1
) = E_Variable
then
5303 Check_Mismatch
(not Same_Instantiated_Variable
(E1
, E2
));
5305 elsif Ekind
(E1
) = E_Package
then
5307 (Ekind
(E1
) /= Ekind
(E2
)
5308 or else Renamed_Object
(E1
) /= Renamed_Object
(E2
));
5310 elsif Is_Overloadable
(E1
) then
5312 -- Verify that the actual subprograms match. Note that actuals
5313 -- that are attributes are rewritten as subprograms. If the
5314 -- subprogram in the formal package is defaulted, no check is
5315 -- needed. Note that this can only happen in Ada 2005 when the
5316 -- formal package can be partially parameterized.
5318 if Nkind
(Unit_Declaration_Node
(E1
)) =
5319 N_Subprogram_Renaming_Declaration
5320 and then From_Default
(Unit_Declaration_Node
(E1
))
5324 -- If the formal package has an "others" box association that
5325 -- covers this formal, there is no need for a check either.
5327 elsif Nkind
(Unit_Declaration_Node
(E2
)) in
5328 N_Formal_Subprogram_Declaration
5329 and then Box_Present
(Unit_Declaration_Node
(E2
))
5333 -- No check needed if subprogram is a defaulted null procedure
5335 elsif No
(Alias
(E2
))
5336 and then Ekind
(E2
) = E_Procedure
5338 Null_Present
(Specification
(Unit_Declaration_Node
(E2
)))
5342 -- Otherwise the actual in the formal and the actual in the
5343 -- instantiation of the formal must match, up to renamings.
5347 (Ekind
(E2
) /= Ekind
(E1
) or else (Alias
(E1
)) /= Alias
(E2
));
5351 raise Program_Error
;
5358 end Check_Formal_Package_Instance
;
5360 ---------------------------
5361 -- Check_Formal_Packages --
5362 ---------------------------
5364 procedure Check_Formal_Packages
(P_Id
: Entity_Id
) is
5366 Formal_P
: Entity_Id
;
5369 -- Iterate through the declarations in the instance, looking for package
5370 -- renaming declarations that denote instances of formal packages. Stop
5371 -- when we find the renaming of the current package itself. The
5372 -- declaration for a formal package without a box is followed by an
5373 -- internal entity that repeats the instantiation.
5375 E
:= First_Entity
(P_Id
);
5376 while Present
(E
) loop
5377 if Ekind
(E
) = E_Package
then
5378 if Renamed_Object
(E
) = P_Id
then
5381 elsif Nkind
(Parent
(E
)) /= N_Package_Renaming_Declaration
then
5384 elsif not Box_Present
(Parent
(Associated_Formal_Package
(E
))) then
5385 Formal_P
:= Next_Entity
(E
);
5386 Check_Formal_Package_Instance
(Formal_P
, E
);
5388 -- After checking, remove the internal validating package. It
5389 -- is only needed for semantic checks, and as it may contain
5390 -- generic formal declarations it should not reach gigi.
5392 Remove
(Unit_Declaration_Node
(Formal_P
));
5398 end Check_Formal_Packages
;
5400 ---------------------------------
5401 -- Check_Forward_Instantiation --
5402 ---------------------------------
5404 procedure Check_Forward_Instantiation
(Decl
: Node_Id
) is
5406 Gen_Comp
: Entity_Id
:= Cunit_Entity
(Get_Source_Unit
(Decl
));
5409 -- The instantiation appears before the generic body if we are in the
5410 -- scope of the unit containing the generic, either in its spec or in
5411 -- the package body, and before the generic body.
5413 if Ekind
(Gen_Comp
) = E_Package_Body
then
5414 Gen_Comp
:= Spec_Entity
(Gen_Comp
);
5417 if In_Open_Scopes
(Gen_Comp
)
5418 and then No
(Corresponding_Body
(Decl
))
5423 and then not Is_Compilation_Unit
(S
)
5424 and then not Is_Child_Unit
(S
)
5426 if Ekind
(S
) = E_Package
then
5427 Set_Has_Forward_Instantiation
(S
);
5433 end Check_Forward_Instantiation
;
5435 ---------------------------
5436 -- Check_Generic_Actuals --
5437 ---------------------------
5439 -- The visibility of the actuals may be different between the point of
5440 -- generic instantiation and the instantiation of the body.
5442 procedure Check_Generic_Actuals
5443 (Instance
: Entity_Id
;
5444 Is_Formal_Box
: Boolean)
5449 function Denotes_Previous_Actual
(Typ
: Entity_Id
) return Boolean;
5450 -- For a formal that is an array type, the component type is often a
5451 -- previous formal in the same unit. The privacy status of the component
5452 -- type will have been examined earlier in the traversal of the
5453 -- corresponding actuals, and this status should not be modified for the
5454 -- array type itself.
5456 -- To detect this case we have to rescan the list of formals, which
5457 -- is usually short enough to ignore the resulting inefficiency.
5459 -----------------------------
5460 -- Denotes_Previous_Actual --
5461 -----------------------------
5463 function Denotes_Previous_Actual
(Typ
: Entity_Id
) return Boolean is
5467 Prev
:= First_Entity
(Instance
);
5468 while Present
(Prev
) loop
5470 and then Nkind
(Parent
(Prev
)) = N_Subtype_Declaration
5471 and then Is_Entity_Name
(Subtype_Indication
(Parent
(Prev
)))
5472 and then Entity
(Subtype_Indication
(Parent
(Prev
))) = Typ
5485 end Denotes_Previous_Actual
;
5487 -- Start of processing for Check_Generic_Actuals
5490 E
:= First_Entity
(Instance
);
5491 while Present
(E
) loop
5493 and then Nkind
(Parent
(E
)) = N_Subtype_Declaration
5494 and then Scope
(Etype
(E
)) /= Instance
5495 and then Is_Entity_Name
(Subtype_Indication
(Parent
(E
)))
5497 if Is_Array_Type
(E
)
5498 and then Denotes_Previous_Actual
(Component_Type
(E
))
5502 Check_Private_View
(Subtype_Indication
(Parent
(E
)));
5505 Set_Is_Generic_Actual_Type
(E
, True);
5506 Set_Is_Hidden
(E
, False);
5507 Set_Is_Potentially_Use_Visible
(E
,
5510 -- We constructed the generic actual type as a subtype of the
5511 -- supplied type. This means that it normally would not inherit
5512 -- subtype specific attributes of the actual, which is wrong for
5513 -- the generic case.
5515 Astype
:= Ancestor_Subtype
(E
);
5519 -- This can happen when E is an itype that is the full view of
5520 -- a private type completed, e.g. with a constrained array. In
5521 -- that case, use the first subtype, which will carry size
5522 -- information. The base type itself is unconstrained and will
5525 Astype
:= First_Subtype
(E
);
5528 Set_Size_Info
(E
, (Astype
));
5529 Set_RM_Size
(E
, RM_Size
(Astype
));
5530 Set_First_Rep_Item
(E
, First_Rep_Item
(Astype
));
5532 if Is_Discrete_Or_Fixed_Point_Type
(E
) then
5533 Set_RM_Size
(E
, RM_Size
(Astype
));
5535 -- In nested instances, the base type of an access actual
5536 -- may itself be private, and need to be exchanged.
5538 elsif Is_Access_Type
(E
)
5539 and then Is_Private_Type
(Etype
(E
))
5542 (New_Occurrence_Of
(Etype
(E
), Sloc
(Instance
)));
5545 elsif Ekind
(E
) = E_Package
then
5547 -- If this is the renaming for the current instance, we're done.
5548 -- Otherwise it is a formal package. If the corresponding formal
5549 -- was declared with a box, the (instantiations of the) generic
5550 -- formal part are also visible. Otherwise, ignore the entity
5551 -- created to validate the actuals.
5553 if Renamed_Object
(E
) = Instance
then
5556 elsif Nkind
(Parent
(E
)) /= N_Package_Renaming_Declaration
then
5559 -- The visibility of a formal of an enclosing generic is already
5562 elsif Denotes_Formal_Package
(E
) then
5565 elsif Present
(Associated_Formal_Package
(E
))
5566 and then not Is_Generic_Formal
(E
)
5568 if Box_Present
(Parent
(Associated_Formal_Package
(E
))) then
5569 Check_Generic_Actuals
(Renamed_Object
(E
), True);
5572 Check_Generic_Actuals
(Renamed_Object
(E
), False);
5575 Set_Is_Hidden
(E
, False);
5578 -- If this is a subprogram instance (in a wrapper package) the
5579 -- actual is fully visible.
5581 elsif Is_Wrapper_Package
(Instance
) then
5582 Set_Is_Hidden
(E
, False);
5584 -- If the formal package is declared with a box, or if the formal
5585 -- parameter is defaulted, it is visible in the body.
5588 or else Is_Visible_Formal
(E
)
5590 Set_Is_Hidden
(E
, False);
5593 if Ekind
(E
) = E_Constant
then
5595 -- If the type of the actual is a private type declared in the
5596 -- enclosing scope of the generic unit, the body of the generic
5597 -- sees the full view of the type (because it has to appear in
5598 -- the corresponding package body). If the type is private now,
5599 -- exchange views to restore the proper visiblity in the instance.
5602 Typ
: constant Entity_Id
:= Base_Type
(Etype
(E
));
5603 -- The type of the actual
5608 Parent_Scope
: Entity_Id
;
5609 -- The enclosing scope of the generic unit
5612 if Is_Wrapper_Package
(Instance
) then
5616 (Unit_Declaration_Node
5617 (Related_Instance
(Instance
))));
5621 (Specification
(Unit_Declaration_Node
(Instance
)));
5624 Parent_Scope
:= Scope
(Gen_Id
);
5626 -- The exchange is only needed if the generic is defined
5627 -- within a package which is not a common ancestor of the
5628 -- scope of the instance, and is not already in scope.
5630 if Is_Private_Type
(Typ
)
5631 and then Scope
(Typ
) = Parent_Scope
5632 and then Scope
(Instance
) /= Parent_Scope
5633 and then Ekind
(Parent_Scope
) = E_Package
5634 and then not Is_Child_Unit
(Gen_Id
)
5638 -- If the type of the entity is a subtype, it may also
5639 -- have to be made visible, together with the base type
5640 -- of its full view, after exchange.
5642 if Is_Private_Type
(Etype
(E
)) then
5643 Switch_View
(Etype
(E
));
5644 Switch_View
(Base_Type
(Etype
(E
)));
5652 end Check_Generic_Actuals
;
5654 ------------------------------
5655 -- Check_Generic_Child_Unit --
5656 ------------------------------
5658 procedure Check_Generic_Child_Unit
5660 Parent_Installed
: in out Boolean)
5662 Loc
: constant Source_Ptr
:= Sloc
(Gen_Id
);
5663 Gen_Par
: Entity_Id
:= Empty
;
5665 Inst_Par
: Entity_Id
;
5668 function Find_Generic_Child
5670 Id
: Node_Id
) return Entity_Id
;
5671 -- Search generic parent for possible child unit with the given name
5673 function In_Enclosing_Instance
return Boolean;
5674 -- Within an instance of the parent, the child unit may be denoted
5675 -- by a simple name, or an abbreviated expanded name. Examine enclosing
5676 -- scopes to locate a possible parent instantiation.
5678 ------------------------
5679 -- Find_Generic_Child --
5680 ------------------------
5682 function Find_Generic_Child
5684 Id
: Node_Id
) return Entity_Id
5689 -- If entity of name is already set, instance has already been
5690 -- resolved, e.g. in an enclosing instantiation.
5692 if Present
(Entity
(Id
)) then
5693 if Scope
(Entity
(Id
)) = Scop
then
5700 E
:= First_Entity
(Scop
);
5701 while Present
(E
) loop
5702 if Chars
(E
) = Chars
(Id
)
5703 and then Is_Child_Unit
(E
)
5705 if Is_Child_Unit
(E
)
5706 and then not Is_Visible_Child_Unit
(E
)
5709 ("generic child unit& is not visible", Gen_Id
, E
);
5721 end Find_Generic_Child
;
5723 ---------------------------
5724 -- In_Enclosing_Instance --
5725 ---------------------------
5727 function In_Enclosing_Instance
return Boolean is
5728 Enclosing_Instance
: Node_Id
;
5729 Instance_Decl
: Node_Id
;
5732 -- We do not inline any call that contains instantiations, except
5733 -- for instantiations of Unchecked_Conversion, so if we are within
5734 -- an inlined body the current instance does not require parents.
5736 if In_Inlined_Body
then
5737 pragma Assert
(Chars
(Gen_Id
) = Name_Unchecked_Conversion
);
5741 -- Loop to check enclosing scopes
5743 Enclosing_Instance
:= Current_Scope
;
5744 while Present
(Enclosing_Instance
) loop
5745 Instance_Decl
:= Unit_Declaration_Node
(Enclosing_Instance
);
5747 if Ekind
(Enclosing_Instance
) = E_Package
5748 and then Is_Generic_Instance
(Enclosing_Instance
)
5750 (Generic_Parent
(Specification
(Instance_Decl
)))
5752 -- Check whether the generic we are looking for is a child of
5755 E
:= Find_Generic_Child
5756 (Generic_Parent
(Specification
(Instance_Decl
)), Gen_Id
);
5757 exit when Present
(E
);
5763 Enclosing_Instance
:= Scope
(Enclosing_Instance
);
5775 Make_Expanded_Name
(Loc
,
5777 Prefix
=> New_Occurrence_Of
(Enclosing_Instance
, Loc
),
5778 Selector_Name
=> New_Occurrence_Of
(E
, Loc
)));
5780 Set_Entity
(Gen_Id
, E
);
5781 Set_Etype
(Gen_Id
, Etype
(E
));
5782 Parent_Installed
:= False; -- Already in scope.
5785 end In_Enclosing_Instance
;
5787 -- Start of processing for Check_Generic_Child_Unit
5790 -- If the name of the generic is given by a selected component, it may
5791 -- be the name of a generic child unit, and the prefix is the name of an
5792 -- instance of the parent, in which case the child unit must be visible.
5793 -- If this instance is not in scope, it must be placed there and removed
5794 -- after instantiation, because what is being instantiated is not the
5795 -- original child, but the corresponding child present in the instance
5798 -- If the child is instantiated within the parent, it can be given by
5799 -- a simple name. In this case the instance is already in scope, but
5800 -- the child generic must be recovered from the generic parent as well.
5802 if Nkind
(Gen_Id
) = N_Selected_Component
then
5803 S
:= Selector_Name
(Gen_Id
);
5804 Analyze
(Prefix
(Gen_Id
));
5805 Inst_Par
:= Entity
(Prefix
(Gen_Id
));
5807 if Ekind
(Inst_Par
) = E_Package
5808 and then Present
(Renamed_Object
(Inst_Par
))
5810 Inst_Par
:= Renamed_Object
(Inst_Par
);
5813 if Ekind
(Inst_Par
) = E_Package
then
5814 if Nkind
(Parent
(Inst_Par
)) = N_Package_Specification
then
5815 Gen_Par
:= Generic_Parent
(Parent
(Inst_Par
));
5817 elsif Nkind
(Parent
(Inst_Par
)) = N_Defining_Program_Unit_Name
5819 Nkind
(Parent
(Parent
(Inst_Par
))) = N_Package_Specification
5821 Gen_Par
:= Generic_Parent
(Parent
(Parent
(Inst_Par
)));
5824 elsif Ekind
(Inst_Par
) = E_Generic_Package
5825 and then Nkind
(Parent
(Gen_Id
)) = N_Formal_Package_Declaration
5827 -- A formal package may be a real child package, and not the
5828 -- implicit instance within a parent. In this case the child is
5829 -- not visible and has to be retrieved explicitly as well.
5831 Gen_Par
:= Inst_Par
;
5834 if Present
(Gen_Par
) then
5836 -- The prefix denotes an instantiation. The entity itself may be a
5837 -- nested generic, or a child unit.
5839 E
:= Find_Generic_Child
(Gen_Par
, S
);
5842 Change_Selected_Component_To_Expanded_Name
(Gen_Id
);
5843 Set_Entity
(Gen_Id
, E
);
5844 Set_Etype
(Gen_Id
, Etype
(E
));
5846 Set_Etype
(S
, Etype
(E
));
5848 -- Indicate that this is a reference to the parent
5850 if In_Extended_Main_Source_Unit
(Gen_Id
) then
5851 Set_Is_Instantiated
(Inst_Par
);
5854 -- A common mistake is to replicate the naming scheme of a
5855 -- hierarchy by instantiating a generic child directly, rather
5856 -- than the implicit child in a parent instance:
5858 -- generic .. package Gpar is ..
5859 -- generic .. package Gpar.Child is ..
5860 -- package Par is new Gpar ();
5863 -- package Par.Child is new Gpar.Child ();
5864 -- rather than Par.Child
5866 -- In this case the instantiation is within Par, which is an
5867 -- instance, but Gpar does not denote Par because we are not IN
5868 -- the instance of Gpar, so this is illegal. The test below
5869 -- recognizes this particular case.
5871 if Is_Child_Unit
(E
)
5872 and then not Comes_From_Source
(Entity
(Prefix
(Gen_Id
)))
5873 and then (not In_Instance
5874 or else Nkind
(Parent
(Parent
(Gen_Id
))) =
5878 ("prefix of generic child unit must be instance of parent",
5882 if not In_Open_Scopes
(Inst_Par
)
5883 and then Nkind
(Parent
(Gen_Id
)) not in
5884 N_Generic_Renaming_Declaration
5886 Install_Parent
(Inst_Par
);
5887 Parent_Installed
:= True;
5889 elsif In_Open_Scopes
(Inst_Par
) then
5891 -- If the parent is already installed, install the actuals
5892 -- for its formal packages. This is necessary when the
5893 -- child instance is a child of the parent instance:
5894 -- in this case, the parent is placed on the scope stack
5895 -- but the formal packages are not made visible.
5897 Install_Formal_Packages
(Inst_Par
);
5901 -- If the generic parent does not contain an entity that
5902 -- corresponds to the selector, the instance doesn't either.
5903 -- Analyzing the node will yield the appropriate error message.
5904 -- If the entity is not a child unit, then it is an inner
5905 -- generic in the parent.
5913 if Is_Child_Unit
(Entity
(Gen_Id
))
5915 Nkind
(Parent
(Gen_Id
)) not in N_Generic_Renaming_Declaration
5916 and then not In_Open_Scopes
(Inst_Par
)
5918 Install_Parent
(Inst_Par
);
5919 Parent_Installed
:= True;
5921 -- The generic unit may be the renaming of the implicit child
5922 -- present in an instance. In that case the parent instance is
5923 -- obtained from the name of the renamed entity.
5925 elsif Ekind
(Entity
(Gen_Id
)) = E_Generic_Package
5926 and then Present
(Renamed_Entity
(Entity
(Gen_Id
)))
5927 and then Is_Child_Unit
(Renamed_Entity
(Entity
(Gen_Id
)))
5930 Renamed_Package
: constant Node_Id
:=
5931 Name
(Parent
(Entity
(Gen_Id
)));
5933 if Nkind
(Renamed_Package
) = N_Expanded_Name
then
5934 Inst_Par
:= Entity
(Prefix
(Renamed_Package
));
5935 Install_Parent
(Inst_Par
);
5936 Parent_Installed
:= True;
5942 elsif Nkind
(Gen_Id
) = N_Expanded_Name
then
5944 -- Entity already present, analyze prefix, whose meaning may be
5945 -- an instance in the current context. If it is an instance of
5946 -- a relative within another, the proper parent may still have
5947 -- to be installed, if they are not of the same generation.
5949 Analyze
(Prefix
(Gen_Id
));
5951 -- In the unlikely case that a local declaration hides the name
5952 -- of the parent package, locate it on the homonym chain. If the
5953 -- context is an instance of the parent, the renaming entity is
5956 Inst_Par
:= Entity
(Prefix
(Gen_Id
));
5957 while Present
(Inst_Par
)
5958 and then not Is_Package_Or_Generic_Package
(Inst_Par
)
5960 Inst_Par
:= Homonym
(Inst_Par
);
5963 pragma Assert
(Present
(Inst_Par
));
5964 Set_Entity
(Prefix
(Gen_Id
), Inst_Par
);
5966 if In_Enclosing_Instance
then
5969 elsif Present
(Entity
(Gen_Id
))
5970 and then Is_Child_Unit
(Entity
(Gen_Id
))
5971 and then not In_Open_Scopes
(Inst_Par
)
5973 Install_Parent
(Inst_Par
);
5974 Parent_Installed
:= True;
5977 elsif In_Enclosing_Instance
then
5979 -- The child unit is found in some enclosing scope
5986 -- If this is the renaming of the implicit child in a parent
5987 -- instance, recover the parent name and install it.
5989 if Is_Entity_Name
(Gen_Id
) then
5990 E
:= Entity
(Gen_Id
);
5992 if Is_Generic_Unit
(E
)
5993 and then Nkind
(Parent
(E
)) in N_Generic_Renaming_Declaration
5994 and then Is_Child_Unit
(Renamed_Object
(E
))
5995 and then Is_Generic_Unit
(Scope
(Renamed_Object
(E
)))
5996 and then Nkind
(Name
(Parent
(E
))) = N_Expanded_Name
5999 New_Copy_Tree
(Name
(Parent
(E
))));
6000 Inst_Par
:= Entity
(Prefix
(Gen_Id
));
6002 if not In_Open_Scopes
(Inst_Par
) then
6003 Install_Parent
(Inst_Par
);
6004 Parent_Installed
:= True;
6007 -- If it is a child unit of a non-generic parent, it may be
6008 -- use-visible and given by a direct name. Install parent as
6011 elsif Is_Generic_Unit
(E
)
6012 and then Is_Child_Unit
(E
)
6014 Nkind
(Parent
(Gen_Id
)) not in N_Generic_Renaming_Declaration
6015 and then not Is_Generic_Unit
(Scope
(E
))
6017 if not In_Open_Scopes
(Scope
(E
)) then
6018 Install_Parent
(Scope
(E
));
6019 Parent_Installed
:= True;
6024 end Check_Generic_Child_Unit
;
6026 -----------------------------
6027 -- Check_Hidden_Child_Unit --
6028 -----------------------------
6030 procedure Check_Hidden_Child_Unit
6032 Gen_Unit
: Entity_Id
;
6033 Act_Decl_Id
: Entity_Id
)
6035 Gen_Id
: constant Node_Id
:= Name
(N
);
6038 if Is_Child_Unit
(Gen_Unit
)
6039 and then Is_Child_Unit
(Act_Decl_Id
)
6040 and then Nkind
(Gen_Id
) = N_Expanded_Name
6041 and then Entity
(Prefix
(Gen_Id
)) = Scope
(Act_Decl_Id
)
6042 and then Chars
(Gen_Unit
) = Chars
(Act_Decl_Id
)
6044 Error_Msg_Node_2
:= Scope
(Act_Decl_Id
);
6046 ("generic unit & is implicitly declared in &",
6047 Defining_Unit_Name
(N
), Gen_Unit
);
6048 Error_Msg_N
("\instance must have different name",
6049 Defining_Unit_Name
(N
));
6051 end Check_Hidden_Child_Unit
;
6053 ------------------------
6054 -- Check_Private_View --
6055 ------------------------
6057 procedure Check_Private_View
(N
: Node_Id
) is
6058 T
: constant Entity_Id
:= Etype
(N
);
6062 -- Exchange views if the type was not private in the generic but is
6063 -- private at the point of instantiation. Do not exchange views if
6064 -- the scope of the type is in scope. This can happen if both generic
6065 -- and instance are sibling units, or if type is defined in a parent.
6066 -- In this case the visibility of the type will be correct for all
6070 BT
:= Base_Type
(T
);
6072 if Is_Private_Type
(T
)
6073 and then not Has_Private_View
(N
)
6074 and then Present
(Full_View
(T
))
6075 and then not In_Open_Scopes
(Scope
(T
))
6077 -- In the generic, the full type was visible. Save the private
6078 -- entity, for subsequent exchange.
6082 elsif Has_Private_View
(N
)
6083 and then not Is_Private_Type
(T
)
6084 and then not Has_Been_Exchanged
(T
)
6085 and then Etype
(Get_Associated_Node
(N
)) /= T
6087 -- Only the private declaration was visible in the generic. If
6088 -- the type appears in a subtype declaration, the subtype in the
6089 -- instance must have a view compatible with that of its parent,
6090 -- which must be exchanged (see corresponding code in Restore_
6091 -- Private_Views). Otherwise, if the type is defined in a parent
6092 -- unit, leave full visibility within instance, which is safe.
6094 if In_Open_Scopes
(Scope
(Base_Type
(T
)))
6095 and then not Is_Private_Type
(Base_Type
(T
))
6096 and then Comes_From_Source
(Base_Type
(T
))
6100 elsif Nkind
(Parent
(N
)) = N_Subtype_Declaration
6101 or else not In_Private_Part
(Scope
(Base_Type
(T
)))
6103 Prepend_Elmt
(T
, Exchanged_Views
);
6104 Exchange_Declarations
(Etype
(Get_Associated_Node
(N
)));
6107 -- For composite types with inconsistent representation exchange
6108 -- component types accordingly.
6110 elsif Is_Access_Type
(T
)
6111 and then Is_Private_Type
(Designated_Type
(T
))
6112 and then not Has_Private_View
(N
)
6113 and then Present
(Full_View
(Designated_Type
(T
)))
6115 Switch_View
(Designated_Type
(T
));
6117 elsif Is_Array_Type
(T
) then
6118 if Is_Private_Type
(Component_Type
(T
))
6119 and then not Has_Private_View
(N
)
6120 and then Present
(Full_View
(Component_Type
(T
)))
6122 Switch_View
(Component_Type
(T
));
6125 -- The normal exchange mechanism relies on the setting of a
6126 -- flag on the reference in the generic. However, an additional
6127 -- mechanism is needed for types that are not explicitly mentioned
6128 -- in the generic, but may be needed in expanded code in the
6129 -- instance. This includes component types of arrays and
6130 -- designated types of access types. This processing must also
6131 -- include the index types of arrays which we take care of here.
6138 Indx
:= First_Index
(T
);
6139 while Present
(Indx
) loop
6140 Typ
:= Base_Type
(Etype
(Indx
));
6142 if Is_Private_Type
(Typ
)
6143 and then Present
(Full_View
(Typ
))
6152 elsif Is_Private_Type
(T
)
6153 and then Present
(Full_View
(T
))
6154 and then Is_Array_Type
(Full_View
(T
))
6155 and then Is_Private_Type
(Component_Type
(Full_View
(T
)))
6159 -- Finally, a non-private subtype may have a private base type, which
6160 -- must be exchanged for consistency. This can happen when a package
6161 -- body is instantiated, when the scope stack is empty but in fact
6162 -- the subtype and the base type are declared in an enclosing scope.
6164 -- Note that in this case we introduce an inconsistency in the view
6165 -- set, because we switch the base type BT, but there could be some
6166 -- private dependent subtypes of BT which remain unswitched. Such
6167 -- subtypes might need to be switched at a later point (see specific
6168 -- provision for that case in Switch_View).
6170 elsif not Is_Private_Type
(T
)
6171 and then not Has_Private_View
(N
)
6172 and then Is_Private_Type
(BT
)
6173 and then Present
(Full_View
(BT
))
6174 and then not Is_Generic_Type
(BT
)
6175 and then not In_Open_Scopes
(BT
)
6177 Prepend_Elmt
(Full_View
(BT
), Exchanged_Views
);
6178 Exchange_Declarations
(BT
);
6181 end Check_Private_View
;
6183 -----------------------------
6184 -- Check_Hidden_Primitives --
6185 -----------------------------
6187 function Check_Hidden_Primitives
(Assoc_List
: List_Id
) return Elist_Id
is
6190 Result
: Elist_Id
:= No_Elist
;
6193 if No
(Assoc_List
) then
6197 -- Traverse the list of associations between formals and actuals
6198 -- searching for renamings of tagged types
6200 Actual
:= First
(Assoc_List
);
6201 while Present
(Actual
) loop
6202 if Nkind
(Actual
) = N_Subtype_Declaration
then
6203 Gen_T
:= Generic_Parent_Type
(Actual
);
6206 and then Is_Tagged_Type
(Gen_T
)
6208 -- Traverse the list of primitives of the actual types
6209 -- searching for hidden primitives that are visible in the
6210 -- corresponding generic formal; leave them visible and
6211 -- append them to Result to restore their decoration later.
6213 Install_Hidden_Primitives
6214 (Prims_List
=> Result
,
6216 Act_T
=> Entity
(Subtype_Indication
(Actual
)));
6224 end Check_Hidden_Primitives
;
6226 --------------------------
6227 -- Contains_Instance_Of --
6228 --------------------------
6230 function Contains_Instance_Of
6233 N
: Node_Id
) return Boolean
6241 -- Verify that there are no circular instantiations. We check whether
6242 -- the unit contains an instance of the current scope or some enclosing
6243 -- scope (in case one of the instances appears in a subunit). Longer
6244 -- circularities involving subunits might seem too pathological to
6245 -- consider, but they were not too pathological for the authors of
6246 -- DEC bc30vsq, so we loop over all enclosing scopes, and mark all
6247 -- enclosing generic scopes as containing an instance.
6250 -- Within a generic subprogram body, the scope is not generic, to
6251 -- allow for recursive subprograms. Use the declaration to determine
6252 -- whether this is a generic unit.
6254 if Ekind
(Scop
) = E_Generic_Package
6255 or else (Is_Subprogram
(Scop
)
6256 and then Nkind
(Unit_Declaration_Node
(Scop
)) =
6257 N_Generic_Subprogram_Declaration
)
6259 Elmt
:= First_Elmt
(Inner_Instances
(Inner
));
6261 while Present
(Elmt
) loop
6262 if Node
(Elmt
) = Scop
then
6263 Error_Msg_Node_2
:= Inner
;
6265 ("circular Instantiation: & instantiated within &!",
6269 elsif Node
(Elmt
) = Inner
then
6272 elsif Contains_Instance_Of
(Node
(Elmt
), Scop
, N
) then
6273 Error_Msg_Node_2
:= Inner
;
6275 ("circular Instantiation: & instantiated within &!",
6283 -- Indicate that Inner is being instantiated within Scop
6285 Append_Elmt
(Inner
, Inner_Instances
(Scop
));
6288 if Scop
= Standard_Standard
then
6291 Scop
:= Scope
(Scop
);
6296 end Contains_Instance_Of
;
6298 -----------------------
6299 -- Copy_Generic_Node --
6300 -----------------------
6302 function Copy_Generic_Node
6304 Parent_Id
: Node_Id
;
6305 Instantiating
: Boolean) return Node_Id
6310 function Copy_Generic_Descendant
(D
: Union_Id
) return Union_Id
;
6311 -- Check the given value of one of the Fields referenced by the
6312 -- current node to determine whether to copy it recursively. The
6313 -- field may hold a Node_Id, a List_Id, or an Elist_Id, or a plain
6314 -- value (Sloc, Uint, Char) in which case it need not be copied.
6316 procedure Copy_Descendants
;
6317 -- Common utility for various nodes
6319 function Copy_Generic_Elist
(E
: Elist_Id
) return Elist_Id
;
6320 -- Make copy of element list
6322 function Copy_Generic_List
6324 Parent_Id
: Node_Id
) return List_Id
;
6325 -- Apply Copy_Node recursively to the members of a node list
6327 function In_Defining_Unit_Name
(Nam
: Node_Id
) return Boolean;
6328 -- True if an identifier is part of the defining program unit name
6329 -- of a child unit. The entity of such an identifier must be kept
6330 -- (for ASIS use) even though as the name of an enclosing generic
6331 -- it would otherwise not be preserved in the generic tree.
6333 ----------------------
6334 -- Copy_Descendants --
6335 ----------------------
6337 procedure Copy_Descendants
is
6339 use Atree
.Unchecked_Access
;
6340 -- This code section is part of the implementation of an untyped
6341 -- tree traversal, so it needs direct access to node fields.
6344 Set_Field1
(New_N
, Copy_Generic_Descendant
(Field1
(N
)));
6345 Set_Field2
(New_N
, Copy_Generic_Descendant
(Field2
(N
)));
6346 Set_Field3
(New_N
, Copy_Generic_Descendant
(Field3
(N
)));
6347 Set_Field4
(New_N
, Copy_Generic_Descendant
(Field4
(N
)));
6348 Set_Field5
(New_N
, Copy_Generic_Descendant
(Field5
(N
)));
6349 end Copy_Descendants
;
6351 -----------------------------
6352 -- Copy_Generic_Descendant --
6353 -----------------------------
6355 function Copy_Generic_Descendant
(D
: Union_Id
) return Union_Id
is
6357 if D
= Union_Id
(Empty
) then
6360 elsif D
in Node_Range
then
6362 (Copy_Generic_Node
(Node_Id
(D
), New_N
, Instantiating
));
6364 elsif D
in List_Range
then
6365 return Union_Id
(Copy_Generic_List
(List_Id
(D
), New_N
));
6367 elsif D
in Elist_Range
then
6368 return Union_Id
(Copy_Generic_Elist
(Elist_Id
(D
)));
6370 -- Nothing else is copyable (e.g. Uint values), return as is
6375 end Copy_Generic_Descendant
;
6377 ------------------------
6378 -- Copy_Generic_Elist --
6379 ------------------------
6381 function Copy_Generic_Elist
(E
: Elist_Id
) return Elist_Id
is
6388 M
:= First_Elmt
(E
);
6389 while Present
(M
) loop
6391 (Copy_Generic_Node
(Node
(M
), Empty
, Instantiating
), L
);
6400 end Copy_Generic_Elist
;
6402 -----------------------
6403 -- Copy_Generic_List --
6404 -----------------------
6406 function Copy_Generic_List
6408 Parent_Id
: Node_Id
) return List_Id
6416 Set_Parent
(New_L
, Parent_Id
);
6419 while Present
(N
) loop
6420 Append
(Copy_Generic_Node
(N
, Empty
, Instantiating
), New_L
);
6429 end Copy_Generic_List
;
6431 ---------------------------
6432 -- In_Defining_Unit_Name --
6433 ---------------------------
6435 function In_Defining_Unit_Name
(Nam
: Node_Id
) return Boolean is
6437 return Present
(Parent
(Nam
))
6438 and then (Nkind
(Parent
(Nam
)) = N_Defining_Program_Unit_Name
6440 (Nkind
(Parent
(Nam
)) = N_Expanded_Name
6441 and then In_Defining_Unit_Name
(Parent
(Nam
))));
6442 end In_Defining_Unit_Name
;
6444 -- Start of processing for Copy_Generic_Node
6451 New_N
:= New_Copy
(N
);
6453 -- Copy aspects if present
6455 if Has_Aspects
(N
) then
6456 Set_Has_Aspects
(New_N
, False);
6457 Set_Aspect_Specifications
6458 (New_N
, Copy_Generic_List
(Aspect_Specifications
(N
), Parent_Id
));
6461 if Instantiating
then
6462 Adjust_Instantiation_Sloc
(New_N
, S_Adjustment
);
6465 if not Is_List_Member
(N
) then
6466 Set_Parent
(New_N
, Parent_Id
);
6469 -- If defining identifier, then all fields have been copied already
6471 if Nkind
(New_N
) in N_Entity
then
6474 -- Special casing for identifiers and other entity names and operators
6476 elsif Nkind_In
(New_N
, N_Identifier
,
6477 N_Character_Literal
,
6480 or else Nkind
(New_N
) in N_Op
6482 if not Instantiating
then
6484 -- Link both nodes in order to assign subsequently the entity of
6485 -- the copy to the original node, in case this is a global
6488 Set_Associated_Node
(N
, New_N
);
6490 -- If we are within an instantiation, this is a nested generic
6491 -- that has already been analyzed at the point of definition. We
6492 -- must preserve references that were global to the enclosing
6493 -- parent at that point. Other occurrences, whether global or
6494 -- local to the current generic, must be resolved anew, so we
6495 -- reset the entity in the generic copy. A global reference has a
6496 -- smaller depth than the parent, or else the same depth in case
6497 -- both are distinct compilation units.
6498 -- A child unit is implicitly declared within the enclosing parent
6499 -- but is in fact global to it, and must be preserved.
6501 -- It is also possible for Current_Instantiated_Parent to be
6502 -- defined, and for this not to be a nested generic, namely if the
6503 -- unit is loaded through Rtsfind. In that case, the entity of
6504 -- New_N is only a link to the associated node, and not a defining
6507 -- The entities for parent units in the defining_program_unit of a
6508 -- generic child unit are established when the context of the unit
6509 -- is first analyzed, before the generic copy is made. They are
6510 -- preserved in the copy for use in ASIS queries.
6512 Ent
:= Entity
(New_N
);
6514 if No
(Current_Instantiated_Parent
.Gen_Id
) then
6516 or else Nkind
(Ent
) /= N_Defining_Identifier
6517 or else not In_Defining_Unit_Name
(N
)
6519 Set_Associated_Node
(New_N
, Empty
);
6524 not Nkind_In
(Ent
, N_Defining_Identifier
,
6525 N_Defining_Character_Literal
,
6526 N_Defining_Operator_Symbol
)
6527 or else No
(Scope
(Ent
))
6529 (Scope
(Ent
) = Current_Instantiated_Parent
.Gen_Id
6530 and then not Is_Child_Unit
(Ent
))
6532 (Scope_Depth
(Scope
(Ent
)) >
6533 Scope_Depth
(Current_Instantiated_Parent
.Gen_Id
)
6535 Get_Source_Unit
(Ent
) =
6536 Get_Source_Unit
(Current_Instantiated_Parent
.Gen_Id
))
6538 Set_Associated_Node
(New_N
, Empty
);
6541 -- Case of instantiating identifier or some other name or operator
6544 -- If the associated node is still defined, the entity in it is
6545 -- global, and must be copied to the instance. If this copy is
6546 -- being made for a body to inline, it is applied to an
6547 -- instantiated tree, and the entity is already present and must
6548 -- be also preserved.
6551 Assoc
: constant Node_Id
:= Get_Associated_Node
(N
);
6554 if Present
(Assoc
) then
6555 if Nkind
(Assoc
) = Nkind
(N
) then
6556 Set_Entity
(New_N
, Entity
(Assoc
));
6557 Check_Private_View
(N
);
6559 elsif Nkind
(Assoc
) = N_Function_Call
then
6560 Set_Entity
(New_N
, Entity
(Name
(Assoc
)));
6562 elsif Nkind_In
(Assoc
, N_Defining_Identifier
,
6563 N_Defining_Character_Literal
,
6564 N_Defining_Operator_Symbol
)
6565 and then Expander_Active
6567 -- Inlining case: we are copying a tree that contains
6568 -- global entities, which are preserved in the copy to be
6569 -- used for subsequent inlining.
6574 Set_Entity
(New_N
, Empty
);
6580 -- For expanded name, we must copy the Prefix and Selector_Name
6582 if Nkind
(N
) = N_Expanded_Name
then
6584 (New_N
, Copy_Generic_Node
(Prefix
(N
), New_N
, Instantiating
));
6586 Set_Selector_Name
(New_N
,
6587 Copy_Generic_Node
(Selector_Name
(N
), New_N
, Instantiating
));
6589 -- For operators, we must copy the right operand
6591 elsif Nkind
(N
) in N_Op
then
6592 Set_Right_Opnd
(New_N
,
6593 Copy_Generic_Node
(Right_Opnd
(N
), New_N
, Instantiating
));
6595 -- And for binary operators, the left operand as well
6597 if Nkind
(N
) in N_Binary_Op
then
6598 Set_Left_Opnd
(New_N
,
6599 Copy_Generic_Node
(Left_Opnd
(N
), New_N
, Instantiating
));
6603 -- Special casing for stubs
6605 elsif Nkind
(N
) in N_Body_Stub
then
6607 -- In any case, we must copy the specification or defining
6608 -- identifier as appropriate.
6610 if Nkind
(N
) = N_Subprogram_Body_Stub
then
6611 Set_Specification
(New_N
,
6612 Copy_Generic_Node
(Specification
(N
), New_N
, Instantiating
));
6615 Set_Defining_Identifier
(New_N
,
6617 (Defining_Identifier
(N
), New_N
, Instantiating
));
6620 -- If we are not instantiating, then this is where we load and
6621 -- analyze subunits, i.e. at the point where the stub occurs. A
6622 -- more permissive system might defer this analysis to the point
6623 -- of instantiation, but this seems to complicated for now.
6625 if not Instantiating
then
6627 Subunit_Name
: constant Unit_Name_Type
:= Get_Unit_Name
(N
);
6629 Unum
: Unit_Number_Type
;
6633 -- Make sure that, if it is a subunit of the main unit that is
6634 -- preprocessed and if -gnateG is specified, the preprocessed
6635 -- file will be written.
6637 Lib
.Analysing_Subunit_Of_Main
:=
6638 Lib
.In_Extended_Main_Source_Unit
(N
);
6641 (Load_Name
=> Subunit_Name
,
6645 Lib
.Analysing_Subunit_Of_Main
:= False;
6647 -- If the proper body is not found, a warning message will be
6648 -- emitted when analyzing the stub, or later at the point
6649 -- of instantiation. Here we just leave the stub as is.
6651 if Unum
= No_Unit
then
6652 Subunits_Missing
:= True;
6653 goto Subunit_Not_Found
;
6656 Subunit
:= Cunit
(Unum
);
6658 if Nkind
(Unit
(Subunit
)) /= N_Subunit
then
6660 ("found child unit instead of expected SEPARATE subunit",
6662 Error_Msg_Sloc
:= Sloc
(N
);
6663 Error_Msg_N
("\to complete stub #", Subunit
);
6664 goto Subunit_Not_Found
;
6667 -- We must create a generic copy of the subunit, in order to
6668 -- perform semantic analysis on it, and we must replace the
6669 -- stub in the original generic unit with the subunit, in order
6670 -- to preserve non-local references within.
6672 -- Only the proper body needs to be copied. Library_Unit and
6673 -- context clause are simply inherited by the generic copy.
6674 -- Note that the copy (which may be recursive if there are
6675 -- nested subunits) must be done first, before attaching it to
6676 -- the enclosing generic.
6680 (Proper_Body
(Unit
(Subunit
)),
6681 Empty
, Instantiating
=> False);
6683 -- Now place the original proper body in the original generic
6684 -- unit. This is a body, not a compilation unit.
6686 Rewrite
(N
, Proper_Body
(Unit
(Subunit
)));
6687 Set_Is_Compilation_Unit
(Defining_Entity
(N
), False);
6688 Set_Was_Originally_Stub
(N
);
6690 -- Finally replace the body of the subunit with its copy, and
6691 -- make this new subunit into the library unit of the generic
6692 -- copy, which does not have stubs any longer.
6694 Set_Proper_Body
(Unit
(Subunit
), New_Body
);
6695 Set_Library_Unit
(New_N
, Subunit
);
6696 Inherit_Context
(Unit
(Subunit
), N
);
6699 -- If we are instantiating, this must be an error case, since
6700 -- otherwise we would have replaced the stub node by the proper body
6701 -- that corresponds. So just ignore it in the copy (i.e. we have
6702 -- copied it, and that is good enough).
6708 <<Subunit_Not_Found
>> null;
6710 -- If the node is a compilation unit, it is the subunit of a stub, which
6711 -- has been loaded already (see code below). In this case, the library
6712 -- unit field of N points to the parent unit (which is a compilation
6713 -- unit) and need not (and cannot!) be copied.
6715 -- When the proper body of the stub is analyzed, the library_unit link
6716 -- is used to establish the proper context (see sem_ch10).
6718 -- The other fields of a compilation unit are copied as usual
6720 elsif Nkind
(N
) = N_Compilation_Unit
then
6722 -- This code can only be executed when not instantiating, because in
6723 -- the copy made for an instantiation, the compilation unit node has
6724 -- disappeared at the point that a stub is replaced by its proper
6727 pragma Assert
(not Instantiating
);
6729 Set_Context_Items
(New_N
,
6730 Copy_Generic_List
(Context_Items
(N
), New_N
));
6733 Copy_Generic_Node
(Unit
(N
), New_N
, False));
6735 Set_First_Inlined_Subprogram
(New_N
,
6737 (First_Inlined_Subprogram
(N
), New_N
, False));
6739 Set_Aux_Decls_Node
(New_N
,
6740 Copy_Generic_Node
(Aux_Decls_Node
(N
), New_N
, False));
6742 -- For an assignment node, the assignment is known to be semantically
6743 -- legal if we are instantiating the template. This avoids incorrect
6744 -- diagnostics in generated code.
6746 elsif Nkind
(N
) = N_Assignment_Statement
then
6748 -- Copy name and expression fields in usual manner
6751 Copy_Generic_Node
(Name
(N
), New_N
, Instantiating
));
6753 Set_Expression
(New_N
,
6754 Copy_Generic_Node
(Expression
(N
), New_N
, Instantiating
));
6756 if Instantiating
then
6757 Set_Assignment_OK
(Name
(New_N
), True);
6760 elsif Nkind_In
(N
, N_Aggregate
, N_Extension_Aggregate
) then
6761 if not Instantiating
then
6762 Set_Associated_Node
(N
, New_N
);
6765 if Present
(Get_Associated_Node
(N
))
6766 and then Nkind
(Get_Associated_Node
(N
)) = Nkind
(N
)
6768 -- In the generic the aggregate has some composite type. If at
6769 -- the point of instantiation the type has a private view,
6770 -- install the full view (and that of its ancestors, if any).
6773 T
: Entity_Id
:= (Etype
(Get_Associated_Node
(New_N
)));
6778 and then Is_Private_Type
(T
)
6784 and then Is_Tagged_Type
(T
)
6785 and then Is_Derived_Type
(T
)
6787 Rt
:= Root_Type
(T
);
6792 if Is_Private_Type
(T
) then
6803 -- Do not copy the associated node, which points to the generic copy
6804 -- of the aggregate.
6807 use Atree
.Unchecked_Access
;
6808 -- This code section is part of the implementation of an untyped
6809 -- tree traversal, so it needs direct access to node fields.
6812 Set_Field1
(New_N
, Copy_Generic_Descendant
(Field1
(N
)));
6813 Set_Field2
(New_N
, Copy_Generic_Descendant
(Field2
(N
)));
6814 Set_Field3
(New_N
, Copy_Generic_Descendant
(Field3
(N
)));
6815 Set_Field5
(New_N
, Copy_Generic_Descendant
(Field5
(N
)));
6818 -- Allocators do not have an identifier denoting the access type, so we
6819 -- must locate it through the expression to check whether the views are
6822 elsif Nkind
(N
) = N_Allocator
6823 and then Nkind
(Expression
(N
)) = N_Qualified_Expression
6824 and then Is_Entity_Name
(Subtype_Mark
(Expression
(N
)))
6825 and then Instantiating
6828 T
: constant Node_Id
:=
6829 Get_Associated_Node
(Subtype_Mark
(Expression
(N
)));
6835 -- Retrieve the allocator node in the generic copy
6837 Acc_T
:= Etype
(Parent
(Parent
(T
)));
6839 and then Is_Private_Type
(Acc_T
)
6841 Switch_View
(Acc_T
);
6848 -- For a proper body, we must catch the case of a proper body that
6849 -- replaces a stub. This represents the point at which a separate
6850 -- compilation unit, and hence template file, may be referenced, so we
6851 -- must make a new source instantiation entry for the template of the
6852 -- subunit, and ensure that all nodes in the subunit are adjusted using
6853 -- this new source instantiation entry.
6855 elsif Nkind
(N
) in N_Proper_Body
then
6857 Save_Adjustment
: constant Sloc_Adjustment
:= S_Adjustment
;
6860 if Instantiating
and then Was_Originally_Stub
(N
) then
6861 Create_Instantiation_Source
6862 (Instantiation_Node
,
6863 Defining_Entity
(N
),
6868 -- Now copy the fields of the proper body, using the new
6869 -- adjustment factor if one was needed as per test above.
6873 -- Restore the original adjustment factor in case changed
6875 S_Adjustment
:= Save_Adjustment
;
6878 -- Don't copy Ident or Comment pragmas, since the comment belongs to the
6879 -- generic unit, not to the instantiating unit.
6881 elsif Nkind
(N
) = N_Pragma
and then Instantiating
then
6883 Prag_Id
: constant Pragma_Id
:= Get_Pragma_Id
(N
);
6885 if Prag_Id
= Pragma_Ident
or else Prag_Id
= Pragma_Comment
then
6886 New_N
:= Make_Null_Statement
(Sloc
(N
));
6893 elsif Nkind_In
(N
, N_Integer_Literal
, N_Real_Literal
) then
6895 -- No descendant fields need traversing
6899 elsif Nkind
(N
) = N_String_Literal
6900 and then Present
(Etype
(N
))
6901 and then Instantiating
6903 -- If the string is declared in an outer scope, the string_literal
6904 -- subtype created for it may have the wrong scope. We force the
6905 -- reanalysis of the constant to generate a new itype in the proper
6908 Set_Etype
(New_N
, Empty
);
6909 Set_Analyzed
(New_N
, False);
6911 -- For the remaining nodes, copy their descendants recursively
6916 if Instantiating
and then Nkind
(N
) = N_Subprogram_Body
then
6917 Set_Generic_Parent
(Specification
(New_N
), N
);
6919 -- Should preserve Corresponding_Spec??? (12.3(14))
6924 end Copy_Generic_Node
;
6926 ----------------------------
6927 -- Denotes_Formal_Package --
6928 ----------------------------
6930 function Denotes_Formal_Package
6932 On_Exit
: Boolean := False;
6933 Instance
: Entity_Id
:= Empty
) return Boolean
6936 Scop
: constant Entity_Id
:= Scope
(Pack
);
6939 function Is_Actual_Of_Previous_Formal
(P
: Entity_Id
) return Boolean;
6940 -- The package in question may be an actual for a previous formal
6941 -- package P of the current instance, so examine its actuals as well.
6942 -- This must be recursive over other formal packages.
6944 ----------------------------------
6945 -- Is_Actual_Of_Previous_Formal --
6946 ----------------------------------
6948 function Is_Actual_Of_Previous_Formal
(P
: Entity_Id
) return Boolean is
6952 E1
:= First_Entity
(P
);
6953 while Present
(E1
) and then E1
/= Instance
loop
6954 if Ekind
(E1
) = E_Package
6955 and then Nkind
(Parent
(E1
)) = N_Package_Renaming_Declaration
6957 if Renamed_Object
(E1
) = Pack
then
6960 elsif E1
= P
or else Renamed_Object
(E1
) = P
then
6963 elsif Is_Actual_Of_Previous_Formal
(E1
) then
6972 end Is_Actual_Of_Previous_Formal
;
6974 -- Start of processing for Denotes_Formal_Package
6980 (Instance_Envs
.Last
).Instantiated_Parent
.Act_Id
;
6982 Par
:= Current_Instantiated_Parent
.Act_Id
;
6985 if Ekind
(Scop
) = E_Generic_Package
6986 or else Nkind
(Unit_Declaration_Node
(Scop
)) =
6987 N_Generic_Subprogram_Declaration
6991 elsif Nkind
(Original_Node
(Unit_Declaration_Node
(Pack
))) =
6992 N_Formal_Package_Declaration
7000 -- Check whether this package is associated with a formal package of
7001 -- the enclosing instantiation. Iterate over the list of renamings.
7003 E
:= First_Entity
(Par
);
7004 while Present
(E
) loop
7005 if Ekind
(E
) /= E_Package
7006 or else Nkind
(Parent
(E
)) /= N_Package_Renaming_Declaration
7010 elsif Renamed_Object
(E
) = Par
then
7013 elsif Renamed_Object
(E
) = Pack
then
7016 elsif Is_Actual_Of_Previous_Formal
(E
) then
7026 end Denotes_Formal_Package
;
7032 procedure End_Generic
is
7034 -- ??? More things could be factored out in this routine. Should
7035 -- probably be done at a later stage.
7037 Inside_A_Generic
:= Generic_Flags
.Table
(Generic_Flags
.Last
);
7038 Generic_Flags
.Decrement_Last
;
7040 Expander_Mode_Restore
;
7047 function Earlier
(N1
, N2
: Node_Id
) return Boolean is
7048 procedure Find_Depth
(P
: in out Node_Id
; D
: in out Integer);
7049 -- Find distance from given node to enclosing compilation unit
7055 procedure Find_Depth
(P
: in out Node_Id
; D
: in out Integer) is
7058 and then Nkind
(P
) /= N_Compilation_Unit
7060 P
:= True_Parent
(P
);
7065 -- Local declarations
7074 -- Start of processing for Earlier
7077 Find_Depth
(P1
, D1
);
7078 Find_Depth
(P2
, D2
);
7088 P1
:= True_Parent
(P1
);
7093 P2
:= True_Parent
(P2
);
7097 -- At this point P1 and P2 are at the same distance from the root.
7098 -- We examine their parents until we find a common declarative list.
7099 -- If we reach the root, N1 and N2 do not descend from the same
7100 -- declarative list (e.g. one is nested in the declarative part and
7101 -- the other is in a block in the statement part) and the earlier
7102 -- one is already frozen.
7104 while not Is_List_Member
(P1
)
7105 or else not Is_List_Member
(P2
)
7106 or else List_Containing
(P1
) /= List_Containing
(P2
)
7108 P1
:= True_Parent
(P1
);
7109 P2
:= True_Parent
(P2
);
7111 if Nkind
(Parent
(P1
)) = N_Subunit
then
7112 P1
:= Corresponding_Stub
(Parent
(P1
));
7115 if Nkind
(Parent
(P2
)) = N_Subunit
then
7116 P2
:= Corresponding_Stub
(Parent
(P2
));
7124 -- Expanded code usually shares the source location of the original
7125 -- construct it was generated for. This however may not necessarely
7126 -- reflect the true location of the code within the tree.
7128 -- Before comparing the slocs of the two nodes, make sure that we are
7129 -- working with correct source locations. Assume that P1 is to the left
7130 -- of P2. If either one does not come from source, traverse the common
7131 -- list heading towards the other node and locate the first source
7135 -- ----+===+===+--------------+===+===+----
7136 -- expanded code expanded code
7138 if not Comes_From_Source
(P1
) then
7139 while Present
(P1
) loop
7141 -- Neither P2 nor a source statement were located during the
7142 -- search. If we reach the end of the list, then P1 does not
7143 -- occur earlier than P2.
7146 -- start --- P2 ----- P1 --- end
7148 if No
(Next
(P1
)) then
7151 -- We encounter P2 while going to the right of the list. This
7152 -- means that P1 does indeed appear earlier.
7155 -- start --- P1 ===== P2 --- end
7156 -- expanded code in between
7161 -- No need to look any further since we have located a source
7164 elsif Comes_From_Source
(P1
) then
7174 if not Comes_From_Source
(P2
) then
7175 while Present
(P2
) loop
7177 -- Neither P1 nor a source statement were located during the
7178 -- search. If we reach the start of the list, then P1 does not
7179 -- occur earlier than P2.
7182 -- start --- P2 --- P1 --- end
7184 if No
(Prev
(P2
)) then
7187 -- We encounter P1 while going to the left of the list. This
7188 -- means that P1 does indeed appear earlier.
7191 -- start --- P1 ===== P2 --- end
7192 -- expanded code in between
7197 -- No need to look any further since we have located a source
7200 elsif Comes_From_Source
(P2
) then
7210 -- At this point either both nodes came from source or we approximated
7211 -- their source locations through neighbouring source statements.
7213 T1
:= Top_Level_Location
(Sloc
(P1
));
7214 T2
:= Top_Level_Location
(Sloc
(P2
));
7216 -- When two nodes come from the same instance, they have identical top
7217 -- level locations. To determine proper relation within the tree, check
7218 -- their locations within the template.
7221 return Sloc
(P1
) < Sloc
(P2
);
7223 -- The two nodes either come from unrelated instances or do not come
7224 -- from instantiated code at all.
7231 ----------------------
7232 -- Find_Actual_Type --
7233 ----------------------
7235 function Find_Actual_Type
7237 Gen_Type
: Entity_Id
) return Entity_Id
7239 Gen_Scope
: constant Entity_Id
:= Scope
(Gen_Type
);
7243 -- Special processing only applies to child units
7245 if not Is_Child_Unit
(Gen_Scope
) then
7246 return Get_Instance_Of
(Typ
);
7248 -- If designated or component type is itself a formal of the child unit,
7249 -- its instance is available.
7251 elsif Scope
(Typ
) = Gen_Scope
then
7252 return Get_Instance_Of
(Typ
);
7254 -- If the array or access type is not declared in the parent unit,
7255 -- no special processing needed.
7257 elsif not Is_Generic_Type
(Typ
)
7258 and then Scope
(Gen_Scope
) /= Scope
(Typ
)
7260 return Get_Instance_Of
(Typ
);
7262 -- Otherwise, retrieve designated or component type by visibility
7265 T
:= Current_Entity
(Typ
);
7266 while Present
(T
) loop
7267 if In_Open_Scopes
(Scope
(T
)) then
7270 elsif Is_Generic_Actual_Type
(T
) then
7279 end Find_Actual_Type
;
7281 ----------------------------
7282 -- Freeze_Subprogram_Body --
7283 ----------------------------
7285 procedure Freeze_Subprogram_Body
7286 (Inst_Node
: Node_Id
;
7288 Pack_Id
: Entity_Id
)
7290 Gen_Unit
: constant Entity_Id
:= Get_Generic_Entity
(Inst_Node
);
7291 Par
: constant Entity_Id
:= Scope
(Gen_Unit
);
7297 function Enclosing_Package_Body
(N
: Node_Id
) return Node_Id
;
7298 -- Find innermost package body that encloses the given node, and which
7299 -- is not a compilation unit. Freeze nodes for the instance, or for its
7300 -- enclosing body, may be inserted after the enclosing_body of the
7301 -- generic unit. Used to determine proper placement of freeze node for
7302 -- both package and subprogram instances.
7304 function Package_Freeze_Node
(B
: Node_Id
) return Node_Id
;
7305 -- Find entity for given package body, and locate or create a freeze
7308 ----------------------------
7309 -- Enclosing_Package_Body --
7310 ----------------------------
7312 function Enclosing_Package_Body
(N
: Node_Id
) return Node_Id
is
7318 and then Nkind
(Parent
(P
)) /= N_Compilation_Unit
7320 if Nkind
(P
) = N_Package_Body
then
7321 if Nkind
(Parent
(P
)) = N_Subunit
then
7322 return Corresponding_Stub
(Parent
(P
));
7328 P
:= True_Parent
(P
);
7332 end Enclosing_Package_Body
;
7334 -------------------------
7335 -- Package_Freeze_Node --
7336 -------------------------
7338 function Package_Freeze_Node
(B
: Node_Id
) return Node_Id
is
7342 if Nkind
(B
) = N_Package_Body
then
7343 Id
:= Corresponding_Spec
(B
);
7344 else pragma Assert
(Nkind
(B
) = N_Package_Body_Stub
);
7345 Id
:= Corresponding_Spec
(Proper_Body
(Unit
(Library_Unit
(B
))));
7348 Ensure_Freeze_Node
(Id
);
7349 return Freeze_Node
(Id
);
7350 end Package_Freeze_Node
;
7352 -- Start of processing of Freeze_Subprogram_Body
7355 -- If the instance and the generic body appear within the same unit, and
7356 -- the instance precedes the generic, the freeze node for the instance
7357 -- must appear after that of the generic. If the generic is nested
7358 -- within another instance I2, then current instance must be frozen
7359 -- after I2. In both cases, the freeze nodes are those of enclosing
7360 -- packages. Otherwise, the freeze node is placed at the end of the
7361 -- current declarative part.
7363 Enc_G
:= Enclosing_Package_Body
(Gen_Body
);
7364 Enc_I
:= Enclosing_Package_Body
(Inst_Node
);
7365 Ensure_Freeze_Node
(Pack_Id
);
7366 F_Node
:= Freeze_Node
(Pack_Id
);
7368 if Is_Generic_Instance
(Par
)
7369 and then Present
(Freeze_Node
(Par
))
7370 and then In_Same_Declarative_Part
(Freeze_Node
(Par
), Inst_Node
)
7372 -- The parent was a premature instantiation. Insert freeze node at
7373 -- the end the current declarative part.
7375 if ABE_Is_Certain
(Get_Package_Instantiation_Node
(Par
)) then
7376 Insert_Freeze_Node_For_Instance
(Inst_Node
, F_Node
);
7378 -- Handle the following case:
7380 -- package Parent_Inst is new ...
7383 -- procedure P ... -- this body freezes Parent_Inst
7385 -- package Inst is new ...
7387 -- In this particular scenario, the freeze node for Inst must be
7388 -- inserted in the same manner as that of Parent_Inst - before the
7389 -- next source body or at the end of the declarative list (body not
7390 -- available). If body P did not exist and Parent_Inst was frozen
7391 -- after Inst, either by a body following Inst or at the end of the
7392 -- declarative region, the freeze node for Inst must be inserted
7393 -- after that of Parent_Inst. This relation is established by
7394 -- comparing the Slocs of Parent_Inst freeze node and Inst.
7396 elsif List_Containing
(Get_Package_Instantiation_Node
(Par
)) =
7397 List_Containing
(Inst_Node
)
7398 and then Sloc
(Freeze_Node
(Par
)) < Sloc
(Inst_Node
)
7400 Insert_Freeze_Node_For_Instance
(Inst_Node
, F_Node
);
7403 Insert_After
(Freeze_Node
(Par
), F_Node
);
7406 -- The body enclosing the instance should be frozen after the body that
7407 -- includes the generic, because the body of the instance may make
7408 -- references to entities therein. If the two are not in the same
7409 -- declarative part, or if the one enclosing the instance is frozen
7410 -- already, freeze the instance at the end of the current declarative
7413 elsif Is_Generic_Instance
(Par
)
7414 and then Present
(Freeze_Node
(Par
))
7415 and then Present
(Enc_I
)
7417 if In_Same_Declarative_Part
(Freeze_Node
(Par
), Enc_I
)
7419 (Nkind
(Enc_I
) = N_Package_Body
7421 In_Same_Declarative_Part
(Freeze_Node
(Par
), Parent
(Enc_I
)))
7423 -- The enclosing package may contain several instances. Rather
7424 -- than computing the earliest point at which to insert its freeze
7425 -- node, we place it at the end of the declarative part of the
7426 -- parent of the generic.
7428 Insert_Freeze_Node_For_Instance
7429 (Freeze_Node
(Par
), Package_Freeze_Node
(Enc_I
));
7432 Insert_Freeze_Node_For_Instance
(Inst_Node
, F_Node
);
7434 elsif Present
(Enc_G
)
7435 and then Present
(Enc_I
)
7436 and then Enc_G
/= Enc_I
7437 and then Earlier
(Inst_Node
, Gen_Body
)
7439 if Nkind
(Enc_G
) = N_Package_Body
then
7440 E_G_Id
:= Corresponding_Spec
(Enc_G
);
7441 else pragma Assert
(Nkind
(Enc_G
) = N_Package_Body_Stub
);
7443 Corresponding_Spec
(Proper_Body
(Unit
(Library_Unit
(Enc_G
))));
7446 -- Freeze package that encloses instance, and place node after
7447 -- package that encloses generic. If enclosing package is already
7448 -- frozen we have to assume it is at the proper place. This may be a
7449 -- potential ABE that requires dynamic checking. Do not add a freeze
7450 -- node if the package that encloses the generic is inside the body
7451 -- that encloses the instance, because the freeze node would be in
7452 -- the wrong scope. Additional contortions needed if the bodies are
7453 -- within a subunit.
7456 Enclosing_Body
: Node_Id
;
7459 if Nkind
(Enc_I
) = N_Package_Body_Stub
then
7460 Enclosing_Body
:= Proper_Body
(Unit
(Library_Unit
(Enc_I
)));
7462 Enclosing_Body
:= Enc_I
;
7465 if Parent
(List_Containing
(Enc_G
)) /= Enclosing_Body
then
7466 Insert_Freeze_Node_For_Instance
7467 (Enc_G
, Package_Freeze_Node
(Enc_I
));
7471 -- Freeze enclosing subunit before instance
7473 Ensure_Freeze_Node
(E_G_Id
);
7475 if not Is_List_Member
(Freeze_Node
(E_G_Id
)) then
7476 Insert_After
(Enc_G
, Freeze_Node
(E_G_Id
));
7479 Insert_Freeze_Node_For_Instance
(Inst_Node
, F_Node
);
7482 -- If none of the above, insert freeze node at the end of the current
7483 -- declarative part.
7485 Insert_Freeze_Node_For_Instance
(Inst_Node
, F_Node
);
7487 end Freeze_Subprogram_Body
;
7493 function Get_Gen_Id
(E
: Assoc_Ptr
) return Entity_Id
is
7495 return Generic_Renamings
.Table
(E
).Gen_Id
;
7498 ---------------------
7499 -- Get_Instance_Of --
7500 ---------------------
7502 function Get_Instance_Of
(A
: Entity_Id
) return Entity_Id
is
7503 Res
: constant Assoc_Ptr
:= Generic_Renamings_HTable
.Get
(A
);
7506 if Res
/= Assoc_Null
then
7507 return Generic_Renamings
.Table
(Res
).Act_Id
;
7509 -- On exit, entity is not instantiated: not a generic parameter, or
7510 -- else parameter of an inner generic unit.
7514 end Get_Instance_Of
;
7516 ------------------------------------
7517 -- Get_Package_Instantiation_Node --
7518 ------------------------------------
7520 function Get_Package_Instantiation_Node
(A
: Entity_Id
) return Node_Id
is
7521 Decl
: Node_Id
:= Unit_Declaration_Node
(A
);
7525 -- If the Package_Instantiation attribute has been set on the package
7526 -- entity, then use it directly when it (or its Original_Node) refers
7527 -- to an N_Package_Instantiation node. In principle it should be
7528 -- possible to have this field set in all cases, which should be
7529 -- investigated, and would allow this function to be significantly
7532 Inst
:= Package_Instantiation
(A
);
7534 if Present
(Inst
) then
7535 if Nkind
(Inst
) = N_Package_Instantiation
then
7538 elsif Nkind
(Original_Node
(Inst
)) = N_Package_Instantiation
then
7539 return Original_Node
(Inst
);
7543 -- If the instantiation is a compilation unit that does not need body
7544 -- then the instantiation node has been rewritten as a package
7545 -- declaration for the instance, and we return the original node.
7547 -- If it is a compilation unit and the instance node has not been
7548 -- rewritten, then it is still the unit of the compilation. Finally, if
7549 -- a body is present, this is a parent of the main unit whose body has
7550 -- been compiled for inlining purposes, and the instantiation node has
7551 -- been rewritten with the instance body.
7553 -- Otherwise the instantiation node appears after the declaration. If
7554 -- the entity is a formal package, the declaration may have been
7555 -- rewritten as a generic declaration (in the case of a formal with box)
7556 -- or left as a formal package declaration if it has actuals, and is
7557 -- found with a forward search.
7559 if Nkind
(Parent
(Decl
)) = N_Compilation_Unit
then
7560 if Nkind
(Decl
) = N_Package_Declaration
7561 and then Present
(Corresponding_Body
(Decl
))
7563 Decl
:= Unit_Declaration_Node
(Corresponding_Body
(Decl
));
7566 if Nkind
(Original_Node
(Decl
)) = N_Package_Instantiation
then
7567 return Original_Node
(Decl
);
7569 return Unit
(Parent
(Decl
));
7572 elsif Nkind
(Decl
) = N_Package_Declaration
7573 and then Nkind
(Original_Node
(Decl
)) = N_Formal_Package_Declaration
7575 return Original_Node
(Decl
);
7578 Inst
:= Next
(Decl
);
7579 while not Nkind_In
(Inst
, N_Package_Instantiation
,
7580 N_Formal_Package_Declaration
)
7587 end Get_Package_Instantiation_Node
;
7589 ------------------------
7590 -- Has_Been_Exchanged --
7591 ------------------------
7593 function Has_Been_Exchanged
(E
: Entity_Id
) return Boolean is
7597 Next
:= First_Elmt
(Exchanged_Views
);
7598 while Present
(Next
) loop
7599 if Full_View
(Node
(Next
)) = E
then
7607 end Has_Been_Exchanged
;
7613 function Hash
(F
: Entity_Id
) return HTable_Range
is
7615 return HTable_Range
(F
mod HTable_Size
);
7618 ------------------------
7619 -- Hide_Current_Scope --
7620 ------------------------
7622 procedure Hide_Current_Scope
is
7623 C
: constant Entity_Id
:= Current_Scope
;
7627 Set_Is_Hidden_Open_Scope
(C
);
7629 E
:= First_Entity
(C
);
7630 while Present
(E
) loop
7631 if Is_Immediately_Visible
(E
) then
7632 Set_Is_Immediately_Visible
(E
, False);
7633 Append_Elmt
(E
, Hidden_Entities
);
7639 -- Make the scope name invisible as well. This is necessary, but might
7640 -- conflict with calls to Rtsfind later on, in case the scope is a
7641 -- predefined one. There is no clean solution to this problem, so for
7642 -- now we depend on the user not redefining Standard itself in one of
7643 -- the parent units.
7645 if Is_Immediately_Visible
(C
) and then C
/= Standard_Standard
then
7646 Set_Is_Immediately_Visible
(C
, False);
7647 Append_Elmt
(C
, Hidden_Entities
);
7650 end Hide_Current_Scope
;
7656 procedure Init_Env
is
7657 Saved
: Instance_Env
;
7660 Saved
.Instantiated_Parent
:= Current_Instantiated_Parent
;
7661 Saved
.Exchanged_Views
:= Exchanged_Views
;
7662 Saved
.Hidden_Entities
:= Hidden_Entities
;
7663 Saved
.Current_Sem_Unit
:= Current_Sem_Unit
;
7664 Saved
.Parent_Unit_Visible
:= Parent_Unit_Visible
;
7665 Saved
.Instance_Parent_Unit
:= Instance_Parent_Unit
;
7667 -- Save configuration switches. These may be reset if the unit is a
7668 -- predefined unit, and the current mode is not Ada 2005.
7670 Save_Opt_Config_Switches
(Saved
.Switches
);
7672 Instance_Envs
.Append
(Saved
);
7674 Exchanged_Views
:= New_Elmt_List
;
7675 Hidden_Entities
:= New_Elmt_List
;
7677 -- Make dummy entry for Instantiated parent. If generic unit is legal,
7678 -- this is set properly in Set_Instance_Env.
7680 Current_Instantiated_Parent
:=
7681 (Current_Scope
, Current_Scope
, Assoc_Null
);
7684 ------------------------------
7685 -- In_Same_Declarative_Part --
7686 ------------------------------
7688 function In_Same_Declarative_Part
7690 Inst
: Node_Id
) return Boolean
7692 Decls
: constant Node_Id
:= Parent
(F_Node
);
7693 Nod
: Node_Id
:= Parent
(Inst
);
7696 while Present
(Nod
) loop
7700 elsif Nkind_In
(Nod
, N_Subprogram_Body
,
7702 N_Package_Declaration
,
7709 elsif Nkind
(Nod
) = N_Subunit
then
7710 Nod
:= Corresponding_Stub
(Nod
);
7712 elsif Nkind
(Nod
) = N_Compilation_Unit
then
7716 Nod
:= Parent
(Nod
);
7721 end In_Same_Declarative_Part
;
7723 ---------------------
7724 -- In_Main_Context --
7725 ---------------------
7727 function In_Main_Context
(E
: Entity_Id
) return Boolean is
7733 if not Is_Compilation_Unit
(E
)
7734 or else Ekind
(E
) /= E_Package
7735 or else In_Private_Part
(E
)
7740 Context
:= Context_Items
(Cunit
(Main_Unit
));
7742 Clause
:= First
(Context
);
7743 while Present
(Clause
) loop
7744 if Nkind
(Clause
) = N_With_Clause
then
7745 Nam
:= Name
(Clause
);
7747 -- If the current scope is part of the context of the main unit,
7748 -- analysis of the corresponding with_clause is not complete, and
7749 -- the entity is not set. We use the Chars field directly, which
7750 -- might produce false positives in rare cases, but guarantees
7751 -- that we produce all the instance bodies we will need.
7753 if (Is_Entity_Name
(Nam
) and then Chars
(Nam
) = Chars
(E
))
7754 or else (Nkind
(Nam
) = N_Selected_Component
7755 and then Chars
(Selector_Name
(Nam
)) = Chars
(E
))
7765 end In_Main_Context
;
7767 ---------------------
7768 -- Inherit_Context --
7769 ---------------------
7771 procedure Inherit_Context
(Gen_Decl
: Node_Id
; Inst
: Node_Id
) is
7772 Current_Context
: List_Id
;
7773 Current_Unit
: Node_Id
;
7782 if Nkind
(Parent
(Gen_Decl
)) = N_Compilation_Unit
then
7784 -- The inherited context is attached to the enclosing compilation
7785 -- unit. This is either the main unit, or the declaration for the
7786 -- main unit (in case the instantiation appears within the package
7787 -- declaration and the main unit is its body).
7789 Current_Unit
:= Parent
(Inst
);
7790 while Present
(Current_Unit
)
7791 and then Nkind
(Current_Unit
) /= N_Compilation_Unit
7793 Current_Unit
:= Parent
(Current_Unit
);
7796 Current_Context
:= Context_Items
(Current_Unit
);
7798 Item
:= First
(Context_Items
(Parent
(Gen_Decl
)));
7799 while Present
(Item
) loop
7800 if Nkind
(Item
) = N_With_Clause
then
7801 Lib_Unit
:= Library_Unit
(Item
);
7803 -- Take care to prevent direct cyclic with's
7805 if Lib_Unit
/= Current_Unit
then
7807 -- Do not add a unit if it is already in the context
7809 Clause
:= First
(Current_Context
);
7811 while Present
(Clause
) loop
7812 if Nkind
(Clause
) = N_With_Clause
and then
7813 Library_Unit
(Clause
) = Lib_Unit
7823 New_I
:= New_Copy
(Item
);
7824 Set_Implicit_With
(New_I
, True);
7825 Set_Implicit_With_From_Instantiation
(New_I
, True);
7826 Append
(New_I
, Current_Context
);
7834 end Inherit_Context
;
7840 procedure Initialize
is
7842 Generic_Renamings
.Init
;
7845 Generic_Renamings_HTable
.Reset
;
7846 Circularity_Detected
:= False;
7847 Exchanged_Views
:= No_Elist
;
7848 Hidden_Entities
:= No_Elist
;
7851 -------------------------------------
7852 -- Insert_Freeze_Node_For_Instance --
7853 -------------------------------------
7855 procedure Insert_Freeze_Node_For_Instance
7864 function Enclosing_Body
(N
: Node_Id
) return Node_Id
;
7865 -- Find enclosing package or subprogram body, if any. Freeze node
7866 -- may be placed at end of current declarative list if previous
7867 -- instance and current one have different enclosing bodies.
7869 function Previous_Instance
(Gen
: Entity_Id
) return Entity_Id
;
7870 -- Find the local instance, if any, that declares the generic that is
7871 -- being instantiated. If present, the freeze node for this instance
7872 -- must follow the freeze node for the previous instance.
7874 --------------------
7875 -- Enclosing_Body --
7876 --------------------
7878 function Enclosing_Body
(N
: Node_Id
) return Node_Id
is
7884 and then Nkind
(Parent
(P
)) /= N_Compilation_Unit
7886 if Nkind_In
(P
, N_Package_Body
, N_Subprogram_Body
) then
7887 if Nkind
(Parent
(P
)) = N_Subunit
then
7888 return Corresponding_Stub
(Parent
(P
));
7894 P
:= True_Parent
(P
);
7900 -----------------------
7901 -- Previous_Instance --
7902 -----------------------
7904 function Previous_Instance
(Gen
: Entity_Id
) return Entity_Id
is
7910 and then S
/= Standard_Standard
7912 if Is_Generic_Instance
(S
)
7913 and then In_Same_Source_Unit
(S
, N
)
7922 end Previous_Instance
;
7924 -- Start of processing for Insert_Freeze_Node_For_Instance
7927 if not Is_List_Member
(F_Node
) then
7929 Decls
:= List_Containing
(N
);
7930 Inst
:= Entity
(F_Node
);
7931 Par_N
:= Parent
(Decls
);
7933 -- When processing a subprogram instantiation, utilize the actual
7934 -- subprogram instantiation rather than its package wrapper as it
7935 -- carries all the context information.
7937 if Is_Wrapper_Package
(Inst
) then
7938 Inst
:= Related_Instance
(Inst
);
7941 -- If this is a package instance, check whether the generic is
7942 -- declared in a previous instance and the current instance is
7943 -- not within the previous one.
7945 if Present
(Generic_Parent
(Parent
(Inst
)))
7946 and then Is_In_Main_Unit
(N
)
7949 Enclosing_N
: constant Node_Id
:= Enclosing_Body
(N
);
7950 Par_I
: constant Entity_Id
:=
7952 (Generic_Parent
(Parent
(Inst
)));
7957 and then Earlier
(N
, Freeze_Node
(Par_I
))
7959 Scop
:= Scope
(Inst
);
7961 -- If the current instance is within the one that contains
7962 -- the generic, the freeze node for the current one must
7963 -- appear in the current declarative part. Ditto, if the
7964 -- current instance is within another package instance or
7965 -- within a body that does not enclose the current instance.
7966 -- In these three cases the freeze node of the previous
7967 -- instance is not relevant.
7969 while Present
(Scop
)
7970 and then Scop
/= Standard_Standard
7972 exit when Scop
= Par_I
7974 (Is_Generic_Instance
(Scop
)
7975 and then Scope_Depth
(Scop
) > Scope_Depth
(Par_I
));
7976 Scop
:= Scope
(Scop
);
7979 -- Previous instance encloses current instance
7981 if Scop
= Par_I
then
7984 -- If the next node is a source body we must freeze in
7985 -- the current scope as well.
7987 elsif Present
(Next
(N
))
7988 and then Nkind_In
(Next
(N
),
7989 N_Subprogram_Body
, N_Package_Body
)
7990 and then Comes_From_Source
(Next
(N
))
7994 -- Current instance is within an unrelated instance
7996 elsif Is_Generic_Instance
(Scop
) then
7999 -- Current instance is within an unrelated body
8001 elsif Present
(Enclosing_N
)
8002 and then Enclosing_N
/= Enclosing_Body
(Par_I
)
8007 Insert_After
(Freeze_Node
(Par_I
), F_Node
);
8014 -- When the instantiation occurs in a package declaration, append the
8015 -- freeze node to the private declarations (if any).
8017 if Nkind
(Par_N
) = N_Package_Specification
8018 and then Decls
= Visible_Declarations
(Par_N
)
8019 and then Present
(Private_Declarations
(Par_N
))
8020 and then not Is_Empty_List
(Private_Declarations
(Par_N
))
8022 Decls
:= Private_Declarations
(Par_N
);
8023 Decl
:= First
(Decls
);
8026 -- Determine the proper freeze point of a package instantiation. We
8027 -- adhere to the general rule of a package or subprogram body causing
8028 -- freezing of anything before it in the same declarative region. In
8029 -- this case, the proper freeze point of a package instantiation is
8030 -- before the first source body which follows, or before a stub. This
8031 -- ensures that entities coming from the instance are already frozen
8032 -- and usable in source bodies.
8034 if Nkind
(Par_N
) /= N_Package_Declaration
8035 and then Ekind
(Inst
) = E_Package
8036 and then Is_Generic_Instance
(Inst
)
8038 not In_Same_Source_Unit
(Generic_Parent
(Parent
(Inst
)), Inst
)
8040 while Present
(Decl
) loop
8041 if (Nkind
(Decl
) in N_Unit_Body
8043 Nkind
(Decl
) in N_Body_Stub
)
8044 and then Comes_From_Source
(Decl
)
8046 Insert_Before
(Decl
, F_Node
);
8054 -- In a package declaration, or if no previous body, insert at end
8057 Set_Sloc
(F_Node
, Sloc
(Last
(Decls
)));
8058 Insert_After
(Last
(Decls
), F_Node
);
8060 end Insert_Freeze_Node_For_Instance
;
8066 procedure Install_Body
8067 (Act_Body
: Node_Id
;
8072 Act_Id
: constant Entity_Id
:= Corresponding_Spec
(Act_Body
);
8073 Act_Unit
: constant Node_Id
:= Unit
(Cunit
(Get_Source_Unit
(N
)));
8074 Gen_Id
: constant Entity_Id
:= Corresponding_Spec
(Gen_Body
);
8075 Par
: constant Entity_Id
:= Scope
(Gen_Id
);
8076 Gen_Unit
: constant Node_Id
:=
8077 Unit
(Cunit
(Get_Source_Unit
(Gen_Decl
)));
8078 Orig_Body
: Node_Id
:= Gen_Body
;
8080 Body_Unit
: Node_Id
;
8082 Must_Delay
: Boolean;
8084 function Enclosing_Subp
(Id
: Entity_Id
) return Entity_Id
;
8085 -- Find subprogram (if any) that encloses instance and/or generic body
8087 function True_Sloc
(N
: Node_Id
) return Source_Ptr
;
8088 -- If the instance is nested inside a generic unit, the Sloc of the
8089 -- instance indicates the place of the original definition, not the
8090 -- point of the current enclosing instance. Pending a better usage of
8091 -- Slocs to indicate instantiation places, we determine the place of
8092 -- origin of a node by finding the maximum sloc of any ancestor node.
8093 -- Why is this not equivalent to Top_Level_Location ???
8095 --------------------
8096 -- Enclosing_Subp --
8097 --------------------
8099 function Enclosing_Subp
(Id
: Entity_Id
) return Entity_Id
is
8104 while Scop
/= Standard_Standard
8105 and then not Is_Overloadable
(Scop
)
8107 Scop
:= Scope
(Scop
);
8117 function True_Sloc
(N
: Node_Id
) return Source_Ptr
is
8124 while Present
(N1
) and then N1
/= Act_Unit
loop
8125 if Sloc
(N1
) > Res
then
8135 -- Start of processing for Install_Body
8138 -- If the body is a subunit, the freeze point is the corresponding stub
8139 -- in the current compilation, not the subunit itself.
8141 if Nkind
(Parent
(Gen_Body
)) = N_Subunit
then
8142 Orig_Body
:= Corresponding_Stub
(Parent
(Gen_Body
));
8144 Orig_Body
:= Gen_Body
;
8147 Body_Unit
:= Unit
(Cunit
(Get_Source_Unit
(Orig_Body
)));
8149 -- If the instantiation and the generic definition appear in the same
8150 -- package declaration, this is an early instantiation. If they appear
8151 -- in the same declarative part, it is an early instantiation only if
8152 -- the generic body appears textually later, and the generic body is
8153 -- also in the main unit.
8155 -- If instance is nested within a subprogram, and the generic body is
8156 -- not, the instance is delayed because the enclosing body is. If
8157 -- instance and body are within the same scope, or the same sub-
8158 -- program body, indicate explicitly that the instance is delayed.
8161 (Gen_Unit
= Act_Unit
8162 and then (Nkind_In
(Gen_Unit
, N_Package_Declaration
,
8163 N_Generic_Package_Declaration
)
8164 or else (Gen_Unit
= Body_Unit
8165 and then True_Sloc
(N
) < Sloc
(Orig_Body
)))
8166 and then Is_In_Main_Unit
(Gen_Unit
)
8167 and then (Scope
(Act_Id
) = Scope
(Gen_Id
)
8169 Enclosing_Subp
(Act_Id
) = Enclosing_Subp
(Gen_Id
)));
8171 -- If this is an early instantiation, the freeze node is placed after
8172 -- the generic body. Otherwise, if the generic appears in an instance,
8173 -- we cannot freeze the current instance until the outer one is frozen.
8174 -- This is only relevant if the current instance is nested within some
8175 -- inner scope not itself within the outer instance. If this scope is
8176 -- a package body in the same declarative part as the outer instance,
8177 -- then that body needs to be frozen after the outer instance. Finally,
8178 -- if no delay is needed, we place the freeze node at the end of the
8179 -- current declarative part.
8181 if Expander_Active
then
8182 Ensure_Freeze_Node
(Act_Id
);
8183 F_Node
:= Freeze_Node
(Act_Id
);
8186 Insert_After
(Orig_Body
, F_Node
);
8188 elsif Is_Generic_Instance
(Par
)
8189 and then Present
(Freeze_Node
(Par
))
8190 and then Scope
(Act_Id
) /= Par
8192 -- Freeze instance of inner generic after instance of enclosing
8195 if In_Same_Declarative_Part
(Freeze_Node
(Par
), N
) then
8197 -- Handle the following case:
8199 -- package Parent_Inst is new ...
8202 -- procedure P ... -- this body freezes Parent_Inst
8204 -- package Inst is new ...
8206 -- In this particular scenario, the freeze node for Inst must
8207 -- be inserted in the same manner as that of Parent_Inst -
8208 -- before the next source body or at the end of the declarative
8209 -- list (body not available). If body P did not exist and
8210 -- Parent_Inst was frozen after Inst, either by a body
8211 -- following Inst or at the end of the declarative region, the
8212 -- freeze node for Inst must be inserted after that of
8213 -- Parent_Inst. This relation is established by comparing the
8214 -- Slocs of Parent_Inst freeze node and Inst.
8216 if List_Containing
(Get_Package_Instantiation_Node
(Par
)) =
8218 and then Sloc
(Freeze_Node
(Par
)) < Sloc
(N
)
8220 Insert_Freeze_Node_For_Instance
(N
, F_Node
);
8222 Insert_After
(Freeze_Node
(Par
), F_Node
);
8225 -- Freeze package enclosing instance of inner generic after
8226 -- instance of enclosing generic.
8228 elsif Nkind_In
(Parent
(N
), N_Package_Body
, N_Subprogram_Body
)
8229 and then In_Same_Declarative_Part
(Freeze_Node
(Par
), Parent
(N
))
8232 Enclosing
: Entity_Id
;
8235 Enclosing
:= Corresponding_Spec
(Parent
(N
));
8237 if No
(Enclosing
) then
8238 Enclosing
:= Defining_Entity
(Parent
(N
));
8241 Insert_Freeze_Node_For_Instance
(N
, F_Node
);
8242 Ensure_Freeze_Node
(Enclosing
);
8244 if not Is_List_Member
(Freeze_Node
(Enclosing
)) then
8246 -- The enclosing context is a subunit, insert the freeze
8247 -- node after the stub.
8249 if Nkind
(Parent
(Parent
(N
))) = N_Subunit
then
8250 Insert_Freeze_Node_For_Instance
8251 (Corresponding_Stub
(Parent
(Parent
(N
))),
8252 Freeze_Node
(Enclosing
));
8254 -- The enclosing context is a package with a stub body
8255 -- which has already been replaced by the real body.
8256 -- Insert the freeze node after the actual body.
8258 elsif Ekind
(Enclosing
) = E_Package
8259 and then Present
(Body_Entity
(Enclosing
))
8260 and then Was_Originally_Stub
8261 (Parent
(Body_Entity
(Enclosing
)))
8263 Insert_Freeze_Node_For_Instance
8264 (Parent
(Body_Entity
(Enclosing
)),
8265 Freeze_Node
(Enclosing
));
8267 -- The parent instance has been frozen before the body of
8268 -- the enclosing package, insert the freeze node after
8271 elsif List_Containing
(Freeze_Node
(Par
)) =
8272 List_Containing
(Parent
(N
))
8273 and then Sloc
(Freeze_Node
(Par
)) < Sloc
(Parent
(N
))
8275 Insert_Freeze_Node_For_Instance
8276 (Parent
(N
), Freeze_Node
(Enclosing
));
8280 (Freeze_Node
(Par
), Freeze_Node
(Enclosing
));
8286 Insert_Freeze_Node_For_Instance
(N
, F_Node
);
8290 Insert_Freeze_Node_For_Instance
(N
, F_Node
);
8294 Set_Is_Frozen
(Act_Id
);
8295 Insert_Before
(N
, Act_Body
);
8296 Mark_Rewrite_Insertion
(Act_Body
);
8299 -----------------------------
8300 -- Install_Formal_Packages --
8301 -----------------------------
8303 procedure Install_Formal_Packages
(Par
: Entity_Id
) is
8306 Gen_E
: Entity_Id
:= Empty
;
8309 E
:= First_Entity
(Par
);
8311 -- If we are installing an instance parent, locate the formal packages
8312 -- of its generic parent.
8314 if Is_Generic_Instance
(Par
) then
8315 Gen
:= Generic_Parent
(Specification
(Unit_Declaration_Node
(Par
)));
8316 Gen_E
:= First_Entity
(Gen
);
8319 while Present
(E
) loop
8320 if Ekind
(E
) = E_Package
8321 and then Nkind
(Parent
(E
)) = N_Package_Renaming_Declaration
8323 -- If this is the renaming for the parent instance, done
8325 if Renamed_Object
(E
) = Par
then
8328 -- The visibility of a formal of an enclosing generic is already
8331 elsif Denotes_Formal_Package
(E
) then
8334 elsif Present
(Associated_Formal_Package
(E
)) then
8335 Check_Generic_Actuals
(Renamed_Object
(E
), True);
8336 Set_Is_Hidden
(E
, False);
8338 -- Find formal package in generic unit that corresponds to
8339 -- (instance of) formal package in instance.
8341 while Present
(Gen_E
) and then Chars
(Gen_E
) /= Chars
(E
) loop
8342 Next_Entity
(Gen_E
);
8345 if Present
(Gen_E
) then
8346 Map_Formal_Package_Entities
(Gen_E
, E
);
8352 if Present
(Gen_E
) then
8353 Next_Entity
(Gen_E
);
8356 end Install_Formal_Packages
;
8358 --------------------
8359 -- Install_Parent --
8360 --------------------
8362 procedure Install_Parent
(P
: Entity_Id
; In_Body
: Boolean := False) is
8363 Ancestors
: constant Elist_Id
:= New_Elmt_List
;
8364 S
: constant Entity_Id
:= Current_Scope
;
8365 Inst_Par
: Entity_Id
;
8366 First_Par
: Entity_Id
;
8367 Inst_Node
: Node_Id
;
8368 Gen_Par
: Entity_Id
;
8369 First_Gen
: Entity_Id
;
8372 procedure Install_Noninstance_Specs
(Par
: Entity_Id
);
8373 -- Install the scopes of noninstance parent units ending with Par
8375 procedure Install_Spec
(Par
: Entity_Id
);
8376 -- The child unit is within the declarative part of the parent, so
8377 -- the declarations within the parent are immediately visible.
8379 -------------------------------
8380 -- Install_Noninstance_Specs --
8381 -------------------------------
8383 procedure Install_Noninstance_Specs
(Par
: Entity_Id
) is
8386 and then Par
/= Standard_Standard
8387 and then not In_Open_Scopes
(Par
)
8389 Install_Noninstance_Specs
(Scope
(Par
));
8392 end Install_Noninstance_Specs
;
8398 procedure Install_Spec
(Par
: Entity_Id
) is
8399 Spec
: constant Node_Id
:=
8400 Specification
(Unit_Declaration_Node
(Par
));
8403 -- If this parent of the child instance is a top-level unit,
8404 -- then record the unit and its visibility for later resetting
8405 -- in Remove_Parent. We exclude units that are generic instances,
8406 -- as we only want to record this information for the ultimate
8407 -- top-level noninstance parent (is that always correct???).
8409 if Scope
(Par
) = Standard_Standard
8410 and then not Is_Generic_Instance
(Par
)
8412 Parent_Unit_Visible
:= Is_Immediately_Visible
(Par
);
8413 Instance_Parent_Unit
:= Par
;
8416 -- Open the parent scope and make it and its declarations visible.
8417 -- If this point is not within a body, then only the visible
8418 -- declarations should be made visible, and installation of the
8419 -- private declarations is deferred until the appropriate point
8420 -- within analysis of the spec being instantiated (see the handling
8421 -- of parent visibility in Analyze_Package_Specification). This is
8422 -- relaxed in the case where the parent unit is Ada.Tags, to avoid
8423 -- private view problems that occur when compiling instantiations of
8424 -- a generic child of that package (Generic_Dispatching_Constructor).
8425 -- If the instance freezes a tagged type, inlinings of operations
8426 -- from Ada.Tags may need the full view of type Tag. If inlining took
8427 -- proper account of establishing visibility of inlined subprograms'
8428 -- parents then it should be possible to remove this
8429 -- special check. ???
8432 Set_Is_Immediately_Visible
(Par
);
8433 Install_Visible_Declarations
(Par
);
8434 Set_Use
(Visible_Declarations
(Spec
));
8436 if In_Body
or else Is_RTU
(Par
, Ada_Tags
) then
8437 Install_Private_Declarations
(Par
);
8438 Set_Use
(Private_Declarations
(Spec
));
8442 -- Start of processing for Install_Parent
8445 -- We need to install the parent instance to compile the instantiation
8446 -- of the child, but the child instance must appear in the current
8447 -- scope. Given that we cannot place the parent above the current scope
8448 -- in the scope stack, we duplicate the current scope and unstack both
8449 -- after the instantiation is complete.
8451 -- If the parent is itself the instantiation of a child unit, we must
8452 -- also stack the instantiation of its parent, and so on. Each such
8453 -- ancestor is the prefix of the name in a prior instantiation.
8455 -- If this is a nested instance, the parent unit itself resolves to
8456 -- a renaming of the parent instance, whose declaration we need.
8458 -- Finally, the parent may be a generic (not an instance) when the
8459 -- child unit appears as a formal package.
8463 if Present
(Renamed_Entity
(Inst_Par
)) then
8464 Inst_Par
:= Renamed_Entity
(Inst_Par
);
8467 First_Par
:= Inst_Par
;
8470 Generic_Parent
(Specification
(Unit_Declaration_Node
(Inst_Par
)));
8472 First_Gen
:= Gen_Par
;
8474 while Present
(Gen_Par
)
8475 and then Is_Child_Unit
(Gen_Par
)
8477 -- Load grandparent instance as well
8479 Inst_Node
:= Get_Package_Instantiation_Node
(Inst_Par
);
8481 if Nkind
(Name
(Inst_Node
)) = N_Expanded_Name
then
8482 Inst_Par
:= Entity
(Prefix
(Name
(Inst_Node
)));
8484 if Present
(Renamed_Entity
(Inst_Par
)) then
8485 Inst_Par
:= Renamed_Entity
(Inst_Par
);
8490 (Specification
(Unit_Declaration_Node
(Inst_Par
)));
8492 if Present
(Gen_Par
) then
8493 Prepend_Elmt
(Inst_Par
, Ancestors
);
8496 -- Parent is not the name of an instantiation
8498 Install_Noninstance_Specs
(Inst_Par
);
8509 if Present
(First_Gen
) then
8510 Append_Elmt
(First_Par
, Ancestors
);
8512 Install_Noninstance_Specs
(First_Par
);
8515 if not Is_Empty_Elmt_List
(Ancestors
) then
8516 Elmt
:= First_Elmt
(Ancestors
);
8517 while Present
(Elmt
) loop
8518 Install_Spec
(Node
(Elmt
));
8519 Install_Formal_Packages
(Node
(Elmt
));
8529 -------------------------------
8530 -- Install_Hidden_Primitives --
8531 -------------------------------
8533 procedure Install_Hidden_Primitives
8534 (Prims_List
: in out Elist_Id
;
8539 List
: Elist_Id
:= No_Elist
;
8540 Prim_G_Elmt
: Elmt_Id
;
8541 Prim_A_Elmt
: Elmt_Id
;
8546 -- No action needed in case of serious errors because we cannot trust
8547 -- in the order of primitives
8549 if Serious_Errors_Detected
> 0 then
8552 -- No action possible if we don't have available the list of primitive
8556 or else not Is_Record_Type
(Gen_T
)
8557 or else not Is_Tagged_Type
(Gen_T
)
8558 or else not Is_Record_Type
(Act_T
)
8559 or else not Is_Tagged_Type
(Act_T
)
8563 -- There is no need to handle interface types since their primitives
8566 elsif Is_Interface
(Gen_T
) then
8570 Prim_G_Elmt
:= First_Elmt
(Primitive_Operations
(Gen_T
));
8572 if not Is_Class_Wide_Type
(Act_T
) then
8573 Prim_A_Elmt
:= First_Elmt
(Primitive_Operations
(Act_T
));
8575 Prim_A_Elmt
:= First_Elmt
(Primitive_Operations
(Root_Type
(Act_T
)));
8579 -- Skip predefined primitives in the generic formal
8581 while Present
(Prim_G_Elmt
)
8582 and then Is_Predefined_Dispatching_Operation
(Node
(Prim_G_Elmt
))
8584 Next_Elmt
(Prim_G_Elmt
);
8587 -- Skip predefined primitives in the generic actual
8589 while Present
(Prim_A_Elmt
)
8590 and then Is_Predefined_Dispatching_Operation
(Node
(Prim_A_Elmt
))
8592 Next_Elmt
(Prim_A_Elmt
);
8595 exit when No
(Prim_G_Elmt
) or else No
(Prim_A_Elmt
);
8597 Prim_G
:= Node
(Prim_G_Elmt
);
8598 Prim_A
:= Node
(Prim_A_Elmt
);
8600 -- There is no need to handle interface primitives because their
8601 -- primitives are not hidden
8603 exit when Present
(Interface_Alias
(Prim_G
));
8605 -- Here we install one hidden primitive
8607 if Chars
(Prim_G
) /= Chars
(Prim_A
)
8608 and then Has_Suffix
(Prim_A
, 'P')
8609 and then Remove_Suffix
(Prim_A
, 'P') = Chars
(Prim_G
)
8611 Set_Chars
(Prim_A
, Chars
(Prim_G
));
8613 if List
= No_Elist
then
8614 List
:= New_Elmt_List
;
8617 Append_Elmt
(Prim_A
, List
);
8620 Next_Elmt
(Prim_A_Elmt
);
8621 Next_Elmt
(Prim_G_Elmt
);
8624 -- Append the elements to the list of temporarily visible primitives
8625 -- avoiding duplicates.
8627 if Present
(List
) then
8628 if No
(Prims_List
) then
8629 Prims_List
:= New_Elmt_List
;
8632 Elmt
:= First_Elmt
(List
);
8633 while Present
(Elmt
) loop
8634 Append_Unique_Elmt
(Node
(Elmt
), Prims_List
);
8638 end Install_Hidden_Primitives
;
8640 -------------------------------
8641 -- Restore_Hidden_Primitives --
8642 -------------------------------
8644 procedure Restore_Hidden_Primitives
(Prims_List
: in out Elist_Id
) is
8645 Prim_Elmt
: Elmt_Id
;
8649 if Prims_List
/= No_Elist
then
8650 Prim_Elmt
:= First_Elmt
(Prims_List
);
8651 while Present
(Prim_Elmt
) loop
8652 Prim
:= Node
(Prim_Elmt
);
8653 Set_Chars
(Prim
, Add_Suffix
(Prim
, 'P'));
8654 Next_Elmt
(Prim_Elmt
);
8657 Prims_List
:= No_Elist
;
8659 end Restore_Hidden_Primitives
;
8661 --------------------------------
8662 -- Instantiate_Formal_Package --
8663 --------------------------------
8665 function Instantiate_Formal_Package
8668 Analyzed_Formal
: Node_Id
) return List_Id
8670 Loc
: constant Source_Ptr
:= Sloc
(Actual
);
8671 Actual_Pack
: Entity_Id
;
8672 Formal_Pack
: Entity_Id
;
8673 Gen_Parent
: Entity_Id
;
8676 Parent_Spec
: Node_Id
;
8678 procedure Find_Matching_Actual
8680 Act
: in out Entity_Id
);
8681 -- We need to associate each formal entity in the formal package
8682 -- with the corresponding entity in the actual package. The actual
8683 -- package has been analyzed and possibly expanded, and as a result
8684 -- there is no one-to-one correspondence between the two lists (for
8685 -- example, the actual may include subtypes, itypes, and inherited
8686 -- primitive operations, interspersed among the renaming declarations
8687 -- for the actuals) . We retrieve the corresponding actual by name
8688 -- because each actual has the same name as the formal, and they do
8689 -- appear in the same order.
8691 function Get_Formal_Entity
(N
: Node_Id
) return Entity_Id
;
8692 -- Retrieve entity of defining entity of generic formal parameter.
8693 -- Only the declarations of formals need to be considered when
8694 -- linking them to actuals, but the declarative list may include
8695 -- internal entities generated during analysis, and those are ignored.
8697 procedure Match_Formal_Entity
8698 (Formal_Node
: Node_Id
;
8699 Formal_Ent
: Entity_Id
;
8700 Actual_Ent
: Entity_Id
);
8701 -- Associates the formal entity with the actual. In the case
8702 -- where Formal_Ent is a formal package, this procedure iterates
8703 -- through all of its formals and enters associations between the
8704 -- actuals occurring in the formal package's corresponding actual
8705 -- package (given by Actual_Ent) and the formal package's formal
8706 -- parameters. This procedure recurses if any of the parameters is
8707 -- itself a package.
8709 function Is_Instance_Of
8710 (Act_Spec
: Entity_Id
;
8711 Gen_Anc
: Entity_Id
) return Boolean;
8712 -- The actual can be an instantiation of a generic within another
8713 -- instance, in which case there is no direct link from it to the
8714 -- original generic ancestor. In that case, we recognize that the
8715 -- ultimate ancestor is the same by examining names and scopes.
8717 procedure Process_Nested_Formal
(Formal
: Entity_Id
);
8718 -- If the current formal is declared with a box, its own formals are
8719 -- visible in the instance, as they were in the generic, and their
8720 -- Hidden flag must be reset. If some of these formals are themselves
8721 -- packages declared with a box, the processing must be recursive.
8723 --------------------------
8724 -- Find_Matching_Actual --
8725 --------------------------
8727 procedure Find_Matching_Actual
8729 Act
: in out Entity_Id
)
8731 Formal_Ent
: Entity_Id
;
8734 case Nkind
(Original_Node
(F
)) is
8735 when N_Formal_Object_Declaration |
8736 N_Formal_Type_Declaration
=>
8737 Formal_Ent
:= Defining_Identifier
(F
);
8739 while Chars
(Act
) /= Chars
(Formal_Ent
) loop
8743 when N_Formal_Subprogram_Declaration |
8744 N_Formal_Package_Declaration |
8745 N_Package_Declaration |
8746 N_Generic_Package_Declaration
=>
8747 Formal_Ent
:= Defining_Entity
(F
);
8749 while Chars
(Act
) /= Chars
(Formal_Ent
) loop
8754 raise Program_Error
;
8756 end Find_Matching_Actual
;
8758 -------------------------
8759 -- Match_Formal_Entity --
8760 -------------------------
8762 procedure Match_Formal_Entity
8763 (Formal_Node
: Node_Id
;
8764 Formal_Ent
: Entity_Id
;
8765 Actual_Ent
: Entity_Id
)
8767 Act_Pkg
: Entity_Id
;
8770 Set_Instance_Of
(Formal_Ent
, Actual_Ent
);
8772 if Ekind
(Actual_Ent
) = E_Package
then
8774 -- Record associations for each parameter
8776 Act_Pkg
:= Actual_Ent
;
8779 A_Ent
: Entity_Id
:= First_Entity
(Act_Pkg
);
8788 -- Retrieve the actual given in the formal package declaration
8790 Actual
:= Entity
(Name
(Original_Node
(Formal_Node
)));
8792 -- The actual in the formal package declaration may be a
8793 -- renamed generic package, in which case we want to retrieve
8794 -- the original generic in order to traverse its formal part.
8796 if Present
(Renamed_Entity
(Actual
)) then
8797 Gen_Decl
:= Unit_Declaration_Node
(Renamed_Entity
(Actual
));
8799 Gen_Decl
:= Unit_Declaration_Node
(Actual
);
8802 Formals
:= Generic_Formal_Declarations
(Gen_Decl
);
8804 if Present
(Formals
) then
8805 F_Node
:= First_Non_Pragma
(Formals
);
8810 while Present
(A_Ent
)
8811 and then Present
(F_Node
)
8812 and then A_Ent
/= First_Private_Entity
(Act_Pkg
)
8814 F_Ent
:= Get_Formal_Entity
(F_Node
);
8816 if Present
(F_Ent
) then
8818 -- This is a formal of the original package. Record
8819 -- association and recurse.
8821 Find_Matching_Actual
(F_Node
, A_Ent
);
8822 Match_Formal_Entity
(F_Node
, F_Ent
, A_Ent
);
8823 Next_Entity
(A_Ent
);
8826 Next_Non_Pragma
(F_Node
);
8830 end Match_Formal_Entity
;
8832 -----------------------
8833 -- Get_Formal_Entity --
8834 -----------------------
8836 function Get_Formal_Entity
(N
: Node_Id
) return Entity_Id
is
8837 Kind
: constant Node_Kind
:= Nkind
(Original_Node
(N
));
8840 when N_Formal_Object_Declaration
=>
8841 return Defining_Identifier
(N
);
8843 when N_Formal_Type_Declaration
=>
8844 return Defining_Identifier
(N
);
8846 when N_Formal_Subprogram_Declaration
=>
8847 return Defining_Unit_Name
(Specification
(N
));
8849 when N_Formal_Package_Declaration
=>
8850 return Defining_Identifier
(Original_Node
(N
));
8852 when N_Generic_Package_Declaration
=>
8853 return Defining_Identifier
(Original_Node
(N
));
8855 -- All other declarations are introduced by semantic analysis and
8856 -- have no match in the actual.
8861 end Get_Formal_Entity
;
8863 --------------------
8864 -- Is_Instance_Of --
8865 --------------------
8867 function Is_Instance_Of
8868 (Act_Spec
: Entity_Id
;
8869 Gen_Anc
: Entity_Id
) return Boolean
8871 Gen_Par
: constant Entity_Id
:= Generic_Parent
(Act_Spec
);
8874 if No
(Gen_Par
) then
8877 -- Simplest case: the generic parent of the actual is the formal
8879 elsif Gen_Par
= Gen_Anc
then
8882 elsif Chars
(Gen_Par
) /= Chars
(Gen_Anc
) then
8885 -- The actual may be obtained through several instantiations. Its
8886 -- scope must itself be an instance of a generic declared in the
8887 -- same scope as the formal. Any other case is detected above.
8889 elsif not Is_Generic_Instance
(Scope
(Gen_Par
)) then
8893 return Generic_Parent
(Parent
(Scope
(Gen_Par
))) = Scope
(Gen_Anc
);
8897 ---------------------------
8898 -- Process_Nested_Formal --
8899 ---------------------------
8901 procedure Process_Nested_Formal
(Formal
: Entity_Id
) is
8905 if Present
(Associated_Formal_Package
(Formal
))
8906 and then Box_Present
(Parent
(Associated_Formal_Package
(Formal
)))
8908 Ent
:= First_Entity
(Formal
);
8909 while Present
(Ent
) loop
8910 Set_Is_Hidden
(Ent
, False);
8911 Set_Is_Visible_Formal
(Ent
);
8912 Set_Is_Potentially_Use_Visible
8913 (Ent
, Is_Potentially_Use_Visible
(Formal
));
8915 if Ekind
(Ent
) = E_Package
then
8916 exit when Renamed_Entity
(Ent
) = Renamed_Entity
(Formal
);
8917 Process_Nested_Formal
(Ent
);
8923 end Process_Nested_Formal
;
8925 -- Start of processing for Instantiate_Formal_Package
8930 if not Is_Entity_Name
(Actual
)
8931 or else Ekind
(Entity
(Actual
)) /= E_Package
8934 ("expect package instance to instantiate formal", Actual
);
8935 Abandon_Instantiation
(Actual
);
8936 raise Program_Error
;
8939 Actual_Pack
:= Entity
(Actual
);
8940 Set_Is_Instantiated
(Actual_Pack
);
8942 -- The actual may be a renamed package, or an outer generic formal
8943 -- package whose instantiation is converted into a renaming.
8945 if Present
(Renamed_Object
(Actual_Pack
)) then
8946 Actual_Pack
:= Renamed_Object
(Actual_Pack
);
8949 if Nkind
(Analyzed_Formal
) = N_Formal_Package_Declaration
then
8950 Gen_Parent
:= Get_Instance_Of
(Entity
(Name
(Analyzed_Formal
)));
8951 Formal_Pack
:= Defining_Identifier
(Analyzed_Formal
);
8954 Generic_Parent
(Specification
(Analyzed_Formal
));
8956 Defining_Unit_Name
(Specification
(Analyzed_Formal
));
8959 if Nkind
(Parent
(Actual_Pack
)) = N_Defining_Program_Unit_Name
then
8960 Parent_Spec
:= Specification
(Unit_Declaration_Node
(Actual_Pack
));
8962 Parent_Spec
:= Parent
(Actual_Pack
);
8965 if Gen_Parent
= Any_Id
then
8967 ("previous error in declaration of formal package", Actual
);
8968 Abandon_Instantiation
(Actual
);
8971 Is_Instance_Of
(Parent_Spec
, Get_Instance_Of
(Gen_Parent
))
8977 ("actual parameter must be instance of&", Actual
, Gen_Parent
);
8978 Abandon_Instantiation
(Actual
);
8981 Set_Instance_Of
(Defining_Identifier
(Formal
), Actual_Pack
);
8982 Map_Formal_Package_Entities
(Formal_Pack
, Actual_Pack
);
8985 Make_Package_Renaming_Declaration
(Loc
,
8986 Defining_Unit_Name
=> New_Copy
(Defining_Identifier
(Formal
)),
8987 Name
=> New_Reference_To
(Actual_Pack
, Loc
));
8989 Set_Associated_Formal_Package
(Defining_Unit_Name
(Nod
),
8990 Defining_Identifier
(Formal
));
8991 Decls
:= New_List
(Nod
);
8993 -- If the formal F has a box, then the generic declarations are
8994 -- visible in the generic G. In an instance of G, the corresponding
8995 -- entities in the actual for F (which are the actuals for the
8996 -- instantiation of the generic that F denotes) must also be made
8997 -- visible for analysis of the current instance. On exit from the
8998 -- current instance, those entities are made private again. If the
8999 -- actual is currently in use, these entities are also use-visible.
9001 -- The loop through the actual entities also steps through the formal
9002 -- entities and enters associations from formals to actuals into the
9003 -- renaming map. This is necessary to properly handle checking of
9004 -- actual parameter associations for later formals that depend on
9005 -- actuals declared in the formal package.
9007 -- In Ada 2005, partial parametrization requires that we make visible
9008 -- the actuals corresponding to formals that were defaulted in the
9009 -- formal package. There formals are identified because they remain
9010 -- formal generics within the formal package, rather than being
9011 -- renamings of the actuals supplied.
9014 Gen_Decl
: constant Node_Id
:=
9015 Unit_Declaration_Node
(Gen_Parent
);
9016 Formals
: constant List_Id
:=
9017 Generic_Formal_Declarations
(Gen_Decl
);
9019 Actual_Ent
: Entity_Id
;
9020 Actual_Of_Formal
: Node_Id
;
9021 Formal_Node
: Node_Id
;
9022 Formal_Ent
: Entity_Id
;
9025 if Present
(Formals
) then
9026 Formal_Node
:= First_Non_Pragma
(Formals
);
9028 Formal_Node
:= Empty
;
9031 Actual_Ent
:= First_Entity
(Actual_Pack
);
9033 First
(Visible_Declarations
(Specification
(Analyzed_Formal
)));
9034 while Present
(Actual_Ent
)
9035 and then Actual_Ent
/= First_Private_Entity
(Actual_Pack
)
9037 if Present
(Formal_Node
) then
9038 Formal_Ent
:= Get_Formal_Entity
(Formal_Node
);
9040 if Present
(Formal_Ent
) then
9041 Find_Matching_Actual
(Formal_Node
, Actual_Ent
);
9043 (Formal_Node
, Formal_Ent
, Actual_Ent
);
9045 -- We iterate at the same time over the actuals of the
9046 -- local package created for the formal, to determine
9047 -- which one of the formals of the original generic were
9048 -- defaulted in the formal. The corresponding actual
9049 -- entities are visible in the enclosing instance.
9051 if Box_Present
(Formal
)
9053 (Present
(Actual_Of_Formal
)
9056 (Get_Formal_Entity
(Actual_Of_Formal
)))
9058 Set_Is_Hidden
(Actual_Ent
, False);
9059 Set_Is_Visible_Formal
(Actual_Ent
);
9060 Set_Is_Potentially_Use_Visible
9061 (Actual_Ent
, In_Use
(Actual_Pack
));
9063 if Ekind
(Actual_Ent
) = E_Package
then
9064 Process_Nested_Formal
(Actual_Ent
);
9068 Set_Is_Hidden
(Actual_Ent
);
9069 Set_Is_Potentially_Use_Visible
(Actual_Ent
, False);
9073 Next_Non_Pragma
(Formal_Node
);
9074 Next
(Actual_Of_Formal
);
9077 -- No further formals to match, but the generic part may
9078 -- contain inherited operation that are not hidden in the
9079 -- enclosing instance.
9081 Next_Entity
(Actual_Ent
);
9085 -- Inherited subprograms generated by formal derived types are
9086 -- also visible if the types are.
9088 Actual_Ent
:= First_Entity
(Actual_Pack
);
9089 while Present
(Actual_Ent
)
9090 and then Actual_Ent
/= First_Private_Entity
(Actual_Pack
)
9092 if Is_Overloadable
(Actual_Ent
)
9094 Nkind
(Parent
(Actual_Ent
)) = N_Subtype_Declaration
9096 not Is_Hidden
(Defining_Identifier
(Parent
(Actual_Ent
)))
9098 Set_Is_Hidden
(Actual_Ent
, False);
9099 Set_Is_Potentially_Use_Visible
9100 (Actual_Ent
, In_Use
(Actual_Pack
));
9103 Next_Entity
(Actual_Ent
);
9107 -- If the formal is not declared with a box, reanalyze it as an
9108 -- abbreviated instantiation, to verify the matching rules of 12.7.
9109 -- The actual checks are performed after the generic associations
9110 -- have been analyzed, to guarantee the same visibility for this
9111 -- instantiation and for the actuals.
9113 -- In Ada 2005, the generic associations for the formal can include
9114 -- defaulted parameters. These are ignored during check. This
9115 -- internal instantiation is removed from the tree after conformance
9116 -- checking, because it contains formal declarations for those
9117 -- defaulted parameters, and those should not reach the back-end.
9119 if not Box_Present
(Formal
) then
9121 I_Pack
: constant Entity_Id
:=
9122 Make_Temporary
(Sloc
(Actual
), 'P');
9125 Set_Is_Internal
(I_Pack
);
9128 Make_Package_Instantiation
(Sloc
(Actual
),
9129 Defining_Unit_Name
=> I_Pack
,
9132 (Get_Instance_Of
(Gen_Parent
), Sloc
(Actual
)),
9133 Generic_Associations
=>
9134 Generic_Associations
(Formal
)));
9140 end Instantiate_Formal_Package
;
9142 -----------------------------------
9143 -- Instantiate_Formal_Subprogram --
9144 -----------------------------------
9146 function Instantiate_Formal_Subprogram
9149 Analyzed_Formal
: Node_Id
) return Node_Id
9152 Formal_Sub
: constant Entity_Id
:=
9153 Defining_Unit_Name
(Specification
(Formal
));
9154 Analyzed_S
: constant Entity_Id
:=
9155 Defining_Unit_Name
(Specification
(Analyzed_Formal
));
9156 Decl_Node
: Node_Id
;
9160 function From_Parent_Scope
(Subp
: Entity_Id
) return Boolean;
9161 -- If the generic is a child unit, the parent has been installed on the
9162 -- scope stack, but a default subprogram cannot resolve to something on
9163 -- the parent because that parent is not really part of the visible
9164 -- context (it is there to resolve explicit local entities). If the
9165 -- default has resolved in this way, we remove the entity from
9166 -- immediate visibility and analyze the node again to emit an error
9167 -- message or find another visible candidate.
9169 procedure Valid_Actual_Subprogram
(Act
: Node_Id
);
9170 -- Perform legality check and raise exception on failure
9172 -----------------------
9173 -- From_Parent_Scope --
9174 -----------------------
9176 function From_Parent_Scope
(Subp
: Entity_Id
) return Boolean is
9177 Gen_Scope
: Node_Id
;
9180 Gen_Scope
:= Scope
(Analyzed_S
);
9181 while Present
(Gen_Scope
) and then Is_Child_Unit
(Gen_Scope
) loop
9182 if Scope
(Subp
) = Scope
(Gen_Scope
) then
9186 Gen_Scope
:= Scope
(Gen_Scope
);
9190 end From_Parent_Scope
;
9192 -----------------------------
9193 -- Valid_Actual_Subprogram --
9194 -----------------------------
9196 procedure Valid_Actual_Subprogram
(Act
: Node_Id
) is
9200 if Is_Entity_Name
(Act
) then
9201 Act_E
:= Entity
(Act
);
9203 elsif Nkind
(Act
) = N_Selected_Component
9204 and then Is_Entity_Name
(Selector_Name
(Act
))
9206 Act_E
:= Entity
(Selector_Name
(Act
));
9212 if (Present
(Act_E
) and then Is_Overloadable
(Act_E
))
9213 or else Nkind_In
(Act
, N_Attribute_Reference
,
9214 N_Indexed_Component
,
9215 N_Character_Literal
,
9216 N_Explicit_Dereference
)
9222 ("expect subprogram or entry name in instantiation of&",
9223 Instantiation_Node
, Formal_Sub
);
9224 Abandon_Instantiation
(Instantiation_Node
);
9226 end Valid_Actual_Subprogram
;
9228 -- Start of processing for Instantiate_Formal_Subprogram
9231 New_Spec
:= New_Copy_Tree
(Specification
(Formal
));
9233 -- The tree copy has created the proper instantiation sloc for the
9234 -- new specification. Use this location for all other constructed
9237 Loc
:= Sloc
(Defining_Unit_Name
(New_Spec
));
9239 -- Create new entity for the actual (New_Copy_Tree does not)
9241 Set_Defining_Unit_Name
9242 (New_Spec
, Make_Defining_Identifier
(Loc
, Chars
(Formal_Sub
)));
9244 -- Create new entities for the each of the formals in the
9245 -- specification of the renaming declaration built for the actual.
9247 if Present
(Parameter_Specifications
(New_Spec
)) then
9251 F
:= First
(Parameter_Specifications
(New_Spec
));
9252 while Present
(F
) loop
9253 Set_Defining_Identifier
(F
,
9254 Make_Defining_Identifier
(Sloc
(F
),
9255 Chars
=> Chars
(Defining_Identifier
(F
))));
9261 -- Find entity of actual. If the actual is an attribute reference, it
9262 -- cannot be resolved here (its formal is missing) but is handled
9263 -- instead in Attribute_Renaming. If the actual is overloaded, it is
9264 -- fully resolved subsequently, when the renaming declaration for the
9265 -- formal is analyzed. If it is an explicit dereference, resolve the
9266 -- prefix but not the actual itself, to prevent interpretation as call.
9268 if Present
(Actual
) then
9269 Loc
:= Sloc
(Actual
);
9270 Set_Sloc
(New_Spec
, Loc
);
9272 if Nkind
(Actual
) = N_Operator_Symbol
then
9273 Find_Direct_Name
(Actual
);
9275 elsif Nkind
(Actual
) = N_Explicit_Dereference
then
9276 Analyze
(Prefix
(Actual
));
9278 elsif Nkind
(Actual
) /= N_Attribute_Reference
then
9282 Valid_Actual_Subprogram
(Actual
);
9285 elsif Present
(Default_Name
(Formal
)) then
9286 if not Nkind_In
(Default_Name
(Formal
), N_Attribute_Reference
,
9287 N_Selected_Component
,
9288 N_Indexed_Component
,
9289 N_Character_Literal
)
9290 and then Present
(Entity
(Default_Name
(Formal
)))
9292 Nam
:= New_Occurrence_Of
(Entity
(Default_Name
(Formal
)), Loc
);
9294 Nam
:= New_Copy
(Default_Name
(Formal
));
9295 Set_Sloc
(Nam
, Loc
);
9298 elsif Box_Present
(Formal
) then
9300 -- Actual is resolved at the point of instantiation. Create an
9301 -- identifier or operator with the same name as the formal.
9303 if Nkind
(Formal_Sub
) = N_Defining_Operator_Symbol
then
9304 Nam
:= Make_Operator_Symbol
(Loc
,
9305 Chars
=> Chars
(Formal_Sub
),
9306 Strval
=> No_String
);
9308 Nam
:= Make_Identifier
(Loc
, Chars
(Formal_Sub
));
9311 elsif Nkind
(Specification
(Formal
)) = N_Procedure_Specification
9312 and then Null_Present
(Specification
(Formal
))
9314 -- Generate null body for procedure, for use in the instance
9317 Make_Subprogram_Body
(Loc
,
9318 Specification
=> New_Spec
,
9319 Declarations
=> New_List
,
9320 Handled_Statement_Sequence
=>
9321 Make_Handled_Sequence_Of_Statements
(Loc
,
9322 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
9324 Set_Is_Intrinsic_Subprogram
(Defining_Unit_Name
(New_Spec
));
9328 Error_Msg_Sloc
:= Sloc
(Scope
(Analyzed_S
));
9330 ("missing actual&", Instantiation_Node
, Formal_Sub
);
9332 ("\in instantiation of & declared#",
9333 Instantiation_Node
, Scope
(Analyzed_S
));
9334 Abandon_Instantiation
(Instantiation_Node
);
9338 Make_Subprogram_Renaming_Declaration
(Loc
,
9339 Specification
=> New_Spec
,
9342 -- If we do not have an actual and the formal specified <> then set to
9343 -- get proper default.
9345 if No
(Actual
) and then Box_Present
(Formal
) then
9346 Set_From_Default
(Decl_Node
);
9349 -- Gather possible interpretations for the actual before analyzing the
9350 -- instance. If overloaded, it will be resolved when analyzing the
9351 -- renaming declaration.
9353 if Box_Present
(Formal
)
9354 and then No
(Actual
)
9358 if Is_Child_Unit
(Scope
(Analyzed_S
))
9359 and then Present
(Entity
(Nam
))
9361 if not Is_Overloaded
(Nam
) then
9362 if From_Parent_Scope
(Entity
(Nam
)) then
9363 Set_Is_Immediately_Visible
(Entity
(Nam
), False);
9364 Set_Entity
(Nam
, Empty
);
9365 Set_Etype
(Nam
, Empty
);
9368 Set_Is_Immediately_Visible
(Entity
(Nam
));
9377 Get_First_Interp
(Nam
, I
, It
);
9378 while Present
(It
.Nam
) loop
9379 if From_Parent_Scope
(It
.Nam
) then
9383 Get_Next_Interp
(I
, It
);
9390 -- The generic instantiation freezes the actual. This can only be done
9391 -- once the actual is resolved, in the analysis of the renaming
9392 -- declaration. To make the formal subprogram entity available, we set
9393 -- Corresponding_Formal_Spec to point to the formal subprogram entity.
9394 -- This is also needed in Analyze_Subprogram_Renaming for the processing
9395 -- of formal abstract subprograms.
9397 Set_Corresponding_Formal_Spec
(Decl_Node
, Analyzed_S
);
9399 -- We cannot analyze the renaming declaration, and thus find the actual,
9400 -- until all the actuals are assembled in the instance. For subsequent
9401 -- checks of other actuals, indicate the node that will hold the
9402 -- instance of this formal.
9404 Set_Instance_Of
(Analyzed_S
, Nam
);
9406 if Nkind
(Actual
) = N_Selected_Component
9407 and then Is_Task_Type
(Etype
(Prefix
(Actual
)))
9408 and then not Is_Frozen
(Etype
(Prefix
(Actual
)))
9410 -- The renaming declaration will create a body, which must appear
9411 -- outside of the instantiation, We move the renaming declaration
9412 -- out of the instance, and create an additional renaming inside,
9413 -- to prevent freezing anomalies.
9416 Anon_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E');
9419 Set_Defining_Unit_Name
(New_Spec
, Anon_Id
);
9420 Insert_Before
(Instantiation_Node
, Decl_Node
);
9421 Analyze
(Decl_Node
);
9423 -- Now create renaming within the instance
9426 Make_Subprogram_Renaming_Declaration
(Loc
,
9427 Specification
=> New_Copy_Tree
(New_Spec
),
9428 Name
=> New_Occurrence_Of
(Anon_Id
, Loc
));
9430 Set_Defining_Unit_Name
(Specification
(Decl_Node
),
9431 Make_Defining_Identifier
(Loc
, Chars
(Formal_Sub
)));
9436 end Instantiate_Formal_Subprogram
;
9438 ------------------------
9439 -- Instantiate_Object --
9440 ------------------------
9442 function Instantiate_Object
9445 Analyzed_Formal
: Node_Id
) return List_Id
9447 Gen_Obj
: constant Entity_Id
:= Defining_Identifier
(Formal
);
9448 A_Gen_Obj
: constant Entity_Id
:=
9449 Defining_Identifier
(Analyzed_Formal
);
9450 Acc_Def
: Node_Id
:= Empty
;
9451 Act_Assoc
: constant Node_Id
:= Parent
(Actual
);
9452 Actual_Decl
: Node_Id
:= Empty
;
9453 Decl_Node
: Node_Id
;
9456 List
: constant List_Id
:= New_List
;
9457 Loc
: constant Source_Ptr
:= Sloc
(Actual
);
9458 Orig_Ftyp
: constant Entity_Id
:= Etype
(A_Gen_Obj
);
9459 Subt_Decl
: Node_Id
:= Empty
;
9460 Subt_Mark
: Node_Id
:= Empty
;
9463 if Present
(Subtype_Mark
(Formal
)) then
9464 Subt_Mark
:= Subtype_Mark
(Formal
);
9466 Check_Access_Definition
(Formal
);
9467 Acc_Def
:= Access_Definition
(Formal
);
9470 -- Sloc for error message on missing actual
9472 Error_Msg_Sloc
:= Sloc
(Scope
(A_Gen_Obj
));
9474 if Get_Instance_Of
(Gen_Obj
) /= Gen_Obj
then
9475 Error_Msg_N
("duplicate instantiation of generic parameter", Actual
);
9478 Set_Parent
(List
, Parent
(Actual
));
9482 if Out_Present
(Formal
) then
9484 -- An IN OUT generic actual must be a name. The instantiation is a
9485 -- renaming declaration. The actual is the name being renamed. We
9486 -- use the actual directly, rather than a copy, because it is not
9487 -- used further in the list of actuals, and because a copy or a use
9488 -- of relocate_node is incorrect if the instance is nested within a
9489 -- generic. In order to simplify ASIS searches, the Generic_Parent
9490 -- field links the declaration to the generic association.
9495 Instantiation_Node
, Gen_Obj
);
9497 ("\in instantiation of & declared#",
9498 Instantiation_Node
, Scope
(A_Gen_Obj
));
9499 Abandon_Instantiation
(Instantiation_Node
);
9502 if Present
(Subt_Mark
) then
9504 Make_Object_Renaming_Declaration
(Loc
,
9505 Defining_Identifier
=> New_Copy
(Gen_Obj
),
9506 Subtype_Mark
=> New_Copy_Tree
(Subt_Mark
),
9509 else pragma Assert
(Present
(Acc_Def
));
9511 Make_Object_Renaming_Declaration
(Loc
,
9512 Defining_Identifier
=> New_Copy
(Gen_Obj
),
9513 Access_Definition
=> New_Copy_Tree
(Acc_Def
),
9517 Set_Corresponding_Generic_Association
(Decl_Node
, Act_Assoc
);
9519 -- The analysis of the actual may produce Insert_Action nodes, so
9520 -- the declaration must have a context in which to attach them.
9522 Append
(Decl_Node
, List
);
9525 -- Return if the analysis of the actual reported some error
9527 if Etype
(Actual
) = Any_Type
then
9531 -- This check is performed here because Analyze_Object_Renaming will
9532 -- not check it when Comes_From_Source is False. Note though that the
9533 -- check for the actual being the name of an object will be performed
9534 -- in Analyze_Object_Renaming.
9536 if Is_Object_Reference
(Actual
)
9537 and then Is_Dependent_Component_Of_Mutable_Object
(Actual
)
9540 ("illegal discriminant-dependent component for in out parameter",
9544 -- The actual has to be resolved in order to check that it is a
9545 -- variable (due to cases such as F (1), where F returns access to an
9546 -- array, and for overloaded prefixes).
9548 Ftyp
:= Get_Instance_Of
(Etype
(A_Gen_Obj
));
9550 -- If the type of the formal is not itself a formal, and the
9551 -- current unit is a child unit, the formal type must be declared
9552 -- in a parent, and must be retrieved by visibility.
9555 and then Is_Generic_Unit
(Scope
(Ftyp
))
9556 and then Is_Child_Unit
(Scope
(A_Gen_Obj
))
9559 Temp
: constant Node_Id
:=
9560 New_Copy_Tree
(Subtype_Mark
(Analyzed_Formal
));
9562 Set_Entity
(Temp
, Empty
);
9564 Ftyp
:= Entity
(Temp
);
9568 if Is_Private_Type
(Ftyp
)
9569 and then not Is_Private_Type
(Etype
(Actual
))
9570 and then (Base_Type
(Full_View
(Ftyp
)) = Base_Type
(Etype
(Actual
))
9571 or else Base_Type
(Etype
(Actual
)) = Ftyp
)
9573 -- If the actual has the type of the full view of the formal, or
9574 -- else a non-private subtype of the formal, then the visibility
9575 -- of the formal type has changed. Add to the actuals a subtype
9576 -- declaration that will force the exchange of views in the body
9577 -- of the instance as well.
9580 Make_Subtype_Declaration
(Loc
,
9581 Defining_Identifier
=> Make_Temporary
(Loc
, 'P'),
9582 Subtype_Indication
=> New_Occurrence_Of
(Ftyp
, Loc
));
9584 Prepend
(Subt_Decl
, List
);
9586 Prepend_Elmt
(Full_View
(Ftyp
), Exchanged_Views
);
9587 Exchange_Declarations
(Ftyp
);
9590 Resolve
(Actual
, Ftyp
);
9592 if not Denotes_Variable
(Actual
) then
9594 ("actual for& must be a variable", Actual
, Gen_Obj
);
9596 elsif Base_Type
(Ftyp
) /= Base_Type
(Etype
(Actual
)) then
9598 -- Ada 2005 (AI-423): For a generic formal object of mode in out,
9599 -- the type of the actual shall resolve to a specific anonymous
9602 if Ada_Version
< Ada_2005
9604 Ekind
(Base_Type
(Ftyp
)) /=
9605 E_Anonymous_Access_Type
9607 Ekind
(Base_Type
(Etype
(Actual
))) /=
9608 E_Anonymous_Access_Type
9610 Error_Msg_NE
("type of actual does not match type of&",
9615 Note_Possible_Modification
(Actual
, Sure
=> True);
9617 -- Check for instantiation of atomic/volatile actual for
9618 -- non-atomic/volatile formal (RM C.6 (12)).
9620 if Is_Atomic_Object
(Actual
)
9621 and then not Is_Atomic
(Orig_Ftyp
)
9624 ("cannot instantiate non-atomic formal object " &
9625 "with atomic actual", Actual
);
9627 elsif Is_Volatile_Object
(Actual
)
9628 and then not Is_Volatile
(Orig_Ftyp
)
9631 ("cannot instantiate non-volatile formal object " &
9632 "with volatile actual", Actual
);
9635 -- Formal in-parameter
9638 -- The instantiation of a generic formal in-parameter is constant
9639 -- declaration. The actual is the expression for that declaration.
9641 if Present
(Actual
) then
9642 if Present
(Subt_Mark
) then
9644 else pragma Assert
(Present
(Acc_Def
));
9649 Make_Object_Declaration
(Loc
,
9650 Defining_Identifier
=> New_Copy
(Gen_Obj
),
9651 Constant_Present
=> True,
9652 Null_Exclusion_Present
=> Null_Exclusion_Present
(Formal
),
9653 Object_Definition
=> New_Copy_Tree
(Def
),
9654 Expression
=> Actual
);
9656 Set_Corresponding_Generic_Association
(Decl_Node
, Act_Assoc
);
9658 -- A generic formal object of a tagged type is defined to be
9659 -- aliased so the new constant must also be treated as aliased.
9661 if Is_Tagged_Type
(Etype
(A_Gen_Obj
)) then
9662 Set_Aliased_Present
(Decl_Node
);
9665 Append
(Decl_Node
, List
);
9667 -- No need to repeat (pre-)analysis of some expression nodes
9668 -- already handled in Preanalyze_Actuals.
9670 if Nkind
(Actual
) /= N_Allocator
then
9673 -- Return if the analysis of the actual reported some error
9675 if Etype
(Actual
) = Any_Type
then
9681 Formal_Type
: constant Entity_Id
:= Etype
(A_Gen_Obj
);
9685 Typ
:= Get_Instance_Of
(Formal_Type
);
9687 Freeze_Before
(Instantiation_Node
, Typ
);
9689 -- If the actual is an aggregate, perform name resolution on
9690 -- its components (the analysis of an aggregate does not do it)
9691 -- to capture local names that may be hidden if the generic is
9694 if Nkind
(Actual
) = N_Aggregate
then
9695 Preanalyze_And_Resolve
(Actual
, Typ
);
9698 if Is_Limited_Type
(Typ
)
9699 and then not OK_For_Limited_Init
(Typ
, Actual
)
9702 ("initialization not allowed for limited types", Actual
);
9703 Explain_Limited_Type
(Typ
, Actual
);
9707 elsif Present
(Default_Expression
(Formal
)) then
9709 -- Use default to construct declaration
9711 if Present
(Subt_Mark
) then
9713 else pragma Assert
(Present
(Acc_Def
));
9718 Make_Object_Declaration
(Sloc
(Formal
),
9719 Defining_Identifier
=> New_Copy
(Gen_Obj
),
9720 Constant_Present
=> True,
9721 Null_Exclusion_Present
=> Null_Exclusion_Present
(Formal
),
9722 Object_Definition
=> New_Copy
(Def
),
9723 Expression
=> New_Copy_Tree
9724 (Default_Expression
(Formal
)));
9726 Append
(Decl_Node
, List
);
9727 Set_Analyzed
(Expression
(Decl_Node
), False);
9732 Instantiation_Node
, Gen_Obj
);
9733 Error_Msg_NE
("\in instantiation of & declared#",
9734 Instantiation_Node
, Scope
(A_Gen_Obj
));
9736 if Is_Scalar_Type
(Etype
(A_Gen_Obj
)) then
9738 -- Create dummy constant declaration so that instance can be
9739 -- analyzed, to minimize cascaded visibility errors.
9741 if Present
(Subt_Mark
) then
9743 else pragma Assert
(Present
(Acc_Def
));
9748 Make_Object_Declaration
(Loc
,
9749 Defining_Identifier
=> New_Copy
(Gen_Obj
),
9750 Constant_Present
=> True,
9751 Null_Exclusion_Present
=> Null_Exclusion_Present
(Formal
),
9752 Object_Definition
=> New_Copy
(Def
),
9754 Make_Attribute_Reference
(Sloc
(Gen_Obj
),
9755 Attribute_Name
=> Name_First
,
9756 Prefix
=> New_Copy
(Def
)));
9758 Append
(Decl_Node
, List
);
9761 Abandon_Instantiation
(Instantiation_Node
);
9766 if Nkind
(Actual
) in N_Has_Entity
then
9767 Actual_Decl
:= Parent
(Entity
(Actual
));
9770 -- Ada 2005 (AI-423): For a formal object declaration with a null
9771 -- exclusion or an access definition that has a null exclusion: If the
9772 -- actual matching the formal object declaration denotes a generic
9773 -- formal object of another generic unit G, and the instantiation
9774 -- containing the actual occurs within the body of G or within the body
9775 -- of a generic unit declared within the declarative region of G, then
9776 -- the declaration of the formal object of G must have a null exclusion.
9777 -- Otherwise, the subtype of the actual matching the formal object
9778 -- declaration shall exclude null.
9780 if Ada_Version
>= Ada_2005
9781 and then Present
(Actual_Decl
)
9783 Nkind_In
(Actual_Decl
, N_Formal_Object_Declaration
,
9784 N_Object_Declaration
)
9785 and then Nkind
(Analyzed_Formal
) = N_Formal_Object_Declaration
9786 and then not Has_Null_Exclusion
(Actual_Decl
)
9787 and then Has_Null_Exclusion
(Analyzed_Formal
)
9789 Error_Msg_Sloc
:= Sloc
(Analyzed_Formal
);
9791 ("actual must exclude null to match generic formal#", Actual
);
9795 end Instantiate_Object
;
9797 ------------------------------
9798 -- Instantiate_Package_Body --
9799 ------------------------------
9801 procedure Instantiate_Package_Body
9802 (Body_Info
: Pending_Body_Info
;
9803 Inlined_Body
: Boolean := False;
9804 Body_Optional
: Boolean := False)
9806 Act_Decl
: constant Node_Id
:= Body_Info
.Act_Decl
;
9807 Inst_Node
: constant Node_Id
:= Body_Info
.Inst_Node
;
9808 Loc
: constant Source_Ptr
:= Sloc
(Inst_Node
);
9810 Gen_Id
: constant Node_Id
:= Name
(Inst_Node
);
9811 Gen_Unit
: constant Entity_Id
:= Get_Generic_Entity
(Inst_Node
);
9812 Gen_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Gen_Unit
);
9813 Act_Spec
: constant Node_Id
:= Specification
(Act_Decl
);
9814 Act_Decl_Id
: constant Entity_Id
:= Defining_Entity
(Act_Spec
);
9816 Act_Body_Name
: Node_Id
;
9818 Gen_Body_Id
: Node_Id
;
9820 Act_Body_Id
: Entity_Id
;
9822 Parent_Installed
: Boolean := False;
9823 Save_Style_Check
: constant Boolean := Style_Check
;
9825 Par_Ent
: Entity_Id
:= Empty
;
9826 Par_Vis
: Boolean := False;
9828 Vis_Prims_List
: Elist_Id
:= No_Elist
;
9829 -- List of primitives made temporarily visible in the instantiation
9830 -- to match the visibility of the formal type
9833 Gen_Body_Id
:= Corresponding_Body
(Gen_Decl
);
9835 -- The instance body may already have been processed, as the parent of
9836 -- another instance that is inlined (Load_Parent_Of_Generic).
9838 if Present
(Corresponding_Body
(Instance_Spec
(Inst_Node
))) then
9842 Expander_Mode_Save_And_Set
(Body_Info
.Expander_Status
);
9844 -- Re-establish the state of information on which checks are suppressed.
9845 -- This information was set in Body_Info at the point of instantiation,
9846 -- and now we restore it so that the instance is compiled using the
9847 -- check status at the instantiation (RM 11.5 (7.2/2), AI95-00224-01).
9849 Local_Suppress_Stack_Top
:= Body_Info
.Local_Suppress_Stack_Top
;
9850 Scope_Suppress
:= Body_Info
.Scope_Suppress
;
9851 Opt
.Ada_Version
:= Body_Info
.Version
;
9853 if No
(Gen_Body_Id
) then
9854 Load_Parent_Of_Generic
9855 (Inst_Node
, Specification
(Gen_Decl
), Body_Optional
);
9856 Gen_Body_Id
:= Corresponding_Body
(Gen_Decl
);
9859 -- Establish global variable for sloc adjustment and for error recovery
9861 Instantiation_Node
:= Inst_Node
;
9863 if Present
(Gen_Body_Id
) then
9864 Save_Env
(Gen_Unit
, Act_Decl_Id
);
9865 Style_Check
:= False;
9866 Current_Sem_Unit
:= Body_Info
.Current_Sem_Unit
;
9868 Gen_Body
:= Unit_Declaration_Node
(Gen_Body_Id
);
9870 Create_Instantiation_Source
9871 (Inst_Node
, Gen_Body_Id
, False, S_Adjustment
);
9875 (Original_Node
(Gen_Body
), Empty
, Instantiating
=> True);
9877 -- Build new name (possibly qualified) for body declaration
9879 Act_Body_Id
:= New_Copy
(Act_Decl_Id
);
9881 -- Some attributes of spec entity are not inherited by body entity
9883 Set_Handler_Records
(Act_Body_Id
, No_List
);
9885 if Nkind
(Defining_Unit_Name
(Act_Spec
)) =
9886 N_Defining_Program_Unit_Name
9889 Make_Defining_Program_Unit_Name
(Loc
,
9890 Name
=> New_Copy_Tree
(Name
(Defining_Unit_Name
(Act_Spec
))),
9891 Defining_Identifier
=> Act_Body_Id
);
9893 Act_Body_Name
:= Act_Body_Id
;
9896 Set_Defining_Unit_Name
(Act_Body
, Act_Body_Name
);
9898 Set_Corresponding_Spec
(Act_Body
, Act_Decl_Id
);
9899 Check_Generic_Actuals
(Act_Decl_Id
, False);
9901 -- Install primitives hidden at the point of the instantiation but
9902 -- visible when processing the generic formals
9908 E
:= First_Entity
(Act_Decl_Id
);
9909 while Present
(E
) loop
9911 and then Is_Generic_Actual_Type
(E
)
9912 and then Is_Tagged_Type
(E
)
9914 Install_Hidden_Primitives
9915 (Prims_List
=> Vis_Prims_List
,
9916 Gen_T
=> Generic_Parent_Type
(Parent
(E
)),
9924 -- If it is a child unit, make the parent instance (which is an
9925 -- instance of the parent of the generic) visible. The parent
9926 -- instance is the prefix of the name of the generic unit.
9928 if Ekind
(Scope
(Gen_Unit
)) = E_Generic_Package
9929 and then Nkind
(Gen_Id
) = N_Expanded_Name
9931 Par_Ent
:= Entity
(Prefix
(Gen_Id
));
9932 Par_Vis
:= Is_Immediately_Visible
(Par_Ent
);
9933 Install_Parent
(Par_Ent
, In_Body
=> True);
9934 Parent_Installed
:= True;
9936 elsif Is_Child_Unit
(Gen_Unit
) then
9937 Par_Ent
:= Scope
(Gen_Unit
);
9938 Par_Vis
:= Is_Immediately_Visible
(Par_Ent
);
9939 Install_Parent
(Par_Ent
, In_Body
=> True);
9940 Parent_Installed
:= True;
9943 -- If the instantiation is a library unit, and this is the main unit,
9944 -- then build the resulting compilation unit nodes for the instance.
9945 -- If this is a compilation unit but it is not the main unit, then it
9946 -- is the body of a unit in the context, that is being compiled
9947 -- because it is encloses some inlined unit or another generic unit
9948 -- being instantiated. In that case, this body is not part of the
9949 -- current compilation, and is not attached to the tree, but its
9950 -- parent must be set for analysis.
9952 if Nkind
(Parent
(Inst_Node
)) = N_Compilation_Unit
then
9954 -- Replace instance node with body of instance, and create new
9955 -- node for corresponding instance declaration.
9957 Build_Instance_Compilation_Unit_Nodes
9958 (Inst_Node
, Act_Body
, Act_Decl
);
9959 Analyze
(Inst_Node
);
9961 if Parent
(Inst_Node
) = Cunit
(Main_Unit
) then
9963 -- If the instance is a child unit itself, then set the scope
9964 -- of the expanded body to be the parent of the instantiation
9965 -- (ensuring that the fully qualified name will be generated
9966 -- for the elaboration subprogram).
9968 if Nkind
(Defining_Unit_Name
(Act_Spec
)) =
9969 N_Defining_Program_Unit_Name
9972 (Defining_Entity
(Inst_Node
), Scope
(Act_Decl_Id
));
9976 -- Case where instantiation is not a library unit
9979 -- If this is an early instantiation, i.e. appears textually
9980 -- before the corresponding body and must be elaborated first,
9981 -- indicate that the body instance is to be delayed.
9983 Install_Body
(Act_Body
, Inst_Node
, Gen_Body
, Gen_Decl
);
9985 -- Now analyze the body. We turn off all checks if this is an
9986 -- internal unit, since there is no reason to have checks on for
9987 -- any predefined run-time library code. All such code is designed
9988 -- to be compiled with checks off.
9990 -- Note that we do NOT apply this criterion to children of GNAT
9991 -- (or on VMS, children of DEC). The latter units must suppress
9992 -- checks explicitly if this is needed.
9994 if Is_Predefined_File_Name
9995 (Unit_File_Name
(Get_Source_Unit
(Gen_Decl
)))
9997 Analyze
(Act_Body
, Suppress
=> All_Checks
);
10003 Inherit_Context
(Gen_Body
, Inst_Node
);
10005 -- Remove the parent instances if they have been placed on the scope
10006 -- stack to compile the body.
10008 if Parent_Installed
then
10009 Remove_Parent
(In_Body
=> True);
10011 -- Restore the previous visibility of the parent
10013 Set_Is_Immediately_Visible
(Par_Ent
, Par_Vis
);
10016 Restore_Hidden_Primitives
(Vis_Prims_List
);
10017 Restore_Private_Views
(Act_Decl_Id
);
10019 -- Remove the current unit from visibility if this is an instance
10020 -- that is not elaborated on the fly for inlining purposes.
10022 if not Inlined_Body
then
10023 Set_Is_Immediately_Visible
(Act_Decl_Id
, False);
10027 Style_Check
:= Save_Style_Check
;
10029 -- If we have no body, and the unit requires a body, then complain. This
10030 -- complaint is suppressed if we have detected other errors (since a
10031 -- common reason for missing the body is that it had errors).
10032 -- In CodePeer mode, a warning has been emitted already, no need for
10033 -- further messages.
10035 elsif Unit_Requires_Body
(Gen_Unit
)
10036 and then not Body_Optional
10038 if CodePeer_Mode
then
10041 elsif Serious_Errors_Detected
= 0 then
10043 ("cannot find body of generic package &", Inst_Node
, Gen_Unit
);
10045 -- Don't attempt to perform any cleanup actions if some other error
10046 -- was already detected, since this can cause blowups.
10052 -- Case of package that does not need a body
10055 -- If the instantiation of the declaration is a library unit, rewrite
10056 -- the original package instantiation as a package declaration in the
10057 -- compilation unit node.
10059 if Nkind
(Parent
(Inst_Node
)) = N_Compilation_Unit
then
10060 Set_Parent_Spec
(Act_Decl
, Parent_Spec
(Inst_Node
));
10061 Rewrite
(Inst_Node
, Act_Decl
);
10063 -- Generate elaboration entity, in case spec has elaboration code.
10064 -- This cannot be done when the instance is analyzed, because it
10065 -- is not known yet whether the body exists.
10067 Set_Elaboration_Entity_Required
(Act_Decl_Id
, False);
10068 Build_Elaboration_Entity
(Parent
(Inst_Node
), Act_Decl_Id
);
10070 -- If the instantiation is not a library unit, then append the
10071 -- declaration to the list of implicitly generated entities, unless
10072 -- it is already a list member which means that it was already
10075 elsif not Is_List_Member
(Act_Decl
) then
10076 Mark_Rewrite_Insertion
(Act_Decl
);
10077 Insert_Before
(Inst_Node
, Act_Decl
);
10081 Expander_Mode_Restore
;
10082 end Instantiate_Package_Body
;
10084 ---------------------------------
10085 -- Instantiate_Subprogram_Body --
10086 ---------------------------------
10088 procedure Instantiate_Subprogram_Body
10089 (Body_Info
: Pending_Body_Info
;
10090 Body_Optional
: Boolean := False)
10092 Act_Decl
: constant Node_Id
:= Body_Info
.Act_Decl
;
10093 Inst_Node
: constant Node_Id
:= Body_Info
.Inst_Node
;
10094 Loc
: constant Source_Ptr
:= Sloc
(Inst_Node
);
10095 Gen_Id
: constant Node_Id
:= Name
(Inst_Node
);
10096 Gen_Unit
: constant Entity_Id
:= Get_Generic_Entity
(Inst_Node
);
10097 Gen_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Gen_Unit
);
10098 Anon_Id
: constant Entity_Id
:=
10099 Defining_Unit_Name
(Specification
(Act_Decl
));
10100 Pack_Id
: constant Entity_Id
:=
10101 Defining_Unit_Name
(Parent
(Act_Decl
));
10103 Gen_Body
: Node_Id
;
10104 Gen_Body_Id
: Node_Id
;
10105 Act_Body
: Node_Id
;
10106 Pack_Body
: Node_Id
;
10107 Prev_Formal
: Entity_Id
;
10108 Ret_Expr
: Node_Id
;
10109 Unit_Renaming
: Node_Id
;
10111 Parent_Installed
: Boolean := False;
10112 Save_Style_Check
: constant Boolean := Style_Check
;
10114 Par_Ent
: Entity_Id
:= Empty
;
10115 Par_Vis
: Boolean := False;
10118 Gen_Body_Id
:= Corresponding_Body
(Gen_Decl
);
10120 -- Subprogram body may have been created already because of an inline
10121 -- pragma, or because of multiple elaborations of the enclosing package
10122 -- when several instances of the subprogram appear in the main unit.
10124 if Present
(Corresponding_Body
(Act_Decl
)) then
10128 Expander_Mode_Save_And_Set
(Body_Info
.Expander_Status
);
10130 -- Re-establish the state of information on which checks are suppressed.
10131 -- This information was set in Body_Info at the point of instantiation,
10132 -- and now we restore it so that the instance is compiled using the
10133 -- check status at the instantiation (RM 11.5 (7.2/2), AI95-00224-01).
10135 Local_Suppress_Stack_Top
:= Body_Info
.Local_Suppress_Stack_Top
;
10136 Scope_Suppress
:= Body_Info
.Scope_Suppress
;
10137 Opt
.Ada_Version
:= Body_Info
.Version
;
10139 if No
(Gen_Body_Id
) then
10141 -- For imported generic subprogram, no body to compile, complete
10142 -- the spec entity appropriately.
10144 if Is_Imported
(Gen_Unit
) then
10145 Set_Is_Imported
(Anon_Id
);
10146 Set_First_Rep_Item
(Anon_Id
, First_Rep_Item
(Gen_Unit
));
10147 Set_Interface_Name
(Anon_Id
, Interface_Name
(Gen_Unit
));
10148 Set_Convention
(Anon_Id
, Convention
(Gen_Unit
));
10149 Set_Has_Completion
(Anon_Id
);
10152 -- For other cases, compile the body
10155 Load_Parent_Of_Generic
10156 (Inst_Node
, Specification
(Gen_Decl
), Body_Optional
);
10157 Gen_Body_Id
:= Corresponding_Body
(Gen_Decl
);
10161 Instantiation_Node
:= Inst_Node
;
10163 if Present
(Gen_Body_Id
) then
10164 Gen_Body
:= Unit_Declaration_Node
(Gen_Body_Id
);
10166 if Nkind
(Gen_Body
) = N_Subprogram_Body_Stub
then
10168 -- Either body is not present, or context is non-expanding, as
10169 -- when compiling a subunit. Mark the instance as completed, and
10170 -- diagnose a missing body when needed.
10173 and then Operating_Mode
= Generate_Code
10176 ("missing proper body for instantiation", Gen_Body
);
10179 Set_Has_Completion
(Anon_Id
);
10183 Save_Env
(Gen_Unit
, Anon_Id
);
10184 Style_Check
:= False;
10185 Current_Sem_Unit
:= Body_Info
.Current_Sem_Unit
;
10186 Create_Instantiation_Source
10194 (Original_Node
(Gen_Body
), Empty
, Instantiating
=> True);
10196 -- Create proper defining name for the body, to correspond to
10197 -- the one in the spec.
10199 Set_Defining_Unit_Name
(Specification
(Act_Body
),
10200 Make_Defining_Identifier
10201 (Sloc
(Defining_Entity
(Inst_Node
)), Chars
(Anon_Id
)));
10202 Set_Corresponding_Spec
(Act_Body
, Anon_Id
);
10203 Set_Has_Completion
(Anon_Id
);
10204 Check_Generic_Actuals
(Pack_Id
, False);
10206 -- Generate a reference to link the visible subprogram instance to
10207 -- the generic body, which for navigation purposes is the only
10208 -- available source for the instance.
10211 (Related_Instance
(Pack_Id
),
10212 Gen_Body_Id
, 'b', Set_Ref
=> False, Force
=> True);
10214 -- If it is a child unit, make the parent instance (which is an
10215 -- instance of the parent of the generic) visible. The parent
10216 -- instance is the prefix of the name of the generic unit.
10218 if Ekind
(Scope
(Gen_Unit
)) = E_Generic_Package
10219 and then Nkind
(Gen_Id
) = N_Expanded_Name
10221 Par_Ent
:= Entity
(Prefix
(Gen_Id
));
10222 Par_Vis
:= Is_Immediately_Visible
(Par_Ent
);
10223 Install_Parent
(Par_Ent
, In_Body
=> True);
10224 Parent_Installed
:= True;
10226 elsif Is_Child_Unit
(Gen_Unit
) then
10227 Par_Ent
:= Scope
(Gen_Unit
);
10228 Par_Vis
:= Is_Immediately_Visible
(Par_Ent
);
10229 Install_Parent
(Par_Ent
, In_Body
=> True);
10230 Parent_Installed
:= True;
10233 -- Inside its body, a reference to the generic unit is a reference
10234 -- to the instance. The corresponding renaming is the first
10235 -- declaration in the body.
10238 Make_Subprogram_Renaming_Declaration
(Loc
,
10240 Copy_Generic_Node
(
10241 Specification
(Original_Node
(Gen_Body
)),
10243 Instantiating
=> True),
10244 Name
=> New_Occurrence_Of
(Anon_Id
, Loc
));
10246 -- If there is a formal subprogram with the same name as the unit
10247 -- itself, do not add this renaming declaration. This is a temporary
10248 -- fix for one ACVC test. ???
10250 Prev_Formal
:= First_Entity
(Pack_Id
);
10251 while Present
(Prev_Formal
) loop
10252 if Chars
(Prev_Formal
) = Chars
(Gen_Unit
)
10253 and then Is_Overloadable
(Prev_Formal
)
10258 Next_Entity
(Prev_Formal
);
10261 if Present
(Prev_Formal
) then
10262 Decls
:= New_List
(Act_Body
);
10264 Decls
:= New_List
(Unit_Renaming
, Act_Body
);
10267 -- The subprogram body is placed in the body of a dummy package body,
10268 -- whose spec contains the subprogram declaration as well as the
10269 -- renaming declarations for the generic parameters.
10271 Pack_Body
:= Make_Package_Body
(Loc
,
10272 Defining_Unit_Name
=> New_Copy
(Pack_Id
),
10273 Declarations
=> Decls
);
10275 Set_Corresponding_Spec
(Pack_Body
, Pack_Id
);
10277 -- If the instantiation is a library unit, then build resulting
10278 -- compilation unit nodes for the instance. The declaration of
10279 -- the enclosing package is the grandparent of the subprogram
10280 -- declaration. First replace the instantiation node as the unit
10281 -- of the corresponding compilation.
10283 if Nkind
(Parent
(Inst_Node
)) = N_Compilation_Unit
then
10284 if Parent
(Inst_Node
) = Cunit
(Main_Unit
) then
10285 Set_Unit
(Parent
(Inst_Node
), Inst_Node
);
10286 Build_Instance_Compilation_Unit_Nodes
10287 (Inst_Node
, Pack_Body
, Parent
(Parent
(Act_Decl
)));
10288 Analyze
(Inst_Node
);
10290 Set_Parent
(Pack_Body
, Parent
(Inst_Node
));
10291 Analyze
(Pack_Body
);
10295 Insert_Before
(Inst_Node
, Pack_Body
);
10296 Mark_Rewrite_Insertion
(Pack_Body
);
10297 Analyze
(Pack_Body
);
10299 if Expander_Active
then
10300 Freeze_Subprogram_Body
(Inst_Node
, Gen_Body
, Pack_Id
);
10304 Inherit_Context
(Gen_Body
, Inst_Node
);
10306 Restore_Private_Views
(Pack_Id
, False);
10308 if Parent_Installed
then
10309 Remove_Parent
(In_Body
=> True);
10311 -- Restore the previous visibility of the parent
10313 Set_Is_Immediately_Visible
(Par_Ent
, Par_Vis
);
10317 Style_Check
:= Save_Style_Check
;
10319 -- Body not found. Error was emitted already. If there were no previous
10320 -- errors, this may be an instance whose scope is a premature instance.
10321 -- In that case we must insure that the (legal) program does raise
10322 -- program error if executed. We generate a subprogram body for this
10323 -- purpose. See DEC ac30vso.
10325 -- Should not reference proprietary DEC tests in comments ???
10327 elsif Serious_Errors_Detected
= 0
10328 and then Nkind
(Parent
(Inst_Node
)) /= N_Compilation_Unit
10330 if Body_Optional
then
10333 elsif Ekind
(Anon_Id
) = E_Procedure
then
10335 Make_Subprogram_Body
(Loc
,
10337 Make_Procedure_Specification
(Loc
,
10338 Defining_Unit_Name
=>
10339 Make_Defining_Identifier
(Loc
, Chars
(Anon_Id
)),
10340 Parameter_Specifications
=>
10342 (Parameter_Specifications
(Parent
(Anon_Id
)))),
10344 Declarations
=> Empty_List
,
10345 Handled_Statement_Sequence
=>
10346 Make_Handled_Sequence_Of_Statements
(Loc
,
10349 Make_Raise_Program_Error
(Loc
,
10351 PE_Access_Before_Elaboration
))));
10355 Make_Raise_Program_Error
(Loc
,
10356 Reason
=> PE_Access_Before_Elaboration
);
10358 Set_Etype
(Ret_Expr
, (Etype
(Anon_Id
)));
10359 Set_Analyzed
(Ret_Expr
);
10362 Make_Subprogram_Body
(Loc
,
10364 Make_Function_Specification
(Loc
,
10365 Defining_Unit_Name
=>
10366 Make_Defining_Identifier
(Loc
, Chars
(Anon_Id
)),
10367 Parameter_Specifications
=>
10369 (Parameter_Specifications
(Parent
(Anon_Id
))),
10370 Result_Definition
=>
10371 New_Occurrence_Of
(Etype
(Anon_Id
), Loc
)),
10373 Declarations
=> Empty_List
,
10374 Handled_Statement_Sequence
=>
10375 Make_Handled_Sequence_Of_Statements
(Loc
,
10378 (Make_Simple_Return_Statement
(Loc
, Ret_Expr
))));
10381 Pack_Body
:= Make_Package_Body
(Loc
,
10382 Defining_Unit_Name
=> New_Copy
(Pack_Id
),
10383 Declarations
=> New_List
(Act_Body
));
10385 Insert_After
(Inst_Node
, Pack_Body
);
10386 Set_Corresponding_Spec
(Pack_Body
, Pack_Id
);
10387 Analyze
(Pack_Body
);
10390 Expander_Mode_Restore
;
10391 end Instantiate_Subprogram_Body
;
10393 ----------------------
10394 -- Instantiate_Type --
10395 ----------------------
10397 function Instantiate_Type
10400 Analyzed_Formal
: Node_Id
;
10401 Actual_Decls
: List_Id
) return List_Id
10403 Gen_T
: constant Entity_Id
:= Defining_Identifier
(Formal
);
10404 A_Gen_T
: constant Entity_Id
:=
10405 Defining_Identifier
(Analyzed_Formal
);
10406 Ancestor
: Entity_Id
:= Empty
;
10407 Def
: constant Node_Id
:= Formal_Type_Definition
(Formal
);
10409 Decl_Node
: Node_Id
;
10410 Decl_Nodes
: List_Id
;
10414 procedure Validate_Array_Type_Instance
;
10415 procedure Validate_Access_Subprogram_Instance
;
10416 procedure Validate_Access_Type_Instance
;
10417 procedure Validate_Derived_Type_Instance
;
10418 procedure Validate_Derived_Interface_Type_Instance
;
10419 procedure Validate_Discriminated_Formal_Type
;
10420 procedure Validate_Interface_Type_Instance
;
10421 procedure Validate_Private_Type_Instance
;
10422 procedure Validate_Incomplete_Type_Instance
;
10423 -- These procedures perform validation tests for the named case.
10424 -- Validate_Discriminated_Formal_Type is shared by formal private
10425 -- types and Ada 2012 formal incomplete types.
10427 function Subtypes_Match
(Gen_T
, Act_T
: Entity_Id
) return Boolean;
10428 -- Check that base types are the same and that the subtypes match
10429 -- statically. Used in several of the above.
10431 --------------------
10432 -- Subtypes_Match --
10433 --------------------
10435 function Subtypes_Match
(Gen_T
, Act_T
: Entity_Id
) return Boolean is
10436 T
: constant Entity_Id
:= Get_Instance_Of
(Gen_T
);
10439 return (Base_Type
(T
) = Base_Type
(Act_T
)
10440 and then Subtypes_Statically_Match
(T
, Act_T
))
10442 or else (Is_Class_Wide_Type
(Gen_T
)
10443 and then Is_Class_Wide_Type
(Act_T
)
10446 (Get_Instance_Of
(Root_Type
(Gen_T
)),
10447 Root_Type
(Act_T
)))
10450 ((Ekind
(Gen_T
) = E_Anonymous_Access_Subprogram_Type
10451 or else Ekind
(Gen_T
) = E_Anonymous_Access_Type
)
10452 and then Ekind
(Act_T
) = Ekind
(Gen_T
)
10454 Subtypes_Statically_Match
10455 (Designated_Type
(Gen_T
), Designated_Type
(Act_T
)));
10456 end Subtypes_Match
;
10458 -----------------------------------------
10459 -- Validate_Access_Subprogram_Instance --
10460 -----------------------------------------
10462 procedure Validate_Access_Subprogram_Instance
is
10464 if not Is_Access_Type
(Act_T
)
10465 or else Ekind
(Designated_Type
(Act_T
)) /= E_Subprogram_Type
10468 ("expect access type in instantiation of &", Actual
, Gen_T
);
10469 Abandon_Instantiation
(Actual
);
10472 -- According to AI05-288, actuals for access_to_subprograms must be
10473 -- subtype conformant with the generic formal. Previous to AI05-288
10474 -- only mode conformance was required.
10476 -- This is a binding interpretation that applies to previous versions
10477 -- of the language, but for now we retain the milder check in order
10478 -- to preserve ACATS tests.
10479 -- These will be protested eventually ???
10481 if Ada_Version
< Ada_2012
then
10482 Check_Mode_Conformant
10483 (Designated_Type
(Act_T
),
10484 Designated_Type
(A_Gen_T
),
10489 Check_Subtype_Conformant
10490 (Designated_Type
(Act_T
),
10491 Designated_Type
(A_Gen_T
),
10496 if Ekind
(Base_Type
(Act_T
)) = E_Access_Protected_Subprogram_Type
then
10497 if Ekind
(A_Gen_T
) = E_Access_Subprogram_Type
then
10499 ("protected access type not allowed for formal &",
10503 elsif Ekind
(A_Gen_T
) = E_Access_Protected_Subprogram_Type
then
10505 ("expect protected access type for formal &",
10508 end Validate_Access_Subprogram_Instance
;
10510 -----------------------------------
10511 -- Validate_Access_Type_Instance --
10512 -----------------------------------
10514 procedure Validate_Access_Type_Instance
is
10515 Desig_Type
: constant Entity_Id
:=
10516 Find_Actual_Type
(Designated_Type
(A_Gen_T
), A_Gen_T
);
10517 Desig_Act
: Entity_Id
;
10520 if not Is_Access_Type
(Act_T
) then
10522 ("expect access type in instantiation of &", Actual
, Gen_T
);
10523 Abandon_Instantiation
(Actual
);
10526 if Is_Access_Constant
(A_Gen_T
) then
10527 if not Is_Access_Constant
(Act_T
) then
10529 ("actual type must be access-to-constant type", Actual
);
10530 Abandon_Instantiation
(Actual
);
10533 if Is_Access_Constant
(Act_T
) then
10535 ("actual type must be access-to-variable type", Actual
);
10536 Abandon_Instantiation
(Actual
);
10538 elsif Ekind
(A_Gen_T
) = E_General_Access_Type
10539 and then Ekind
(Base_Type
(Act_T
)) /= E_General_Access_Type
10541 Error_Msg_N
-- CODEFIX
10542 ("actual must be general access type!", Actual
);
10543 Error_Msg_NE
-- CODEFIX
10544 ("add ALL to }!", Actual
, Act_T
);
10545 Abandon_Instantiation
(Actual
);
10549 -- The designated subtypes, that is to say the subtypes introduced
10550 -- by an access type declaration (and not by a subtype declaration)
10553 Desig_Act
:= Designated_Type
(Base_Type
(Act_T
));
10555 -- The designated type may have been introduced through a limited_
10556 -- with clause, in which case retrieve the non-limited view. This
10557 -- applies to incomplete types as well as to class-wide types.
10559 if From_With_Type
(Desig_Act
) then
10560 Desig_Act
:= Available_View
(Desig_Act
);
10563 if not Subtypes_Match
10564 (Desig_Type
, Desig_Act
) then
10566 ("designated type of actual does not match that of formal &",
10568 Abandon_Instantiation
(Actual
);
10570 elsif Is_Access_Type
(Designated_Type
(Act_T
))
10571 and then Is_Constrained
(Designated_Type
(Designated_Type
(Act_T
)))
10573 Is_Constrained
(Designated_Type
(Desig_Type
))
10576 ("designated type of actual does not match that of formal &",
10578 Abandon_Instantiation
(Actual
);
10581 -- Ada 2005: null-exclusion indicators of the two types must agree
10583 if Can_Never_Be_Null
(A_Gen_T
) /= Can_Never_Be_Null
(Act_T
) then
10585 ("non null exclusion of actual and formal & do not match",
10588 end Validate_Access_Type_Instance
;
10590 ----------------------------------
10591 -- Validate_Array_Type_Instance --
10592 ----------------------------------
10594 procedure Validate_Array_Type_Instance
is
10599 function Formal_Dimensions
return Int
;
10600 -- Count number of dimensions in array type formal
10602 -----------------------
10603 -- Formal_Dimensions --
10604 -----------------------
10606 function Formal_Dimensions
return Int
is
10611 if Nkind
(Def
) = N_Constrained_Array_Definition
then
10612 Index
:= First
(Discrete_Subtype_Definitions
(Def
));
10614 Index
:= First
(Subtype_Marks
(Def
));
10617 while Present
(Index
) loop
10619 Next_Index
(Index
);
10623 end Formal_Dimensions
;
10625 -- Start of processing for Validate_Array_Type_Instance
10628 if not Is_Array_Type
(Act_T
) then
10630 ("expect array type in instantiation of &", Actual
, Gen_T
);
10631 Abandon_Instantiation
(Actual
);
10633 elsif Nkind
(Def
) = N_Constrained_Array_Definition
then
10634 if not (Is_Constrained
(Act_T
)) then
10636 ("expect constrained array in instantiation of &",
10638 Abandon_Instantiation
(Actual
);
10642 if Is_Constrained
(Act_T
) then
10644 ("expect unconstrained array in instantiation of &",
10646 Abandon_Instantiation
(Actual
);
10650 if Formal_Dimensions
/= Number_Dimensions
(Act_T
) then
10652 ("dimensions of actual do not match formal &", Actual
, Gen_T
);
10653 Abandon_Instantiation
(Actual
);
10656 I1
:= First_Index
(A_Gen_T
);
10657 I2
:= First_Index
(Act_T
);
10658 for J
in 1 .. Formal_Dimensions
loop
10660 -- If the indexes of the actual were given by a subtype_mark,
10661 -- the index was transformed into a range attribute. Retrieve
10662 -- the original type mark for checking.
10664 if Is_Entity_Name
(Original_Node
(I2
)) then
10665 T2
:= Entity
(Original_Node
(I2
));
10670 if not Subtypes_Match
10671 (Find_Actual_Type
(Etype
(I1
), A_Gen_T
), T2
)
10674 ("index types of actual do not match those of formal &",
10676 Abandon_Instantiation
(Actual
);
10683 -- Check matching subtypes. Note that there are complex visibility
10684 -- issues when the generic is a child unit and some aspect of the
10685 -- generic type is declared in a parent unit of the generic. We do
10686 -- the test to handle this special case only after a direct check
10687 -- for static matching has failed.
10690 (Component_Type
(A_Gen_T
), Component_Type
(Act_T
))
10691 or else Subtypes_Match
10692 (Find_Actual_Type
(Component_Type
(A_Gen_T
), A_Gen_T
),
10693 Component_Type
(Act_T
))
10698 ("component subtype of actual does not match that of formal &",
10700 Abandon_Instantiation
(Actual
);
10703 if Has_Aliased_Components
(A_Gen_T
)
10704 and then not Has_Aliased_Components
(Act_T
)
10707 ("actual must have aliased components to match formal type &",
10710 end Validate_Array_Type_Instance
;
10712 -----------------------------------------------
10713 -- Validate_Derived_Interface_Type_Instance --
10714 -----------------------------------------------
10716 procedure Validate_Derived_Interface_Type_Instance
is
10717 Par
: constant Entity_Id
:= Entity
(Subtype_Indication
(Def
));
10721 -- First apply interface instance checks
10723 Validate_Interface_Type_Instance
;
10725 -- Verify that immediate parent interface is an ancestor of
10729 and then not Interface_Present_In_Ancestor
(Act_T
, Par
)
10732 ("interface actual must include progenitor&", Actual
, Par
);
10735 -- Now verify that the actual includes all other ancestors of
10738 Elmt
:= First_Elmt
(Interfaces
(A_Gen_T
));
10739 while Present
(Elmt
) loop
10740 if not Interface_Present_In_Ancestor
10741 (Act_T
, Get_Instance_Of
(Node
(Elmt
)))
10744 ("interface actual must include progenitor&",
10745 Actual
, Node
(Elmt
));
10750 end Validate_Derived_Interface_Type_Instance
;
10752 ------------------------------------
10753 -- Validate_Derived_Type_Instance --
10754 ------------------------------------
10756 procedure Validate_Derived_Type_Instance
is
10757 Actual_Discr
: Entity_Id
;
10758 Ancestor_Discr
: Entity_Id
;
10761 -- If the parent type in the generic declaration is itself a previous
10762 -- formal type, then it is local to the generic and absent from the
10763 -- analyzed generic definition. In that case the ancestor is the
10764 -- instance of the formal (which must have been instantiated
10765 -- previously), unless the ancestor is itself a formal derived type.
10766 -- In this latter case (which is the subject of Corrigendum 8652/0038
10767 -- (AI-202) the ancestor of the formals is the ancestor of its
10768 -- parent. Otherwise, the analyzed generic carries the parent type.
10769 -- If the parent type is defined in a previous formal package, then
10770 -- the scope of that formal package is that of the generic type
10771 -- itself, and it has already been mapped into the corresponding type
10772 -- in the actual package.
10774 -- Common case: parent type defined outside of the generic
10776 if Is_Entity_Name
(Subtype_Mark
(Def
))
10777 and then Present
(Entity
(Subtype_Mark
(Def
)))
10779 Ancestor
:= Get_Instance_Of
(Entity
(Subtype_Mark
(Def
)));
10781 -- Check whether parent is defined in a previous formal package
10784 Scope
(Scope
(Base_Type
(Etype
(A_Gen_T
)))) = Scope
(A_Gen_T
)
10787 Get_Instance_Of
(Base_Type
(Etype
(A_Gen_T
)));
10789 -- The type may be a local derivation, or a type extension of a
10790 -- previous formal, or of a formal of a parent package.
10792 elsif Is_Derived_Type
(Get_Instance_Of
(A_Gen_T
))
10794 Ekind
(Get_Instance_Of
(A_Gen_T
)) = E_Record_Type_With_Private
10796 -- Check whether the parent is another derived formal type in the
10797 -- same generic unit.
10799 if Etype
(A_Gen_T
) /= A_Gen_T
10800 and then Is_Generic_Type
(Etype
(A_Gen_T
))
10801 and then Scope
(Etype
(A_Gen_T
)) = Scope
(A_Gen_T
)
10802 and then Etype
(Etype
(A_Gen_T
)) /= Etype
(A_Gen_T
)
10804 -- Locate ancestor of parent from the subtype declaration
10805 -- created for the actual.
10811 Decl
:= First
(Actual_Decls
);
10812 while Present
(Decl
) loop
10813 if Nkind
(Decl
) = N_Subtype_Declaration
10814 and then Chars
(Defining_Identifier
(Decl
)) =
10815 Chars
(Etype
(A_Gen_T
))
10817 Ancestor
:= Generic_Parent_Type
(Decl
);
10825 pragma Assert
(Present
(Ancestor
));
10827 -- The ancestor itself may be a previous formal that has been
10830 Ancestor
:= Get_Instance_Of
(Ancestor
);
10834 Get_Instance_Of
(Base_Type
(Get_Instance_Of
(A_Gen_T
)));
10837 -- An unusual case: the actual is a type declared in a parent unit,
10838 -- but is not a formal type so there is no instance_of for it.
10839 -- Retrieve it by analyzing the record extension.
10841 elsif Is_Child_Unit
(Scope
(A_Gen_T
))
10842 and then In_Open_Scopes
(Scope
(Act_T
))
10843 and then Is_Generic_Instance
(Scope
(Act_T
))
10845 Analyze
(Subtype_Mark
(Def
));
10846 Ancestor
:= Entity
(Subtype_Mark
(Def
));
10849 Ancestor
:= Get_Instance_Of
(Etype
(Base_Type
(A_Gen_T
)));
10852 -- If the formal derived type has pragma Preelaborable_Initialization
10853 -- then the actual type must have preelaborable initialization.
10855 if Known_To_Have_Preelab_Init
(A_Gen_T
)
10856 and then not Has_Preelaborable_Initialization
(Act_T
)
10859 ("actual for & must have preelaborable initialization",
10863 -- Ada 2005 (AI-251)
10865 if Ada_Version
>= Ada_2005
10866 and then Is_Interface
(Ancestor
)
10868 if not Interface_Present_In_Ancestor
(Act_T
, Ancestor
) then
10870 ("(Ada 2005) expected type implementing & in instantiation",
10874 elsif not Is_Ancestor
(Base_Type
(Ancestor
), Act_T
) then
10876 ("expect type derived from & in instantiation",
10877 Actual
, First_Subtype
(Ancestor
));
10878 Abandon_Instantiation
(Actual
);
10881 -- Ada 2005 (AI-443): Synchronized formal derived type checks. Note
10882 -- that the formal type declaration has been rewritten as a private
10885 if Ada_Version
>= Ada_2005
10886 and then Nkind
(Parent
(A_Gen_T
)) = N_Private_Extension_Declaration
10887 and then Synchronized_Present
(Parent
(A_Gen_T
))
10889 -- The actual must be a synchronized tagged type
10891 if not Is_Tagged_Type
(Act_T
) then
10893 ("actual of synchronized type must be tagged", Actual
);
10894 Abandon_Instantiation
(Actual
);
10896 elsif Nkind
(Parent
(Act_T
)) = N_Full_Type_Declaration
10897 and then Nkind
(Type_Definition
(Parent
(Act_T
))) =
10898 N_Derived_Type_Definition
10899 and then not Synchronized_Present
(Type_Definition
10903 ("actual of synchronized type must be synchronized", Actual
);
10904 Abandon_Instantiation
(Actual
);
10908 -- Perform atomic/volatile checks (RM C.6(12)). Note that AI05-0218-1
10909 -- removes the second instance of the phrase "or allow pass by copy".
10911 if Is_Atomic
(Act_T
) and then not Is_Atomic
(Ancestor
) then
10913 ("cannot have atomic actual type for non-atomic formal type",
10916 elsif Is_Volatile
(Act_T
) and then not Is_Volatile
(Ancestor
) then
10918 ("cannot have volatile actual type for non-volatile formal type",
10922 -- It should not be necessary to check for unknown discriminants on
10923 -- Formal, but for some reason Has_Unknown_Discriminants is false for
10924 -- A_Gen_T, so Is_Indefinite_Subtype incorrectly returns False. This
10925 -- needs fixing. ???
10927 if not Is_Indefinite_Subtype
(A_Gen_T
)
10928 and then not Unknown_Discriminants_Present
(Formal
)
10929 and then Is_Indefinite_Subtype
(Act_T
)
10932 ("actual subtype must be constrained", Actual
);
10933 Abandon_Instantiation
(Actual
);
10936 if not Unknown_Discriminants_Present
(Formal
) then
10937 if Is_Constrained
(Ancestor
) then
10938 if not Is_Constrained
(Act_T
) then
10940 ("actual subtype must be constrained", Actual
);
10941 Abandon_Instantiation
(Actual
);
10944 -- Ancestor is unconstrained, Check if generic formal and actual
10945 -- agree on constrainedness. The check only applies to array types
10946 -- and discriminated types.
10948 elsif Is_Constrained
(Act_T
) then
10949 if Ekind
(Ancestor
) = E_Access_Type
10951 (not Is_Constrained
(A_Gen_T
)
10952 and then Is_Composite_Type
(A_Gen_T
))
10955 ("actual subtype must be unconstrained", Actual
);
10956 Abandon_Instantiation
(Actual
);
10959 -- A class-wide type is only allowed if the formal has unknown
10962 elsif Is_Class_Wide_Type
(Act_T
)
10963 and then not Has_Unknown_Discriminants
(Ancestor
)
10966 ("actual for & cannot be a class-wide type", Actual
, Gen_T
);
10967 Abandon_Instantiation
(Actual
);
10969 -- Otherwise, the formal and actual shall have the same number
10970 -- of discriminants and each discriminant of the actual must
10971 -- correspond to a discriminant of the formal.
10973 elsif Has_Discriminants
(Act_T
)
10974 and then not Has_Unknown_Discriminants
(Act_T
)
10975 and then Has_Discriminants
(Ancestor
)
10977 Actual_Discr
:= First_Discriminant
(Act_T
);
10978 Ancestor_Discr
:= First_Discriminant
(Ancestor
);
10979 while Present
(Actual_Discr
)
10980 and then Present
(Ancestor_Discr
)
10982 if Base_Type
(Act_T
) /= Base_Type
(Ancestor
) and then
10983 No
(Corresponding_Discriminant
(Actual_Discr
))
10986 ("discriminant & does not correspond " &
10987 "to ancestor discriminant", Actual
, Actual_Discr
);
10988 Abandon_Instantiation
(Actual
);
10991 Next_Discriminant
(Actual_Discr
);
10992 Next_Discriminant
(Ancestor_Discr
);
10995 if Present
(Actual_Discr
) or else Present
(Ancestor_Discr
) then
10997 ("actual for & must have same number of discriminants",
10999 Abandon_Instantiation
(Actual
);
11002 -- This case should be caught by the earlier check for
11003 -- constrainedness, but the check here is added for completeness.
11005 elsif Has_Discriminants
(Act_T
)
11006 and then not Has_Unknown_Discriminants
(Act_T
)
11009 ("actual for & must not have discriminants", Actual
, Gen_T
);
11010 Abandon_Instantiation
(Actual
);
11012 elsif Has_Discriminants
(Ancestor
) then
11014 ("actual for & must have known discriminants", Actual
, Gen_T
);
11015 Abandon_Instantiation
(Actual
);
11018 if not Subtypes_Statically_Compatible
(Act_T
, Ancestor
) then
11020 ("constraint on actual is incompatible with formal", Actual
);
11021 Abandon_Instantiation
(Actual
);
11025 -- If the formal and actual types are abstract, check that there
11026 -- are no abstract primitives of the actual type that correspond to
11027 -- nonabstract primitives of the formal type (second sentence of
11030 if Is_Abstract_Type
(A_Gen_T
) and then Is_Abstract_Type
(Act_T
) then
11031 Check_Abstract_Primitives
: declare
11032 Gen_Prims
: constant Elist_Id
:=
11033 Primitive_Operations
(A_Gen_T
);
11034 Gen_Elmt
: Elmt_Id
;
11035 Gen_Subp
: Entity_Id
;
11036 Anc_Subp
: Entity_Id
;
11037 Anc_Formal
: Entity_Id
;
11038 Anc_F_Type
: Entity_Id
;
11040 Act_Prims
: constant Elist_Id
:= Primitive_Operations
(Act_T
);
11041 Act_Elmt
: Elmt_Id
;
11042 Act_Subp
: Entity_Id
;
11043 Act_Formal
: Entity_Id
;
11044 Act_F_Type
: Entity_Id
;
11046 Subprograms_Correspond
: Boolean;
11048 function Is_Tagged_Ancestor
(T1
, T2
: Entity_Id
) return Boolean;
11049 -- Returns true if T2 is derived directly or indirectly from
11050 -- T1, including derivations from interfaces. T1 and T2 are
11051 -- required to be specific tagged base types.
11053 ------------------------
11054 -- Is_Tagged_Ancestor --
11055 ------------------------
11057 function Is_Tagged_Ancestor
(T1
, T2
: Entity_Id
) return Boolean
11059 Intfc_Elmt
: Elmt_Id
;
11062 -- The predicate is satisfied if the types are the same
11067 -- If we've reached the top of the derivation chain then
11068 -- we know that T1 is not an ancestor of T2.
11070 elsif Etype
(T2
) = T2
then
11073 -- Proceed to check T2's immediate parent
11075 elsif Is_Ancestor
(T1
, Base_Type
(Etype
(T2
))) then
11078 -- Finally, check to see if T1 is an ancestor of any of T2's
11082 Intfc_Elmt
:= First_Elmt
(Interfaces
(T2
));
11083 while Present
(Intfc_Elmt
) loop
11084 if Is_Ancestor
(T1
, Node
(Intfc_Elmt
)) then
11088 Next_Elmt
(Intfc_Elmt
);
11093 end Is_Tagged_Ancestor
;
11095 -- Start of processing for Check_Abstract_Primitives
11098 -- Loop over all of the formal derived type's primitives
11100 Gen_Elmt
:= First_Elmt
(Gen_Prims
);
11101 while Present
(Gen_Elmt
) loop
11102 Gen_Subp
:= Node
(Gen_Elmt
);
11104 -- If the primitive of the formal is not abstract, then
11105 -- determine whether there is a corresponding primitive of
11106 -- the actual type that's abstract.
11108 if not Is_Abstract_Subprogram
(Gen_Subp
) then
11109 Act_Elmt
:= First_Elmt
(Act_Prims
);
11110 while Present
(Act_Elmt
) loop
11111 Act_Subp
:= Node
(Act_Elmt
);
11113 -- If we find an abstract primitive of the actual,
11114 -- then we need to test whether it corresponds to the
11115 -- subprogram from which the generic formal primitive
11118 if Is_Abstract_Subprogram
(Act_Subp
) then
11119 Anc_Subp
:= Alias
(Gen_Subp
);
11121 -- Test whether we have a corresponding primitive
11122 -- by comparing names, kinds, formal types, and
11125 if Chars
(Anc_Subp
) = Chars
(Act_Subp
)
11126 and then Ekind
(Anc_Subp
) = Ekind
(Act_Subp
)
11128 Anc_Formal
:= First_Formal
(Anc_Subp
);
11129 Act_Formal
:= First_Formal
(Act_Subp
);
11130 while Present
(Anc_Formal
)
11131 and then Present
(Act_Formal
)
11133 Anc_F_Type
:= Etype
(Anc_Formal
);
11134 Act_F_Type
:= Etype
(Act_Formal
);
11136 if Ekind
(Anc_F_Type
)
11137 = E_Anonymous_Access_Type
11139 Anc_F_Type
:= Designated_Type
(Anc_F_Type
);
11141 if Ekind
(Act_F_Type
)
11142 = E_Anonymous_Access_Type
11145 Designated_Type
(Act_F_Type
);
11151 Ekind
(Act_F_Type
) = E_Anonymous_Access_Type
11156 Anc_F_Type
:= Base_Type
(Anc_F_Type
);
11157 Act_F_Type
:= Base_Type
(Act_F_Type
);
11159 -- If the formal is controlling, then the
11160 -- the type of the actual primitive's formal
11161 -- must be derived directly or indirectly
11162 -- from the type of the ancestor primitive's
11165 if Is_Controlling_Formal
(Anc_Formal
) then
11166 if not Is_Tagged_Ancestor
11167 (Anc_F_Type
, Act_F_Type
)
11172 -- Otherwise the types of the formals must
11175 elsif Anc_F_Type
/= Act_F_Type
then
11179 Next_Entity
(Anc_Formal
);
11180 Next_Entity
(Act_Formal
);
11183 -- If we traversed through all of the formals
11184 -- then so far the subprograms correspond, so
11185 -- now check that any result types correspond.
11187 if No
(Anc_Formal
) and then No
(Act_Formal
) then
11188 Subprograms_Correspond
:= True;
11190 if Ekind
(Act_Subp
) = E_Function
then
11191 Anc_F_Type
:= Etype
(Anc_Subp
);
11192 Act_F_Type
:= Etype
(Act_Subp
);
11194 if Ekind
(Anc_F_Type
)
11195 = E_Anonymous_Access_Type
11198 Designated_Type
(Anc_F_Type
);
11200 if Ekind
(Act_F_Type
)
11201 = E_Anonymous_Access_Type
11204 Designated_Type
(Act_F_Type
);
11206 Subprograms_Correspond
:= False;
11211 = E_Anonymous_Access_Type
11213 Subprograms_Correspond
:= False;
11216 Anc_F_Type
:= Base_Type
(Anc_F_Type
);
11217 Act_F_Type
:= Base_Type
(Act_F_Type
);
11219 -- Now either the result types must be
11220 -- the same or, if the result type is
11221 -- controlling, the result type of the
11222 -- actual primitive must descend from the
11223 -- result type of the ancestor primitive.
11225 if Subprograms_Correspond
11226 and then Anc_F_Type
/= Act_F_Type
11228 Has_Controlling_Result
(Anc_Subp
)
11230 not Is_Tagged_Ancestor
11231 (Anc_F_Type
, Act_F_Type
)
11233 Subprograms_Correspond
:= False;
11237 -- Found a matching subprogram belonging to
11238 -- formal ancestor type, so actual subprogram
11239 -- corresponds and this violates 3.9.3(9).
11241 if Subprograms_Correspond
then
11243 ("abstract subprogram & overrides " &
11244 "nonabstract subprogram of ancestor",
11252 Next_Elmt
(Act_Elmt
);
11256 Next_Elmt
(Gen_Elmt
);
11258 end Check_Abstract_Primitives
;
11261 -- Verify that limitedness matches. If parent is a limited
11262 -- interface then the generic formal is not unless declared
11263 -- explicitly so. If not declared limited, the actual cannot be
11264 -- limited (see AI05-0087).
11266 -- Even though this AI is a binding interpretation, we enable the
11267 -- check only in Ada 2012 mode, because this improper construct
11268 -- shows up in user code and in existing B-tests.
11270 if Is_Limited_Type
(Act_T
)
11271 and then not Is_Limited_Type
(A_Gen_T
)
11272 and then Ada_Version
>= Ada_2012
11274 if In_Instance
then
11278 ("actual for non-limited & cannot be a limited type", Actual
,
11280 Explain_Limited_Type
(Act_T
, Actual
);
11281 Abandon_Instantiation
(Actual
);
11284 end Validate_Derived_Type_Instance
;
11286 ----------------------------------------
11287 -- Validate_Discriminated_Formal_Type --
11288 ----------------------------------------
11290 procedure Validate_Discriminated_Formal_Type
is
11291 Formal_Discr
: Entity_Id
;
11292 Actual_Discr
: Entity_Id
;
11293 Formal_Subt
: Entity_Id
;
11296 if Has_Discriminants
(A_Gen_T
) then
11297 if not Has_Discriminants
(Act_T
) then
11299 ("actual for & must have discriminants", Actual
, Gen_T
);
11300 Abandon_Instantiation
(Actual
);
11302 elsif Is_Constrained
(Act_T
) then
11304 ("actual for & must be unconstrained", Actual
, Gen_T
);
11305 Abandon_Instantiation
(Actual
);
11308 Formal_Discr
:= First_Discriminant
(A_Gen_T
);
11309 Actual_Discr
:= First_Discriminant
(Act_T
);
11310 while Formal_Discr
/= Empty
loop
11311 if Actual_Discr
= Empty
then
11313 ("discriminants on actual do not match formal",
11315 Abandon_Instantiation
(Actual
);
11318 Formal_Subt
:= Get_Instance_Of
(Etype
(Formal_Discr
));
11320 -- Access discriminants match if designated types do
11322 if Ekind
(Base_Type
(Formal_Subt
)) = E_Anonymous_Access_Type
11323 and then (Ekind
(Base_Type
(Etype
(Actual_Discr
)))) =
11324 E_Anonymous_Access_Type
11327 (Designated_Type
(Base_Type
(Formal_Subt
))) =
11328 Designated_Type
(Base_Type
(Etype
(Actual_Discr
)))
11332 elsif Base_Type
(Formal_Subt
) /=
11333 Base_Type
(Etype
(Actual_Discr
))
11336 ("types of actual discriminants must match formal",
11338 Abandon_Instantiation
(Actual
);
11340 elsif not Subtypes_Statically_Match
11341 (Formal_Subt
, Etype
(Actual_Discr
))
11342 and then Ada_Version
>= Ada_95
11345 ("subtypes of actual discriminants must match formal",
11347 Abandon_Instantiation
(Actual
);
11350 Next_Discriminant
(Formal_Discr
);
11351 Next_Discriminant
(Actual_Discr
);
11354 if Actual_Discr
/= Empty
then
11356 ("discriminants on actual do not match formal",
11358 Abandon_Instantiation
(Actual
);
11362 end Validate_Discriminated_Formal_Type
;
11364 ---------------------------------------
11365 -- Validate_Incomplete_Type_Instance --
11366 ---------------------------------------
11368 procedure Validate_Incomplete_Type_Instance
is
11370 if not Is_Tagged_Type
(Act_T
)
11371 and then Is_Tagged_Type
(A_Gen_T
)
11374 ("actual for & must be a tagged type", Actual
, Gen_T
);
11377 Validate_Discriminated_Formal_Type
;
11378 end Validate_Incomplete_Type_Instance
;
11380 --------------------------------------
11381 -- Validate_Interface_Type_Instance --
11382 --------------------------------------
11384 procedure Validate_Interface_Type_Instance
is
11386 if not Is_Interface
(Act_T
) then
11388 ("actual for formal interface type must be an interface",
11391 elsif Is_Limited_Type
(Act_T
) /= Is_Limited_Type
(A_Gen_T
)
11393 Is_Task_Interface
(A_Gen_T
) /= Is_Task_Interface
(Act_T
)
11395 Is_Protected_Interface
(A_Gen_T
) /=
11396 Is_Protected_Interface
(Act_T
)
11398 Is_Synchronized_Interface
(A_Gen_T
) /=
11399 Is_Synchronized_Interface
(Act_T
)
11402 ("actual for interface& does not match (RM 12.5.5(4))",
11405 end Validate_Interface_Type_Instance
;
11407 ------------------------------------
11408 -- Validate_Private_Type_Instance --
11409 ------------------------------------
11411 procedure Validate_Private_Type_Instance
is
11413 if Is_Limited_Type
(Act_T
)
11414 and then not Is_Limited_Type
(A_Gen_T
)
11416 if In_Instance
then
11420 ("actual for non-limited & cannot be a limited type", Actual
,
11422 Explain_Limited_Type
(Act_T
, Actual
);
11423 Abandon_Instantiation
(Actual
);
11426 elsif Known_To_Have_Preelab_Init
(A_Gen_T
)
11427 and then not Has_Preelaborable_Initialization
(Act_T
)
11430 ("actual for & must have preelaborable initialization", Actual
,
11433 elsif Is_Indefinite_Subtype
(Act_T
)
11434 and then not Is_Indefinite_Subtype
(A_Gen_T
)
11435 and then Ada_Version
>= Ada_95
11438 ("actual for & must be a definite subtype", Actual
, Gen_T
);
11440 elsif not Is_Tagged_Type
(Act_T
)
11441 and then Is_Tagged_Type
(A_Gen_T
)
11444 ("actual for & must be a tagged type", Actual
, Gen_T
);
11447 Validate_Discriminated_Formal_Type
;
11449 end Validate_Private_Type_Instance
;
11451 -- Start of processing for Instantiate_Type
11454 if Get_Instance_Of
(A_Gen_T
) /= A_Gen_T
then
11455 Error_Msg_N
("duplicate instantiation of generic type", Actual
);
11456 return New_List
(Error
);
11458 elsif not Is_Entity_Name
(Actual
)
11459 or else not Is_Type
(Entity
(Actual
))
11462 ("expect valid subtype mark to instantiate &", Actual
, Gen_T
);
11463 Abandon_Instantiation
(Actual
);
11466 Act_T
:= Entity
(Actual
);
11468 -- Ada 2005 (AI-216): An Unchecked_Union subtype shall only be passed
11469 -- as a generic actual parameter if the corresponding formal type
11470 -- does not have a known_discriminant_part, or is a formal derived
11471 -- type that is an Unchecked_Union type.
11473 if Is_Unchecked_Union
(Base_Type
(Act_T
)) then
11474 if not Has_Discriminants
(A_Gen_T
)
11476 (Is_Derived_Type
(A_Gen_T
)
11478 Is_Unchecked_Union
(A_Gen_T
))
11482 Error_Msg_N
("unchecked union cannot be the actual for a" &
11483 " discriminated formal type", Act_T
);
11488 -- Deal with fixed/floating restrictions
11490 if Is_Floating_Point_Type
(Act_T
) then
11491 Check_Restriction
(No_Floating_Point
, Actual
);
11492 elsif Is_Fixed_Point_Type
(Act_T
) then
11493 Check_Restriction
(No_Fixed_Point
, Actual
);
11496 -- Deal with error of using incomplete type as generic actual.
11497 -- This includes limited views of a type, even if the non-limited
11498 -- view may be available.
11500 if Ekind
(Act_T
) = E_Incomplete_Type
11501 or else (Is_Class_Wide_Type
(Act_T
)
11503 Ekind
(Root_Type
(Act_T
)) = E_Incomplete_Type
)
11505 -- If the formal is an incomplete type, the actual can be
11506 -- incomplete as well.
11508 if Ekind
(A_Gen_T
) = E_Incomplete_Type
then
11511 elsif Is_Class_Wide_Type
(Act_T
)
11512 or else No
(Full_View
(Act_T
))
11514 Error_Msg_N
("premature use of incomplete type", Actual
);
11515 Abandon_Instantiation
(Actual
);
11517 Act_T
:= Full_View
(Act_T
);
11518 Set_Entity
(Actual
, Act_T
);
11520 if Has_Private_Component
(Act_T
) then
11522 ("premature use of type with private component", Actual
);
11526 -- Deal with error of premature use of private type as generic actual
11528 elsif Is_Private_Type
(Act_T
)
11529 and then Is_Private_Type
(Base_Type
(Act_T
))
11530 and then not Is_Generic_Type
(Act_T
)
11531 and then not Is_Derived_Type
(Act_T
)
11532 and then No
(Full_View
(Root_Type
(Act_T
)))
11534 -- If the formal is an incomplete type, the actual can be
11535 -- private or incomplete as well.
11537 if Ekind
(A_Gen_T
) = E_Incomplete_Type
then
11540 Error_Msg_N
("premature use of private type", Actual
);
11543 elsif Has_Private_Component
(Act_T
) then
11545 ("premature use of type with private component", Actual
);
11548 Set_Instance_Of
(A_Gen_T
, Act_T
);
11550 -- If the type is generic, the class-wide type may also be used
11552 if Is_Tagged_Type
(A_Gen_T
)
11553 and then Is_Tagged_Type
(Act_T
)
11554 and then not Is_Class_Wide_Type
(A_Gen_T
)
11556 Set_Instance_Of
(Class_Wide_Type
(A_Gen_T
),
11557 Class_Wide_Type
(Act_T
));
11560 if not Is_Abstract_Type
(A_Gen_T
)
11561 and then Is_Abstract_Type
(Act_T
)
11564 ("actual of non-abstract formal cannot be abstract", Actual
);
11567 -- A generic scalar type is a first subtype for which we generate
11568 -- an anonymous base type. Indicate that the instance of this base
11569 -- is the base type of the actual.
11571 if Is_Scalar_Type
(A_Gen_T
) then
11572 Set_Instance_Of
(Etype
(A_Gen_T
), Etype
(Act_T
));
11576 if Error_Posted
(Act_T
) then
11579 case Nkind
(Def
) is
11580 when N_Formal_Private_Type_Definition
=>
11581 Validate_Private_Type_Instance
;
11583 when N_Formal_Incomplete_Type_Definition
=>
11584 Validate_Incomplete_Type_Instance
;
11586 when N_Formal_Derived_Type_Definition
=>
11587 Validate_Derived_Type_Instance
;
11589 when N_Formal_Discrete_Type_Definition
=>
11590 if not Is_Discrete_Type
(Act_T
) then
11592 ("expect discrete type in instantiation of&",
11594 Abandon_Instantiation
(Actual
);
11597 when N_Formal_Signed_Integer_Type_Definition
=>
11598 if not Is_Signed_Integer_Type
(Act_T
) then
11600 ("expect signed integer type in instantiation of&",
11602 Abandon_Instantiation
(Actual
);
11605 when N_Formal_Modular_Type_Definition
=>
11606 if not Is_Modular_Integer_Type
(Act_T
) then
11608 ("expect modular type in instantiation of &",
11610 Abandon_Instantiation
(Actual
);
11613 when N_Formal_Floating_Point_Definition
=>
11614 if not Is_Floating_Point_Type
(Act_T
) then
11616 ("expect float type in instantiation of &", Actual
, Gen_T
);
11617 Abandon_Instantiation
(Actual
);
11620 when N_Formal_Ordinary_Fixed_Point_Definition
=>
11621 if not Is_Ordinary_Fixed_Point_Type
(Act_T
) then
11623 ("expect ordinary fixed point type in instantiation of &",
11625 Abandon_Instantiation
(Actual
);
11628 when N_Formal_Decimal_Fixed_Point_Definition
=>
11629 if not Is_Decimal_Fixed_Point_Type
(Act_T
) then
11631 ("expect decimal type in instantiation of &",
11633 Abandon_Instantiation
(Actual
);
11636 when N_Array_Type_Definition
=>
11637 Validate_Array_Type_Instance
;
11639 when N_Access_To_Object_Definition
=>
11640 Validate_Access_Type_Instance
;
11642 when N_Access_Function_Definition |
11643 N_Access_Procedure_Definition
=>
11644 Validate_Access_Subprogram_Instance
;
11646 when N_Record_Definition
=>
11647 Validate_Interface_Type_Instance
;
11649 when N_Derived_Type_Definition
=>
11650 Validate_Derived_Interface_Type_Instance
;
11653 raise Program_Error
;
11658 Subt
:= New_Copy
(Gen_T
);
11660 -- Use adjusted sloc of subtype name as the location for other nodes in
11661 -- the subtype declaration.
11663 Loc
:= Sloc
(Subt
);
11666 Make_Subtype_Declaration
(Loc
,
11667 Defining_Identifier
=> Subt
,
11668 Subtype_Indication
=> New_Reference_To
(Act_T
, Loc
));
11670 if Is_Private_Type
(Act_T
) then
11671 Set_Has_Private_View
(Subtype_Indication
(Decl_Node
));
11673 elsif Is_Access_Type
(Act_T
)
11674 and then Is_Private_Type
(Designated_Type
(Act_T
))
11676 Set_Has_Private_View
(Subtype_Indication
(Decl_Node
));
11679 Decl_Nodes
:= New_List
(Decl_Node
);
11681 -- Flag actual derived types so their elaboration produces the
11682 -- appropriate renamings for the primitive operations of the ancestor.
11683 -- Flag actual for formal private types as well, to determine whether
11684 -- operations in the private part may override inherited operations.
11685 -- If the formal has an interface list, the ancestor is not the
11686 -- parent, but the analyzed formal that includes the interface
11687 -- operations of all its progenitors.
11689 -- Same treatment for formal private types, so we can check whether the
11690 -- type is tagged limited when validating derivations in the private
11691 -- part. (See AI05-096).
11693 if Nkind
(Def
) = N_Formal_Derived_Type_Definition
then
11694 if Present
(Interface_List
(Def
)) then
11695 Set_Generic_Parent_Type
(Decl_Node
, A_Gen_T
);
11697 Set_Generic_Parent_Type
(Decl_Node
, Ancestor
);
11700 elsif Nkind_In
(Def
,
11701 N_Formal_Private_Type_Definition
,
11702 N_Formal_Incomplete_Type_Definition
)
11704 Set_Generic_Parent_Type
(Decl_Node
, A_Gen_T
);
11707 -- If the actual is a synchronized type that implements an interface,
11708 -- the primitive operations are attached to the corresponding record,
11709 -- and we have to treat it as an additional generic actual, so that its
11710 -- primitive operations become visible in the instance. The task or
11711 -- protected type itself does not carry primitive operations.
11713 if Is_Concurrent_Type
(Act_T
)
11714 and then Is_Tagged_Type
(Act_T
)
11715 and then Present
(Corresponding_Record_Type
(Act_T
))
11716 and then Present
(Ancestor
)
11717 and then Is_Interface
(Ancestor
)
11720 Corr_Rec
: constant Entity_Id
:=
11721 Corresponding_Record_Type
(Act_T
);
11722 New_Corr
: Entity_Id
;
11723 Corr_Decl
: Node_Id
;
11726 New_Corr
:= Make_Temporary
(Loc
, 'S');
11728 Make_Subtype_Declaration
(Loc
,
11729 Defining_Identifier
=> New_Corr
,
11730 Subtype_Indication
=>
11731 New_Reference_To
(Corr_Rec
, Loc
));
11732 Append_To
(Decl_Nodes
, Corr_Decl
);
11734 if Ekind
(Act_T
) = E_Task_Type
then
11735 Set_Ekind
(Subt
, E_Task_Subtype
);
11737 Set_Ekind
(Subt
, E_Protected_Subtype
);
11740 Set_Corresponding_Record_Type
(Subt
, Corr_Rec
);
11741 Set_Generic_Parent_Type
(Corr_Decl
, Ancestor
);
11742 Set_Generic_Parent_Type
(Decl_Node
, Empty
);
11747 end Instantiate_Type
;
11749 ---------------------
11750 -- Is_In_Main_Unit --
11751 ---------------------
11753 function Is_In_Main_Unit
(N
: Node_Id
) return Boolean is
11754 Unum
: constant Unit_Number_Type
:= Get_Source_Unit
(N
);
11755 Current_Unit
: Node_Id
;
11758 if Unum
= Main_Unit
then
11761 -- If the current unit is a subunit then it is either the main unit or
11762 -- is being compiled as part of the main unit.
11764 elsif Nkind
(N
) = N_Compilation_Unit
then
11765 return Nkind
(Unit
(N
)) = N_Subunit
;
11768 Current_Unit
:= Parent
(N
);
11769 while Present
(Current_Unit
)
11770 and then Nkind
(Current_Unit
) /= N_Compilation_Unit
11772 Current_Unit
:= Parent
(Current_Unit
);
11775 -- The instantiation node is in the main unit, or else the current node
11776 -- (perhaps as the result of nested instantiations) is in the main unit,
11777 -- or in the declaration of the main unit, which in this last case must
11780 return Unum
= Main_Unit
11781 or else Current_Unit
= Cunit
(Main_Unit
)
11782 or else Current_Unit
= Library_Unit
(Cunit
(Main_Unit
))
11783 or else (Present
(Library_Unit
(Current_Unit
))
11784 and then Is_In_Main_Unit
(Library_Unit
(Current_Unit
)));
11785 end Is_In_Main_Unit
;
11787 ----------------------------
11788 -- Load_Parent_Of_Generic --
11789 ----------------------------
11791 procedure Load_Parent_Of_Generic
11794 Body_Optional
: Boolean := False)
11796 Comp_Unit
: constant Node_Id
:= Cunit
(Get_Source_Unit
(Spec
));
11797 Save_Style_Check
: constant Boolean := Style_Check
;
11798 True_Parent
: Node_Id
;
11799 Inst_Node
: Node_Id
;
11801 Previous_Instances
: constant Elist_Id
:= New_Elmt_List
;
11803 procedure Collect_Previous_Instances
(Decls
: List_Id
);
11804 -- Collect all instantiations in the given list of declarations, that
11805 -- precede the generic that we need to load. If the bodies of these
11806 -- instantiations are available, we must analyze them, to ensure that
11807 -- the public symbols generated are the same when the unit is compiled
11808 -- to generate code, and when it is compiled in the context of a unit
11809 -- that needs a particular nested instance. This process is applied to
11810 -- both package and subprogram instances.
11812 --------------------------------
11813 -- Collect_Previous_Instances --
11814 --------------------------------
11816 procedure Collect_Previous_Instances
(Decls
: List_Id
) is
11820 Decl
:= First
(Decls
);
11821 while Present
(Decl
) loop
11822 if Sloc
(Decl
) >= Sloc
(Inst_Node
) then
11825 -- If Decl is an instantiation, then record it as requiring
11826 -- instantiation of the corresponding body, except if it is an
11827 -- abbreviated instantiation generated internally for conformance
11828 -- checking purposes only for the case of a formal package
11829 -- declared without a box (see Instantiate_Formal_Package). Such
11830 -- an instantiation does not generate any code (the actual code
11831 -- comes from actual) and thus does not need to be analyzed here.
11832 -- If the instantiation appears with a generic package body it is
11833 -- not analyzed here either.
11835 elsif Nkind
(Decl
) = N_Package_Instantiation
11836 and then not Is_Internal
(Defining_Entity
(Decl
))
11838 Append_Elmt
(Decl
, Previous_Instances
);
11840 -- For a subprogram instantiation, omit instantiations intrinsic
11841 -- operations (Unchecked_Conversions, etc.) that have no bodies.
11843 elsif Nkind_In
(Decl
, N_Function_Instantiation
,
11844 N_Procedure_Instantiation
)
11845 and then not Is_Intrinsic_Subprogram
(Entity
(Name
(Decl
)))
11847 Append_Elmt
(Decl
, Previous_Instances
);
11849 elsif Nkind
(Decl
) = N_Package_Declaration
then
11850 Collect_Previous_Instances
11851 (Visible_Declarations
(Specification
(Decl
)));
11852 Collect_Previous_Instances
11853 (Private_Declarations
(Specification
(Decl
)));
11855 -- Previous non-generic bodies may contain instances as well
11857 elsif Nkind
(Decl
) = N_Package_Body
11858 and then Ekind
(Corresponding_Spec
(Decl
)) /= E_Generic_Package
11860 Collect_Previous_Instances
(Declarations
(Decl
));
11862 elsif Nkind
(Decl
) = N_Subprogram_Body
11863 and then not Acts_As_Spec
(Decl
)
11864 and then not Is_Generic_Subprogram
(Corresponding_Spec
(Decl
))
11866 Collect_Previous_Instances
(Declarations
(Decl
));
11871 end Collect_Previous_Instances
;
11873 -- Start of processing for Load_Parent_Of_Generic
11876 if not In_Same_Source_Unit
(N
, Spec
)
11877 or else Nkind
(Unit
(Comp_Unit
)) = N_Package_Declaration
11878 or else (Nkind
(Unit
(Comp_Unit
)) = N_Package_Body
11879 and then not Is_In_Main_Unit
(Spec
))
11881 -- Find body of parent of spec, and analyze it. A special case arises
11882 -- when the parent is an instantiation, that is to say when we are
11883 -- currently instantiating a nested generic. In that case, there is
11884 -- no separate file for the body of the enclosing instance. Instead,
11885 -- the enclosing body must be instantiated as if it were a pending
11886 -- instantiation, in order to produce the body for the nested generic
11887 -- we require now. Note that in that case the generic may be defined
11888 -- in a package body, the instance defined in the same package body,
11889 -- and the original enclosing body may not be in the main unit.
11891 Inst_Node
:= Empty
;
11893 True_Parent
:= Parent
(Spec
);
11894 while Present
(True_Parent
)
11895 and then Nkind
(True_Parent
) /= N_Compilation_Unit
11897 if Nkind
(True_Parent
) = N_Package_Declaration
11899 Nkind
(Original_Node
(True_Parent
)) = N_Package_Instantiation
11901 -- Parent is a compilation unit that is an instantiation.
11902 -- Instantiation node has been replaced with package decl.
11904 Inst_Node
:= Original_Node
(True_Parent
);
11907 elsif Nkind
(True_Parent
) = N_Package_Declaration
11908 and then Present
(Generic_Parent
(Specification
(True_Parent
)))
11909 and then Nkind
(Parent
(True_Parent
)) /= N_Compilation_Unit
11911 -- Parent is an instantiation within another specification.
11912 -- Declaration for instance has been inserted before original
11913 -- instantiation node. A direct link would be preferable?
11915 Inst_Node
:= Next
(True_Parent
);
11916 while Present
(Inst_Node
)
11917 and then Nkind
(Inst_Node
) /= N_Package_Instantiation
11922 -- If the instance appears within a generic, and the generic
11923 -- unit is defined within a formal package of the enclosing
11924 -- generic, there is no generic body available, and none
11925 -- needed. A more precise test should be used ???
11927 if No
(Inst_Node
) then
11934 True_Parent
:= Parent
(True_Parent
);
11938 -- Case where we are currently instantiating a nested generic
11940 if Present
(Inst_Node
) then
11941 if Nkind
(Parent
(True_Parent
)) = N_Compilation_Unit
then
11943 -- Instantiation node and declaration of instantiated package
11944 -- were exchanged when only the declaration was needed.
11945 -- Restore instantiation node before proceeding with body.
11947 Set_Unit
(Parent
(True_Parent
), Inst_Node
);
11950 -- Now complete instantiation of enclosing body, if it appears in
11951 -- some other unit. If it appears in the current unit, the body
11952 -- will have been instantiated already.
11954 if No
(Corresponding_Body
(Instance_Spec
(Inst_Node
))) then
11956 -- We need to determine the expander mode to instantiate the
11957 -- enclosing body. Because the generic body we need may use
11958 -- global entities declared in the enclosing package (including
11959 -- aggregates) it is in general necessary to compile this body
11960 -- with expansion enabled, except if we are within a generic
11961 -- package, in which case the usual generic rule applies.
11964 Exp_Status
: Boolean := True;
11968 -- Loop through scopes looking for generic package
11970 Scop
:= Scope
(Defining_Entity
(Instance_Spec
(Inst_Node
)));
11971 while Present
(Scop
)
11972 and then Scop
/= Standard_Standard
11974 if Ekind
(Scop
) = E_Generic_Package
then
11975 Exp_Status
:= False;
11979 Scop
:= Scope
(Scop
);
11982 -- Collect previous instantiations in the unit that contains
11983 -- the desired generic.
11985 if Nkind
(Parent
(True_Parent
)) /= N_Compilation_Unit
11986 and then not Body_Optional
11990 Info
: Pending_Body_Info
;
11994 Par
:= Parent
(Inst_Node
);
11995 while Present
(Par
) loop
11996 exit when Nkind
(Parent
(Par
)) = N_Compilation_Unit
;
11997 Par
:= Parent
(Par
);
12000 pragma Assert
(Present
(Par
));
12002 if Nkind
(Par
) = N_Package_Body
then
12003 Collect_Previous_Instances
(Declarations
(Par
));
12005 elsif Nkind
(Par
) = N_Package_Declaration
then
12006 Collect_Previous_Instances
12007 (Visible_Declarations
(Specification
(Par
)));
12008 Collect_Previous_Instances
12009 (Private_Declarations
(Specification
(Par
)));
12012 -- Enclosing unit is a subprogram body. In this
12013 -- case all instance bodies are processed in order
12014 -- and there is no need to collect them separately.
12019 Decl
:= First_Elmt
(Previous_Instances
);
12020 while Present
(Decl
) loop
12022 (Inst_Node
=> Node
(Decl
),
12024 Instance_Spec
(Node
(Decl
)),
12025 Expander_Status
=> Exp_Status
,
12026 Current_Sem_Unit
=>
12027 Get_Code_Unit
(Sloc
(Node
(Decl
))),
12028 Scope_Suppress
=> Scope_Suppress
,
12029 Local_Suppress_Stack_Top
=>
12030 Local_Suppress_Stack_Top
,
12031 Version
=> Ada_Version
);
12033 -- Package instance
12036 Nkind
(Node
(Decl
)) = N_Package_Instantiation
12038 Instantiate_Package_Body
12039 (Info
, Body_Optional
=> True);
12041 -- Subprogram instance
12044 -- The instance_spec is the wrapper package,
12045 -- and the subprogram declaration is the last
12046 -- declaration in the wrapper.
12050 (Visible_Declarations
12051 (Specification
(Info
.Act_Decl
)));
12053 Instantiate_Subprogram_Body
12054 (Info
, Body_Optional
=> True);
12062 Instantiate_Package_Body
12064 ((Inst_Node
=> Inst_Node
,
12065 Act_Decl
=> True_Parent
,
12066 Expander_Status
=> Exp_Status
,
12067 Current_Sem_Unit
=>
12068 Get_Code_Unit
(Sloc
(Inst_Node
)),
12069 Scope_Suppress
=> Scope_Suppress
,
12070 Local_Suppress_Stack_Top
=>
12071 Local_Suppress_Stack_Top
,
12072 Version
=> Ada_Version
)),
12073 Body_Optional
=> Body_Optional
);
12077 -- Case where we are not instantiating a nested generic
12080 Opt
.Style_Check
:= False;
12081 Expander_Mode_Save_And_Set
(True);
12082 Load_Needed_Body
(Comp_Unit
, OK
);
12083 Opt
.Style_Check
:= Save_Style_Check
;
12084 Expander_Mode_Restore
;
12087 and then Unit_Requires_Body
(Defining_Entity
(Spec
))
12088 and then not Body_Optional
12091 Bname
: constant Unit_Name_Type
:=
12092 Get_Body_Name
(Get_Unit_Name
(Unit
(Comp_Unit
)));
12095 -- In CodePeer mode, the missing body may make the analysis
12096 -- incomplete, but we do not treat it as fatal.
12098 if CodePeer_Mode
then
12102 Error_Msg_Unit_1
:= Bname
;
12103 Error_Msg_N
("this instantiation requires$!", N
);
12104 Error_Msg_File_1
:=
12105 Get_File_Name
(Bname
, Subunit
=> False);
12106 Error_Msg_N
("\but file{ was not found!", N
);
12107 raise Unrecoverable_Error
;
12114 -- If loading parent of the generic caused an instantiation circularity,
12115 -- we abandon compilation at this point, because otherwise in some cases
12116 -- we get into trouble with infinite recursions after this point.
12118 if Circularity_Detected
then
12119 raise Unrecoverable_Error
;
12121 end Load_Parent_Of_Generic
;
12123 ---------------------------------
12124 -- Map_Formal_Package_Entities --
12125 ---------------------------------
12127 procedure Map_Formal_Package_Entities
(Form
: Entity_Id
; Act
: Entity_Id
) is
12132 Set_Instance_Of
(Form
, Act
);
12134 -- Traverse formal and actual package to map the corresponding entities.
12135 -- We skip over internal entities that may be generated during semantic
12136 -- analysis, and find the matching entities by name, given that they
12137 -- must appear in the same order.
12139 E1
:= First_Entity
(Form
);
12140 E2
:= First_Entity
(Act
);
12141 while Present
(E1
) and then E1
/= First_Private_Entity
(Form
) loop
12142 -- Could this test be a single condition???
12143 -- Seems like it could, and isn't FPE (Form) a constant anyway???
12145 if not Is_Internal
(E1
)
12146 and then Present
(Parent
(E1
))
12147 and then not Is_Class_Wide_Type
(E1
)
12148 and then not Is_Internal_Name
(Chars
(E1
))
12150 while Present
(E2
) and then Chars
(E2
) /= Chars
(E1
) loop
12157 Set_Instance_Of
(E1
, E2
);
12159 if Is_Type
(E1
) and then Is_Tagged_Type
(E2
) then
12160 Set_Instance_Of
(Class_Wide_Type
(E1
), Class_Wide_Type
(E2
));
12163 if Is_Constrained
(E1
) then
12164 Set_Instance_Of
(Base_Type
(E1
), Base_Type
(E2
));
12167 if Ekind
(E1
) = E_Package
and then No
(Renamed_Object
(E1
)) then
12168 Map_Formal_Package_Entities
(E1
, E2
);
12175 end Map_Formal_Package_Entities
;
12177 -----------------------
12178 -- Move_Freeze_Nodes --
12179 -----------------------
12181 procedure Move_Freeze_Nodes
12182 (Out_Of
: Entity_Id
;
12187 Next_Decl
: Node_Id
;
12188 Next_Node
: Node_Id
:= After
;
12191 function Is_Outer_Type
(T
: Entity_Id
) return Boolean;
12192 -- Check whether entity is declared in a scope external to that of the
12195 -------------------
12196 -- Is_Outer_Type --
12197 -------------------
12199 function Is_Outer_Type
(T
: Entity_Id
) return Boolean is
12200 Scop
: Entity_Id
:= Scope
(T
);
12203 if Scope_Depth
(Scop
) < Scope_Depth
(Out_Of
) then
12207 while Scop
/= Standard_Standard
loop
12208 if Scop
= Out_Of
then
12211 Scop
:= Scope
(Scop
);
12219 -- Start of processing for Move_Freeze_Nodes
12226 -- First remove the freeze nodes that may appear before all other
12230 while Present
(Decl
)
12231 and then Nkind
(Decl
) = N_Freeze_Entity
12232 and then Is_Outer_Type
(Entity
(Decl
))
12234 Decl
:= Remove_Head
(L
);
12235 Insert_After
(Next_Node
, Decl
);
12236 Set_Analyzed
(Decl
, False);
12241 -- Next scan the list of declarations and remove each freeze node that
12242 -- appears ahead of the current node.
12244 while Present
(Decl
) loop
12245 while Present
(Next
(Decl
))
12246 and then Nkind
(Next
(Decl
)) = N_Freeze_Entity
12247 and then Is_Outer_Type
(Entity
(Next
(Decl
)))
12249 Next_Decl
:= Remove_Next
(Decl
);
12250 Insert_After
(Next_Node
, Next_Decl
);
12251 Set_Analyzed
(Next_Decl
, False);
12252 Next_Node
:= Next_Decl
;
12255 -- If the declaration is a nested package or concurrent type, then
12256 -- recurse. Nested generic packages will have been processed from the
12259 case Nkind
(Decl
) is
12260 when N_Package_Declaration
=>
12261 Spec
:= Specification
(Decl
);
12263 when N_Task_Type_Declaration
=>
12264 Spec
:= Task_Definition
(Decl
);
12266 when N_Protected_Type_Declaration
=>
12267 Spec
:= Protected_Definition
(Decl
);
12273 if Present
(Spec
) then
12274 Move_Freeze_Nodes
(Out_Of
, Next_Node
, Visible_Declarations
(Spec
));
12275 Move_Freeze_Nodes
(Out_Of
, Next_Node
, Private_Declarations
(Spec
));
12280 end Move_Freeze_Nodes
;
12286 function Next_Assoc
(E
: Assoc_Ptr
) return Assoc_Ptr
is
12288 return Generic_Renamings
.Table
(E
).Next_In_HTable
;
12291 ------------------------
12292 -- Preanalyze_Actuals --
12293 ------------------------
12295 procedure Preanalyze_Actuals
(N
: Node_Id
) is
12298 Errs
: constant Int
:= Serious_Errors_Detected
;
12300 Cur
: Entity_Id
:= Empty
;
12301 -- Current homograph of the instance name
12304 -- Saved visibility status of the current homograph
12307 Assoc
:= First
(Generic_Associations
(N
));
12309 -- If the instance is a child unit, its name may hide an outer homonym,
12310 -- so make it invisible to perform name resolution on the actuals.
12312 if Nkind
(Defining_Unit_Name
(N
)) = N_Defining_Program_Unit_Name
12314 (Current_Entity
(Defining_Identifier
(Defining_Unit_Name
(N
))))
12316 Cur
:= Current_Entity
(Defining_Identifier
(Defining_Unit_Name
(N
)));
12318 if Is_Compilation_Unit
(Cur
) then
12319 Vis
:= Is_Immediately_Visible
(Cur
);
12320 Set_Is_Immediately_Visible
(Cur
, False);
12326 while Present
(Assoc
) loop
12327 if Nkind
(Assoc
) /= N_Others_Choice
then
12328 Act
:= Explicit_Generic_Actual_Parameter
(Assoc
);
12330 -- Within a nested instantiation, a defaulted actual is an empty
12331 -- association, so nothing to analyze. If the subprogram actual
12332 -- is an attribute, analyze prefix only, because actual is not a
12333 -- complete attribute reference.
12335 -- If actual is an allocator, analyze expression only. The full
12336 -- analysis can generate code, and if instance is a compilation
12337 -- unit we have to wait until the package instance is installed
12338 -- to have a proper place to insert this code.
12340 -- String literals may be operators, but at this point we do not
12341 -- know whether the actual is a formal subprogram or a string.
12346 elsif Nkind
(Act
) = N_Attribute_Reference
then
12347 Analyze
(Prefix
(Act
));
12349 elsif Nkind
(Act
) = N_Explicit_Dereference
then
12350 Analyze
(Prefix
(Act
));
12352 elsif Nkind
(Act
) = N_Allocator
then
12354 Expr
: constant Node_Id
:= Expression
(Act
);
12357 if Nkind
(Expr
) = N_Subtype_Indication
then
12358 Analyze
(Subtype_Mark
(Expr
));
12360 -- Analyze separately each discriminant constraint, when
12361 -- given with a named association.
12367 Constr
:= First
(Constraints
(Constraint
(Expr
)));
12368 while Present
(Constr
) loop
12369 if Nkind
(Constr
) = N_Discriminant_Association
then
12370 Analyze
(Expression
(Constr
));
12384 elsif Nkind
(Act
) /= N_Operator_Symbol
then
12388 if Errs
/= Serious_Errors_Detected
then
12390 -- Do a minimal analysis of the generic, to prevent spurious
12391 -- warnings complaining about the generic being unreferenced,
12392 -- before abandoning the instantiation.
12394 Analyze
(Name
(N
));
12396 if Is_Entity_Name
(Name
(N
))
12397 and then Etype
(Name
(N
)) /= Any_Type
12399 Generate_Reference
(Entity
(Name
(N
)), Name
(N
));
12400 Set_Is_Instantiated
(Entity
(Name
(N
)));
12403 if Present
(Cur
) then
12405 -- For the case of a child instance hiding an outer homonym,
12406 -- provide additional warning which might explain the error.
12408 Set_Is_Immediately_Visible
(Cur
, Vis
);
12409 Error_Msg_NE
("& hides outer unit with the same name?",
12410 N
, Defining_Unit_Name
(N
));
12413 Abandon_Instantiation
(Act
);
12420 if Present
(Cur
) then
12421 Set_Is_Immediately_Visible
(Cur
, Vis
);
12423 end Preanalyze_Actuals
;
12425 -------------------
12426 -- Remove_Parent --
12427 -------------------
12429 procedure Remove_Parent
(In_Body
: Boolean := False) is
12430 S
: Entity_Id
:= Current_Scope
;
12431 -- S is the scope containing the instantiation just completed. The scope
12432 -- stack contains the parent instances of the instantiation, followed by
12441 -- After child instantiation is complete, remove from scope stack the
12442 -- extra copy of the current scope, and then remove parent instances.
12444 if not In_Body
then
12447 while Current_Scope
/= S
loop
12448 P
:= Current_Scope
;
12449 End_Package_Scope
(Current_Scope
);
12451 if In_Open_Scopes
(P
) then
12452 E
:= First_Entity
(P
);
12453 while Present
(E
) loop
12454 Set_Is_Immediately_Visible
(E
, True);
12458 -- If instantiation is declared in a block, it is the enclosing
12459 -- scope that might be a parent instance. Note that only one
12460 -- block can be involved, because the parent instances have
12461 -- been installed within it.
12463 if Ekind
(P
) = E_Block
then
12464 Cur_P
:= Scope
(P
);
12469 if Is_Generic_Instance
(Cur_P
) and then P
/= Current_Scope
then
12470 -- We are within an instance of some sibling. Retain
12471 -- visibility of parent, for proper subsequent cleanup, and
12472 -- reinstall private declarations as well.
12474 Set_In_Private_Part
(P
);
12475 Install_Private_Declarations
(P
);
12478 -- If the ultimate parent is a top-level unit recorded in
12479 -- Instance_Parent_Unit, then reset its visibility to what it was
12480 -- before instantiation. (It's not clear what the purpose is of
12481 -- testing whether Scope (P) is In_Open_Scopes, but that test was
12482 -- present before the ultimate parent test was added.???)
12484 elsif not In_Open_Scopes
(Scope
(P
))
12485 or else (P
= Instance_Parent_Unit
12486 and then not Parent_Unit_Visible
)
12488 Set_Is_Immediately_Visible
(P
, False);
12490 -- If the current scope is itself an instantiation of a generic
12491 -- nested within P, and we are in the private part of body of this
12492 -- instantiation, restore the full views of P, that were removed
12493 -- in End_Package_Scope above. This obscure case can occur when a
12494 -- subunit of a generic contains an instance of a child unit of
12495 -- its generic parent unit.
12497 elsif S
= Current_Scope
and then Is_Generic_Instance
(S
) then
12499 Par
: constant Entity_Id
:=
12501 (Specification
(Unit_Declaration_Node
(S
)));
12504 and then P
= Scope
(Par
)
12505 and then (In_Package_Body
(S
) or else In_Private_Part
(S
))
12507 Set_In_Private_Part
(P
);
12508 Install_Private_Declarations
(P
);
12514 -- Reset visibility of entities in the enclosing scope
12516 Set_Is_Hidden_Open_Scope
(Current_Scope
, False);
12518 Hidden
:= First_Elmt
(Hidden_Entities
);
12519 while Present
(Hidden
) loop
12520 Set_Is_Immediately_Visible
(Node
(Hidden
), True);
12521 Next_Elmt
(Hidden
);
12525 -- Each body is analyzed separately, and there is no context that
12526 -- needs preserving from one body instance to the next, so remove all
12527 -- parent scopes that have been installed.
12529 while Present
(S
) loop
12530 End_Package_Scope
(S
);
12531 Set_Is_Immediately_Visible
(S
, False);
12532 S
:= Current_Scope
;
12533 exit when S
= Standard_Standard
;
12542 procedure Restore_Env
is
12543 Saved
: Instance_Env
renames Instance_Envs
.Table
(Instance_Envs
.Last
);
12546 if No
(Current_Instantiated_Parent
.Act_Id
) then
12547 -- Restore environment after subprogram inlining
12549 Restore_Private_Views
(Empty
);
12552 Current_Instantiated_Parent
:= Saved
.Instantiated_Parent
;
12553 Exchanged_Views
:= Saved
.Exchanged_Views
;
12554 Hidden_Entities
:= Saved
.Hidden_Entities
;
12555 Current_Sem_Unit
:= Saved
.Current_Sem_Unit
;
12556 Parent_Unit_Visible
:= Saved
.Parent_Unit_Visible
;
12557 Instance_Parent_Unit
:= Saved
.Instance_Parent_Unit
;
12559 Restore_Opt_Config_Switches
(Saved
.Switches
);
12561 Instance_Envs
.Decrement_Last
;
12564 ---------------------------
12565 -- Restore_Private_Views --
12566 ---------------------------
12568 procedure Restore_Private_Views
12569 (Pack_Id
: Entity_Id
;
12570 Is_Package
: Boolean := True)
12575 Dep_Elmt
: Elmt_Id
;
12578 procedure Restore_Nested_Formal
(Formal
: Entity_Id
);
12579 -- Hide the generic formals of formal packages declared with box which
12580 -- were reachable in the current instantiation.
12582 ---------------------------
12583 -- Restore_Nested_Formal --
12584 ---------------------------
12586 procedure Restore_Nested_Formal
(Formal
: Entity_Id
) is
12590 if Present
(Renamed_Object
(Formal
))
12591 and then Denotes_Formal_Package
(Renamed_Object
(Formal
), True)
12595 elsif Present
(Associated_Formal_Package
(Formal
)) then
12596 Ent
:= First_Entity
(Formal
);
12597 while Present
(Ent
) loop
12598 exit when Ekind
(Ent
) = E_Package
12599 and then Renamed_Entity
(Ent
) = Renamed_Entity
(Formal
);
12601 Set_Is_Hidden
(Ent
);
12602 Set_Is_Potentially_Use_Visible
(Ent
, False);
12604 -- If package, then recurse
12606 if Ekind
(Ent
) = E_Package
then
12607 Restore_Nested_Formal
(Ent
);
12613 end Restore_Nested_Formal
;
12615 -- Start of processing for Restore_Private_Views
12618 M
:= First_Elmt
(Exchanged_Views
);
12619 while Present
(M
) loop
12622 -- Subtypes of types whose views have been exchanged, and that are
12623 -- defined within the instance, were not on the Private_Dependents
12624 -- list on entry to the instance, so they have to be exchanged
12625 -- explicitly now, in order to remain consistent with the view of the
12628 if Ekind_In
(Typ
, E_Private_Type
,
12629 E_Limited_Private_Type
,
12630 E_Record_Type_With_Private
)
12632 Dep_Elmt
:= First_Elmt
(Private_Dependents
(Typ
));
12633 while Present
(Dep_Elmt
) loop
12634 Dep_Typ
:= Node
(Dep_Elmt
);
12636 if Scope
(Dep_Typ
) = Pack_Id
12637 and then Present
(Full_View
(Dep_Typ
))
12639 Replace_Elmt
(Dep_Elmt
, Full_View
(Dep_Typ
));
12640 Exchange_Declarations
(Dep_Typ
);
12643 Next_Elmt
(Dep_Elmt
);
12647 Exchange_Declarations
(Node
(M
));
12651 if No
(Pack_Id
) then
12655 -- Make the generic formal parameters private, and make the formal types
12656 -- into subtypes of the actuals again.
12658 E
:= First_Entity
(Pack_Id
);
12659 while Present
(E
) loop
12660 Set_Is_Hidden
(E
, True);
12663 and then Nkind
(Parent
(E
)) = N_Subtype_Declaration
12665 Set_Is_Generic_Actual_Type
(E
, False);
12667 -- An unusual case of aliasing: the actual may also be directly
12668 -- visible in the generic, and be private there, while it is fully
12669 -- visible in the context of the instance. The internal subtype
12670 -- is private in the instance but has full visibility like its
12671 -- parent in the enclosing scope. This enforces the invariant that
12672 -- the privacy status of all private dependents of a type coincide
12673 -- with that of the parent type. This can only happen when a
12674 -- generic child unit is instantiated within a sibling.
12676 if Is_Private_Type
(E
)
12677 and then not Is_Private_Type
(Etype
(E
))
12679 Exchange_Declarations
(E
);
12682 elsif Ekind
(E
) = E_Package
then
12684 -- The end of the renaming list is the renaming of the generic
12685 -- package itself. If the instance is a subprogram, all entities
12686 -- in the corresponding package are renamings. If this entity is
12687 -- a formal package, make its own formals private as well. The
12688 -- actual in this case is itself the renaming of an instantiation.
12689 -- If the entity is not a package renaming, it is the entity
12690 -- created to validate formal package actuals: ignore it.
12692 -- If the actual is itself a formal package for the enclosing
12693 -- generic, or the actual for such a formal package, it remains
12694 -- visible on exit from the instance, and therefore nothing needs
12695 -- to be done either, except to keep it accessible.
12697 if Is_Package
and then Renamed_Object
(E
) = Pack_Id
then
12700 elsif Nkind
(Parent
(E
)) /= N_Package_Renaming_Declaration
then
12704 Denotes_Formal_Package
(Renamed_Object
(E
), True, Pack_Id
)
12706 Set_Is_Hidden
(E
, False);
12710 Act_P
: constant Entity_Id
:= Renamed_Object
(E
);
12714 Id
:= First_Entity
(Act_P
);
12716 and then Id
/= First_Private_Entity
(Act_P
)
12718 exit when Ekind
(Id
) = E_Package
12719 and then Renamed_Object
(Id
) = Act_P
;
12721 Set_Is_Hidden
(Id
, True);
12722 Set_Is_Potentially_Use_Visible
(Id
, In_Use
(Act_P
));
12724 if Ekind
(Id
) = E_Package
then
12725 Restore_Nested_Formal
(Id
);
12736 end Restore_Private_Views
;
12743 (Gen_Unit
: Entity_Id
;
12744 Act_Unit
: Entity_Id
)
12748 Set_Instance_Env
(Gen_Unit
, Act_Unit
);
12751 ----------------------------
12752 -- Save_Global_References --
12753 ----------------------------
12755 procedure Save_Global_References
(N
: Node_Id
) is
12756 Gen_Scope
: Entity_Id
;
12760 function Is_Global
(E
: Entity_Id
) return Boolean;
12761 -- Check whether entity is defined outside of generic unit. Examine the
12762 -- scope of an entity, and the scope of the scope, etc, until we find
12763 -- either Standard, in which case the entity is global, or the generic
12764 -- unit itself, which indicates that the entity is local. If the entity
12765 -- is the generic unit itself, as in the case of a recursive call, or
12766 -- the enclosing generic unit, if different from the current scope, then
12767 -- it is local as well, because it will be replaced at the point of
12768 -- instantiation. On the other hand, if it is a reference to a child
12769 -- unit of a common ancestor, which appears in an instantiation, it is
12770 -- global because it is used to denote a specific compilation unit at
12771 -- the time the instantiations will be analyzed.
12773 procedure Reset_Entity
(N
: Node_Id
);
12774 -- Save semantic information on global entity so that it is not resolved
12775 -- again at instantiation time.
12777 procedure Save_Entity_Descendants
(N
: Node_Id
);
12778 -- Apply Save_Global_References to the two syntactic descendants of
12779 -- non-terminal nodes that carry an Associated_Node and are processed
12780 -- through Reset_Entity. Once the global entity (if any) has been
12781 -- captured together with its type, only two syntactic descendants need
12782 -- to be traversed to complete the processing of the tree rooted at N.
12783 -- This applies to Selected_Components, Expanded_Names, and to Operator
12784 -- nodes. N can also be a character literal, identifier, or operator
12785 -- symbol node, but the call has no effect in these cases.
12787 procedure Save_Global_Defaults
(N1
, N2
: Node_Id
);
12788 -- Default actuals in nested instances must be handled specially
12789 -- because there is no link to them from the original tree. When an
12790 -- actual subprogram is given by a default, we add an explicit generic
12791 -- association for it in the instantiation node. When we save the
12792 -- global references on the name of the instance, we recover the list
12793 -- of generic associations, and add an explicit one to the original
12794 -- generic tree, through which a global actual can be preserved.
12795 -- Similarly, if a child unit is instantiated within a sibling, in the
12796 -- context of the parent, we must preserve the identifier of the parent
12797 -- so that it can be properly resolved in a subsequent instantiation.
12799 procedure Save_Global_Descendant
(D
: Union_Id
);
12800 -- Apply Save_Global_References recursively to the descendents of the
12803 procedure Save_References
(N
: Node_Id
);
12804 -- This is the recursive procedure that does the work, once the
12805 -- enclosing generic scope has been established.
12811 function Is_Global
(E
: Entity_Id
) return Boolean is
12814 function Is_Instance_Node
(Decl
: Node_Id
) return Boolean;
12815 -- Determine whether the parent node of a reference to a child unit
12816 -- denotes an instantiation or a formal package, in which case the
12817 -- reference to the child unit is global, even if it appears within
12818 -- the current scope (e.g. when the instance appears within the body
12819 -- of an ancestor).
12821 ----------------------
12822 -- Is_Instance_Node --
12823 ----------------------
12825 function Is_Instance_Node
(Decl
: Node_Id
) return Boolean is
12827 return Nkind
(Decl
) in N_Generic_Instantiation
12829 Nkind
(Original_Node
(Decl
)) = N_Formal_Package_Declaration
;
12830 end Is_Instance_Node
;
12832 -- Start of processing for Is_Global
12835 if E
= Gen_Scope
then
12838 elsif E
= Standard_Standard
then
12841 elsif Is_Child_Unit
(E
)
12842 and then (Is_Instance_Node
(Parent
(N2
))
12843 or else (Nkind
(Parent
(N2
)) = N_Expanded_Name
12844 and then N2
= Selector_Name
(Parent
(N2
))
12846 Is_Instance_Node
(Parent
(Parent
(N2
)))))
12852 while Se
/= Gen_Scope
loop
12853 if Se
= Standard_Standard
then
12868 procedure Reset_Entity
(N
: Node_Id
) is
12870 procedure Set_Global_Type
(N
: Node_Id
; N2
: Node_Id
);
12871 -- If the type of N2 is global to the generic unit, save the type in
12872 -- the generic node. Just as we perform name capture for explicit
12873 -- references within the generic, we must capture the global types
12874 -- of local entities because they may participate in resolution in
12877 function Top_Ancestor
(E
: Entity_Id
) return Entity_Id
;
12878 -- Find the ultimate ancestor of the current unit. If it is not a
12879 -- generic unit, then the name of the current unit in the prefix of
12880 -- an expanded name must be replaced with its generic homonym to
12881 -- ensure that it will be properly resolved in an instance.
12883 ---------------------
12884 -- Set_Global_Type --
12885 ---------------------
12887 procedure Set_Global_Type
(N
: Node_Id
; N2
: Node_Id
) is
12888 Typ
: constant Entity_Id
:= Etype
(N2
);
12891 Set_Etype
(N
, Typ
);
12893 if Entity
(N
) /= N2
12894 and then Has_Private_View
(Entity
(N
))
12896 -- If the entity of N is not the associated node, this is a
12897 -- nested generic and it has an associated node as well, whose
12898 -- type is already the full view (see below). Indicate that the
12899 -- original node has a private view.
12901 Set_Has_Private_View
(N
);
12904 -- If not a private type, nothing else to do
12906 if not Is_Private_Type
(Typ
) then
12907 if Is_Array_Type
(Typ
)
12908 and then Is_Private_Type
(Component_Type
(Typ
))
12910 Set_Has_Private_View
(N
);
12913 -- If it is a derivation of a private type in a context where no
12914 -- full view is needed, nothing to do either.
12916 elsif No
(Full_View
(Typ
)) and then Typ
/= Etype
(Typ
) then
12919 -- Otherwise mark the type for flipping and use the full view when
12923 Set_Has_Private_View
(N
);
12925 if Present
(Full_View
(Typ
)) then
12926 Set_Etype
(N2
, Full_View
(Typ
));
12929 end Set_Global_Type
;
12935 function Top_Ancestor
(E
: Entity_Id
) return Entity_Id
is
12940 while Is_Child_Unit
(Par
) loop
12941 Par
:= Scope
(Par
);
12947 -- Start of processing for Reset_Entity
12950 N2
:= Get_Associated_Node
(N
);
12953 if Present
(E
) then
12955 -- If the node is an entry call to an entry in an enclosing task,
12956 -- it is rewritten as a selected component. No global entity to
12957 -- preserve in this case, since the expansion will be redone in
12960 if not Nkind_In
(E
, N_Defining_Identifier
,
12961 N_Defining_Character_Literal
,
12962 N_Defining_Operator_Symbol
)
12964 Set_Associated_Node
(N
, Empty
);
12965 Set_Etype
(N
, Empty
);
12969 -- If the entity is an itype created as a subtype of an access
12970 -- type with a null exclusion restore source entity for proper
12971 -- visibility. The itype will be created anew in the instance.
12974 and then Ekind
(E
) = E_Access_Subtype
12975 and then Is_Entity_Name
(N
)
12976 and then Chars
(Etype
(E
)) = Chars
(N
)
12979 Set_Entity
(N2
, E
);
12983 if Is_Global
(E
) then
12984 Set_Global_Type
(N
, N2
);
12986 elsif Nkind
(N
) = N_Op_Concat
12987 and then Is_Generic_Type
(Etype
(N2
))
12988 and then (Base_Type
(Etype
(Right_Opnd
(N2
))) = Etype
(N2
)
12990 Base_Type
(Etype
(Left_Opnd
(N2
))) = Etype
(N2
))
12991 and then Is_Intrinsic_Subprogram
(E
)
12996 -- Entity is local. Mark generic node as unresolved.
12997 -- Note that now it does not have an entity.
12999 Set_Associated_Node
(N
, Empty
);
13000 Set_Etype
(N
, Empty
);
13003 if Nkind
(Parent
(N
)) in N_Generic_Instantiation
13004 and then N
= Name
(Parent
(N
))
13006 Save_Global_Defaults
(Parent
(N
), Parent
(N2
));
13009 elsif Nkind
(Parent
(N
)) = N_Selected_Component
13010 and then Nkind
(Parent
(N2
)) = N_Expanded_Name
13012 if Is_Global
(Entity
(Parent
(N2
))) then
13013 Change_Selected_Component_To_Expanded_Name
(Parent
(N
));
13014 Set_Associated_Node
(Parent
(N
), Parent
(N2
));
13015 Set_Global_Type
(Parent
(N
), Parent
(N2
));
13016 Save_Entity_Descendants
(N
);
13018 -- If this is a reference to the current generic entity, replace
13019 -- by the name of the generic homonym of the current package. This
13020 -- is because in an instantiation Par.P.Q will not resolve to the
13021 -- name of the instance, whose enclosing scope is not necessarily
13022 -- Par. We use the generic homonym rather that the name of the
13023 -- generic itself because it may be hidden by a local declaration.
13025 elsif In_Open_Scopes
(Entity
(Parent
(N2
)))
13027 Is_Generic_Unit
(Top_Ancestor
(Entity
(Prefix
(Parent
(N2
)))))
13029 if Ekind
(Entity
(Parent
(N2
))) = E_Generic_Package
then
13030 Rewrite
(Parent
(N
),
13031 Make_Identifier
(Sloc
(N
),
13033 Chars
(Generic_Homonym
(Entity
(Parent
(N2
))))));
13035 Rewrite
(Parent
(N
),
13036 Make_Identifier
(Sloc
(N
),
13037 Chars
=> Chars
(Selector_Name
(Parent
(N2
)))));
13041 if Nkind
(Parent
(Parent
(N
))) in N_Generic_Instantiation
13042 and then Parent
(N
) = Name
(Parent
(Parent
(N
)))
13044 Save_Global_Defaults
13045 (Parent
(Parent
(N
)), Parent
(Parent
((N2
))));
13048 -- A selected component may denote a static constant that has been
13049 -- folded. If the static constant is global to the generic, capture
13050 -- its value. Otherwise the folding will happen in any instantiation.
13052 elsif Nkind
(Parent
(N
)) = N_Selected_Component
13053 and then Nkind_In
(Parent
(N2
), N_Integer_Literal
, N_Real_Literal
)
13055 if Present
(Entity
(Original_Node
(Parent
(N2
))))
13056 and then Is_Global
(Entity
(Original_Node
(Parent
(N2
))))
13058 Rewrite
(Parent
(N
), New_Copy
(Parent
(N2
)));
13059 Set_Analyzed
(Parent
(N
), False);
13065 -- A selected component may be transformed into a parameterless
13066 -- function call. If the called entity is global, rewrite the node
13067 -- appropriately, i.e. as an extended name for the global entity.
13069 elsif Nkind
(Parent
(N
)) = N_Selected_Component
13070 and then Nkind
(Parent
(N2
)) = N_Function_Call
13071 and then N
= Selector_Name
(Parent
(N
))
13073 if No
(Parameter_Associations
(Parent
(N2
))) then
13074 if Is_Global
(Entity
(Name
(Parent
(N2
)))) then
13075 Change_Selected_Component_To_Expanded_Name
(Parent
(N
));
13076 Set_Associated_Node
(Parent
(N
), Name
(Parent
(N2
)));
13077 Set_Global_Type
(Parent
(N
), Name
(Parent
(N2
)));
13078 Save_Entity_Descendants
(N
);
13081 Set_Is_Prefixed_Call
(Parent
(N
));
13082 Set_Associated_Node
(N
, Empty
);
13083 Set_Etype
(N
, Empty
);
13086 -- In Ada 2005, X.F may be a call to a primitive operation,
13087 -- rewritten as F (X). This rewriting will be done again in an
13088 -- instance, so keep the original node. Global entities will be
13089 -- captured as for other constructs. Indicate that this must
13090 -- resolve as a call, to prevent accidental overloading in the
13091 -- instance, if both a component and a primitive operation appear
13095 Set_Is_Prefixed_Call
(Parent
(N
));
13098 -- Entity is local. Reset in generic unit, so that node is resolved
13099 -- anew at the point of instantiation.
13102 Set_Associated_Node
(N
, Empty
);
13103 Set_Etype
(N
, Empty
);
13107 -----------------------------
13108 -- Save_Entity_Descendants --
13109 -----------------------------
13111 procedure Save_Entity_Descendants
(N
: Node_Id
) is
13114 when N_Binary_Op
=>
13115 Save_Global_Descendant
(Union_Id
(Left_Opnd
(N
)));
13116 Save_Global_Descendant
(Union_Id
(Right_Opnd
(N
)));
13119 Save_Global_Descendant
(Union_Id
(Right_Opnd
(N
)));
13121 when N_Expanded_Name | N_Selected_Component
=>
13122 Save_Global_Descendant
(Union_Id
(Prefix
(N
)));
13123 Save_Global_Descendant
(Union_Id
(Selector_Name
(N
)));
13125 when N_Identifier | N_Character_Literal | N_Operator_Symbol
=>
13129 raise Program_Error
;
13131 end Save_Entity_Descendants
;
13133 --------------------------
13134 -- Save_Global_Defaults --
13135 --------------------------
13137 procedure Save_Global_Defaults
(N1
, N2
: Node_Id
) is
13138 Loc
: constant Source_Ptr
:= Sloc
(N1
);
13139 Assoc2
: constant List_Id
:= Generic_Associations
(N2
);
13140 Gen_Id
: constant Entity_Id
:= Get_Generic_Entity
(N2
);
13147 Actual
: Entity_Id
;
13150 Assoc1
:= Generic_Associations
(N1
);
13152 if Present
(Assoc1
) then
13153 Act1
:= First
(Assoc1
);
13156 Set_Generic_Associations
(N1
, New_List
);
13157 Assoc1
:= Generic_Associations
(N1
);
13160 if Present
(Assoc2
) then
13161 Act2
:= First
(Assoc2
);
13166 while Present
(Act1
) and then Present
(Act2
) loop
13171 -- Find the associations added for default subprograms
13173 if Present
(Act2
) then
13174 while Nkind
(Act2
) /= N_Generic_Association
13175 or else No
(Entity
(Selector_Name
(Act2
)))
13176 or else not Is_Overloadable
(Entity
(Selector_Name
(Act2
)))
13181 -- Add a similar association if the default is global. The
13182 -- renaming declaration for the actual has been analyzed, and
13183 -- its alias is the program it renames. Link the actual in the
13184 -- original generic tree with the node in the analyzed tree.
13186 while Present
(Act2
) loop
13187 Subp
:= Entity
(Selector_Name
(Act2
));
13188 Def
:= Explicit_Generic_Actual_Parameter
(Act2
);
13190 -- Following test is defence against rubbish errors
13192 if No
(Alias
(Subp
)) then
13196 -- Retrieve the resolved actual from the renaming declaration
13197 -- created for the instantiated formal.
13199 Actual
:= Entity
(Name
(Parent
(Parent
(Subp
))));
13200 Set_Entity
(Def
, Actual
);
13201 Set_Etype
(Def
, Etype
(Actual
));
13203 if Is_Global
(Actual
) then
13205 Make_Generic_Association
(Loc
,
13206 Selector_Name
=> New_Occurrence_Of
(Subp
, Loc
),
13207 Explicit_Generic_Actual_Parameter
=>
13208 New_Occurrence_Of
(Actual
, Loc
));
13210 Set_Associated_Node
13211 (Explicit_Generic_Actual_Parameter
(Ndec
), Def
);
13213 Append
(Ndec
, Assoc1
);
13215 -- If there are other defaults, add a dummy association in case
13216 -- there are other defaulted formals with the same name.
13218 elsif Present
(Next
(Act2
)) then
13220 Make_Generic_Association
(Loc
,
13221 Selector_Name
=> New_Occurrence_Of
(Subp
, Loc
),
13222 Explicit_Generic_Actual_Parameter
=> Empty
);
13224 Append
(Ndec
, Assoc1
);
13231 if Nkind
(Name
(N1
)) = N_Identifier
13232 and then Is_Child_Unit
(Gen_Id
)
13233 and then Is_Global
(Gen_Id
)
13234 and then Is_Generic_Unit
(Scope
(Gen_Id
))
13235 and then In_Open_Scopes
(Scope
(Gen_Id
))
13237 -- This is an instantiation of a child unit within a sibling, so
13238 -- that the generic parent is in scope. An eventual instance must
13239 -- occur within the scope of an instance of the parent. Make name
13240 -- in instance into an expanded name, to preserve the identifier
13241 -- of the parent, so it can be resolved subsequently.
13243 Rewrite
(Name
(N2
),
13244 Make_Expanded_Name
(Loc
,
13245 Chars
=> Chars
(Gen_Id
),
13246 Prefix
=> New_Occurrence_Of
(Scope
(Gen_Id
), Loc
),
13247 Selector_Name
=> New_Occurrence_Of
(Gen_Id
, Loc
)));
13248 Set_Entity
(Name
(N2
), Gen_Id
);
13250 Rewrite
(Name
(N1
),
13251 Make_Expanded_Name
(Loc
,
13252 Chars
=> Chars
(Gen_Id
),
13253 Prefix
=> New_Occurrence_Of
(Scope
(Gen_Id
), Loc
),
13254 Selector_Name
=> New_Occurrence_Of
(Gen_Id
, Loc
)));
13256 Set_Associated_Node
(Name
(N1
), Name
(N2
));
13257 Set_Associated_Node
(Prefix
(Name
(N1
)), Empty
);
13258 Set_Associated_Node
13259 (Selector_Name
(Name
(N1
)), Selector_Name
(Name
(N2
)));
13260 Set_Etype
(Name
(N1
), Etype
(Gen_Id
));
13263 end Save_Global_Defaults
;
13265 ----------------------------
13266 -- Save_Global_Descendant --
13267 ----------------------------
13269 procedure Save_Global_Descendant
(D
: Union_Id
) is
13273 if D
in Node_Range
then
13274 if D
= Union_Id
(Empty
) then
13277 elsif Nkind
(Node_Id
(D
)) /= N_Compilation_Unit
then
13278 Save_References
(Node_Id
(D
));
13281 elsif D
in List_Range
then
13282 if D
= Union_Id
(No_List
)
13283 or else Is_Empty_List
(List_Id
(D
))
13288 N1
:= First
(List_Id
(D
));
13289 while Present
(N1
) loop
13290 Save_References
(N1
);
13295 -- Element list or other non-node field, nothing to do
13300 end Save_Global_Descendant
;
13302 ---------------------
13303 -- Save_References --
13304 ---------------------
13306 -- This is the recursive procedure that does the work once the enclosing
13307 -- generic scope has been established. We have to treat specially a
13308 -- number of node rewritings that are required by semantic processing
13309 -- and which change the kind of nodes in the generic copy: typically
13310 -- constant-folding, replacing an operator node by a string literal, or
13311 -- a selected component by an expanded name. In each of those cases, the
13312 -- transformation is propagated to the generic unit.
13314 procedure Save_References
(N
: Node_Id
) is
13315 Loc
: constant Source_Ptr
:= Sloc
(N
);
13321 elsif Nkind_In
(N
, N_Character_Literal
, N_Operator_Symbol
) then
13322 if Nkind
(N
) = Nkind
(Get_Associated_Node
(N
)) then
13325 elsif Nkind
(N
) = N_Operator_Symbol
13326 and then Nkind
(Get_Associated_Node
(N
)) = N_String_Literal
13328 Change_Operator_Symbol_To_String_Literal
(N
);
13331 elsif Nkind
(N
) in N_Op
then
13332 if Nkind
(N
) = Nkind
(Get_Associated_Node
(N
)) then
13333 if Nkind
(N
) = N_Op_Concat
then
13334 Set_Is_Component_Left_Opnd
(N
,
13335 Is_Component_Left_Opnd
(Get_Associated_Node
(N
)));
13337 Set_Is_Component_Right_Opnd
(N
,
13338 Is_Component_Right_Opnd
(Get_Associated_Node
(N
)));
13344 -- Node may be transformed into call to a user-defined operator
13346 N2
:= Get_Associated_Node
(N
);
13348 if Nkind
(N2
) = N_Function_Call
then
13349 E
:= Entity
(Name
(N2
));
13352 and then Is_Global
(E
)
13354 Set_Etype
(N
, Etype
(N2
));
13356 Set_Associated_Node
(N
, Empty
);
13357 Set_Etype
(N
, Empty
);
13360 elsif Nkind_In
(N2
, N_Integer_Literal
,
13364 if Present
(Original_Node
(N2
))
13365 and then Nkind
(Original_Node
(N2
)) = Nkind
(N
)
13368 -- Operation was constant-folded. Whenever possible,
13369 -- recover semantic information from unfolded node,
13372 Set_Associated_Node
(N
, Original_Node
(N2
));
13374 if Nkind
(N
) = N_Op_Concat
then
13375 Set_Is_Component_Left_Opnd
(N
,
13376 Is_Component_Left_Opnd
(Get_Associated_Node
(N
)));
13377 Set_Is_Component_Right_Opnd
(N
,
13378 Is_Component_Right_Opnd
(Get_Associated_Node
(N
)));
13384 -- If original node is already modified, propagate
13385 -- constant-folding to template.
13387 Rewrite
(N
, New_Copy
(N2
));
13388 Set_Analyzed
(N
, False);
13391 elsif Nkind
(N2
) = N_Identifier
13392 and then Ekind
(Entity
(N2
)) = E_Enumeration_Literal
13394 -- Same if call was folded into a literal, but in this case
13395 -- retain the entity to avoid spurious ambiguities if it is
13396 -- overloaded at the point of instantiation or inlining.
13398 Rewrite
(N
, New_Copy
(N2
));
13399 Set_Analyzed
(N
, False);
13403 -- Complete operands check if node has not been constant-folded
13405 if Nkind
(N
) in N_Op
then
13406 Save_Entity_Descendants
(N
);
13409 elsif Nkind
(N
) = N_Identifier
then
13410 if Nkind
(N
) = Nkind
(Get_Associated_Node
(N
)) then
13412 -- If this is a discriminant reference, always save it. It is
13413 -- used in the instance to find the corresponding discriminant
13414 -- positionally rather than by name.
13416 Set_Original_Discriminant
13417 (N
, Original_Discriminant
(Get_Associated_Node
(N
)));
13421 N2
:= Get_Associated_Node
(N
);
13423 if Nkind
(N2
) = N_Function_Call
then
13424 E
:= Entity
(Name
(N2
));
13426 -- Name resolves to a call to parameterless function. If
13427 -- original entity is global, mark node as resolved.
13430 and then Is_Global
(E
)
13432 Set_Etype
(N
, Etype
(N2
));
13434 Set_Associated_Node
(N
, Empty
);
13435 Set_Etype
(N
, Empty
);
13438 elsif Nkind_In
(N2
, N_Integer_Literal
, N_Real_Literal
)
13439 and then Is_Entity_Name
(Original_Node
(N2
))
13441 -- Name resolves to named number that is constant-folded,
13442 -- We must preserve the original name for ASIS use, and
13443 -- undo the constant-folding, which will be repeated in
13446 Set_Associated_Node
(N
, Original_Node
(N2
));
13449 elsif Nkind
(N2
) = N_String_Literal
then
13451 -- Name resolves to string literal. Perform the same
13452 -- replacement in generic.
13454 Rewrite
(N
, New_Copy
(N2
));
13456 elsif Nkind
(N2
) = N_Explicit_Dereference
then
13458 -- An identifier is rewritten as a dereference if it is the
13459 -- prefix in an implicit dereference (call or attribute).
13460 -- The analysis of an instantiation will expand the node
13461 -- again, so we preserve the original tree but link it to
13462 -- the resolved entity in case it is global.
13464 if Is_Entity_Name
(Prefix
(N2
))
13465 and then Present
(Entity
(Prefix
(N2
)))
13466 and then Is_Global
(Entity
(Prefix
(N2
)))
13468 Set_Associated_Node
(N
, Prefix
(N2
));
13470 elsif Nkind
(Prefix
(N2
)) = N_Function_Call
13471 and then Is_Global
(Entity
(Name
(Prefix
(N2
))))
13474 Make_Explicit_Dereference
(Loc
,
13475 Prefix
=> Make_Function_Call
(Loc
,
13477 New_Occurrence_Of
(Entity
(Name
(Prefix
(N2
))),
13481 Set_Associated_Node
(N
, Empty
);
13482 Set_Etype
(N
, Empty
);
13485 -- The subtype mark of a nominally unconstrained object is
13486 -- rewritten as a subtype indication using the bounds of the
13487 -- expression. Recover the original subtype mark.
13489 elsif Nkind
(N2
) = N_Subtype_Indication
13490 and then Is_Entity_Name
(Original_Node
(N2
))
13492 Set_Associated_Node
(N
, Original_Node
(N2
));
13500 elsif Nkind
(N
) in N_Entity
then
13505 Qual
: Node_Id
:= Empty
;
13506 Typ
: Entity_Id
:= Empty
;
13509 use Atree
.Unchecked_Access
;
13510 -- This code section is part of implementing an untyped tree
13511 -- traversal, so it needs direct access to node fields.
13514 if Nkind_In
(N
, N_Aggregate
, N_Extension_Aggregate
) then
13515 N2
:= Get_Associated_Node
(N
);
13522 -- In an instance within a generic, use the name of the
13523 -- actual and not the original generic parameter. If the
13524 -- actual is global in the current generic it must be
13525 -- preserved for its instantiation.
13527 if Nkind
(Parent
(Typ
)) = N_Subtype_Declaration
13529 Present
(Generic_Parent_Type
(Parent
(Typ
)))
13531 Typ
:= Base_Type
(Typ
);
13532 Set_Etype
(N2
, Typ
);
13538 or else not Is_Global
(Typ
)
13540 Set_Associated_Node
(N
, Empty
);
13542 -- If the aggregate is an actual in a call, it has been
13543 -- resolved in the current context, to some local type.
13544 -- The enclosing call may have been disambiguated by the
13545 -- aggregate, and this disambiguation might fail at
13546 -- instantiation time because the type to which the
13547 -- aggregate did resolve is not preserved. In order to
13548 -- preserve some of this information, we wrap the
13549 -- aggregate in a qualified expression, using the id of
13550 -- its type. For further disambiguation we qualify the
13551 -- type name with its scope (if visible) because both
13552 -- id's will have corresponding entities in an instance.
13553 -- This resolves most of the problems with missing type
13554 -- information on aggregates in instances.
13556 if Nkind
(N2
) = Nkind
(N
)
13557 and then Nkind
(Parent
(N2
)) in N_Subprogram_Call
13558 and then Comes_From_Source
(Typ
)
13560 if Is_Immediately_Visible
(Scope
(Typ
)) then
13561 Nam
:= Make_Selected_Component
(Loc
,
13563 Make_Identifier
(Loc
, Chars
(Scope
(Typ
))),
13565 Make_Identifier
(Loc
, Chars
(Typ
)));
13567 Nam
:= Make_Identifier
(Loc
, Chars
(Typ
));
13571 Make_Qualified_Expression
(Loc
,
13572 Subtype_Mark
=> Nam
,
13573 Expression
=> Relocate_Node
(N
));
13577 Save_Global_Descendant
(Field1
(N
));
13578 Save_Global_Descendant
(Field2
(N
));
13579 Save_Global_Descendant
(Field3
(N
));
13580 Save_Global_Descendant
(Field5
(N
));
13582 if Present
(Qual
) then
13586 -- All other cases than aggregates
13589 Save_Global_Descendant
(Field1
(N
));
13590 Save_Global_Descendant
(Field2
(N
));
13591 Save_Global_Descendant
(Field3
(N
));
13592 Save_Global_Descendant
(Field4
(N
));
13593 Save_Global_Descendant
(Field5
(N
));
13598 -- If a node has aspects, references within their expressions must
13599 -- be saved separately, given that they are not directly in the
13602 if Has_Aspects
(N
) then
13606 Aspect
:= First
(Aspect_Specifications
(N
));
13607 while Present
(Aspect
) loop
13608 Save_Global_References
(Expression
(Aspect
));
13613 end Save_References
;
13615 -- Start of processing for Save_Global_References
13618 Gen_Scope
:= Current_Scope
;
13620 -- If the generic unit is a child unit, references to entities in the
13621 -- parent are treated as local, because they will be resolved anew in
13622 -- the context of the instance of the parent.
13624 while Is_Child_Unit
(Gen_Scope
)
13625 and then Ekind
(Scope
(Gen_Scope
)) = E_Generic_Package
13627 Gen_Scope
:= Scope
(Gen_Scope
);
13630 Save_References
(N
);
13631 end Save_Global_References
;
13633 --------------------------------------
13634 -- Set_Copied_Sloc_For_Inlined_Body --
13635 --------------------------------------
13637 procedure Set_Copied_Sloc_For_Inlined_Body
(N
: Node_Id
; E
: Entity_Id
) is
13639 Create_Instantiation_Source
(N
, E
, True, S_Adjustment
);
13640 end Set_Copied_Sloc_For_Inlined_Body
;
13642 ---------------------
13643 -- Set_Instance_Of --
13644 ---------------------
13646 procedure Set_Instance_Of
(A
: Entity_Id
; B
: Entity_Id
) is
13648 Generic_Renamings
.Table
(Generic_Renamings
.Last
) := (A
, B
, Assoc_Null
);
13649 Generic_Renamings_HTable
.Set
(Generic_Renamings
.Last
);
13650 Generic_Renamings
.Increment_Last
;
13651 end Set_Instance_Of
;
13653 --------------------
13654 -- Set_Next_Assoc --
13655 --------------------
13657 procedure Set_Next_Assoc
(E
: Assoc_Ptr
; Next
: Assoc_Ptr
) is
13659 Generic_Renamings
.Table
(E
).Next_In_HTable
:= Next
;
13660 end Set_Next_Assoc
;
13662 -------------------
13663 -- Start_Generic --
13664 -------------------
13666 procedure Start_Generic
is
13668 -- ??? More things could be factored out in this routine.
13669 -- Should probably be done at a later stage.
13671 Generic_Flags
.Append
(Inside_A_Generic
);
13672 Inside_A_Generic
:= True;
13674 Expander_Mode_Save_And_Set
(False);
13677 ----------------------
13678 -- Set_Instance_Env --
13679 ----------------------
13681 procedure Set_Instance_Env
13682 (Gen_Unit
: Entity_Id
;
13683 Act_Unit
: Entity_Id
)
13686 -- Regardless of the current mode, predefined units are analyzed in the
13687 -- most current Ada mode, and earlier version Ada checks do not apply
13688 -- to predefined units. Nothing needs to be done for non-internal units.
13689 -- These are always analyzed in the current mode.
13691 if Is_Internal_File_Name
13692 (Fname
=> Unit_File_Name
(Get_Source_Unit
(Gen_Unit
)),
13693 Renamings_Included
=> True)
13695 Set_Opt_Config_Switches
(True, Current_Sem_Unit
= Main_Unit
);
13698 Current_Instantiated_Parent
:=
13699 (Gen_Id
=> Gen_Unit
,
13700 Act_Id
=> Act_Unit
,
13701 Next_In_HTable
=> Assoc_Null
);
13702 end Set_Instance_Env
;
13708 procedure Switch_View
(T
: Entity_Id
) is
13709 BT
: constant Entity_Id
:= Base_Type
(T
);
13710 Priv_Elmt
: Elmt_Id
:= No_Elmt
;
13711 Priv_Sub
: Entity_Id
;
13714 -- T may be private but its base type may have been exchanged through
13715 -- some other occurrence, in which case there is nothing to switch
13716 -- besides T itself. Note that a private dependent subtype of a private
13717 -- type might not have been switched even if the base type has been,
13718 -- because of the last branch of Check_Private_View (see comment there).
13720 if not Is_Private_Type
(BT
) then
13721 Prepend_Elmt
(Full_View
(T
), Exchanged_Views
);
13722 Exchange_Declarations
(T
);
13726 Priv_Elmt
:= First_Elmt
(Private_Dependents
(BT
));
13728 if Present
(Full_View
(BT
)) then
13729 Prepend_Elmt
(Full_View
(BT
), Exchanged_Views
);
13730 Exchange_Declarations
(BT
);
13733 while Present
(Priv_Elmt
) loop
13734 Priv_Sub
:= (Node
(Priv_Elmt
));
13736 -- We avoid flipping the subtype if the Etype of its full view is
13737 -- private because this would result in a malformed subtype. This
13738 -- occurs when the Etype of the subtype full view is the full view of
13739 -- the base type (and since the base types were just switched, the
13740 -- subtype is pointing to the wrong view). This is currently the case
13741 -- for tagged record types, access types (maybe more?) and needs to
13742 -- be resolved. ???
13744 if Present
(Full_View
(Priv_Sub
))
13745 and then not Is_Private_Type
(Etype
(Full_View
(Priv_Sub
)))
13747 Prepend_Elmt
(Full_View
(Priv_Sub
), Exchanged_Views
);
13748 Exchange_Declarations
(Priv_Sub
);
13751 Next_Elmt
(Priv_Elmt
);
13759 function True_Parent
(N
: Node_Id
) return Node_Id
is
13761 if Nkind
(Parent
(N
)) = N_Subunit
then
13762 return Parent
(Corresponding_Stub
(Parent
(N
)));
13768 -----------------------------
13769 -- Valid_Default_Attribute --
13770 -----------------------------
13772 procedure Valid_Default_Attribute
(Nam
: Entity_Id
; Def
: Node_Id
) is
13773 Attr_Id
: constant Attribute_Id
:=
13774 Get_Attribute_Id
(Attribute_Name
(Def
));
13775 T
: constant Entity_Id
:= Entity
(Prefix
(Def
));
13776 Is_Fun
: constant Boolean := (Ekind
(Nam
) = E_Function
);
13789 F
:= First_Formal
(Nam
);
13790 while Present
(F
) loop
13791 Num_F
:= Num_F
+ 1;
13796 when Attribute_Adjacent | Attribute_Ceiling | Attribute_Copy_Sign |
13797 Attribute_Floor | Attribute_Fraction | Attribute_Machine |
13798 Attribute_Model | Attribute_Remainder | Attribute_Rounding |
13799 Attribute_Unbiased_Rounding
=>
13802 and then Is_Floating_Point_Type
(T
);
13804 when Attribute_Image | Attribute_Pred | Attribute_Succ |
13805 Attribute_Value | Attribute_Wide_Image |
13806 Attribute_Wide_Value
=>
13807 OK
:= (Is_Fun
and then Num_F
= 1 and then Is_Scalar_Type
(T
));
13809 when Attribute_Max | Attribute_Min
=>
13810 OK
:= (Is_Fun
and then Num_F
= 2 and then Is_Scalar_Type
(T
));
13812 when Attribute_Input
=>
13813 OK
:= (Is_Fun
and then Num_F
= 1);
13815 when Attribute_Output | Attribute_Read | Attribute_Write
=>
13816 OK
:= (not Is_Fun
and then Num_F
= 2);
13823 Error_Msg_N
("attribute reference has wrong profile for subprogram",
13826 end Valid_Default_Attribute
;