1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Aspects
; use Aspects
;
27 with Atree
; use Atree
;
28 with Einfo
; use Einfo
;
29 with Elists
; use Elists
;
30 with Errout
; use Errout
;
31 with Expander
; use Expander
;
32 with Exp_Disp
; use Exp_Disp
;
33 with Exp_Util
; use Exp_Util
;
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
;
79 with Warnsw
; use Warnsw
;
83 package body Sem_Ch12
is
85 ----------------------------------------------------------
86 -- Implementation of Generic Analysis and Instantiation --
87 ----------------------------------------------------------
89 -- GNAT implements generics by macro expansion. No attempt is made to share
90 -- generic instantiations (for now). Analysis of a generic definition does
91 -- not perform any expansion action, but the expander must be called on the
92 -- tree for each instantiation, because the expansion may of course depend
93 -- on the generic actuals. All of this is best achieved as follows:
95 -- a) Semantic analysis of a generic unit is performed on a copy of the
96 -- tree for the generic unit. All tree modifications that follow analysis
97 -- do not affect the original tree. Links are kept between the original
98 -- tree and the copy, in order to recognize non-local references within
99 -- the generic, and propagate them to each instance (recall that name
100 -- resolution is done on the generic declaration: generics are not really
101 -- macros). This is summarized in the following diagram:
103 -- .-----------. .----------.
104 -- | semantic |<--------------| generic |
106 -- | |==============>| |
107 -- |___________| global |__________|
118 -- b) Each instantiation copies the original tree, and inserts into it a
119 -- series of declarations that describe the mapping between generic formals
120 -- and actuals. For example, a generic In OUT parameter is an object
121 -- renaming of the corresponding actual, etc. Generic IN parameters are
122 -- constant declarations.
124 -- c) In order to give the right visibility for these renamings, we use
125 -- a different scheme for package and subprogram instantiations. For
126 -- packages, the list of renamings is inserted into the package
127 -- specification, before the visible declarations of the package. The
128 -- renamings are analyzed before any of the text of the instance, and are
129 -- thus visible at the right place. Furthermore, outside of the instance,
130 -- the generic parameters are visible and denote their corresponding
133 -- For subprograms, we create a container package to hold the renamings
134 -- and the subprogram instance itself. Analysis of the package makes the
135 -- renaming declarations visible to the subprogram. After analyzing the
136 -- package, the defining entity for the subprogram is touched-up so that
137 -- it appears declared in the current scope, and not inside the container
140 -- If the instantiation is a compilation unit, the container package is
141 -- given the same name as the subprogram instance. This ensures that
142 -- the elaboration procedure called by the binder, using the compilation
143 -- unit name, calls in fact the elaboration procedure for the package.
145 -- Not surprisingly, private types complicate this approach. By saving in
146 -- the original generic object the non-local references, we guarantee that
147 -- the proper entities are referenced at the point of instantiation.
148 -- However, for private types, this by itself does not insure that the
149 -- proper VIEW of the entity is used (the full type may be visible at the
150 -- point of generic definition, but not at instantiation, or vice-versa).
151 -- In order to reference the proper view, we special-case any reference
152 -- to private types in the generic object, by saving both views, one in
153 -- the generic and one in the semantic copy. At time of instantiation, we
154 -- check whether the two views are consistent, and exchange declarations if
155 -- necessary, in order to restore the correct visibility. Similarly, if
156 -- the instance view is private when the generic view was not, we perform
157 -- the exchange. After completing the instantiation, we restore the
158 -- current visibility. The flag Has_Private_View marks identifiers in the
159 -- the generic unit that require checking.
161 -- Visibility within nested generic units requires special handling.
162 -- Consider the following scheme:
164 -- type Global is ... -- outside of generic unit.
168 -- type Semi_Global is ... -- global to inner.
171 -- procedure inner (X1 : Global; X2 : Semi_Global);
173 -- procedure in2 is new inner (...); -- 4
176 -- package New_Outer is new Outer (...); -- 2
177 -- procedure New_Inner is new New_Outer.Inner (...); -- 3
179 -- The semantic analysis of Outer captures all occurrences of Global.
180 -- The semantic analysis of Inner (at 1) captures both occurrences of
181 -- Global and Semi_Global.
183 -- At point 2 (instantiation of Outer), we also produce a generic copy
184 -- of Inner, even though Inner is, at that point, not being instantiated.
185 -- (This is just part of the semantic analysis of New_Outer).
187 -- Critically, references to Global within Inner must be preserved, while
188 -- references to Semi_Global should not preserved, because they must now
189 -- resolve to an entity within New_Outer. To distinguish between these, we
190 -- use a global variable, Current_Instantiated_Parent, which is set when
191 -- performing a generic copy during instantiation (at 2). This variable is
192 -- used when performing a generic copy that is not an instantiation, but
193 -- that is nested within one, as the occurrence of 1 within 2. The analysis
194 -- of a nested generic only preserves references that are global to the
195 -- enclosing Current_Instantiated_Parent. We use the Scope_Depth value to
196 -- determine whether a reference is external to the given parent.
198 -- The instantiation at point 3 requires no special treatment. The method
199 -- works as well for further nestings of generic units, but of course the
200 -- variable Current_Instantiated_Parent must be stacked because nested
201 -- instantiations can occur, e.g. the occurrence of 4 within 2.
203 -- The instantiation of package and subprogram bodies is handled in a
204 -- similar manner, except that it is delayed until after semantic
205 -- analysis is complete. In this fashion complex cross-dependencies
206 -- between several package declarations and bodies containing generics
207 -- can be compiled which otherwise would diagnose spurious circularities.
209 -- For example, it is possible to compile two packages A and B that
210 -- have the following structure:
212 -- package A is package B is
213 -- generic ... generic ...
214 -- package G_A is package G_B is
217 -- package body A is package body B is
218 -- package N_B is new G_B (..) package N_A is new G_A (..)
220 -- The table Pending_Instantiations in package Inline is used to keep
221 -- track of body instantiations that are delayed in this manner. Inline
222 -- handles the actual calls to do the body instantiations. This activity
223 -- is part of Inline, since the processing occurs at the same point, and
224 -- for essentially the same reason, as the handling of inlined routines.
226 ----------------------------------------------
227 -- Detection of Instantiation Circularities --
228 ----------------------------------------------
230 -- If we have a chain of instantiations that is circular, this is static
231 -- error which must be detected at compile time. The detection of these
232 -- circularities is carried out at the point that we insert a generic
233 -- instance spec or body. If there is a circularity, then the analysis of
234 -- the offending spec or body will eventually result in trying to load the
235 -- same unit again, and we detect this problem as we analyze the package
236 -- instantiation for the second time.
238 -- At least in some cases after we have detected the circularity, we get
239 -- into trouble if we try to keep going. The following flag is set if a
240 -- circularity is detected, and used to abandon compilation after the
241 -- messages have been posted.
243 Circularity_Detected
: Boolean := False;
244 -- This should really be reset on encountering a new main unit, but in
245 -- practice we are not using multiple main units so it is not critical.
247 --------------------------------------------------
248 -- Formal packages and partial parameterization --
249 --------------------------------------------------
251 -- When compiling a generic, a formal package is a local instantiation. If
252 -- declared with a box, its generic formals are visible in the enclosing
253 -- generic. If declared with a partial list of actuals, those actuals that
254 -- are defaulted (covered by an Others clause, or given an explicit box
255 -- initialization) are also visible in the enclosing generic, while those
256 -- that have a corresponding actual are not.
258 -- In our source model of instantiation, the same visibility must be
259 -- present in the spec and body of an instance: the names of the formals
260 -- that are defaulted must be made visible within the instance, and made
261 -- invisible (hidden) after the instantiation is complete, so that they
262 -- are not accessible outside of the instance.
264 -- In a generic, a formal package is treated like a special instantiation.
265 -- Our Ada 95 compiler handled formals with and without box in different
266 -- ways. With partial parameterization, we use a single model for both.
267 -- We create a package declaration that consists of the specification of
268 -- the generic package, and a set of declarations that map the actuals
269 -- into local renamings, just as we do for bona fide instantiations. For
270 -- defaulted parameters and formals with a box, we copy directly the
271 -- declarations of the formal into this local package. The result is a
272 -- a package whose visible declarations may include generic formals. This
273 -- package is only used for type checking and visibility analysis, and
274 -- never reaches the back-end, so it can freely violate the placement
275 -- rules for generic formal declarations.
277 -- The list of declarations (renamings and copies of formals) is built
278 -- by Analyze_Associations, just as for regular instantiations.
280 -- At the point of instantiation, conformance checking must be applied only
281 -- to those parameters that were specified in the formal. We perform this
282 -- checking by creating another internal instantiation, this one including
283 -- only the renamings and the formals (the rest of the package spec is not
284 -- relevant to conformance checking). We can then traverse two lists: the
285 -- list of actuals in the instance that corresponds to the formal package,
286 -- and the list of actuals produced for this bogus instantiation. We apply
287 -- the conformance rules to those actuals that are not defaulted (i.e.
288 -- which still appear as generic formals.
290 -- When we compile an instance body we must make the right parameters
291 -- visible again. The predicate Is_Generic_Formal indicates which of the
292 -- formals should have its Is_Hidden flag reset.
294 -----------------------
295 -- Local subprograms --
296 -----------------------
298 procedure Abandon_Instantiation
(N
: Node_Id
);
299 pragma No_Return
(Abandon_Instantiation
);
300 -- Posts an error message "instantiation abandoned" at the indicated node
301 -- and then raises the exception Instantiation_Error to do it.
303 procedure Analyze_Formal_Array_Type
304 (T
: in out Entity_Id
;
306 -- A formal array type is treated like an array type declaration, and
307 -- invokes Array_Type_Declaration (sem_ch3) whose first parameter is
308 -- in-out, because in the case of an anonymous type the entity is
309 -- actually created in the procedure.
311 -- The following procedures treat other kinds of formal parameters
313 procedure Analyze_Formal_Derived_Interface_Type
318 procedure Analyze_Formal_Derived_Type
323 procedure Analyze_Formal_Interface_Type
328 -- The following subprograms create abbreviated declarations for formal
329 -- scalar types. We introduce an anonymous base of the proper class for
330 -- each of them, and define the formals as constrained first subtypes of
331 -- their bases. The bounds are expressions that are non-static in the
334 procedure Analyze_Formal_Decimal_Fixed_Point_Type
335 (T
: Entity_Id
; Def
: Node_Id
);
336 procedure Analyze_Formal_Discrete_Type
(T
: Entity_Id
; Def
: Node_Id
);
337 procedure Analyze_Formal_Floating_Type
(T
: Entity_Id
; Def
: Node_Id
);
338 procedure Analyze_Formal_Signed_Integer_Type
(T
: Entity_Id
; Def
: Node_Id
);
339 procedure Analyze_Formal_Modular_Type
(T
: Entity_Id
; Def
: Node_Id
);
340 procedure Analyze_Formal_Ordinary_Fixed_Point_Type
341 (T
: Entity_Id
; Def
: Node_Id
);
343 procedure Analyze_Formal_Private_Type
347 -- Creates a new private type, which does not require completion
349 procedure Analyze_Formal_Incomplete_Type
(T
: Entity_Id
; Def
: Node_Id
);
350 -- Ada 2012: Creates a new incomplete type whose actual does not freeze
352 procedure Analyze_Generic_Formal_Part
(N
: Node_Id
);
353 -- Analyze generic formal part
355 procedure Analyze_Generic_Access_Type
(T
: Entity_Id
; Def
: Node_Id
);
356 -- Create a new access type with the given designated type
358 function Analyze_Associations
361 F_Copy
: List_Id
) return List_Id
;
362 -- At instantiation time, build the list of associations between formals
363 -- and actuals. Each association becomes a renaming declaration for the
364 -- formal entity. F_Copy is the analyzed list of formals in the generic
365 -- copy. It is used to apply legality checks to the actuals. I_Node is the
366 -- instantiation node itself.
368 procedure Analyze_Subprogram_Instantiation
372 procedure Build_Instance_Compilation_Unit_Nodes
376 -- This procedure is used in the case where the generic instance of a
377 -- subprogram body or package body is a library unit. In this case, the
378 -- original library unit node for the generic instantiation must be
379 -- replaced by the resulting generic body, and a link made to a new
380 -- compilation unit node for the generic declaration. The argument N is
381 -- the original generic instantiation. Act_Body and Act_Decl are the body
382 -- and declaration of the instance (either package body and declaration
383 -- nodes or subprogram body and declaration nodes depending on the case).
384 -- On return, the node N has been rewritten with the actual body.
386 procedure Check_Access_Definition
(N
: Node_Id
);
387 -- Subsidiary routine to null exclusion processing. Perform an assertion
388 -- check on Ada version and the presence of an access definition in N.
390 procedure Check_Formal_Packages
(P_Id
: Entity_Id
);
391 -- Apply the following to all formal packages in generic associations
393 procedure Check_Formal_Package_Instance
394 (Formal_Pack
: Entity_Id
;
395 Actual_Pack
: Entity_Id
);
396 -- Verify that the actuals of the actual instance match the actuals of
397 -- the template for a formal package that is not declared with a box.
399 procedure Check_Forward_Instantiation
(Decl
: Node_Id
);
400 -- If the generic is a local entity and the corresponding body has not
401 -- been seen yet, flag enclosing packages to indicate that it will be
402 -- elaborated after the generic body. Subprograms declared in the same
403 -- package cannot be inlined by the front-end because front-end inlining
404 -- requires a strict linear order of elaboration.
406 function Check_Hidden_Primitives
(Assoc_List
: List_Id
) return Elist_Id
;
407 -- Check if some association between formals and actuals requires to make
408 -- visible primitives of a tagged type, and make those primitives visible.
409 -- Return the list of primitives whose visibility is modified (to restore
410 -- their visibility later through Restore_Hidden_Primitives). If no
411 -- candidate is found then return No_Elist.
413 procedure Check_Hidden_Child_Unit
415 Gen_Unit
: Entity_Id
;
416 Act_Decl_Id
: Entity_Id
);
417 -- If the generic unit is an implicit child instance within a parent
418 -- instance, we need to make an explicit test that it is not hidden by
419 -- a child instance of the same name and parent.
421 procedure Check_Generic_Actuals
422 (Instance
: Entity_Id
;
423 Is_Formal_Box
: Boolean);
424 -- Similar to previous one. Check the actuals in the instantiation,
425 -- whose views can change between the point of instantiation and the point
426 -- of instantiation of the body. In addition, mark the generic renamings
427 -- as generic actuals, so that they are not compatible with other actuals.
428 -- Recurse on an actual that is a formal package whose declaration has
431 function Contains_Instance_Of
434 N
: Node_Id
) return Boolean;
435 -- Inner is instantiated within the generic Outer. Check whether Inner
436 -- directly or indirectly contains an instance of Outer or of one of its
437 -- parents, in the case of a subunit. Each generic unit holds a list of
438 -- the entities instantiated within (at any depth). This procedure
439 -- determines whether the set of such lists contains a cycle, i.e. an
440 -- illegal circular instantiation.
442 function Denotes_Formal_Package
444 On_Exit
: Boolean := False;
445 Instance
: Entity_Id
:= Empty
) return Boolean;
446 -- Returns True if E is a formal package of an enclosing generic, or
447 -- the actual for such a formal in an enclosing instantiation. If such
448 -- a package is used as a formal in an nested generic, or as an actual
449 -- in a nested instantiation, the visibility of ITS formals should not
450 -- be modified. When called from within Restore_Private_Views, the flag
451 -- On_Exit is true, to indicate that the search for a possible enclosing
452 -- instance should ignore the current one. In that case Instance denotes
453 -- the declaration for which this is an actual. This declaration may be
454 -- an instantiation in the source, or the internal instantiation that
455 -- corresponds to the actual for a formal package.
457 function Earlier
(N1
, N2
: Node_Id
) return Boolean;
458 -- Yields True if N1 and N2 appear in the same compilation unit,
459 -- ignoring subunits, and if N1 is to the left of N2 in a left-to-right
460 -- traversal of the tree for the unit. Used to determine the placement
461 -- of freeze nodes for instance bodies that may depend on other instances.
463 function Find_Actual_Type
465 Gen_Type
: Entity_Id
) return Entity_Id
;
466 -- When validating the actual types of a child instance, check whether
467 -- the formal is a formal type of the parent unit, and retrieve the current
468 -- actual for it. Typ is the entity in the analyzed formal type declaration
469 -- (component or index type of an array type, or designated type of an
470 -- access formal) and Gen_Type is the enclosing analyzed formal array
471 -- or access type. The desired actual may be a formal of a parent, or may
472 -- be declared in a formal package of a parent. In both cases it is a
473 -- generic actual type because it appears within a visible instance.
474 -- Finally, it may be declared in a parent unit without being a formal
475 -- of that unit, in which case it must be retrieved by visibility.
476 -- Ambiguities may still arise if two homonyms are declared in two formal
477 -- packages, and the prefix of the formal type may be needed to resolve
478 -- the ambiguity in the instance ???
480 function In_Same_Declarative_Part
482 Inst
: Node_Id
) return Boolean;
483 -- True if the instantiation Inst and the given freeze_node F_Node appear
484 -- within the same declarative part, ignoring subunits, but with no inter-
485 -- vening subprograms or concurrent units. Used to find the proper plave
486 -- for the freeze node of an instance, when the generic is declared in a
487 -- previous instance. If predicate is true, the freeze node of the instance
488 -- can be placed after the freeze node of the previous instance, Otherwise
489 -- it has to be placed at the end of the current declarative part.
491 function In_Main_Context
(E
: Entity_Id
) return Boolean;
492 -- Check whether an instantiation is in the context of the main unit.
493 -- Used to determine whether its body should be elaborated to allow
494 -- front-end inlining.
496 procedure Set_Instance_Env
497 (Gen_Unit
: Entity_Id
;
498 Act_Unit
: Entity_Id
);
499 -- Save current instance on saved environment, to be used to determine
500 -- the global status of entities in nested instances. Part of Save_Env.
501 -- called after verifying that the generic unit is legal for the instance,
502 -- The procedure also examines whether the generic unit is a predefined
503 -- unit, in order to set configuration switches accordingly. As a result
504 -- the procedure must be called after analyzing and freezing the actuals.
506 procedure Set_Instance_Of
(A
: Entity_Id
; B
: Entity_Id
);
507 -- Associate analyzed generic parameter with corresponding
508 -- instance. Used for semantic checks at instantiation time.
510 function Has_Been_Exchanged
(E
: Entity_Id
) return Boolean;
511 -- Traverse the Exchanged_Views list to see if a type was private
512 -- and has already been flipped during this phase of instantiation.
514 procedure Hide_Current_Scope
;
515 -- When instantiating a generic child unit, the parent context must be
516 -- present, but the instance and all entities that may be generated
517 -- must be inserted in the current scope. We leave the current scope
518 -- on the stack, but make its entities invisible to avoid visibility
519 -- problems. This is reversed at the end of the instantiation. This is
520 -- not done for the instantiation of the bodies, which only require the
521 -- instances of the generic parents to be in scope.
523 procedure Install_Body
528 -- If the instantiation happens textually before the body of the generic,
529 -- the instantiation of the body must be analyzed after the generic body,
530 -- and not at the point of instantiation. Such early instantiations can
531 -- happen if the generic and the instance appear in a package declaration
532 -- because the generic body can only appear in the corresponding package
533 -- body. Early instantiations can also appear if generic, instance and
534 -- body are all in the declarative part of a subprogram or entry. Entities
535 -- of packages that are early instantiations are delayed, and their freeze
536 -- node appears after the generic body.
538 procedure Insert_Freeze_Node_For_Instance
541 -- N denotes a package or a subprogram instantiation and F_Node is the
542 -- associated freeze node. Insert the freeze node before the first source
543 -- body which follows immediately after N. If no such body is found, the
544 -- freeze node is inserted at the end of the declarative region which
547 procedure Freeze_Subprogram_Body
548 (Inst_Node
: Node_Id
;
550 Pack_Id
: Entity_Id
);
551 -- The generic body may appear textually after the instance, including
552 -- in the proper body of a stub, or within a different package instance.
553 -- Given that the instance can only be elaborated after the generic, we
554 -- place freeze_nodes for the instance and/or for packages that may enclose
555 -- the instance and the generic, so that the back-end can establish the
556 -- proper order of elaboration.
559 -- Establish environment for subsequent instantiation. Separated from
560 -- Save_Env because data-structures for visibility handling must be
561 -- initialized before call to Check_Generic_Child_Unit.
563 procedure Install_Formal_Packages
(Par
: Entity_Id
);
564 -- Install the visible part of any formal of the parent that is a formal
565 -- package. Note that for the case of a formal package with a box, this
566 -- includes the formal part of the formal package (12.7(10/2)).
568 procedure Install_Parent
(P
: Entity_Id
; In_Body
: Boolean := False);
569 -- When compiling an instance of a child unit the parent (which is
570 -- itself an instance) is an enclosing scope that must be made
571 -- immediately visible. This procedure is also used to install the non-
572 -- generic parent of a generic child unit when compiling its body, so
573 -- that full views of types in the parent are made visible.
575 procedure Remove_Parent
(In_Body
: Boolean := False);
576 -- Reverse effect after instantiation of child is complete
578 procedure Install_Hidden_Primitives
579 (Prims_List
: in out Elist_Id
;
582 -- Remove suffix 'P' from hidden primitives of Act_T to match the
583 -- visibility of primitives of Gen_T. The list of primitives to which
584 -- the suffix is removed is added to Prims_List to restore them later.
586 procedure Restore_Hidden_Primitives
(Prims_List
: in out Elist_Id
);
587 -- Restore suffix 'P' to primitives of Prims_List and leave Prims_List
590 procedure Inline_Instance_Body
592 Gen_Unit
: Entity_Id
;
594 -- If front-end inlining is requested, instantiate the package body,
595 -- and preserve the visibility of its compilation unit, to insure
596 -- that successive instantiations succeed.
598 -- The functions Instantiate_XXX perform various legality checks and build
599 -- the declarations for instantiated generic parameters. In all of these
600 -- Formal is the entity in the generic unit, Actual is the entity of
601 -- expression in the generic associations, and Analyzed_Formal is the
602 -- formal in the generic copy, which contains the semantic information to
603 -- be used to validate the actual.
605 function Instantiate_Object
608 Analyzed_Formal
: Node_Id
) return List_Id
;
610 function Instantiate_Type
613 Analyzed_Formal
: Node_Id
;
614 Actual_Decls
: List_Id
) return List_Id
;
616 function Instantiate_Formal_Subprogram
619 Analyzed_Formal
: Node_Id
) return Node_Id
;
621 function Instantiate_Formal_Package
624 Analyzed_Formal
: Node_Id
) return List_Id
;
625 -- If the formal package is declared with a box, special visibility rules
626 -- apply to its formals: they are in the visible part of the package. This
627 -- is true in the declarative region of the formal package, that is to say
628 -- in the enclosing generic or instantiation. For an instantiation, the
629 -- parameters of the formal package are made visible in an explicit step.
630 -- Furthermore, if the actual has a visible USE clause, these formals must
631 -- be made potentially use-visible as well. On exit from the enclosing
632 -- instantiation, the reverse must be done.
634 -- For a formal package declared without a box, there are conformance rules
635 -- that apply to the actuals in the generic declaration and the actuals of
636 -- the actual package in the enclosing instantiation. The simplest way to
637 -- apply these rules is to repeat the instantiation of the formal package
638 -- in the context of the enclosing instance, and compare the generic
639 -- associations of this instantiation with those of the actual package.
640 -- This internal instantiation only needs to contain the renamings of the
641 -- formals: the visible and private declarations themselves need not be
644 -- In Ada 2005, the formal package may be only partially parameterized.
645 -- In that case the visibility step must make visible those actuals whose
646 -- corresponding formals were given with a box. A final complication
647 -- involves inherited operations from formal derived types, which must
648 -- be visible if the type is.
650 function Is_In_Main_Unit
(N
: Node_Id
) return Boolean;
651 -- Test if given node is in the main unit
653 procedure Load_Parent_Of_Generic
656 Body_Optional
: Boolean := False);
657 -- If the generic appears in a separate non-generic library unit, load the
658 -- corresponding body to retrieve the body of the generic. N is the node
659 -- for the generic instantiation, Spec is the generic package declaration.
661 -- Body_Optional is a flag that indicates that the body is being loaded to
662 -- ensure that temporaries are generated consistently when there are other
663 -- instances in the current declarative part that precede the one being
664 -- loaded. In that case a missing body is acceptable.
666 procedure Inherit_Context
(Gen_Decl
: Node_Id
; Inst
: Node_Id
);
667 -- Add the context clause of the unit containing a generic unit to a
668 -- compilation unit that is, or contains, an instantiation.
670 function Get_Associated_Node
(N
: Node_Id
) return Node_Id
;
671 -- In order to propagate semantic information back from the analyzed copy
672 -- to the original generic, we maintain links between selected nodes in the
673 -- generic and their corresponding copies. At the end of generic analysis,
674 -- the routine Save_Global_References traverses the generic tree, examines
675 -- the semantic information, and preserves the links to those nodes that
676 -- contain global information. At instantiation, the information from the
677 -- associated node is placed on the new copy, so that name resolution is
680 -- Three kinds of source nodes have associated nodes:
682 -- a) those that can reference (denote) entities, that is identifiers,
683 -- character literals, expanded_names, operator symbols, operators,
684 -- and attribute reference nodes. These nodes have an Entity field
685 -- and are the set of nodes that are in N_Has_Entity.
687 -- b) aggregates (N_Aggregate and N_Extension_Aggregate)
689 -- c) selected components (N_Selected_Component)
691 -- For the first class, the associated node preserves the entity if it is
692 -- global. If the generic contains nested instantiations, the associated
693 -- node itself has been recopied, and a chain of them must be followed.
695 -- For aggregates, the associated node allows retrieval of the type, which
696 -- may otherwise not appear in the generic. The view of this type may be
697 -- different between generic and instantiation, and the full view can be
698 -- installed before the instantiation is analyzed. For aggregates of type
699 -- extensions, the same view exchange may have to be performed for some of
700 -- the ancestor types, if their view is private at the point of
703 -- Nodes that are selected components in the parse tree may be rewritten
704 -- as expanded names after resolution, and must be treated as potential
705 -- entity holders, which is why they also have an Associated_Node.
707 -- Nodes that do not come from source, such as freeze nodes, do not appear
708 -- in the generic tree, and need not have an associated node.
710 -- The associated node is stored in the Associated_Node field. Note that
711 -- this field overlaps Entity, which is fine, because the whole point is
712 -- that we don't need or want the normal Entity field in this situation.
714 procedure Map_Formal_Package_Entities
(Form
: Entity_Id
; Act
: Entity_Id
);
715 -- Within the generic part, entities in the formal package are
716 -- visible. To validate subsequent type declarations, indicate
717 -- the correspondence between the entities in the analyzed formal,
718 -- and the entities in the actual package. There are three packages
719 -- involved in the instantiation of a formal package: the parent
720 -- generic P1 which appears in the generic declaration, the fake
721 -- instantiation P2 which appears in the analyzed generic, and whose
722 -- visible entities may be used in subsequent formals, and the actual
723 -- P3 in the instance. To validate subsequent formals, me indicate
724 -- that the entities in P2 are mapped into those of P3. The mapping of
725 -- entities has to be done recursively for nested packages.
727 procedure Move_Freeze_Nodes
731 -- Freeze nodes can be generated in the analysis of a generic unit, but
732 -- will not be seen by the back-end. It is necessary to move those nodes
733 -- to the enclosing scope if they freeze an outer entity. We place them
734 -- at the end of the enclosing generic package, which is semantically
737 procedure Preanalyze_Actuals
(N
: Node_Id
);
738 -- Analyze actuals to perform name resolution. Full resolution is done
739 -- later, when the expected types are known, but names have to be captured
740 -- before installing parents of generics, that are not visible for the
741 -- actuals themselves.
743 function True_Parent
(N
: Node_Id
) return Node_Id
;
744 -- For a subunit, return parent of corresponding stub, else return
747 procedure Valid_Default_Attribute
(Nam
: Entity_Id
; Def
: Node_Id
);
748 -- Verify that an attribute that appears as the default for a formal
749 -- subprogram is a function or procedure with the correct profile.
751 -------------------------------------------
752 -- Data Structures for Generic Renamings --
753 -------------------------------------------
755 -- The map Generic_Renamings associates generic entities with their
756 -- corresponding actuals. Currently used to validate type instances. It
757 -- will eventually be used for all generic parameters to eliminate the
758 -- need for overload resolution in the instance.
760 type Assoc_Ptr
is new Int
;
762 Assoc_Null
: constant Assoc_Ptr
:= -1;
767 Next_In_HTable
: Assoc_Ptr
;
770 package Generic_Renamings
is new Table
.Table
771 (Table_Component_Type
=> Assoc
,
772 Table_Index_Type
=> Assoc_Ptr
,
773 Table_Low_Bound
=> 0,
775 Table_Increment
=> 100,
776 Table_Name
=> "Generic_Renamings");
778 -- Variable to hold enclosing instantiation. When the environment is
779 -- saved for a subprogram inlining, the corresponding Act_Id is empty.
781 Current_Instantiated_Parent
: Assoc
:= (Empty
, Empty
, Assoc_Null
);
783 -- Hash table for associations
785 HTable_Size
: constant := 37;
786 type HTable_Range
is range 0 .. HTable_Size
- 1;
788 procedure Set_Next_Assoc
(E
: Assoc_Ptr
; Next
: Assoc_Ptr
);
789 function Next_Assoc
(E
: Assoc_Ptr
) return Assoc_Ptr
;
790 function Get_Gen_Id
(E
: Assoc_Ptr
) return Entity_Id
;
791 function Hash
(F
: Entity_Id
) return HTable_Range
;
793 package Generic_Renamings_HTable
is new GNAT
.HTable
.Static_HTable
(
794 Header_Num
=> HTable_Range
,
796 Elmt_Ptr
=> Assoc_Ptr
,
797 Null_Ptr
=> Assoc_Null
,
798 Set_Next
=> Set_Next_Assoc
,
801 Get_Key
=> Get_Gen_Id
,
805 Exchanged_Views
: Elist_Id
;
806 -- This list holds the private views that have been exchanged during
807 -- instantiation to restore the visibility of the generic declaration.
808 -- (see comments above). After instantiation, the current visibility is
809 -- reestablished by means of a traversal of this list.
811 Hidden_Entities
: Elist_Id
;
812 -- This list holds the entities of the current scope that are removed
813 -- from immediate visibility when instantiating a child unit. Their
814 -- visibility is restored in Remove_Parent.
816 -- Because instantiations can be recursive, the following must be saved
817 -- on entry and restored on exit from an instantiation (spec or body).
818 -- This is done by the two procedures Save_Env and Restore_Env. For
819 -- package and subprogram instantiations (but not for the body instances)
820 -- the action of Save_Env is done in two steps: Init_Env is called before
821 -- Check_Generic_Child_Unit, because setting the parent instances requires
822 -- that the visibility data structures be properly initialized. Once the
823 -- generic is unit is validated, Set_Instance_Env completes Save_Env.
825 Parent_Unit_Visible
: Boolean := False;
826 -- Parent_Unit_Visible is used when the generic is a child unit, and
827 -- indicates whether the ultimate parent of the generic is visible in the
828 -- instantiation environment. It is used to reset the visibility of the
829 -- parent at the end of the instantiation (see Remove_Parent).
831 Instance_Parent_Unit
: Entity_Id
:= Empty
;
832 -- This records the ultimate parent unit of an instance of a generic
833 -- child unit and is used in conjunction with Parent_Unit_Visible to
834 -- indicate the unit to which the Parent_Unit_Visible flag corresponds.
836 type Instance_Env
is record
837 Instantiated_Parent
: Assoc
;
838 Exchanged_Views
: Elist_Id
;
839 Hidden_Entities
: Elist_Id
;
840 Current_Sem_Unit
: Unit_Number_Type
;
841 Parent_Unit_Visible
: Boolean := False;
842 Instance_Parent_Unit
: Entity_Id
:= Empty
;
843 Switches
: Config_Switches_Type
;
846 package Instance_Envs
is new Table
.Table
(
847 Table_Component_Type
=> Instance_Env
,
848 Table_Index_Type
=> Int
,
849 Table_Low_Bound
=> 0,
851 Table_Increment
=> 100,
852 Table_Name
=> "Instance_Envs");
854 procedure Restore_Private_Views
855 (Pack_Id
: Entity_Id
;
856 Is_Package
: Boolean := True);
857 -- Restore the private views of external types, and unmark the generic
858 -- renamings of actuals, so that they become compatible subtypes again.
859 -- For subprograms, Pack_Id is the package constructed to hold the
862 procedure Switch_View
(T
: Entity_Id
);
863 -- Switch the partial and full views of a type and its private
864 -- dependents (i.e. its subtypes and derived types).
866 ------------------------------------
867 -- Structures for Error Reporting --
868 ------------------------------------
870 Instantiation_Node
: Node_Id
;
871 -- Used by subprograms that validate instantiation of formal parameters
872 -- where there might be no actual on which to place the error message.
873 -- Also used to locate the instantiation node for generic subunits.
875 Instantiation_Error
: exception;
876 -- When there is a semantic error in the generic parameter matching,
877 -- there is no point in continuing the instantiation, because the
878 -- number of cascaded errors is unpredictable. This exception aborts
879 -- the instantiation process altogether.
881 S_Adjustment
: Sloc_Adjustment
;
882 -- Offset created for each node in an instantiation, in order to keep
883 -- track of the source position of the instantiation in each of its nodes.
884 -- A subsequent semantic error or warning on a construct of the instance
885 -- points to both places: the original generic node, and the point of
886 -- instantiation. See Sinput and Sinput.L for additional details.
888 ------------------------------------------------------------
889 -- Data structure for keeping track when inside a Generic --
890 ------------------------------------------------------------
892 -- The following table is used to save values of the Inside_A_Generic
893 -- flag (see spec of Sem) when they are saved by Start_Generic.
895 package Generic_Flags
is new Table
.Table
(
896 Table_Component_Type
=> Boolean,
897 Table_Index_Type
=> Int
,
898 Table_Low_Bound
=> 0,
900 Table_Increment
=> 200,
901 Table_Name
=> "Generic_Flags");
903 ---------------------------
904 -- Abandon_Instantiation --
905 ---------------------------
907 procedure Abandon_Instantiation
(N
: Node_Id
) is
909 Error_Msg_N
("\instantiation abandoned!", N
);
910 raise Instantiation_Error
;
911 end Abandon_Instantiation
;
913 --------------------------
914 -- Analyze_Associations --
915 --------------------------
917 function Analyze_Associations
920 F_Copy
: List_Id
) return List_Id
922 Actuals_To_Freeze
: constant Elist_Id
:= New_Elmt_List
;
923 Assoc
: constant List_Id
:= New_List
;
924 Default_Actuals
: constant Elist_Id
:= New_Elmt_List
;
925 Gen_Unit
: constant Entity_Id
:=
926 Defining_Entity
(Parent
(F_Copy
));
930 Analyzed_Formal
: Node_Id
;
931 First_Named
: Node_Id
:= Empty
;
935 Saved_Formal
: Node_Id
;
937 Default_Formals
: constant List_Id
:= New_List
;
938 -- If an Others_Choice is present, some of the formals may be defaulted.
939 -- To simplify the treatment of visibility in an instance, we introduce
940 -- individual defaults for each such formal. These defaults are
941 -- appended to the list of associations and replace the Others_Choice.
943 Found_Assoc
: Node_Id
;
944 -- Association for the current formal being match. Empty if there are
945 -- no remaining actuals, or if there is no named association with the
946 -- name of the formal.
948 Is_Named_Assoc
: Boolean;
949 Num_Matched
: Int
:= 0;
950 Num_Actuals
: Int
:= 0;
952 Others_Present
: Boolean := False;
953 Others_Choice
: Node_Id
:= Empty
;
954 -- In Ada 2005, indicates partial parameterization of a formal
955 -- package. As usual an other association must be last in the list.
957 function Build_Function_Wrapper
959 Actual
: Entity_Id
:= Empty
) return Node_Id
;
960 -- In GNATprove mode, create a wrapper function for actuals that are
961 -- functions with any number of formal parameters, in order to propagate
962 -- their contract to the renaming declarations generated for them.
963 -- If the actual is absent, the formal has a default, and the name of
964 -- the function is that of the formal.
966 function Build_Operator_Wrapper
968 Actual
: Entity_Id
:= Empty
) return Node_Id
;
969 -- In GNATprove mode, create a wrapper function for actuals that are
970 -- operators, in order to propagate their contract to the renaming
971 -- declarations generated for them. If the actual is absent, this is
972 -- a formal with a default, and the name of the operator is that of the
975 procedure Check_Overloaded_Formal_Subprogram
(Formal
: Entity_Id
);
976 -- Apply RM 12.3 (9): if a formal subprogram is overloaded, the instance
977 -- cannot have a named association for it. AI05-0025 extends this rule
978 -- to formals of formal packages by AI05-0025, and it also applies to
979 -- box-initialized formals.
981 function Has_Fully_Defined_Profile
(Subp
: Entity_Id
) return Boolean;
982 -- Determine whether the parameter types and the return type of Subp
983 -- are fully defined at the point of instantiation.
985 function Matching_Actual
987 A_F
: Entity_Id
) return Node_Id
;
988 -- Find actual that corresponds to a given a formal parameter. If the
989 -- actuals are positional, return the next one, if any. If the actuals
990 -- are named, scan the parameter associations to find the right one.
991 -- A_F is the corresponding entity in the analyzed generic,which is
992 -- placed on the selector name for ASIS use.
994 -- In Ada 2005, a named association may be given with a box, in which
995 -- case Matching_Actual sets Found_Assoc to the generic association,
996 -- but return Empty for the actual itself. In this case the code below
997 -- creates a corresponding declaration for the formal.
999 function Partial_Parameterization
return Boolean;
1000 -- Ada 2005: if no match is found for a given formal, check if the
1001 -- association for it includes a box, or whether the associations
1002 -- include an Others clause.
1004 procedure Process_Default
(F
: Entity_Id
);
1005 -- Add a copy of the declaration of generic formal F to the list of
1006 -- associations, and add an explicit box association for F if there
1007 -- is none yet, and the default comes from an Others_Choice.
1009 function Renames_Standard_Subprogram
(Subp
: Entity_Id
) return Boolean;
1010 -- Determine whether Subp renames one of the subprograms defined in the
1011 -- generated package Standard.
1013 procedure Set_Analyzed_Formal
;
1014 -- Find the node in the generic copy that corresponds to a given formal.
1015 -- The semantic information on this node is used to perform legality
1016 -- checks on the actuals. Because semantic analysis can introduce some
1017 -- anonymous entities or modify the declaration node itself, the
1018 -- correspondence between the two lists is not one-one. In addition to
1019 -- anonymous types, the presence a formal equality will introduce an
1020 -- implicit declaration for the corresponding inequality.
1022 ----------------------------
1023 -- Build_Function_Wrapper --
1024 ----------------------------
1026 function Build_Function_Wrapper
1027 (Formal
: Entity_Id
;
1028 Actual
: Entity_Id
:= Empty
) return Node_Id
1030 Loc
: constant Source_Ptr
:= Sloc
(I_Node
);
1033 Func_Name
: Node_Id
;
1035 Parm_Type
: Node_Id
;
1036 Profile
: List_Id
:= New_List
;
1043 -- If there is no actual, the formal has a default and is retrieved
1044 -- by name. Otherwise the wrapper encloses a call to the actual.
1047 Func_Name
:= Make_Identifier
(Loc
, Chars
(Formal
));
1049 Func_Name
:= New_Occurrence_Of
(Entity
(Actual
), Loc
);
1052 Func
:= Make_Defining_Identifier
(Loc
, Chars
(Formal
));
1053 Set_Ekind
(Func
, E_Function
);
1054 Set_Is_Generic_Actual_Subprogram
(Func
);
1056 Actuals
:= New_List
;
1057 Profile
:= New_List
;
1059 if Present
(Actual
) then
1060 Act_F
:= First_Formal
(Entity
(Actual
));
1065 Form_F
:= First_Formal
(Formal
);
1066 while Present
(Form_F
) loop
1068 -- Create new formal for profile of wrapper, and add a reference
1069 -- to it in the list of actuals for the enclosing call. The name
1070 -- must be that of the formal in the formal subprogram, because
1071 -- calls to it in the generic body may use named associations.
1073 New_F
:= Make_Defining_Identifier
(Loc
, Chars
(Form_F
));
1077 -- If formal has a class-wide type rewrite as the corresponding
1078 -- attribute, because the class-wide type is not retrievable by
1081 if Is_Class_Wide_Type
(Etype
(Form_F
)) then
1083 Make_Attribute_Reference
(Loc
,
1084 Attribute_Name
=> Name_Class
,
1086 Make_Identifier
(Loc
, Chars
(Etype
(Etype
(Form_F
)))));
1090 Make_Identifier
(Loc
,
1091 Chars
=> Chars
(First_Subtype
(Etype
(Form_F
))));
1094 -- If actual is present, use the type of its own formal
1097 Parm_Type
:= New_Occurrence_Of
(Etype
(Act_F
), Loc
);
1101 Make_Parameter_Specification
(Loc
,
1102 Defining_Identifier
=> New_F
,
1103 Parameter_Type
=> Parm_Type
));
1105 Append_To
(Actuals
, New_Occurrence_Of
(New_F
, Loc
));
1106 Next_Formal
(Form_F
);
1108 if Present
(Act_F
) then
1109 Next_Formal
(Act_F
);
1114 Make_Function_Specification
(Loc
,
1115 Defining_Unit_Name
=> Func
,
1116 Parameter_Specifications
=> Profile
,
1117 Result_Definition
=>
1118 Make_Identifier
(Loc
, Chars
(Etype
(Formal
))));
1121 Make_Expression_Function
(Loc
,
1122 Specification
=> Spec
,
1124 Make_Function_Call
(Loc
,
1126 Parameter_Associations
=> Actuals
));
1129 end Build_Function_Wrapper
;
1131 ----------------------------
1132 -- Build_Operator_Wrapper --
1133 ----------------------------
1135 function Build_Operator_Wrapper
1136 (Formal
: Entity_Id
;
1137 Actual
: Entity_Id
:= Empty
) return Node_Id
1139 Loc
: constant Source_Ptr
:= Sloc
(I_Node
);
1140 Typ
: constant Entity_Id
:= Etype
(Formal
);
1141 Is_Binary
: constant Boolean :=
1142 Present
(Next_Formal
(First_Formal
(Formal
)));
1154 Op_Name
:= Chars
(Formal
);
1156 Op_Name
:= Chars
(Actual
);
1159 -- Create entities for wrapper function and its formals
1161 F1
:= Make_Temporary
(Loc
, 'A');
1162 F2
:= Make_Temporary
(Loc
, 'B');
1163 L
:= New_Occurrence_Of
(F1
, Loc
);
1164 R
:= New_Occurrence_Of
(F2
, Loc
);
1166 Func
:= Make_Defining_Identifier
(Loc
, Chars
(Formal
));
1167 Set_Ekind
(Func
, E_Function
);
1168 Set_Is_Generic_Actual_Subprogram
(Func
);
1171 Make_Function_Specification
(Loc
,
1172 Defining_Unit_Name
=> Func
,
1173 Parameter_Specifications
=> New_List
(
1174 Make_Parameter_Specification
(Loc
,
1175 Defining_Identifier
=> F1
,
1177 Make_Identifier
(Loc
,
1178 Chars
=> Chars
(Etype
(First_Formal
(Formal
)))))),
1179 Result_Definition
=> Make_Identifier
(Loc
, Chars
(Typ
)));
1182 Append_To
(Parameter_Specifications
(Spec
),
1183 Make_Parameter_Specification
(Loc
,
1184 Defining_Identifier
=> F2
,
1186 Make_Identifier
(Loc
,
1187 Chars
(Etype
(Next_Formal
(First_Formal
(Formal
)))))));
1190 -- Build expression as a function call, or as an operator node
1191 -- that corresponds to the name of the actual, starting with binary
1194 if Present
(Actual
) and then Op_Name
not in Any_Operator_Name
then
1196 Make_Function_Call
(Loc
,
1198 New_Occurrence_Of
(Entity
(Actual
), Loc
),
1199 Parameter_Associations
=> New_List
(L
));
1202 Append_To
(Parameter_Associations
(Expr
), R
);
1207 elsif Is_Binary
then
1208 if Op_Name
= Name_Op_And
then
1209 Expr
:= Make_Op_And
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
1210 elsif Op_Name
= Name_Op_Or
then
1211 Expr
:= Make_Op_Or
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
1212 elsif Op_Name
= Name_Op_Xor
then
1213 Expr
:= Make_Op_Xor
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
1214 elsif Op_Name
= Name_Op_Eq
then
1215 Expr
:= Make_Op_Eq
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
1216 elsif Op_Name
= Name_Op_Ne
then
1217 Expr
:= Make_Op_Ne
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
1218 elsif Op_Name
= Name_Op_Le
then
1219 Expr
:= Make_Op_Le
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
1220 elsif Op_Name
= Name_Op_Gt
then
1221 Expr
:= Make_Op_Gt
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
1222 elsif Op_Name
= Name_Op_Ge
then
1223 Expr
:= Make_Op_Ge
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
1224 elsif Op_Name
= Name_Op_Lt
then
1225 Expr
:= Make_Op_Lt
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
1226 elsif Op_Name
= Name_Op_Add
then
1227 Expr
:= Make_Op_Add
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
1228 elsif Op_Name
= Name_Op_Subtract
then
1229 Expr
:= Make_Op_Subtract
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
1230 elsif Op_Name
= Name_Op_Concat
then
1231 Expr
:= Make_Op_Concat
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
1232 elsif Op_Name
= Name_Op_Multiply
then
1233 Expr
:= Make_Op_Multiply
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
1234 elsif Op_Name
= Name_Op_Divide
then
1235 Expr
:= Make_Op_Divide
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
1236 elsif Op_Name
= Name_Op_Mod
then
1237 Expr
:= Make_Op_Mod
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
1238 elsif Op_Name
= Name_Op_Rem
then
1239 Expr
:= Make_Op_Rem
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
1240 elsif Op_Name
= Name_Op_Expon
then
1241 Expr
:= Make_Op_Expon
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
1247 if Op_Name
= Name_Op_Add
then
1248 Expr
:= Make_Op_Plus
(Loc
, Right_Opnd
=> L
);
1249 elsif Op_Name
= Name_Op_Subtract
then
1250 Expr
:= Make_Op_Minus
(Loc
, Right_Opnd
=> L
);
1251 elsif Op_Name
= Name_Op_Abs
then
1252 Expr
:= Make_Op_Abs
(Loc
, Right_Opnd
=> L
);
1253 elsif Op_Name
= Name_Op_Not
then
1254 Expr
:= Make_Op_Not
(Loc
, Right_Opnd
=> L
);
1258 -- Propagate visible entity to operator node, either from a
1259 -- given actual or from a default.
1261 if Is_Entity_Name
(Actual
) and then Nkind
(Expr
) in N_Op
then
1262 Set_Entity
(Expr
, Entity
(Actual
));
1266 Make_Expression_Function
(Loc
,
1267 Specification
=> Spec
,
1268 Expression
=> Expr
);
1271 end Build_Operator_Wrapper
;
1273 ----------------------------------------
1274 -- Check_Overloaded_Formal_Subprogram --
1275 ----------------------------------------
1277 procedure Check_Overloaded_Formal_Subprogram
(Formal
: Entity_Id
) is
1278 Temp_Formal
: Entity_Id
;
1281 Temp_Formal
:= First
(Formals
);
1282 while Present
(Temp_Formal
) loop
1283 if Nkind
(Temp_Formal
) in N_Formal_Subprogram_Declaration
1284 and then Temp_Formal
/= Formal
1286 Chars
(Defining_Unit_Name
(Specification
(Formal
))) =
1287 Chars
(Defining_Unit_Name
(Specification
(Temp_Formal
)))
1289 if Present
(Found_Assoc
) then
1291 ("named association not allowed for overloaded formal",
1296 ("named association not allowed for overloaded formal",
1300 Abandon_Instantiation
(Instantiation_Node
);
1305 end Check_Overloaded_Formal_Subprogram
;
1307 -------------------------------
1308 -- Has_Fully_Defined_Profile --
1309 -------------------------------
1311 function Has_Fully_Defined_Profile
(Subp
: Entity_Id
) return Boolean is
1312 function Is_Fully_Defined_Type
(Typ
: Entity_Id
) return Boolean;
1313 -- Determine whethet type Typ is fully defined
1315 ---------------------------
1316 -- Is_Fully_Defined_Type --
1317 ---------------------------
1319 function Is_Fully_Defined_Type
(Typ
: Entity_Id
) return Boolean is
1321 -- A private type without a full view is not fully defined
1323 if Is_Private_Type
(Typ
)
1324 and then No
(Full_View
(Typ
))
1328 -- An incomplete type is never fully defined
1330 elsif Is_Incomplete_Type
(Typ
) then
1333 -- All other types are fully defined
1338 end Is_Fully_Defined_Type
;
1340 -- Local declarations
1344 -- Start of processing for Has_Fully_Defined_Profile
1347 -- Check the parameters
1349 Param
:= First_Formal
(Subp
);
1350 while Present
(Param
) loop
1351 if not Is_Fully_Defined_Type
(Etype
(Param
)) then
1355 Next_Formal
(Param
);
1358 -- Check the return type
1360 return Is_Fully_Defined_Type
(Etype
(Subp
));
1361 end Has_Fully_Defined_Profile
;
1363 ---------------------
1364 -- Matching_Actual --
1365 ---------------------
1367 function Matching_Actual
1369 A_F
: Entity_Id
) return Node_Id
1375 Is_Named_Assoc
:= False;
1377 -- End of list of purely positional parameters
1379 if No
(Actual
) or else Nkind
(Actual
) = N_Others_Choice
then
1380 Found_Assoc
:= Empty
;
1383 -- Case of positional parameter corresponding to current formal
1385 elsif No
(Selector_Name
(Actual
)) then
1386 Found_Assoc
:= Actual
;
1387 Act
:= Explicit_Generic_Actual_Parameter
(Actual
);
1388 Num_Matched
:= Num_Matched
+ 1;
1391 -- Otherwise scan list of named actuals to find the one with the
1392 -- desired name. All remaining actuals have explicit names.
1395 Is_Named_Assoc
:= True;
1396 Found_Assoc
:= Empty
;
1400 while Present
(Actual
) loop
1401 if Chars
(Selector_Name
(Actual
)) = Chars
(F
) then
1402 Set_Entity
(Selector_Name
(Actual
), A_F
);
1403 Set_Etype
(Selector_Name
(Actual
), Etype
(A_F
));
1404 Generate_Reference
(A_F
, Selector_Name
(Actual
));
1405 Found_Assoc
:= Actual
;
1406 Act
:= Explicit_Generic_Actual_Parameter
(Actual
);
1407 Num_Matched
:= Num_Matched
+ 1;
1415 -- Reset for subsequent searches. In most cases the named
1416 -- associations are in order. If they are not, we reorder them
1417 -- to avoid scanning twice the same actual. This is not just a
1418 -- question of efficiency: there may be multiple defaults with
1419 -- boxes that have the same name. In a nested instantiation we
1420 -- insert actuals for those defaults, and cannot rely on their
1421 -- names to disambiguate them.
1423 if Actual
= First_Named
then
1426 elsif Present
(Actual
) then
1427 Insert_Before
(First_Named
, Remove_Next
(Prev
));
1430 Actual
:= First_Named
;
1433 if Is_Entity_Name
(Act
) and then Present
(Entity
(Act
)) then
1434 Set_Used_As_Generic_Actual
(Entity
(Act
));
1438 end Matching_Actual
;
1440 ------------------------------
1441 -- Partial_Parameterization --
1442 ------------------------------
1444 function Partial_Parameterization
return Boolean is
1446 return Others_Present
1447 or else (Present
(Found_Assoc
) and then Box_Present
(Found_Assoc
));
1448 end Partial_Parameterization
;
1450 ---------------------
1451 -- Process_Default --
1452 ---------------------
1454 procedure Process_Default
(F
: Entity_Id
) is
1455 Loc
: constant Source_Ptr
:= Sloc
(I_Node
);
1456 F_Id
: constant Entity_Id
:= Defining_Entity
(F
);
1462 -- Append copy of formal declaration to associations, and create new
1463 -- defining identifier for it.
1465 Decl
:= New_Copy_Tree
(F
);
1466 Id
:= Make_Defining_Identifier
(Sloc
(F_Id
), Chars
(F_Id
));
1468 if Nkind
(F
) in N_Formal_Subprogram_Declaration
then
1469 Set_Defining_Unit_Name
(Specification
(Decl
), Id
);
1472 Set_Defining_Identifier
(Decl
, Id
);
1475 Append
(Decl
, Assoc
);
1477 if No
(Found_Assoc
) then
1479 Make_Generic_Association
(Loc
,
1480 Selector_Name
=> New_Occurrence_Of
(Id
, Loc
),
1481 Explicit_Generic_Actual_Parameter
=> Empty
);
1482 Set_Box_Present
(Default
);
1483 Append
(Default
, Default_Formals
);
1485 end Process_Default
;
1487 ---------------------------------
1488 -- Renames_Standard_Subprogram --
1489 ---------------------------------
1491 function Renames_Standard_Subprogram
(Subp
: Entity_Id
) return Boolean is
1496 while Present
(Id
) loop
1497 if Scope
(Id
) = Standard_Standard
then
1505 end Renames_Standard_Subprogram
;
1507 -------------------------
1508 -- Set_Analyzed_Formal --
1509 -------------------------
1511 procedure Set_Analyzed_Formal
is
1515 while Present
(Analyzed_Formal
) loop
1516 Kind
:= Nkind
(Analyzed_Formal
);
1518 case Nkind
(Formal
) is
1520 when N_Formal_Subprogram_Declaration
=>
1521 exit when Kind
in N_Formal_Subprogram_Declaration
1524 (Defining_Unit_Name
(Specification
(Formal
))) =
1526 (Defining_Unit_Name
(Specification
(Analyzed_Formal
)));
1528 when N_Formal_Package_Declaration
=>
1529 exit when Nkind_In
(Kind
, N_Formal_Package_Declaration
,
1530 N_Generic_Package_Declaration
,
1531 N_Package_Declaration
);
1533 when N_Use_Package_Clause | N_Use_Type_Clause
=> exit;
1537 -- Skip freeze nodes, and nodes inserted to replace
1538 -- unrecognized pragmas.
1541 Kind
not in N_Formal_Subprogram_Declaration
1542 and then not Nkind_In
(Kind
, N_Subprogram_Declaration
,
1546 and then Chars
(Defining_Identifier
(Formal
)) =
1547 Chars
(Defining_Identifier
(Analyzed_Formal
));
1550 Next
(Analyzed_Formal
);
1552 end Set_Analyzed_Formal
;
1554 -- Start of processing for Analyze_Associations
1557 Actuals
:= Generic_Associations
(I_Node
);
1559 if Present
(Actuals
) then
1561 -- Check for an Others choice, indicating a partial parameterization
1562 -- for a formal package.
1564 Actual
:= First
(Actuals
);
1565 while Present
(Actual
) loop
1566 if Nkind
(Actual
) = N_Others_Choice
then
1567 Others_Present
:= True;
1568 Others_Choice
:= Actual
;
1570 if Present
(Next
(Actual
)) then
1571 Error_Msg_N
("others must be last association", Actual
);
1574 -- This subprogram is used both for formal packages and for
1575 -- instantiations. For the latter, associations must all be
1578 if Nkind
(I_Node
) /= N_Formal_Package_Declaration
1579 and then Comes_From_Source
(I_Node
)
1582 ("others association not allowed in an instance",
1586 -- In any case, nothing to do after the others association
1590 elsif Box_Present
(Actual
)
1591 and then Comes_From_Source
(I_Node
)
1592 and then Nkind
(I_Node
) /= N_Formal_Package_Declaration
1595 ("box association not allowed in an instance", Actual
);
1601 -- If named associations are present, save first named association
1602 -- (it may of course be Empty) to facilitate subsequent name search.
1604 First_Named
:= First
(Actuals
);
1605 while Present
(First_Named
)
1606 and then Nkind
(First_Named
) /= N_Others_Choice
1607 and then No
(Selector_Name
(First_Named
))
1609 Num_Actuals
:= Num_Actuals
+ 1;
1614 Named
:= First_Named
;
1615 while Present
(Named
) loop
1616 if Nkind
(Named
) /= N_Others_Choice
1617 and then No
(Selector_Name
(Named
))
1619 Error_Msg_N
("invalid positional actual after named one", Named
);
1620 Abandon_Instantiation
(Named
);
1623 -- A named association may lack an actual parameter, if it was
1624 -- introduced for a default subprogram that turns out to be local
1625 -- to the outer instantiation.
1627 if Nkind
(Named
) /= N_Others_Choice
1628 and then Present
(Explicit_Generic_Actual_Parameter
(Named
))
1630 Num_Actuals
:= Num_Actuals
+ 1;
1636 if Present
(Formals
) then
1637 Formal
:= First_Non_Pragma
(Formals
);
1638 Analyzed_Formal
:= First_Non_Pragma
(F_Copy
);
1640 if Present
(Actuals
) then
1641 Actual
:= First
(Actuals
);
1643 -- All formals should have default values
1649 while Present
(Formal
) loop
1650 Set_Analyzed_Formal
;
1651 Saved_Formal
:= Next_Non_Pragma
(Formal
);
1653 case Nkind
(Formal
) is
1654 when N_Formal_Object_Declaration
=>
1657 Defining_Identifier
(Formal
),
1658 Defining_Identifier
(Analyzed_Formal
));
1660 if No
(Match
) and then Partial_Parameterization
then
1661 Process_Default
(Formal
);
1664 (Instantiate_Object
(Formal
, Match
, Analyzed_Formal
),
1668 -- If the object is a call to an expression function, this
1669 -- is a freezing point for it.
1671 if Is_Entity_Name
(Match
)
1672 and then Present
(Entity
(Match
))
1674 (Original_Node
(Unit_Declaration_Node
(Entity
(Match
))))
1675 = N_Expression_Function
1677 Append_Elmt
(Entity
(Match
), Actuals_To_Freeze
);
1680 when N_Formal_Type_Declaration
=>
1683 Defining_Identifier
(Formal
),
1684 Defining_Identifier
(Analyzed_Formal
));
1687 if Partial_Parameterization
then
1688 Process_Default
(Formal
);
1691 Error_Msg_Sloc
:= Sloc
(Gen_Unit
);
1695 Defining_Identifier
(Formal
));
1696 Error_Msg_NE
("\in instantiation of & declared#",
1697 Instantiation_Node
, Gen_Unit
);
1698 Abandon_Instantiation
(Instantiation_Node
);
1705 (Formal
, Match
, Analyzed_Formal
, Assoc
),
1708 -- An instantiation is a freeze point for the actuals,
1709 -- unless this is a rewritten formal package, or the
1710 -- formal is an Ada 2012 formal incomplete type.
1712 if Nkind
(I_Node
) = N_Formal_Package_Declaration
1714 (Ada_Version
>= Ada_2012
1716 Ekind
(Defining_Identifier
(Analyzed_Formal
)) =
1722 Append_Elmt
(Entity
(Match
), Actuals_To_Freeze
);
1726 -- A remote access-to-class-wide type is not a legal actual
1727 -- for a generic formal of an access type (E.2.2(17/2)).
1728 -- In GNAT an exception to this rule is introduced when
1729 -- the formal is marked as remote using implementation
1730 -- defined aspect/pragma Remote_Access_Type. In that case
1731 -- the actual must be remote as well.
1733 -- If the current instantiation is the construction of a
1734 -- local copy for a formal package the actuals may be
1735 -- defaulted, and there is no matching actual to check.
1737 if Nkind
(Analyzed_Formal
) = N_Formal_Type_Declaration
1739 Nkind
(Formal_Type_Definition
(Analyzed_Formal
)) =
1740 N_Access_To_Object_Definition
1741 and then Present
(Match
)
1744 Formal_Ent
: constant Entity_Id
:=
1745 Defining_Identifier
(Analyzed_Formal
);
1747 if Is_Remote_Access_To_Class_Wide_Type
(Entity
(Match
))
1748 = Is_Remote_Types
(Formal_Ent
)
1750 -- Remoteness of formal and actual match
1754 elsif Is_Remote_Types
(Formal_Ent
) then
1756 -- Remote formal, non-remote actual
1759 ("actual for& must be remote", Match
, Formal_Ent
);
1762 -- Non-remote formal, remote actual
1765 ("actual for& may not be remote",
1771 when N_Formal_Subprogram_Declaration
=>
1774 (Defining_Unit_Name
(Specification
(Formal
)),
1775 Defining_Unit_Name
(Specification
(Analyzed_Formal
)));
1777 -- If the formal subprogram has the same name as another
1778 -- formal subprogram of the generic, then a named
1779 -- association is illegal (12.3(9)). Exclude named
1780 -- associations that are generated for a nested instance.
1783 and then Is_Named_Assoc
1784 and then Comes_From_Source
(Found_Assoc
)
1786 Check_Overloaded_Formal_Subprogram
(Formal
);
1789 -- If there is no corresponding actual, this may be case
1790 -- of partial parameterization, or else the formal has a
1791 -- default or a box.
1793 if No
(Match
) and then Partial_Parameterization
then
1794 Process_Default
(Formal
);
1796 if Nkind
(I_Node
) = N_Formal_Package_Declaration
then
1797 Check_Overloaded_Formal_Subprogram
(Formal
);
1803 (Containing_Package_With_Ext_Axioms
1804 (Defining_Entity
(Analyzed_Formal
)))
1805 and then Ekind
(Defining_Entity
(Analyzed_Formal
)) =
1808 -- If actual is an entity (function or operator),
1809 -- and expander is active, build wrapper for it.
1810 -- Note that wrappers play no role within a generic.
1812 if Present
(Match
) and then Expander_Active
then
1813 if Nkind
(Match
) = N_Operator_Symbol
then
1815 -- If the name is a default, find its visible
1816 -- entity at the point of instantiation.
1818 if Is_Entity_Name
(Match
)
1819 and then No
(Entity
(Match
))
1821 Find_Direct_Name
(Match
);
1826 Build_Operator_Wrapper
1827 (Defining_Entity
(Analyzed_Formal
), Match
));
1831 Build_Function_Wrapper
1832 (Defining_Entity
(Analyzed_Formal
), Match
));
1835 -- Ditto if formal is an operator with a default.
1837 elsif Box_Present
(Formal
)
1838 and then Nkind
(Defining_Entity
(Analyzed_Formal
)) =
1839 N_Defining_Operator_Symbol
1840 and then Expander_Active
1843 Build_Operator_Wrapper
1844 (Defining_Entity
(Analyzed_Formal
)));
1846 -- Otherwise create renaming declaration.
1850 Build_Function_Wrapper
1851 (Defining_Entity
(Analyzed_Formal
)));
1856 Instantiate_Formal_Subprogram
1857 (Formal
, Match
, Analyzed_Formal
));
1860 -- An instantiation is a freeze point for the actuals,
1861 -- unless this is a rewritten formal package.
1863 if Nkind
(I_Node
) /= N_Formal_Package_Declaration
1864 and then Nkind
(Match
) = N_Identifier
1865 and then Is_Subprogram
(Entity
(Match
))
1867 -- The actual subprogram may rename a routine defined
1868 -- in Standard. Avoid freezing such renamings because
1869 -- subprograms coming from Standard cannot be frozen.
1872 not Renames_Standard_Subprogram
(Entity
(Match
))
1874 -- If the actual subprogram comes from a different
1875 -- unit, it is already frozen, either by a body in
1876 -- that unit or by the end of the declarative part
1877 -- of the unit. This check avoids the freezing of
1878 -- subprograms defined in Standard which are used
1879 -- as generic actuals.
1881 and then In_Same_Code_Unit
(Entity
(Match
), I_Node
)
1882 and then Has_Fully_Defined_Profile
(Entity
(Match
))
1884 -- Mark the subprogram as having a delayed freeze
1885 -- since this may be an out-of-order action.
1887 Set_Has_Delayed_Freeze
(Entity
(Match
));
1888 Append_Elmt
(Entity
(Match
), Actuals_To_Freeze
);
1892 -- If this is a nested generic, preserve default for later
1895 if No
(Match
) and then Box_Present
(Formal
) then
1897 (Defining_Unit_Name
(Specification
(Last
(Assoc
))),
1901 when N_Formal_Package_Declaration
=>
1904 Defining_Identifier
(Formal
),
1905 Defining_Identifier
(Original_Node
(Analyzed_Formal
)));
1908 if Partial_Parameterization
then
1909 Process_Default
(Formal
);
1912 Error_Msg_Sloc
:= Sloc
(Gen_Unit
);
1915 Instantiation_Node
, Defining_Identifier
(Formal
));
1916 Error_Msg_NE
("\in instantiation of & declared#",
1917 Instantiation_Node
, Gen_Unit
);
1919 Abandon_Instantiation
(Instantiation_Node
);
1925 (Instantiate_Formal_Package
1926 (Formal
, Match
, Analyzed_Formal
),
1930 -- For use type and use package appearing in the generic part,
1931 -- we have already copied them, so we can just move them where
1932 -- they belong (we mustn't recopy them since this would mess up
1933 -- the Sloc values).
1935 when N_Use_Package_Clause |
1936 N_Use_Type_Clause
=>
1937 if Nkind
(Original_Node
(I_Node
)) =
1938 N_Formal_Package_Declaration
1940 Append
(New_Copy_Tree
(Formal
), Assoc
);
1943 Append
(Formal
, Assoc
);
1947 raise Program_Error
;
1951 Formal
:= Saved_Formal
;
1952 Next_Non_Pragma
(Analyzed_Formal
);
1955 if Num_Actuals
> Num_Matched
then
1956 Error_Msg_Sloc
:= Sloc
(Gen_Unit
);
1958 if Present
(Selector_Name
(Actual
)) then
1960 ("unmatched actual&",
1961 Actual
, Selector_Name
(Actual
));
1962 Error_Msg_NE
("\in instantiation of& declared#",
1966 ("unmatched actual in instantiation of& declared#",
1971 elsif Present
(Actuals
) then
1973 ("too many actuals in generic instantiation", Instantiation_Node
);
1976 -- An instantiation freezes all generic actuals. The only exceptions
1977 -- to this are incomplete types and subprograms which are not fully
1978 -- defined at the point of instantiation.
1981 Elmt
: Elmt_Id
:= First_Elmt
(Actuals_To_Freeze
);
1983 while Present
(Elmt
) loop
1984 Freeze_Before
(I_Node
, Node
(Elmt
));
1989 -- If there are default subprograms, normalize the tree by adding
1990 -- explicit associations for them. This is required if the instance
1991 -- appears within a generic.
1999 Elmt
:= First_Elmt
(Default_Actuals
);
2000 while Present
(Elmt
) loop
2001 if No
(Actuals
) then
2002 Actuals
:= New_List
;
2003 Set_Generic_Associations
(I_Node
, Actuals
);
2006 Subp
:= Node
(Elmt
);
2008 Make_Generic_Association
(Sloc
(Subp
),
2009 Selector_Name
=> New_Occurrence_Of
(Subp
, Sloc
(Subp
)),
2010 Explicit_Generic_Actual_Parameter
=>
2011 New_Occurrence_Of
(Subp
, Sloc
(Subp
)));
2012 Mark_Rewrite_Insertion
(New_D
);
2013 Append_To
(Actuals
, New_D
);
2018 -- If this is a formal package, normalize the parameter list by adding
2019 -- explicit box associations for the formals that are covered by an
2022 if not Is_Empty_List
(Default_Formals
) then
2023 Append_List
(Default_Formals
, Formals
);
2027 end Analyze_Associations
;
2029 -------------------------------
2030 -- Analyze_Formal_Array_Type --
2031 -------------------------------
2033 procedure Analyze_Formal_Array_Type
2034 (T
: in out Entity_Id
;
2040 -- Treated like a non-generic array declaration, with additional
2045 if Nkind
(Def
) = N_Constrained_Array_Definition
then
2046 DSS
:= First
(Discrete_Subtype_Definitions
(Def
));
2047 while Present
(DSS
) loop
2048 if Nkind_In
(DSS
, N_Subtype_Indication
,
2050 N_Attribute_Reference
)
2052 Error_Msg_N
("only a subtype mark is allowed in a formal", DSS
);
2059 Array_Type_Declaration
(T
, Def
);
2060 Set_Is_Generic_Type
(Base_Type
(T
));
2062 if Ekind
(Component_Type
(T
)) = E_Incomplete_Type
2063 and then No
(Full_View
(Component_Type
(T
)))
2065 Error_Msg_N
("premature usage of incomplete type", Def
);
2067 -- Check that range constraint is not allowed on the component type
2068 -- of a generic formal array type (AARM 12.5.3(3))
2070 elsif Is_Internal
(Component_Type
(T
))
2071 and then Present
(Subtype_Indication
(Component_Definition
(Def
)))
2072 and then Nkind
(Original_Node
2073 (Subtype_Indication
(Component_Definition
(Def
)))) =
2074 N_Subtype_Indication
2077 ("in a formal, a subtype indication can only be "
2078 & "a subtype mark (RM 12.5.3(3))",
2079 Subtype_Indication
(Component_Definition
(Def
)));
2082 end Analyze_Formal_Array_Type
;
2084 ---------------------------------------------
2085 -- Analyze_Formal_Decimal_Fixed_Point_Type --
2086 ---------------------------------------------
2088 -- As for other generic types, we create a valid type representation with
2089 -- legal but arbitrary attributes, whose values are never considered
2090 -- static. For all scalar types we introduce an anonymous base type, with
2091 -- the same attributes. We choose the corresponding integer type to be
2092 -- Standard_Integer.
2093 -- Here and in other similar routines, the Sloc of the generated internal
2094 -- type must be the same as the sloc of the defining identifier of the
2095 -- formal type declaration, to provide proper source navigation.
2097 procedure Analyze_Formal_Decimal_Fixed_Point_Type
2101 Loc
: constant Source_Ptr
:= Sloc
(Def
);
2103 Base
: constant Entity_Id
:=
2105 (E_Decimal_Fixed_Point_Type
,
2107 Sloc
(Defining_Identifier
(Parent
(Def
))), 'G');
2109 Int_Base
: constant Entity_Id
:= Standard_Integer
;
2110 Delta_Val
: constant Ureal
:= Ureal_1
;
2111 Digs_Val
: constant Uint
:= Uint_6
;
2113 function Make_Dummy_Bound
return Node_Id
;
2114 -- Return a properly typed universal real literal to use as a bound
2116 ----------------------
2117 -- Make_Dummy_Bound --
2118 ----------------------
2120 function Make_Dummy_Bound
return Node_Id
is
2121 Bound
: constant Node_Id
:= Make_Real_Literal
(Loc
, Ureal_1
);
2123 Set_Etype
(Bound
, Universal_Real
);
2125 end Make_Dummy_Bound
;
2127 -- Start of processing for Analyze_Formal_Decimal_Fixed_Point_Type
2132 Set_Etype
(Base
, Base
);
2133 Set_Size_Info
(Base
, Int_Base
);
2134 Set_RM_Size
(Base
, RM_Size
(Int_Base
));
2135 Set_First_Rep_Item
(Base
, First_Rep_Item
(Int_Base
));
2136 Set_Digits_Value
(Base
, Digs_Val
);
2137 Set_Delta_Value
(Base
, Delta_Val
);
2138 Set_Small_Value
(Base
, Delta_Val
);
2139 Set_Scalar_Range
(Base
,
2141 Low_Bound
=> Make_Dummy_Bound
,
2142 High_Bound
=> Make_Dummy_Bound
));
2144 Set_Is_Generic_Type
(Base
);
2145 Set_Parent
(Base
, Parent
(Def
));
2147 Set_Ekind
(T
, E_Decimal_Fixed_Point_Subtype
);
2148 Set_Etype
(T
, Base
);
2149 Set_Size_Info
(T
, Int_Base
);
2150 Set_RM_Size
(T
, RM_Size
(Int_Base
));
2151 Set_First_Rep_Item
(T
, First_Rep_Item
(Int_Base
));
2152 Set_Digits_Value
(T
, Digs_Val
);
2153 Set_Delta_Value
(T
, Delta_Val
);
2154 Set_Small_Value
(T
, Delta_Val
);
2155 Set_Scalar_Range
(T
, Scalar_Range
(Base
));
2156 Set_Is_Constrained
(T
);
2158 Check_Restriction
(No_Fixed_Point
, Def
);
2159 end Analyze_Formal_Decimal_Fixed_Point_Type
;
2161 -------------------------------------------
2162 -- Analyze_Formal_Derived_Interface_Type --
2163 -------------------------------------------
2165 procedure Analyze_Formal_Derived_Interface_Type
2170 Loc
: constant Source_Ptr
:= Sloc
(Def
);
2173 -- Rewrite as a type declaration of a derived type. This ensures that
2174 -- the interface list and primitive operations are properly captured.
2177 Make_Full_Type_Declaration
(Loc
,
2178 Defining_Identifier
=> T
,
2179 Type_Definition
=> Def
));
2181 Set_Is_Generic_Type
(T
);
2182 end Analyze_Formal_Derived_Interface_Type
;
2184 ---------------------------------
2185 -- Analyze_Formal_Derived_Type --
2186 ---------------------------------
2188 procedure Analyze_Formal_Derived_Type
2193 Loc
: constant Source_Ptr
:= Sloc
(Def
);
2194 Unk_Disc
: constant Boolean := Unknown_Discriminants_Present
(N
);
2198 Set_Is_Generic_Type
(T
);
2200 if Private_Present
(Def
) then
2202 Make_Private_Extension_Declaration
(Loc
,
2203 Defining_Identifier
=> T
,
2204 Discriminant_Specifications
=> Discriminant_Specifications
(N
),
2205 Unknown_Discriminants_Present
=> Unk_Disc
,
2206 Subtype_Indication
=> Subtype_Mark
(Def
),
2207 Interface_List
=> Interface_List
(Def
));
2209 Set_Abstract_Present
(New_N
, Abstract_Present
(Def
));
2210 Set_Limited_Present
(New_N
, Limited_Present
(Def
));
2211 Set_Synchronized_Present
(New_N
, Synchronized_Present
(Def
));
2215 Make_Full_Type_Declaration
(Loc
,
2216 Defining_Identifier
=> T
,
2217 Discriminant_Specifications
=>
2218 Discriminant_Specifications
(Parent
(T
)),
2220 Make_Derived_Type_Definition
(Loc
,
2221 Subtype_Indication
=> Subtype_Mark
(Def
)));
2223 Set_Abstract_Present
2224 (Type_Definition
(New_N
), Abstract_Present
(Def
));
2226 (Type_Definition
(New_N
), Limited_Present
(Def
));
2233 if not Is_Composite_Type
(T
) then
2235 ("unknown discriminants not allowed for elementary types", N
);
2237 Set_Has_Unknown_Discriminants
(T
);
2238 Set_Is_Constrained
(T
, False);
2242 -- If the parent type has a known size, so does the formal, which makes
2243 -- legal representation clauses that involve the formal.
2245 Set_Size_Known_At_Compile_Time
2246 (T
, Size_Known_At_Compile_Time
(Entity
(Subtype_Mark
(Def
))));
2247 end Analyze_Formal_Derived_Type
;
2249 ----------------------------------
2250 -- Analyze_Formal_Discrete_Type --
2251 ----------------------------------
2253 -- The operations defined for a discrete types are those of an enumeration
2254 -- type. The size is set to an arbitrary value, for use in analyzing the
2257 procedure Analyze_Formal_Discrete_Type
(T
: Entity_Id
; Def
: Node_Id
) is
2258 Loc
: constant Source_Ptr
:= Sloc
(Def
);
2262 Base
: constant Entity_Id
:=
2264 (E_Floating_Point_Type
, Current_Scope
,
2265 Sloc
(Defining_Identifier
(Parent
(Def
))), 'G');
2269 Set_Ekind
(T
, E_Enumeration_Subtype
);
2270 Set_Etype
(T
, Base
);
2273 Set_Is_Generic_Type
(T
);
2274 Set_Is_Constrained
(T
);
2276 -- For semantic analysis, the bounds of the type must be set to some
2277 -- non-static value. The simplest is to create attribute nodes for those
2278 -- bounds, that refer to the type itself. These bounds are never
2279 -- analyzed but serve as place-holders.
2282 Make_Attribute_Reference
(Loc
,
2283 Attribute_Name
=> Name_First
,
2284 Prefix
=> New_Occurrence_Of
(T
, Loc
));
2288 Make_Attribute_Reference
(Loc
,
2289 Attribute_Name
=> Name_Last
,
2290 Prefix
=> New_Occurrence_Of
(T
, Loc
));
2293 Set_Scalar_Range
(T
,
2298 Set_Ekind
(Base
, E_Enumeration_Type
);
2299 Set_Etype
(Base
, Base
);
2300 Init_Size
(Base
, 8);
2301 Init_Alignment
(Base
);
2302 Set_Is_Generic_Type
(Base
);
2303 Set_Scalar_Range
(Base
, Scalar_Range
(T
));
2304 Set_Parent
(Base
, Parent
(Def
));
2305 end Analyze_Formal_Discrete_Type
;
2307 ----------------------------------
2308 -- Analyze_Formal_Floating_Type --
2309 ---------------------------------
2311 procedure Analyze_Formal_Floating_Type
(T
: Entity_Id
; Def
: Node_Id
) is
2312 Base
: constant Entity_Id
:=
2314 (E_Floating_Point_Type
, Current_Scope
,
2315 Sloc
(Defining_Identifier
(Parent
(Def
))), 'G');
2318 -- The various semantic attributes are taken from the predefined type
2319 -- Float, just so that all of them are initialized. Their values are
2320 -- never used because no constant folding or expansion takes place in
2321 -- the generic itself.
2324 Set_Ekind
(T
, E_Floating_Point_Subtype
);
2325 Set_Etype
(T
, Base
);
2326 Set_Size_Info
(T
, (Standard_Float
));
2327 Set_RM_Size
(T
, RM_Size
(Standard_Float
));
2328 Set_Digits_Value
(T
, Digits_Value
(Standard_Float
));
2329 Set_Scalar_Range
(T
, Scalar_Range
(Standard_Float
));
2330 Set_Is_Constrained
(T
);
2332 Set_Is_Generic_Type
(Base
);
2333 Set_Etype
(Base
, Base
);
2334 Set_Size_Info
(Base
, (Standard_Float
));
2335 Set_RM_Size
(Base
, RM_Size
(Standard_Float
));
2336 Set_Digits_Value
(Base
, Digits_Value
(Standard_Float
));
2337 Set_Scalar_Range
(Base
, Scalar_Range
(Standard_Float
));
2338 Set_Parent
(Base
, Parent
(Def
));
2340 Check_Restriction
(No_Floating_Point
, Def
);
2341 end Analyze_Formal_Floating_Type
;
2343 -----------------------------------
2344 -- Analyze_Formal_Interface_Type;--
2345 -----------------------------------
2347 procedure Analyze_Formal_Interface_Type
2352 Loc
: constant Source_Ptr
:= Sloc
(N
);
2357 Make_Full_Type_Declaration
(Loc
,
2358 Defining_Identifier
=> T
,
2359 Type_Definition
=> Def
);
2363 Set_Is_Generic_Type
(T
);
2364 end Analyze_Formal_Interface_Type
;
2366 ---------------------------------
2367 -- Analyze_Formal_Modular_Type --
2368 ---------------------------------
2370 procedure Analyze_Formal_Modular_Type
(T
: Entity_Id
; Def
: Node_Id
) is
2372 -- Apart from their entity kind, generic modular types are treated like
2373 -- signed integer types, and have the same attributes.
2375 Analyze_Formal_Signed_Integer_Type
(T
, Def
);
2376 Set_Ekind
(T
, E_Modular_Integer_Subtype
);
2377 Set_Ekind
(Etype
(T
), E_Modular_Integer_Type
);
2379 end Analyze_Formal_Modular_Type
;
2381 ---------------------------------------
2382 -- Analyze_Formal_Object_Declaration --
2383 ---------------------------------------
2385 procedure Analyze_Formal_Object_Declaration
(N
: Node_Id
) is
2386 E
: constant Node_Id
:= Default_Expression
(N
);
2387 Id
: constant Node_Id
:= Defining_Identifier
(N
);
2394 -- Determine the mode of the formal object
2396 if Out_Present
(N
) then
2397 K
:= E_Generic_In_Out_Parameter
;
2399 if not In_Present
(N
) then
2400 Error_Msg_N
("formal generic objects cannot have mode OUT", N
);
2404 K
:= E_Generic_In_Parameter
;
2407 if Present
(Subtype_Mark
(N
)) then
2408 Find_Type
(Subtype_Mark
(N
));
2409 T
:= Entity
(Subtype_Mark
(N
));
2411 -- Verify that there is no redundant null exclusion
2413 if Null_Exclusion_Present
(N
) then
2414 if not Is_Access_Type
(T
) then
2416 ("null exclusion can only apply to an access type", N
);
2418 elsif Can_Never_Be_Null
(T
) then
2420 ("`NOT NULL` not allowed (& already excludes null)",
2425 -- Ada 2005 (AI-423): Formal object with an access definition
2428 Check_Access_Definition
(N
);
2429 T
:= Access_Definition
2431 N
=> Access_Definition
(N
));
2434 if Ekind
(T
) = E_Incomplete_Type
then
2436 Error_Node
: Node_Id
;
2439 if Present
(Subtype_Mark
(N
)) then
2440 Error_Node
:= Subtype_Mark
(N
);
2442 Check_Access_Definition
(N
);
2443 Error_Node
:= Access_Definition
(N
);
2446 Error_Msg_N
("premature usage of incomplete type", Error_Node
);
2450 if K
= E_Generic_In_Parameter
then
2452 -- Ada 2005 (AI-287): Limited aggregates allowed in generic formals
2454 if Ada_Version
< Ada_2005
and then Is_Limited_Type
(T
) then
2456 ("generic formal of mode IN must not be of limited type", N
);
2457 Explain_Limited_Type
(T
, N
);
2460 if Is_Abstract_Type
(T
) then
2462 ("generic formal of mode IN must not be of abstract type", N
);
2466 Preanalyze_Spec_Expression
(E
, T
);
2468 if Is_Limited_Type
(T
) and then not OK_For_Limited_Init
(T
, E
) then
2470 ("initialization not allowed for limited types", E
);
2471 Explain_Limited_Type
(T
, E
);
2478 -- Case of generic IN OUT parameter
2481 -- If the formal has an unconstrained type, construct its actual
2482 -- subtype, as is done for subprogram formals. In this fashion, all
2483 -- its uses can refer to specific bounds.
2488 if (Is_Array_Type
(T
) and then not Is_Constrained
(T
))
2489 or else (Ekind
(T
) = E_Record_Type
and then Has_Discriminants
(T
))
2492 Non_Freezing_Ref
: constant Node_Id
:=
2493 New_Occurrence_Of
(Id
, Sloc
(Id
));
2497 -- Make sure the actual subtype doesn't generate bogus freezing
2499 Set_Must_Not_Freeze
(Non_Freezing_Ref
);
2500 Decl
:= Build_Actual_Subtype
(T
, Non_Freezing_Ref
);
2501 Insert_Before_And_Analyze
(N
, Decl
);
2502 Set_Actual_Subtype
(Id
, Defining_Identifier
(Decl
));
2505 Set_Actual_Subtype
(Id
, T
);
2510 ("initialization not allowed for `IN OUT` formals", N
);
2514 if Has_Aspects
(N
) then
2515 Analyze_Aspect_Specifications
(N
, Id
);
2517 end Analyze_Formal_Object_Declaration
;
2519 ----------------------------------------------
2520 -- Analyze_Formal_Ordinary_Fixed_Point_Type --
2521 ----------------------------------------------
2523 procedure Analyze_Formal_Ordinary_Fixed_Point_Type
2527 Loc
: constant Source_Ptr
:= Sloc
(Def
);
2528 Base
: constant Entity_Id
:=
2530 (E_Ordinary_Fixed_Point_Type
, Current_Scope
,
2531 Sloc
(Defining_Identifier
(Parent
(Def
))), 'G');
2534 -- The semantic attributes are set for completeness only, their values
2535 -- will never be used, since all properties of the type are non-static.
2538 Set_Ekind
(T
, E_Ordinary_Fixed_Point_Subtype
);
2539 Set_Etype
(T
, Base
);
2540 Set_Size_Info
(T
, Standard_Integer
);
2541 Set_RM_Size
(T
, RM_Size
(Standard_Integer
));
2542 Set_Small_Value
(T
, Ureal_1
);
2543 Set_Delta_Value
(T
, Ureal_1
);
2544 Set_Scalar_Range
(T
,
2546 Low_Bound
=> Make_Real_Literal
(Loc
, Ureal_1
),
2547 High_Bound
=> Make_Real_Literal
(Loc
, Ureal_1
)));
2548 Set_Is_Constrained
(T
);
2550 Set_Is_Generic_Type
(Base
);
2551 Set_Etype
(Base
, Base
);
2552 Set_Size_Info
(Base
, Standard_Integer
);
2553 Set_RM_Size
(Base
, RM_Size
(Standard_Integer
));
2554 Set_Small_Value
(Base
, Ureal_1
);
2555 Set_Delta_Value
(Base
, Ureal_1
);
2556 Set_Scalar_Range
(Base
, Scalar_Range
(T
));
2557 Set_Parent
(Base
, Parent
(Def
));
2559 Check_Restriction
(No_Fixed_Point
, Def
);
2560 end Analyze_Formal_Ordinary_Fixed_Point_Type
;
2562 ----------------------------------------
2563 -- Analyze_Formal_Package_Declaration --
2564 ----------------------------------------
2566 procedure Analyze_Formal_Package_Declaration
(N
: Node_Id
) is
2567 Loc
: constant Source_Ptr
:= Sloc
(N
);
2568 Pack_Id
: constant Entity_Id
:= Defining_Identifier
(N
);
2570 Gen_Id
: constant Node_Id
:= Name
(N
);
2572 Gen_Unit
: Entity_Id
;
2574 Parent_Installed
: Boolean := False;
2576 Parent_Instance
: Entity_Id
;
2577 Renaming_In_Par
: Entity_Id
;
2578 Associations
: Boolean := True;
2580 Vis_Prims_List
: Elist_Id
:= No_Elist
;
2581 -- List of primitives made temporarily visible in the instantiation
2582 -- to match the visibility of the formal type
2584 function Build_Local_Package
return Node_Id
;
2585 -- The formal package is rewritten so that its parameters are replaced
2586 -- with corresponding declarations. For parameters with bona fide
2587 -- associations these declarations are created by Analyze_Associations
2588 -- as for a regular instantiation. For boxed parameters, we preserve
2589 -- the formal declarations and analyze them, in order to introduce
2590 -- entities of the right kind in the environment of the formal.
2592 -------------------------
2593 -- Build_Local_Package --
2594 -------------------------
2596 function Build_Local_Package
return Node_Id
is
2598 Pack_Decl
: Node_Id
;
2601 -- Within the formal, the name of the generic package is a renaming
2602 -- of the formal (as for a regular instantiation).
2605 Make_Package_Declaration
(Loc
,
2608 (Specification
(Original_Node
(Gen_Decl
)),
2609 Empty
, Instantiating
=> True));
2611 Renaming
:= Make_Package_Renaming_Declaration
(Loc
,
2612 Defining_Unit_Name
=>
2613 Make_Defining_Identifier
(Loc
, Chars
(Gen_Unit
)),
2614 Name
=> New_Occurrence_Of
(Formal
, Loc
));
2616 if Nkind
(Gen_Id
) = N_Identifier
2617 and then Chars
(Gen_Id
) = Chars
(Pack_Id
)
2620 ("& is hidden within declaration of instance", Gen_Id
, Gen_Unit
);
2623 -- If the formal is declared with a box, or with an others choice,
2624 -- create corresponding declarations for all entities in the formal
2625 -- part, so that names with the proper types are available in the
2626 -- specification of the formal package.
2628 -- On the other hand, if there are no associations, then all the
2629 -- formals must have defaults, and this will be checked by the
2630 -- call to Analyze_Associations.
2633 or else Nkind
(First
(Generic_Associations
(N
))) = N_Others_Choice
2636 Formal_Decl
: Node_Id
;
2639 -- TBA : for a formal package, need to recurse ???
2644 (Generic_Formal_Declarations
(Original_Node
(Gen_Decl
)));
2645 while Present
(Formal_Decl
) loop
2647 (Decls
, Copy_Generic_Node
(Formal_Decl
, Empty
, True));
2652 -- If generic associations are present, use Analyze_Associations to
2653 -- create the proper renaming declarations.
2657 Act_Tree
: constant Node_Id
:=
2659 (Original_Node
(Gen_Decl
), Empty
,
2660 Instantiating
=> True);
2663 Generic_Renamings
.Set_Last
(0);
2664 Generic_Renamings_HTable
.Reset
;
2665 Instantiation_Node
:= N
;
2668 Analyze_Associations
2669 (I_Node
=> Original_Node
(N
),
2670 Formals
=> Generic_Formal_Declarations
(Act_Tree
),
2671 F_Copy
=> Generic_Formal_Declarations
(Gen_Decl
));
2673 Vis_Prims_List
:= Check_Hidden_Primitives
(Decls
);
2677 Append
(Renaming
, To
=> Decls
);
2679 -- Add generated declarations ahead of local declarations in
2682 if No
(Visible_Declarations
(Specification
(Pack_Decl
))) then
2683 Set_Visible_Declarations
(Specification
(Pack_Decl
), Decls
);
2686 (First
(Visible_Declarations
(Specification
(Pack_Decl
))),
2691 end Build_Local_Package
;
2693 -- Start of processing for Analyze_Formal_Package_Declaration
2696 Check_Text_IO_Special_Unit
(Gen_Id
);
2699 Check_Generic_Child_Unit
(Gen_Id
, Parent_Installed
);
2700 Gen_Unit
:= Entity
(Gen_Id
);
2702 -- Check for a formal package that is a package renaming
2704 if Present
(Renamed_Object
(Gen_Unit
)) then
2706 -- Indicate that unit is used, before replacing it with renamed
2707 -- entity for use below.
2709 if In_Extended_Main_Source_Unit
(N
) then
2710 Set_Is_Instantiated
(Gen_Unit
);
2711 Generate_Reference
(Gen_Unit
, N
);
2714 Gen_Unit
:= Renamed_Object
(Gen_Unit
);
2717 if Ekind
(Gen_Unit
) /= E_Generic_Package
then
2718 Error_Msg_N
("expect generic package name", Gen_Id
);
2722 elsif Gen_Unit
= Current_Scope
then
2724 ("generic package cannot be used as a formal package of itself",
2729 elsif In_Open_Scopes
(Gen_Unit
) then
2730 if Is_Compilation_Unit
(Gen_Unit
)
2731 and then Is_Child_Unit
(Current_Scope
)
2733 -- Special-case the error when the formal is a parent, and
2734 -- continue analysis to minimize cascaded errors.
2737 ("generic parent cannot be used as formal package "
2738 & "of a child unit",
2743 ("generic package cannot be used as a formal package "
2751 -- Check that name of formal package does not hide name of generic,
2752 -- or its leading prefix. This check must be done separately because
2753 -- the name of the generic has already been analyzed.
2756 Gen_Name
: Entity_Id
;
2760 while Nkind
(Gen_Name
) = N_Expanded_Name
loop
2761 Gen_Name
:= Prefix
(Gen_Name
);
2764 if Chars
(Gen_Name
) = Chars
(Pack_Id
) then
2766 ("& is hidden within declaration of formal package",
2772 or else No
(Generic_Associations
(N
))
2773 or else Nkind
(First
(Generic_Associations
(N
))) = N_Others_Choice
2775 Associations
:= False;
2778 -- If there are no generic associations, the generic parameters appear
2779 -- as local entities and are instantiated like them. We copy the generic
2780 -- package declaration as if it were an instantiation, and analyze it
2781 -- like a regular package, except that we treat the formals as
2782 -- additional visible components.
2784 Gen_Decl
:= Unit_Declaration_Node
(Gen_Unit
);
2786 if In_Extended_Main_Source_Unit
(N
) then
2787 Set_Is_Instantiated
(Gen_Unit
);
2788 Generate_Reference
(Gen_Unit
, N
);
2791 Formal
:= New_Copy
(Pack_Id
);
2792 Create_Instantiation_Source
(N
, Gen_Unit
, False, S_Adjustment
);
2795 -- Make local generic without formals. The formals will be replaced
2796 -- with internal declarations.
2798 New_N
:= Build_Local_Package
;
2800 -- If there are errors in the parameter list, Analyze_Associations
2801 -- raises Instantiation_Error. Patch the declaration to prevent
2802 -- further exception propagation.
2805 when Instantiation_Error
=>
2807 Enter_Name
(Formal
);
2808 Set_Ekind
(Formal
, E_Variable
);
2809 Set_Etype
(Formal
, Any_Type
);
2810 Restore_Hidden_Primitives
(Vis_Prims_List
);
2812 if Parent_Installed
then
2820 Set_Defining_Unit_Name
(Specification
(New_N
), Formal
);
2821 Set_Generic_Parent
(Specification
(N
), Gen_Unit
);
2822 Set_Instance_Env
(Gen_Unit
, Formal
);
2823 Set_Is_Generic_Instance
(Formal
);
2825 Enter_Name
(Formal
);
2826 Set_Ekind
(Formal
, E_Package
);
2827 Set_Etype
(Formal
, Standard_Void_Type
);
2828 Set_Inner_Instances
(Formal
, New_Elmt_List
);
2829 Push_Scope
(Formal
);
2831 if Is_Child_Unit
(Gen_Unit
)
2832 and then Parent_Installed
2834 -- Similarly, we have to make the name of the formal visible in the
2835 -- parent instance, to resolve properly fully qualified names that
2836 -- may appear in the generic unit. The parent instance has been
2837 -- placed on the scope stack ahead of the current scope.
2839 Parent_Instance
:= Scope_Stack
.Table
(Scope_Stack
.Last
- 1).Entity
;
2842 Make_Defining_Identifier
(Loc
, Chars
(Gen_Unit
));
2843 Set_Ekind
(Renaming_In_Par
, E_Package
);
2844 Set_Etype
(Renaming_In_Par
, Standard_Void_Type
);
2845 Set_Scope
(Renaming_In_Par
, Parent_Instance
);
2846 Set_Parent
(Renaming_In_Par
, Parent
(Formal
));
2847 Set_Renamed_Object
(Renaming_In_Par
, Formal
);
2848 Append_Entity
(Renaming_In_Par
, Parent_Instance
);
2851 Analyze
(Specification
(N
));
2853 -- The formals for which associations are provided are not visible
2854 -- outside of the formal package. The others are still declared by a
2855 -- formal parameter declaration.
2857 -- If there are no associations, the only local entity to hide is the
2858 -- generated package renaming itself.
2864 E
:= First_Entity
(Formal
);
2865 while Present
(E
) loop
2867 and then not Is_Generic_Formal
(E
)
2872 if Ekind
(E
) = E_Package
2873 and then Renamed_Entity
(E
) = Formal
2883 End_Package_Scope
(Formal
);
2884 Restore_Hidden_Primitives
(Vis_Prims_List
);
2886 if Parent_Installed
then
2892 -- Inside the generic unit, the formal package is a regular package, but
2893 -- no body is needed for it. Note that after instantiation, the defining
2894 -- unit name we need is in the new tree and not in the original (see
2895 -- Package_Instantiation). A generic formal package is an instance, and
2896 -- can be used as an actual for an inner instance.
2898 Set_Has_Completion
(Formal
, True);
2900 -- Add semantic information to the original defining identifier.
2903 Set_Ekind
(Pack_Id
, E_Package
);
2904 Set_Etype
(Pack_Id
, Standard_Void_Type
);
2905 Set_Scope
(Pack_Id
, Scope
(Formal
));
2906 Set_Has_Completion
(Pack_Id
, True);
2909 if Has_Aspects
(N
) then
2910 Analyze_Aspect_Specifications
(N
, Pack_Id
);
2912 end Analyze_Formal_Package_Declaration
;
2914 ---------------------------------
2915 -- Analyze_Formal_Private_Type --
2916 ---------------------------------
2918 procedure Analyze_Formal_Private_Type
2924 New_Private_Type
(N
, T
, Def
);
2926 -- Set the size to an arbitrary but legal value
2928 Set_Size_Info
(T
, Standard_Integer
);
2929 Set_RM_Size
(T
, RM_Size
(Standard_Integer
));
2930 end Analyze_Formal_Private_Type
;
2932 ------------------------------------
2933 -- Analyze_Formal_Incomplete_Type --
2934 ------------------------------------
2936 procedure Analyze_Formal_Incomplete_Type
2942 Set_Ekind
(T
, E_Incomplete_Type
);
2944 Set_Private_Dependents
(T
, New_Elmt_List
);
2946 if Tagged_Present
(Def
) then
2947 Set_Is_Tagged_Type
(T
);
2948 Make_Class_Wide_Type
(T
);
2949 Set_Direct_Primitive_Operations
(T
, New_Elmt_List
);
2951 end Analyze_Formal_Incomplete_Type
;
2953 ----------------------------------------
2954 -- Analyze_Formal_Signed_Integer_Type --
2955 ----------------------------------------
2957 procedure Analyze_Formal_Signed_Integer_Type
2961 Base
: constant Entity_Id
:=
2963 (E_Signed_Integer_Type
,
2965 Sloc
(Defining_Identifier
(Parent
(Def
))), 'G');
2970 Set_Ekind
(T
, E_Signed_Integer_Subtype
);
2971 Set_Etype
(T
, Base
);
2972 Set_Size_Info
(T
, Standard_Integer
);
2973 Set_RM_Size
(T
, RM_Size
(Standard_Integer
));
2974 Set_Scalar_Range
(T
, Scalar_Range
(Standard_Integer
));
2975 Set_Is_Constrained
(T
);
2977 Set_Is_Generic_Type
(Base
);
2978 Set_Size_Info
(Base
, Standard_Integer
);
2979 Set_RM_Size
(Base
, RM_Size
(Standard_Integer
));
2980 Set_Etype
(Base
, Base
);
2981 Set_Scalar_Range
(Base
, Scalar_Range
(Standard_Integer
));
2982 Set_Parent
(Base
, Parent
(Def
));
2983 end Analyze_Formal_Signed_Integer_Type
;
2985 -------------------------------------------
2986 -- Analyze_Formal_Subprogram_Declaration --
2987 -------------------------------------------
2989 procedure Analyze_Formal_Subprogram_Declaration
(N
: Node_Id
) is
2990 Spec
: constant Node_Id
:= Specification
(N
);
2991 Def
: constant Node_Id
:= Default_Name
(N
);
2992 Nam
: constant Entity_Id
:= Defining_Unit_Name
(Spec
);
3000 if Nkind
(Nam
) = N_Defining_Program_Unit_Name
then
3001 Error_Msg_N
("name of formal subprogram must be a direct name", Nam
);
3005 Analyze_Subprogram_Declaration
(N
);
3006 Set_Is_Formal_Subprogram
(Nam
);
3007 Set_Has_Completion
(Nam
);
3009 if Nkind
(N
) = N_Formal_Abstract_Subprogram_Declaration
then
3010 Set_Is_Abstract_Subprogram
(Nam
);
3011 Set_Is_Dispatching_Operation
(Nam
);
3014 Ctrl_Type
: constant Entity_Id
:= Find_Dispatching_Type
(Nam
);
3016 if No
(Ctrl_Type
) then
3018 ("abstract formal subprogram must have a controlling type",
3021 elsif Ada_Version
>= Ada_2012
3022 and then Is_Incomplete_Type
(Ctrl_Type
)
3025 ("controlling type of abstract formal subprogram cannot " &
3026 "be incomplete type", N
, Ctrl_Type
);
3029 Check_Controlling_Formals
(Ctrl_Type
, Nam
);
3034 -- Default name is resolved at the point of instantiation
3036 if Box_Present
(N
) then
3039 -- Else default is bound at the point of generic declaration
3041 elsif Present
(Def
) then
3042 if Nkind
(Def
) = N_Operator_Symbol
then
3043 Find_Direct_Name
(Def
);
3045 elsif Nkind
(Def
) /= N_Attribute_Reference
then
3049 -- For an attribute reference, analyze the prefix and verify
3050 -- that it has the proper profile for the subprogram.
3052 Analyze
(Prefix
(Def
));
3053 Valid_Default_Attribute
(Nam
, Def
);
3057 -- Default name may be overloaded, in which case the interpretation
3058 -- with the correct profile must be selected, as for a renaming.
3059 -- If the definition is an indexed component, it must denote a
3060 -- member of an entry family. If it is a selected component, it
3061 -- can be a protected operation.
3063 if Etype
(Def
) = Any_Type
then
3066 elsif Nkind
(Def
) = N_Selected_Component
then
3067 if not Is_Overloadable
(Entity
(Selector_Name
(Def
))) then
3068 Error_Msg_N
("expect valid subprogram name as default", Def
);
3071 elsif Nkind
(Def
) = N_Indexed_Component
then
3072 if Is_Entity_Name
(Prefix
(Def
)) then
3073 if Ekind
(Entity
(Prefix
(Def
))) /= E_Entry_Family
then
3074 Error_Msg_N
("expect valid subprogram name as default", Def
);
3077 elsif Nkind
(Prefix
(Def
)) = N_Selected_Component
then
3078 if Ekind
(Entity
(Selector_Name
(Prefix
(Def
)))) /=
3081 Error_Msg_N
("expect valid subprogram name as default", Def
);
3085 Error_Msg_N
("expect valid subprogram name as default", Def
);
3089 elsif Nkind
(Def
) = N_Character_Literal
then
3091 -- Needs some type checks: subprogram should be parameterless???
3093 Resolve
(Def
, (Etype
(Nam
)));
3095 elsif not Is_Entity_Name
(Def
)
3096 or else not Is_Overloadable
(Entity
(Def
))
3098 Error_Msg_N
("expect valid subprogram name as default", Def
);
3101 elsif not Is_Overloaded
(Def
) then
3102 Subp
:= Entity
(Def
);
3105 Error_Msg_N
("premature usage of formal subprogram", Def
);
3107 elsif not Entity_Matches_Spec
(Subp
, Nam
) then
3108 Error_Msg_N
("no visible entity matches specification", Def
);
3111 -- More than one interpretation, so disambiguate as for a renaming
3116 I1
: Interp_Index
:= 0;
3122 Get_First_Interp
(Def
, I
, It
);
3123 while Present
(It
.Nam
) loop
3124 if Entity_Matches_Spec
(It
.Nam
, Nam
) then
3125 if Subp
/= Any_Id
then
3126 It1
:= Disambiguate
(Def
, I1
, I
, Etype
(Subp
));
3128 if It1
= No_Interp
then
3129 Error_Msg_N
("ambiguous default subprogram", Def
);
3142 Get_Next_Interp
(I
, It
);
3146 if Subp
/= Any_Id
then
3148 -- Subprogram found, generate reference to it
3150 Set_Entity
(Def
, Subp
);
3151 Generate_Reference
(Subp
, Def
);
3154 Error_Msg_N
("premature usage of formal subprogram", Def
);
3156 elsif Ekind
(Subp
) /= E_Operator
then
3157 Check_Mode_Conformant
(Subp
, Nam
);
3161 Error_Msg_N
("no visible subprogram matches specification", N
);
3167 if Has_Aspects
(N
) then
3168 Analyze_Aspect_Specifications
(N
, Nam
);
3171 end Analyze_Formal_Subprogram_Declaration
;
3173 -------------------------------------
3174 -- Analyze_Formal_Type_Declaration --
3175 -------------------------------------
3177 procedure Analyze_Formal_Type_Declaration
(N
: Node_Id
) is
3178 Def
: constant Node_Id
:= Formal_Type_Definition
(N
);
3182 T
:= Defining_Identifier
(N
);
3184 if Present
(Discriminant_Specifications
(N
))
3185 and then Nkind
(Def
) /= N_Formal_Private_Type_Definition
3188 ("discriminants not allowed for this formal type", T
);
3191 -- Enter the new name, and branch to specific routine
3194 when N_Formal_Private_Type_Definition
=>
3195 Analyze_Formal_Private_Type
(N
, T
, Def
);
3197 when N_Formal_Derived_Type_Definition
=>
3198 Analyze_Formal_Derived_Type
(N
, T
, Def
);
3200 when N_Formal_Incomplete_Type_Definition
=>
3201 Analyze_Formal_Incomplete_Type
(T
, Def
);
3203 when N_Formal_Discrete_Type_Definition
=>
3204 Analyze_Formal_Discrete_Type
(T
, Def
);
3206 when N_Formal_Signed_Integer_Type_Definition
=>
3207 Analyze_Formal_Signed_Integer_Type
(T
, Def
);
3209 when N_Formal_Modular_Type_Definition
=>
3210 Analyze_Formal_Modular_Type
(T
, Def
);
3212 when N_Formal_Floating_Point_Definition
=>
3213 Analyze_Formal_Floating_Type
(T
, Def
);
3215 when N_Formal_Ordinary_Fixed_Point_Definition
=>
3216 Analyze_Formal_Ordinary_Fixed_Point_Type
(T
, Def
);
3218 when N_Formal_Decimal_Fixed_Point_Definition
=>
3219 Analyze_Formal_Decimal_Fixed_Point_Type
(T
, Def
);
3221 when N_Array_Type_Definition
=>
3222 Analyze_Formal_Array_Type
(T
, Def
);
3224 when N_Access_To_Object_Definition |
3225 N_Access_Function_Definition |
3226 N_Access_Procedure_Definition
=>
3227 Analyze_Generic_Access_Type
(T
, Def
);
3229 -- Ada 2005: a interface declaration is encoded as an abstract
3230 -- record declaration or a abstract type derivation.
3232 when N_Record_Definition
=>
3233 Analyze_Formal_Interface_Type
(N
, T
, Def
);
3235 when N_Derived_Type_Definition
=>
3236 Analyze_Formal_Derived_Interface_Type
(N
, T
, Def
);
3242 raise Program_Error
;
3246 Set_Is_Generic_Type
(T
);
3248 if Has_Aspects
(N
) then
3249 Analyze_Aspect_Specifications
(N
, T
);
3251 end Analyze_Formal_Type_Declaration
;
3253 ------------------------------------
3254 -- Analyze_Function_Instantiation --
3255 ------------------------------------
3257 procedure Analyze_Function_Instantiation
(N
: Node_Id
) is
3259 Analyze_Subprogram_Instantiation
(N
, E_Function
);
3260 end Analyze_Function_Instantiation
;
3262 ---------------------------------
3263 -- Analyze_Generic_Access_Type --
3264 ---------------------------------
3266 procedure Analyze_Generic_Access_Type
(T
: Entity_Id
; Def
: Node_Id
) is
3270 if Nkind
(Def
) = N_Access_To_Object_Definition
then
3271 Access_Type_Declaration
(T
, Def
);
3273 if Is_Incomplete_Or_Private_Type
(Designated_Type
(T
))
3274 and then No
(Full_View
(Designated_Type
(T
)))
3275 and then not Is_Generic_Type
(Designated_Type
(T
))
3277 Error_Msg_N
("premature usage of incomplete type", Def
);
3279 elsif not Is_Entity_Name
(Subtype_Indication
(Def
)) then
3281 ("only a subtype mark is allowed in a formal", Def
);
3285 Access_Subprogram_Declaration
(T
, Def
);
3287 end Analyze_Generic_Access_Type
;
3289 ---------------------------------
3290 -- Analyze_Generic_Formal_Part --
3291 ---------------------------------
3293 procedure Analyze_Generic_Formal_Part
(N
: Node_Id
) is
3294 Gen_Parm_Decl
: Node_Id
;
3297 -- The generic formals are processed in the scope of the generic unit,
3298 -- where they are immediately visible. The scope is installed by the
3301 Gen_Parm_Decl
:= First
(Generic_Formal_Declarations
(N
));
3303 while Present
(Gen_Parm_Decl
) loop
3304 Analyze
(Gen_Parm_Decl
);
3305 Next
(Gen_Parm_Decl
);
3308 Generate_Reference_To_Generic_Formals
(Current_Scope
);
3309 end Analyze_Generic_Formal_Part
;
3311 ------------------------------------------
3312 -- Analyze_Generic_Package_Declaration --
3313 ------------------------------------------
3315 procedure Analyze_Generic_Package_Declaration
(N
: Node_Id
) is
3316 Loc
: constant Source_Ptr
:= Sloc
(N
);
3319 Save_Parent
: Node_Id
;
3321 Decls
: constant List_Id
:=
3322 Visible_Declarations
(Specification
(N
));
3326 Check_SPARK_05_Restriction
("generic is not allowed", N
);
3328 -- We introduce a renaming of the enclosing package, to have a usable
3329 -- entity as the prefix of an expanded name for a local entity of the
3330 -- form Par.P.Q, where P is the generic package. This is because a local
3331 -- entity named P may hide it, so that the usual visibility rules in
3332 -- the instance will not resolve properly.
3335 Make_Package_Renaming_Declaration
(Loc
,
3336 Defining_Unit_Name
=>
3337 Make_Defining_Identifier
(Loc
,
3338 Chars
=> New_External_Name
(Chars
(Defining_Entity
(N
)), "GH")),
3339 Name
=> Make_Identifier
(Loc
, Chars
(Defining_Entity
(N
))));
3341 if Present
(Decls
) then
3342 Decl
:= First
(Decls
);
3343 while Present
(Decl
)
3344 and then Nkind
(Decl
) = N_Pragma
3349 if Present
(Decl
) then
3350 Insert_Before
(Decl
, Renaming
);
3352 Append
(Renaming
, Visible_Declarations
(Specification
(N
)));
3356 Set_Visible_Declarations
(Specification
(N
), New_List
(Renaming
));
3359 -- Create copy of generic unit, and save for instantiation. If the unit
3360 -- is a child unit, do not copy the specifications for the parent, which
3361 -- are not part of the generic tree.
3363 Save_Parent
:= Parent_Spec
(N
);
3364 Set_Parent_Spec
(N
, Empty
);
3366 New_N
:= Copy_Generic_Node
(N
, Empty
, Instantiating
=> False);
3367 Set_Parent_Spec
(New_N
, Save_Parent
);
3370 -- Once the contents of the generic copy and the template are swapped,
3371 -- do the same for their respective aspect specifications.
3373 Exchange_Aspects
(N
, New_N
);
3374 Id
:= Defining_Entity
(N
);
3375 Generate_Definition
(Id
);
3377 -- Expansion is not applied to generic units
3382 Set_Ekind
(Id
, E_Generic_Package
);
3383 Set_Etype
(Id
, Standard_Void_Type
);
3384 Set_Contract
(Id
, Make_Contract
(Sloc
(Id
)));
3386 -- A generic package declared within a Ghost scope is rendered Ghost
3387 -- (SPARK RM 6.9(2)).
3389 if Within_Ghost_Scope
then
3390 Set_Is_Ghost_Entity
(Id
);
3393 -- Analyze aspects now, so that generated pragmas appear in the
3394 -- declarations before building and analyzing the generic copy.
3396 if Has_Aspects
(N
) then
3397 Analyze_Aspect_Specifications
(N
, Id
);
3401 Enter_Generic_Scope
(Id
);
3402 Set_Inner_Instances
(Id
, New_Elmt_List
);
3404 Set_Categorization_From_Pragmas
(N
);
3405 Set_Is_Pure
(Id
, Is_Pure
(Current_Scope
));
3407 -- Link the declaration of the generic homonym in the generic copy to
3408 -- the package it renames, so that it is always resolved properly.
3410 Set_Generic_Homonym
(Id
, Defining_Unit_Name
(Renaming
));
3411 Set_Entity
(Associated_Node
(Name
(Renaming
)), Id
);
3413 -- For a library unit, we have reconstructed the entity for the unit,
3414 -- and must reset it in the library tables.
3416 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
3417 Set_Cunit_Entity
(Current_Sem_Unit
, Id
);
3420 Analyze_Generic_Formal_Part
(N
);
3422 -- After processing the generic formals, analysis proceeds as for a
3423 -- non-generic package.
3425 Analyze
(Specification
(N
));
3427 Validate_Categorization_Dependency
(N
, Id
);
3431 End_Package_Scope
(Id
);
3432 Exit_Generic_Scope
(Id
);
3434 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
3435 Move_Freeze_Nodes
(Id
, N
, Visible_Declarations
(Specification
(N
)));
3436 Move_Freeze_Nodes
(Id
, N
, Private_Declarations
(Specification
(N
)));
3437 Move_Freeze_Nodes
(Id
, N
, Generic_Formal_Declarations
(N
));
3440 Set_Body_Required
(Parent
(N
), Unit_Requires_Body
(Id
));
3441 Validate_RT_RAT_Component
(N
);
3443 -- If this is a spec without a body, check that generic parameters
3446 if not Body_Required
(Parent
(N
)) then
3447 Check_References
(Id
);
3451 -- If there is a specified storage pool in the context, create an
3452 -- aspect on the package declaration, so that it is used in any
3453 -- instance that does not override it.
3455 if Present
(Default_Pool
) then
3461 Make_Aspect_Specification
(Loc
,
3462 Identifier
=> Make_Identifier
(Loc
, Name_Default_Storage_Pool
),
3463 Expression
=> New_Copy
(Default_Pool
));
3465 if No
(Aspect_Specifications
(Specification
(N
))) then
3466 Set_Aspect_Specifications
(Specification
(N
), New_List
(ASN
));
3468 Append
(ASN
, Aspect_Specifications
(Specification
(N
)));
3472 end Analyze_Generic_Package_Declaration
;
3474 --------------------------------------------
3475 -- Analyze_Generic_Subprogram_Declaration --
3476 --------------------------------------------
3478 procedure Analyze_Generic_Subprogram_Declaration
(N
: Node_Id
) is
3483 Result_Type
: Entity_Id
;
3484 Save_Parent
: Node_Id
;
3488 Check_SPARK_05_Restriction
("generic is not allowed", N
);
3490 -- Create copy of generic unit, and save for instantiation. If the unit
3491 -- is a child unit, do not copy the specifications for the parent, which
3492 -- are not part of the generic tree.
3494 Save_Parent
:= Parent_Spec
(N
);
3495 Set_Parent_Spec
(N
, Empty
);
3497 New_N
:= Copy_Generic_Node
(N
, Empty
, Instantiating
=> False);
3498 Set_Parent_Spec
(New_N
, Save_Parent
);
3501 -- Once the contents of the generic copy and the template are swapped,
3502 -- do the same for their respective aspect specifications.
3504 Exchange_Aspects
(N
, New_N
);
3506 Spec
:= Specification
(N
);
3507 Id
:= Defining_Entity
(Spec
);
3508 Generate_Definition
(Id
);
3509 Set_Contract
(Id
, Make_Contract
(Sloc
(Id
)));
3511 if Nkind
(Id
) = N_Defining_Operator_Symbol
then
3513 ("operator symbol not allowed for generic subprogram", Id
);
3519 Set_Scope_Depth_Value
(Id
, Scope_Depth
(Current_Scope
) + 1);
3521 -- Analyze the aspects of the generic copy to ensure that all generated
3522 -- pragmas (if any) perform their semantic effects.
3524 if Has_Aspects
(N
) then
3525 Analyze_Aspect_Specifications
(N
, Id
);
3529 Enter_Generic_Scope
(Id
);
3530 Set_Inner_Instances
(Id
, New_Elmt_List
);
3531 Set_Is_Pure
(Id
, Is_Pure
(Current_Scope
));
3533 Analyze_Generic_Formal_Part
(N
);
3535 Formals
:= Parameter_Specifications
(Spec
);
3537 if Present
(Formals
) then
3538 Process_Formals
(Formals
, Spec
);
3541 if Nkind
(Spec
) = N_Function_Specification
then
3542 Set_Ekind
(Id
, E_Generic_Function
);
3544 if Nkind
(Result_Definition
(Spec
)) = N_Access_Definition
then
3545 Result_Type
:= Access_Definition
(Spec
, Result_Definition
(Spec
));
3546 Set_Etype
(Id
, Result_Type
);
3548 -- Check restriction imposed by AI05-073: a generic function
3549 -- cannot return an abstract type or an access to such.
3551 -- This is a binding interpretation should it apply to earlier
3552 -- versions of Ada as well as Ada 2012???
3554 if Is_Abstract_Type
(Designated_Type
(Result_Type
))
3555 and then Ada_Version
>= Ada_2012
3557 Error_Msg_N
("generic function cannot have an access result"
3558 & " that designates an abstract type", Spec
);
3562 Find_Type
(Result_Definition
(Spec
));
3563 Typ
:= Entity
(Result_Definition
(Spec
));
3565 if Is_Abstract_Type
(Typ
)
3566 and then Ada_Version
>= Ada_2012
3569 ("generic function cannot have abstract result type", Spec
);
3572 -- If a null exclusion is imposed on the result type, then create
3573 -- a null-excluding itype (an access subtype) and use it as the
3574 -- function's Etype.
3576 if Is_Access_Type
(Typ
)
3577 and then Null_Exclusion_Present
(Spec
)
3580 Create_Null_Excluding_Itype
3582 Related_Nod
=> Spec
,
3583 Scope_Id
=> Defining_Unit_Name
(Spec
)));
3585 Set_Etype
(Id
, Typ
);
3590 Set_Ekind
(Id
, E_Generic_Procedure
);
3591 Set_Etype
(Id
, Standard_Void_Type
);
3594 -- A generic subprogram declared within a Ghost scope is rendered Ghost
3595 -- (SPARK RM 6.9(2)).
3597 if Within_Ghost_Scope
then
3598 Set_Is_Ghost_Entity
(Id
);
3601 -- For a library unit, we have reconstructed the entity for the unit,
3602 -- and must reset it in the library tables. We also make sure that
3603 -- Body_Required is set properly in the original compilation unit node.
3605 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
3606 Set_Cunit_Entity
(Current_Sem_Unit
, Id
);
3607 Set_Body_Required
(Parent
(N
), Unit_Requires_Body
(Id
));
3610 Set_Categorization_From_Pragmas
(N
);
3611 Validate_Categorization_Dependency
(N
, Id
);
3613 Save_Global_References
(Original_Node
(N
));
3615 -- For ASIS purposes, convert any postcondition, precondition pragmas
3616 -- into aspects, if N is not a compilation unit by itself, in order to
3617 -- enable the analysis of expressions inside the corresponding PPC
3620 if ASIS_Mode
and then Is_List_Member
(N
) then
3621 Make_Aspect_For_PPC_In_Gen_Sub_Decl
(N
);
3626 Exit_Generic_Scope
(Id
);
3627 Generate_Reference_To_Formals
(Id
);
3629 List_Inherited_Pre_Post_Aspects
(Id
);
3630 end Analyze_Generic_Subprogram_Declaration
;
3632 -----------------------------------
3633 -- Analyze_Package_Instantiation --
3634 -----------------------------------
3636 procedure Analyze_Package_Instantiation
(N
: Node_Id
) is
3637 Loc
: constant Source_Ptr
:= Sloc
(N
);
3638 Gen_Id
: constant Node_Id
:= Name
(N
);
3641 Act_Decl_Name
: Node_Id
;
3642 Act_Decl_Id
: Entity_Id
;
3648 Gen_Unit
: Entity_Id
;
3650 Is_Actual_Pack
: constant Boolean :=
3651 Is_Internal
(Defining_Entity
(N
));
3653 Env_Installed
: Boolean := False;
3654 Parent_Installed
: Boolean := False;
3655 Renaming_List
: List_Id
;
3656 Unit_Renaming
: Node_Id
;
3657 Needs_Body
: Boolean;
3658 Inline_Now
: Boolean := False;
3660 Save_IPSM
: constant Boolean := Ignore_Pragma_SPARK_Mode
;
3661 -- Save flag Ignore_Pragma_SPARK_Mode for restore on exit
3663 Save_SM
: constant SPARK_Mode_Type
:= SPARK_Mode
;
3664 Save_SMP
: constant Node_Id
:= SPARK_Mode_Pragma
;
3665 -- Save the SPARK_Mode-related data for restore on exit
3667 Save_Style_Check
: constant Boolean := Style_Check
;
3668 -- Save style check mode for restore on exit
3670 procedure Delay_Descriptors
(E
: Entity_Id
);
3671 -- Delay generation of subprogram descriptors for given entity
3673 function Might_Inline_Subp
return Boolean;
3674 -- If inlining is active and the generic contains inlined subprograms,
3675 -- we instantiate the body. This may cause superfluous instantiations,
3676 -- but it is simpler than detecting the need for the body at the point
3677 -- of inlining, when the context of the instance is not available.
3679 -----------------------
3680 -- Delay_Descriptors --
3681 -----------------------
3683 procedure Delay_Descriptors
(E
: Entity_Id
) is
3685 if not Delay_Subprogram_Descriptors
(E
) then
3686 Set_Delay_Subprogram_Descriptors
(E
);
3687 Pending_Descriptor
.Append
(E
);
3689 end Delay_Descriptors
;
3691 -----------------------
3692 -- Might_Inline_Subp --
3693 -----------------------
3695 function Might_Inline_Subp
return Boolean is
3699 if not Inline_Processing_Required
then
3703 E
:= First_Entity
(Gen_Unit
);
3704 while Present
(E
) loop
3705 if Is_Subprogram
(E
) and then Is_Inlined
(E
) then
3714 end Might_Inline_Subp
;
3716 -- Local declarations
3718 Vis_Prims_List
: Elist_Id
:= No_Elist
;
3719 -- List of primitives made temporarily visible in the instantiation
3720 -- to match the visibility of the formal type
3722 -- Start of processing for Analyze_Package_Instantiation
3725 Check_SPARK_05_Restriction
("generic is not allowed", N
);
3727 -- Very first thing: check for Text_IO sp[ecial unit in case we are
3728 -- instantiating one of the children of [[Wide_]Wide_]Text_IO.
3730 Check_Text_IO_Special_Unit
(Name
(N
));
3732 -- Make node global for error reporting
3734 Instantiation_Node
:= N
;
3736 -- Turn off style checking in instances. If the check is enabled on the
3737 -- generic unit, a warning in an instance would just be noise. If not
3738 -- enabled on the generic, then a warning in an instance is just wrong.
3740 Style_Check
:= False;
3742 -- Case of instantiation of a generic package
3744 if Nkind
(N
) = N_Package_Instantiation
then
3745 Act_Decl_Id
:= New_Copy
(Defining_Entity
(N
));
3746 Set_Comes_From_Source
(Act_Decl_Id
, True);
3748 if Nkind
(Defining_Unit_Name
(N
)) = N_Defining_Program_Unit_Name
then
3750 Make_Defining_Program_Unit_Name
(Loc
,
3751 Name
=> New_Copy_Tree
(Name
(Defining_Unit_Name
(N
))),
3752 Defining_Identifier
=> Act_Decl_Id
);
3754 Act_Decl_Name
:= Act_Decl_Id
;
3757 -- Case of instantiation of a formal package
3760 Act_Decl_Id
:= Defining_Identifier
(N
);
3761 Act_Decl_Name
:= Act_Decl_Id
;
3764 Generate_Definition
(Act_Decl_Id
);
3765 Preanalyze_Actuals
(N
);
3768 Env_Installed
:= True;
3770 -- Reset renaming map for formal types. The mapping is established
3771 -- when analyzing the generic associations, but some mappings are
3772 -- inherited from formal packages of parent units, and these are
3773 -- constructed when the parents are installed.
3775 Generic_Renamings
.Set_Last
(0);
3776 Generic_Renamings_HTable
.Reset
;
3778 Check_Generic_Child_Unit
(Gen_Id
, Parent_Installed
);
3779 Gen_Unit
:= Entity
(Gen_Id
);
3781 -- Verify that it is the name of a generic package
3783 -- A visibility glitch: if the instance is a child unit and the generic
3784 -- is the generic unit of a parent instance (i.e. both the parent and
3785 -- the child units are instances of the same package) the name now
3786 -- denotes the renaming within the parent, not the intended generic
3787 -- unit. See if there is a homonym that is the desired generic. The
3788 -- renaming declaration must be visible inside the instance of the
3789 -- child, but not when analyzing the name in the instantiation itself.
3791 if Ekind
(Gen_Unit
) = E_Package
3792 and then Present
(Renamed_Entity
(Gen_Unit
))
3793 and then In_Open_Scopes
(Renamed_Entity
(Gen_Unit
))
3794 and then Is_Generic_Instance
(Renamed_Entity
(Gen_Unit
))
3795 and then Present
(Homonym
(Gen_Unit
))
3797 Gen_Unit
:= Homonym
(Gen_Unit
);
3800 if Etype
(Gen_Unit
) = Any_Type
then
3804 elsif Ekind
(Gen_Unit
) /= E_Generic_Package
then
3806 -- Ada 2005 (AI-50217): Cannot use instance in limited with_clause
3808 if From_Limited_With
(Gen_Unit
) then
3810 ("cannot instantiate a limited withed package", Gen_Id
);
3813 ("& is not the name of a generic package", Gen_Id
, Gen_Unit
);
3820 if In_Extended_Main_Source_Unit
(N
) then
3821 Set_Is_Instantiated
(Gen_Unit
);
3822 Generate_Reference
(Gen_Unit
, N
);
3824 if Present
(Renamed_Object
(Gen_Unit
)) then
3825 Set_Is_Instantiated
(Renamed_Object
(Gen_Unit
));
3826 Generate_Reference
(Renamed_Object
(Gen_Unit
), N
);
3830 if Nkind
(Gen_Id
) = N_Identifier
3831 and then Chars
(Gen_Unit
) = Chars
(Defining_Entity
(N
))
3834 ("& is hidden within declaration of instance", Gen_Id
, Gen_Unit
);
3836 elsif Nkind
(Gen_Id
) = N_Expanded_Name
3837 and then Is_Child_Unit
(Gen_Unit
)
3838 and then Nkind
(Prefix
(Gen_Id
)) = N_Identifier
3839 and then Chars
(Act_Decl_Id
) = Chars
(Prefix
(Gen_Id
))
3842 ("& is hidden within declaration of instance ", Prefix
(Gen_Id
));
3845 Set_Entity
(Gen_Id
, Gen_Unit
);
3847 -- If generic is a renaming, get original generic unit
3849 if Present
(Renamed_Object
(Gen_Unit
))
3850 and then Ekind
(Renamed_Object
(Gen_Unit
)) = E_Generic_Package
3852 Gen_Unit
:= Renamed_Object
(Gen_Unit
);
3855 -- Verify that there are no circular instantiations
3857 if In_Open_Scopes
(Gen_Unit
) then
3858 Error_Msg_NE
("instantiation of & within itself", N
, Gen_Unit
);
3862 elsif Contains_Instance_Of
(Gen_Unit
, Current_Scope
, Gen_Id
) then
3863 Error_Msg_Node_2
:= Current_Scope
;
3865 ("circular Instantiation: & instantiated in &!", N
, Gen_Unit
);
3866 Circularity_Detected
:= True;
3871 -- If the context of the instance is subject to SPARK_Mode "off",
3872 -- set the global flag which signals Analyze_Pragma to ignore all
3873 -- SPARK_Mode pragmas within the instance.
3875 if SPARK_Mode
= Off
then
3876 Ignore_Pragma_SPARK_Mode
:= True;
3879 Gen_Decl
:= Unit_Declaration_Node
(Gen_Unit
);
3880 Gen_Spec
:= Specification
(Gen_Decl
);
3882 -- Initialize renamings map, for error checking, and the list that
3883 -- holds private entities whose views have changed between generic
3884 -- definition and instantiation. If this is the instance created to
3885 -- validate an actual package, the instantiation environment is that
3886 -- of the enclosing instance.
3888 Create_Instantiation_Source
(N
, Gen_Unit
, False, S_Adjustment
);
3890 -- Copy original generic tree, to produce text for instantiation
3894 (Original_Node
(Gen_Decl
), Empty
, Instantiating
=> True);
3896 Act_Spec
:= Specification
(Act_Tree
);
3898 -- If this is the instance created to validate an actual package,
3899 -- only the formals matter, do not examine the package spec itself.
3901 if Is_Actual_Pack
then
3902 Set_Visible_Declarations
(Act_Spec
, New_List
);
3903 Set_Private_Declarations
(Act_Spec
, New_List
);
3907 Analyze_Associations
3909 Formals
=> Generic_Formal_Declarations
(Act_Tree
),
3910 F_Copy
=> Generic_Formal_Declarations
(Gen_Decl
));
3912 Vis_Prims_List
:= Check_Hidden_Primitives
(Renaming_List
);
3914 Set_Instance_Env
(Gen_Unit
, Act_Decl_Id
);
3915 Set_Defining_Unit_Name
(Act_Spec
, Act_Decl_Name
);
3916 Set_Is_Generic_Instance
(Act_Decl_Id
);
3917 Set_Generic_Parent
(Act_Spec
, Gen_Unit
);
3919 -- References to the generic in its own declaration or its body are
3920 -- references to the instance. Add a renaming declaration for the
3921 -- generic unit itself. This declaration, as well as the renaming
3922 -- declarations for the generic formals, must remain private to the
3923 -- unit: the formals, because this is the language semantics, and
3924 -- the unit because its use is an artifact of the implementation.
3927 Make_Package_Renaming_Declaration
(Loc
,
3928 Defining_Unit_Name
=>
3929 Make_Defining_Identifier
(Loc
, Chars
(Gen_Unit
)),
3930 Name
=> New_Occurrence_Of
(Act_Decl_Id
, Loc
));
3932 Append
(Unit_Renaming
, Renaming_List
);
3934 -- The renaming declarations are the first local declarations of the
3937 if Is_Non_Empty_List
(Visible_Declarations
(Act_Spec
)) then
3939 (First
(Visible_Declarations
(Act_Spec
)), Renaming_List
);
3941 Set_Visible_Declarations
(Act_Spec
, Renaming_List
);
3944 Act_Decl
:= Make_Package_Declaration
(Loc
, Specification
=> Act_Spec
);
3946 -- Propagate the aspect specifications from the package declaration
3947 -- template to the instantiated version of the package declaration.
3949 if Has_Aspects
(Act_Tree
) then
3950 Set_Aspect_Specifications
(Act_Decl
,
3951 New_Copy_List_Tree
(Aspect_Specifications
(Act_Tree
)));
3954 -- The generic may have a generated Default_Storage_Pool aspect,
3955 -- set at the point of generic declaration. If the instance has
3956 -- that aspect, it overrides the one inherited from the generic.
3958 if Has_Aspects
(Gen_Spec
) then
3959 if No
(Aspect_Specifications
(N
)) then
3960 Set_Aspect_Specifications
(N
,
3962 (Aspect_Specifications
(Gen_Spec
))));
3966 ASN1
, ASN2
: Node_Id
;
3969 ASN1
:= First
(Aspect_Specifications
(N
));
3970 while Present
(ASN1
) loop
3971 if Chars
(Identifier
(ASN1
))
3972 = Name_Default_Storage_Pool
3974 -- If generic carries a default storage pool, remove
3975 -- it in favor of the instance one.
3977 ASN2
:= First
(Aspect_Specifications
(Gen_Spec
));
3978 while Present
(ASN2
) loop
3979 if Chars
(Identifier
(ASN2
)) =
3980 Name_Default_Storage_Pool
3993 Prepend_List_To
(Aspect_Specifications
(N
),
3995 (Aspect_Specifications
(Gen_Spec
))));
4000 -- Save the instantiation node, for subsequent instantiation of the
4001 -- body, if there is one and we are generating code for the current
4002 -- unit. Mark unit as having a body (avoids premature error message).
4004 -- We instantiate the body if we are generating code, if we are
4005 -- generating cross-reference information, or if we are building
4006 -- trees for ASIS use or GNATprove use.
4009 Enclosing_Body_Present
: Boolean := False;
4010 -- If the generic unit is not a compilation unit, then a body may
4011 -- be present in its parent even if none is required. We create a
4012 -- tentative pending instantiation for the body, which will be
4013 -- discarded if none is actually present.
4018 if Scope
(Gen_Unit
) /= Standard_Standard
4019 and then not Is_Child_Unit
(Gen_Unit
)
4021 Scop
:= Scope
(Gen_Unit
);
4023 while Present
(Scop
)
4024 and then Scop
/= Standard_Standard
4026 if Unit_Requires_Body
(Scop
) then
4027 Enclosing_Body_Present
:= True;
4030 elsif In_Open_Scopes
(Scop
)
4031 and then In_Package_Body
(Scop
)
4033 Enclosing_Body_Present
:= True;
4037 exit when Is_Compilation_Unit
(Scop
);
4038 Scop
:= Scope
(Scop
);
4042 -- If front-end inlining is enabled, and this is a unit for which
4043 -- code will be generated, we instantiate the body at once.
4045 -- This is done if the instance is not the main unit, and if the
4046 -- generic is not a child unit of another generic, to avoid scope
4047 -- problems and the reinstallation of parent instances.
4050 and then (not Is_Child_Unit
(Gen_Unit
)
4051 or else not Is_Generic_Unit
(Scope
(Gen_Unit
)))
4052 and then Might_Inline_Subp
4053 and then not Is_Actual_Pack
4055 if not Back_End_Inlining
4056 and then Front_End_Inlining
4057 and then (Is_In_Main_Unit
(N
)
4058 or else In_Main_Context
(Current_Scope
))
4059 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit
4063 -- In configurable_run_time mode we force the inlining of
4064 -- predefined subprograms marked Inline_Always, to minimize
4065 -- the use of the run-time library.
4067 elsif Is_Predefined_File_Name
4068 (Unit_File_Name
(Get_Source_Unit
(Gen_Decl
)))
4069 and then Configurable_Run_Time_Mode
4070 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit
4075 -- If the current scope is itself an instance within a child
4076 -- unit, there will be duplications in the scope stack, and the
4077 -- unstacking mechanism in Inline_Instance_Body will fail.
4078 -- This loses some rare cases of optimization, and might be
4079 -- improved some day, if we can find a proper abstraction for
4080 -- "the complete compilation context" that can be saved and
4083 if Is_Generic_Instance
(Current_Scope
) then
4085 Curr_Unit
: constant Entity_Id
:=
4086 Cunit_Entity
(Current_Sem_Unit
);
4088 if Curr_Unit
/= Current_Scope
4089 and then Is_Child_Unit
(Curr_Unit
)
4091 Inline_Now
:= False;
4098 (Unit_Requires_Body
(Gen_Unit
)
4099 or else Enclosing_Body_Present
4100 or else Present
(Corresponding_Body
(Gen_Decl
)))
4101 and then (Is_In_Main_Unit
(N
) or else Might_Inline_Subp
)
4102 and then not Is_Actual_Pack
4103 and then not Inline_Now
4104 and then (Operating_Mode
= Generate_Code
4106 -- Need comment for this check ???
4108 or else (Operating_Mode
= Check_Semantics
4109 and then (ASIS_Mode
or GNATprove_Mode
)));
4111 -- If front_end_inlining is enabled, do not instantiate body if
4112 -- within a generic context.
4114 if (Front_End_Inlining
and then not Expander_Active
)
4115 or else Is_Generic_Unit
(Cunit_Entity
(Main_Unit
))
4117 Needs_Body
:= False;
4120 -- If the current context is generic, and the package being
4121 -- instantiated is declared within a formal package, there is no
4122 -- body to instantiate until the enclosing generic is instantiated
4123 -- and there is an actual for the formal package. If the formal
4124 -- package has parameters, we build a regular package instance for
4125 -- it, that precedes the original formal package declaration.
4127 if In_Open_Scopes
(Scope
(Scope
(Gen_Unit
))) then
4129 Decl
: constant Node_Id
:=
4131 (Unit_Declaration_Node
(Scope
(Gen_Unit
)));
4133 if Nkind
(Decl
) = N_Formal_Package_Declaration
4134 or else (Nkind
(Decl
) = N_Package_Declaration
4135 and then Is_List_Member
(Decl
)
4136 and then Present
(Next
(Decl
))
4138 Nkind
(Next
(Decl
)) =
4139 N_Formal_Package_Declaration
)
4141 Needs_Body
:= False;
4147 -- For RCI unit calling stubs, we omit the instance body if the
4148 -- instance is the RCI library unit itself.
4150 -- However there is a special case for nested instances: in this case
4151 -- we do generate the instance body, as it might be required, e.g.
4152 -- because it provides stream attributes for some type used in the
4153 -- profile of a remote subprogram. This is consistent with 12.3(12),
4154 -- which indicates that the instance body occurs at the place of the
4155 -- instantiation, and thus is part of the RCI declaration, which is
4156 -- present on all client partitions (this is E.2.3(18)).
4158 -- Note that AI12-0002 may make it illegal at some point to have
4159 -- stream attributes defined in an RCI unit, in which case this
4160 -- special case will become unnecessary. In the meantime, there
4161 -- is known application code in production that depends on this
4162 -- being possible, so we definitely cannot eliminate the body in
4163 -- the case of nested instances for the time being.
4165 -- When we generate a nested instance body, calling stubs for any
4166 -- relevant subprogram will be be inserted immediately after the
4167 -- subprogram declarations, and will take precedence over the
4168 -- subsequent (original) body. (The stub and original body will be
4169 -- complete homographs, but this is permitted in an instance).
4170 -- (Could we do better and remove the original body???)
4172 if Distribution_Stub_Mode
= Generate_Caller_Stub_Body
4173 and then Comes_From_Source
(N
)
4174 and then Nkind
(Parent
(N
)) = N_Compilation_Unit
4176 Needs_Body
:= False;
4181 -- Here is a defence against a ludicrous number of instantiations
4182 -- caused by a circular set of instantiation attempts.
4184 if Pending_Instantiations
.Last
> Maximum_Instantiations
then
4185 Error_Msg_Uint_1
:= UI_From_Int
(Maximum_Instantiations
);
4186 Error_Msg_N
("too many instantiations, exceeds max of^", N
);
4187 Error_Msg_N
("\limit can be changed using -gnateinn switch", N
);
4188 raise Unrecoverable_Error
;
4191 -- Indicate that the enclosing scopes contain an instantiation,
4192 -- and that cleanup actions should be delayed until after the
4193 -- instance body is expanded.
4195 Check_Forward_Instantiation
(Gen_Decl
);
4196 if Nkind
(N
) = N_Package_Instantiation
then
4198 Enclosing_Master
: Entity_Id
;
4201 -- Loop to search enclosing masters
4203 Enclosing_Master
:= Current_Scope
;
4204 Scope_Loop
: while Enclosing_Master
/= Standard_Standard
loop
4205 if Ekind
(Enclosing_Master
) = E_Package
then
4206 if Is_Compilation_Unit
(Enclosing_Master
) then
4207 if In_Package_Body
(Enclosing_Master
) then
4209 (Body_Entity
(Enclosing_Master
));
4218 Enclosing_Master
:= Scope
(Enclosing_Master
);
4221 elsif Is_Generic_Unit
(Enclosing_Master
)
4222 or else Ekind
(Enclosing_Master
) = E_Void
4224 -- Cleanup actions will eventually be performed on the
4225 -- enclosing subprogram or package instance, if any.
4226 -- Enclosing scope is void in the formal part of a
4227 -- generic subprogram.
4232 if Ekind
(Enclosing_Master
) = E_Entry
4234 Ekind
(Scope
(Enclosing_Master
)) = E_Protected_Type
4236 if not Expander_Active
then
4240 Protected_Body_Subprogram
(Enclosing_Master
);
4244 Set_Delay_Cleanups
(Enclosing_Master
);
4246 while Ekind
(Enclosing_Master
) = E_Block
loop
4247 Enclosing_Master
:= Scope
(Enclosing_Master
);
4250 if Is_Subprogram
(Enclosing_Master
) then
4251 Delay_Descriptors
(Enclosing_Master
);
4253 elsif Is_Task_Type
(Enclosing_Master
) then
4255 TBP
: constant Node_Id
:=
4256 Get_Task_Body_Procedure
4259 if Present
(TBP
) then
4260 Delay_Descriptors
(TBP
);
4261 Set_Delay_Cleanups
(TBP
);
4268 end loop Scope_Loop
;
4271 -- Make entry in table
4273 Pending_Instantiations
.Append
4275 Act_Decl
=> Act_Decl
,
4276 Expander_Status
=> Expander_Active
,
4277 Current_Sem_Unit
=> Current_Sem_Unit
,
4278 Scope_Suppress
=> Scope_Suppress
,
4279 Local_Suppress_Stack_Top
=> Local_Suppress_Stack_Top
,
4280 Version
=> Ada_Version
,
4281 Version_Pragma
=> Ada_Version_Pragma
,
4282 Warnings
=> Save_Warnings
,
4283 SPARK_Mode
=> SPARK_Mode
,
4284 SPARK_Mode_Pragma
=> SPARK_Mode_Pragma
));
4288 Set_Categorization_From_Pragmas
(Act_Decl
);
4290 if Parent_Installed
then
4294 Set_Instance_Spec
(N
, Act_Decl
);
4296 -- If not a compilation unit, insert the package declaration before
4297 -- the original instantiation node.
4299 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
4300 Mark_Rewrite_Insertion
(Act_Decl
);
4301 Insert_Before
(N
, Act_Decl
);
4303 if Has_Aspects
(N
) then
4304 Analyze_Aspect_Specifications
(N
, Act_Decl_Id
);
4306 -- The pragma created for a Default_Storage_Pool aspect must
4307 -- appear ahead of the declarations in the instance spec.
4308 -- Analysis has placed it after the instance node, so remove
4309 -- it and reinsert it properly now.
4312 ASN
: constant Node_Id
:= First
(Aspect_Specifications
(N
));
4313 A_Name
: constant Name_Id
:= Chars
(Identifier
(ASN
));
4317 if A_Name
= Name_Default_Storage_Pool
then
4318 if No
(Visible_Declarations
(Act_Spec
)) then
4319 Set_Visible_Declarations
(Act_Spec
, New_List
);
4323 while Present
(Decl
) loop
4324 if Nkind
(Decl
) = N_Pragma
then
4326 Prepend
(Decl
, Visible_Declarations
(Act_Spec
));
4338 -- For an instantiation that is a compilation unit, place
4339 -- declaration on current node so context is complete for analysis
4340 -- (including nested instantiations). If this is the main unit,
4341 -- the declaration eventually replaces the instantiation node.
4342 -- If the instance body is created later, it replaces the
4343 -- instance node, and the declaration is attached to it
4344 -- (see Build_Instance_Compilation_Unit_Nodes).
4347 if Cunit_Entity
(Current_Sem_Unit
) = Defining_Entity
(N
) then
4349 -- The entity for the current unit is the newly created one,
4350 -- and all semantic information is attached to it.
4352 Set_Cunit_Entity
(Current_Sem_Unit
, Act_Decl_Id
);
4354 -- If this is the main unit, replace the main entity as well
4356 if Current_Sem_Unit
= Main_Unit
then
4357 Main_Unit_Entity
:= Act_Decl_Id
;
4361 Set_Unit
(Parent
(N
), Act_Decl
);
4362 Set_Parent_Spec
(Act_Decl
, Parent_Spec
(N
));
4363 Set_Package_Instantiation
(Act_Decl_Id
, N
);
4365 -- Process aspect specifications of the instance node, if any, to
4366 -- take into account categorization pragmas before analyzing the
4369 if Has_Aspects
(N
) then
4370 Analyze_Aspect_Specifications
(N
, Act_Decl_Id
);
4374 Set_Unit
(Parent
(N
), N
);
4375 Set_Body_Required
(Parent
(N
), False);
4377 -- We never need elaboration checks on instantiations, since by
4378 -- definition, the body instantiation is elaborated at the same
4379 -- time as the spec instantiation.
4381 Set_Suppress_Elaboration_Warnings
(Act_Decl_Id
);
4382 Set_Kill_Elaboration_Checks
(Act_Decl_Id
);
4385 Check_Elab_Instantiation
(N
);
4387 if ABE_Is_Certain
(N
) and then Needs_Body
then
4388 Pending_Instantiations
.Decrement_Last
;
4391 Check_Hidden_Child_Unit
(N
, Gen_Unit
, Act_Decl_Id
);
4393 Set_First_Private_Entity
(Defining_Unit_Name
(Unit_Renaming
),
4394 First_Private_Entity
(Act_Decl_Id
));
4396 -- If the instantiation will receive a body, the unit will be
4397 -- transformed into a package body, and receive its own elaboration
4398 -- entity. Otherwise, the nature of the unit is now a package
4401 if Nkind
(Parent
(N
)) = N_Compilation_Unit
4402 and then not Needs_Body
4404 Rewrite
(N
, Act_Decl
);
4407 if Present
(Corresponding_Body
(Gen_Decl
))
4408 or else Unit_Requires_Body
(Gen_Unit
)
4410 Set_Has_Completion
(Act_Decl_Id
);
4413 Check_Formal_Packages
(Act_Decl_Id
);
4415 Restore_Hidden_Primitives
(Vis_Prims_List
);
4416 Restore_Private_Views
(Act_Decl_Id
);
4418 Inherit_Context
(Gen_Decl
, N
);
4420 if Parent_Installed
then
4425 Env_Installed
:= False;
4428 Validate_Categorization_Dependency
(N
, Act_Decl_Id
);
4430 -- There used to be a check here to prevent instantiations in local
4431 -- contexts if the No_Local_Allocators restriction was active. This
4432 -- check was removed by a binding interpretation in AI-95-00130/07,
4433 -- but we retain the code for documentation purposes.
4435 -- if Ekind (Act_Decl_Id) /= E_Void
4436 -- and then not Is_Library_Level_Entity (Act_Decl_Id)
4438 -- Check_Restriction (No_Local_Allocators, N);
4442 Inline_Instance_Body
(N
, Gen_Unit
, Act_Decl
);
4445 -- The following is a tree patch for ASIS: ASIS needs separate nodes to
4446 -- be used as defining identifiers for a formal package and for the
4447 -- corresponding expanded package.
4449 if Nkind
(N
) = N_Formal_Package_Declaration
then
4450 Act_Decl_Id
:= New_Copy
(Defining_Entity
(N
));
4451 Set_Comes_From_Source
(Act_Decl_Id
, True);
4452 Set_Is_Generic_Instance
(Act_Decl_Id
, False);
4453 Set_Defining_Identifier
(N
, Act_Decl_Id
);
4456 Ignore_Pragma_SPARK_Mode
:= Save_IPSM
;
4457 SPARK_Mode
:= Save_SM
;
4458 SPARK_Mode_Pragma
:= Save_SMP
;
4459 Style_Check
:= Save_Style_Check
;
4461 if SPARK_Mode
= On
then
4462 Dynamic_Elaboration_Checks
:= False;
4465 -- Check that if N is an instantiation of System.Dim_Float_IO or
4466 -- System.Dim_Integer_IO, the formal type has a dimension system.
4468 if Nkind
(N
) = N_Package_Instantiation
4469 and then Is_Dim_IO_Package_Instantiation
(N
)
4472 Assoc
: constant Node_Id
:= First
(Generic_Associations
(N
));
4474 if not Has_Dimension_System
4475 (Etype
(Explicit_Generic_Actual_Parameter
(Assoc
)))
4477 Error_Msg_N
("type with a dimension system expected", Assoc
);
4483 if Has_Aspects
(N
) and then Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
4484 Analyze_Aspect_Specifications
(N
, Act_Decl_Id
);
4488 when Instantiation_Error
=>
4489 if Parent_Installed
then
4493 if Env_Installed
then
4497 Ignore_Pragma_SPARK_Mode
:= Save_IPSM
;
4498 SPARK_Mode
:= Save_SM
;
4499 SPARK_Mode_Pragma
:= Save_SMP
;
4500 Style_Check
:= Save_Style_Check
;
4502 if SPARK_Mode
= On
then
4503 Dynamic_Elaboration_Checks
:= False;
4505 end Analyze_Package_Instantiation
;
4507 --------------------------
4508 -- Inline_Instance_Body --
4509 --------------------------
4511 procedure Inline_Instance_Body
4513 Gen_Unit
: Entity_Id
;
4516 Curr_Comp
: constant Node_Id
:= Cunit
(Current_Sem_Unit
);
4517 Curr_Unit
: constant Entity_Id
:= Cunit_Entity
(Current_Sem_Unit
);
4518 Gen_Comp
: constant Entity_Id
:=
4519 Cunit_Entity
(Get_Source_Unit
(Gen_Unit
));
4521 Save_SM
: constant SPARK_Mode_Type
:= SPARK_Mode
;
4522 Save_SMP
: constant Node_Id
:= SPARK_Mode_Pragma
;
4523 -- Save all SPARK_Mode-related attributes as removing enclosing scopes
4524 -- to provide a clean environment for analysis of the inlined body will
4525 -- eliminate any previously set SPARK_Mode.
4527 Scope_Stack_Depth
: constant Int
:=
4528 Scope_Stack
.Last
- Scope_Stack
.First
+ 1;
4530 Use_Clauses
: array (1 .. Scope_Stack_Depth
) of Node_Id
;
4531 Instances
: array (1 .. Scope_Stack_Depth
) of Entity_Id
;
4532 Inner_Scopes
: array (1 .. Scope_Stack_Depth
) of Entity_Id
;
4533 Curr_Scope
: Entity_Id
:= Empty
;
4535 Num_Inner
: Int
:= 0;
4536 Num_Scopes
: Int
:= 0;
4537 N_Instances
: Int
:= 0;
4538 Removed
: Boolean := False;
4543 -- Case of generic unit defined in another unit. We must remove the
4544 -- complete context of the current unit to install that of the generic.
4546 if Gen_Comp
/= Cunit_Entity
(Current_Sem_Unit
) then
4548 -- Add some comments for the following two loops ???
4551 while Present
(S
) and then S
/= Standard_Standard
loop
4553 Num_Scopes
:= Num_Scopes
+ 1;
4555 Use_Clauses
(Num_Scopes
) :=
4557 (Scope_Stack
.Last
- Num_Scopes
+ 1).
4559 End_Use_Clauses
(Use_Clauses
(Num_Scopes
));
4561 exit when Scope_Stack
.Last
- Num_Scopes
+ 1 = Scope_Stack
.First
4562 or else Scope_Stack
.Table
4563 (Scope_Stack
.Last
- Num_Scopes
).Entity
= Scope
(S
);
4566 exit when Is_Generic_Instance
(S
)
4567 and then (In_Package_Body
(S
)
4568 or else Ekind
(S
) = E_Procedure
4569 or else Ekind
(S
) = E_Function
);
4573 Vis
:= Is_Immediately_Visible
(Gen_Comp
);
4575 -- Find and save all enclosing instances
4580 and then S
/= Standard_Standard
4582 if Is_Generic_Instance
(S
) then
4583 N_Instances
:= N_Instances
+ 1;
4584 Instances
(N_Instances
) := S
;
4586 exit when In_Package_Body
(S
);
4592 -- Remove context of current compilation unit, unless we are within a
4593 -- nested package instantiation, in which case the context has been
4594 -- removed previously.
4596 -- If current scope is the body of a child unit, remove context of
4597 -- spec as well. If an enclosing scope is an instance body, the
4598 -- context has already been removed, but the entities in the body
4599 -- must be made invisible as well.
4604 and then S
/= Standard_Standard
4606 if Is_Generic_Instance
(S
)
4607 and then (In_Package_Body
(S
)
4608 or else Ekind_In
(S
, E_Procedure
, E_Function
))
4610 -- We still have to remove the entities of the enclosing
4611 -- instance from direct visibility.
4616 E
:= First_Entity
(S
);
4617 while Present
(E
) loop
4618 Set_Is_Immediately_Visible
(E
, False);
4627 or else (Ekind
(Curr_Unit
) = E_Package_Body
4628 and then S
= Spec_Entity
(Curr_Unit
))
4629 or else (Ekind
(Curr_Unit
) = E_Subprogram_Body
4632 (Unit_Declaration_Node
(Curr_Unit
)))
4636 -- Remove entities in current scopes from visibility, so that
4637 -- instance body is compiled in a clean environment.
4639 List
:= Save_Scope_Stack
(Handle_Use
=> False);
4641 if Is_Child_Unit
(S
) then
4643 -- Remove child unit from stack, as well as inner scopes.
4644 -- Removing the context of a child unit removes parent units
4647 while Current_Scope
/= S
loop
4648 Num_Inner
:= Num_Inner
+ 1;
4649 Inner_Scopes
(Num_Inner
) := Current_Scope
;
4654 Remove_Context
(Curr_Comp
);
4658 Remove_Context
(Curr_Comp
);
4661 if Ekind
(Curr_Unit
) = E_Package_Body
then
4662 Remove_Context
(Library_Unit
(Curr_Comp
));
4669 pragma Assert
(Num_Inner
< Num_Scopes
);
4671 -- The inlined package body must be analyzed with the SPARK_Mode of
4672 -- the enclosing context, otherwise the body may cause bogus errors
4673 -- if a configuration SPARK_Mode pragma in in effect.
4675 Push_Scope
(Standard_Standard
);
4676 Scope_Stack
.Table
(Scope_Stack
.Last
).Is_Active_Stack_Base
:= True;
4677 Instantiate_Package_Body
4680 Act_Decl
=> Act_Decl
,
4681 Expander_Status
=> Expander_Active
,
4682 Current_Sem_Unit
=> Current_Sem_Unit
,
4683 Scope_Suppress
=> Scope_Suppress
,
4684 Local_Suppress_Stack_Top
=> Local_Suppress_Stack_Top
,
4685 Version
=> Ada_Version
,
4686 Version_Pragma
=> Ada_Version_Pragma
,
4687 Warnings
=> Save_Warnings
,
4688 SPARK_Mode
=> Save_SM
,
4689 SPARK_Mode_Pragma
=> Save_SMP
)),
4690 Inlined_Body
=> True);
4696 Set_Is_Immediately_Visible
(Gen_Comp
, Vis
);
4698 -- Reset Generic_Instance flag so that use clauses can be installed
4699 -- in the proper order. (See Use_One_Package for effect of enclosing
4700 -- instances on processing of use clauses).
4702 for J
in 1 .. N_Instances
loop
4703 Set_Is_Generic_Instance
(Instances
(J
), False);
4707 Install_Context
(Curr_Comp
);
4709 if Present
(Curr_Scope
)
4710 and then Is_Child_Unit
(Curr_Scope
)
4712 Push_Scope
(Curr_Scope
);
4713 Set_Is_Immediately_Visible
(Curr_Scope
);
4715 -- Finally, restore inner scopes as well
4717 for J
in reverse 1 .. Num_Inner
loop
4718 Push_Scope
(Inner_Scopes
(J
));
4722 Restore_Scope_Stack
(List
, Handle_Use
=> False);
4724 if Present
(Curr_Scope
)
4726 (In_Private_Part
(Curr_Scope
)
4727 or else In_Package_Body
(Curr_Scope
))
4729 -- Install private declaration of ancestor units, which are
4730 -- currently available. Restore_Scope_Stack and Install_Context
4731 -- only install the visible part of parents.
4736 Par
:= Scope
(Curr_Scope
);
4737 while (Present
(Par
))
4738 and then Par
/= Standard_Standard
4740 Install_Private_Declarations
(Par
);
4747 -- Restore use clauses. For a child unit, use clauses in the parents
4748 -- are restored when installing the context, so only those in inner
4749 -- scopes (and those local to the child unit itself) need to be
4750 -- installed explicitly.
4752 if Is_Child_Unit
(Curr_Unit
)
4755 for J
in reverse 1 .. Num_Inner
+ 1 loop
4756 Scope_Stack
.Table
(Scope_Stack
.Last
- J
+ 1).First_Use_Clause
:=
4758 Install_Use_Clauses
(Use_Clauses
(J
));
4762 for J
in reverse 1 .. Num_Scopes
loop
4763 Scope_Stack
.Table
(Scope_Stack
.Last
- J
+ 1).First_Use_Clause
:=
4765 Install_Use_Clauses
(Use_Clauses
(J
));
4769 -- Restore status of instances. If one of them is a body, make its
4770 -- local entities visible again.
4777 for J
in 1 .. N_Instances
loop
4778 Inst
:= Instances
(J
);
4779 Set_Is_Generic_Instance
(Inst
, True);
4781 if In_Package_Body
(Inst
)
4782 or else Ekind_In
(S
, E_Procedure
, E_Function
)
4784 E
:= First_Entity
(Instances
(J
));
4785 while Present
(E
) loop
4786 Set_Is_Immediately_Visible
(E
);
4793 -- If generic unit is in current unit, current context is correct. Note
4794 -- that the context is guaranteed to carry the correct SPARK_Mode as no
4795 -- enclosing scopes were removed.
4798 Instantiate_Package_Body
4801 Act_Decl
=> Act_Decl
,
4802 Expander_Status
=> Expander_Active
,
4803 Current_Sem_Unit
=> Current_Sem_Unit
,
4804 Scope_Suppress
=> Scope_Suppress
,
4805 Local_Suppress_Stack_Top
=> Local_Suppress_Stack_Top
,
4806 Version
=> Ada_Version
,
4807 Version_Pragma
=> Ada_Version_Pragma
,
4808 Warnings
=> Save_Warnings
,
4809 SPARK_Mode
=> SPARK_Mode
,
4810 SPARK_Mode_Pragma
=> SPARK_Mode_Pragma
)),
4811 Inlined_Body
=> True);
4813 end Inline_Instance_Body
;
4815 -------------------------------------
4816 -- Analyze_Procedure_Instantiation --
4817 -------------------------------------
4819 procedure Analyze_Procedure_Instantiation
(N
: Node_Id
) is
4821 Analyze_Subprogram_Instantiation
(N
, E_Procedure
);
4822 end Analyze_Procedure_Instantiation
;
4824 -----------------------------------
4825 -- Need_Subprogram_Instance_Body --
4826 -----------------------------------
4828 function Need_Subprogram_Instance_Body
4830 Subp
: Entity_Id
) return Boolean
4833 -- Must be inlined (or inlined renaming)
4835 if (Is_In_Main_Unit
(N
)
4836 or else Is_Inlined
(Subp
)
4837 or else Is_Inlined
(Alias
(Subp
)))
4839 -- Must be generating code or analyzing code in ASIS/GNATprove mode
4841 and then (Operating_Mode
= Generate_Code
4842 or else (Operating_Mode
= Check_Semantics
4843 and then (ASIS_Mode
or GNATprove_Mode
)))
4845 -- The body is needed when generating code (full expansion), in ASIS
4846 -- mode for other tools, and in GNATprove mode (special expansion) for
4847 -- formal verification of the body itself.
4849 and then (Expander_Active
or ASIS_Mode
or GNATprove_Mode
)
4851 -- No point in inlining if ABE is inevitable
4853 and then not ABE_Is_Certain
(N
)
4855 -- Or if subprogram is eliminated
4857 and then not Is_Eliminated
(Subp
)
4859 Pending_Instantiations
.Append
4861 Act_Decl
=> Unit_Declaration_Node
(Subp
),
4862 Expander_Status
=> Expander_Active
,
4863 Current_Sem_Unit
=> Current_Sem_Unit
,
4864 Scope_Suppress
=> Scope_Suppress
,
4865 Local_Suppress_Stack_Top
=> Local_Suppress_Stack_Top
,
4866 Version
=> Ada_Version
,
4867 Version_Pragma
=> Ada_Version_Pragma
,
4868 Warnings
=> Save_Warnings
,
4869 SPARK_Mode
=> SPARK_Mode
,
4870 SPARK_Mode_Pragma
=> SPARK_Mode_Pragma
));
4873 -- Here if not inlined, or we ignore the inlining
4878 end Need_Subprogram_Instance_Body
;
4880 --------------------------------------
4881 -- Analyze_Subprogram_Instantiation --
4882 --------------------------------------
4884 procedure Analyze_Subprogram_Instantiation
4888 Loc
: constant Source_Ptr
:= Sloc
(N
);
4889 Gen_Id
: constant Node_Id
:= Name
(N
);
4891 Anon_Id
: constant Entity_Id
:=
4892 Make_Defining_Identifier
(Sloc
(Defining_Entity
(N
)),
4893 Chars
=> New_External_Name
4894 (Chars
(Defining_Entity
(N
)), 'R'));
4896 Act_Decl_Id
: Entity_Id
;
4901 Env_Installed
: Boolean := False;
4902 Gen_Unit
: Entity_Id
;
4904 Pack_Id
: Entity_Id
;
4905 Parent_Installed
: Boolean := False;
4906 Renaming_List
: List_Id
;
4908 procedure Analyze_Instance_And_Renamings
;
4909 -- The instance must be analyzed in a context that includes the mappings
4910 -- of generic parameters into actuals. We create a package declaration
4911 -- for this purpose, and a subprogram with an internal name within the
4912 -- package. The subprogram instance is simply an alias for the internal
4913 -- subprogram, declared in the current scope.
4915 ------------------------------------
4916 -- Analyze_Instance_And_Renamings --
4917 ------------------------------------
4919 procedure Analyze_Instance_And_Renamings
is
4920 Def_Ent
: constant Entity_Id
:= Defining_Entity
(N
);
4921 Pack_Decl
: Node_Id
;
4924 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
4926 -- For the case of a compilation unit, the container package has
4927 -- the same name as the instantiation, to insure that the binder
4928 -- calls the elaboration procedure with the right name. Copy the
4929 -- entity of the instance, which may have compilation level flags
4930 -- (e.g. Is_Child_Unit) set.
4932 Pack_Id
:= New_Copy
(Def_Ent
);
4935 -- Otherwise we use the name of the instantiation concatenated
4936 -- with its source position to ensure uniqueness if there are
4937 -- several instantiations with the same name.
4940 Make_Defining_Identifier
(Loc
,
4941 Chars
=> New_External_Name
4942 (Related_Id
=> Chars
(Def_Ent
),
4944 Suffix_Index
=> Source_Offset
(Sloc
(Def_Ent
))));
4947 Pack_Decl
:= Make_Package_Declaration
(Loc
,
4948 Specification
=> Make_Package_Specification
(Loc
,
4949 Defining_Unit_Name
=> Pack_Id
,
4950 Visible_Declarations
=> Renaming_List
,
4951 End_Label
=> Empty
));
4953 Set_Instance_Spec
(N
, Pack_Decl
);
4954 Set_Is_Generic_Instance
(Pack_Id
);
4955 Set_Debug_Info_Needed
(Pack_Id
);
4957 -- Case of not a compilation unit
4959 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
4960 Mark_Rewrite_Insertion
(Pack_Decl
);
4961 Insert_Before
(N
, Pack_Decl
);
4962 Set_Has_Completion
(Pack_Id
);
4964 -- Case of an instantiation that is a compilation unit
4966 -- Place declaration on current node so context is complete for
4967 -- analysis (including nested instantiations), and for use in a
4968 -- context_clause (see Analyze_With_Clause).
4971 Set_Unit
(Parent
(N
), Pack_Decl
);
4972 Set_Parent_Spec
(Pack_Decl
, Parent_Spec
(N
));
4975 Analyze
(Pack_Decl
);
4976 Check_Formal_Packages
(Pack_Id
);
4977 Set_Is_Generic_Instance
(Pack_Id
, False);
4979 -- Why do we clear Is_Generic_Instance??? We set it 20 lines
4982 -- Body of the enclosing package is supplied when instantiating the
4983 -- subprogram body, after semantic analysis is completed.
4985 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
4987 -- Remove package itself from visibility, so it does not
4988 -- conflict with subprogram.
4990 Set_Name_Entity_Id
(Chars
(Pack_Id
), Homonym
(Pack_Id
));
4992 -- Set name and scope of internal subprogram so that the proper
4993 -- external name will be generated. The proper scope is the scope
4994 -- of the wrapper package. We need to generate debugging info for
4995 -- the internal subprogram, so set flag accordingly.
4997 Set_Chars
(Anon_Id
, Chars
(Defining_Entity
(N
)));
4998 Set_Scope
(Anon_Id
, Scope
(Pack_Id
));
5000 -- Mark wrapper package as referenced, to avoid spurious warnings
5001 -- if the instantiation appears in various with_ clauses of
5002 -- subunits of the main unit.
5004 Set_Referenced
(Pack_Id
);
5007 Set_Is_Generic_Instance
(Anon_Id
);
5008 Set_Debug_Info_Needed
(Anon_Id
);
5009 Act_Decl_Id
:= New_Copy
(Anon_Id
);
5011 Set_Parent
(Act_Decl_Id
, Parent
(Anon_Id
));
5012 Set_Chars
(Act_Decl_Id
, Chars
(Defining_Entity
(N
)));
5013 Set_Sloc
(Act_Decl_Id
, Sloc
(Defining_Entity
(N
)));
5014 Set_Comes_From_Source
(Act_Decl_Id
, True);
5016 -- The signature may involve types that are not frozen yet, but the
5017 -- subprogram will be frozen at the point the wrapper package is
5018 -- frozen, so it does not need its own freeze node. In fact, if one
5019 -- is created, it might conflict with the freezing actions from the
5022 Set_Has_Delayed_Freeze
(Anon_Id
, False);
5024 -- If the instance is a child unit, mark the Id accordingly. Mark
5025 -- the anonymous entity as well, which is the real subprogram and
5026 -- which is used when the instance appears in a context clause.
5027 -- Similarly, propagate the Is_Eliminated flag to handle properly
5028 -- nested eliminated subprograms.
5030 Set_Is_Child_Unit
(Act_Decl_Id
, Is_Child_Unit
(Defining_Entity
(N
)));
5031 Set_Is_Child_Unit
(Anon_Id
, Is_Child_Unit
(Defining_Entity
(N
)));
5032 New_Overloaded_Entity
(Act_Decl_Id
);
5033 Check_Eliminated
(Act_Decl_Id
);
5034 Set_Is_Eliminated
(Anon_Id
, Is_Eliminated
(Act_Decl_Id
));
5036 -- In compilation unit case, kill elaboration checks on the
5037 -- instantiation, since they are never needed -- the body is
5038 -- instantiated at the same point as the spec.
5040 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
5041 Set_Suppress_Elaboration_Warnings
(Act_Decl_Id
);
5042 Set_Kill_Elaboration_Checks
(Act_Decl_Id
);
5043 Set_Is_Compilation_Unit
(Anon_Id
);
5045 Set_Cunit_Entity
(Current_Sem_Unit
, Pack_Id
);
5048 -- The instance is not a freezing point for the new subprogram
5050 Set_Is_Frozen
(Act_Decl_Id
, False);
5052 if Nkind
(Defining_Entity
(N
)) = N_Defining_Operator_Symbol
then
5053 Valid_Operator_Definition
(Act_Decl_Id
);
5056 Set_Alias
(Act_Decl_Id
, Anon_Id
);
5057 Set_Parent
(Act_Decl_Id
, Parent
(Anon_Id
));
5058 Set_Has_Completion
(Act_Decl_Id
);
5059 Set_Related_Instance
(Pack_Id
, Act_Decl_Id
);
5061 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
5062 Set_Body_Required
(Parent
(N
), False);
5064 end Analyze_Instance_And_Renamings
;
5068 Save_IPSM
: constant Boolean := Ignore_Pragma_SPARK_Mode
;
5069 -- Save flag Ignore_Pragma_SPARK_Mode for restore on exit
5071 Save_SM
: constant SPARK_Mode_Type
:= SPARK_Mode
;
5072 Save_SMP
: constant Node_Id
:= SPARK_Mode_Pragma
;
5073 -- Save the SPARK_Mode-related data for restore on exit
5075 Vis_Prims_List
: Elist_Id
:= No_Elist
;
5076 -- List of primitives made temporarily visible in the instantiation
5077 -- to match the visibility of the formal type
5079 -- Start of processing for Analyze_Subprogram_Instantiation
5082 Check_SPARK_05_Restriction
("generic is not allowed", N
);
5084 -- Very first thing: check for special Text_IO unit in case we are
5085 -- instantiating one of the children of [[Wide_]Wide_]Text_IO. Of course
5086 -- such an instantiation is bogus (these are packages, not subprograms),
5087 -- but we get a better error message if we do this.
5089 Check_Text_IO_Special_Unit
(Gen_Id
);
5091 -- Make node global for error reporting
5093 Instantiation_Node
:= N
;
5095 -- For package instantiations we turn off style checks, because they
5096 -- will have been emitted in the generic. For subprogram instantiations
5097 -- we want to apply at least the check on overriding indicators so we
5098 -- do not modify the style check status.
5100 -- The renaming declarations for the actuals do not come from source and
5101 -- will not generate spurious warnings.
5103 Preanalyze_Actuals
(N
);
5106 Env_Installed
:= True;
5107 Check_Generic_Child_Unit
(Gen_Id
, Parent_Installed
);
5108 Gen_Unit
:= Entity
(Gen_Id
);
5110 Generate_Reference
(Gen_Unit
, Gen_Id
);
5112 if Nkind
(Gen_Id
) = N_Identifier
5113 and then Chars
(Gen_Unit
) = Chars
(Defining_Entity
(N
))
5116 ("& is hidden within declaration of instance", Gen_Id
, Gen_Unit
);
5119 if Etype
(Gen_Unit
) = Any_Type
then
5124 -- Verify that it is a generic subprogram of the right kind, and that
5125 -- it does not lead to a circular instantiation.
5127 if K
= E_Procedure
and then Ekind
(Gen_Unit
) /= E_Generic_Procedure
then
5129 ("& is not the name of a generic procedure", Gen_Id
, Gen_Unit
);
5131 elsif K
= E_Function
and then Ekind
(Gen_Unit
) /= E_Generic_Function
then
5133 ("& is not the name of a generic function", Gen_Id
, Gen_Unit
);
5135 elsif In_Open_Scopes
(Gen_Unit
) then
5136 Error_Msg_NE
("instantiation of & within itself", N
, Gen_Unit
);
5139 -- If the context of the instance is subject to SPARK_Mode "off",
5140 -- set the global flag which signals Analyze_Pragma to ignore all
5141 -- SPARK_Mode pragmas within the instance.
5143 if SPARK_Mode
= Off
then
5144 Ignore_Pragma_SPARK_Mode
:= True;
5147 Set_Entity
(Gen_Id
, Gen_Unit
);
5148 Set_Is_Instantiated
(Gen_Unit
);
5150 if In_Extended_Main_Source_Unit
(N
) then
5151 Generate_Reference
(Gen_Unit
, N
);
5154 -- If renaming, get original unit
5156 if Present
(Renamed_Object
(Gen_Unit
))
5157 and then Ekind_In
(Renamed_Object
(Gen_Unit
), E_Generic_Procedure
,
5160 Gen_Unit
:= Renamed_Object
(Gen_Unit
);
5161 Set_Is_Instantiated
(Gen_Unit
);
5162 Generate_Reference
(Gen_Unit
, N
);
5165 if Contains_Instance_Of
(Gen_Unit
, Current_Scope
, Gen_Id
) then
5166 Error_Msg_Node_2
:= Current_Scope
;
5168 ("circular Instantiation: & instantiated in &!", N
, Gen_Unit
);
5169 Circularity_Detected
:= True;
5170 Restore_Hidden_Primitives
(Vis_Prims_List
);
5174 Gen_Decl
:= Unit_Declaration_Node
(Gen_Unit
);
5176 -- Initialize renamings map, for error checking
5178 Generic_Renamings
.Set_Last
(0);
5179 Generic_Renamings_HTable
.Reset
;
5181 Create_Instantiation_Source
(N
, Gen_Unit
, False, S_Adjustment
);
5183 -- Copy original generic tree, to produce text for instantiation
5187 (Original_Node
(Gen_Decl
), Empty
, Instantiating
=> True);
5189 -- Inherit overriding indicator from instance node
5191 Act_Spec
:= Specification
(Act_Tree
);
5192 Set_Must_Override
(Act_Spec
, Must_Override
(N
));
5193 Set_Must_Not_Override
(Act_Spec
, Must_Not_Override
(N
));
5196 Analyze_Associations
5198 Formals
=> Generic_Formal_Declarations
(Act_Tree
),
5199 F_Copy
=> Generic_Formal_Declarations
(Gen_Decl
));
5201 Vis_Prims_List
:= Check_Hidden_Primitives
(Renaming_List
);
5203 -- The subprogram itself cannot contain a nested instance, so the
5204 -- current parent is left empty.
5206 Set_Instance_Env
(Gen_Unit
, Empty
);
5208 -- Build the subprogram declaration, which does not appear in the
5209 -- generic template, and give it a sloc consistent with that of the
5212 Set_Defining_Unit_Name
(Act_Spec
, Anon_Id
);
5213 Set_Generic_Parent
(Act_Spec
, Gen_Unit
);
5215 Make_Subprogram_Declaration
(Sloc
(Act_Spec
),
5216 Specification
=> Act_Spec
);
5218 -- The aspects have been copied previously, but they have to be
5219 -- linked explicitly to the new subprogram declaration. Explicit
5220 -- pre/postconditions on the instance are analyzed below, in a
5223 Move_Aspects
(Act_Tree
, To
=> Act_Decl
);
5224 Set_Categorization_From_Pragmas
(Act_Decl
);
5226 if Parent_Installed
then
5230 Append
(Act_Decl
, Renaming_List
);
5231 Analyze_Instance_And_Renamings
;
5233 -- If the generic is marked Import (Intrinsic), then so is the
5234 -- instance. This indicates that there is no body to instantiate. If
5235 -- generic is marked inline, so it the instance, and the anonymous
5236 -- subprogram it renames. If inlined, or else if inlining is enabled
5237 -- for the compilation, we generate the instance body even if it is
5238 -- not within the main unit.
5240 if Is_Intrinsic_Subprogram
(Gen_Unit
) then
5241 Set_Is_Intrinsic_Subprogram
(Anon_Id
);
5242 Set_Is_Intrinsic_Subprogram
(Act_Decl_Id
);
5244 if Chars
(Gen_Unit
) = Name_Unchecked_Conversion
then
5245 Validate_Unchecked_Conversion
(N
, Act_Decl_Id
);
5249 -- Inherit convention from generic unit. Intrinsic convention, as for
5250 -- an instance of unchecked conversion, is not inherited because an
5251 -- explicit Ada instance has been created.
5253 if Has_Convention_Pragma
(Gen_Unit
)
5254 and then Convention
(Gen_Unit
) /= Convention_Intrinsic
5256 Set_Convention
(Act_Decl_Id
, Convention
(Gen_Unit
));
5257 Set_Is_Exported
(Act_Decl_Id
, Is_Exported
(Gen_Unit
));
5260 Generate_Definition
(Act_Decl_Id
);
5261 -- Set_Contract (Anon_Id, Make_Contract (Sloc (Anon_Id)));
5263 Set_Contract
(Act_Decl_Id
, Make_Contract
(Sloc
(Act_Decl_Id
)));
5265 -- Inherit all inlining-related flags which apply to the generic in
5266 -- the subprogram and its declaration.
5268 Set_Is_Inlined
(Act_Decl_Id
, Is_Inlined
(Gen_Unit
));
5269 Set_Is_Inlined
(Anon_Id
, Is_Inlined
(Gen_Unit
));
5271 Set_Has_Pragma_Inline
(Act_Decl_Id
, Has_Pragma_Inline
(Gen_Unit
));
5272 Set_Has_Pragma_Inline
(Anon_Id
, Has_Pragma_Inline
(Gen_Unit
));
5274 Set_Has_Pragma_Inline_Always
5275 (Act_Decl_Id
, Has_Pragma_Inline_Always
(Gen_Unit
));
5276 Set_Has_Pragma_Inline_Always
5277 (Anon_Id
, Has_Pragma_Inline_Always
(Gen_Unit
));
5279 if not Is_Intrinsic_Subprogram
(Gen_Unit
) then
5280 Check_Elab_Instantiation
(N
);
5283 if Is_Dispatching_Operation
(Act_Decl_Id
)
5284 and then Ada_Version
>= Ada_2005
5290 Formal
:= First_Formal
(Act_Decl_Id
);
5291 while Present
(Formal
) loop
5292 if Ekind
(Etype
(Formal
)) = E_Anonymous_Access_Type
5293 and then Is_Controlling_Formal
(Formal
)
5294 and then not Can_Never_Be_Null
(Formal
)
5296 Error_Msg_NE
("access parameter& is controlling,",
5299 ("\corresponding parameter of & must be"
5300 & " explicitly null-excluding", N
, Gen_Id
);
5303 Next_Formal
(Formal
);
5308 Check_Hidden_Child_Unit
(N
, Gen_Unit
, Act_Decl_Id
);
5310 Validate_Categorization_Dependency
(N
, Act_Decl_Id
);
5312 if not Is_Intrinsic_Subprogram
(Act_Decl_Id
) then
5313 Inherit_Context
(Gen_Decl
, N
);
5315 Restore_Private_Views
(Pack_Id
, False);
5317 -- If the context requires a full instantiation, mark node for
5318 -- subsequent construction of the body.
5320 if Need_Subprogram_Instance_Body
(N
, Act_Decl_Id
) then
5321 Check_Forward_Instantiation
(Gen_Decl
);
5323 -- The wrapper package is always delayed, because it does not
5324 -- constitute a freeze point, but to insure that the freeze
5325 -- node is placed properly, it is created directly when
5326 -- instantiating the body (otherwise the freeze node might
5327 -- appear to early for nested instantiations).
5329 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
then
5331 -- For ASIS purposes, indicate that the wrapper package has
5332 -- replaced the instantiation node.
5334 Rewrite
(N
, Unit
(Parent
(N
)));
5335 Set_Unit
(Parent
(N
), N
);
5338 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
then
5340 -- Replace instance node for library-level instantiations of
5341 -- intrinsic subprograms, for ASIS use.
5343 Rewrite
(N
, Unit
(Parent
(N
)));
5344 Set_Unit
(Parent
(N
), N
);
5347 if Parent_Installed
then
5351 Restore_Hidden_Primitives
(Vis_Prims_List
);
5353 Env_Installed
:= False;
5354 Generic_Renamings
.Set_Last
(0);
5355 Generic_Renamings_HTable
.Reset
;
5357 Ignore_Pragma_SPARK_Mode
:= Save_IPSM
;
5358 SPARK_Mode
:= Save_SM
;
5359 SPARK_Mode_Pragma
:= Save_SMP
;
5361 if SPARK_Mode
= On
then
5362 Dynamic_Elaboration_Checks
:= False;
5368 if Has_Aspects
(N
) then
5369 Analyze_Aspect_Specifications
(N
, Act_Decl_Id
);
5373 when Instantiation_Error
=>
5374 if Parent_Installed
then
5378 if Env_Installed
then
5382 Ignore_Pragma_SPARK_Mode
:= Save_IPSM
;
5383 SPARK_Mode
:= Save_SM
;
5384 SPARK_Mode_Pragma
:= Save_SMP
;
5386 if SPARK_Mode
= On
then
5387 Dynamic_Elaboration_Checks
:= False;
5389 end Analyze_Subprogram_Instantiation
;
5391 -------------------------
5392 -- Get_Associated_Node --
5393 -------------------------
5395 function Get_Associated_Node
(N
: Node_Id
) return Node_Id
is
5399 Assoc
:= Associated_Node
(N
);
5401 if Nkind
(Assoc
) /= Nkind
(N
) then
5404 elsif Nkind_In
(Assoc
, N_Aggregate
, N_Extension_Aggregate
) then
5408 -- If the node is part of an inner generic, it may itself have been
5409 -- remapped into a further generic copy. Associated_Node is otherwise
5410 -- used for the entity of the node, and will be of a different node
5411 -- kind, or else N has been rewritten as a literal or function call.
5413 while Present
(Associated_Node
(Assoc
))
5414 and then Nkind
(Associated_Node
(Assoc
)) = Nkind
(Assoc
)
5416 Assoc
:= Associated_Node
(Assoc
);
5419 -- Follow and additional link in case the final node was rewritten.
5420 -- This can only happen with nested generic units.
5422 if (Nkind
(Assoc
) = N_Identifier
or else Nkind
(Assoc
) in N_Op
)
5423 and then Present
(Associated_Node
(Assoc
))
5424 and then (Nkind_In
(Associated_Node
(Assoc
), N_Function_Call
,
5425 N_Explicit_Dereference
,
5430 Assoc
:= Associated_Node
(Assoc
);
5433 -- An additional special case: an unconstrained type in an object
5434 -- declaration may have been rewritten as a local subtype constrained
5435 -- by the expression in the declaration. We need to recover the
5436 -- original entity which may be global.
5438 if Present
(Original_Node
(Assoc
))
5439 and then Nkind
(Parent
(N
)) = N_Object_Declaration
5441 Assoc
:= Original_Node
(Assoc
);
5446 end Get_Associated_Node
;
5448 -------------------------------------------
5449 -- Build_Instance_Compilation_Unit_Nodes --
5450 -------------------------------------------
5452 procedure Build_Instance_Compilation_Unit_Nodes
5457 Decl_Cunit
: Node_Id
;
5458 Body_Cunit
: Node_Id
;
5460 New_Main
: constant Entity_Id
:= Defining_Entity
(Act_Decl
);
5461 Old_Main
: constant Entity_Id
:= Cunit_Entity
(Main_Unit
);
5464 -- A new compilation unit node is built for the instance declaration
5467 Make_Compilation_Unit
(Sloc
(N
),
5468 Context_Items
=> Empty_List
,
5470 Aux_Decls_Node
=> Make_Compilation_Unit_Aux
(Sloc
(N
)));
5472 Set_Parent_Spec
(Act_Decl
, Parent_Spec
(N
));
5474 -- The new compilation unit is linked to its body, but both share the
5475 -- same file, so we do not set Body_Required on the new unit so as not
5476 -- to create a spurious dependency on a non-existent body in the ali.
5477 -- This simplifies CodePeer unit traversal.
5479 -- We use the original instantiation compilation unit as the resulting
5480 -- compilation unit of the instance, since this is the main unit.
5482 Rewrite
(N
, Act_Body
);
5484 -- Propagate the aspect specifications from the package body template to
5485 -- the instantiated version of the package body.
5487 if Has_Aspects
(Act_Body
) then
5488 Set_Aspect_Specifications
5489 (N
, New_Copy_List_Tree
(Aspect_Specifications
(Act_Body
)));
5492 Body_Cunit
:= Parent
(N
);
5494 -- The two compilation unit nodes are linked by the Library_Unit field
5496 Set_Library_Unit
(Decl_Cunit
, Body_Cunit
);
5497 Set_Library_Unit
(Body_Cunit
, Decl_Cunit
);
5499 -- Preserve the private nature of the package if needed
5501 Set_Private_Present
(Decl_Cunit
, Private_Present
(Body_Cunit
));
5503 -- If the instance is not the main unit, its context, categorization
5504 -- and elaboration entity are not relevant to the compilation.
5506 if Body_Cunit
/= Cunit
(Main_Unit
) then
5507 Make_Instance_Unit
(Body_Cunit
, In_Main
=> False);
5511 -- The context clause items on the instantiation, which are now attached
5512 -- to the body compilation unit (since the body overwrote the original
5513 -- instantiation node), semantically belong on the spec, so copy them
5514 -- there. It's harmless to leave them on the body as well. In fact one
5515 -- could argue that they belong in both places.
5517 Citem
:= First
(Context_Items
(Body_Cunit
));
5518 while Present
(Citem
) loop
5519 Append
(New_Copy
(Citem
), Context_Items
(Decl_Cunit
));
5523 -- Propagate categorization flags on packages, so that they appear in
5524 -- the ali file for the spec of the unit.
5526 if Ekind
(New_Main
) = E_Package
then
5527 Set_Is_Pure
(Old_Main
, Is_Pure
(New_Main
));
5528 Set_Is_Preelaborated
(Old_Main
, Is_Preelaborated
(New_Main
));
5529 Set_Is_Remote_Types
(Old_Main
, Is_Remote_Types
(New_Main
));
5530 Set_Is_Shared_Passive
(Old_Main
, Is_Shared_Passive
(New_Main
));
5531 Set_Is_Remote_Call_Interface
5532 (Old_Main
, Is_Remote_Call_Interface
(New_Main
));
5535 -- Make entry in Units table, so that binder can generate call to
5536 -- elaboration procedure for body, if any.
5538 Make_Instance_Unit
(Body_Cunit
, In_Main
=> True);
5539 Main_Unit_Entity
:= New_Main
;
5540 Set_Cunit_Entity
(Main_Unit
, Main_Unit_Entity
);
5542 -- Build elaboration entity, since the instance may certainly generate
5543 -- elaboration code requiring a flag for protection.
5545 Build_Elaboration_Entity
(Decl_Cunit
, New_Main
);
5546 end Build_Instance_Compilation_Unit_Nodes
;
5548 -----------------------------
5549 -- Check_Access_Definition --
5550 -----------------------------
5552 procedure Check_Access_Definition
(N
: Node_Id
) is
5555 (Ada_Version
>= Ada_2005
and then Present
(Access_Definition
(N
)));
5557 end Check_Access_Definition
;
5559 -----------------------------------
5560 -- Check_Formal_Package_Instance --
5561 -----------------------------------
5563 -- If the formal has specific parameters, they must match those of the
5564 -- actual. Both of them are instances, and the renaming declarations for
5565 -- their formal parameters appear in the same order in both. The analyzed
5566 -- formal has been analyzed in the context of the current instance.
5568 procedure Check_Formal_Package_Instance
5569 (Formal_Pack
: Entity_Id
;
5570 Actual_Pack
: Entity_Id
)
5572 E1
: Entity_Id
:= First_Entity
(Actual_Pack
);
5573 E2
: Entity_Id
:= First_Entity
(Formal_Pack
);
5578 procedure Check_Mismatch
(B
: Boolean);
5579 -- Common error routine for mismatch between the parameters of the
5580 -- actual instance and those of the formal package.
5582 function Same_Instantiated_Constant
(E1
, E2
: Entity_Id
) return Boolean;
5583 -- The formal may come from a nested formal package, and the actual may
5584 -- have been constant-folded. To determine whether the two denote the
5585 -- same entity we may have to traverse several definitions to recover
5586 -- the ultimate entity that they refer to.
5588 function Same_Instantiated_Variable
(E1
, E2
: Entity_Id
) return Boolean;
5589 -- Similarly, if the formal comes from a nested formal package, the
5590 -- actual may designate the formal through multiple renamings, which
5591 -- have to be followed to determine the original variable in question.
5593 --------------------
5594 -- Check_Mismatch --
5595 --------------------
5597 procedure Check_Mismatch
(B
: Boolean) is
5598 Kind
: constant Node_Kind
:= Nkind
(Parent
(E2
));
5601 if Kind
= N_Formal_Type_Declaration
then
5604 elsif Nkind_In
(Kind
, N_Formal_Object_Declaration
,
5605 N_Formal_Package_Declaration
)
5606 or else Kind
in N_Formal_Subprogram_Declaration
5612 ("actual for & in actual instance does not match formal",
5613 Parent
(Actual_Pack
), E1
);
5617 --------------------------------
5618 -- Same_Instantiated_Constant --
5619 --------------------------------
5621 function Same_Instantiated_Constant
5622 (E1
, E2
: Entity_Id
) return Boolean
5628 while Present
(Ent
) loop
5632 elsif Ekind
(Ent
) /= E_Constant
then
5635 elsif Is_Entity_Name
(Constant_Value
(Ent
)) then
5636 if Entity
(Constant_Value
(Ent
)) = E1
then
5639 Ent
:= Entity
(Constant_Value
(Ent
));
5642 -- The actual may be a constant that has been folded. Recover
5645 elsif Is_Entity_Name
(Original_Node
(Constant_Value
(Ent
))) then
5646 Ent
:= Entity
(Original_Node
(Constant_Value
(Ent
)));
5653 end Same_Instantiated_Constant
;
5655 --------------------------------
5656 -- Same_Instantiated_Variable --
5657 --------------------------------
5659 function Same_Instantiated_Variable
5660 (E1
, E2
: Entity_Id
) return Boolean
5662 function Original_Entity
(E
: Entity_Id
) return Entity_Id
;
5663 -- Follow chain of renamings to the ultimate ancestor
5665 ---------------------
5666 -- Original_Entity --
5667 ---------------------
5669 function Original_Entity
(E
: Entity_Id
) return Entity_Id
is
5674 while Nkind
(Parent
(Orig
)) = N_Object_Renaming_Declaration
5675 and then Present
(Renamed_Object
(Orig
))
5676 and then Is_Entity_Name
(Renamed_Object
(Orig
))
5678 Orig
:= Entity
(Renamed_Object
(Orig
));
5682 end Original_Entity
;
5684 -- Start of processing for Same_Instantiated_Variable
5687 return Ekind
(E1
) = Ekind
(E2
)
5688 and then Original_Entity
(E1
) = Original_Entity
(E2
);
5689 end Same_Instantiated_Variable
;
5691 -- Start of processing for Check_Formal_Package_Instance
5695 and then Present
(E2
)
5697 exit when Ekind
(E1
) = E_Package
5698 and then Renamed_Entity
(E1
) = Renamed_Entity
(Actual_Pack
);
5700 -- If the formal is the renaming of the formal package, this
5701 -- is the end of its formal part, which may occur before the
5702 -- end of the formal part in the actual in the presence of
5703 -- defaulted parameters in the formal package.
5705 exit when Nkind
(Parent
(E2
)) = N_Package_Renaming_Declaration
5706 and then Renamed_Entity
(E2
) = Scope
(E2
);
5708 -- The analysis of the actual may generate additional internal
5709 -- entities. If the formal is defaulted, there is no corresponding
5710 -- analysis and the internal entities must be skipped, until we
5711 -- find corresponding entities again.
5713 if Comes_From_Source
(E2
)
5714 and then not Comes_From_Source
(E1
)
5715 and then Chars
(E1
) /= Chars
(E2
)
5718 and then Chars
(E1
) /= Chars
(E2
)
5727 -- If the formal entity comes from a formal declaration, it was
5728 -- defaulted in the formal package, and no check is needed on it.
5730 elsif Nkind
(Parent
(E2
)) = N_Formal_Object_Declaration
then
5733 -- Ditto for defaulted formal subprograms.
5735 elsif Is_Overloadable
(E1
)
5736 and then Nkind
(Unit_Declaration_Node
(E2
)) in
5737 N_Formal_Subprogram_Declaration
5741 elsif Is_Type
(E1
) then
5743 -- Subtypes must statically match. E1, E2 are the local entities
5744 -- that are subtypes of the actuals. Itypes generated for other
5745 -- parameters need not be checked, the check will be performed
5746 -- on the parameters themselves.
5748 -- If E2 is a formal type declaration, it is a defaulted parameter
5749 -- and needs no checking.
5751 if not Is_Itype
(E1
)
5752 and then not Is_Itype
(E2
)
5756 or else Etype
(E1
) /= Etype
(E2
)
5757 or else not Subtypes_Statically_Match
(E1
, E2
));
5760 elsif Ekind
(E1
) = E_Constant
then
5762 -- IN parameters must denote the same static value, or the same
5763 -- constant, or the literal null.
5765 Expr1
:= Expression
(Parent
(E1
));
5767 if Ekind
(E2
) /= E_Constant
then
5768 Check_Mismatch
(True);
5771 Expr2
:= Expression
(Parent
(E2
));
5774 if Is_OK_Static_Expression
(Expr1
) then
5775 if not Is_OK_Static_Expression
(Expr2
) then
5776 Check_Mismatch
(True);
5778 elsif Is_Discrete_Type
(Etype
(E1
)) then
5780 V1
: constant Uint
:= Expr_Value
(Expr1
);
5781 V2
: constant Uint
:= Expr_Value
(Expr2
);
5783 Check_Mismatch
(V1
/= V2
);
5786 elsif Is_Real_Type
(Etype
(E1
)) then
5788 V1
: constant Ureal
:= Expr_Value_R
(Expr1
);
5789 V2
: constant Ureal
:= Expr_Value_R
(Expr2
);
5791 Check_Mismatch
(V1
/= V2
);
5794 elsif Is_String_Type
(Etype
(E1
))
5795 and then Nkind
(Expr1
) = N_String_Literal
5797 if Nkind
(Expr2
) /= N_String_Literal
then
5798 Check_Mismatch
(True);
5801 (not String_Equal
(Strval
(Expr1
), Strval
(Expr2
)));
5805 elsif Is_Entity_Name
(Expr1
) then
5806 if Is_Entity_Name
(Expr2
) then
5807 if Entity
(Expr1
) = Entity
(Expr2
) then
5811 (not Same_Instantiated_Constant
5812 (Entity
(Expr1
), Entity
(Expr2
)));
5815 Check_Mismatch
(True);
5818 elsif Is_Entity_Name
(Original_Node
(Expr1
))
5819 and then Is_Entity_Name
(Expr2
)
5821 Same_Instantiated_Constant
5822 (Entity
(Original_Node
(Expr1
)), Entity
(Expr2
))
5826 elsif Nkind
(Expr1
) = N_Null
then
5827 Check_Mismatch
(Nkind
(Expr1
) /= N_Null
);
5830 Check_Mismatch
(True);
5833 elsif Ekind
(E1
) = E_Variable
then
5834 Check_Mismatch
(not Same_Instantiated_Variable
(E1
, E2
));
5836 elsif Ekind
(E1
) = E_Package
then
5838 (Ekind
(E1
) /= Ekind
(E2
)
5839 or else Renamed_Object
(E1
) /= Renamed_Object
(E2
));
5841 elsif Is_Overloadable
(E1
) then
5843 -- Verify that the actual subprograms match. Note that actuals
5844 -- that are attributes are rewritten as subprograms. If the
5845 -- subprogram in the formal package is defaulted, no check is
5846 -- needed. Note that this can only happen in Ada 2005 when the
5847 -- formal package can be partially parameterized.
5849 if Nkind
(Unit_Declaration_Node
(E1
)) =
5850 N_Subprogram_Renaming_Declaration
5851 and then From_Default
(Unit_Declaration_Node
(E1
))
5855 -- If the formal package has an "others" box association that
5856 -- covers this formal, there is no need for a check either.
5858 elsif Nkind
(Unit_Declaration_Node
(E2
)) in
5859 N_Formal_Subprogram_Declaration
5860 and then Box_Present
(Unit_Declaration_Node
(E2
))
5864 -- No check needed if subprogram is a defaulted null procedure
5866 elsif No
(Alias
(E2
))
5867 and then Ekind
(E2
) = E_Procedure
5869 Null_Present
(Specification
(Unit_Declaration_Node
(E2
)))
5873 -- Otherwise the actual in the formal and the actual in the
5874 -- instantiation of the formal must match, up to renamings.
5878 (Ekind
(E2
) /= Ekind
(E1
) or else (Alias
(E1
)) /= Alias
(E2
));
5882 raise Program_Error
;
5889 end Check_Formal_Package_Instance
;
5891 ---------------------------
5892 -- Check_Formal_Packages --
5893 ---------------------------
5895 procedure Check_Formal_Packages
(P_Id
: Entity_Id
) is
5897 Formal_P
: Entity_Id
;
5900 -- Iterate through the declarations in the instance, looking for package
5901 -- renaming declarations that denote instances of formal packages. Stop
5902 -- when we find the renaming of the current package itself. The
5903 -- declaration for a formal package without a box is followed by an
5904 -- internal entity that repeats the instantiation.
5906 E
:= First_Entity
(P_Id
);
5907 while Present
(E
) loop
5908 if Ekind
(E
) = E_Package
then
5909 if Renamed_Object
(E
) = P_Id
then
5912 elsif Nkind
(Parent
(E
)) /= N_Package_Renaming_Declaration
then
5915 elsif not Box_Present
(Parent
(Associated_Formal_Package
(E
))) then
5916 Formal_P
:= Next_Entity
(E
);
5917 Check_Formal_Package_Instance
(Formal_P
, E
);
5919 -- After checking, remove the internal validating package. It
5920 -- is only needed for semantic checks, and as it may contain
5921 -- generic formal declarations it should not reach gigi.
5923 Remove
(Unit_Declaration_Node
(Formal_P
));
5929 end Check_Formal_Packages
;
5931 ---------------------------------
5932 -- Check_Forward_Instantiation --
5933 ---------------------------------
5935 procedure Check_Forward_Instantiation
(Decl
: Node_Id
) is
5937 Gen_Comp
: Entity_Id
:= Cunit_Entity
(Get_Source_Unit
(Decl
));
5940 -- The instantiation appears before the generic body if we are in the
5941 -- scope of the unit containing the generic, either in its spec or in
5942 -- the package body, and before the generic body.
5944 if Ekind
(Gen_Comp
) = E_Package_Body
then
5945 Gen_Comp
:= Spec_Entity
(Gen_Comp
);
5948 if In_Open_Scopes
(Gen_Comp
)
5949 and then No
(Corresponding_Body
(Decl
))
5954 and then not Is_Compilation_Unit
(S
)
5955 and then not Is_Child_Unit
(S
)
5957 if Ekind
(S
) = E_Package
then
5958 Set_Has_Forward_Instantiation
(S
);
5964 end Check_Forward_Instantiation
;
5966 ---------------------------
5967 -- Check_Generic_Actuals --
5968 ---------------------------
5970 -- The visibility of the actuals may be different between the point of
5971 -- generic instantiation and the instantiation of the body.
5973 procedure Check_Generic_Actuals
5974 (Instance
: Entity_Id
;
5975 Is_Formal_Box
: Boolean)
5980 function Denotes_Previous_Actual
(Typ
: Entity_Id
) return Boolean;
5981 -- For a formal that is an array type, the component type is often a
5982 -- previous formal in the same unit. The privacy status of the component
5983 -- type will have been examined earlier in the traversal of the
5984 -- corresponding actuals, and this status should not be modified for
5985 -- the array (sub)type itself. However, if the base type of the array
5986 -- (sub)type is private, its full view must be restored in the body to
5987 -- be consistent with subsequent index subtypes, etc.
5989 -- To detect this case we have to rescan the list of formals, which is
5990 -- usually short enough to ignore the resulting inefficiency.
5992 -----------------------------
5993 -- Denotes_Previous_Actual --
5994 -----------------------------
5996 function Denotes_Previous_Actual
(Typ
: Entity_Id
) return Boolean is
6000 Prev
:= First_Entity
(Instance
);
6001 while Present
(Prev
) loop
6003 and then Nkind
(Parent
(Prev
)) = N_Subtype_Declaration
6004 and then Is_Entity_Name
(Subtype_Indication
(Parent
(Prev
)))
6005 and then Entity
(Subtype_Indication
(Parent
(Prev
))) = Typ
6018 end Denotes_Previous_Actual
;
6020 -- Start of processing for Check_Generic_Actuals
6023 E
:= First_Entity
(Instance
);
6024 while Present
(E
) loop
6026 and then Nkind
(Parent
(E
)) = N_Subtype_Declaration
6027 and then Scope
(Etype
(E
)) /= Instance
6028 and then Is_Entity_Name
(Subtype_Indication
(Parent
(E
)))
6030 if Is_Array_Type
(E
)
6031 and then not Is_Private_Type
(Etype
(E
))
6032 and then Denotes_Previous_Actual
(Component_Type
(E
))
6036 Check_Private_View
(Subtype_Indication
(Parent
(E
)));
6039 Set_Is_Generic_Actual_Type
(E
, True);
6040 Set_Is_Hidden
(E
, False);
6041 Set_Is_Potentially_Use_Visible
(E
,
6044 -- We constructed the generic actual type as a subtype of the
6045 -- supplied type. This means that it normally would not inherit
6046 -- subtype specific attributes of the actual, which is wrong for
6047 -- the generic case.
6049 Astype
:= Ancestor_Subtype
(E
);
6053 -- This can happen when E is an itype that is the full view of
6054 -- a private type completed, e.g. with a constrained array. In
6055 -- that case, use the first subtype, which will carry size
6056 -- information. The base type itself is unconstrained and will
6059 Astype
:= First_Subtype
(E
);
6062 Set_Size_Info
(E
, (Astype
));
6063 Set_RM_Size
(E
, RM_Size
(Astype
));
6064 Set_First_Rep_Item
(E
, First_Rep_Item
(Astype
));
6066 if Is_Discrete_Or_Fixed_Point_Type
(E
) then
6067 Set_RM_Size
(E
, RM_Size
(Astype
));
6069 -- In nested instances, the base type of an access actual may
6070 -- itself be private, and need to be exchanged.
6072 elsif Is_Access_Type
(E
)
6073 and then Is_Private_Type
(Etype
(E
))
6076 (New_Occurrence_Of
(Etype
(E
), Sloc
(Instance
)));
6079 elsif Ekind
(E
) = E_Package
then
6081 -- If this is the renaming for the current instance, we're done.
6082 -- Otherwise it is a formal package. If the corresponding formal
6083 -- was declared with a box, the (instantiations of the) generic
6084 -- formal part are also visible. Otherwise, ignore the entity
6085 -- created to validate the actuals.
6087 if Renamed_Object
(E
) = Instance
then
6090 elsif Nkind
(Parent
(E
)) /= N_Package_Renaming_Declaration
then
6093 -- The visibility of a formal of an enclosing generic is already
6096 elsif Denotes_Formal_Package
(E
) then
6099 elsif Present
(Associated_Formal_Package
(E
))
6100 and then not Is_Generic_Formal
(E
)
6102 if Box_Present
(Parent
(Associated_Formal_Package
(E
))) then
6103 Check_Generic_Actuals
(Renamed_Object
(E
), True);
6106 Check_Generic_Actuals
(Renamed_Object
(E
), False);
6109 Set_Is_Hidden
(E
, False);
6112 -- If this is a subprogram instance (in a wrapper package) the
6113 -- actual is fully visible.
6115 elsif Is_Wrapper_Package
(Instance
) then
6116 Set_Is_Hidden
(E
, False);
6118 -- If the formal package is declared with a box, or if the formal
6119 -- parameter is defaulted, it is visible in the body.
6121 elsif Is_Formal_Box
or else Is_Visible_Formal
(E
) then
6122 Set_Is_Hidden
(E
, False);
6125 if Ekind
(E
) = E_Constant
then
6127 -- If the type of the actual is a private type declared in the
6128 -- enclosing scope of the generic unit, the body of the generic
6129 -- sees the full view of the type (because it has to appear in
6130 -- the corresponding package body). If the type is private now,
6131 -- exchange views to restore the proper visiblity in the instance.
6134 Typ
: constant Entity_Id
:= Base_Type
(Etype
(E
));
6135 -- The type of the actual
6140 Parent_Scope
: Entity_Id
;
6141 -- The enclosing scope of the generic unit
6144 if Is_Wrapper_Package
(Instance
) then
6148 (Unit_Declaration_Node
6149 (Related_Instance
(Instance
))));
6152 Generic_Parent
(Package_Specification
(Instance
));
6155 Parent_Scope
:= Scope
(Gen_Id
);
6157 -- The exchange is only needed if the generic is defined
6158 -- within a package which is not a common ancestor of the
6159 -- scope of the instance, and is not already in scope.
6161 if Is_Private_Type
(Typ
)
6162 and then Scope
(Typ
) = Parent_Scope
6163 and then Scope
(Instance
) /= Parent_Scope
6164 and then Ekind
(Parent_Scope
) = E_Package
6165 and then not Is_Child_Unit
(Gen_Id
)
6169 -- If the type of the entity is a subtype, it may also have
6170 -- to be made visible, together with the base type of its
6171 -- full view, after exchange.
6173 if Is_Private_Type
(Etype
(E
)) then
6174 Switch_View
(Etype
(E
));
6175 Switch_View
(Base_Type
(Etype
(E
)));
6183 end Check_Generic_Actuals
;
6185 ------------------------------
6186 -- Check_Generic_Child_Unit --
6187 ------------------------------
6189 procedure Check_Generic_Child_Unit
6191 Parent_Installed
: in out Boolean)
6193 Loc
: constant Source_Ptr
:= Sloc
(Gen_Id
);
6194 Gen_Par
: Entity_Id
:= Empty
;
6196 Inst_Par
: Entity_Id
;
6199 function Find_Generic_Child
6201 Id
: Node_Id
) return Entity_Id
;
6202 -- Search generic parent for possible child unit with the given name
6204 function In_Enclosing_Instance
return Boolean;
6205 -- Within an instance of the parent, the child unit may be denoted by
6206 -- a simple name, or an abbreviated expanded name. Examine enclosing
6207 -- scopes to locate a possible parent instantiation.
6209 ------------------------
6210 -- Find_Generic_Child --
6211 ------------------------
6213 function Find_Generic_Child
6215 Id
: Node_Id
) return Entity_Id
6220 -- If entity of name is already set, instance has already been
6221 -- resolved, e.g. in an enclosing instantiation.
6223 if Present
(Entity
(Id
)) then
6224 if Scope
(Entity
(Id
)) = Scop
then
6231 E
:= First_Entity
(Scop
);
6232 while Present
(E
) loop
6233 if Chars
(E
) = Chars
(Id
)
6234 and then Is_Child_Unit
(E
)
6236 if Is_Child_Unit
(E
)
6237 and then not Is_Visible_Lib_Unit
(E
)
6240 ("generic child unit& is not visible", Gen_Id
, E
);
6252 end Find_Generic_Child
;
6254 ---------------------------
6255 -- In_Enclosing_Instance --
6256 ---------------------------
6258 function In_Enclosing_Instance
return Boolean is
6259 Enclosing_Instance
: Node_Id
;
6260 Instance_Decl
: Node_Id
;
6263 -- We do not inline any call that contains instantiations, except
6264 -- for instantiations of Unchecked_Conversion, so if we are within
6265 -- an inlined body the current instance does not require parents.
6267 if In_Inlined_Body
then
6268 pragma Assert
(Chars
(Gen_Id
) = Name_Unchecked_Conversion
);
6272 -- Loop to check enclosing scopes
6274 Enclosing_Instance
:= Current_Scope
;
6275 while Present
(Enclosing_Instance
) loop
6276 Instance_Decl
:= Unit_Declaration_Node
(Enclosing_Instance
);
6278 if Ekind
(Enclosing_Instance
) = E_Package
6279 and then Is_Generic_Instance
(Enclosing_Instance
)
6281 (Generic_Parent
(Specification
(Instance_Decl
)))
6283 -- Check whether the generic we are looking for is a child of
6286 E
:= Find_Generic_Child
6287 (Generic_Parent
(Specification
(Instance_Decl
)), Gen_Id
);
6288 exit when Present
(E
);
6294 Enclosing_Instance
:= Scope
(Enclosing_Instance
);
6306 Make_Expanded_Name
(Loc
,
6308 Prefix
=> New_Occurrence_Of
(Enclosing_Instance
, Loc
),
6309 Selector_Name
=> New_Occurrence_Of
(E
, Loc
)));
6311 Set_Entity
(Gen_Id
, E
);
6312 Set_Etype
(Gen_Id
, Etype
(E
));
6313 Parent_Installed
:= False; -- Already in scope.
6316 end In_Enclosing_Instance
;
6318 -- Start of processing for Check_Generic_Child_Unit
6321 -- If the name of the generic is given by a selected component, it may
6322 -- be the name of a generic child unit, and the prefix is the name of an
6323 -- instance of the parent, in which case the child unit must be visible.
6324 -- If this instance is not in scope, it must be placed there and removed
6325 -- after instantiation, because what is being instantiated is not the
6326 -- original child, but the corresponding child present in the instance
6329 -- If the child is instantiated within the parent, it can be given by
6330 -- a simple name. In this case the instance is already in scope, but
6331 -- the child generic must be recovered from the generic parent as well.
6333 if Nkind
(Gen_Id
) = N_Selected_Component
then
6334 S
:= Selector_Name
(Gen_Id
);
6335 Analyze
(Prefix
(Gen_Id
));
6336 Inst_Par
:= Entity
(Prefix
(Gen_Id
));
6338 if Ekind
(Inst_Par
) = E_Package
6339 and then Present
(Renamed_Object
(Inst_Par
))
6341 Inst_Par
:= Renamed_Object
(Inst_Par
);
6344 if Ekind
(Inst_Par
) = E_Package
then
6345 if Nkind
(Parent
(Inst_Par
)) = N_Package_Specification
then
6346 Gen_Par
:= Generic_Parent
(Parent
(Inst_Par
));
6348 elsif Nkind
(Parent
(Inst_Par
)) = N_Defining_Program_Unit_Name
6350 Nkind
(Parent
(Parent
(Inst_Par
))) = N_Package_Specification
6352 Gen_Par
:= Generic_Parent
(Parent
(Parent
(Inst_Par
)));
6355 elsif Ekind
(Inst_Par
) = E_Generic_Package
6356 and then Nkind
(Parent
(Gen_Id
)) = N_Formal_Package_Declaration
6358 -- A formal package may be a real child package, and not the
6359 -- implicit instance within a parent. In this case the child is
6360 -- not visible and has to be retrieved explicitly as well.
6362 Gen_Par
:= Inst_Par
;
6365 if Present
(Gen_Par
) then
6367 -- The prefix denotes an instantiation. The entity itself may be a
6368 -- nested generic, or a child unit.
6370 E
:= Find_Generic_Child
(Gen_Par
, S
);
6373 Change_Selected_Component_To_Expanded_Name
(Gen_Id
);
6374 Set_Entity
(Gen_Id
, E
);
6375 Set_Etype
(Gen_Id
, Etype
(E
));
6377 Set_Etype
(S
, Etype
(E
));
6379 -- Indicate that this is a reference to the parent
6381 if In_Extended_Main_Source_Unit
(Gen_Id
) then
6382 Set_Is_Instantiated
(Inst_Par
);
6385 -- A common mistake is to replicate the naming scheme of a
6386 -- hierarchy by instantiating a generic child directly, rather
6387 -- than the implicit child in a parent instance:
6389 -- generic .. package Gpar is ..
6390 -- generic .. package Gpar.Child is ..
6391 -- package Par is new Gpar ();
6394 -- package Par.Child is new Gpar.Child ();
6395 -- rather than Par.Child
6397 -- In this case the instantiation is within Par, which is an
6398 -- instance, but Gpar does not denote Par because we are not IN
6399 -- the instance of Gpar, so this is illegal. The test below
6400 -- recognizes this particular case.
6402 if Is_Child_Unit
(E
)
6403 and then not Comes_From_Source
(Entity
(Prefix
(Gen_Id
)))
6404 and then (not In_Instance
6405 or else Nkind
(Parent
(Parent
(Gen_Id
))) =
6409 ("prefix of generic child unit must be instance of parent",
6413 if not In_Open_Scopes
(Inst_Par
)
6414 and then Nkind
(Parent
(Gen_Id
)) not in
6415 N_Generic_Renaming_Declaration
6417 Install_Parent
(Inst_Par
);
6418 Parent_Installed
:= True;
6420 elsif In_Open_Scopes
(Inst_Par
) then
6422 -- If the parent is already installed, install the actuals
6423 -- for its formal packages. This is necessary when the child
6424 -- instance is a child of the parent instance: in this case,
6425 -- the parent is placed on the scope stack but the formal
6426 -- packages are not made visible.
6428 Install_Formal_Packages
(Inst_Par
);
6432 -- If the generic parent does not contain an entity that
6433 -- corresponds to the selector, the instance doesn't either.
6434 -- Analyzing the node will yield the appropriate error message.
6435 -- If the entity is not a child unit, then it is an inner
6436 -- generic in the parent.
6444 if Is_Child_Unit
(Entity
(Gen_Id
))
6446 Nkind
(Parent
(Gen_Id
)) not in N_Generic_Renaming_Declaration
6447 and then not In_Open_Scopes
(Inst_Par
)
6449 Install_Parent
(Inst_Par
);
6450 Parent_Installed
:= True;
6452 -- The generic unit may be the renaming of the implicit child
6453 -- present in an instance. In that case the parent instance is
6454 -- obtained from the name of the renamed entity.
6456 elsif Ekind
(Entity
(Gen_Id
)) = E_Generic_Package
6457 and then Present
(Renamed_Entity
(Entity
(Gen_Id
)))
6458 and then Is_Child_Unit
(Renamed_Entity
(Entity
(Gen_Id
)))
6461 Renamed_Package
: constant Node_Id
:=
6462 Name
(Parent
(Entity
(Gen_Id
)));
6464 if Nkind
(Renamed_Package
) = N_Expanded_Name
then
6465 Inst_Par
:= Entity
(Prefix
(Renamed_Package
));
6466 Install_Parent
(Inst_Par
);
6467 Parent_Installed
:= True;
6473 elsif Nkind
(Gen_Id
) = N_Expanded_Name
then
6475 -- Entity already present, analyze prefix, whose meaning may be
6476 -- an instance in the current context. If it is an instance of
6477 -- a relative within another, the proper parent may still have
6478 -- to be installed, if they are not of the same generation.
6480 Analyze
(Prefix
(Gen_Id
));
6482 -- In the unlikely case that a local declaration hides the name
6483 -- of the parent package, locate it on the homonym chain. If the
6484 -- context is an instance of the parent, the renaming entity is
6487 Inst_Par
:= Entity
(Prefix
(Gen_Id
));
6488 while Present
(Inst_Par
)
6489 and then not Is_Package_Or_Generic_Package
(Inst_Par
)
6491 Inst_Par
:= Homonym
(Inst_Par
);
6494 pragma Assert
(Present
(Inst_Par
));
6495 Set_Entity
(Prefix
(Gen_Id
), Inst_Par
);
6497 if In_Enclosing_Instance
then
6500 elsif Present
(Entity
(Gen_Id
))
6501 and then Is_Child_Unit
(Entity
(Gen_Id
))
6502 and then not In_Open_Scopes
(Inst_Par
)
6504 Install_Parent
(Inst_Par
);
6505 Parent_Installed
:= True;
6508 elsif In_Enclosing_Instance
then
6510 -- The child unit is found in some enclosing scope
6517 -- If this is the renaming of the implicit child in a parent
6518 -- instance, recover the parent name and install it.
6520 if Is_Entity_Name
(Gen_Id
) then
6521 E
:= Entity
(Gen_Id
);
6523 if Is_Generic_Unit
(E
)
6524 and then Nkind
(Parent
(E
)) in N_Generic_Renaming_Declaration
6525 and then Is_Child_Unit
(Renamed_Object
(E
))
6526 and then Is_Generic_Unit
(Scope
(Renamed_Object
(E
)))
6527 and then Nkind
(Name
(Parent
(E
))) = N_Expanded_Name
6530 New_Copy_Tree
(Name
(Parent
(E
))));
6531 Inst_Par
:= Entity
(Prefix
(Gen_Id
));
6533 if not In_Open_Scopes
(Inst_Par
) then
6534 Install_Parent
(Inst_Par
);
6535 Parent_Installed
:= True;
6538 -- If it is a child unit of a non-generic parent, it may be
6539 -- use-visible and given by a direct name. Install parent as
6542 elsif Is_Generic_Unit
(E
)
6543 and then Is_Child_Unit
(E
)
6545 Nkind
(Parent
(Gen_Id
)) not in N_Generic_Renaming_Declaration
6546 and then not Is_Generic_Unit
(Scope
(E
))
6548 if not In_Open_Scopes
(Scope
(E
)) then
6549 Install_Parent
(Scope
(E
));
6550 Parent_Installed
:= True;
6555 end Check_Generic_Child_Unit
;
6557 -----------------------------
6558 -- Check_Hidden_Child_Unit --
6559 -----------------------------
6561 procedure Check_Hidden_Child_Unit
6563 Gen_Unit
: Entity_Id
;
6564 Act_Decl_Id
: Entity_Id
)
6566 Gen_Id
: constant Node_Id
:= Name
(N
);
6569 if Is_Child_Unit
(Gen_Unit
)
6570 and then Is_Child_Unit
(Act_Decl_Id
)
6571 and then Nkind
(Gen_Id
) = N_Expanded_Name
6572 and then Entity
(Prefix
(Gen_Id
)) = Scope
(Act_Decl_Id
)
6573 and then Chars
(Gen_Unit
) = Chars
(Act_Decl_Id
)
6575 Error_Msg_Node_2
:= Scope
(Act_Decl_Id
);
6577 ("generic unit & is implicitly declared in &",
6578 Defining_Unit_Name
(N
), Gen_Unit
);
6579 Error_Msg_N
("\instance must have different name",
6580 Defining_Unit_Name
(N
));
6582 end Check_Hidden_Child_Unit
;
6584 ------------------------
6585 -- Check_Private_View --
6586 ------------------------
6588 procedure Check_Private_View
(N
: Node_Id
) is
6589 T
: constant Entity_Id
:= Etype
(N
);
6593 -- Exchange views if the type was not private in the generic but is
6594 -- private at the point of instantiation. Do not exchange views if
6595 -- the scope of the type is in scope. This can happen if both generic
6596 -- and instance are sibling units, or if type is defined in a parent.
6597 -- In this case the visibility of the type will be correct for all
6601 BT
:= Base_Type
(T
);
6603 if Is_Private_Type
(T
)
6604 and then not Has_Private_View
(N
)
6605 and then Present
(Full_View
(T
))
6606 and then not In_Open_Scopes
(Scope
(T
))
6608 -- In the generic, the full type was visible. Save the private
6609 -- entity, for subsequent exchange.
6613 elsif Has_Private_View
(N
)
6614 and then not Is_Private_Type
(T
)
6615 and then not Has_Been_Exchanged
(T
)
6616 and then Etype
(Get_Associated_Node
(N
)) /= T
6618 -- Only the private declaration was visible in the generic. If
6619 -- the type appears in a subtype declaration, the subtype in the
6620 -- instance must have a view compatible with that of its parent,
6621 -- which must be exchanged (see corresponding code in Restore_
6622 -- Private_Views). Otherwise, if the type is defined in a parent
6623 -- unit, leave full visibility within instance, which is safe.
6625 if In_Open_Scopes
(Scope
(Base_Type
(T
)))
6626 and then not Is_Private_Type
(Base_Type
(T
))
6627 and then Comes_From_Source
(Base_Type
(T
))
6631 elsif Nkind
(Parent
(N
)) = N_Subtype_Declaration
6632 or else not In_Private_Part
(Scope
(Base_Type
(T
)))
6634 Prepend_Elmt
(T
, Exchanged_Views
);
6635 Exchange_Declarations
(Etype
(Get_Associated_Node
(N
)));
6638 -- For composite types with inconsistent representation exchange
6639 -- component types accordingly.
6641 elsif Is_Access_Type
(T
)
6642 and then Is_Private_Type
(Designated_Type
(T
))
6643 and then not Has_Private_View
(N
)
6644 and then Present
(Full_View
(Designated_Type
(T
)))
6646 Switch_View
(Designated_Type
(T
));
6648 elsif Is_Array_Type
(T
) then
6649 if Is_Private_Type
(Component_Type
(T
))
6650 and then not Has_Private_View
(N
)
6651 and then Present
(Full_View
(Component_Type
(T
)))
6653 Switch_View
(Component_Type
(T
));
6656 -- The normal exchange mechanism relies on the setting of a
6657 -- flag on the reference in the generic. However, an additional
6658 -- mechanism is needed for types that are not explicitly
6659 -- mentioned in the generic, but may be needed in expanded code
6660 -- in the instance. This includes component types of arrays and
6661 -- designated types of access types. This processing must also
6662 -- include the index types of arrays which we take care of here.
6669 Indx
:= First_Index
(T
);
6670 while Present
(Indx
) loop
6671 Typ
:= Base_Type
(Etype
(Indx
));
6673 if Is_Private_Type
(Typ
)
6674 and then Present
(Full_View
(Typ
))
6683 elsif Is_Private_Type
(T
)
6684 and then Present
(Full_View
(T
))
6685 and then Is_Array_Type
(Full_View
(T
))
6686 and then Is_Private_Type
(Component_Type
(Full_View
(T
)))
6690 -- Finally, a non-private subtype may have a private base type, which
6691 -- must be exchanged for consistency. This can happen when a package
6692 -- body is instantiated, when the scope stack is empty but in fact
6693 -- the subtype and the base type are declared in an enclosing scope.
6695 -- Note that in this case we introduce an inconsistency in the view
6696 -- set, because we switch the base type BT, but there could be some
6697 -- private dependent subtypes of BT which remain unswitched. Such
6698 -- subtypes might need to be switched at a later point (see specific
6699 -- provision for that case in Switch_View).
6701 elsif not Is_Private_Type
(T
)
6702 and then not Has_Private_View
(N
)
6703 and then Is_Private_Type
(BT
)
6704 and then Present
(Full_View
(BT
))
6705 and then not Is_Generic_Type
(BT
)
6706 and then not In_Open_Scopes
(BT
)
6708 Prepend_Elmt
(Full_View
(BT
), Exchanged_Views
);
6709 Exchange_Declarations
(BT
);
6712 end Check_Private_View
;
6714 -----------------------------
6715 -- Check_Hidden_Primitives --
6716 -----------------------------
6718 function Check_Hidden_Primitives
(Assoc_List
: List_Id
) return Elist_Id
is
6721 Result
: Elist_Id
:= No_Elist
;
6724 if No
(Assoc_List
) then
6728 -- Traverse the list of associations between formals and actuals
6729 -- searching for renamings of tagged types
6731 Actual
:= First
(Assoc_List
);
6732 while Present
(Actual
) loop
6733 if Nkind
(Actual
) = N_Subtype_Declaration
then
6734 Gen_T
:= Generic_Parent_Type
(Actual
);
6737 and then Is_Tagged_Type
(Gen_T
)
6739 -- Traverse the list of primitives of the actual types
6740 -- searching for hidden primitives that are visible in the
6741 -- corresponding generic formal; leave them visible and
6742 -- append them to Result to restore their decoration later.
6744 Install_Hidden_Primitives
6745 (Prims_List
=> Result
,
6747 Act_T
=> Entity
(Subtype_Indication
(Actual
)));
6755 end Check_Hidden_Primitives
;
6757 --------------------------
6758 -- Contains_Instance_Of --
6759 --------------------------
6761 function Contains_Instance_Of
6764 N
: Node_Id
) return Boolean
6772 -- Verify that there are no circular instantiations. We check whether
6773 -- the unit contains an instance of the current scope or some enclosing
6774 -- scope (in case one of the instances appears in a subunit). Longer
6775 -- circularities involving subunits might seem too pathological to
6776 -- consider, but they were not too pathological for the authors of
6777 -- DEC bc30vsq, so we loop over all enclosing scopes, and mark all
6778 -- enclosing generic scopes as containing an instance.
6781 -- Within a generic subprogram body, the scope is not generic, to
6782 -- allow for recursive subprograms. Use the declaration to determine
6783 -- whether this is a generic unit.
6785 if Ekind
(Scop
) = E_Generic_Package
6786 or else (Is_Subprogram
(Scop
)
6787 and then Nkind
(Unit_Declaration_Node
(Scop
)) =
6788 N_Generic_Subprogram_Declaration
)
6790 Elmt
:= First_Elmt
(Inner_Instances
(Inner
));
6792 while Present
(Elmt
) loop
6793 if Node
(Elmt
) = Scop
then
6794 Error_Msg_Node_2
:= Inner
;
6796 ("circular Instantiation: & instantiated within &!",
6800 elsif Node
(Elmt
) = Inner
then
6803 elsif Contains_Instance_Of
(Node
(Elmt
), Scop
, N
) then
6804 Error_Msg_Node_2
:= Inner
;
6806 ("circular Instantiation: & instantiated within &!",
6814 -- Indicate that Inner is being instantiated within Scop
6816 Append_Elmt
(Inner
, Inner_Instances
(Scop
));
6819 if Scop
= Standard_Standard
then
6822 Scop
:= Scope
(Scop
);
6827 end Contains_Instance_Of
;
6829 -----------------------
6830 -- Copy_Generic_Node --
6831 -----------------------
6833 function Copy_Generic_Node
6835 Parent_Id
: Node_Id
;
6836 Instantiating
: Boolean) return Node_Id
6841 function Copy_Generic_Descendant
(D
: Union_Id
) return Union_Id
;
6842 -- Check the given value of one of the Fields referenced by the current
6843 -- node to determine whether to copy it recursively. The field may hold
6844 -- a Node_Id, a List_Id, or an Elist_Id, or a plain value (Sloc, Uint,
6845 -- Char) in which case it need not be copied.
6847 procedure Copy_Descendants
;
6848 -- Common utility for various nodes
6850 function Copy_Generic_Elist
(E
: Elist_Id
) return Elist_Id
;
6851 -- Make copy of element list
6853 function Copy_Generic_List
6855 Parent_Id
: Node_Id
) return List_Id
;
6856 -- Apply Copy_Node recursively to the members of a node list
6858 function In_Defining_Unit_Name
(Nam
: Node_Id
) return Boolean;
6859 -- True if an identifier is part of the defining program unit name of
6860 -- a child unit. The entity of such an identifier must be kept (for
6861 -- ASIS use) even though as the name of an enclosing generic it would
6862 -- otherwise not be preserved in the generic tree.
6864 ----------------------
6865 -- Copy_Descendants --
6866 ----------------------
6868 procedure Copy_Descendants
is
6870 use Atree
.Unchecked_Access
;
6871 -- This code section is part of the implementation of an untyped
6872 -- tree traversal, so it needs direct access to node fields.
6875 Set_Field1
(New_N
, Copy_Generic_Descendant
(Field1
(N
)));
6876 Set_Field2
(New_N
, Copy_Generic_Descendant
(Field2
(N
)));
6877 Set_Field3
(New_N
, Copy_Generic_Descendant
(Field3
(N
)));
6878 Set_Field4
(New_N
, Copy_Generic_Descendant
(Field4
(N
)));
6879 Set_Field5
(New_N
, Copy_Generic_Descendant
(Field5
(N
)));
6880 end Copy_Descendants
;
6882 -----------------------------
6883 -- Copy_Generic_Descendant --
6884 -----------------------------
6886 function Copy_Generic_Descendant
(D
: Union_Id
) return Union_Id
is
6888 if D
= Union_Id
(Empty
) then
6891 elsif D
in Node_Range
then
6893 (Copy_Generic_Node
(Node_Id
(D
), New_N
, Instantiating
));
6895 elsif D
in List_Range
then
6896 return Union_Id
(Copy_Generic_List
(List_Id
(D
), New_N
));
6898 elsif D
in Elist_Range
then
6899 return Union_Id
(Copy_Generic_Elist
(Elist_Id
(D
)));
6901 -- Nothing else is copyable (e.g. Uint values), return as is
6906 end Copy_Generic_Descendant
;
6908 ------------------------
6909 -- Copy_Generic_Elist --
6910 ------------------------
6912 function Copy_Generic_Elist
(E
: Elist_Id
) return Elist_Id
is
6919 M
:= First_Elmt
(E
);
6920 while Present
(M
) loop
6922 (Copy_Generic_Node
(Node
(M
), Empty
, Instantiating
), L
);
6931 end Copy_Generic_Elist
;
6933 -----------------------
6934 -- Copy_Generic_List --
6935 -----------------------
6937 function Copy_Generic_List
6939 Parent_Id
: Node_Id
) return List_Id
6947 Set_Parent
(New_L
, Parent_Id
);
6950 while Present
(N
) loop
6951 Append
(Copy_Generic_Node
(N
, Empty
, Instantiating
), New_L
);
6960 end Copy_Generic_List
;
6962 ---------------------------
6963 -- In_Defining_Unit_Name --
6964 ---------------------------
6966 function In_Defining_Unit_Name
(Nam
: Node_Id
) return Boolean is
6968 return Present
(Parent
(Nam
))
6969 and then (Nkind
(Parent
(Nam
)) = N_Defining_Program_Unit_Name
6971 (Nkind
(Parent
(Nam
)) = N_Expanded_Name
6972 and then In_Defining_Unit_Name
(Parent
(Nam
))));
6973 end In_Defining_Unit_Name
;
6975 -- Start of processing for Copy_Generic_Node
6982 New_N
:= New_Copy
(N
);
6984 -- Copy aspects if present
6986 if Has_Aspects
(N
) then
6987 Set_Has_Aspects
(New_N
, False);
6988 Set_Aspect_Specifications
6989 (New_N
, Copy_Generic_List
(Aspect_Specifications
(N
), Parent_Id
));
6992 if Instantiating
then
6993 Adjust_Instantiation_Sloc
(New_N
, S_Adjustment
);
6996 if not Is_List_Member
(N
) then
6997 Set_Parent
(New_N
, Parent_Id
);
7000 -- If defining identifier, then all fields have been copied already
7002 if Nkind
(New_N
) in N_Entity
then
7005 -- Special casing for identifiers and other entity names and operators
7007 elsif Nkind_In
(New_N
, N_Identifier
,
7008 N_Character_Literal
,
7011 or else Nkind
(New_N
) in N_Op
7013 if not Instantiating
then
7015 -- Link both nodes in order to assign subsequently the entity of
7016 -- the copy to the original node, in case this is a global
7019 Set_Associated_Node
(N
, New_N
);
7021 -- If we are within an instantiation, this is a nested generic
7022 -- that has already been analyzed at the point of definition.
7023 -- We must preserve references that were global to the enclosing
7024 -- parent at that point. Other occurrences, whether global or
7025 -- local to the current generic, must be resolved anew, so we
7026 -- reset the entity in the generic copy. A global reference has a
7027 -- smaller depth than the parent, or else the same depth in case
7028 -- both are distinct compilation units.
7030 -- A child unit is implicitly declared within the enclosing parent
7031 -- but is in fact global to it, and must be preserved.
7033 -- It is also possible for Current_Instantiated_Parent to be
7034 -- defined, and for this not to be a nested generic, namely if
7035 -- the unit is loaded through Rtsfind. In that case, the entity of
7036 -- New_N is only a link to the associated node, and not a defining
7039 -- The entities for parent units in the defining_program_unit of a
7040 -- generic child unit are established when the context of the unit
7041 -- is first analyzed, before the generic copy is made. They are
7042 -- preserved in the copy for use in ASIS queries.
7044 Ent
:= Entity
(New_N
);
7046 if No
(Current_Instantiated_Parent
.Gen_Id
) then
7048 or else Nkind
(Ent
) /= N_Defining_Identifier
7049 or else not In_Defining_Unit_Name
(N
)
7051 Set_Associated_Node
(New_N
, Empty
);
7056 not Nkind_In
(Ent
, N_Defining_Identifier
,
7057 N_Defining_Character_Literal
,
7058 N_Defining_Operator_Symbol
)
7059 or else No
(Scope
(Ent
))
7061 (Scope
(Ent
) = Current_Instantiated_Parent
.Gen_Id
7062 and then not Is_Child_Unit
(Ent
))
7064 (Scope_Depth
(Scope
(Ent
)) >
7065 Scope_Depth
(Current_Instantiated_Parent
.Gen_Id
)
7067 Get_Source_Unit
(Ent
) =
7068 Get_Source_Unit
(Current_Instantiated_Parent
.Gen_Id
))
7070 Set_Associated_Node
(New_N
, Empty
);
7073 -- Case of instantiating identifier or some other name or operator
7076 -- If the associated node is still defined, the entity in it
7077 -- is global, and must be copied to the instance. If this copy
7078 -- is being made for a body to inline, it is applied to an
7079 -- instantiated tree, and the entity is already present and
7080 -- must be also preserved.
7083 Assoc
: constant Node_Id
:= Get_Associated_Node
(N
);
7086 if Present
(Assoc
) then
7087 if Nkind
(Assoc
) = Nkind
(N
) then
7088 Set_Entity
(New_N
, Entity
(Assoc
));
7089 Check_Private_View
(N
);
7091 -- The name in the call may be a selected component if the
7092 -- call has not been analyzed yet, as may be the case for
7093 -- pre/post conditions in a generic unit.
7095 elsif Nkind
(Assoc
) = N_Function_Call
7096 and then Is_Entity_Name
(Name
(Assoc
))
7098 Set_Entity
(New_N
, Entity
(Name
(Assoc
)));
7100 elsif Nkind_In
(Assoc
, N_Defining_Identifier
,
7101 N_Defining_Character_Literal
,
7102 N_Defining_Operator_Symbol
)
7103 and then Expander_Active
7105 -- Inlining case: we are copying a tree that contains
7106 -- global entities, which are preserved in the copy to be
7107 -- used for subsequent inlining.
7112 Set_Entity
(New_N
, Empty
);
7118 -- For expanded name, we must copy the Prefix and Selector_Name
7120 if Nkind
(N
) = N_Expanded_Name
then
7122 (New_N
, Copy_Generic_Node
(Prefix
(N
), New_N
, Instantiating
));
7124 Set_Selector_Name
(New_N
,
7125 Copy_Generic_Node
(Selector_Name
(N
), New_N
, Instantiating
));
7127 -- For operators, we must copy the right operand
7129 elsif Nkind
(N
) in N_Op
then
7130 Set_Right_Opnd
(New_N
,
7131 Copy_Generic_Node
(Right_Opnd
(N
), New_N
, Instantiating
));
7133 -- And for binary operators, the left operand as well
7135 if Nkind
(N
) in N_Binary_Op
then
7136 Set_Left_Opnd
(New_N
,
7137 Copy_Generic_Node
(Left_Opnd
(N
), New_N
, Instantiating
));
7141 -- Special casing for stubs
7143 elsif Nkind
(N
) in N_Body_Stub
then
7145 -- In any case, we must copy the specification or defining
7146 -- identifier as appropriate.
7148 if Nkind
(N
) = N_Subprogram_Body_Stub
then
7149 Set_Specification
(New_N
,
7150 Copy_Generic_Node
(Specification
(N
), New_N
, Instantiating
));
7153 Set_Defining_Identifier
(New_N
,
7155 (Defining_Identifier
(N
), New_N
, Instantiating
));
7158 -- If we are not instantiating, then this is where we load and
7159 -- analyze subunits, i.e. at the point where the stub occurs. A
7160 -- more permissive system might defer this analysis to the point
7161 -- of instantiation, but this seems too complicated for now.
7163 if not Instantiating
then
7165 Subunit_Name
: constant Unit_Name_Type
:= Get_Unit_Name
(N
);
7167 Unum
: Unit_Number_Type
;
7171 -- Make sure that, if it is a subunit of the main unit that is
7172 -- preprocessed and if -gnateG is specified, the preprocessed
7173 -- file will be written.
7175 Lib
.Analysing_Subunit_Of_Main
:=
7176 Lib
.In_Extended_Main_Source_Unit
(N
);
7179 (Load_Name
=> Subunit_Name
,
7183 Lib
.Analysing_Subunit_Of_Main
:= False;
7185 -- If the proper body is not found, a warning message will be
7186 -- emitted when analyzing the stub, or later at the point of
7187 -- instantiation. Here we just leave the stub as is.
7189 if Unum
= No_Unit
then
7190 Subunits_Missing
:= True;
7191 goto Subunit_Not_Found
;
7194 Subunit
:= Cunit
(Unum
);
7196 if Nkind
(Unit
(Subunit
)) /= N_Subunit
then
7198 ("found child unit instead of expected SEPARATE subunit",
7200 Error_Msg_Sloc
:= Sloc
(N
);
7201 Error_Msg_N
("\to complete stub #", Subunit
);
7202 goto Subunit_Not_Found
;
7205 -- We must create a generic copy of the subunit, in order to
7206 -- perform semantic analysis on it, and we must replace the
7207 -- stub in the original generic unit with the subunit, in order
7208 -- to preserve non-local references within.
7210 -- Only the proper body needs to be copied. Library_Unit and
7211 -- context clause are simply inherited by the generic copy.
7212 -- Note that the copy (which may be recursive if there are
7213 -- nested subunits) must be done first, before attaching it to
7214 -- the enclosing generic.
7218 (Proper_Body
(Unit
(Subunit
)),
7219 Empty
, Instantiating
=> False);
7221 -- Now place the original proper body in the original generic
7222 -- unit. This is a body, not a compilation unit.
7224 Rewrite
(N
, Proper_Body
(Unit
(Subunit
)));
7225 Set_Is_Compilation_Unit
(Defining_Entity
(N
), False);
7226 Set_Was_Originally_Stub
(N
);
7228 -- Finally replace the body of the subunit with its copy, and
7229 -- make this new subunit into the library unit of the generic
7230 -- copy, which does not have stubs any longer.
7232 Set_Proper_Body
(Unit
(Subunit
), New_Body
);
7233 Set_Library_Unit
(New_N
, Subunit
);
7234 Inherit_Context
(Unit
(Subunit
), N
);
7237 -- If we are instantiating, this must be an error case, since
7238 -- otherwise we would have replaced the stub node by the proper body
7239 -- that corresponds. So just ignore it in the copy (i.e. we have
7240 -- copied it, and that is good enough).
7246 <<Subunit_Not_Found
>> null;
7248 -- If the node is a compilation unit, it is the subunit of a stub, which
7249 -- has been loaded already (see code below). In this case, the library
7250 -- unit field of N points to the parent unit (which is a compilation
7251 -- unit) and need not (and cannot) be copied.
7253 -- When the proper body of the stub is analyzed, the library_unit link
7254 -- is used to establish the proper context (see sem_ch10).
7256 -- The other fields of a compilation unit are copied as usual
7258 elsif Nkind
(N
) = N_Compilation_Unit
then
7260 -- This code can only be executed when not instantiating, because in
7261 -- the copy made for an instantiation, the compilation unit node has
7262 -- disappeared at the point that a stub is replaced by its proper
7265 pragma Assert
(not Instantiating
);
7267 Set_Context_Items
(New_N
,
7268 Copy_Generic_List
(Context_Items
(N
), New_N
));
7271 Copy_Generic_Node
(Unit
(N
), New_N
, False));
7273 Set_First_Inlined_Subprogram
(New_N
,
7275 (First_Inlined_Subprogram
(N
), New_N
, False));
7277 Set_Aux_Decls_Node
(New_N
,
7278 Copy_Generic_Node
(Aux_Decls_Node
(N
), New_N
, False));
7280 -- For an assignment node, the assignment is known to be semantically
7281 -- legal if we are instantiating the template. This avoids incorrect
7282 -- diagnostics in generated code.
7284 elsif Nkind
(N
) = N_Assignment_Statement
then
7286 -- Copy name and expression fields in usual manner
7289 Copy_Generic_Node
(Name
(N
), New_N
, Instantiating
));
7291 Set_Expression
(New_N
,
7292 Copy_Generic_Node
(Expression
(N
), New_N
, Instantiating
));
7294 if Instantiating
then
7295 Set_Assignment_OK
(Name
(New_N
), True);
7298 elsif Nkind_In
(N
, N_Aggregate
, N_Extension_Aggregate
) then
7299 if not Instantiating
then
7300 Set_Associated_Node
(N
, New_N
);
7303 if Present
(Get_Associated_Node
(N
))
7304 and then Nkind
(Get_Associated_Node
(N
)) = Nkind
(N
)
7306 -- In the generic the aggregate has some composite type. If at
7307 -- the point of instantiation the type has a private view,
7308 -- install the full view (and that of its ancestors, if any).
7311 T
: Entity_Id
:= (Etype
(Get_Associated_Node
(New_N
)));
7316 and then Is_Private_Type
(T
)
7322 and then Is_Tagged_Type
(T
)
7323 and then Is_Derived_Type
(T
)
7325 Rt
:= Root_Type
(T
);
7330 if Is_Private_Type
(T
) then
7341 -- Do not copy the associated node, which points to the generic copy
7342 -- of the aggregate.
7345 use Atree
.Unchecked_Access
;
7346 -- This code section is part of the implementation of an untyped
7347 -- tree traversal, so it needs direct access to node fields.
7350 Set_Field1
(New_N
, Copy_Generic_Descendant
(Field1
(N
)));
7351 Set_Field2
(New_N
, Copy_Generic_Descendant
(Field2
(N
)));
7352 Set_Field3
(New_N
, Copy_Generic_Descendant
(Field3
(N
)));
7353 Set_Field5
(New_N
, Copy_Generic_Descendant
(Field5
(N
)));
7356 -- Allocators do not have an identifier denoting the access type, so we
7357 -- must locate it through the expression to check whether the views are
7360 elsif Nkind
(N
) = N_Allocator
7361 and then Nkind
(Expression
(N
)) = N_Qualified_Expression
7362 and then Is_Entity_Name
(Subtype_Mark
(Expression
(N
)))
7363 and then Instantiating
7366 T
: constant Node_Id
:=
7367 Get_Associated_Node
(Subtype_Mark
(Expression
(N
)));
7373 -- Retrieve the allocator node in the generic copy
7375 Acc_T
:= Etype
(Parent
(Parent
(T
)));
7377 and then Is_Private_Type
(Acc_T
)
7379 Switch_View
(Acc_T
);
7386 -- For a proper body, we must catch the case of a proper body that
7387 -- replaces a stub. This represents the point at which a separate
7388 -- compilation unit, and hence template file, may be referenced, so we
7389 -- must make a new source instantiation entry for the template of the
7390 -- subunit, and ensure that all nodes in the subunit are adjusted using
7391 -- this new source instantiation entry.
7393 elsif Nkind
(N
) in N_Proper_Body
then
7395 Save_Adjustment
: constant Sloc_Adjustment
:= S_Adjustment
;
7398 if Instantiating
and then Was_Originally_Stub
(N
) then
7399 Create_Instantiation_Source
7400 (Instantiation_Node
,
7401 Defining_Entity
(N
),
7406 -- Now copy the fields of the proper body, using the new
7407 -- adjustment factor if one was needed as per test above.
7411 -- Restore the original adjustment factor in case changed
7413 S_Adjustment
:= Save_Adjustment
;
7416 -- Don't copy Ident or Comment pragmas, since the comment belongs to the
7417 -- generic unit, not to the instantiating unit.
7419 elsif Nkind
(N
) = N_Pragma
and then Instantiating
then
7421 Prag_Id
: constant Pragma_Id
:= Get_Pragma_Id
(N
);
7423 if Prag_Id
= Pragma_Ident
or else Prag_Id
= Pragma_Comment
then
7424 New_N
:= Make_Null_Statement
(Sloc
(N
));
7430 elsif Nkind_In
(N
, N_Integer_Literal
, N_Real_Literal
) then
7432 -- No descendant fields need traversing
7436 elsif Nkind
(N
) = N_String_Literal
7437 and then Present
(Etype
(N
))
7438 and then Instantiating
7440 -- If the string is declared in an outer scope, the string_literal
7441 -- subtype created for it may have the wrong scope. We force the
7442 -- reanalysis of the constant to generate a new itype in the proper
7445 Set_Etype
(New_N
, Empty
);
7446 Set_Analyzed
(New_N
, False);
7448 -- For the remaining nodes, copy their descendants recursively
7453 if Instantiating
and then Nkind
(N
) = N_Subprogram_Body
then
7454 Set_Generic_Parent
(Specification
(New_N
), N
);
7456 -- Should preserve Corresponding_Spec??? (12.3(14))
7461 end Copy_Generic_Node
;
7463 ----------------------------
7464 -- Denotes_Formal_Package --
7465 ----------------------------
7467 function Denotes_Formal_Package
7469 On_Exit
: Boolean := False;
7470 Instance
: Entity_Id
:= Empty
) return Boolean
7473 Scop
: constant Entity_Id
:= Scope
(Pack
);
7476 function Is_Actual_Of_Previous_Formal
(P
: Entity_Id
) return Boolean;
7477 -- The package in question may be an actual for a previous formal
7478 -- package P of the current instance, so examine its actuals as well.
7479 -- This must be recursive over other formal packages.
7481 ----------------------------------
7482 -- Is_Actual_Of_Previous_Formal --
7483 ----------------------------------
7485 function Is_Actual_Of_Previous_Formal
(P
: Entity_Id
) return Boolean is
7489 E1
:= First_Entity
(P
);
7490 while Present
(E1
) and then E1
/= Instance
loop
7491 if Ekind
(E1
) = E_Package
7492 and then Nkind
(Parent
(E1
)) = N_Package_Renaming_Declaration
7494 if Renamed_Object
(E1
) = Pack
then
7497 elsif E1
= P
or else Renamed_Object
(E1
) = P
then
7500 elsif Is_Actual_Of_Previous_Formal
(E1
) then
7509 end Is_Actual_Of_Previous_Formal
;
7511 -- Start of processing for Denotes_Formal_Package
7517 (Instance_Envs
.Last
).Instantiated_Parent
.Act_Id
;
7519 Par
:= Current_Instantiated_Parent
.Act_Id
;
7522 if Ekind
(Scop
) = E_Generic_Package
7523 or else Nkind
(Unit_Declaration_Node
(Scop
)) =
7524 N_Generic_Subprogram_Declaration
7528 elsif Nkind
(Original_Node
(Unit_Declaration_Node
(Pack
))) =
7529 N_Formal_Package_Declaration
7537 -- Check whether this package is associated with a formal package of
7538 -- the enclosing instantiation. Iterate over the list of renamings.
7540 E
:= First_Entity
(Par
);
7541 while Present
(E
) loop
7542 if Ekind
(E
) /= E_Package
7543 or else Nkind
(Parent
(E
)) /= N_Package_Renaming_Declaration
7547 elsif Renamed_Object
(E
) = Par
then
7550 elsif Renamed_Object
(E
) = Pack
then
7553 elsif Is_Actual_Of_Previous_Formal
(E
) then
7563 end Denotes_Formal_Package
;
7569 procedure End_Generic
is
7571 -- ??? More things could be factored out in this routine. Should
7572 -- probably be done at a later stage.
7574 Inside_A_Generic
:= Generic_Flags
.Table
(Generic_Flags
.Last
);
7575 Generic_Flags
.Decrement_Last
;
7577 Expander_Mode_Restore
;
7584 function Earlier
(N1
, N2
: Node_Id
) return Boolean is
7585 procedure Find_Depth
(P
: in out Node_Id
; D
: in out Integer);
7586 -- Find distance from given node to enclosing compilation unit
7592 procedure Find_Depth
(P
: in out Node_Id
; D
: in out Integer) is
7595 and then Nkind
(P
) /= N_Compilation_Unit
7597 P
:= True_Parent
(P
);
7602 -- Local declarations
7611 -- Start of processing for Earlier
7614 Find_Depth
(P1
, D1
);
7615 Find_Depth
(P2
, D2
);
7625 P1
:= True_Parent
(P1
);
7630 P2
:= True_Parent
(P2
);
7634 -- At this point P1 and P2 are at the same distance from the root.
7635 -- We examine their parents until we find a common declarative list.
7636 -- If we reach the root, N1 and N2 do not descend from the same
7637 -- declarative list (e.g. one is nested in the declarative part and
7638 -- the other is in a block in the statement part) and the earlier
7639 -- one is already frozen.
7641 while not Is_List_Member
(P1
)
7642 or else not Is_List_Member
(P2
)
7643 or else List_Containing
(P1
) /= List_Containing
(P2
)
7645 P1
:= True_Parent
(P1
);
7646 P2
:= True_Parent
(P2
);
7648 if Nkind
(Parent
(P1
)) = N_Subunit
then
7649 P1
:= Corresponding_Stub
(Parent
(P1
));
7652 if Nkind
(Parent
(P2
)) = N_Subunit
then
7653 P2
:= Corresponding_Stub
(Parent
(P2
));
7661 -- Expanded code usually shares the source location of the original
7662 -- construct it was generated for. This however may not necessarely
7663 -- reflect the true location of the code within the tree.
7665 -- Before comparing the slocs of the two nodes, make sure that we are
7666 -- working with correct source locations. Assume that P1 is to the left
7667 -- of P2. If either one does not come from source, traverse the common
7668 -- list heading towards the other node and locate the first source
7672 -- ----+===+===+--------------+===+===+----
7673 -- expanded code expanded code
7675 if not Comes_From_Source
(P1
) then
7676 while Present
(P1
) loop
7678 -- Neither P2 nor a source statement were located during the
7679 -- search. If we reach the end of the list, then P1 does not
7680 -- occur earlier than P2.
7683 -- start --- P2 ----- P1 --- end
7685 if No
(Next
(P1
)) then
7688 -- We encounter P2 while going to the right of the list. This
7689 -- means that P1 does indeed appear earlier.
7692 -- start --- P1 ===== P2 --- end
7693 -- expanded code in between
7698 -- No need to look any further since we have located a source
7701 elsif Comes_From_Source
(P1
) then
7711 if not Comes_From_Source
(P2
) then
7712 while Present
(P2
) loop
7714 -- Neither P1 nor a source statement were located during the
7715 -- search. If we reach the start of the list, then P1 does not
7716 -- occur earlier than P2.
7719 -- start --- P2 --- P1 --- end
7721 if No
(Prev
(P2
)) then
7724 -- We encounter P1 while going to the left of the list. This
7725 -- means that P1 does indeed appear earlier.
7728 -- start --- P1 ===== P2 --- end
7729 -- expanded code in between
7734 -- No need to look any further since we have located a source
7737 elsif Comes_From_Source
(P2
) then
7747 -- At this point either both nodes came from source or we approximated
7748 -- their source locations through neighbouring source statements.
7750 T1
:= Top_Level_Location
(Sloc
(P1
));
7751 T2
:= Top_Level_Location
(Sloc
(P2
));
7753 -- When two nodes come from the same instance, they have identical top
7754 -- level locations. To determine proper relation within the tree, check
7755 -- their locations within the template.
7758 return Sloc
(P1
) < Sloc
(P2
);
7760 -- The two nodes either come from unrelated instances or do not come
7761 -- from instantiated code at all.
7768 ----------------------
7769 -- Find_Actual_Type --
7770 ----------------------
7772 function Find_Actual_Type
7774 Gen_Type
: Entity_Id
) return Entity_Id
7776 Gen_Scope
: constant Entity_Id
:= Scope
(Gen_Type
);
7780 -- Special processing only applies to child units
7782 if not Is_Child_Unit
(Gen_Scope
) then
7783 return Get_Instance_Of
(Typ
);
7785 -- If designated or component type is itself a formal of the child unit,
7786 -- its instance is available.
7788 elsif Scope
(Typ
) = Gen_Scope
then
7789 return Get_Instance_Of
(Typ
);
7791 -- If the array or access type is not declared in the parent unit,
7792 -- no special processing needed.
7794 elsif not Is_Generic_Type
(Typ
)
7795 and then Scope
(Gen_Scope
) /= Scope
(Typ
)
7797 return Get_Instance_Of
(Typ
);
7799 -- Otherwise, retrieve designated or component type by visibility
7802 T
:= Current_Entity
(Typ
);
7803 while Present
(T
) loop
7804 if In_Open_Scopes
(Scope
(T
)) then
7807 elsif Is_Generic_Actual_Type
(T
) then
7816 end Find_Actual_Type
;
7818 ----------------------------
7819 -- Freeze_Subprogram_Body --
7820 ----------------------------
7822 procedure Freeze_Subprogram_Body
7823 (Inst_Node
: Node_Id
;
7825 Pack_Id
: Entity_Id
)
7827 Gen_Unit
: constant Entity_Id
:= Get_Generic_Entity
(Inst_Node
);
7828 Par
: constant Entity_Id
:= Scope
(Gen_Unit
);
7834 function Enclosing_Package_Body
(N
: Node_Id
) return Node_Id
;
7835 -- Find innermost package body that encloses the given node, and which
7836 -- is not a compilation unit. Freeze nodes for the instance, or for its
7837 -- enclosing body, may be inserted after the enclosing_body of the
7838 -- generic unit. Used to determine proper placement of freeze node for
7839 -- both package and subprogram instances.
7841 function Package_Freeze_Node
(B
: Node_Id
) return Node_Id
;
7842 -- Find entity for given package body, and locate or create a freeze
7845 ----------------------------
7846 -- Enclosing_Package_Body --
7847 ----------------------------
7849 function Enclosing_Package_Body
(N
: Node_Id
) return Node_Id
is
7855 and then Nkind
(Parent
(P
)) /= N_Compilation_Unit
7857 if Nkind
(P
) = N_Package_Body
then
7858 if Nkind
(Parent
(P
)) = N_Subunit
then
7859 return Corresponding_Stub
(Parent
(P
));
7865 P
:= True_Parent
(P
);
7869 end Enclosing_Package_Body
;
7871 -------------------------
7872 -- Package_Freeze_Node --
7873 -------------------------
7875 function Package_Freeze_Node
(B
: Node_Id
) return Node_Id
is
7879 if Nkind
(B
) = N_Package_Body
then
7880 Id
:= Corresponding_Spec
(B
);
7881 else pragma Assert
(Nkind
(B
) = N_Package_Body_Stub
);
7882 Id
:= Corresponding_Spec
(Proper_Body
(Unit
(Library_Unit
(B
))));
7885 Ensure_Freeze_Node
(Id
);
7886 return Freeze_Node
(Id
);
7887 end Package_Freeze_Node
;
7889 -- Start of processing of Freeze_Subprogram_Body
7892 -- If the instance and the generic body appear within the same unit, and
7893 -- the instance precedes the generic, the freeze node for the instance
7894 -- must appear after that of the generic. If the generic is nested
7895 -- within another instance I2, then current instance must be frozen
7896 -- after I2. In both cases, the freeze nodes are those of enclosing
7897 -- packages. Otherwise, the freeze node is placed at the end of the
7898 -- current declarative part.
7900 Enc_G
:= Enclosing_Package_Body
(Gen_Body
);
7901 Enc_I
:= Enclosing_Package_Body
(Inst_Node
);
7902 Ensure_Freeze_Node
(Pack_Id
);
7903 F_Node
:= Freeze_Node
(Pack_Id
);
7905 if Is_Generic_Instance
(Par
)
7906 and then Present
(Freeze_Node
(Par
))
7907 and then In_Same_Declarative_Part
(Freeze_Node
(Par
), Inst_Node
)
7909 -- The parent was a premature instantiation. Insert freeze node at
7910 -- the end the current declarative part.
7912 if ABE_Is_Certain
(Get_Package_Instantiation_Node
(Par
)) then
7913 Insert_Freeze_Node_For_Instance
(Inst_Node
, F_Node
);
7915 -- Handle the following case:
7917 -- package Parent_Inst is new ...
7920 -- procedure P ... -- this body freezes Parent_Inst
7922 -- package Inst is new ...
7924 -- In this particular scenario, the freeze node for Inst must be
7925 -- inserted in the same manner as that of Parent_Inst - before the
7926 -- next source body or at the end of the declarative list (body not
7927 -- available). If body P did not exist and Parent_Inst was frozen
7928 -- after Inst, either by a body following Inst or at the end of the
7929 -- declarative region, the freeze node for Inst must be inserted
7930 -- after that of Parent_Inst. This relation is established by
7931 -- comparing the Slocs of Parent_Inst freeze node and Inst.
7933 elsif List_Containing
(Get_Package_Instantiation_Node
(Par
)) =
7934 List_Containing
(Inst_Node
)
7935 and then Sloc
(Freeze_Node
(Par
)) < Sloc
(Inst_Node
)
7937 Insert_Freeze_Node_For_Instance
(Inst_Node
, F_Node
);
7940 Insert_After
(Freeze_Node
(Par
), F_Node
);
7943 -- The body enclosing the instance should be frozen after the body that
7944 -- includes the generic, because the body of the instance may make
7945 -- references to entities therein. If the two are not in the same
7946 -- declarative part, or if the one enclosing the instance is frozen
7947 -- already, freeze the instance at the end of the current declarative
7950 elsif Is_Generic_Instance
(Par
)
7951 and then Present
(Freeze_Node
(Par
))
7952 and then Present
(Enc_I
)
7954 if In_Same_Declarative_Part
(Freeze_Node
(Par
), Enc_I
)
7956 (Nkind
(Enc_I
) = N_Package_Body
7958 In_Same_Declarative_Part
(Freeze_Node
(Par
), Parent
(Enc_I
)))
7960 -- The enclosing package may contain several instances. Rather
7961 -- than computing the earliest point at which to insert its freeze
7962 -- node, we place it at the end of the declarative part of the
7963 -- parent of the generic.
7965 Insert_Freeze_Node_For_Instance
7966 (Freeze_Node
(Par
), Package_Freeze_Node
(Enc_I
));
7969 Insert_Freeze_Node_For_Instance
(Inst_Node
, F_Node
);
7971 elsif Present
(Enc_G
)
7972 and then Present
(Enc_I
)
7973 and then Enc_G
/= Enc_I
7974 and then Earlier
(Inst_Node
, Gen_Body
)
7976 if Nkind
(Enc_G
) = N_Package_Body
then
7977 E_G_Id
:= Corresponding_Spec
(Enc_G
);
7978 else pragma Assert
(Nkind
(Enc_G
) = N_Package_Body_Stub
);
7980 Corresponding_Spec
(Proper_Body
(Unit
(Library_Unit
(Enc_G
))));
7983 -- Freeze package that encloses instance, and place node after the
7984 -- package that encloses generic. If enclosing package is already
7985 -- frozen we have to assume it is at the proper place. This may be a
7986 -- potential ABE that requires dynamic checking. Do not add a freeze
7987 -- node if the package that encloses the generic is inside the body
7988 -- that encloses the instance, because the freeze node would be in
7989 -- the wrong scope. Additional contortions needed if the bodies are
7990 -- within a subunit.
7993 Enclosing_Body
: Node_Id
;
7996 if Nkind
(Enc_I
) = N_Package_Body_Stub
then
7997 Enclosing_Body
:= Proper_Body
(Unit
(Library_Unit
(Enc_I
)));
7999 Enclosing_Body
:= Enc_I
;
8002 if Parent
(List_Containing
(Enc_G
)) /= Enclosing_Body
then
8003 Insert_Freeze_Node_For_Instance
8004 (Enc_G
, Package_Freeze_Node
(Enc_I
));
8008 -- Freeze enclosing subunit before instance
8010 Ensure_Freeze_Node
(E_G_Id
);
8012 if not Is_List_Member
(Freeze_Node
(E_G_Id
)) then
8013 Insert_After
(Enc_G
, Freeze_Node
(E_G_Id
));
8016 Insert_Freeze_Node_For_Instance
(Inst_Node
, F_Node
);
8019 -- If none of the above, insert freeze node at the end of the current
8020 -- declarative part.
8022 Insert_Freeze_Node_For_Instance
(Inst_Node
, F_Node
);
8024 end Freeze_Subprogram_Body
;
8030 function Get_Gen_Id
(E
: Assoc_Ptr
) return Entity_Id
is
8032 return Generic_Renamings
.Table
(E
).Gen_Id
;
8035 ---------------------
8036 -- Get_Instance_Of --
8037 ---------------------
8039 function Get_Instance_Of
(A
: Entity_Id
) return Entity_Id
is
8040 Res
: constant Assoc_Ptr
:= Generic_Renamings_HTable
.Get
(A
);
8043 if Res
/= Assoc_Null
then
8044 return Generic_Renamings
.Table
(Res
).Act_Id
;
8046 -- On exit, entity is not instantiated: not a generic parameter, or
8047 -- else parameter of an inner generic unit.
8051 end Get_Instance_Of
;
8053 ------------------------------------
8054 -- Get_Package_Instantiation_Node --
8055 ------------------------------------
8057 function Get_Package_Instantiation_Node
(A
: Entity_Id
) return Node_Id
is
8058 Decl
: Node_Id
:= Unit_Declaration_Node
(A
);
8062 -- If the Package_Instantiation attribute has been set on the package
8063 -- entity, then use it directly when it (or its Original_Node) refers
8064 -- to an N_Package_Instantiation node. In principle it should be
8065 -- possible to have this field set in all cases, which should be
8066 -- investigated, and would allow this function to be significantly
8069 Inst
:= Package_Instantiation
(A
);
8071 if Present
(Inst
) then
8072 if Nkind
(Inst
) = N_Package_Instantiation
then
8075 elsif Nkind
(Original_Node
(Inst
)) = N_Package_Instantiation
then
8076 return Original_Node
(Inst
);
8080 -- If the instantiation is a compilation unit that does not need body
8081 -- then the instantiation node has been rewritten as a package
8082 -- declaration for the instance, and we return the original node.
8084 -- If it is a compilation unit and the instance node has not been
8085 -- rewritten, then it is still the unit of the compilation. Finally, if
8086 -- a body is present, this is a parent of the main unit whose body has
8087 -- been compiled for inlining purposes, and the instantiation node has
8088 -- been rewritten with the instance body.
8090 -- Otherwise the instantiation node appears after the declaration. If
8091 -- the entity is a formal package, the declaration may have been
8092 -- rewritten as a generic declaration (in the case of a formal with box)
8093 -- or left as a formal package declaration if it has actuals, and is
8094 -- found with a forward search.
8096 if Nkind
(Parent
(Decl
)) = N_Compilation_Unit
then
8097 if Nkind
(Decl
) = N_Package_Declaration
8098 and then Present
(Corresponding_Body
(Decl
))
8100 Decl
:= Unit_Declaration_Node
(Corresponding_Body
(Decl
));
8103 if Nkind
(Original_Node
(Decl
)) = N_Package_Instantiation
then
8104 return Original_Node
(Decl
);
8106 return Unit
(Parent
(Decl
));
8109 elsif Nkind
(Decl
) = N_Package_Declaration
8110 and then Nkind
(Original_Node
(Decl
)) = N_Formal_Package_Declaration
8112 return Original_Node
(Decl
);
8115 Inst
:= Next
(Decl
);
8116 while not Nkind_In
(Inst
, N_Package_Instantiation
,
8117 N_Formal_Package_Declaration
)
8124 end Get_Package_Instantiation_Node
;
8126 ------------------------
8127 -- Has_Been_Exchanged --
8128 ------------------------
8130 function Has_Been_Exchanged
(E
: Entity_Id
) return Boolean is
8134 Next
:= First_Elmt
(Exchanged_Views
);
8135 while Present
(Next
) loop
8136 if Full_View
(Node
(Next
)) = E
then
8144 end Has_Been_Exchanged
;
8150 function Hash
(F
: Entity_Id
) return HTable_Range
is
8152 return HTable_Range
(F
mod HTable_Size
);
8155 ------------------------
8156 -- Hide_Current_Scope --
8157 ------------------------
8159 procedure Hide_Current_Scope
is
8160 C
: constant Entity_Id
:= Current_Scope
;
8164 Set_Is_Hidden_Open_Scope
(C
);
8166 E
:= First_Entity
(C
);
8167 while Present
(E
) loop
8168 if Is_Immediately_Visible
(E
) then
8169 Set_Is_Immediately_Visible
(E
, False);
8170 Append_Elmt
(E
, Hidden_Entities
);
8176 -- Make the scope name invisible as well. This is necessary, but might
8177 -- conflict with calls to Rtsfind later on, in case the scope is a
8178 -- predefined one. There is no clean solution to this problem, so for
8179 -- now we depend on the user not redefining Standard itself in one of
8180 -- the parent units.
8182 if Is_Immediately_Visible
(C
) and then C
/= Standard_Standard
then
8183 Set_Is_Immediately_Visible
(C
, False);
8184 Append_Elmt
(C
, Hidden_Entities
);
8187 end Hide_Current_Scope
;
8193 procedure Init_Env
is
8194 Saved
: Instance_Env
;
8197 Saved
.Instantiated_Parent
:= Current_Instantiated_Parent
;
8198 Saved
.Exchanged_Views
:= Exchanged_Views
;
8199 Saved
.Hidden_Entities
:= Hidden_Entities
;
8200 Saved
.Current_Sem_Unit
:= Current_Sem_Unit
;
8201 Saved
.Parent_Unit_Visible
:= Parent_Unit_Visible
;
8202 Saved
.Instance_Parent_Unit
:= Instance_Parent_Unit
;
8204 -- Save configuration switches. These may be reset if the unit is a
8205 -- predefined unit, and the current mode is not Ada 2005.
8207 Save_Opt_Config_Switches
(Saved
.Switches
);
8209 Instance_Envs
.Append
(Saved
);
8211 Exchanged_Views
:= New_Elmt_List
;
8212 Hidden_Entities
:= New_Elmt_List
;
8214 -- Make dummy entry for Instantiated parent. If generic unit is legal,
8215 -- this is set properly in Set_Instance_Env.
8217 Current_Instantiated_Parent
:=
8218 (Current_Scope
, Current_Scope
, Assoc_Null
);
8221 ------------------------------
8222 -- In_Same_Declarative_Part --
8223 ------------------------------
8225 function In_Same_Declarative_Part
8227 Inst
: Node_Id
) return Boolean
8229 Decls
: constant Node_Id
:= Parent
(F_Node
);
8230 Nod
: Node_Id
:= Parent
(Inst
);
8233 while Present
(Nod
) loop
8237 elsif Nkind_In
(Nod
, N_Subprogram_Body
,
8239 N_Package_Declaration
,
8246 elsif Nkind
(Nod
) = N_Subunit
then
8247 Nod
:= Corresponding_Stub
(Nod
);
8249 elsif Nkind
(Nod
) = N_Compilation_Unit
then
8253 Nod
:= Parent
(Nod
);
8258 end In_Same_Declarative_Part
;
8260 ---------------------
8261 -- In_Main_Context --
8262 ---------------------
8264 function In_Main_Context
(E
: Entity_Id
) return Boolean is
8270 if not Is_Compilation_Unit
(E
)
8271 or else Ekind
(E
) /= E_Package
8272 or else In_Private_Part
(E
)
8277 Context
:= Context_Items
(Cunit
(Main_Unit
));
8279 Clause
:= First
(Context
);
8280 while Present
(Clause
) loop
8281 if Nkind
(Clause
) = N_With_Clause
then
8282 Nam
:= Name
(Clause
);
8284 -- If the current scope is part of the context of the main unit,
8285 -- analysis of the corresponding with_clause is not complete, and
8286 -- the entity is not set. We use the Chars field directly, which
8287 -- might produce false positives in rare cases, but guarantees
8288 -- that we produce all the instance bodies we will need.
8290 if (Is_Entity_Name
(Nam
) and then Chars
(Nam
) = Chars
(E
))
8291 or else (Nkind
(Nam
) = N_Selected_Component
8292 and then Chars
(Selector_Name
(Nam
)) = Chars
(E
))
8302 end In_Main_Context
;
8304 ---------------------
8305 -- Inherit_Context --
8306 ---------------------
8308 procedure Inherit_Context
(Gen_Decl
: Node_Id
; Inst
: Node_Id
) is
8309 Current_Context
: List_Id
;
8310 Current_Unit
: Node_Id
;
8319 if Nkind
(Parent
(Gen_Decl
)) = N_Compilation_Unit
then
8321 -- The inherited context is attached to the enclosing compilation
8322 -- unit. This is either the main unit, or the declaration for the
8323 -- main unit (in case the instantiation appears within the package
8324 -- declaration and the main unit is its body).
8326 Current_Unit
:= Parent
(Inst
);
8327 while Present
(Current_Unit
)
8328 and then Nkind
(Current_Unit
) /= N_Compilation_Unit
8330 Current_Unit
:= Parent
(Current_Unit
);
8333 Current_Context
:= Context_Items
(Current_Unit
);
8335 Item
:= First
(Context_Items
(Parent
(Gen_Decl
)));
8336 while Present
(Item
) loop
8337 if Nkind
(Item
) = N_With_Clause
then
8338 Lib_Unit
:= Library_Unit
(Item
);
8340 -- Take care to prevent direct cyclic with's
8342 if Lib_Unit
/= Current_Unit
then
8344 -- Do not add a unit if it is already in the context
8346 Clause
:= First
(Current_Context
);
8348 while Present
(Clause
) loop
8349 if Nkind
(Clause
) = N_With_Clause
and then
8350 Library_Unit
(Clause
) = Lib_Unit
8360 New_I
:= New_Copy
(Item
);
8361 Set_Implicit_With
(New_I
, True);
8362 Set_Implicit_With_From_Instantiation
(New_I
, True);
8363 Append
(New_I
, Current_Context
);
8371 end Inherit_Context
;
8377 procedure Initialize
is
8379 Generic_Renamings
.Init
;
8382 Generic_Renamings_HTable
.Reset
;
8383 Circularity_Detected
:= False;
8384 Exchanged_Views
:= No_Elist
;
8385 Hidden_Entities
:= No_Elist
;
8388 -------------------------------------
8389 -- Insert_Freeze_Node_For_Instance --
8390 -------------------------------------
8392 procedure Insert_Freeze_Node_For_Instance
8401 function Enclosing_Body
(N
: Node_Id
) return Node_Id
;
8402 -- Find enclosing package or subprogram body, if any. Freeze node may
8403 -- be placed at end of current declarative list if previous instance
8404 -- and current one have different enclosing bodies.
8406 function Previous_Instance
(Gen
: Entity_Id
) return Entity_Id
;
8407 -- Find the local instance, if any, that declares the generic that is
8408 -- being instantiated. If present, the freeze node for this instance
8409 -- must follow the freeze node for the previous instance.
8411 --------------------
8412 -- Enclosing_Body --
8413 --------------------
8415 function Enclosing_Body
(N
: Node_Id
) return Node_Id
is
8421 and then Nkind
(Parent
(P
)) /= N_Compilation_Unit
8423 if Nkind_In
(P
, N_Package_Body
, N_Subprogram_Body
) then
8424 if Nkind
(Parent
(P
)) = N_Subunit
then
8425 return Corresponding_Stub
(Parent
(P
));
8431 P
:= True_Parent
(P
);
8437 -----------------------
8438 -- Previous_Instance --
8439 -----------------------
8441 function Previous_Instance
(Gen
: Entity_Id
) return Entity_Id
is
8447 and then S
/= Standard_Standard
8449 if Is_Generic_Instance
(S
)
8450 and then In_Same_Source_Unit
(S
, N
)
8459 end Previous_Instance
;
8461 -- Start of processing for Insert_Freeze_Node_For_Instance
8464 if not Is_List_Member
(F_Node
) then
8466 Decls
:= List_Containing
(N
);
8467 Inst
:= Entity
(F_Node
);
8468 Par_N
:= Parent
(Decls
);
8470 -- When processing a subprogram instantiation, utilize the actual
8471 -- subprogram instantiation rather than its package wrapper as it
8472 -- carries all the context information.
8474 if Is_Wrapper_Package
(Inst
) then
8475 Inst
:= Related_Instance
(Inst
);
8478 -- If this is a package instance, check whether the generic is
8479 -- declared in a previous instance and the current instance is
8480 -- not within the previous one.
8482 if Present
(Generic_Parent
(Parent
(Inst
)))
8483 and then Is_In_Main_Unit
(N
)
8486 Enclosing_N
: constant Node_Id
:= Enclosing_Body
(N
);
8487 Par_I
: constant Entity_Id
:=
8489 (Generic_Parent
(Parent
(Inst
)));
8494 and then Earlier
(N
, Freeze_Node
(Par_I
))
8496 Scop
:= Scope
(Inst
);
8498 -- If the current instance is within the one that contains
8499 -- the generic, the freeze node for the current one must
8500 -- appear in the current declarative part. Ditto, if the
8501 -- current instance is within another package instance or
8502 -- within a body that does not enclose the current instance.
8503 -- In these three cases the freeze node of the previous
8504 -- instance is not relevant.
8506 while Present
(Scop
)
8507 and then Scop
/= Standard_Standard
8509 exit when Scop
= Par_I
8511 (Is_Generic_Instance
(Scop
)
8512 and then Scope_Depth
(Scop
) > Scope_Depth
(Par_I
));
8513 Scop
:= Scope
(Scop
);
8516 -- Previous instance encloses current instance
8518 if Scop
= Par_I
then
8521 -- If the next node is a source body we must freeze in
8522 -- the current scope as well.
8524 elsif Present
(Next
(N
))
8525 and then Nkind_In
(Next
(N
),
8526 N_Subprogram_Body
, N_Package_Body
)
8527 and then Comes_From_Source
(Next
(N
))
8531 -- Current instance is within an unrelated instance
8533 elsif Is_Generic_Instance
(Scop
) then
8536 -- Current instance is within an unrelated body
8538 elsif Present
(Enclosing_N
)
8539 and then Enclosing_N
/= Enclosing_Body
(Par_I
)
8544 Insert_After
(Freeze_Node
(Par_I
), F_Node
);
8551 -- When the instantiation occurs in a package declaration, append the
8552 -- freeze node to the private declarations (if any).
8554 if Nkind
(Par_N
) = N_Package_Specification
8555 and then Decls
= Visible_Declarations
(Par_N
)
8556 and then Present
(Private_Declarations
(Par_N
))
8557 and then not Is_Empty_List
(Private_Declarations
(Par_N
))
8559 Decls
:= Private_Declarations
(Par_N
);
8560 Decl
:= First
(Decls
);
8563 -- Determine the proper freeze point of a package instantiation. We
8564 -- adhere to the general rule of a package or subprogram body causing
8565 -- freezing of anything before it in the same declarative region. In
8566 -- this case, the proper freeze point of a package instantiation is
8567 -- before the first source body which follows, or before a stub. This
8568 -- ensures that entities coming from the instance are already frozen
8569 -- and usable in source bodies.
8571 if Nkind
(Par_N
) /= N_Package_Declaration
8572 and then Ekind
(Inst
) = E_Package
8573 and then Is_Generic_Instance
(Inst
)
8575 not In_Same_Source_Unit
(Generic_Parent
(Parent
(Inst
)), Inst
)
8577 while Present
(Decl
) loop
8578 if (Nkind
(Decl
) in N_Unit_Body
8580 Nkind
(Decl
) in N_Body_Stub
)
8581 and then Comes_From_Source
(Decl
)
8583 Insert_Before
(Decl
, F_Node
);
8591 -- In a package declaration, or if no previous body, insert at end
8594 Set_Sloc
(F_Node
, Sloc
(Last
(Decls
)));
8595 Insert_After
(Last
(Decls
), F_Node
);
8597 end Insert_Freeze_Node_For_Instance
;
8603 procedure Install_Body
8604 (Act_Body
: Node_Id
;
8609 Act_Id
: constant Entity_Id
:= Corresponding_Spec
(Act_Body
);
8610 Act_Unit
: constant Node_Id
:= Unit
(Cunit
(Get_Source_Unit
(N
)));
8611 Gen_Id
: constant Entity_Id
:= Corresponding_Spec
(Gen_Body
);
8612 Par
: constant Entity_Id
:= Scope
(Gen_Id
);
8613 Gen_Unit
: constant Node_Id
:=
8614 Unit
(Cunit
(Get_Source_Unit
(Gen_Decl
)));
8615 Orig_Body
: Node_Id
:= Gen_Body
;
8617 Body_Unit
: Node_Id
;
8619 Must_Delay
: Boolean;
8621 function In_Same_Enclosing_Subp
return Boolean;
8622 -- Check whether instance and generic body are within same subprogram.
8624 function True_Sloc
(N
: Node_Id
) return Source_Ptr
;
8625 -- If the instance is nested inside a generic unit, the Sloc of the
8626 -- instance indicates the place of the original definition, not the
8627 -- point of the current enclosing instance. Pending a better usage of
8628 -- Slocs to indicate instantiation places, we determine the place of
8629 -- origin of a node by finding the maximum sloc of any ancestor node.
8630 -- Why is this not equivalent to Top_Level_Location ???
8632 ----------------------------
8633 -- In_Same_Enclosing_Subp --
8634 ----------------------------
8636 function In_Same_Enclosing_Subp
return Boolean is
8641 Scop
:= Scope
(Act_Id
);
8642 while Scop
/= Standard_Standard
8643 and then not Is_Overloadable
(Scop
)
8645 Scop
:= Scope
(Scop
);
8648 if Scop
= Standard_Standard
then
8654 Scop
:= Scope
(Gen_Id
);
8655 while Scop
/= Standard_Standard
loop
8659 Scop
:= Scope
(Scop
);
8664 end In_Same_Enclosing_Subp
;
8670 function True_Sloc
(N
: Node_Id
) return Source_Ptr
is
8677 while Present
(N1
) and then N1
/= Act_Unit
loop
8678 if Sloc
(N1
) > Res
then
8688 -- Start of processing for Install_Body
8691 -- If the body is a subunit, the freeze point is the corresponding stub
8692 -- in the current compilation, not the subunit itself.
8694 if Nkind
(Parent
(Gen_Body
)) = N_Subunit
then
8695 Orig_Body
:= Corresponding_Stub
(Parent
(Gen_Body
));
8697 Orig_Body
:= Gen_Body
;
8700 Body_Unit
:= Unit
(Cunit
(Get_Source_Unit
(Orig_Body
)));
8702 -- If the instantiation and the generic definition appear in the same
8703 -- package declaration, this is an early instantiation. If they appear
8704 -- in the same declarative part, it is an early instantiation only if
8705 -- the generic body appears textually later, and the generic body is
8706 -- also in the main unit.
8708 -- If instance is nested within a subprogram, and the generic body
8709 -- is not, the instance is delayed because the enclosing body is. If
8710 -- instance and body are within the same scope, or the same subprogram
8711 -- body, indicate explicitly that the instance is delayed.
8714 (Gen_Unit
= Act_Unit
8715 and then (Nkind_In
(Gen_Unit
, N_Package_Declaration
,
8716 N_Generic_Package_Declaration
)
8717 or else (Gen_Unit
= Body_Unit
8718 and then True_Sloc
(N
) < Sloc
(Orig_Body
)))
8719 and then Is_In_Main_Unit
(Gen_Unit
)
8720 and then (Scope
(Act_Id
) = Scope
(Gen_Id
)
8721 or else In_Same_Enclosing_Subp
));
8723 -- If this is an early instantiation, the freeze node is placed after
8724 -- the generic body. Otherwise, if the generic appears in an instance,
8725 -- we cannot freeze the current instance until the outer one is frozen.
8726 -- This is only relevant if the current instance is nested within some
8727 -- inner scope not itself within the outer instance. If this scope is
8728 -- a package body in the same declarative part as the outer instance,
8729 -- then that body needs to be frozen after the outer instance. Finally,
8730 -- if no delay is needed, we place the freeze node at the end of the
8731 -- current declarative part.
8733 if Expander_Active
then
8734 Ensure_Freeze_Node
(Act_Id
);
8735 F_Node
:= Freeze_Node
(Act_Id
);
8738 Insert_After
(Orig_Body
, F_Node
);
8740 elsif Is_Generic_Instance
(Par
)
8741 and then Present
(Freeze_Node
(Par
))
8742 and then Scope
(Act_Id
) /= Par
8744 -- Freeze instance of inner generic after instance of enclosing
8747 if In_Same_Declarative_Part
(Freeze_Node
(Par
), N
) then
8749 -- Handle the following case:
8751 -- package Parent_Inst is new ...
8754 -- procedure P ... -- this body freezes Parent_Inst
8756 -- package Inst is new ...
8758 -- In this particular scenario, the freeze node for Inst must
8759 -- be inserted in the same manner as that of Parent_Inst,
8760 -- before the next source body or at the end of the declarative
8761 -- list (body not available). If body P did not exist and
8762 -- Parent_Inst was frozen after Inst, either by a body
8763 -- following Inst or at the end of the declarative region,
8764 -- the freeze node for Inst must be inserted after that of
8765 -- Parent_Inst. This relation is established by comparing
8766 -- the Slocs of Parent_Inst freeze node and Inst.
8768 if List_Containing
(Get_Package_Instantiation_Node
(Par
)) =
8770 and then Sloc
(Freeze_Node
(Par
)) < Sloc
(N
)
8772 Insert_Freeze_Node_For_Instance
(N
, F_Node
);
8774 Insert_After
(Freeze_Node
(Par
), F_Node
);
8777 -- Freeze package enclosing instance of inner generic after
8778 -- instance of enclosing generic.
8780 elsif Nkind_In
(Parent
(N
), N_Package_Body
, N_Subprogram_Body
)
8781 and then In_Same_Declarative_Part
(Freeze_Node
(Par
), Parent
(N
))
8784 Enclosing
: Entity_Id
;
8787 Enclosing
:= Corresponding_Spec
(Parent
(N
));
8789 if No
(Enclosing
) then
8790 Enclosing
:= Defining_Entity
(Parent
(N
));
8793 Insert_Freeze_Node_For_Instance
(N
, F_Node
);
8794 Ensure_Freeze_Node
(Enclosing
);
8796 if not Is_List_Member
(Freeze_Node
(Enclosing
)) then
8798 -- The enclosing context is a subunit, insert the freeze
8799 -- node after the stub.
8801 if Nkind
(Parent
(Parent
(N
))) = N_Subunit
then
8802 Insert_Freeze_Node_For_Instance
8803 (Corresponding_Stub
(Parent
(Parent
(N
))),
8804 Freeze_Node
(Enclosing
));
8806 -- The enclosing context is a package with a stub body
8807 -- which has already been replaced by the real body.
8808 -- Insert the freeze node after the actual body.
8810 elsif Ekind
(Enclosing
) = E_Package
8811 and then Present
(Body_Entity
(Enclosing
))
8812 and then Was_Originally_Stub
8813 (Parent
(Body_Entity
(Enclosing
)))
8815 Insert_Freeze_Node_For_Instance
8816 (Parent
(Body_Entity
(Enclosing
)),
8817 Freeze_Node
(Enclosing
));
8819 -- The parent instance has been frozen before the body of
8820 -- the enclosing package, insert the freeze node after
8823 elsif List_Containing
(Freeze_Node
(Par
)) =
8824 List_Containing
(Parent
(N
))
8825 and then Sloc
(Freeze_Node
(Par
)) < Sloc
(Parent
(N
))
8827 Insert_Freeze_Node_For_Instance
8828 (Parent
(N
), Freeze_Node
(Enclosing
));
8832 (Freeze_Node
(Par
), Freeze_Node
(Enclosing
));
8838 Insert_Freeze_Node_For_Instance
(N
, F_Node
);
8842 Insert_Freeze_Node_For_Instance
(N
, F_Node
);
8846 Set_Is_Frozen
(Act_Id
);
8847 Insert_Before
(N
, Act_Body
);
8848 Mark_Rewrite_Insertion
(Act_Body
);
8851 -----------------------------
8852 -- Install_Formal_Packages --
8853 -----------------------------
8855 procedure Install_Formal_Packages
(Par
: Entity_Id
) is
8858 Gen_E
: Entity_Id
:= Empty
;
8861 E
:= First_Entity
(Par
);
8863 -- If we are installing an instance parent, locate the formal packages
8864 -- of its generic parent.
8866 if Is_Generic_Instance
(Par
) then
8867 Gen
:= Generic_Parent
(Package_Specification
(Par
));
8868 Gen_E
:= First_Entity
(Gen
);
8871 while Present
(E
) loop
8872 if Ekind
(E
) = E_Package
8873 and then Nkind
(Parent
(E
)) = N_Package_Renaming_Declaration
8875 -- If this is the renaming for the parent instance, done
8877 if Renamed_Object
(E
) = Par
then
8880 -- The visibility of a formal of an enclosing generic is already
8883 elsif Denotes_Formal_Package
(E
) then
8886 elsif Present
(Associated_Formal_Package
(E
)) then
8887 Check_Generic_Actuals
(Renamed_Object
(E
), True);
8888 Set_Is_Hidden
(E
, False);
8890 -- Find formal package in generic unit that corresponds to
8891 -- (instance of) formal package in instance.
8893 while Present
(Gen_E
) and then Chars
(Gen_E
) /= Chars
(E
) loop
8894 Next_Entity
(Gen_E
);
8897 if Present
(Gen_E
) then
8898 Map_Formal_Package_Entities
(Gen_E
, E
);
8904 if Present
(Gen_E
) then
8905 Next_Entity
(Gen_E
);
8908 end Install_Formal_Packages
;
8910 --------------------
8911 -- Install_Parent --
8912 --------------------
8914 procedure Install_Parent
(P
: Entity_Id
; In_Body
: Boolean := False) is
8915 Ancestors
: constant Elist_Id
:= New_Elmt_List
;
8916 S
: constant Entity_Id
:= Current_Scope
;
8917 Inst_Par
: Entity_Id
;
8918 First_Par
: Entity_Id
;
8919 Inst_Node
: Node_Id
;
8920 Gen_Par
: Entity_Id
;
8921 First_Gen
: Entity_Id
;
8924 procedure Install_Noninstance_Specs
(Par
: Entity_Id
);
8925 -- Install the scopes of noninstance parent units ending with Par
8927 procedure Install_Spec
(Par
: Entity_Id
);
8928 -- The child unit is within the declarative part of the parent, so the
8929 -- declarations within the parent are immediately visible.
8931 -------------------------------
8932 -- Install_Noninstance_Specs --
8933 -------------------------------
8935 procedure Install_Noninstance_Specs
(Par
: Entity_Id
) is
8938 and then Par
/= Standard_Standard
8939 and then not In_Open_Scopes
(Par
)
8941 Install_Noninstance_Specs
(Scope
(Par
));
8944 end Install_Noninstance_Specs
;
8950 procedure Install_Spec
(Par
: Entity_Id
) is
8951 Spec
: constant Node_Id
:= Package_Specification
(Par
);
8954 -- If this parent of the child instance is a top-level unit,
8955 -- then record the unit and its visibility for later resetting in
8956 -- Remove_Parent. We exclude units that are generic instances, as we
8957 -- only want to record this information for the ultimate top-level
8958 -- noninstance parent (is that always correct???).
8960 if Scope
(Par
) = Standard_Standard
8961 and then not Is_Generic_Instance
(Par
)
8963 Parent_Unit_Visible
:= Is_Immediately_Visible
(Par
);
8964 Instance_Parent_Unit
:= Par
;
8967 -- Open the parent scope and make it and its declarations visible.
8968 -- If this point is not within a body, then only the visible
8969 -- declarations should be made visible, and installation of the
8970 -- private declarations is deferred until the appropriate point
8971 -- within analysis of the spec being instantiated (see the handling
8972 -- of parent visibility in Analyze_Package_Specification). This is
8973 -- relaxed in the case where the parent unit is Ada.Tags, to avoid
8974 -- private view problems that occur when compiling instantiations of
8975 -- a generic child of that package (Generic_Dispatching_Constructor).
8976 -- If the instance freezes a tagged type, inlinings of operations
8977 -- from Ada.Tags may need the full view of type Tag. If inlining took
8978 -- proper account of establishing visibility of inlined subprograms'
8979 -- parents then it should be possible to remove this
8980 -- special check. ???
8983 Set_Is_Immediately_Visible
(Par
);
8984 Install_Visible_Declarations
(Par
);
8985 Set_Use
(Visible_Declarations
(Spec
));
8987 if In_Body
or else Is_RTU
(Par
, Ada_Tags
) then
8988 Install_Private_Declarations
(Par
);
8989 Set_Use
(Private_Declarations
(Spec
));
8993 -- Start of processing for Install_Parent
8996 -- We need to install the parent instance to compile the instantiation
8997 -- of the child, but the child instance must appear in the current
8998 -- scope. Given that we cannot place the parent above the current scope
8999 -- in the scope stack, we duplicate the current scope and unstack both
9000 -- after the instantiation is complete.
9002 -- If the parent is itself the instantiation of a child unit, we must
9003 -- also stack the instantiation of its parent, and so on. Each such
9004 -- ancestor is the prefix of the name in a prior instantiation.
9006 -- If this is a nested instance, the parent unit itself resolves to
9007 -- a renaming of the parent instance, whose declaration we need.
9009 -- Finally, the parent may be a generic (not an instance) when the
9010 -- child unit appears as a formal package.
9014 if Present
(Renamed_Entity
(Inst_Par
)) then
9015 Inst_Par
:= Renamed_Entity
(Inst_Par
);
9018 First_Par
:= Inst_Par
;
9020 Gen_Par
:= Generic_Parent
(Package_Specification
(Inst_Par
));
9022 First_Gen
:= Gen_Par
;
9024 while Present
(Gen_Par
)
9025 and then Is_Child_Unit
(Gen_Par
)
9027 -- Load grandparent instance as well
9029 Inst_Node
:= Get_Package_Instantiation_Node
(Inst_Par
);
9031 if Nkind
(Name
(Inst_Node
)) = N_Expanded_Name
then
9032 Inst_Par
:= Entity
(Prefix
(Name
(Inst_Node
)));
9034 if Present
(Renamed_Entity
(Inst_Par
)) then
9035 Inst_Par
:= Renamed_Entity
(Inst_Par
);
9038 Gen_Par
:= Generic_Parent
(Package_Specification
(Inst_Par
));
9040 if Present
(Gen_Par
) then
9041 Prepend_Elmt
(Inst_Par
, Ancestors
);
9044 -- Parent is not the name of an instantiation
9046 Install_Noninstance_Specs
(Inst_Par
);
9057 if Present
(First_Gen
) then
9058 Append_Elmt
(First_Par
, Ancestors
);
9060 Install_Noninstance_Specs
(First_Par
);
9063 if not Is_Empty_Elmt_List
(Ancestors
) then
9064 Elmt
:= First_Elmt
(Ancestors
);
9065 while Present
(Elmt
) loop
9066 Install_Spec
(Node
(Elmt
));
9067 Install_Formal_Packages
(Node
(Elmt
));
9077 -------------------------------
9078 -- Install_Hidden_Primitives --
9079 -------------------------------
9081 procedure Install_Hidden_Primitives
9082 (Prims_List
: in out Elist_Id
;
9087 List
: Elist_Id
:= No_Elist
;
9088 Prim_G_Elmt
: Elmt_Id
;
9089 Prim_A_Elmt
: Elmt_Id
;
9094 -- No action needed in case of serious errors because we cannot trust
9095 -- in the order of primitives
9097 if Serious_Errors_Detected
> 0 then
9100 -- No action possible if we don't have available the list of primitive
9104 or else not Is_Record_Type
(Gen_T
)
9105 or else not Is_Tagged_Type
(Gen_T
)
9106 or else not Is_Record_Type
(Act_T
)
9107 or else not Is_Tagged_Type
(Act_T
)
9111 -- There is no need to handle interface types since their primitives
9114 elsif Is_Interface
(Gen_T
) then
9118 Prim_G_Elmt
:= First_Elmt
(Primitive_Operations
(Gen_T
));
9120 if not Is_Class_Wide_Type
(Act_T
) then
9121 Prim_A_Elmt
:= First_Elmt
(Primitive_Operations
(Act_T
));
9123 Prim_A_Elmt
:= First_Elmt
(Primitive_Operations
(Root_Type
(Act_T
)));
9127 -- Skip predefined primitives in the generic formal
9129 while Present
(Prim_G_Elmt
)
9130 and then Is_Predefined_Dispatching_Operation
(Node
(Prim_G_Elmt
))
9132 Next_Elmt
(Prim_G_Elmt
);
9135 -- Skip predefined primitives in the generic actual
9137 while Present
(Prim_A_Elmt
)
9138 and then Is_Predefined_Dispatching_Operation
(Node
(Prim_A_Elmt
))
9140 Next_Elmt
(Prim_A_Elmt
);
9143 exit when No
(Prim_G_Elmt
) or else No
(Prim_A_Elmt
);
9145 Prim_G
:= Node
(Prim_G_Elmt
);
9146 Prim_A
:= Node
(Prim_A_Elmt
);
9148 -- There is no need to handle interface primitives because their
9149 -- primitives are not hidden
9151 exit when Present
(Interface_Alias
(Prim_G
));
9153 -- Here we install one hidden primitive
9155 if Chars
(Prim_G
) /= Chars
(Prim_A
)
9156 and then Has_Suffix
(Prim_A
, 'P')
9157 and then Remove_Suffix
(Prim_A
, 'P') = Chars
(Prim_G
)
9159 Set_Chars
(Prim_A
, Chars
(Prim_G
));
9160 Append_New_Elmt
(Prim_A
, To
=> List
);
9163 Next_Elmt
(Prim_A_Elmt
);
9164 Next_Elmt
(Prim_G_Elmt
);
9167 -- Append the elements to the list of temporarily visible primitives
9168 -- avoiding duplicates.
9170 if Present
(List
) then
9171 if No
(Prims_List
) then
9172 Prims_List
:= New_Elmt_List
;
9175 Elmt
:= First_Elmt
(List
);
9176 while Present
(Elmt
) loop
9177 Append_Unique_Elmt
(Node
(Elmt
), Prims_List
);
9181 end Install_Hidden_Primitives
;
9183 -------------------------------
9184 -- Restore_Hidden_Primitives --
9185 -------------------------------
9187 procedure Restore_Hidden_Primitives
(Prims_List
: in out Elist_Id
) is
9188 Prim_Elmt
: Elmt_Id
;
9192 if Prims_List
/= No_Elist
then
9193 Prim_Elmt
:= First_Elmt
(Prims_List
);
9194 while Present
(Prim_Elmt
) loop
9195 Prim
:= Node
(Prim_Elmt
);
9196 Set_Chars
(Prim
, Add_Suffix
(Prim
, 'P'));
9197 Next_Elmt
(Prim_Elmt
);
9200 Prims_List
:= No_Elist
;
9202 end Restore_Hidden_Primitives
;
9204 --------------------------------
9205 -- Instantiate_Formal_Package --
9206 --------------------------------
9208 function Instantiate_Formal_Package
9211 Analyzed_Formal
: Node_Id
) return List_Id
9213 Loc
: constant Source_Ptr
:= Sloc
(Actual
);
9214 Actual_Pack
: Entity_Id
;
9215 Formal_Pack
: Entity_Id
;
9216 Gen_Parent
: Entity_Id
;
9219 Parent_Spec
: Node_Id
;
9221 procedure Find_Matching_Actual
9223 Act
: in out Entity_Id
);
9224 -- We need to associate each formal entity in the formal package with
9225 -- the corresponding entity in the actual package. The actual package
9226 -- has been analyzed and possibly expanded, and as a result there is
9227 -- no one-to-one correspondence between the two lists (for example,
9228 -- the actual may include subtypes, itypes, and inherited primitive
9229 -- operations, interspersed among the renaming declarations for the
9230 -- actuals) . We retrieve the corresponding actual by name because each
9231 -- actual has the same name as the formal, and they do appear in the
9234 function Get_Formal_Entity
(N
: Node_Id
) return Entity_Id
;
9235 -- Retrieve entity of defining entity of generic formal parameter.
9236 -- Only the declarations of formals need to be considered when
9237 -- linking them to actuals, but the declarative list may include
9238 -- internal entities generated during analysis, and those are ignored.
9240 procedure Match_Formal_Entity
9241 (Formal_Node
: Node_Id
;
9242 Formal_Ent
: Entity_Id
;
9243 Actual_Ent
: Entity_Id
);
9244 -- Associates the formal entity with the actual. In the case where
9245 -- Formal_Ent is a formal package, this procedure iterates through all
9246 -- of its formals and enters associations between the actuals occurring
9247 -- in the formal package's corresponding actual package (given by
9248 -- Actual_Ent) and the formal package's formal parameters. This
9249 -- procedure recurses if any of the parameters is itself a package.
9251 function Is_Instance_Of
9252 (Act_Spec
: Entity_Id
;
9253 Gen_Anc
: Entity_Id
) return Boolean;
9254 -- The actual can be an instantiation of a generic within another
9255 -- instance, in which case there is no direct link from it to the
9256 -- original generic ancestor. In that case, we recognize that the
9257 -- ultimate ancestor is the same by examining names and scopes.
9259 procedure Process_Nested_Formal
(Formal
: Entity_Id
);
9260 -- If the current formal is declared with a box, its own formals are
9261 -- visible in the instance, as they were in the generic, and their
9262 -- Hidden flag must be reset. If some of these formals are themselves
9263 -- packages declared with a box, the processing must be recursive.
9265 --------------------------
9266 -- Find_Matching_Actual --
9267 --------------------------
9269 procedure Find_Matching_Actual
9271 Act
: in out Entity_Id
)
9273 Formal_Ent
: Entity_Id
;
9276 case Nkind
(Original_Node
(F
)) is
9277 when N_Formal_Object_Declaration |
9278 N_Formal_Type_Declaration
=>
9279 Formal_Ent
:= Defining_Identifier
(F
);
9281 while Chars
(Act
) /= Chars
(Formal_Ent
) loop
9285 when N_Formal_Subprogram_Declaration |
9286 N_Formal_Package_Declaration |
9287 N_Package_Declaration |
9288 N_Generic_Package_Declaration
=>
9289 Formal_Ent
:= Defining_Entity
(F
);
9291 while Chars
(Act
) /= Chars
(Formal_Ent
) loop
9296 raise Program_Error
;
9298 end Find_Matching_Actual
;
9300 -------------------------
9301 -- Match_Formal_Entity --
9302 -------------------------
9304 procedure Match_Formal_Entity
9305 (Formal_Node
: Node_Id
;
9306 Formal_Ent
: Entity_Id
;
9307 Actual_Ent
: Entity_Id
)
9309 Act_Pkg
: Entity_Id
;
9312 Set_Instance_Of
(Formal_Ent
, Actual_Ent
);
9314 if Ekind
(Actual_Ent
) = E_Package
then
9316 -- Record associations for each parameter
9318 Act_Pkg
:= Actual_Ent
;
9321 A_Ent
: Entity_Id
:= First_Entity
(Act_Pkg
);
9330 -- Retrieve the actual given in the formal package declaration
9332 Actual
:= Entity
(Name
(Original_Node
(Formal_Node
)));
9334 -- The actual in the formal package declaration may be a
9335 -- renamed generic package, in which case we want to retrieve
9336 -- the original generic in order to traverse its formal part.
9338 if Present
(Renamed_Entity
(Actual
)) then
9339 Gen_Decl
:= Unit_Declaration_Node
(Renamed_Entity
(Actual
));
9341 Gen_Decl
:= Unit_Declaration_Node
(Actual
);
9344 Formals
:= Generic_Formal_Declarations
(Gen_Decl
);
9346 if Present
(Formals
) then
9347 F_Node
:= First_Non_Pragma
(Formals
);
9352 while Present
(A_Ent
)
9353 and then Present
(F_Node
)
9354 and then A_Ent
/= First_Private_Entity
(Act_Pkg
)
9356 F_Ent
:= Get_Formal_Entity
(F_Node
);
9358 if Present
(F_Ent
) then
9360 -- This is a formal of the original package. Record
9361 -- association and recurse.
9363 Find_Matching_Actual
(F_Node
, A_Ent
);
9364 Match_Formal_Entity
(F_Node
, F_Ent
, A_Ent
);
9365 Next_Entity
(A_Ent
);
9368 Next_Non_Pragma
(F_Node
);
9372 end Match_Formal_Entity
;
9374 -----------------------
9375 -- Get_Formal_Entity --
9376 -----------------------
9378 function Get_Formal_Entity
(N
: Node_Id
) return Entity_Id
is
9379 Kind
: constant Node_Kind
:= Nkind
(Original_Node
(N
));
9382 when N_Formal_Object_Declaration
=>
9383 return Defining_Identifier
(N
);
9385 when N_Formal_Type_Declaration
=>
9386 return Defining_Identifier
(N
);
9388 when N_Formal_Subprogram_Declaration
=>
9389 return Defining_Unit_Name
(Specification
(N
));
9391 when N_Formal_Package_Declaration
=>
9392 return Defining_Identifier
(Original_Node
(N
));
9394 when N_Generic_Package_Declaration
=>
9395 return Defining_Identifier
(Original_Node
(N
));
9397 -- All other declarations are introduced by semantic analysis and
9398 -- have no match in the actual.
9403 end Get_Formal_Entity
;
9405 --------------------
9406 -- Is_Instance_Of --
9407 --------------------
9409 function Is_Instance_Of
9410 (Act_Spec
: Entity_Id
;
9411 Gen_Anc
: Entity_Id
) return Boolean
9413 Gen_Par
: constant Entity_Id
:= Generic_Parent
(Act_Spec
);
9416 if No
(Gen_Par
) then
9419 -- Simplest case: the generic parent of the actual is the formal
9421 elsif Gen_Par
= Gen_Anc
then
9424 elsif Chars
(Gen_Par
) /= Chars
(Gen_Anc
) then
9427 -- The actual may be obtained through several instantiations. Its
9428 -- scope must itself be an instance of a generic declared in the
9429 -- same scope as the formal. Any other case is detected above.
9431 elsif not Is_Generic_Instance
(Scope
(Gen_Par
)) then
9435 return Generic_Parent
(Parent
(Scope
(Gen_Par
))) = Scope
(Gen_Anc
);
9439 ---------------------------
9440 -- Process_Nested_Formal --
9441 ---------------------------
9443 procedure Process_Nested_Formal
(Formal
: Entity_Id
) is
9447 if Present
(Associated_Formal_Package
(Formal
))
9448 and then Box_Present
(Parent
(Associated_Formal_Package
(Formal
)))
9450 Ent
:= First_Entity
(Formal
);
9451 while Present
(Ent
) loop
9452 Set_Is_Hidden
(Ent
, False);
9453 Set_Is_Visible_Formal
(Ent
);
9454 Set_Is_Potentially_Use_Visible
9455 (Ent
, Is_Potentially_Use_Visible
(Formal
));
9457 if Ekind
(Ent
) = E_Package
then
9458 exit when Renamed_Entity
(Ent
) = Renamed_Entity
(Formal
);
9459 Process_Nested_Formal
(Ent
);
9465 end Process_Nested_Formal
;
9467 -- Start of processing for Instantiate_Formal_Package
9472 if not Is_Entity_Name
(Actual
)
9473 or else Ekind
(Entity
(Actual
)) /= E_Package
9476 ("expect package instance to instantiate formal", Actual
);
9477 Abandon_Instantiation
(Actual
);
9478 raise Program_Error
;
9481 Actual_Pack
:= Entity
(Actual
);
9482 Set_Is_Instantiated
(Actual_Pack
);
9484 -- The actual may be a renamed package, or an outer generic formal
9485 -- package whose instantiation is converted into a renaming.
9487 if Present
(Renamed_Object
(Actual_Pack
)) then
9488 Actual_Pack
:= Renamed_Object
(Actual_Pack
);
9491 if Nkind
(Analyzed_Formal
) = N_Formal_Package_Declaration
then
9492 Gen_Parent
:= Get_Instance_Of
(Entity
(Name
(Analyzed_Formal
)));
9493 Formal_Pack
:= Defining_Identifier
(Analyzed_Formal
);
9496 Generic_Parent
(Specification
(Analyzed_Formal
));
9498 Defining_Unit_Name
(Specification
(Analyzed_Formal
));
9501 if Nkind
(Parent
(Actual_Pack
)) = N_Defining_Program_Unit_Name
then
9502 Parent_Spec
:= Package_Specification
(Actual_Pack
);
9504 Parent_Spec
:= Parent
(Actual_Pack
);
9507 if Gen_Parent
= Any_Id
then
9509 ("previous error in declaration of formal package", Actual
);
9510 Abandon_Instantiation
(Actual
);
9513 Is_Instance_Of
(Parent_Spec
, Get_Instance_Of
(Gen_Parent
))
9519 ("actual parameter must be instance of&", Actual
, Gen_Parent
);
9520 Abandon_Instantiation
(Actual
);
9523 Set_Instance_Of
(Defining_Identifier
(Formal
), Actual_Pack
);
9524 Map_Formal_Package_Entities
(Formal_Pack
, Actual_Pack
);
9527 Make_Package_Renaming_Declaration
(Loc
,
9528 Defining_Unit_Name
=> New_Copy
(Defining_Identifier
(Formal
)),
9529 Name
=> New_Occurrence_Of
(Actual_Pack
, Loc
));
9531 Set_Associated_Formal_Package
(Defining_Unit_Name
(Nod
),
9532 Defining_Identifier
(Formal
));
9533 Decls
:= New_List
(Nod
);
9535 -- If the formal F has a box, then the generic declarations are
9536 -- visible in the generic G. In an instance of G, the corresponding
9537 -- entities in the actual for F (which are the actuals for the
9538 -- instantiation of the generic that F denotes) must also be made
9539 -- visible for analysis of the current instance. On exit from the
9540 -- current instance, those entities are made private again. If the
9541 -- actual is currently in use, these entities are also use-visible.
9543 -- The loop through the actual entities also steps through the formal
9544 -- entities and enters associations from formals to actuals into the
9545 -- renaming map. This is necessary to properly handle checking of
9546 -- actual parameter associations for later formals that depend on
9547 -- actuals declared in the formal package.
9549 -- In Ada 2005, partial parameterization requires that we make
9550 -- visible the actuals corresponding to formals that were defaulted
9551 -- in the formal package. There formals are identified because they
9552 -- remain formal generics within the formal package, rather than
9553 -- being renamings of the actuals supplied.
9556 Gen_Decl
: constant Node_Id
:=
9557 Unit_Declaration_Node
(Gen_Parent
);
9558 Formals
: constant List_Id
:=
9559 Generic_Formal_Declarations
(Gen_Decl
);
9561 Actual_Ent
: Entity_Id
;
9562 Actual_Of_Formal
: Node_Id
;
9563 Formal_Node
: Node_Id
;
9564 Formal_Ent
: Entity_Id
;
9567 if Present
(Formals
) then
9568 Formal_Node
:= First_Non_Pragma
(Formals
);
9570 Formal_Node
:= Empty
;
9573 Actual_Ent
:= First_Entity
(Actual_Pack
);
9575 First
(Visible_Declarations
(Specification
(Analyzed_Formal
)));
9576 while Present
(Actual_Ent
)
9577 and then Actual_Ent
/= First_Private_Entity
(Actual_Pack
)
9579 if Present
(Formal_Node
) then
9580 Formal_Ent
:= Get_Formal_Entity
(Formal_Node
);
9582 if Present
(Formal_Ent
) then
9583 Find_Matching_Actual
(Formal_Node
, Actual_Ent
);
9585 (Formal_Node
, Formal_Ent
, Actual_Ent
);
9587 -- We iterate at the same time over the actuals of the
9588 -- local package created for the formal, to determine
9589 -- which one of the formals of the original generic were
9590 -- defaulted in the formal. The corresponding actual
9591 -- entities are visible in the enclosing instance.
9593 if Box_Present
(Formal
)
9595 (Present
(Actual_Of_Formal
)
9598 (Get_Formal_Entity
(Actual_Of_Formal
)))
9600 Set_Is_Hidden
(Actual_Ent
, False);
9601 Set_Is_Visible_Formal
(Actual_Ent
);
9602 Set_Is_Potentially_Use_Visible
9603 (Actual_Ent
, In_Use
(Actual_Pack
));
9605 if Ekind
(Actual_Ent
) = E_Package
then
9606 Process_Nested_Formal
(Actual_Ent
);
9610 Set_Is_Hidden
(Actual_Ent
);
9611 Set_Is_Potentially_Use_Visible
(Actual_Ent
, False);
9615 Next_Non_Pragma
(Formal_Node
);
9616 Next
(Actual_Of_Formal
);
9619 -- No further formals to match, but the generic part may
9620 -- contain inherited operation that are not hidden in the
9621 -- enclosing instance.
9623 Next_Entity
(Actual_Ent
);
9627 -- Inherited subprograms generated by formal derived types are
9628 -- also visible if the types are.
9630 Actual_Ent
:= First_Entity
(Actual_Pack
);
9631 while Present
(Actual_Ent
)
9632 and then Actual_Ent
/= First_Private_Entity
(Actual_Pack
)
9634 if Is_Overloadable
(Actual_Ent
)
9636 Nkind
(Parent
(Actual_Ent
)) = N_Subtype_Declaration
9638 not Is_Hidden
(Defining_Identifier
(Parent
(Actual_Ent
)))
9640 Set_Is_Hidden
(Actual_Ent
, False);
9641 Set_Is_Potentially_Use_Visible
9642 (Actual_Ent
, In_Use
(Actual_Pack
));
9645 Next_Entity
(Actual_Ent
);
9649 -- If the formal is not declared with a box, reanalyze it as an
9650 -- abbreviated instantiation, to verify the matching rules of 12.7.
9651 -- The actual checks are performed after the generic associations
9652 -- have been analyzed, to guarantee the same visibility for this
9653 -- instantiation and for the actuals.
9655 -- In Ada 2005, the generic associations for the formal can include
9656 -- defaulted parameters. These are ignored during check. This
9657 -- internal instantiation is removed from the tree after conformance
9658 -- checking, because it contains formal declarations for those
9659 -- defaulted parameters, and those should not reach the back-end.
9661 if not Box_Present
(Formal
) then
9663 I_Pack
: constant Entity_Id
:=
9664 Make_Temporary
(Sloc
(Actual
), 'P');
9667 Set_Is_Internal
(I_Pack
);
9670 Make_Package_Instantiation
(Sloc
(Actual
),
9671 Defining_Unit_Name
=> I_Pack
,
9674 (Get_Instance_Of
(Gen_Parent
), Sloc
(Actual
)),
9675 Generic_Associations
=>
9676 Generic_Associations
(Formal
)));
9682 end Instantiate_Formal_Package
;
9684 -----------------------------------
9685 -- Instantiate_Formal_Subprogram --
9686 -----------------------------------
9688 function Instantiate_Formal_Subprogram
9691 Analyzed_Formal
: Node_Id
) return Node_Id
9693 Analyzed_S
: constant Entity_Id
:=
9694 Defining_Unit_Name
(Specification
(Analyzed_Formal
));
9695 Formal_Sub
: constant Entity_Id
:=
9696 Defining_Unit_Name
(Specification
(Formal
));
9698 function From_Parent_Scope
(Subp
: Entity_Id
) return Boolean;
9699 -- If the generic is a child unit, the parent has been installed on the
9700 -- scope stack, but a default subprogram cannot resolve to something
9701 -- on the parent because that parent is not really part of the visible
9702 -- context (it is there to resolve explicit local entities). If the
9703 -- default has resolved in this way, we remove the entity from immediate
9704 -- visibility and analyze the node again to emit an error message or
9705 -- find another visible candidate.
9707 procedure Valid_Actual_Subprogram
(Act
: Node_Id
);
9708 -- Perform legality check and raise exception on failure
9710 -----------------------
9711 -- From_Parent_Scope --
9712 -----------------------
9714 function From_Parent_Scope
(Subp
: Entity_Id
) return Boolean is
9715 Gen_Scope
: Node_Id
;
9718 Gen_Scope
:= Scope
(Analyzed_S
);
9719 while Present
(Gen_Scope
) and then Is_Child_Unit
(Gen_Scope
) loop
9720 if Scope
(Subp
) = Scope
(Gen_Scope
) then
9724 Gen_Scope
:= Scope
(Gen_Scope
);
9728 end From_Parent_Scope
;
9730 -----------------------------
9731 -- Valid_Actual_Subprogram --
9732 -----------------------------
9734 procedure Valid_Actual_Subprogram
(Act
: Node_Id
) is
9738 if Is_Entity_Name
(Act
) then
9739 Act_E
:= Entity
(Act
);
9741 elsif Nkind
(Act
) = N_Selected_Component
9742 and then Is_Entity_Name
(Selector_Name
(Act
))
9744 Act_E
:= Entity
(Selector_Name
(Act
));
9750 if (Present
(Act_E
) and then Is_Overloadable
(Act_E
))
9751 or else Nkind_In
(Act
, N_Attribute_Reference
,
9752 N_Indexed_Component
,
9753 N_Character_Literal
,
9754 N_Explicit_Dereference
)
9760 ("expect subprogram or entry name in instantiation of&",
9761 Instantiation_Node
, Formal_Sub
);
9762 Abandon_Instantiation
(Instantiation_Node
);
9763 end Valid_Actual_Subprogram
;
9767 Decl_Node
: Node_Id
;
9771 New_Subp
: Entity_Id
;
9773 -- Start of processing for Instantiate_Formal_Subprogram
9776 New_Spec
:= New_Copy_Tree
(Specification
(Formal
));
9778 -- The tree copy has created the proper instantiation sloc for the
9779 -- new specification. Use this location for all other constructed
9782 Loc
:= Sloc
(Defining_Unit_Name
(New_Spec
));
9784 -- Create new entity for the actual (New_Copy_Tree does not), and
9785 -- indicate that it is an actual.
9787 New_Subp
:= Make_Defining_Identifier
(Loc
, Chars
(Formal_Sub
));
9788 Set_Ekind
(New_Subp
, Ekind
(Analyzed_S
));
9789 Set_Is_Generic_Actual_Subprogram
(New_Subp
);
9790 Set_Defining_Unit_Name
(New_Spec
, New_Subp
);
9792 -- Create new entities for the each of the formals in the specification
9793 -- of the renaming declaration built for the actual.
9795 if Present
(Parameter_Specifications
(New_Spec
)) then
9801 F
:= First
(Parameter_Specifications
(New_Spec
));
9802 while Present
(F
) loop
9803 F_Id
:= Defining_Identifier
(F
);
9805 Set_Defining_Identifier
(F
,
9806 Make_Defining_Identifier
(Sloc
(F_Id
), Chars
(F_Id
)));
9812 -- Find entity of actual. If the actual is an attribute reference, it
9813 -- cannot be resolved here (its formal is missing) but is handled
9814 -- instead in Attribute_Renaming. If the actual is overloaded, it is
9815 -- fully resolved subsequently, when the renaming declaration for the
9816 -- formal is analyzed. If it is an explicit dereference, resolve the
9817 -- prefix but not the actual itself, to prevent interpretation as call.
9819 if Present
(Actual
) then
9820 Loc
:= Sloc
(Actual
);
9821 Set_Sloc
(New_Spec
, Loc
);
9823 if Nkind
(Actual
) = N_Operator_Symbol
then
9824 Find_Direct_Name
(Actual
);
9826 elsif Nkind
(Actual
) = N_Explicit_Dereference
then
9827 Analyze
(Prefix
(Actual
));
9829 elsif Nkind
(Actual
) /= N_Attribute_Reference
then
9833 Valid_Actual_Subprogram
(Actual
);
9836 elsif Present
(Default_Name
(Formal
)) then
9837 if not Nkind_In
(Default_Name
(Formal
), N_Attribute_Reference
,
9838 N_Selected_Component
,
9839 N_Indexed_Component
,
9840 N_Character_Literal
)
9841 and then Present
(Entity
(Default_Name
(Formal
)))
9843 Nam
:= New_Occurrence_Of
(Entity
(Default_Name
(Formal
)), Loc
);
9845 Nam
:= New_Copy
(Default_Name
(Formal
));
9846 Set_Sloc
(Nam
, Loc
);
9849 elsif Box_Present
(Formal
) then
9851 -- Actual is resolved at the point of instantiation. Create an
9852 -- identifier or operator with the same name as the formal.
9854 if Nkind
(Formal_Sub
) = N_Defining_Operator_Symbol
then
9856 Make_Operator_Symbol
(Loc
,
9857 Chars
=> Chars
(Formal_Sub
),
9858 Strval
=> No_String
);
9860 Nam
:= Make_Identifier
(Loc
, Chars
(Formal_Sub
));
9863 elsif Nkind
(Specification
(Formal
)) = N_Procedure_Specification
9864 and then Null_Present
(Specification
(Formal
))
9866 -- Generate null body for procedure, for use in the instance
9869 Make_Subprogram_Body
(Loc
,
9870 Specification
=> New_Spec
,
9871 Declarations
=> New_List
,
9872 Handled_Statement_Sequence
=>
9873 Make_Handled_Sequence_Of_Statements
(Loc
,
9874 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
9876 Set_Is_Intrinsic_Subprogram
(Defining_Unit_Name
(New_Spec
));
9880 Error_Msg_Sloc
:= Sloc
(Scope
(Analyzed_S
));
9882 ("missing actual&", Instantiation_Node
, Formal_Sub
);
9884 ("\in instantiation of & declared#",
9885 Instantiation_Node
, Scope
(Analyzed_S
));
9886 Abandon_Instantiation
(Instantiation_Node
);
9890 Make_Subprogram_Renaming_Declaration
(Loc
,
9891 Specification
=> New_Spec
,
9894 -- If we do not have an actual and the formal specified <> then set to
9895 -- get proper default.
9897 if No
(Actual
) and then Box_Present
(Formal
) then
9898 Set_From_Default
(Decl_Node
);
9901 -- Gather possible interpretations for the actual before analyzing the
9902 -- instance. If overloaded, it will be resolved when analyzing the
9903 -- renaming declaration.
9905 if Box_Present
(Formal
) and then No
(Actual
) then
9908 if Is_Child_Unit
(Scope
(Analyzed_S
))
9909 and then Present
(Entity
(Nam
))
9911 if not Is_Overloaded
(Nam
) then
9912 if From_Parent_Scope
(Entity
(Nam
)) then
9913 Set_Is_Immediately_Visible
(Entity
(Nam
), False);
9914 Set_Entity
(Nam
, Empty
);
9915 Set_Etype
(Nam
, Empty
);
9918 Set_Is_Immediately_Visible
(Entity
(Nam
));
9927 Get_First_Interp
(Nam
, I
, It
);
9928 while Present
(It
.Nam
) loop
9929 if From_Parent_Scope
(It
.Nam
) then
9933 Get_Next_Interp
(I
, It
);
9940 -- The generic instantiation freezes the actual. This can only be done
9941 -- once the actual is resolved, in the analysis of the renaming
9942 -- declaration. To make the formal subprogram entity available, we set
9943 -- Corresponding_Formal_Spec to point to the formal subprogram entity.
9944 -- This is also needed in Analyze_Subprogram_Renaming for the processing
9945 -- of formal abstract subprograms.
9947 Set_Corresponding_Formal_Spec
(Decl_Node
, Analyzed_S
);
9949 -- We cannot analyze the renaming declaration, and thus find the actual,
9950 -- until all the actuals are assembled in the instance. For subsequent
9951 -- checks of other actuals, indicate the node that will hold the
9952 -- instance of this formal.
9954 Set_Instance_Of
(Analyzed_S
, Nam
);
9956 if Nkind
(Actual
) = N_Selected_Component
9957 and then Is_Task_Type
(Etype
(Prefix
(Actual
)))
9958 and then not Is_Frozen
(Etype
(Prefix
(Actual
)))
9960 -- The renaming declaration will create a body, which must appear
9961 -- outside of the instantiation, We move the renaming declaration
9962 -- out of the instance, and create an additional renaming inside,
9963 -- to prevent freezing anomalies.
9966 Anon_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E');
9969 Set_Defining_Unit_Name
(New_Spec
, Anon_Id
);
9970 Insert_Before
(Instantiation_Node
, Decl_Node
);
9971 Analyze
(Decl_Node
);
9973 -- Now create renaming within the instance
9976 Make_Subprogram_Renaming_Declaration
(Loc
,
9977 Specification
=> New_Copy_Tree
(New_Spec
),
9978 Name
=> New_Occurrence_Of
(Anon_Id
, Loc
));
9980 Set_Defining_Unit_Name
(Specification
(Decl_Node
),
9981 Make_Defining_Identifier
(Loc
, Chars
(Formal_Sub
)));
9986 end Instantiate_Formal_Subprogram
;
9988 ------------------------
9989 -- Instantiate_Object --
9990 ------------------------
9992 function Instantiate_Object
9995 Analyzed_Formal
: Node_Id
) return List_Id
9997 Gen_Obj
: constant Entity_Id
:= Defining_Identifier
(Formal
);
9998 A_Gen_Obj
: constant Entity_Id
:=
9999 Defining_Identifier
(Analyzed_Formal
);
10000 Acc_Def
: Node_Id
:= Empty
;
10001 Act_Assoc
: constant Node_Id
:= Parent
(Actual
);
10002 Actual_Decl
: Node_Id
:= Empty
;
10003 Decl_Node
: Node_Id
;
10006 List
: constant List_Id
:= New_List
;
10007 Loc
: constant Source_Ptr
:= Sloc
(Actual
);
10008 Orig_Ftyp
: constant Entity_Id
:= Etype
(A_Gen_Obj
);
10009 Subt_Decl
: Node_Id
:= Empty
;
10010 Subt_Mark
: Node_Id
:= Empty
;
10013 if Present
(Subtype_Mark
(Formal
)) then
10014 Subt_Mark
:= Subtype_Mark
(Formal
);
10016 Check_Access_Definition
(Formal
);
10017 Acc_Def
:= Access_Definition
(Formal
);
10020 -- Sloc for error message on missing actual
10022 Error_Msg_Sloc
:= Sloc
(Scope
(A_Gen_Obj
));
10024 if Get_Instance_Of
(Gen_Obj
) /= Gen_Obj
then
10025 Error_Msg_N
("duplicate instantiation of generic parameter", Actual
);
10028 Set_Parent
(List
, Parent
(Actual
));
10032 if Out_Present
(Formal
) then
10034 -- An IN OUT generic actual must be a name. The instantiation is a
10035 -- renaming declaration. The actual is the name being renamed. We
10036 -- use the actual directly, rather than a copy, because it is not
10037 -- used further in the list of actuals, and because a copy or a use
10038 -- of relocate_node is incorrect if the instance is nested within a
10039 -- generic. In order to simplify ASIS searches, the Generic_Parent
10040 -- field links the declaration to the generic association.
10042 if No
(Actual
) then
10044 ("missing actual&",
10045 Instantiation_Node
, Gen_Obj
);
10047 ("\in instantiation of & declared#",
10048 Instantiation_Node
, Scope
(A_Gen_Obj
));
10049 Abandon_Instantiation
(Instantiation_Node
);
10052 if Present
(Subt_Mark
) then
10054 Make_Object_Renaming_Declaration
(Loc
,
10055 Defining_Identifier
=> New_Copy
(Gen_Obj
),
10056 Subtype_Mark
=> New_Copy_Tree
(Subt_Mark
),
10059 else pragma Assert
(Present
(Acc_Def
));
10061 Make_Object_Renaming_Declaration
(Loc
,
10062 Defining_Identifier
=> New_Copy
(Gen_Obj
),
10063 Access_Definition
=> New_Copy_Tree
(Acc_Def
),
10067 Set_Corresponding_Generic_Association
(Decl_Node
, Act_Assoc
);
10069 -- The analysis of the actual may produce Insert_Action nodes, so
10070 -- the declaration must have a context in which to attach them.
10072 Append
(Decl_Node
, List
);
10075 -- Return if the analysis of the actual reported some error
10077 if Etype
(Actual
) = Any_Type
then
10081 -- This check is performed here because Analyze_Object_Renaming will
10082 -- not check it when Comes_From_Source is False. Note though that the
10083 -- check for the actual being the name of an object will be performed
10084 -- in Analyze_Object_Renaming.
10086 if Is_Object_Reference
(Actual
)
10087 and then Is_Dependent_Component_Of_Mutable_Object
(Actual
)
10090 ("illegal discriminant-dependent component for in out parameter",
10094 -- The actual has to be resolved in order to check that it is a
10095 -- variable (due to cases such as F (1), where F returns access to
10096 -- an array, and for overloaded prefixes).
10098 Ftyp
:= Get_Instance_Of
(Etype
(A_Gen_Obj
));
10100 -- If the type of the formal is not itself a formal, and the current
10101 -- unit is a child unit, the formal type must be declared in a
10102 -- parent, and must be retrieved by visibility.
10104 if Ftyp
= Orig_Ftyp
10105 and then Is_Generic_Unit
(Scope
(Ftyp
))
10106 and then Is_Child_Unit
(Scope
(A_Gen_Obj
))
10109 Temp
: constant Node_Id
:=
10110 New_Copy_Tree
(Subtype_Mark
(Analyzed_Formal
));
10112 Set_Entity
(Temp
, Empty
);
10114 Ftyp
:= Entity
(Temp
);
10118 if Is_Private_Type
(Ftyp
)
10119 and then not Is_Private_Type
(Etype
(Actual
))
10120 and then (Base_Type
(Full_View
(Ftyp
)) = Base_Type
(Etype
(Actual
))
10121 or else Base_Type
(Etype
(Actual
)) = Ftyp
)
10123 -- If the actual has the type of the full view of the formal, or
10124 -- else a non-private subtype of the formal, then the visibility
10125 -- of the formal type has changed. Add to the actuals a subtype
10126 -- declaration that will force the exchange of views in the body
10127 -- of the instance as well.
10130 Make_Subtype_Declaration
(Loc
,
10131 Defining_Identifier
=> Make_Temporary
(Loc
, 'P'),
10132 Subtype_Indication
=> New_Occurrence_Of
(Ftyp
, Loc
));
10134 Prepend
(Subt_Decl
, List
);
10136 Prepend_Elmt
(Full_View
(Ftyp
), Exchanged_Views
);
10137 Exchange_Declarations
(Ftyp
);
10140 Resolve
(Actual
, Ftyp
);
10142 if not Denotes_Variable
(Actual
) then
10144 ("actual for& must be a variable", Actual
, Gen_Obj
);
10146 elsif Base_Type
(Ftyp
) /= Base_Type
(Etype
(Actual
)) then
10148 -- Ada 2005 (AI-423): For a generic formal object of mode in out,
10149 -- the type of the actual shall resolve to a specific anonymous
10152 if Ada_Version
< Ada_2005
10153 or else Ekind
(Base_Type
(Ftyp
)) /=
10154 E_Anonymous_Access_Type
10155 or else Ekind
(Base_Type
(Etype
(Actual
))) /=
10156 E_Anonymous_Access_Type
10159 ("type of actual does not match type of&", Actual
, Gen_Obj
);
10163 Note_Possible_Modification
(Actual
, Sure
=> True);
10165 -- Check for instantiation of atomic/volatile actual for
10166 -- non-atomic/volatile formal (RM C.6 (12)).
10168 if Is_Atomic_Object
(Actual
) and then not Is_Atomic
(Orig_Ftyp
) then
10170 ("cannot instantiate non-atomic formal object "
10171 & "with atomic actual", Actual
);
10173 elsif Is_Volatile_Object
(Actual
) and then not Is_Volatile
(Orig_Ftyp
)
10176 ("cannot instantiate non-volatile formal object "
10177 & "with volatile actual", Actual
);
10180 -- Formal in-parameter
10183 -- The instantiation of a generic formal in-parameter is constant
10184 -- declaration. The actual is the expression for that declaration.
10186 if Present
(Actual
) then
10187 if Present
(Subt_Mark
) then
10189 else pragma Assert
(Present
(Acc_Def
));
10194 Make_Object_Declaration
(Loc
,
10195 Defining_Identifier
=> New_Copy
(Gen_Obj
),
10196 Constant_Present
=> True,
10197 Null_Exclusion_Present
=> Null_Exclusion_Present
(Formal
),
10198 Object_Definition
=> New_Copy_Tree
(Def
),
10199 Expression
=> Actual
);
10201 Set_Corresponding_Generic_Association
(Decl_Node
, Act_Assoc
);
10203 -- A generic formal object of a tagged type is defined to be
10204 -- aliased so the new constant must also be treated as aliased.
10206 if Is_Tagged_Type
(Etype
(A_Gen_Obj
)) then
10207 Set_Aliased_Present
(Decl_Node
);
10210 Append
(Decl_Node
, List
);
10212 -- No need to repeat (pre-)analysis of some expression nodes
10213 -- already handled in Preanalyze_Actuals.
10215 if Nkind
(Actual
) /= N_Allocator
then
10218 -- Return if the analysis of the actual reported some error
10220 if Etype
(Actual
) = Any_Type
then
10226 Formal_Type
: constant Entity_Id
:= Etype
(A_Gen_Obj
);
10230 Typ
:= Get_Instance_Of
(Formal_Type
);
10232 -- If the actual appears in the current or an enclosing scope,
10233 -- use its type directly. This is relevant if it has an actual
10234 -- subtype that is distinct from its nominal one. This cannot
10235 -- be done in general because the type of the actual may
10236 -- depend on other actuals, and only be fully determined when
10237 -- the enclosing instance is analyzed.
10239 if Present
(Etype
(Actual
))
10240 and then Is_Constr_Subt_For_U_Nominal
(Etype
(Actual
))
10242 Freeze_Before
(Instantiation_Node
, Etype
(Actual
));
10244 Freeze_Before
(Instantiation_Node
, Typ
);
10247 -- If the actual is an aggregate, perform name resolution on
10248 -- its components (the analysis of an aggregate does not do it)
10249 -- to capture local names that may be hidden if the generic is
10252 if Nkind
(Actual
) = N_Aggregate
then
10253 Preanalyze_And_Resolve
(Actual
, Typ
);
10256 if Is_Limited_Type
(Typ
)
10257 and then not OK_For_Limited_Init
(Typ
, Actual
)
10260 ("initialization not allowed for limited types", Actual
);
10261 Explain_Limited_Type
(Typ
, Actual
);
10265 elsif Present
(Default_Expression
(Formal
)) then
10267 -- Use default to construct declaration
10269 if Present
(Subt_Mark
) then
10271 else pragma Assert
(Present
(Acc_Def
));
10276 Make_Object_Declaration
(Sloc
(Formal
),
10277 Defining_Identifier
=> New_Copy
(Gen_Obj
),
10278 Constant_Present
=> True,
10279 Null_Exclusion_Present
=> Null_Exclusion_Present
(Formal
),
10280 Object_Definition
=> New_Copy
(Def
),
10281 Expression
=> New_Copy_Tree
10282 (Default_Expression
(Formal
)));
10284 Append
(Decl_Node
, List
);
10285 Set_Analyzed
(Expression
(Decl_Node
), False);
10289 ("missing actual&",
10290 Instantiation_Node
, Gen_Obj
);
10291 Error_Msg_NE
("\in instantiation of & declared#",
10292 Instantiation_Node
, Scope
(A_Gen_Obj
));
10294 if Is_Scalar_Type
(Etype
(A_Gen_Obj
)) then
10296 -- Create dummy constant declaration so that instance can be
10297 -- analyzed, to minimize cascaded visibility errors.
10299 if Present
(Subt_Mark
) then
10301 else pragma Assert
(Present
(Acc_Def
));
10306 Make_Object_Declaration
(Loc
,
10307 Defining_Identifier
=> New_Copy
(Gen_Obj
),
10308 Constant_Present
=> True,
10309 Null_Exclusion_Present
=> Null_Exclusion_Present
(Formal
),
10310 Object_Definition
=> New_Copy
(Def
),
10312 Make_Attribute_Reference
(Sloc
(Gen_Obj
),
10313 Attribute_Name
=> Name_First
,
10314 Prefix
=> New_Copy
(Def
)));
10316 Append
(Decl_Node
, List
);
10319 Abandon_Instantiation
(Instantiation_Node
);
10324 if Nkind
(Actual
) in N_Has_Entity
then
10325 Actual_Decl
:= Parent
(Entity
(Actual
));
10328 -- Ada 2005 (AI-423): For a formal object declaration with a null
10329 -- exclusion or an access definition that has a null exclusion: If the
10330 -- actual matching the formal object declaration denotes a generic
10331 -- formal object of another generic unit G, and the instantiation
10332 -- containing the actual occurs within the body of G or within the body
10333 -- of a generic unit declared within the declarative region of G, then
10334 -- the declaration of the formal object of G must have a null exclusion.
10335 -- Otherwise, the subtype of the actual matching the formal object
10336 -- declaration shall exclude null.
10338 if Ada_Version
>= Ada_2005
10339 and then Present
(Actual_Decl
)
10341 Nkind_In
(Actual_Decl
, N_Formal_Object_Declaration
,
10342 N_Object_Declaration
)
10343 and then Nkind
(Analyzed_Formal
) = N_Formal_Object_Declaration
10344 and then not Has_Null_Exclusion
(Actual_Decl
)
10345 and then Has_Null_Exclusion
(Analyzed_Formal
)
10347 Error_Msg_Sloc
:= Sloc
(Analyzed_Formal
);
10349 ("actual must exclude null to match generic formal#", Actual
);
10352 -- An effectively volatile object cannot be used as an actual in
10353 -- a generic instance. The following check is only relevant when
10354 -- SPARK_Mode is on as it is not a standard Ada legality rule.
10357 and then Present
(Actual
)
10358 and then Is_Effectively_Volatile_Object
(Actual
)
10361 ("volatile object cannot act as actual in generic instantiation "
10362 & "(SPARK RM 7.1.3(8))", Actual
);
10366 end Instantiate_Object
;
10368 ------------------------------
10369 -- Instantiate_Package_Body --
10370 ------------------------------
10372 procedure Instantiate_Package_Body
10373 (Body_Info
: Pending_Body_Info
;
10374 Inlined_Body
: Boolean := False;
10375 Body_Optional
: Boolean := False)
10377 Act_Decl
: constant Node_Id
:= Body_Info
.Act_Decl
;
10378 Inst_Node
: constant Node_Id
:= Body_Info
.Inst_Node
;
10379 Loc
: constant Source_Ptr
:= Sloc
(Inst_Node
);
10381 Gen_Id
: constant Node_Id
:= Name
(Inst_Node
);
10382 Gen_Unit
: constant Entity_Id
:= Get_Generic_Entity
(Inst_Node
);
10383 Gen_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Gen_Unit
);
10384 Act_Spec
: constant Node_Id
:= Specification
(Act_Decl
);
10385 Act_Decl_Id
: constant Entity_Id
:= Defining_Entity
(Act_Spec
);
10387 Act_Body_Name
: Node_Id
;
10388 Gen_Body
: Node_Id
;
10389 Gen_Body_Id
: Node_Id
;
10390 Act_Body
: Node_Id
;
10391 Act_Body_Id
: Entity_Id
;
10393 Parent_Installed
: Boolean := False;
10394 Save_Style_Check
: constant Boolean := Style_Check
;
10396 Par_Ent
: Entity_Id
:= Empty
;
10397 Par_Vis
: Boolean := False;
10399 Vis_Prims_List
: Elist_Id
:= No_Elist
;
10400 -- List of primitives made temporarily visible in the instantiation
10401 -- to match the visibility of the formal type
10403 procedure Check_Initialized_Types
;
10404 -- In a generic package body, an entity of a generic private type may
10405 -- appear uninitialized. This is suspicious, unless the actual is a
10406 -- fully initialized type.
10408 -----------------------------
10409 -- Check_Initialized_Types --
10410 -----------------------------
10412 procedure Check_Initialized_Types
is
10414 Formal
: Entity_Id
;
10415 Actual
: Entity_Id
;
10416 Uninit_Var
: Entity_Id
;
10419 Decl
:= First
(Generic_Formal_Declarations
(Gen_Decl
));
10420 while Present
(Decl
) loop
10421 Uninit_Var
:= Empty
;
10423 if Nkind
(Decl
) = N_Private_Extension_Declaration
then
10424 Uninit_Var
:= Uninitialized_Variable
(Decl
);
10426 elsif Nkind
(Decl
) = N_Formal_Type_Declaration
10427 and then Nkind
(Formal_Type_Definition
(Decl
)) =
10428 N_Formal_Private_Type_Definition
10431 Uninitialized_Variable
(Formal_Type_Definition
(Decl
));
10434 if Present
(Uninit_Var
) then
10435 Formal
:= Defining_Identifier
(Decl
);
10436 Actual
:= First_Entity
(Act_Decl_Id
);
10438 -- For each formal there is a subtype declaration that renames
10439 -- the actual and has the same name as the formal. Locate the
10440 -- formal for warning message about uninitialized variables
10441 -- in the generic, for which the actual type should be a fully
10442 -- initialized type.
10444 while Present
(Actual
) loop
10445 exit when Ekind
(Actual
) = E_Package
10446 and then Present
(Renamed_Object
(Actual
));
10448 if Chars
(Actual
) = Chars
(Formal
)
10449 and then not Is_Scalar_Type
(Actual
)
10450 and then not Is_Fully_Initialized_Type
(Actual
)
10451 and then Warn_On_No_Value_Assigned
10453 Error_Msg_Node_2
:= Formal
;
10455 ("generic unit has uninitialized variable& of "
10456 & "formal private type &?v?", Actual
, Uninit_Var
);
10458 ("actual type for& should be fully initialized type?v?",
10463 Next_Entity
(Actual
);
10469 end Check_Initialized_Types
;
10471 -- Start of processing for Instantiate_Package_Body
10474 Gen_Body_Id
:= Corresponding_Body
(Gen_Decl
);
10476 -- The instance body may already have been processed, as the parent of
10477 -- another instance that is inlined (Load_Parent_Of_Generic).
10479 if Present
(Corresponding_Body
(Instance_Spec
(Inst_Node
))) then
10483 Expander_Mode_Save_And_Set
(Body_Info
.Expander_Status
);
10485 -- Re-establish the state of information on which checks are suppressed.
10486 -- This information was set in Body_Info at the point of instantiation,
10487 -- and now we restore it so that the instance is compiled using the
10488 -- check status at the instantiation (RM 11.5 (7.2/2), AI95-00224-01).
10490 Local_Suppress_Stack_Top
:= Body_Info
.Local_Suppress_Stack_Top
;
10491 Scope_Suppress
:= Body_Info
.Scope_Suppress
;
10492 Opt
.Ada_Version
:= Body_Info
.Version
;
10493 Opt
.Ada_Version_Pragma
:= Body_Info
.Version_Pragma
;
10494 Restore_Warnings
(Body_Info
.Warnings
);
10495 Opt
.SPARK_Mode
:= Body_Info
.SPARK_Mode
;
10496 Opt
.SPARK_Mode_Pragma
:= Body_Info
.SPARK_Mode_Pragma
;
10498 if No
(Gen_Body_Id
) then
10500 -- Do not look for parent of generic body if none is required.
10501 -- This may happen when the routine is called as part of the
10502 -- Pending_Instantiations processing, when nested instances
10503 -- may precede the one generated from the main unit.
10505 if not Unit_Requires_Body
(Defining_Entity
(Gen_Decl
))
10506 and then Body_Optional
10510 Load_Parent_Of_Generic
10511 (Inst_Node
, Specification
(Gen_Decl
), Body_Optional
);
10512 Gen_Body_Id
:= Corresponding_Body
(Gen_Decl
);
10516 -- Establish global variable for sloc adjustment and for error recovery
10518 Instantiation_Node
:= Inst_Node
;
10520 if Present
(Gen_Body_Id
) then
10521 Save_Env
(Gen_Unit
, Act_Decl_Id
);
10522 Style_Check
:= False;
10523 Current_Sem_Unit
:= Body_Info
.Current_Sem_Unit
;
10525 Gen_Body
:= Unit_Declaration_Node
(Gen_Body_Id
);
10527 Create_Instantiation_Source
10528 (Inst_Node
, Gen_Body_Id
, False, S_Adjustment
);
10532 (Original_Node
(Gen_Body
), Empty
, Instantiating
=> True);
10534 -- Build new name (possibly qualified) for body declaration
10536 Act_Body_Id
:= New_Copy
(Act_Decl_Id
);
10538 -- Some attributes of spec entity are not inherited by body entity
10540 Set_Handler_Records
(Act_Body_Id
, No_List
);
10542 if Nkind
(Defining_Unit_Name
(Act_Spec
)) =
10543 N_Defining_Program_Unit_Name
10546 Make_Defining_Program_Unit_Name
(Loc
,
10547 Name
=> New_Copy_Tree
(Name
(Defining_Unit_Name
(Act_Spec
))),
10548 Defining_Identifier
=> Act_Body_Id
);
10550 Act_Body_Name
:= Act_Body_Id
;
10553 Set_Defining_Unit_Name
(Act_Body
, Act_Body_Name
);
10555 Set_Corresponding_Spec
(Act_Body
, Act_Decl_Id
);
10556 Check_Generic_Actuals
(Act_Decl_Id
, False);
10557 Check_Initialized_Types
;
10559 -- Install primitives hidden at the point of the instantiation but
10560 -- visible when processing the generic formals
10566 E
:= First_Entity
(Act_Decl_Id
);
10567 while Present
(E
) loop
10569 and then Is_Generic_Actual_Type
(E
)
10570 and then Is_Tagged_Type
(E
)
10572 Install_Hidden_Primitives
10573 (Prims_List
=> Vis_Prims_List
,
10574 Gen_T
=> Generic_Parent_Type
(Parent
(E
)),
10582 -- If it is a child unit, make the parent instance (which is an
10583 -- instance of the parent of the generic) visible. The parent
10584 -- instance is the prefix of the name of the generic unit.
10586 if Ekind
(Scope
(Gen_Unit
)) = E_Generic_Package
10587 and then Nkind
(Gen_Id
) = N_Expanded_Name
10589 Par_Ent
:= Entity
(Prefix
(Gen_Id
));
10590 Par_Vis
:= Is_Immediately_Visible
(Par_Ent
);
10591 Install_Parent
(Par_Ent
, In_Body
=> True);
10592 Parent_Installed
:= True;
10594 elsif Is_Child_Unit
(Gen_Unit
) then
10595 Par_Ent
:= Scope
(Gen_Unit
);
10596 Par_Vis
:= Is_Immediately_Visible
(Par_Ent
);
10597 Install_Parent
(Par_Ent
, In_Body
=> True);
10598 Parent_Installed
:= True;
10601 -- If the instantiation is a library unit, and this is the main unit,
10602 -- then build the resulting compilation unit nodes for the instance.
10603 -- If this is a compilation unit but it is not the main unit, then it
10604 -- is the body of a unit in the context, that is being compiled
10605 -- because it is encloses some inlined unit or another generic unit
10606 -- being instantiated. In that case, this body is not part of the
10607 -- current compilation, and is not attached to the tree, but its
10608 -- parent must be set for analysis.
10610 if Nkind
(Parent
(Inst_Node
)) = N_Compilation_Unit
then
10612 -- Replace instance node with body of instance, and create new
10613 -- node for corresponding instance declaration.
10615 Build_Instance_Compilation_Unit_Nodes
10616 (Inst_Node
, Act_Body
, Act_Decl
);
10617 Analyze
(Inst_Node
);
10619 if Parent
(Inst_Node
) = Cunit
(Main_Unit
) then
10621 -- If the instance is a child unit itself, then set the scope
10622 -- of the expanded body to be the parent of the instantiation
10623 -- (ensuring that the fully qualified name will be generated
10624 -- for the elaboration subprogram).
10626 if Nkind
(Defining_Unit_Name
(Act_Spec
)) =
10627 N_Defining_Program_Unit_Name
10630 (Defining_Entity
(Inst_Node
), Scope
(Act_Decl_Id
));
10634 -- Case where instantiation is not a library unit
10637 -- If this is an early instantiation, i.e. appears textually
10638 -- before the corresponding body and must be elaborated first,
10639 -- indicate that the body instance is to be delayed.
10641 Install_Body
(Act_Body
, Inst_Node
, Gen_Body
, Gen_Decl
);
10643 -- Now analyze the body. We turn off all checks if this is an
10644 -- internal unit, since there is no reason to have checks on for
10645 -- any predefined run-time library code. All such code is designed
10646 -- to be compiled with checks off.
10648 -- Note that we do NOT apply this criterion to children of GNAT
10649 -- The latter units must suppress checks explicitly if needed.
10651 if Is_Predefined_File_Name
10652 (Unit_File_Name
(Get_Source_Unit
(Gen_Decl
)))
10654 Analyze
(Act_Body
, Suppress
=> All_Checks
);
10656 Analyze
(Act_Body
);
10660 Inherit_Context
(Gen_Body
, Inst_Node
);
10662 -- Remove the parent instances if they have been placed on the scope
10663 -- stack to compile the body.
10665 if Parent_Installed
then
10666 Remove_Parent
(In_Body
=> True);
10668 -- Restore the previous visibility of the parent
10670 Set_Is_Immediately_Visible
(Par_Ent
, Par_Vis
);
10673 Restore_Hidden_Primitives
(Vis_Prims_List
);
10674 Restore_Private_Views
(Act_Decl_Id
);
10676 -- Remove the current unit from visibility if this is an instance
10677 -- that is not elaborated on the fly for inlining purposes.
10679 if not Inlined_Body
then
10680 Set_Is_Immediately_Visible
(Act_Decl_Id
, False);
10684 Style_Check
:= Save_Style_Check
;
10686 -- If we have no body, and the unit requires a body, then complain. This
10687 -- complaint is suppressed if we have detected other errors (since a
10688 -- common reason for missing the body is that it had errors).
10689 -- In CodePeer mode, a warning has been emitted already, no need for
10690 -- further messages.
10692 elsif Unit_Requires_Body
(Gen_Unit
)
10693 and then not Body_Optional
10695 if CodePeer_Mode
then
10698 elsif Serious_Errors_Detected
= 0 then
10700 ("cannot find body of generic package &", Inst_Node
, Gen_Unit
);
10702 -- Don't attempt to perform any cleanup actions if some other error
10703 -- was already detected, since this can cause blowups.
10709 -- Case of package that does not need a body
10712 -- If the instantiation of the declaration is a library unit, rewrite
10713 -- the original package instantiation as a package declaration in the
10714 -- compilation unit node.
10716 if Nkind
(Parent
(Inst_Node
)) = N_Compilation_Unit
then
10717 Set_Parent_Spec
(Act_Decl
, Parent_Spec
(Inst_Node
));
10718 Rewrite
(Inst_Node
, Act_Decl
);
10720 -- Generate elaboration entity, in case spec has elaboration code.
10721 -- This cannot be done when the instance is analyzed, because it
10722 -- is not known yet whether the body exists.
10724 Set_Elaboration_Entity_Required
(Act_Decl_Id
, False);
10725 Build_Elaboration_Entity
(Parent
(Inst_Node
), Act_Decl_Id
);
10727 -- If the instantiation is not a library unit, then append the
10728 -- declaration to the list of implicitly generated entities, unless
10729 -- it is already a list member which means that it was already
10732 elsif not Is_List_Member
(Act_Decl
) then
10733 Mark_Rewrite_Insertion
(Act_Decl
);
10734 Insert_Before
(Inst_Node
, Act_Decl
);
10738 Expander_Mode_Restore
;
10739 end Instantiate_Package_Body
;
10741 ---------------------------------
10742 -- Instantiate_Subprogram_Body --
10743 ---------------------------------
10745 procedure Instantiate_Subprogram_Body
10746 (Body_Info
: Pending_Body_Info
;
10747 Body_Optional
: Boolean := False)
10749 Act_Decl
: constant Node_Id
:= Body_Info
.Act_Decl
;
10750 Inst_Node
: constant Node_Id
:= Body_Info
.Inst_Node
;
10751 Loc
: constant Source_Ptr
:= Sloc
(Inst_Node
);
10752 Gen_Id
: constant Node_Id
:= Name
(Inst_Node
);
10753 Gen_Unit
: constant Entity_Id
:= Get_Generic_Entity
(Inst_Node
);
10754 Gen_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Gen_Unit
);
10755 Anon_Id
: constant Entity_Id
:=
10756 Defining_Unit_Name
(Specification
(Act_Decl
));
10757 Pack_Id
: constant Entity_Id
:=
10758 Defining_Unit_Name
(Parent
(Act_Decl
));
10760 Gen_Body
: Node_Id
;
10761 Gen_Body_Id
: Node_Id
;
10762 Act_Body
: Node_Id
;
10763 Pack_Body
: Node_Id
;
10764 Prev_Formal
: Entity_Id
;
10765 Ret_Expr
: Node_Id
;
10766 Unit_Renaming
: Node_Id
;
10768 Parent_Installed
: Boolean := False;
10770 Saved_Style_Check
: constant Boolean := Style_Check
;
10771 Saved_Warnings
: constant Warning_Record
:= Save_Warnings
;
10773 Par_Ent
: Entity_Id
:= Empty
;
10774 Par_Vis
: Boolean := False;
10777 Gen_Body_Id
:= Corresponding_Body
(Gen_Decl
);
10779 -- Subprogram body may have been created already because of an inline
10780 -- pragma, or because of multiple elaborations of the enclosing package
10781 -- when several instances of the subprogram appear in the main unit.
10783 if Present
(Corresponding_Body
(Act_Decl
)) then
10787 Expander_Mode_Save_And_Set
(Body_Info
.Expander_Status
);
10789 -- Re-establish the state of information on which checks are suppressed.
10790 -- This information was set in Body_Info at the point of instantiation,
10791 -- and now we restore it so that the instance is compiled using the
10792 -- check status at the instantiation (RM 11.5 (7.2/2), AI95-00224-01).
10794 Local_Suppress_Stack_Top
:= Body_Info
.Local_Suppress_Stack_Top
;
10795 Scope_Suppress
:= Body_Info
.Scope_Suppress
;
10796 Opt
.Ada_Version
:= Body_Info
.Version
;
10797 Opt
.Ada_Version_Pragma
:= Body_Info
.Version_Pragma
;
10798 Restore_Warnings
(Body_Info
.Warnings
);
10799 Opt
.SPARK_Mode
:= Body_Info
.SPARK_Mode
;
10800 Opt
.SPARK_Mode_Pragma
:= Body_Info
.SPARK_Mode_Pragma
;
10802 if No
(Gen_Body_Id
) then
10804 -- For imported generic subprogram, no body to compile, complete
10805 -- the spec entity appropriately.
10807 if Is_Imported
(Gen_Unit
) then
10808 Set_Is_Imported
(Anon_Id
);
10809 Set_First_Rep_Item
(Anon_Id
, First_Rep_Item
(Gen_Unit
));
10810 Set_Interface_Name
(Anon_Id
, Interface_Name
(Gen_Unit
));
10811 Set_Convention
(Anon_Id
, Convention
(Gen_Unit
));
10812 Set_Has_Completion
(Anon_Id
);
10815 -- For other cases, compile the body
10818 Load_Parent_Of_Generic
10819 (Inst_Node
, Specification
(Gen_Decl
), Body_Optional
);
10820 Gen_Body_Id
:= Corresponding_Body
(Gen_Decl
);
10824 Instantiation_Node
:= Inst_Node
;
10826 if Present
(Gen_Body_Id
) then
10827 Gen_Body
:= Unit_Declaration_Node
(Gen_Body_Id
);
10829 if Nkind
(Gen_Body
) = N_Subprogram_Body_Stub
then
10831 -- Either body is not present, or context is non-expanding, as
10832 -- when compiling a subunit. Mark the instance as completed, and
10833 -- diagnose a missing body when needed.
10836 and then Operating_Mode
= Generate_Code
10839 ("missing proper body for instantiation", Gen_Body
);
10842 Set_Has_Completion
(Anon_Id
);
10846 Save_Env
(Gen_Unit
, Anon_Id
);
10847 Style_Check
:= False;
10848 Current_Sem_Unit
:= Body_Info
.Current_Sem_Unit
;
10849 Create_Instantiation_Source
10857 (Original_Node
(Gen_Body
), Empty
, Instantiating
=> True);
10859 -- Create proper defining name for the body, to correspond to
10860 -- the one in the spec.
10862 Set_Defining_Unit_Name
(Specification
(Act_Body
),
10863 Make_Defining_Identifier
10864 (Sloc
(Defining_Entity
(Inst_Node
)), Chars
(Anon_Id
)));
10865 Set_Corresponding_Spec
(Act_Body
, Anon_Id
);
10866 Set_Has_Completion
(Anon_Id
);
10867 Check_Generic_Actuals
(Pack_Id
, False);
10869 -- Generate a reference to link the visible subprogram instance to
10870 -- the generic body, which for navigation purposes is the only
10871 -- available source for the instance.
10874 (Related_Instance
(Pack_Id
),
10875 Gen_Body_Id
, 'b', Set_Ref
=> False, Force
=> True);
10877 -- If it is a child unit, make the parent instance (which is an
10878 -- instance of the parent of the generic) visible. The parent
10879 -- instance is the prefix of the name of the generic unit.
10881 if Ekind
(Scope
(Gen_Unit
)) = E_Generic_Package
10882 and then Nkind
(Gen_Id
) = N_Expanded_Name
10884 Par_Ent
:= Entity
(Prefix
(Gen_Id
));
10885 Par_Vis
:= Is_Immediately_Visible
(Par_Ent
);
10886 Install_Parent
(Par_Ent
, In_Body
=> True);
10887 Parent_Installed
:= True;
10889 elsif Is_Child_Unit
(Gen_Unit
) then
10890 Par_Ent
:= Scope
(Gen_Unit
);
10891 Par_Vis
:= Is_Immediately_Visible
(Par_Ent
);
10892 Install_Parent
(Par_Ent
, In_Body
=> True);
10893 Parent_Installed
:= True;
10896 -- Inside its body, a reference to the generic unit is a reference
10897 -- to the instance. The corresponding renaming is the first
10898 -- declaration in the body.
10901 Make_Subprogram_Renaming_Declaration
(Loc
,
10903 Copy_Generic_Node
(
10904 Specification
(Original_Node
(Gen_Body
)),
10906 Instantiating
=> True),
10907 Name
=> New_Occurrence_Of
(Anon_Id
, Loc
));
10909 -- If there is a formal subprogram with the same name as the unit
10910 -- itself, do not add this renaming declaration. This is a temporary
10911 -- fix for one ACVC test. ???
10913 Prev_Formal
:= First_Entity
(Pack_Id
);
10914 while Present
(Prev_Formal
) loop
10915 if Chars
(Prev_Formal
) = Chars
(Gen_Unit
)
10916 and then Is_Overloadable
(Prev_Formal
)
10921 Next_Entity
(Prev_Formal
);
10924 if Present
(Prev_Formal
) then
10925 Decls
:= New_List
(Act_Body
);
10927 Decls
:= New_List
(Unit_Renaming
, Act_Body
);
10930 -- The subprogram body is placed in the body of a dummy package body,
10931 -- whose spec contains the subprogram declaration as well as the
10932 -- renaming declarations for the generic parameters.
10934 Pack_Body
:= Make_Package_Body
(Loc
,
10935 Defining_Unit_Name
=> New_Copy
(Pack_Id
),
10936 Declarations
=> Decls
);
10938 Set_Corresponding_Spec
(Pack_Body
, Pack_Id
);
10940 -- If the instantiation is a library unit, then build resulting
10941 -- compilation unit nodes for the instance. The declaration of
10942 -- the enclosing package is the grandparent of the subprogram
10943 -- declaration. First replace the instantiation node as the unit
10944 -- of the corresponding compilation.
10946 if Nkind
(Parent
(Inst_Node
)) = N_Compilation_Unit
then
10947 if Parent
(Inst_Node
) = Cunit
(Main_Unit
) then
10948 Set_Unit
(Parent
(Inst_Node
), Inst_Node
);
10949 Build_Instance_Compilation_Unit_Nodes
10950 (Inst_Node
, Pack_Body
, Parent
(Parent
(Act_Decl
)));
10951 Analyze
(Inst_Node
);
10953 Set_Parent
(Pack_Body
, Parent
(Inst_Node
));
10954 Analyze
(Pack_Body
);
10958 Insert_Before
(Inst_Node
, Pack_Body
);
10959 Mark_Rewrite_Insertion
(Pack_Body
);
10960 Analyze
(Pack_Body
);
10962 if Expander_Active
then
10963 Freeze_Subprogram_Body
(Inst_Node
, Gen_Body
, Pack_Id
);
10967 Inherit_Context
(Gen_Body
, Inst_Node
);
10969 Restore_Private_Views
(Pack_Id
, False);
10971 if Parent_Installed
then
10972 Remove_Parent
(In_Body
=> True);
10974 -- Restore the previous visibility of the parent
10976 Set_Is_Immediately_Visible
(Par_Ent
, Par_Vis
);
10980 Style_Check
:= Saved_Style_Check
;
10981 Restore_Warnings
(Saved_Warnings
);
10983 -- Body not found. Error was emitted already. If there were no previous
10984 -- errors, this may be an instance whose scope is a premature instance.
10985 -- In that case we must insure that the (legal) program does raise
10986 -- program error if executed. We generate a subprogram body for this
10987 -- purpose. See DEC ac30vso.
10989 -- Should not reference proprietary DEC tests in comments ???
10991 elsif Serious_Errors_Detected
= 0
10992 and then Nkind
(Parent
(Inst_Node
)) /= N_Compilation_Unit
10994 if Body_Optional
then
10997 elsif Ekind
(Anon_Id
) = E_Procedure
then
10999 Make_Subprogram_Body
(Loc
,
11001 Make_Procedure_Specification
(Loc
,
11002 Defining_Unit_Name
=>
11003 Make_Defining_Identifier
(Loc
, Chars
(Anon_Id
)),
11004 Parameter_Specifications
=>
11006 (Parameter_Specifications
(Parent
(Anon_Id
)))),
11008 Declarations
=> Empty_List
,
11009 Handled_Statement_Sequence
=>
11010 Make_Handled_Sequence_Of_Statements
(Loc
,
11013 Make_Raise_Program_Error
(Loc
,
11015 PE_Access_Before_Elaboration
))));
11019 Make_Raise_Program_Error
(Loc
,
11020 Reason
=> PE_Access_Before_Elaboration
);
11022 Set_Etype
(Ret_Expr
, (Etype
(Anon_Id
)));
11023 Set_Analyzed
(Ret_Expr
);
11026 Make_Subprogram_Body
(Loc
,
11028 Make_Function_Specification
(Loc
,
11029 Defining_Unit_Name
=>
11030 Make_Defining_Identifier
(Loc
, Chars
(Anon_Id
)),
11031 Parameter_Specifications
=>
11033 (Parameter_Specifications
(Parent
(Anon_Id
))),
11034 Result_Definition
=>
11035 New_Occurrence_Of
(Etype
(Anon_Id
), Loc
)),
11037 Declarations
=> Empty_List
,
11038 Handled_Statement_Sequence
=>
11039 Make_Handled_Sequence_Of_Statements
(Loc
,
11042 (Make_Simple_Return_Statement
(Loc
, Ret_Expr
))));
11045 Pack_Body
:= Make_Package_Body
(Loc
,
11046 Defining_Unit_Name
=> New_Copy
(Pack_Id
),
11047 Declarations
=> New_List
(Act_Body
));
11049 Insert_After
(Inst_Node
, Pack_Body
);
11050 Set_Corresponding_Spec
(Pack_Body
, Pack_Id
);
11051 Analyze
(Pack_Body
);
11054 Expander_Mode_Restore
;
11055 end Instantiate_Subprogram_Body
;
11057 ----------------------
11058 -- Instantiate_Type --
11059 ----------------------
11061 function Instantiate_Type
11064 Analyzed_Formal
: Node_Id
;
11065 Actual_Decls
: List_Id
) return List_Id
11067 Gen_T
: constant Entity_Id
:= Defining_Identifier
(Formal
);
11068 A_Gen_T
: constant Entity_Id
:=
11069 Defining_Identifier
(Analyzed_Formal
);
11070 Ancestor
: Entity_Id
:= Empty
;
11071 Def
: constant Node_Id
:= Formal_Type_Definition
(Formal
);
11073 Decl_Node
: Node_Id
;
11074 Decl_Nodes
: List_Id
;
11078 procedure Diagnose_Predicated_Actual
;
11079 -- There are a number of constructs in which a discrete type with
11080 -- predicates is illegal, e.g. as an index in an array type declaration.
11081 -- If a generic type is used is such a construct in a generic package
11082 -- declaration, it carries the flag No_Predicate_On_Actual. it is part
11083 -- of the generic contract that the actual cannot have predicates.
11085 procedure Validate_Array_Type_Instance
;
11086 procedure Validate_Access_Subprogram_Instance
;
11087 procedure Validate_Access_Type_Instance
;
11088 procedure Validate_Derived_Type_Instance
;
11089 procedure Validate_Derived_Interface_Type_Instance
;
11090 procedure Validate_Discriminated_Formal_Type
;
11091 procedure Validate_Interface_Type_Instance
;
11092 procedure Validate_Private_Type_Instance
;
11093 procedure Validate_Incomplete_Type_Instance
;
11094 -- These procedures perform validation tests for the named case.
11095 -- Validate_Discriminated_Formal_Type is shared by formal private
11096 -- types and Ada 2012 formal incomplete types.
11098 function Subtypes_Match
(Gen_T
, Act_T
: Entity_Id
) return Boolean;
11099 -- Check that base types are the same and that the subtypes match
11100 -- statically. Used in several of the above.
11102 ---------------------------------
11103 -- Diagnose_Predicated_Actual --
11104 ---------------------------------
11106 procedure Diagnose_Predicated_Actual
is
11108 if No_Predicate_On_Actual
(A_Gen_T
)
11109 and then Has_Predicates
(Act_T
)
11112 ("actual for& cannot be a type with predicate",
11113 Instantiation_Node
, A_Gen_T
);
11115 elsif No_Dynamic_Predicate_On_Actual
(A_Gen_T
)
11116 and then Has_Predicates
(Act_T
)
11117 and then not Has_Static_Predicate_Aspect
(Act_T
)
11120 ("actual for& cannot be a type with a dynamic predicate",
11121 Instantiation_Node
, A_Gen_T
);
11123 end Diagnose_Predicated_Actual
;
11125 --------------------
11126 -- Subtypes_Match --
11127 --------------------
11129 function Subtypes_Match
(Gen_T
, Act_T
: Entity_Id
) return Boolean is
11130 T
: constant Entity_Id
:= Get_Instance_Of
(Gen_T
);
11133 -- Some detailed comments would be useful here ???
11135 return ((Base_Type
(T
) = Act_T
11136 or else Base_Type
(T
) = Base_Type
(Act_T
))
11137 and then Subtypes_Statically_Match
(T
, Act_T
))
11139 or else (Is_Class_Wide_Type
(Gen_T
)
11140 and then Is_Class_Wide_Type
(Act_T
)
11141 and then Subtypes_Match
11142 (Get_Instance_Of
(Root_Type
(Gen_T
)),
11143 Root_Type
(Act_T
)))
11146 (Ekind_In
(Gen_T
, E_Anonymous_Access_Subprogram_Type
,
11147 E_Anonymous_Access_Type
)
11148 and then Ekind
(Act_T
) = Ekind
(Gen_T
)
11149 and then Subtypes_Statically_Match
11150 (Designated_Type
(Gen_T
), Designated_Type
(Act_T
)));
11151 end Subtypes_Match
;
11153 -----------------------------------------
11154 -- Validate_Access_Subprogram_Instance --
11155 -----------------------------------------
11157 procedure Validate_Access_Subprogram_Instance
is
11159 if not Is_Access_Type
(Act_T
)
11160 or else Ekind
(Designated_Type
(Act_T
)) /= E_Subprogram_Type
11163 ("expect access type in instantiation of &", Actual
, Gen_T
);
11164 Abandon_Instantiation
(Actual
);
11167 -- According to AI05-288, actuals for access_to_subprograms must be
11168 -- subtype conformant with the generic formal. Previous to AI05-288
11169 -- only mode conformance was required.
11171 -- This is a binding interpretation that applies to previous versions
11172 -- of the language, no need to maintain previous weaker checks.
11174 Check_Subtype_Conformant
11175 (Designated_Type
(Act_T
),
11176 Designated_Type
(A_Gen_T
),
11180 if Ekind
(Base_Type
(Act_T
)) = E_Access_Protected_Subprogram_Type
then
11181 if Ekind
(A_Gen_T
) = E_Access_Subprogram_Type
then
11183 ("protected access type not allowed for formal &",
11187 elsif Ekind
(A_Gen_T
) = E_Access_Protected_Subprogram_Type
then
11189 ("expect protected access type for formal &",
11192 end Validate_Access_Subprogram_Instance
;
11194 -----------------------------------
11195 -- Validate_Access_Type_Instance --
11196 -----------------------------------
11198 procedure Validate_Access_Type_Instance
is
11199 Desig_Type
: constant Entity_Id
:=
11200 Find_Actual_Type
(Designated_Type
(A_Gen_T
), A_Gen_T
);
11201 Desig_Act
: Entity_Id
;
11204 if not Is_Access_Type
(Act_T
) then
11206 ("expect access type in instantiation of &", Actual
, Gen_T
);
11207 Abandon_Instantiation
(Actual
);
11210 if Is_Access_Constant
(A_Gen_T
) then
11211 if not Is_Access_Constant
(Act_T
) then
11213 ("actual type must be access-to-constant type", Actual
);
11214 Abandon_Instantiation
(Actual
);
11217 if Is_Access_Constant
(Act_T
) then
11219 ("actual type must be access-to-variable type", Actual
);
11220 Abandon_Instantiation
(Actual
);
11222 elsif Ekind
(A_Gen_T
) = E_General_Access_Type
11223 and then Ekind
(Base_Type
(Act_T
)) /= E_General_Access_Type
11225 Error_Msg_N
-- CODEFIX
11226 ("actual must be general access type!", Actual
);
11227 Error_Msg_NE
-- CODEFIX
11228 ("add ALL to }!", Actual
, Act_T
);
11229 Abandon_Instantiation
(Actual
);
11233 -- The designated subtypes, that is to say the subtypes introduced
11234 -- by an access type declaration (and not by a subtype declaration)
11237 Desig_Act
:= Designated_Type
(Base_Type
(Act_T
));
11239 -- The designated type may have been introduced through a limited_
11240 -- with clause, in which case retrieve the non-limited view. This
11241 -- applies to incomplete types as well as to class-wide types.
11243 if From_Limited_With
(Desig_Act
) then
11244 Desig_Act
:= Available_View
(Desig_Act
);
11247 if not Subtypes_Match
(Desig_Type
, Desig_Act
) then
11249 ("designated type of actual does not match that of formal &",
11252 if not Predicates_Match
(Desig_Type
, Desig_Act
) then
11253 Error_Msg_N
("\predicates do not match", Actual
);
11256 Abandon_Instantiation
(Actual
);
11258 elsif Is_Access_Type
(Designated_Type
(Act_T
))
11259 and then Is_Constrained
(Designated_Type
(Designated_Type
(Act_T
)))
11261 Is_Constrained
(Designated_Type
(Desig_Type
))
11264 ("designated type of actual does not match that of formal &",
11267 if not Predicates_Match
(Desig_Type
, Desig_Act
) then
11268 Error_Msg_N
("\predicates do not match", Actual
);
11271 Abandon_Instantiation
(Actual
);
11274 -- Ada 2005: null-exclusion indicators of the two types must agree
11276 if Can_Never_Be_Null
(A_Gen_T
) /= Can_Never_Be_Null
(Act_T
) then
11278 ("non null exclusion of actual and formal & do not match",
11281 end Validate_Access_Type_Instance
;
11283 ----------------------------------
11284 -- Validate_Array_Type_Instance --
11285 ----------------------------------
11287 procedure Validate_Array_Type_Instance
is
11292 function Formal_Dimensions
return Int
;
11293 -- Count number of dimensions in array type formal
11295 -----------------------
11296 -- Formal_Dimensions --
11297 -----------------------
11299 function Formal_Dimensions
return Int
is
11304 if Nkind
(Def
) = N_Constrained_Array_Definition
then
11305 Index
:= First
(Discrete_Subtype_Definitions
(Def
));
11307 Index
:= First
(Subtype_Marks
(Def
));
11310 while Present
(Index
) loop
11312 Next_Index
(Index
);
11316 end Formal_Dimensions
;
11318 -- Start of processing for Validate_Array_Type_Instance
11321 if not Is_Array_Type
(Act_T
) then
11323 ("expect array type in instantiation of &", Actual
, Gen_T
);
11324 Abandon_Instantiation
(Actual
);
11326 elsif Nkind
(Def
) = N_Constrained_Array_Definition
then
11327 if not (Is_Constrained
(Act_T
)) then
11329 ("expect constrained array in instantiation of &",
11331 Abandon_Instantiation
(Actual
);
11335 if Is_Constrained
(Act_T
) then
11337 ("expect unconstrained array in instantiation of &",
11339 Abandon_Instantiation
(Actual
);
11343 if Formal_Dimensions
/= Number_Dimensions
(Act_T
) then
11345 ("dimensions of actual do not match formal &", Actual
, Gen_T
);
11346 Abandon_Instantiation
(Actual
);
11349 I1
:= First_Index
(A_Gen_T
);
11350 I2
:= First_Index
(Act_T
);
11351 for J
in 1 .. Formal_Dimensions
loop
11353 -- If the indexes of the actual were given by a subtype_mark,
11354 -- the index was transformed into a range attribute. Retrieve
11355 -- the original type mark for checking.
11357 if Is_Entity_Name
(Original_Node
(I2
)) then
11358 T2
:= Entity
(Original_Node
(I2
));
11363 if not Subtypes_Match
11364 (Find_Actual_Type
(Etype
(I1
), A_Gen_T
), T2
)
11367 ("index types of actual do not match those of formal &",
11369 Abandon_Instantiation
(Actual
);
11376 -- Check matching subtypes. Note that there are complex visibility
11377 -- issues when the generic is a child unit and some aspect of the
11378 -- generic type is declared in a parent unit of the generic. We do
11379 -- the test to handle this special case only after a direct check
11380 -- for static matching has failed. The case where both the component
11381 -- type and the array type are separate formals, and the component
11382 -- type is a private view may also require special checking in
11386 (Component_Type
(A_Gen_T
), Component_Type
(Act_T
))
11389 (Find_Actual_Type
(Component_Type
(A_Gen_T
), A_Gen_T
),
11390 Component_Type
(Act_T
))
11395 ("component subtype of actual does not match that of formal &",
11397 Abandon_Instantiation
(Actual
);
11400 if Has_Aliased_Components
(A_Gen_T
)
11401 and then not Has_Aliased_Components
(Act_T
)
11404 ("actual must have aliased components to match formal type &",
11407 end Validate_Array_Type_Instance
;
11409 -----------------------------------------------
11410 -- Validate_Derived_Interface_Type_Instance --
11411 -----------------------------------------------
11413 procedure Validate_Derived_Interface_Type_Instance
is
11414 Par
: constant Entity_Id
:= Entity
(Subtype_Indication
(Def
));
11418 -- First apply interface instance checks
11420 Validate_Interface_Type_Instance
;
11422 -- Verify that immediate parent interface is an ancestor of
11426 and then not Interface_Present_In_Ancestor
(Act_T
, Par
)
11429 ("interface actual must include progenitor&", Actual
, Par
);
11432 -- Now verify that the actual includes all other ancestors of
11435 Elmt
:= First_Elmt
(Interfaces
(A_Gen_T
));
11436 while Present
(Elmt
) loop
11437 if not Interface_Present_In_Ancestor
11438 (Act_T
, Get_Instance_Of
(Node
(Elmt
)))
11441 ("interface actual must include progenitor&",
11442 Actual
, Node
(Elmt
));
11447 end Validate_Derived_Interface_Type_Instance
;
11449 ------------------------------------
11450 -- Validate_Derived_Type_Instance --
11451 ------------------------------------
11453 procedure Validate_Derived_Type_Instance
is
11454 Actual_Discr
: Entity_Id
;
11455 Ancestor_Discr
: Entity_Id
;
11458 -- If the parent type in the generic declaration is itself a previous
11459 -- formal type, then it is local to the generic and absent from the
11460 -- analyzed generic definition. In that case the ancestor is the
11461 -- instance of the formal (which must have been instantiated
11462 -- previously), unless the ancestor is itself a formal derived type.
11463 -- In this latter case (which is the subject of Corrigendum 8652/0038
11464 -- (AI-202) the ancestor of the formals is the ancestor of its
11465 -- parent. Otherwise, the analyzed generic carries the parent type.
11466 -- If the parent type is defined in a previous formal package, then
11467 -- the scope of that formal package is that of the generic type
11468 -- itself, and it has already been mapped into the corresponding type
11469 -- in the actual package.
11471 -- Common case: parent type defined outside of the generic
11473 if Is_Entity_Name
(Subtype_Mark
(Def
))
11474 and then Present
(Entity
(Subtype_Mark
(Def
)))
11476 Ancestor
:= Get_Instance_Of
(Entity
(Subtype_Mark
(Def
)));
11478 -- Check whether parent is defined in a previous formal package
11481 Scope
(Scope
(Base_Type
(Etype
(A_Gen_T
)))) = Scope
(A_Gen_T
)
11484 Get_Instance_Of
(Base_Type
(Etype
(A_Gen_T
)));
11486 -- The type may be a local derivation, or a type extension of a
11487 -- previous formal, or of a formal of a parent package.
11489 elsif Is_Derived_Type
(Get_Instance_Of
(A_Gen_T
))
11491 Ekind
(Get_Instance_Of
(A_Gen_T
)) = E_Record_Type_With_Private
11493 -- Check whether the parent is another derived formal type in the
11494 -- same generic unit.
11496 if Etype
(A_Gen_T
) /= A_Gen_T
11497 and then Is_Generic_Type
(Etype
(A_Gen_T
))
11498 and then Scope
(Etype
(A_Gen_T
)) = Scope
(A_Gen_T
)
11499 and then Etype
(Etype
(A_Gen_T
)) /= Etype
(A_Gen_T
)
11501 -- Locate ancestor of parent from the subtype declaration
11502 -- created for the actual.
11508 Decl
:= First
(Actual_Decls
);
11509 while Present
(Decl
) loop
11510 if Nkind
(Decl
) = N_Subtype_Declaration
11511 and then Chars
(Defining_Identifier
(Decl
)) =
11512 Chars
(Etype
(A_Gen_T
))
11514 Ancestor
:= Generic_Parent_Type
(Decl
);
11522 pragma Assert
(Present
(Ancestor
));
11524 -- The ancestor itself may be a previous formal that has been
11527 Ancestor
:= Get_Instance_Of
(Ancestor
);
11531 Get_Instance_Of
(Base_Type
(Get_Instance_Of
(A_Gen_T
)));
11534 -- An unusual case: the actual is a type declared in a parent unit,
11535 -- but is not a formal type so there is no instance_of for it.
11536 -- Retrieve it by analyzing the record extension.
11538 elsif Is_Child_Unit
(Scope
(A_Gen_T
))
11539 and then In_Open_Scopes
(Scope
(Act_T
))
11540 and then Is_Generic_Instance
(Scope
(Act_T
))
11542 Analyze
(Subtype_Mark
(Def
));
11543 Ancestor
:= Entity
(Subtype_Mark
(Def
));
11546 Ancestor
:= Get_Instance_Of
(Etype
(Base_Type
(A_Gen_T
)));
11549 -- If the formal derived type has pragma Preelaborable_Initialization
11550 -- then the actual type must have preelaborable initialization.
11552 if Known_To_Have_Preelab_Init
(A_Gen_T
)
11553 and then not Has_Preelaborable_Initialization
(Act_T
)
11556 ("actual for & must have preelaborable initialization",
11560 -- Ada 2005 (AI-251)
11562 if Ada_Version
>= Ada_2005
and then Is_Interface
(Ancestor
) then
11563 if not Interface_Present_In_Ancestor
(Act_T
, Ancestor
) then
11565 ("(Ada 2005) expected type implementing & in instantiation",
11569 elsif not Is_Ancestor
(Base_Type
(Ancestor
), Act_T
) then
11571 ("expect type derived from & in instantiation",
11572 Actual
, First_Subtype
(Ancestor
));
11573 Abandon_Instantiation
(Actual
);
11576 -- Ada 2005 (AI-443): Synchronized formal derived type checks. Note
11577 -- that the formal type declaration has been rewritten as a private
11580 if Ada_Version
>= Ada_2005
11581 and then Nkind
(Parent
(A_Gen_T
)) = N_Private_Extension_Declaration
11582 and then Synchronized_Present
(Parent
(A_Gen_T
))
11584 -- The actual must be a synchronized tagged type
11586 if not Is_Tagged_Type
(Act_T
) then
11588 ("actual of synchronized type must be tagged", Actual
);
11589 Abandon_Instantiation
(Actual
);
11591 elsif Nkind
(Parent
(Act_T
)) = N_Full_Type_Declaration
11592 and then Nkind
(Type_Definition
(Parent
(Act_T
))) =
11593 N_Derived_Type_Definition
11594 and then not Synchronized_Present
(Type_Definition
11598 ("actual of synchronized type must be synchronized", Actual
);
11599 Abandon_Instantiation
(Actual
);
11603 -- Perform atomic/volatile checks (RM C.6(12)). Note that AI05-0218-1
11604 -- removes the second instance of the phrase "or allow pass by copy".
11606 if Is_Atomic
(Act_T
) and then not Is_Atomic
(Ancestor
) then
11608 ("cannot have atomic actual type for non-atomic formal type",
11611 elsif Is_Volatile
(Act_T
) and then not Is_Volatile
(Ancestor
) then
11613 ("cannot have volatile actual type for non-volatile formal type",
11617 -- It should not be necessary to check for unknown discriminants on
11618 -- Formal, but for some reason Has_Unknown_Discriminants is false for
11619 -- A_Gen_T, so Is_Indefinite_Subtype incorrectly returns False. This
11620 -- needs fixing. ???
11622 if not Is_Indefinite_Subtype
(A_Gen_T
)
11623 and then not Unknown_Discriminants_Present
(Formal
)
11624 and then Is_Indefinite_Subtype
(Act_T
)
11627 ("actual subtype must be constrained", Actual
);
11628 Abandon_Instantiation
(Actual
);
11631 if not Unknown_Discriminants_Present
(Formal
) then
11632 if Is_Constrained
(Ancestor
) then
11633 if not Is_Constrained
(Act_T
) then
11635 ("actual subtype must be constrained", Actual
);
11636 Abandon_Instantiation
(Actual
);
11639 -- Ancestor is unconstrained, Check if generic formal and actual
11640 -- agree on constrainedness. The check only applies to array types
11641 -- and discriminated types.
11643 elsif Is_Constrained
(Act_T
) then
11644 if Ekind
(Ancestor
) = E_Access_Type
11645 or else (not Is_Constrained
(A_Gen_T
)
11646 and then Is_Composite_Type
(A_Gen_T
))
11648 Error_Msg_N
("actual subtype must be unconstrained", Actual
);
11649 Abandon_Instantiation
(Actual
);
11652 -- A class-wide type is only allowed if the formal has unknown
11655 elsif Is_Class_Wide_Type
(Act_T
)
11656 and then not Has_Unknown_Discriminants
(Ancestor
)
11659 ("actual for & cannot be a class-wide type", Actual
, Gen_T
);
11660 Abandon_Instantiation
(Actual
);
11662 -- Otherwise, the formal and actual must have the same number
11663 -- of discriminants and each discriminant of the actual must
11664 -- correspond to a discriminant of the formal.
11666 elsif Has_Discriminants
(Act_T
)
11667 and then not Has_Unknown_Discriminants
(Act_T
)
11668 and then Has_Discriminants
(Ancestor
)
11670 Actual_Discr
:= First_Discriminant
(Act_T
);
11671 Ancestor_Discr
:= First_Discriminant
(Ancestor
);
11672 while Present
(Actual_Discr
)
11673 and then Present
(Ancestor_Discr
)
11675 if Base_Type
(Act_T
) /= Base_Type
(Ancestor
) and then
11676 No
(Corresponding_Discriminant
(Actual_Discr
))
11679 ("discriminant & does not correspond " &
11680 "to ancestor discriminant", Actual
, Actual_Discr
);
11681 Abandon_Instantiation
(Actual
);
11684 Next_Discriminant
(Actual_Discr
);
11685 Next_Discriminant
(Ancestor_Discr
);
11688 if Present
(Actual_Discr
) or else Present
(Ancestor_Discr
) then
11690 ("actual for & must have same number of discriminants",
11692 Abandon_Instantiation
(Actual
);
11695 -- This case should be caught by the earlier check for
11696 -- constrainedness, but the check here is added for completeness.
11698 elsif Has_Discriminants
(Act_T
)
11699 and then not Has_Unknown_Discriminants
(Act_T
)
11702 ("actual for & must not have discriminants", Actual
, Gen_T
);
11703 Abandon_Instantiation
(Actual
);
11705 elsif Has_Discriminants
(Ancestor
) then
11707 ("actual for & must have known discriminants", Actual
, Gen_T
);
11708 Abandon_Instantiation
(Actual
);
11711 if not Subtypes_Statically_Compatible
11712 (Act_T
, Ancestor
, Formal_Derived_Matching
=> True)
11715 ("constraint on actual is incompatible with formal", Actual
);
11716 Abandon_Instantiation
(Actual
);
11720 -- If the formal and actual types are abstract, check that there
11721 -- are no abstract primitives of the actual type that correspond to
11722 -- nonabstract primitives of the formal type (second sentence of
11725 if Is_Abstract_Type
(A_Gen_T
) and then Is_Abstract_Type
(Act_T
) then
11726 Check_Abstract_Primitives
: declare
11727 Gen_Prims
: constant Elist_Id
:=
11728 Primitive_Operations
(A_Gen_T
);
11729 Gen_Elmt
: Elmt_Id
;
11730 Gen_Subp
: Entity_Id
;
11731 Anc_Subp
: Entity_Id
;
11732 Anc_Formal
: Entity_Id
;
11733 Anc_F_Type
: Entity_Id
;
11735 Act_Prims
: constant Elist_Id
:= Primitive_Operations
(Act_T
);
11736 Act_Elmt
: Elmt_Id
;
11737 Act_Subp
: Entity_Id
;
11738 Act_Formal
: Entity_Id
;
11739 Act_F_Type
: Entity_Id
;
11741 Subprograms_Correspond
: Boolean;
11743 function Is_Tagged_Ancestor
(T1
, T2
: Entity_Id
) return Boolean;
11744 -- Returns true if T2 is derived directly or indirectly from
11745 -- T1, including derivations from interfaces. T1 and T2 are
11746 -- required to be specific tagged base types.
11748 ------------------------
11749 -- Is_Tagged_Ancestor --
11750 ------------------------
11752 function Is_Tagged_Ancestor
(T1
, T2
: Entity_Id
) return Boolean
11754 Intfc_Elmt
: Elmt_Id
;
11757 -- The predicate is satisfied if the types are the same
11762 -- If we've reached the top of the derivation chain then
11763 -- we know that T1 is not an ancestor of T2.
11765 elsif Etype
(T2
) = T2
then
11768 -- Proceed to check T2's immediate parent
11770 elsif Is_Ancestor
(T1
, Base_Type
(Etype
(T2
))) then
11773 -- Finally, check to see if T1 is an ancestor of any of T2's
11777 Intfc_Elmt
:= First_Elmt
(Interfaces
(T2
));
11778 while Present
(Intfc_Elmt
) loop
11779 if Is_Ancestor
(T1
, Node
(Intfc_Elmt
)) then
11783 Next_Elmt
(Intfc_Elmt
);
11788 end Is_Tagged_Ancestor
;
11790 -- Start of processing for Check_Abstract_Primitives
11793 -- Loop over all of the formal derived type's primitives
11795 Gen_Elmt
:= First_Elmt
(Gen_Prims
);
11796 while Present
(Gen_Elmt
) loop
11797 Gen_Subp
:= Node
(Gen_Elmt
);
11799 -- If the primitive of the formal is not abstract, then
11800 -- determine whether there is a corresponding primitive of
11801 -- the actual type that's abstract.
11803 if not Is_Abstract_Subprogram
(Gen_Subp
) then
11804 Act_Elmt
:= First_Elmt
(Act_Prims
);
11805 while Present
(Act_Elmt
) loop
11806 Act_Subp
:= Node
(Act_Elmt
);
11808 -- If we find an abstract primitive of the actual,
11809 -- then we need to test whether it corresponds to the
11810 -- subprogram from which the generic formal primitive
11813 if Is_Abstract_Subprogram
(Act_Subp
) then
11814 Anc_Subp
:= Alias
(Gen_Subp
);
11816 -- Test whether we have a corresponding primitive
11817 -- by comparing names, kinds, formal types, and
11820 if Chars
(Anc_Subp
) = Chars
(Act_Subp
)
11821 and then Ekind
(Anc_Subp
) = Ekind
(Act_Subp
)
11823 Anc_Formal
:= First_Formal
(Anc_Subp
);
11824 Act_Formal
:= First_Formal
(Act_Subp
);
11825 while Present
(Anc_Formal
)
11826 and then Present
(Act_Formal
)
11828 Anc_F_Type
:= Etype
(Anc_Formal
);
11829 Act_F_Type
:= Etype
(Act_Formal
);
11831 if Ekind
(Anc_F_Type
)
11832 = E_Anonymous_Access_Type
11834 Anc_F_Type
:= Designated_Type
(Anc_F_Type
);
11836 if Ekind
(Act_F_Type
)
11837 = E_Anonymous_Access_Type
11840 Designated_Type
(Act_F_Type
);
11846 Ekind
(Act_F_Type
) = E_Anonymous_Access_Type
11851 Anc_F_Type
:= Base_Type
(Anc_F_Type
);
11852 Act_F_Type
:= Base_Type
(Act_F_Type
);
11854 -- If the formal is controlling, then the
11855 -- the type of the actual primitive's formal
11856 -- must be derived directly or indirectly
11857 -- from the type of the ancestor primitive's
11860 if Is_Controlling_Formal
(Anc_Formal
) then
11861 if not Is_Tagged_Ancestor
11862 (Anc_F_Type
, Act_F_Type
)
11867 -- Otherwise the types of the formals must
11870 elsif Anc_F_Type
/= Act_F_Type
then
11874 Next_Entity
(Anc_Formal
);
11875 Next_Entity
(Act_Formal
);
11878 -- If we traversed through all of the formals
11879 -- then so far the subprograms correspond, so
11880 -- now check that any result types correspond.
11882 if No
(Anc_Formal
) and then No
(Act_Formal
) then
11883 Subprograms_Correspond
:= True;
11885 if Ekind
(Act_Subp
) = E_Function
then
11886 Anc_F_Type
:= Etype
(Anc_Subp
);
11887 Act_F_Type
:= Etype
(Act_Subp
);
11889 if Ekind
(Anc_F_Type
)
11890 = E_Anonymous_Access_Type
11893 Designated_Type
(Anc_F_Type
);
11895 if Ekind
(Act_F_Type
)
11896 = E_Anonymous_Access_Type
11899 Designated_Type
(Act_F_Type
);
11901 Subprograms_Correspond
:= False;
11906 = E_Anonymous_Access_Type
11908 Subprograms_Correspond
:= False;
11911 Anc_F_Type
:= Base_Type
(Anc_F_Type
);
11912 Act_F_Type
:= Base_Type
(Act_F_Type
);
11914 -- Now either the result types must be
11915 -- the same or, if the result type is
11916 -- controlling, the result type of the
11917 -- actual primitive must descend from the
11918 -- result type of the ancestor primitive.
11920 if Subprograms_Correspond
11921 and then Anc_F_Type
/= Act_F_Type
11923 Has_Controlling_Result
(Anc_Subp
)
11925 not Is_Tagged_Ancestor
11926 (Anc_F_Type
, Act_F_Type
)
11928 Subprograms_Correspond
:= False;
11932 -- Found a matching subprogram belonging to
11933 -- formal ancestor type, so actual subprogram
11934 -- corresponds and this violates 3.9.3(9).
11936 if Subprograms_Correspond
then
11938 ("abstract subprogram & overrides " &
11939 "nonabstract subprogram of ancestor",
11947 Next_Elmt
(Act_Elmt
);
11951 Next_Elmt
(Gen_Elmt
);
11953 end Check_Abstract_Primitives
;
11956 -- Verify that limitedness matches. If parent is a limited
11957 -- interface then the generic formal is not unless declared
11958 -- explicitly so. If not declared limited, the actual cannot be
11959 -- limited (see AI05-0087).
11961 -- Even though this AI is a binding interpretation, we enable the
11962 -- check only in Ada 2012 mode, because this improper construct
11963 -- shows up in user code and in existing B-tests.
11965 if Is_Limited_Type
(Act_T
)
11966 and then not Is_Limited_Type
(A_Gen_T
)
11967 and then Ada_Version
>= Ada_2012
11969 if In_Instance
then
11973 ("actual for non-limited & cannot be a limited type", Actual
,
11975 Explain_Limited_Type
(Act_T
, Actual
);
11976 Abandon_Instantiation
(Actual
);
11979 end Validate_Derived_Type_Instance
;
11981 ----------------------------------------
11982 -- Validate_Discriminated_Formal_Type --
11983 ----------------------------------------
11985 procedure Validate_Discriminated_Formal_Type
is
11986 Formal_Discr
: Entity_Id
;
11987 Actual_Discr
: Entity_Id
;
11988 Formal_Subt
: Entity_Id
;
11991 if Has_Discriminants
(A_Gen_T
) then
11992 if not Has_Discriminants
(Act_T
) then
11994 ("actual for & must have discriminants", Actual
, Gen_T
);
11995 Abandon_Instantiation
(Actual
);
11997 elsif Is_Constrained
(Act_T
) then
11999 ("actual for & must be unconstrained", Actual
, Gen_T
);
12000 Abandon_Instantiation
(Actual
);
12003 Formal_Discr
:= First_Discriminant
(A_Gen_T
);
12004 Actual_Discr
:= First_Discriminant
(Act_T
);
12005 while Formal_Discr
/= Empty
loop
12006 if Actual_Discr
= Empty
then
12008 ("discriminants on actual do not match formal",
12010 Abandon_Instantiation
(Actual
);
12013 Formal_Subt
:= Get_Instance_Of
(Etype
(Formal_Discr
));
12015 -- Access discriminants match if designated types do
12017 if Ekind
(Base_Type
(Formal_Subt
)) = E_Anonymous_Access_Type
12018 and then (Ekind
(Base_Type
(Etype
(Actual_Discr
)))) =
12019 E_Anonymous_Access_Type
12022 (Designated_Type
(Base_Type
(Formal_Subt
))) =
12023 Designated_Type
(Base_Type
(Etype
(Actual_Discr
)))
12027 elsif Base_Type
(Formal_Subt
) /=
12028 Base_Type
(Etype
(Actual_Discr
))
12031 ("types of actual discriminants must match formal",
12033 Abandon_Instantiation
(Actual
);
12035 elsif not Subtypes_Statically_Match
12036 (Formal_Subt
, Etype
(Actual_Discr
))
12037 and then Ada_Version
>= Ada_95
12040 ("subtypes of actual discriminants must match formal",
12042 Abandon_Instantiation
(Actual
);
12045 Next_Discriminant
(Formal_Discr
);
12046 Next_Discriminant
(Actual_Discr
);
12049 if Actual_Discr
/= Empty
then
12051 ("discriminants on actual do not match formal",
12053 Abandon_Instantiation
(Actual
);
12057 end Validate_Discriminated_Formal_Type
;
12059 ---------------------------------------
12060 -- Validate_Incomplete_Type_Instance --
12061 ---------------------------------------
12063 procedure Validate_Incomplete_Type_Instance
is
12065 if not Is_Tagged_Type
(Act_T
)
12066 and then Is_Tagged_Type
(A_Gen_T
)
12069 ("actual for & must be a tagged type", Actual
, Gen_T
);
12072 Validate_Discriminated_Formal_Type
;
12073 end Validate_Incomplete_Type_Instance
;
12075 --------------------------------------
12076 -- Validate_Interface_Type_Instance --
12077 --------------------------------------
12079 procedure Validate_Interface_Type_Instance
is
12081 if not Is_Interface
(Act_T
) then
12083 ("actual for formal interface type must be an interface",
12086 elsif Is_Limited_Type
(Act_T
) /= Is_Limited_Type
(A_Gen_T
)
12087 or else Is_Task_Interface
(A_Gen_T
) /= Is_Task_Interface
(Act_T
)
12088 or else Is_Protected_Interface
(A_Gen_T
) /=
12089 Is_Protected_Interface
(Act_T
)
12090 or else Is_Synchronized_Interface
(A_Gen_T
) /=
12091 Is_Synchronized_Interface
(Act_T
)
12094 ("actual for interface& does not match (RM 12.5.5(4))",
12097 end Validate_Interface_Type_Instance
;
12099 ------------------------------------
12100 -- Validate_Private_Type_Instance --
12101 ------------------------------------
12103 procedure Validate_Private_Type_Instance
is
12105 if Is_Limited_Type
(Act_T
)
12106 and then not Is_Limited_Type
(A_Gen_T
)
12108 if In_Instance
then
12112 ("actual for non-limited & cannot be a limited type", Actual
,
12114 Explain_Limited_Type
(Act_T
, Actual
);
12115 Abandon_Instantiation
(Actual
);
12118 elsif Known_To_Have_Preelab_Init
(A_Gen_T
)
12119 and then not Has_Preelaborable_Initialization
(Act_T
)
12122 ("actual for & must have preelaborable initialization", Actual
,
12125 elsif Is_Indefinite_Subtype
(Act_T
)
12126 and then not Is_Indefinite_Subtype
(A_Gen_T
)
12127 and then Ada_Version
>= Ada_95
12130 ("actual for & must be a definite subtype", Actual
, Gen_T
);
12132 elsif not Is_Tagged_Type
(Act_T
)
12133 and then Is_Tagged_Type
(A_Gen_T
)
12136 ("actual for & must be a tagged type", Actual
, Gen_T
);
12139 Validate_Discriminated_Formal_Type
;
12141 end Validate_Private_Type_Instance
;
12143 -- Start of processing for Instantiate_Type
12146 if Get_Instance_Of
(A_Gen_T
) /= A_Gen_T
then
12147 Error_Msg_N
("duplicate instantiation of generic type", Actual
);
12148 return New_List
(Error
);
12150 elsif not Is_Entity_Name
(Actual
)
12151 or else not Is_Type
(Entity
(Actual
))
12154 ("expect valid subtype mark to instantiate &", Actual
, Gen_T
);
12155 Abandon_Instantiation
(Actual
);
12158 Act_T
:= Entity
(Actual
);
12160 -- Ada 2005 (AI-216): An Unchecked_Union subtype shall only be passed
12161 -- as a generic actual parameter if the corresponding formal type
12162 -- does not have a known_discriminant_part, or is a formal derived
12163 -- type that is an Unchecked_Union type.
12165 if Is_Unchecked_Union
(Base_Type
(Act_T
)) then
12166 if not Has_Discriminants
(A_Gen_T
)
12167 or else (Is_Derived_Type
(A_Gen_T
)
12168 and then Is_Unchecked_Union
(A_Gen_T
))
12172 Error_Msg_N
("unchecked union cannot be the actual for a "
12173 & "discriminated formal type", Act_T
);
12178 -- Deal with fixed/floating restrictions
12180 if Is_Floating_Point_Type
(Act_T
) then
12181 Check_Restriction
(No_Floating_Point
, Actual
);
12182 elsif Is_Fixed_Point_Type
(Act_T
) then
12183 Check_Restriction
(No_Fixed_Point
, Actual
);
12186 -- Deal with error of using incomplete type as generic actual.
12187 -- This includes limited views of a type, even if the non-limited
12188 -- view may be available.
12190 if Ekind
(Act_T
) = E_Incomplete_Type
12191 or else (Is_Class_Wide_Type
(Act_T
)
12192 and then Ekind
(Root_Type
(Act_T
)) = E_Incomplete_Type
)
12194 -- If the formal is an incomplete type, the actual can be
12195 -- incomplete as well.
12197 if Ekind
(A_Gen_T
) = E_Incomplete_Type
then
12200 elsif Is_Class_Wide_Type
(Act_T
)
12201 or else No
(Full_View
(Act_T
))
12203 Error_Msg_N
("premature use of incomplete type", Actual
);
12204 Abandon_Instantiation
(Actual
);
12206 Act_T
:= Full_View
(Act_T
);
12207 Set_Entity
(Actual
, Act_T
);
12209 if Has_Private_Component
(Act_T
) then
12211 ("premature use of type with private component", Actual
);
12215 -- Deal with error of premature use of private type as generic actual
12217 elsif Is_Private_Type
(Act_T
)
12218 and then Is_Private_Type
(Base_Type
(Act_T
))
12219 and then not Is_Generic_Type
(Act_T
)
12220 and then not Is_Derived_Type
(Act_T
)
12221 and then No
(Full_View
(Root_Type
(Act_T
)))
12223 -- If the formal is an incomplete type, the actual can be
12224 -- private or incomplete as well.
12226 if Ekind
(A_Gen_T
) = E_Incomplete_Type
then
12229 Error_Msg_N
("premature use of private type", Actual
);
12232 elsif Has_Private_Component
(Act_T
) then
12234 ("premature use of type with private component", Actual
);
12237 Set_Instance_Of
(A_Gen_T
, Act_T
);
12239 -- If the type is generic, the class-wide type may also be used
12241 if Is_Tagged_Type
(A_Gen_T
)
12242 and then Is_Tagged_Type
(Act_T
)
12243 and then not Is_Class_Wide_Type
(A_Gen_T
)
12245 Set_Instance_Of
(Class_Wide_Type
(A_Gen_T
),
12246 Class_Wide_Type
(Act_T
));
12249 if not Is_Abstract_Type
(A_Gen_T
)
12250 and then Is_Abstract_Type
(Act_T
)
12253 ("actual of non-abstract formal cannot be abstract", Actual
);
12256 -- A generic scalar type is a first subtype for which we generate
12257 -- an anonymous base type. Indicate that the instance of this base
12258 -- is the base type of the actual.
12260 if Is_Scalar_Type
(A_Gen_T
) then
12261 Set_Instance_Of
(Etype
(A_Gen_T
), Etype
(Act_T
));
12265 if Error_Posted
(Act_T
) then
12268 case Nkind
(Def
) is
12269 when N_Formal_Private_Type_Definition
=>
12270 Validate_Private_Type_Instance
;
12272 when N_Formal_Incomplete_Type_Definition
=>
12273 Validate_Incomplete_Type_Instance
;
12275 when N_Formal_Derived_Type_Definition
=>
12276 Validate_Derived_Type_Instance
;
12278 when N_Formal_Discrete_Type_Definition
=>
12279 if not Is_Discrete_Type
(Act_T
) then
12281 ("expect discrete type in instantiation of&",
12283 Abandon_Instantiation
(Actual
);
12286 Diagnose_Predicated_Actual
;
12288 when N_Formal_Signed_Integer_Type_Definition
=>
12289 if not Is_Signed_Integer_Type
(Act_T
) then
12291 ("expect signed integer type in instantiation of&",
12293 Abandon_Instantiation
(Actual
);
12296 Diagnose_Predicated_Actual
;
12298 when N_Formal_Modular_Type_Definition
=>
12299 if not Is_Modular_Integer_Type
(Act_T
) then
12301 ("expect modular type in instantiation of &",
12303 Abandon_Instantiation
(Actual
);
12306 Diagnose_Predicated_Actual
;
12308 when N_Formal_Floating_Point_Definition
=>
12309 if not Is_Floating_Point_Type
(Act_T
) then
12311 ("expect float type in instantiation of &", Actual
, Gen_T
);
12312 Abandon_Instantiation
(Actual
);
12315 when N_Formal_Ordinary_Fixed_Point_Definition
=>
12316 if not Is_Ordinary_Fixed_Point_Type
(Act_T
) then
12318 ("expect ordinary fixed point type in instantiation of &",
12320 Abandon_Instantiation
(Actual
);
12323 when N_Formal_Decimal_Fixed_Point_Definition
=>
12324 if not Is_Decimal_Fixed_Point_Type
(Act_T
) then
12326 ("expect decimal type in instantiation of &",
12328 Abandon_Instantiation
(Actual
);
12331 when N_Array_Type_Definition
=>
12332 Validate_Array_Type_Instance
;
12334 when N_Access_To_Object_Definition
=>
12335 Validate_Access_Type_Instance
;
12337 when N_Access_Function_Definition |
12338 N_Access_Procedure_Definition
=>
12339 Validate_Access_Subprogram_Instance
;
12341 when N_Record_Definition
=>
12342 Validate_Interface_Type_Instance
;
12344 when N_Derived_Type_Definition
=>
12345 Validate_Derived_Interface_Type_Instance
;
12348 raise Program_Error
;
12353 Subt
:= New_Copy
(Gen_T
);
12355 -- Use adjusted sloc of subtype name as the location for other nodes in
12356 -- the subtype declaration.
12358 Loc
:= Sloc
(Subt
);
12361 Make_Subtype_Declaration
(Loc
,
12362 Defining_Identifier
=> Subt
,
12363 Subtype_Indication
=> New_Occurrence_Of
(Act_T
, Loc
));
12365 if Is_Private_Type
(Act_T
) then
12366 Set_Has_Private_View
(Subtype_Indication
(Decl_Node
));
12368 elsif Is_Access_Type
(Act_T
)
12369 and then Is_Private_Type
(Designated_Type
(Act_T
))
12371 Set_Has_Private_View
(Subtype_Indication
(Decl_Node
));
12374 Decl_Nodes
:= New_List
(Decl_Node
);
12376 -- Flag actual derived types so their elaboration produces the
12377 -- appropriate renamings for the primitive operations of the ancestor.
12378 -- Flag actual for formal private types as well, to determine whether
12379 -- operations in the private part may override inherited operations.
12380 -- If the formal has an interface list, the ancestor is not the
12381 -- parent, but the analyzed formal that includes the interface
12382 -- operations of all its progenitors.
12384 -- Same treatment for formal private types, so we can check whether the
12385 -- type is tagged limited when validating derivations in the private
12386 -- part. (See AI05-096).
12388 if Nkind
(Def
) = N_Formal_Derived_Type_Definition
then
12389 if Present
(Interface_List
(Def
)) then
12390 Set_Generic_Parent_Type
(Decl_Node
, A_Gen_T
);
12392 Set_Generic_Parent_Type
(Decl_Node
, Ancestor
);
12395 elsif Nkind_In
(Def
,
12396 N_Formal_Private_Type_Definition
,
12397 N_Formal_Incomplete_Type_Definition
)
12399 Set_Generic_Parent_Type
(Decl_Node
, A_Gen_T
);
12402 -- If the actual is a synchronized type that implements an interface,
12403 -- the primitive operations are attached to the corresponding record,
12404 -- and we have to treat it as an additional generic actual, so that its
12405 -- primitive operations become visible in the instance. The task or
12406 -- protected type itself does not carry primitive operations.
12408 if Is_Concurrent_Type
(Act_T
)
12409 and then Is_Tagged_Type
(Act_T
)
12410 and then Present
(Corresponding_Record_Type
(Act_T
))
12411 and then Present
(Ancestor
)
12412 and then Is_Interface
(Ancestor
)
12415 Corr_Rec
: constant Entity_Id
:=
12416 Corresponding_Record_Type
(Act_T
);
12417 New_Corr
: Entity_Id
;
12418 Corr_Decl
: Node_Id
;
12421 New_Corr
:= Make_Temporary
(Loc
, 'S');
12423 Make_Subtype_Declaration
(Loc
,
12424 Defining_Identifier
=> New_Corr
,
12425 Subtype_Indication
=>
12426 New_Occurrence_Of
(Corr_Rec
, Loc
));
12427 Append_To
(Decl_Nodes
, Corr_Decl
);
12429 if Ekind
(Act_T
) = E_Task_Type
then
12430 Set_Ekind
(Subt
, E_Task_Subtype
);
12432 Set_Ekind
(Subt
, E_Protected_Subtype
);
12435 Set_Corresponding_Record_Type
(Subt
, Corr_Rec
);
12436 Set_Generic_Parent_Type
(Corr_Decl
, Ancestor
);
12437 Set_Generic_Parent_Type
(Decl_Node
, Empty
);
12442 end Instantiate_Type
;
12444 ---------------------
12445 -- Is_In_Main_Unit --
12446 ---------------------
12448 function Is_In_Main_Unit
(N
: Node_Id
) return Boolean is
12449 Unum
: constant Unit_Number_Type
:= Get_Source_Unit
(N
);
12450 Current_Unit
: Node_Id
;
12453 if Unum
= Main_Unit
then
12456 -- If the current unit is a subunit then it is either the main unit or
12457 -- is being compiled as part of the main unit.
12459 elsif Nkind
(N
) = N_Compilation_Unit
then
12460 return Nkind
(Unit
(N
)) = N_Subunit
;
12463 Current_Unit
:= Parent
(N
);
12464 while Present
(Current_Unit
)
12465 and then Nkind
(Current_Unit
) /= N_Compilation_Unit
12467 Current_Unit
:= Parent
(Current_Unit
);
12470 -- The instantiation node is in the main unit, or else the current node
12471 -- (perhaps as the result of nested instantiations) is in the main unit,
12472 -- or in the declaration of the main unit, which in this last case must
12475 return Unum
= Main_Unit
12476 or else Current_Unit
= Cunit
(Main_Unit
)
12477 or else Current_Unit
= Library_Unit
(Cunit
(Main_Unit
))
12478 or else (Present
(Library_Unit
(Current_Unit
))
12479 and then Is_In_Main_Unit
(Library_Unit
(Current_Unit
)));
12480 end Is_In_Main_Unit
;
12482 ----------------------------
12483 -- Load_Parent_Of_Generic --
12484 ----------------------------
12486 procedure Load_Parent_Of_Generic
12489 Body_Optional
: Boolean := False)
12491 Comp_Unit
: constant Node_Id
:= Cunit
(Get_Source_Unit
(Spec
));
12492 Saved_Style_Check
: constant Boolean := Style_Check
;
12493 Saved_Warnings
: constant Warning_Record
:= Save_Warnings
;
12494 True_Parent
: Node_Id
;
12495 Inst_Node
: Node_Id
;
12497 Previous_Instances
: constant Elist_Id
:= New_Elmt_List
;
12499 procedure Collect_Previous_Instances
(Decls
: List_Id
);
12500 -- Collect all instantiations in the given list of declarations, that
12501 -- precede the generic that we need to load. If the bodies of these
12502 -- instantiations are available, we must analyze them, to ensure that
12503 -- the public symbols generated are the same when the unit is compiled
12504 -- to generate code, and when it is compiled in the context of a unit
12505 -- that needs a particular nested instance. This process is applied to
12506 -- both package and subprogram instances.
12508 --------------------------------
12509 -- Collect_Previous_Instances --
12510 --------------------------------
12512 procedure Collect_Previous_Instances
(Decls
: List_Id
) is
12516 Decl
:= First
(Decls
);
12517 while Present
(Decl
) loop
12518 if Sloc
(Decl
) >= Sloc
(Inst_Node
) then
12521 -- If Decl is an instantiation, then record it as requiring
12522 -- instantiation of the corresponding body, except if it is an
12523 -- abbreviated instantiation generated internally for conformance
12524 -- checking purposes only for the case of a formal package
12525 -- declared without a box (see Instantiate_Formal_Package). Such
12526 -- an instantiation does not generate any code (the actual code
12527 -- comes from actual) and thus does not need to be analyzed here.
12528 -- If the instantiation appears with a generic package body it is
12529 -- not analyzed here either.
12531 elsif Nkind
(Decl
) = N_Package_Instantiation
12532 and then not Is_Internal
(Defining_Entity
(Decl
))
12534 Append_Elmt
(Decl
, Previous_Instances
);
12536 -- For a subprogram instantiation, omit instantiations intrinsic
12537 -- operations (Unchecked_Conversions, etc.) that have no bodies.
12539 elsif Nkind_In
(Decl
, N_Function_Instantiation
,
12540 N_Procedure_Instantiation
)
12541 and then not Is_Intrinsic_Subprogram
(Entity
(Name
(Decl
)))
12543 Append_Elmt
(Decl
, Previous_Instances
);
12545 elsif Nkind
(Decl
) = N_Package_Declaration
then
12546 Collect_Previous_Instances
12547 (Visible_Declarations
(Specification
(Decl
)));
12548 Collect_Previous_Instances
12549 (Private_Declarations
(Specification
(Decl
)));
12551 -- Previous non-generic bodies may contain instances as well
12553 elsif Nkind
(Decl
) = N_Package_Body
12554 and then Ekind
(Corresponding_Spec
(Decl
)) /= E_Generic_Package
12556 Collect_Previous_Instances
(Declarations
(Decl
));
12558 elsif Nkind
(Decl
) = N_Subprogram_Body
12559 and then not Acts_As_Spec
(Decl
)
12560 and then not Is_Generic_Subprogram
(Corresponding_Spec
(Decl
))
12562 Collect_Previous_Instances
(Declarations
(Decl
));
12567 end Collect_Previous_Instances
;
12569 -- Start of processing for Load_Parent_Of_Generic
12572 if not In_Same_Source_Unit
(N
, Spec
)
12573 or else Nkind
(Unit
(Comp_Unit
)) = N_Package_Declaration
12574 or else (Nkind
(Unit
(Comp_Unit
)) = N_Package_Body
12575 and then not Is_In_Main_Unit
(Spec
))
12577 -- Find body of parent of spec, and analyze it. A special case arises
12578 -- when the parent is an instantiation, that is to say when we are
12579 -- currently instantiating a nested generic. In that case, there is
12580 -- no separate file for the body of the enclosing instance. Instead,
12581 -- the enclosing body must be instantiated as if it were a pending
12582 -- instantiation, in order to produce the body for the nested generic
12583 -- we require now. Note that in that case the generic may be defined
12584 -- in a package body, the instance defined in the same package body,
12585 -- and the original enclosing body may not be in the main unit.
12587 Inst_Node
:= Empty
;
12589 True_Parent
:= Parent
(Spec
);
12590 while Present
(True_Parent
)
12591 and then Nkind
(True_Parent
) /= N_Compilation_Unit
12593 if Nkind
(True_Parent
) = N_Package_Declaration
12595 Nkind
(Original_Node
(True_Parent
)) = N_Package_Instantiation
12597 -- Parent is a compilation unit that is an instantiation.
12598 -- Instantiation node has been replaced with package decl.
12600 Inst_Node
:= Original_Node
(True_Parent
);
12603 elsif Nkind
(True_Parent
) = N_Package_Declaration
12604 and then Present
(Generic_Parent
(Specification
(True_Parent
)))
12605 and then Nkind
(Parent
(True_Parent
)) /= N_Compilation_Unit
12607 -- Parent is an instantiation within another specification.
12608 -- Declaration for instance has been inserted before original
12609 -- instantiation node. A direct link would be preferable?
12611 Inst_Node
:= Next
(True_Parent
);
12612 while Present
(Inst_Node
)
12613 and then Nkind
(Inst_Node
) /= N_Package_Instantiation
12618 -- If the instance appears within a generic, and the generic
12619 -- unit is defined within a formal package of the enclosing
12620 -- generic, there is no generic body available, and none
12621 -- needed. A more precise test should be used ???
12623 if No
(Inst_Node
) then
12630 True_Parent
:= Parent
(True_Parent
);
12634 -- Case where we are currently instantiating a nested generic
12636 if Present
(Inst_Node
) then
12637 if Nkind
(Parent
(True_Parent
)) = N_Compilation_Unit
then
12639 -- Instantiation node and declaration of instantiated package
12640 -- were exchanged when only the declaration was needed.
12641 -- Restore instantiation node before proceeding with body.
12643 Set_Unit
(Parent
(True_Parent
), Inst_Node
);
12646 -- Now complete instantiation of enclosing body, if it appears in
12647 -- some other unit. If it appears in the current unit, the body
12648 -- will have been instantiated already.
12650 if No
(Corresponding_Body
(Instance_Spec
(Inst_Node
))) then
12652 -- We need to determine the expander mode to instantiate the
12653 -- enclosing body. Because the generic body we need may use
12654 -- global entities declared in the enclosing package (including
12655 -- aggregates) it is in general necessary to compile this body
12656 -- with expansion enabled, except if we are within a generic
12657 -- package, in which case the usual generic rule applies.
12660 Exp_Status
: Boolean := True;
12664 -- Loop through scopes looking for generic package
12666 Scop
:= Scope
(Defining_Entity
(Instance_Spec
(Inst_Node
)));
12667 while Present
(Scop
)
12668 and then Scop
/= Standard_Standard
12670 if Ekind
(Scop
) = E_Generic_Package
then
12671 Exp_Status
:= False;
12675 Scop
:= Scope
(Scop
);
12678 -- Collect previous instantiations in the unit that contains
12679 -- the desired generic.
12681 if Nkind
(Parent
(True_Parent
)) /= N_Compilation_Unit
12682 and then not Body_Optional
12686 Info
: Pending_Body_Info
;
12690 Par
:= Parent
(Inst_Node
);
12691 while Present
(Par
) loop
12692 exit when Nkind
(Parent
(Par
)) = N_Compilation_Unit
;
12693 Par
:= Parent
(Par
);
12696 pragma Assert
(Present
(Par
));
12698 if Nkind
(Par
) = N_Package_Body
then
12699 Collect_Previous_Instances
(Declarations
(Par
));
12701 elsif Nkind
(Par
) = N_Package_Declaration
then
12702 Collect_Previous_Instances
12703 (Visible_Declarations
(Specification
(Par
)));
12704 Collect_Previous_Instances
12705 (Private_Declarations
(Specification
(Par
)));
12708 -- Enclosing unit is a subprogram body. In this
12709 -- case all instance bodies are processed in order
12710 -- and there is no need to collect them separately.
12715 Decl
:= First_Elmt
(Previous_Instances
);
12716 while Present
(Decl
) loop
12718 (Inst_Node
=> Node
(Decl
),
12720 Instance_Spec
(Node
(Decl
)),
12721 Expander_Status
=> Exp_Status
,
12722 Current_Sem_Unit
=>
12723 Get_Code_Unit
(Sloc
(Node
(Decl
))),
12724 Scope_Suppress
=> Scope_Suppress
,
12725 Local_Suppress_Stack_Top
=>
12726 Local_Suppress_Stack_Top
,
12727 Version
=> Ada_Version
,
12728 Version_Pragma
=> Ada_Version_Pragma
,
12729 Warnings
=> Save_Warnings
,
12730 SPARK_Mode
=> SPARK_Mode
,
12731 SPARK_Mode_Pragma
=> SPARK_Mode_Pragma
);
12733 -- Package instance
12736 Nkind
(Node
(Decl
)) = N_Package_Instantiation
12738 Instantiate_Package_Body
12739 (Info
, Body_Optional
=> True);
12741 -- Subprogram instance
12744 -- The instance_spec is the wrapper package,
12745 -- and the subprogram declaration is the last
12746 -- declaration in the wrapper.
12750 (Visible_Declarations
12751 (Specification
(Info
.Act_Decl
)));
12753 Instantiate_Subprogram_Body
12754 (Info
, Body_Optional
=> True);
12762 Instantiate_Package_Body
12764 ((Inst_Node
=> Inst_Node
,
12765 Act_Decl
=> True_Parent
,
12766 Expander_Status
=> Exp_Status
,
12767 Current_Sem_Unit
=> Get_Code_Unit
12768 (Sloc
(Inst_Node
)),
12769 Scope_Suppress
=> Scope_Suppress
,
12770 Local_Suppress_Stack_Top
=> Local_Suppress_Stack_Top
,
12771 Version
=> Ada_Version
,
12772 Version_Pragma
=> Ada_Version_Pragma
,
12773 Warnings
=> Save_Warnings
,
12774 SPARK_Mode
=> SPARK_Mode
,
12775 SPARK_Mode_Pragma
=> SPARK_Mode_Pragma
)),
12776 Body_Optional
=> Body_Optional
);
12780 -- Case where we are not instantiating a nested generic
12783 Opt
.Style_Check
:= False;
12784 Expander_Mode_Save_And_Set
(True);
12785 Load_Needed_Body
(Comp_Unit
, OK
);
12786 Opt
.Style_Check
:= Saved_Style_Check
;
12787 Restore_Warnings
(Saved_Warnings
);
12788 Expander_Mode_Restore
;
12791 and then Unit_Requires_Body
(Defining_Entity
(Spec
))
12792 and then not Body_Optional
12795 Bname
: constant Unit_Name_Type
:=
12796 Get_Body_Name
(Get_Unit_Name
(Unit
(Comp_Unit
)));
12799 -- In CodePeer mode, the missing body may make the analysis
12800 -- incomplete, but we do not treat it as fatal.
12802 if CodePeer_Mode
then
12806 Error_Msg_Unit_1
:= Bname
;
12807 Error_Msg_N
("this instantiation requires$!", N
);
12808 Error_Msg_File_1
:=
12809 Get_File_Name
(Bname
, Subunit
=> False);
12810 Error_Msg_N
("\but file{ was not found!", N
);
12811 raise Unrecoverable_Error
;
12818 -- If loading parent of the generic caused an instantiation circularity,
12819 -- we abandon compilation at this point, because otherwise in some cases
12820 -- we get into trouble with infinite recursions after this point.
12822 if Circularity_Detected
then
12823 raise Unrecoverable_Error
;
12825 end Load_Parent_Of_Generic
;
12827 ---------------------------------
12828 -- Map_Formal_Package_Entities --
12829 ---------------------------------
12831 procedure Map_Formal_Package_Entities
(Form
: Entity_Id
; Act
: Entity_Id
) is
12836 Set_Instance_Of
(Form
, Act
);
12838 -- Traverse formal and actual package to map the corresponding entities.
12839 -- We skip over internal entities that may be generated during semantic
12840 -- analysis, and find the matching entities by name, given that they
12841 -- must appear in the same order.
12843 E1
:= First_Entity
(Form
);
12844 E2
:= First_Entity
(Act
);
12845 while Present
(E1
) and then E1
/= First_Private_Entity
(Form
) loop
12846 -- Could this test be a single condition??? Seems like it could, and
12847 -- isn't FPE (Form) a constant anyway???
12849 if not Is_Internal
(E1
)
12850 and then Present
(Parent
(E1
))
12851 and then not Is_Class_Wide_Type
(E1
)
12852 and then not Is_Internal_Name
(Chars
(E1
))
12854 while Present
(E2
) and then Chars
(E2
) /= Chars
(E1
) loop
12861 Set_Instance_Of
(E1
, E2
);
12863 if Is_Type
(E1
) and then Is_Tagged_Type
(E2
) then
12864 Set_Instance_Of
(Class_Wide_Type
(E1
), Class_Wide_Type
(E2
));
12867 if Is_Constrained
(E1
) then
12868 Set_Instance_Of
(Base_Type
(E1
), Base_Type
(E2
));
12871 if Ekind
(E1
) = E_Package
and then No
(Renamed_Object
(E1
)) then
12872 Map_Formal_Package_Entities
(E1
, E2
);
12879 end Map_Formal_Package_Entities
;
12881 -----------------------
12882 -- Move_Freeze_Nodes --
12883 -----------------------
12885 procedure Move_Freeze_Nodes
12886 (Out_Of
: Entity_Id
;
12891 Next_Decl
: Node_Id
;
12892 Next_Node
: Node_Id
:= After
;
12895 function Is_Outer_Type
(T
: Entity_Id
) return Boolean;
12896 -- Check whether entity is declared in a scope external to that of the
12899 -------------------
12900 -- Is_Outer_Type --
12901 -------------------
12903 function Is_Outer_Type
(T
: Entity_Id
) return Boolean is
12904 Scop
: Entity_Id
:= Scope
(T
);
12907 if Scope_Depth
(Scop
) < Scope_Depth
(Out_Of
) then
12911 while Scop
/= Standard_Standard
loop
12912 if Scop
= Out_Of
then
12915 Scop
:= Scope
(Scop
);
12923 -- Start of processing for Move_Freeze_Nodes
12930 -- First remove the freeze nodes that may appear before all other
12934 while Present
(Decl
)
12935 and then Nkind
(Decl
) = N_Freeze_Entity
12936 and then Is_Outer_Type
(Entity
(Decl
))
12938 Decl
:= Remove_Head
(L
);
12939 Insert_After
(Next_Node
, Decl
);
12940 Set_Analyzed
(Decl
, False);
12945 -- Next scan the list of declarations and remove each freeze node that
12946 -- appears ahead of the current node.
12948 while Present
(Decl
) loop
12949 while Present
(Next
(Decl
))
12950 and then Nkind
(Next
(Decl
)) = N_Freeze_Entity
12951 and then Is_Outer_Type
(Entity
(Next
(Decl
)))
12953 Next_Decl
:= Remove_Next
(Decl
);
12954 Insert_After
(Next_Node
, Next_Decl
);
12955 Set_Analyzed
(Next_Decl
, False);
12956 Next_Node
:= Next_Decl
;
12959 -- If the declaration is a nested package or concurrent type, then
12960 -- recurse. Nested generic packages will have been processed from the
12963 case Nkind
(Decl
) is
12964 when N_Package_Declaration
=>
12965 Spec
:= Specification
(Decl
);
12967 when N_Task_Type_Declaration
=>
12968 Spec
:= Task_Definition
(Decl
);
12970 when N_Protected_Type_Declaration
=>
12971 Spec
:= Protected_Definition
(Decl
);
12977 if Present
(Spec
) then
12978 Move_Freeze_Nodes
(Out_Of
, Next_Node
, Visible_Declarations
(Spec
));
12979 Move_Freeze_Nodes
(Out_Of
, Next_Node
, Private_Declarations
(Spec
));
12984 end Move_Freeze_Nodes
;
12990 function Next_Assoc
(E
: Assoc_Ptr
) return Assoc_Ptr
is
12992 return Generic_Renamings
.Table
(E
).Next_In_HTable
;
12995 ------------------------
12996 -- Preanalyze_Actuals --
12997 ------------------------
12999 procedure Preanalyze_Actuals
(N
: Node_Id
) is
13002 Errs
: constant Int
:= Serious_Errors_Detected
;
13004 Cur
: Entity_Id
:= Empty
;
13005 -- Current homograph of the instance name
13008 -- Saved visibility status of the current homograph
13011 Assoc
:= First
(Generic_Associations
(N
));
13013 -- If the instance is a child unit, its name may hide an outer homonym,
13014 -- so make it invisible to perform name resolution on the actuals.
13016 if Nkind
(Defining_Unit_Name
(N
)) = N_Defining_Program_Unit_Name
13018 (Current_Entity
(Defining_Identifier
(Defining_Unit_Name
(N
))))
13020 Cur
:= Current_Entity
(Defining_Identifier
(Defining_Unit_Name
(N
)));
13022 if Is_Compilation_Unit
(Cur
) then
13023 Vis
:= Is_Immediately_Visible
(Cur
);
13024 Set_Is_Immediately_Visible
(Cur
, False);
13030 while Present
(Assoc
) loop
13031 if Nkind
(Assoc
) /= N_Others_Choice
then
13032 Act
:= Explicit_Generic_Actual_Parameter
(Assoc
);
13034 -- Within a nested instantiation, a defaulted actual is an empty
13035 -- association, so nothing to analyze. If the subprogram actual
13036 -- is an attribute, analyze prefix only, because actual is not a
13037 -- complete attribute reference.
13039 -- If actual is an allocator, analyze expression only. The full
13040 -- analysis can generate code, and if instance is a compilation
13041 -- unit we have to wait until the package instance is installed
13042 -- to have a proper place to insert this code.
13044 -- String literals may be operators, but at this point we do not
13045 -- know whether the actual is a formal subprogram or a string.
13050 elsif Nkind
(Act
) = N_Attribute_Reference
then
13051 Analyze
(Prefix
(Act
));
13053 elsif Nkind
(Act
) = N_Explicit_Dereference
then
13054 Analyze
(Prefix
(Act
));
13056 elsif Nkind
(Act
) = N_Allocator
then
13058 Expr
: constant Node_Id
:= Expression
(Act
);
13061 if Nkind
(Expr
) = N_Subtype_Indication
then
13062 Analyze
(Subtype_Mark
(Expr
));
13064 -- Analyze separately each discriminant constraint, when
13065 -- given with a named association.
13071 Constr
:= First
(Constraints
(Constraint
(Expr
)));
13072 while Present
(Constr
) loop
13073 if Nkind
(Constr
) = N_Discriminant_Association
then
13074 Analyze
(Expression
(Constr
));
13088 elsif Nkind
(Act
) /= N_Operator_Symbol
then
13092 if Errs
/= Serious_Errors_Detected
then
13094 -- Do a minimal analysis of the generic, to prevent spurious
13095 -- warnings complaining about the generic being unreferenced,
13096 -- before abandoning the instantiation.
13098 Analyze
(Name
(N
));
13100 if Is_Entity_Name
(Name
(N
))
13101 and then Etype
(Name
(N
)) /= Any_Type
13103 Generate_Reference
(Entity
(Name
(N
)), Name
(N
));
13104 Set_Is_Instantiated
(Entity
(Name
(N
)));
13107 if Present
(Cur
) then
13109 -- For the case of a child instance hiding an outer homonym,
13110 -- provide additional warning which might explain the error.
13112 Set_Is_Immediately_Visible
(Cur
, Vis
);
13113 Error_Msg_NE
("& hides outer unit with the same name??",
13114 N
, Defining_Unit_Name
(N
));
13117 Abandon_Instantiation
(Act
);
13124 if Present
(Cur
) then
13125 Set_Is_Immediately_Visible
(Cur
, Vis
);
13127 end Preanalyze_Actuals
;
13129 -------------------
13130 -- Remove_Parent --
13131 -------------------
13133 procedure Remove_Parent
(In_Body
: Boolean := False) is
13134 S
: Entity_Id
:= Current_Scope
;
13135 -- S is the scope containing the instantiation just completed. The scope
13136 -- stack contains the parent instances of the instantiation, followed by
13145 -- After child instantiation is complete, remove from scope stack the
13146 -- extra copy of the current scope, and then remove parent instances.
13148 if not In_Body
then
13151 while Current_Scope
/= S
loop
13152 P
:= Current_Scope
;
13153 End_Package_Scope
(Current_Scope
);
13155 if In_Open_Scopes
(P
) then
13156 E
:= First_Entity
(P
);
13157 while Present
(E
) loop
13158 Set_Is_Immediately_Visible
(E
, True);
13162 -- If instantiation is declared in a block, it is the enclosing
13163 -- scope that might be a parent instance. Note that only one
13164 -- block can be involved, because the parent instances have
13165 -- been installed within it.
13167 if Ekind
(P
) = E_Block
then
13168 Cur_P
:= Scope
(P
);
13173 if Is_Generic_Instance
(Cur_P
) and then P
/= Current_Scope
then
13174 -- We are within an instance of some sibling. Retain
13175 -- visibility of parent, for proper subsequent cleanup, and
13176 -- reinstall private declarations as well.
13178 Set_In_Private_Part
(P
);
13179 Install_Private_Declarations
(P
);
13182 -- If the ultimate parent is a top-level unit recorded in
13183 -- Instance_Parent_Unit, then reset its visibility to what it was
13184 -- before instantiation. (It's not clear what the purpose is of
13185 -- testing whether Scope (P) is In_Open_Scopes, but that test was
13186 -- present before the ultimate parent test was added.???)
13188 elsif not In_Open_Scopes
(Scope
(P
))
13189 or else (P
= Instance_Parent_Unit
13190 and then not Parent_Unit_Visible
)
13192 Set_Is_Immediately_Visible
(P
, False);
13194 -- If the current scope is itself an instantiation of a generic
13195 -- nested within P, and we are in the private part of body of this
13196 -- instantiation, restore the full views of P, that were removed
13197 -- in End_Package_Scope above. This obscure case can occur when a
13198 -- subunit of a generic contains an instance of a child unit of
13199 -- its generic parent unit.
13201 elsif S
= Current_Scope
and then Is_Generic_Instance
(S
) then
13203 Par
: constant Entity_Id
:=
13204 Generic_Parent
(Package_Specification
(S
));
13207 and then P
= Scope
(Par
)
13208 and then (In_Package_Body
(S
) or else In_Private_Part
(S
))
13210 Set_In_Private_Part
(P
);
13211 Install_Private_Declarations
(P
);
13217 -- Reset visibility of entities in the enclosing scope
13219 Set_Is_Hidden_Open_Scope
(Current_Scope
, False);
13221 Hidden
:= First_Elmt
(Hidden_Entities
);
13222 while Present
(Hidden
) loop
13223 Set_Is_Immediately_Visible
(Node
(Hidden
), True);
13224 Next_Elmt
(Hidden
);
13228 -- Each body is analyzed separately, and there is no context that
13229 -- needs preserving from one body instance to the next, so remove all
13230 -- parent scopes that have been installed.
13232 while Present
(S
) loop
13233 End_Package_Scope
(S
);
13234 Set_Is_Immediately_Visible
(S
, False);
13235 S
:= Current_Scope
;
13236 exit when S
= Standard_Standard
;
13245 procedure Restore_Env
is
13246 Saved
: Instance_Env
renames Instance_Envs
.Table
(Instance_Envs
.Last
);
13249 if No
(Current_Instantiated_Parent
.Act_Id
) then
13250 -- Restore environment after subprogram inlining
13252 Restore_Private_Views
(Empty
);
13255 Current_Instantiated_Parent
:= Saved
.Instantiated_Parent
;
13256 Exchanged_Views
:= Saved
.Exchanged_Views
;
13257 Hidden_Entities
:= Saved
.Hidden_Entities
;
13258 Current_Sem_Unit
:= Saved
.Current_Sem_Unit
;
13259 Parent_Unit_Visible
:= Saved
.Parent_Unit_Visible
;
13260 Instance_Parent_Unit
:= Saved
.Instance_Parent_Unit
;
13262 Restore_Opt_Config_Switches
(Saved
.Switches
);
13264 Instance_Envs
.Decrement_Last
;
13267 ---------------------------
13268 -- Restore_Private_Views --
13269 ---------------------------
13271 procedure Restore_Private_Views
13272 (Pack_Id
: Entity_Id
;
13273 Is_Package
: Boolean := True)
13278 Dep_Elmt
: Elmt_Id
;
13281 procedure Restore_Nested_Formal
(Formal
: Entity_Id
);
13282 -- Hide the generic formals of formal packages declared with box which
13283 -- were reachable in the current instantiation.
13285 ---------------------------
13286 -- Restore_Nested_Formal --
13287 ---------------------------
13289 procedure Restore_Nested_Formal
(Formal
: Entity_Id
) is
13293 if Present
(Renamed_Object
(Formal
))
13294 and then Denotes_Formal_Package
(Renamed_Object
(Formal
), True)
13298 elsif Present
(Associated_Formal_Package
(Formal
)) then
13299 Ent
:= First_Entity
(Formal
);
13300 while Present
(Ent
) loop
13301 exit when Ekind
(Ent
) = E_Package
13302 and then Renamed_Entity
(Ent
) = Renamed_Entity
(Formal
);
13304 Set_Is_Hidden
(Ent
);
13305 Set_Is_Potentially_Use_Visible
(Ent
, False);
13307 -- If package, then recurse
13309 if Ekind
(Ent
) = E_Package
then
13310 Restore_Nested_Formal
(Ent
);
13316 end Restore_Nested_Formal
;
13318 -- Start of processing for Restore_Private_Views
13321 M
:= First_Elmt
(Exchanged_Views
);
13322 while Present
(M
) loop
13325 -- Subtypes of types whose views have been exchanged, and that are
13326 -- defined within the instance, were not on the Private_Dependents
13327 -- list on entry to the instance, so they have to be exchanged
13328 -- explicitly now, in order to remain consistent with the view of the
13331 if Ekind_In
(Typ
, E_Private_Type
,
13332 E_Limited_Private_Type
,
13333 E_Record_Type_With_Private
)
13335 Dep_Elmt
:= First_Elmt
(Private_Dependents
(Typ
));
13336 while Present
(Dep_Elmt
) loop
13337 Dep_Typ
:= Node
(Dep_Elmt
);
13339 if Scope
(Dep_Typ
) = Pack_Id
13340 and then Present
(Full_View
(Dep_Typ
))
13342 Replace_Elmt
(Dep_Elmt
, Full_View
(Dep_Typ
));
13343 Exchange_Declarations
(Dep_Typ
);
13346 Next_Elmt
(Dep_Elmt
);
13350 Exchange_Declarations
(Node
(M
));
13354 if No
(Pack_Id
) then
13358 -- Make the generic formal parameters private, and make the formal types
13359 -- into subtypes of the actuals again.
13361 E
:= First_Entity
(Pack_Id
);
13362 while Present
(E
) loop
13363 Set_Is_Hidden
(E
, True);
13366 and then Nkind
(Parent
(E
)) = N_Subtype_Declaration
13368 -- If the actual for E is itself a generic actual type from
13369 -- an enclosing instance, E is still a generic actual type
13370 -- outside of the current instance. This matter when resolving
13371 -- an overloaded call that may be ambiguous in the enclosing
13372 -- instance, when two of its actuals coincide.
13374 if Is_Entity_Name
(Subtype_Indication
(Parent
(E
)))
13375 and then Is_Generic_Actual_Type
13376 (Entity
(Subtype_Indication
(Parent
(E
))))
13380 Set_Is_Generic_Actual_Type
(E
, False);
13383 -- An unusual case of aliasing: the actual may also be directly
13384 -- visible in the generic, and be private there, while it is fully
13385 -- visible in the context of the instance. The internal subtype
13386 -- is private in the instance but has full visibility like its
13387 -- parent in the enclosing scope. This enforces the invariant that
13388 -- the privacy status of all private dependents of a type coincide
13389 -- with that of the parent type. This can only happen when a
13390 -- generic child unit is instantiated within a sibling.
13392 if Is_Private_Type
(E
)
13393 and then not Is_Private_Type
(Etype
(E
))
13395 Exchange_Declarations
(E
);
13398 elsif Ekind
(E
) = E_Package
then
13400 -- The end of the renaming list is the renaming of the generic
13401 -- package itself. If the instance is a subprogram, all entities
13402 -- in the corresponding package are renamings. If this entity is
13403 -- a formal package, make its own formals private as well. The
13404 -- actual in this case is itself the renaming of an instantiation.
13405 -- If the entity is not a package renaming, it is the entity
13406 -- created to validate formal package actuals: ignore it.
13408 -- If the actual is itself a formal package for the enclosing
13409 -- generic, or the actual for such a formal package, it remains
13410 -- visible on exit from the instance, and therefore nothing needs
13411 -- to be done either, except to keep it accessible.
13413 if Is_Package
and then Renamed_Object
(E
) = Pack_Id
then
13416 elsif Nkind
(Parent
(E
)) /= N_Package_Renaming_Declaration
then
13420 Denotes_Formal_Package
(Renamed_Object
(E
), True, Pack_Id
)
13422 Set_Is_Hidden
(E
, False);
13426 Act_P
: constant Entity_Id
:= Renamed_Object
(E
);
13430 Id
:= First_Entity
(Act_P
);
13432 and then Id
/= First_Private_Entity
(Act_P
)
13434 exit when Ekind
(Id
) = E_Package
13435 and then Renamed_Object
(Id
) = Act_P
;
13437 Set_Is_Hidden
(Id
, True);
13438 Set_Is_Potentially_Use_Visible
(Id
, In_Use
(Act_P
));
13440 if Ekind
(Id
) = E_Package
then
13441 Restore_Nested_Formal
(Id
);
13452 end Restore_Private_Views
;
13459 (Gen_Unit
: Entity_Id
;
13460 Act_Unit
: Entity_Id
)
13464 Set_Instance_Env
(Gen_Unit
, Act_Unit
);
13467 ----------------------------
13468 -- Save_Global_References --
13469 ----------------------------
13471 procedure Save_Global_References
(N
: Node_Id
) is
13472 Gen_Scope
: Entity_Id
;
13476 function Is_Global
(E
: Entity_Id
) return Boolean;
13477 -- Check whether entity is defined outside of generic unit. Examine the
13478 -- scope of an entity, and the scope of the scope, etc, until we find
13479 -- either Standard, in which case the entity is global, or the generic
13480 -- unit itself, which indicates that the entity is local. If the entity
13481 -- is the generic unit itself, as in the case of a recursive call, or
13482 -- the enclosing generic unit, if different from the current scope, then
13483 -- it is local as well, because it will be replaced at the point of
13484 -- instantiation. On the other hand, if it is a reference to a child
13485 -- unit of a common ancestor, which appears in an instantiation, it is
13486 -- global because it is used to denote a specific compilation unit at
13487 -- the time the instantiations will be analyzed.
13489 procedure Reset_Entity
(N
: Node_Id
);
13490 -- Save semantic information on global entity so that it is not resolved
13491 -- again at instantiation time.
13493 procedure Save_Entity_Descendants
(N
: Node_Id
);
13494 -- Apply Save_Global_References to the two syntactic descendants of
13495 -- non-terminal nodes that carry an Associated_Node and are processed
13496 -- through Reset_Entity. Once the global entity (if any) has been
13497 -- captured together with its type, only two syntactic descendants need
13498 -- to be traversed to complete the processing of the tree rooted at N.
13499 -- This applies to Selected_Components, Expanded_Names, and to Operator
13500 -- nodes. N can also be a character literal, identifier, or operator
13501 -- symbol node, but the call has no effect in these cases.
13503 procedure Save_Global_Defaults
(N1
, N2
: Node_Id
);
13504 -- Default actuals in nested instances must be handled specially
13505 -- because there is no link to them from the original tree. When an
13506 -- actual subprogram is given by a default, we add an explicit generic
13507 -- association for it in the instantiation node. When we save the
13508 -- global references on the name of the instance, we recover the list
13509 -- of generic associations, and add an explicit one to the original
13510 -- generic tree, through which a global actual can be preserved.
13511 -- Similarly, if a child unit is instantiated within a sibling, in the
13512 -- context of the parent, we must preserve the identifier of the parent
13513 -- so that it can be properly resolved in a subsequent instantiation.
13515 procedure Save_Global_Descendant
(D
: Union_Id
);
13516 -- Apply Save_Global_References recursively to the descendents of the
13519 procedure Save_References
(N
: Node_Id
);
13520 -- This is the recursive procedure that does the work, once the
13521 -- enclosing generic scope has been established.
13527 function Is_Global
(E
: Entity_Id
) return Boolean is
13530 function Is_Instance_Node
(Decl
: Node_Id
) return Boolean;
13531 -- Determine whether the parent node of a reference to a child unit
13532 -- denotes an instantiation or a formal package, in which case the
13533 -- reference to the child unit is global, even if it appears within
13534 -- the current scope (e.g. when the instance appears within the body
13535 -- of an ancestor).
13537 ----------------------
13538 -- Is_Instance_Node --
13539 ----------------------
13541 function Is_Instance_Node
(Decl
: Node_Id
) return Boolean is
13543 return Nkind
(Decl
) in N_Generic_Instantiation
13545 Nkind
(Original_Node
(Decl
)) = N_Formal_Package_Declaration
;
13546 end Is_Instance_Node
;
13548 -- Start of processing for Is_Global
13551 if E
= Gen_Scope
then
13554 elsif E
= Standard_Standard
then
13557 elsif Is_Child_Unit
(E
)
13558 and then (Is_Instance_Node
(Parent
(N2
))
13559 or else (Nkind
(Parent
(N2
)) = N_Expanded_Name
13560 and then N2
= Selector_Name
(Parent
(N2
))
13562 Is_Instance_Node
(Parent
(Parent
(N2
)))))
13568 while Se
/= Gen_Scope
loop
13569 if Se
= Standard_Standard
then
13584 procedure Reset_Entity
(N
: Node_Id
) is
13586 procedure Set_Global_Type
(N
: Node_Id
; N2
: Node_Id
);
13587 -- If the type of N2 is global to the generic unit, save the type in
13588 -- the generic node. Just as we perform name capture for explicit
13589 -- references within the generic, we must capture the global types
13590 -- of local entities because they may participate in resolution in
13593 function Top_Ancestor
(E
: Entity_Id
) return Entity_Id
;
13594 -- Find the ultimate ancestor of the current unit. If it is not a
13595 -- generic unit, then the name of the current unit in the prefix of
13596 -- an expanded name must be replaced with its generic homonym to
13597 -- ensure that it will be properly resolved in an instance.
13599 ---------------------
13600 -- Set_Global_Type --
13601 ---------------------
13603 procedure Set_Global_Type
(N
: Node_Id
; N2
: Node_Id
) is
13604 Typ
: constant Entity_Id
:= Etype
(N2
);
13607 Set_Etype
(N
, Typ
);
13609 if Entity
(N
) /= N2
13610 and then Has_Private_View
(Entity
(N
))
13612 -- If the entity of N is not the associated node, this is a
13613 -- nested generic and it has an associated node as well, whose
13614 -- type is already the full view (see below). Indicate that the
13615 -- original node has a private view.
13617 Set_Has_Private_View
(N
);
13620 -- If not a private type, nothing else to do
13622 if not Is_Private_Type
(Typ
) then
13623 if Is_Array_Type
(Typ
)
13624 and then Is_Private_Type
(Component_Type
(Typ
))
13626 Set_Has_Private_View
(N
);
13629 -- If it is a derivation of a private type in a context where no
13630 -- full view is needed, nothing to do either.
13632 elsif No
(Full_View
(Typ
)) and then Typ
/= Etype
(Typ
) then
13635 -- Otherwise mark the type for flipping and use the full view when
13639 Set_Has_Private_View
(N
);
13641 if Present
(Full_View
(Typ
)) then
13642 Set_Etype
(N2
, Full_View
(Typ
));
13645 end Set_Global_Type
;
13651 function Top_Ancestor
(E
: Entity_Id
) return Entity_Id
is
13656 while Is_Child_Unit
(Par
) loop
13657 Par
:= Scope
(Par
);
13663 -- Start of processing for Reset_Entity
13666 N2
:= Get_Associated_Node
(N
);
13669 if Present
(E
) then
13671 -- If the node is an entry call to an entry in an enclosing task,
13672 -- it is rewritten as a selected component. No global entity to
13673 -- preserve in this case, since the expansion will be redone in
13676 if not Nkind_In
(E
, N_Defining_Identifier
,
13677 N_Defining_Character_Literal
,
13678 N_Defining_Operator_Symbol
)
13680 Set_Associated_Node
(N
, Empty
);
13681 Set_Etype
(N
, Empty
);
13685 -- If the entity is an itype created as a subtype of an access
13686 -- type with a null exclusion restore source entity for proper
13687 -- visibility. The itype will be created anew in the instance.
13690 and then Ekind
(E
) = E_Access_Subtype
13691 and then Is_Entity_Name
(N
)
13692 and then Chars
(Etype
(E
)) = Chars
(N
)
13695 Set_Entity
(N2
, E
);
13699 if Is_Global
(E
) then
13701 -- If the entity is a package renaming that is the prefix of
13702 -- an expanded name, it has been rewritten as the renamed
13703 -- package, which is necessary semantically but complicates
13704 -- ASIS tree traversal, so we recover the original entity to
13705 -- expose the renaming. Take into account that the context may
13706 -- be a nested generic, that the original node may itself have
13707 -- an associated node that had better be an entity, and that
13708 -- the current node is still a selected component.
13710 if Ekind
(E
) = E_Package
13711 and then Nkind
(N
) = N_Selected_Component
13712 and then Nkind
(Parent
(N
)) = N_Expanded_Name
13713 and then Present
(Original_Node
(N2
))
13714 and then Is_Entity_Name
(Original_Node
(N2
))
13715 and then Present
(Entity
(Original_Node
(N2
)))
13717 if Is_Global
(Entity
(Original_Node
(N2
))) then
13718 N2
:= Original_Node
(N2
);
13719 Set_Associated_Node
(N
, N2
);
13720 Set_Global_Type
(N
, N2
);
13723 -- Renaming is local, and will be resolved in instance
13725 Set_Associated_Node
(N
, Empty
);
13726 Set_Etype
(N
, Empty
);
13730 Set_Global_Type
(N
, N2
);
13733 elsif Nkind
(N
) = N_Op_Concat
13734 and then Is_Generic_Type
(Etype
(N2
))
13735 and then (Base_Type
(Etype
(Right_Opnd
(N2
))) = Etype
(N2
)
13737 Base_Type
(Etype
(Left_Opnd
(N2
))) = Etype
(N2
))
13738 and then Is_Intrinsic_Subprogram
(E
)
13743 -- Entity is local. Mark generic node as unresolved.
13744 -- Note that now it does not have an entity.
13746 Set_Associated_Node
(N
, Empty
);
13747 Set_Etype
(N
, Empty
);
13750 if Nkind
(Parent
(N
)) in N_Generic_Instantiation
13751 and then N
= Name
(Parent
(N
))
13753 Save_Global_Defaults
(Parent
(N
), Parent
(N2
));
13756 elsif Nkind
(Parent
(N
)) = N_Selected_Component
13757 and then Nkind
(Parent
(N2
)) = N_Expanded_Name
13759 if Is_Global
(Entity
(Parent
(N2
))) then
13760 Change_Selected_Component_To_Expanded_Name
(Parent
(N
));
13761 Set_Associated_Node
(Parent
(N
), Parent
(N2
));
13762 Set_Global_Type
(Parent
(N
), Parent
(N2
));
13763 Save_Entity_Descendants
(N
);
13765 -- If this is a reference to the current generic entity, replace
13766 -- by the name of the generic homonym of the current package. This
13767 -- is because in an instantiation Par.P.Q will not resolve to the
13768 -- name of the instance, whose enclosing scope is not necessarily
13769 -- Par. We use the generic homonym rather that the name of the
13770 -- generic itself because it may be hidden by a local declaration.
13772 elsif In_Open_Scopes
(Entity
(Parent
(N2
)))
13774 Is_Generic_Unit
(Top_Ancestor
(Entity
(Prefix
(Parent
(N2
)))))
13776 if Ekind
(Entity
(Parent
(N2
))) = E_Generic_Package
then
13777 Rewrite
(Parent
(N
),
13778 Make_Identifier
(Sloc
(N
),
13780 Chars
(Generic_Homonym
(Entity
(Parent
(N2
))))));
13782 Rewrite
(Parent
(N
),
13783 Make_Identifier
(Sloc
(N
),
13784 Chars
=> Chars
(Selector_Name
(Parent
(N2
)))));
13788 if Nkind
(Parent
(Parent
(N
))) in N_Generic_Instantiation
13789 and then Parent
(N
) = Name
(Parent
(Parent
(N
)))
13791 Save_Global_Defaults
13792 (Parent
(Parent
(N
)), Parent
(Parent
((N2
))));
13795 -- A selected component may denote a static constant that has been
13796 -- folded. If the static constant is global to the generic, capture
13797 -- its value. Otherwise the folding will happen in any instantiation.
13799 elsif Nkind
(Parent
(N
)) = N_Selected_Component
13800 and then Nkind_In
(Parent
(N2
), N_Integer_Literal
, N_Real_Literal
)
13802 if Present
(Entity
(Original_Node
(Parent
(N2
))))
13803 and then Is_Global
(Entity
(Original_Node
(Parent
(N2
))))
13805 Rewrite
(Parent
(N
), New_Copy
(Parent
(N2
)));
13806 Set_Analyzed
(Parent
(N
), False);
13812 -- A selected component may be transformed into a parameterless
13813 -- function call. If the called entity is global, rewrite the node
13814 -- appropriately, i.e. as an extended name for the global entity.
13816 elsif Nkind
(Parent
(N
)) = N_Selected_Component
13817 and then Nkind
(Parent
(N2
)) = N_Function_Call
13818 and then N
= Selector_Name
(Parent
(N
))
13820 if No
(Parameter_Associations
(Parent
(N2
))) then
13821 if Is_Global
(Entity
(Name
(Parent
(N2
)))) then
13822 Change_Selected_Component_To_Expanded_Name
(Parent
(N
));
13823 Set_Associated_Node
(Parent
(N
), Name
(Parent
(N2
)));
13824 Set_Global_Type
(Parent
(N
), Name
(Parent
(N2
)));
13825 Save_Entity_Descendants
(N
);
13828 Set_Is_Prefixed_Call
(Parent
(N
));
13829 Set_Associated_Node
(N
, Empty
);
13830 Set_Etype
(N
, Empty
);
13833 -- In Ada 2005, X.F may be a call to a primitive operation,
13834 -- rewritten as F (X). This rewriting will be done again in an
13835 -- instance, so keep the original node. Global entities will be
13836 -- captured as for other constructs. Indicate that this must
13837 -- resolve as a call, to prevent accidental overloading in the
13838 -- instance, if both a component and a primitive operation appear
13842 Set_Is_Prefixed_Call
(Parent
(N
));
13845 -- Entity is local. Reset in generic unit, so that node is resolved
13846 -- anew at the point of instantiation.
13849 Set_Associated_Node
(N
, Empty
);
13850 Set_Etype
(N
, Empty
);
13854 -----------------------------
13855 -- Save_Entity_Descendants --
13856 -----------------------------
13858 procedure Save_Entity_Descendants
(N
: Node_Id
) is
13861 when N_Binary_Op
=>
13862 Save_Global_Descendant
(Union_Id
(Left_Opnd
(N
)));
13863 Save_Global_Descendant
(Union_Id
(Right_Opnd
(N
)));
13866 Save_Global_Descendant
(Union_Id
(Right_Opnd
(N
)));
13868 when N_Expanded_Name | N_Selected_Component
=>
13869 Save_Global_Descendant
(Union_Id
(Prefix
(N
)));
13870 Save_Global_Descendant
(Union_Id
(Selector_Name
(N
)));
13872 when N_Identifier | N_Character_Literal | N_Operator_Symbol
=>
13876 raise Program_Error
;
13878 end Save_Entity_Descendants
;
13880 --------------------------
13881 -- Save_Global_Defaults --
13882 --------------------------
13884 procedure Save_Global_Defaults
(N1
, N2
: Node_Id
) is
13885 Loc
: constant Source_Ptr
:= Sloc
(N1
);
13886 Assoc2
: constant List_Id
:= Generic_Associations
(N2
);
13887 Gen_Id
: constant Entity_Id
:= Get_Generic_Entity
(N2
);
13894 Actual
: Entity_Id
;
13897 Assoc1
:= Generic_Associations
(N1
);
13899 if Present
(Assoc1
) then
13900 Act1
:= First
(Assoc1
);
13903 Set_Generic_Associations
(N1
, New_List
);
13904 Assoc1
:= Generic_Associations
(N1
);
13907 if Present
(Assoc2
) then
13908 Act2
:= First
(Assoc2
);
13913 while Present
(Act1
) and then Present
(Act2
) loop
13918 -- Find the associations added for default subprograms
13920 if Present
(Act2
) then
13921 while Nkind
(Act2
) /= N_Generic_Association
13922 or else No
(Entity
(Selector_Name
(Act2
)))
13923 or else not Is_Overloadable
(Entity
(Selector_Name
(Act2
)))
13928 -- Add a similar association if the default is global. The
13929 -- renaming declaration for the actual has been analyzed, and
13930 -- its alias is the program it renames. Link the actual in the
13931 -- original generic tree with the node in the analyzed tree.
13933 while Present
(Act2
) loop
13934 Subp
:= Entity
(Selector_Name
(Act2
));
13935 Def
:= Explicit_Generic_Actual_Parameter
(Act2
);
13937 -- Following test is defence against rubbish errors
13939 if No
(Alias
(Subp
)) then
13943 -- Retrieve the resolved actual from the renaming declaration
13944 -- created for the instantiated formal.
13946 Actual
:= Entity
(Name
(Parent
(Parent
(Subp
))));
13947 Set_Entity
(Def
, Actual
);
13948 Set_Etype
(Def
, Etype
(Actual
));
13950 if Is_Global
(Actual
) then
13952 Make_Generic_Association
(Loc
,
13953 Selector_Name
=> New_Occurrence_Of
(Subp
, Loc
),
13954 Explicit_Generic_Actual_Parameter
=>
13955 New_Occurrence_Of
(Actual
, Loc
));
13957 Set_Associated_Node
13958 (Explicit_Generic_Actual_Parameter
(Ndec
), Def
);
13960 Append
(Ndec
, Assoc1
);
13962 -- If there are other defaults, add a dummy association in case
13963 -- there are other defaulted formals with the same name.
13965 elsif Present
(Next
(Act2
)) then
13967 Make_Generic_Association
(Loc
,
13968 Selector_Name
=> New_Occurrence_Of
(Subp
, Loc
),
13969 Explicit_Generic_Actual_Parameter
=> Empty
);
13971 Append
(Ndec
, Assoc1
);
13978 if Nkind
(Name
(N1
)) = N_Identifier
13979 and then Is_Child_Unit
(Gen_Id
)
13980 and then Is_Global
(Gen_Id
)
13981 and then Is_Generic_Unit
(Scope
(Gen_Id
))
13982 and then In_Open_Scopes
(Scope
(Gen_Id
))
13984 -- This is an instantiation of a child unit within a sibling, so
13985 -- that the generic parent is in scope. An eventual instance must
13986 -- occur within the scope of an instance of the parent. Make name
13987 -- in instance into an expanded name, to preserve the identifier
13988 -- of the parent, so it can be resolved subsequently.
13990 Rewrite
(Name
(N2
),
13991 Make_Expanded_Name
(Loc
,
13992 Chars
=> Chars
(Gen_Id
),
13993 Prefix
=> New_Occurrence_Of
(Scope
(Gen_Id
), Loc
),
13994 Selector_Name
=> New_Occurrence_Of
(Gen_Id
, Loc
)));
13995 Set_Entity
(Name
(N2
), Gen_Id
);
13997 Rewrite
(Name
(N1
),
13998 Make_Expanded_Name
(Loc
,
13999 Chars
=> Chars
(Gen_Id
),
14000 Prefix
=> New_Occurrence_Of
(Scope
(Gen_Id
), Loc
),
14001 Selector_Name
=> New_Occurrence_Of
(Gen_Id
, Loc
)));
14003 Set_Associated_Node
(Name
(N1
), Name
(N2
));
14004 Set_Associated_Node
(Prefix
(Name
(N1
)), Empty
);
14005 Set_Associated_Node
14006 (Selector_Name
(Name
(N1
)), Selector_Name
(Name
(N2
)));
14007 Set_Etype
(Name
(N1
), Etype
(Gen_Id
));
14010 end Save_Global_Defaults
;
14012 ----------------------------
14013 -- Save_Global_Descendant --
14014 ----------------------------
14016 procedure Save_Global_Descendant
(D
: Union_Id
) is
14020 if D
in Node_Range
then
14021 if D
= Union_Id
(Empty
) then
14024 elsif Nkind
(Node_Id
(D
)) /= N_Compilation_Unit
then
14025 Save_References
(Node_Id
(D
));
14028 elsif D
in List_Range
then
14029 if D
= Union_Id
(No_List
) or else Is_Empty_List
(List_Id
(D
)) then
14033 N1
:= First
(List_Id
(D
));
14034 while Present
(N1
) loop
14035 Save_References
(N1
);
14040 -- Element list or other non-node field, nothing to do
14045 end Save_Global_Descendant
;
14047 ---------------------
14048 -- Save_References --
14049 ---------------------
14051 -- This is the recursive procedure that does the work once the enclosing
14052 -- generic scope has been established. We have to treat specially a
14053 -- number of node rewritings that are required by semantic processing
14054 -- and which change the kind of nodes in the generic copy: typically
14055 -- constant-folding, replacing an operator node by a string literal, or
14056 -- a selected component by an expanded name. In each of those cases, the
14057 -- transformation is propagated to the generic unit.
14059 procedure Save_References
(N
: Node_Id
) is
14060 Loc
: constant Source_Ptr
:= Sloc
(N
);
14066 elsif Nkind_In
(N
, N_Character_Literal
, N_Operator_Symbol
) then
14067 if Nkind
(N
) = Nkind
(Get_Associated_Node
(N
)) then
14070 elsif Nkind
(N
) = N_Operator_Symbol
14071 and then Nkind
(Get_Associated_Node
(N
)) = N_String_Literal
14073 Change_Operator_Symbol_To_String_Literal
(N
);
14076 elsif Nkind
(N
) in N_Op
then
14077 if Nkind
(N
) = Nkind
(Get_Associated_Node
(N
)) then
14078 if Nkind
(N
) = N_Op_Concat
then
14079 Set_Is_Component_Left_Opnd
(N
,
14080 Is_Component_Left_Opnd
(Get_Associated_Node
(N
)));
14082 Set_Is_Component_Right_Opnd
(N
,
14083 Is_Component_Right_Opnd
(Get_Associated_Node
(N
)));
14089 -- Node may be transformed into call to a user-defined operator
14091 N2
:= Get_Associated_Node
(N
);
14093 if Nkind
(N2
) = N_Function_Call
then
14094 E
:= Entity
(Name
(N2
));
14097 and then Is_Global
(E
)
14099 Set_Etype
(N
, Etype
(N2
));
14101 Set_Associated_Node
(N
, Empty
);
14102 Set_Etype
(N
, Empty
);
14105 elsif Nkind_In
(N2
, N_Integer_Literal
,
14109 if Present
(Original_Node
(N2
))
14110 and then Nkind
(Original_Node
(N2
)) = Nkind
(N
)
14113 -- Operation was constant-folded. Whenever possible,
14114 -- recover semantic information from unfolded node,
14117 Set_Associated_Node
(N
, Original_Node
(N2
));
14119 if Nkind
(N
) = N_Op_Concat
then
14120 Set_Is_Component_Left_Opnd
(N
,
14121 Is_Component_Left_Opnd
(Get_Associated_Node
(N
)));
14122 Set_Is_Component_Right_Opnd
(N
,
14123 Is_Component_Right_Opnd
(Get_Associated_Node
(N
)));
14129 -- If original node is already modified, propagate
14130 -- constant-folding to template.
14132 Rewrite
(N
, New_Copy
(N2
));
14133 Set_Analyzed
(N
, False);
14136 elsif Nkind
(N2
) = N_Identifier
14137 and then Ekind
(Entity
(N2
)) = E_Enumeration_Literal
14139 -- Same if call was folded into a literal, but in this case
14140 -- retain the entity to avoid spurious ambiguities if it is
14141 -- overloaded at the point of instantiation or inlining.
14143 Rewrite
(N
, New_Copy
(N2
));
14144 Set_Analyzed
(N
, False);
14148 -- Complete operands check if node has not been constant-folded
14150 if Nkind
(N
) in N_Op
then
14151 Save_Entity_Descendants
(N
);
14154 elsif Nkind
(N
) = N_Identifier
then
14155 if Nkind
(N
) = Nkind
(Get_Associated_Node
(N
)) then
14157 -- If this is a discriminant reference, always save it. It is
14158 -- used in the instance to find the corresponding discriminant
14159 -- positionally rather than by name.
14161 Set_Original_Discriminant
14162 (N
, Original_Discriminant
(Get_Associated_Node
(N
)));
14166 N2
:= Get_Associated_Node
(N
);
14168 if Nkind
(N2
) = N_Function_Call
then
14169 E
:= Entity
(Name
(N2
));
14171 -- Name resolves to a call to parameterless function. If
14172 -- original entity is global, mark node as resolved.
14175 and then Is_Global
(E
)
14177 Set_Etype
(N
, Etype
(N2
));
14179 Set_Associated_Node
(N
, Empty
);
14180 Set_Etype
(N
, Empty
);
14183 elsif Nkind_In
(N2
, N_Integer_Literal
, N_Real_Literal
)
14184 and then Is_Entity_Name
(Original_Node
(N2
))
14186 -- Name resolves to named number that is constant-folded,
14187 -- We must preserve the original name for ASIS use, and
14188 -- undo the constant-folding, which will be repeated in
14191 Set_Associated_Node
(N
, Original_Node
(N2
));
14194 elsif Nkind
(N2
) = N_String_Literal
then
14196 -- Name resolves to string literal. Perform the same
14197 -- replacement in generic.
14199 Rewrite
(N
, New_Copy
(N2
));
14201 elsif Nkind
(N2
) = N_Explicit_Dereference
then
14203 -- An identifier is rewritten as a dereference if it is the
14204 -- prefix in an implicit dereference (call or attribute).
14205 -- The analysis of an instantiation will expand the node
14206 -- again, so we preserve the original tree but link it to
14207 -- the resolved entity in case it is global.
14209 if Is_Entity_Name
(Prefix
(N2
))
14210 and then Present
(Entity
(Prefix
(N2
)))
14211 and then Is_Global
(Entity
(Prefix
(N2
)))
14213 Set_Associated_Node
(N
, Prefix
(N2
));
14215 elsif Nkind
(Prefix
(N2
)) = N_Function_Call
14216 and then Is_Global
(Entity
(Name
(Prefix
(N2
))))
14219 Make_Explicit_Dereference
(Loc
,
14220 Prefix
=> Make_Function_Call
(Loc
,
14222 New_Occurrence_Of
(Entity
(Name
(Prefix
(N2
))),
14226 Set_Associated_Node
(N
, Empty
);
14227 Set_Etype
(N
, Empty
);
14230 -- The subtype mark of a nominally unconstrained object is
14231 -- rewritten as a subtype indication using the bounds of the
14232 -- expression. Recover the original subtype mark.
14234 elsif Nkind
(N2
) = N_Subtype_Indication
14235 and then Is_Entity_Name
(Original_Node
(N2
))
14237 Set_Associated_Node
(N
, Original_Node
(N2
));
14245 elsif Nkind
(N
) in N_Entity
then
14250 Qual
: Node_Id
:= Empty
;
14251 Typ
: Entity_Id
:= Empty
;
14254 use Atree
.Unchecked_Access
;
14255 -- This code section is part of implementing an untyped tree
14256 -- traversal, so it needs direct access to node fields.
14259 if Nkind_In
(N
, N_Aggregate
, N_Extension_Aggregate
) then
14260 N2
:= Get_Associated_Node
(N
);
14267 -- In an instance within a generic, use the name of the
14268 -- actual and not the original generic parameter. If the
14269 -- actual is global in the current generic it must be
14270 -- preserved for its instantiation.
14272 if Nkind
(Parent
(Typ
)) = N_Subtype_Declaration
14274 Present
(Generic_Parent_Type
(Parent
(Typ
)))
14276 Typ
:= Base_Type
(Typ
);
14277 Set_Etype
(N2
, Typ
);
14281 if No
(N2
) or else No
(Typ
) or else not Is_Global
(Typ
) then
14282 Set_Associated_Node
(N
, Empty
);
14284 -- If the aggregate is an actual in a call, it has been
14285 -- resolved in the current context, to some local type.
14286 -- The enclosing call may have been disambiguated by the
14287 -- aggregate, and this disambiguation might fail at
14288 -- instantiation time because the type to which the
14289 -- aggregate did resolve is not preserved. In order to
14290 -- preserve some of this information, we wrap the
14291 -- aggregate in a qualified expression, using the id of
14292 -- its type. For further disambiguation we qualify the
14293 -- type name with its scope (if visible) because both
14294 -- id's will have corresponding entities in an instance.
14295 -- This resolves most of the problems with missing type
14296 -- information on aggregates in instances.
14298 if Nkind
(N2
) = Nkind
(N
)
14299 and then Nkind
(Parent
(N2
)) in N_Subprogram_Call
14300 and then Comes_From_Source
(Typ
)
14302 if Is_Immediately_Visible
(Scope
(Typ
)) then
14303 Nam
:= Make_Selected_Component
(Loc
,
14305 Make_Identifier
(Loc
, Chars
(Scope
(Typ
))),
14307 Make_Identifier
(Loc
, Chars
(Typ
)));
14309 Nam
:= Make_Identifier
(Loc
, Chars
(Typ
));
14313 Make_Qualified_Expression
(Loc
,
14314 Subtype_Mark
=> Nam
,
14315 Expression
=> Relocate_Node
(N
));
14319 Save_Global_Descendant
(Field1
(N
));
14320 Save_Global_Descendant
(Field2
(N
));
14321 Save_Global_Descendant
(Field3
(N
));
14322 Save_Global_Descendant
(Field5
(N
));
14324 if Present
(Qual
) then
14328 -- All other cases than aggregates
14331 Save_Global_Descendant
(Field1
(N
));
14332 Save_Global_Descendant
(Field2
(N
));
14333 Save_Global_Descendant
(Field3
(N
));
14334 Save_Global_Descendant
(Field4
(N
));
14335 Save_Global_Descendant
(Field5
(N
));
14340 -- If a node has aspects, references within their expressions must
14341 -- be saved separately, given they are not directly in the tree.
14343 if Has_Aspects
(N
) then
14348 Aspect
:= First
(Aspect_Specifications
(N
));
14349 while Present
(Aspect
) loop
14350 if Present
(Expression
(Aspect
)) then
14351 Save_Global_References
(Expression
(Aspect
));
14358 end Save_References
;
14360 -- Start of processing for Save_Global_References
14363 Gen_Scope
:= Current_Scope
;
14365 -- If the generic unit is a child unit, references to entities in the
14366 -- parent are treated as local, because they will be resolved anew in
14367 -- the context of the instance of the parent.
14369 while Is_Child_Unit
(Gen_Scope
)
14370 and then Ekind
(Scope
(Gen_Scope
)) = E_Generic_Package
14372 Gen_Scope
:= Scope
(Gen_Scope
);
14375 Save_References
(N
);
14376 end Save_Global_References
;
14378 --------------------------------------
14379 -- Set_Copied_Sloc_For_Inlined_Body --
14380 --------------------------------------
14382 procedure Set_Copied_Sloc_For_Inlined_Body
(N
: Node_Id
; E
: Entity_Id
) is
14384 Create_Instantiation_Source
(N
, E
, True, S_Adjustment
);
14385 end Set_Copied_Sloc_For_Inlined_Body
;
14387 ---------------------
14388 -- Set_Instance_Of --
14389 ---------------------
14391 procedure Set_Instance_Of
(A
: Entity_Id
; B
: Entity_Id
) is
14393 Generic_Renamings
.Table
(Generic_Renamings
.Last
) := (A
, B
, Assoc_Null
);
14394 Generic_Renamings_HTable
.Set
(Generic_Renamings
.Last
);
14395 Generic_Renamings
.Increment_Last
;
14396 end Set_Instance_Of
;
14398 --------------------
14399 -- Set_Next_Assoc --
14400 --------------------
14402 procedure Set_Next_Assoc
(E
: Assoc_Ptr
; Next
: Assoc_Ptr
) is
14404 Generic_Renamings
.Table
(E
).Next_In_HTable
:= Next
;
14405 end Set_Next_Assoc
;
14407 -------------------
14408 -- Start_Generic --
14409 -------------------
14411 procedure Start_Generic
is
14413 -- ??? More things could be factored out in this routine.
14414 -- Should probably be done at a later stage.
14416 Generic_Flags
.Append
(Inside_A_Generic
);
14417 Inside_A_Generic
:= True;
14419 Expander_Mode_Save_And_Set
(False);
14422 ----------------------
14423 -- Set_Instance_Env --
14424 ----------------------
14426 procedure Set_Instance_Env
14427 (Gen_Unit
: Entity_Id
;
14428 Act_Unit
: Entity_Id
)
14430 Assertion_Status
: constant Boolean := Assertions_Enabled
;
14431 Save_SPARK_Mode
: constant SPARK_Mode_Type
:= SPARK_Mode
;
14432 Save_SPARK_Mode_Pragma
: constant Node_Id
:= SPARK_Mode_Pragma
;
14435 -- Regardless of the current mode, predefined units are analyzed in the
14436 -- most current Ada mode, and earlier version Ada checks do not apply
14437 -- to predefined units. Nothing needs to be done for non-internal units.
14438 -- These are always analyzed in the current mode.
14440 if Is_Internal_File_Name
14441 (Fname
=> Unit_File_Name
(Get_Source_Unit
(Gen_Unit
)),
14442 Renamings_Included
=> True)
14444 Set_Opt_Config_Switches
(True, Current_Sem_Unit
= Main_Unit
);
14446 -- In Ada2012 we may want to enable assertions in an instance of a
14447 -- predefined unit, in which case we need to preserve the current
14448 -- setting for the Assertions_Enabled flag. This will become more
14449 -- critical when pre/postconditions are added to predefined units,
14450 -- as is already the case for some numeric libraries.
14452 if Ada_Version
>= Ada_2012
then
14453 Assertions_Enabled
:= Assertion_Status
;
14456 -- SPARK_Mode for an instance is the one applicable at the point of
14459 SPARK_Mode
:= Save_SPARK_Mode
;
14460 SPARK_Mode_Pragma
:= Save_SPARK_Mode_Pragma
;
14462 -- Make sure dynamic elaboration checks are off in SPARK Mode
14464 if SPARK_Mode
= On
then
14465 Dynamic_Elaboration_Checks
:= False;
14469 Current_Instantiated_Parent
:=
14470 (Gen_Id
=> Gen_Unit
,
14471 Act_Id
=> Act_Unit
,
14472 Next_In_HTable
=> Assoc_Null
);
14473 end Set_Instance_Env
;
14479 procedure Switch_View
(T
: Entity_Id
) is
14480 BT
: constant Entity_Id
:= Base_Type
(T
);
14481 Priv_Elmt
: Elmt_Id
:= No_Elmt
;
14482 Priv_Sub
: Entity_Id
;
14485 -- T may be private but its base type may have been exchanged through
14486 -- some other occurrence, in which case there is nothing to switch
14487 -- besides T itself. Note that a private dependent subtype of a private
14488 -- type might not have been switched even if the base type has been,
14489 -- because of the last branch of Check_Private_View (see comment there).
14491 if not Is_Private_Type
(BT
) then
14492 Prepend_Elmt
(Full_View
(T
), Exchanged_Views
);
14493 Exchange_Declarations
(T
);
14497 Priv_Elmt
:= First_Elmt
(Private_Dependents
(BT
));
14499 if Present
(Full_View
(BT
)) then
14500 Prepend_Elmt
(Full_View
(BT
), Exchanged_Views
);
14501 Exchange_Declarations
(BT
);
14504 while Present
(Priv_Elmt
) loop
14505 Priv_Sub
:= (Node
(Priv_Elmt
));
14507 -- We avoid flipping the subtype if the Etype of its full view is
14508 -- private because this would result in a malformed subtype. This
14509 -- occurs when the Etype of the subtype full view is the full view of
14510 -- the base type (and since the base types were just switched, the
14511 -- subtype is pointing to the wrong view). This is currently the case
14512 -- for tagged record types, access types (maybe more?) and needs to
14513 -- be resolved. ???
14515 if Present
(Full_View
(Priv_Sub
))
14516 and then not Is_Private_Type
(Etype
(Full_View
(Priv_Sub
)))
14518 Prepend_Elmt
(Full_View
(Priv_Sub
), Exchanged_Views
);
14519 Exchange_Declarations
(Priv_Sub
);
14522 Next_Elmt
(Priv_Elmt
);
14530 function True_Parent
(N
: Node_Id
) return Node_Id
is
14532 if Nkind
(Parent
(N
)) = N_Subunit
then
14533 return Parent
(Corresponding_Stub
(Parent
(N
)));
14539 -----------------------------
14540 -- Valid_Default_Attribute --
14541 -----------------------------
14543 procedure Valid_Default_Attribute
(Nam
: Entity_Id
; Def
: Node_Id
) is
14544 Attr_Id
: constant Attribute_Id
:=
14545 Get_Attribute_Id
(Attribute_Name
(Def
));
14546 T
: constant Entity_Id
:= Entity
(Prefix
(Def
));
14547 Is_Fun
: constant Boolean := (Ekind
(Nam
) = E_Function
);
14553 if No
(T
) or else T
= Any_Id
then
14558 F
:= First_Formal
(Nam
);
14559 while Present
(F
) loop
14560 Num_F
:= Num_F
+ 1;
14565 when Attribute_Adjacent | Attribute_Ceiling | Attribute_Copy_Sign |
14566 Attribute_Floor | Attribute_Fraction | Attribute_Machine |
14567 Attribute_Model | Attribute_Remainder | Attribute_Rounding |
14568 Attribute_Unbiased_Rounding
=>
14571 and then Is_Floating_Point_Type
(T
);
14573 when Attribute_Image | Attribute_Pred | Attribute_Succ |
14574 Attribute_Value | Attribute_Wide_Image |
14575 Attribute_Wide_Value
=>
14576 OK
:= (Is_Fun
and then Num_F
= 1 and then Is_Scalar_Type
(T
));
14578 when Attribute_Max | Attribute_Min
=>
14579 OK
:= (Is_Fun
and then Num_F
= 2 and then Is_Scalar_Type
(T
));
14581 when Attribute_Input
=>
14582 OK
:= (Is_Fun
and then Num_F
= 1);
14584 when Attribute_Output | Attribute_Read | Attribute_Write
=>
14585 OK
:= (not Is_Fun
and then Num_F
= 2);
14592 Error_Msg_N
("attribute reference has wrong profile for subprogram",
14595 end Valid_Default_Attribute
;