1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree; use Atree;
27 with Einfo; use Einfo;
28 with Elists; use Elists;
29 with Errout; use Errout;
30 with Expander; use Expander;
31 with Fname; use Fname;
32 with Fname.UF; use Fname.UF;
33 with Freeze; use Freeze;
35 with Itypes; use Itypes;
37 with Lib.Load; use Lib.Load;
38 with Lib.Xref; use Lib.Xref;
39 with Nlists; use Nlists;
40 with Namet; use Namet;
41 with Nmake; use Nmake;
43 with Rident; use Rident;
44 with Restrict; use Restrict;
45 with Rtsfind; use Rtsfind;
47 with Sem_Aux; use Sem_Aux;
48 with Sem_Cat; use Sem_Cat;
49 with Sem_Ch3; use Sem_Ch3;
50 with Sem_Ch6; use Sem_Ch6;
51 with Sem_Ch7; use Sem_Ch7;
52 with Sem_Ch8; use Sem_Ch8;
53 with Sem_Ch10; use Sem_Ch10;
54 with Sem_Ch13; use Sem_Ch13;
55 with Sem_Disp; use Sem_Disp;
56 with Sem_Elab; use Sem_Elab;
57 with Sem_Elim; use Sem_Elim;
58 with Sem_Eval; use Sem_Eval;
59 with Sem_Res; use Sem_Res;
60 with Sem_Type; use Sem_Type;
61 with Sem_Util; use Sem_Util;
62 with Sem_Warn; use Sem_Warn;
63 with Stand; use Stand;
64 with Sinfo; use Sinfo;
65 with Sinfo.CN; use Sinfo.CN;
66 with Sinput; use Sinput;
67 with Sinput.L; use Sinput.L;
68 with Snames; use Snames;
69 with Stringt; use Stringt;
70 with Uname; use Uname;
72 with Tbuild; use Tbuild;
73 with Uintp; use Uintp;
74 with Urealp; use Urealp;
78 package body Sem_Ch12 is
80 ----------------------------------------------------------
81 -- Implementation of Generic Analysis and Instantiation --
82 ----------------------------------------------------------
84 -- GNAT implements generics by macro expansion. No attempt is made to share
85 -- generic instantiations (for now). Analysis of a generic definition does
86 -- not perform any expansion action, but the expander must be called on the
87 -- tree for each instantiation, because the expansion may of course depend
88 -- on the generic actuals. All of this is best achieved as follows:
90 -- a) Semantic analysis of a generic unit is performed on a copy of the
91 -- tree for the generic unit. All tree modifications that follow analysis
92 -- do not affect the original tree. Links are kept between the original
93 -- tree and the copy, in order to recognize non-local references within
94 -- the generic, and propagate them to each instance (recall that name
95 -- resolution is done on the generic declaration: generics are not really
96 -- macros!). This is summarized in the following diagram:
98 -- .-----------. .----------.
99 -- | semantic |<--------------| generic |
101 -- | |==============>| |
102 -- |___________| global |__________|
113 -- b) Each instantiation copies the original tree, and inserts into it a
114 -- series of declarations that describe the mapping between generic formals
115 -- and actuals. For example, a generic In OUT parameter is an object
116 -- renaming of the corresponding actual, etc. Generic IN parameters are
117 -- constant declarations.
119 -- c) In order to give the right visibility for these renamings, we use
120 -- a different scheme for package and subprogram instantiations. For
121 -- packages, the list of renamings is inserted into the package
122 -- specification, before the visible declarations of the package. The
123 -- renamings are analyzed before any of the text of the instance, and are
124 -- thus visible at the right place. Furthermore, outside of the instance,
125 -- the generic parameters are visible and denote their corresponding
128 -- For subprograms, we create a container package to hold the renamings
129 -- and the subprogram instance itself. Analysis of the package makes the
130 -- renaming declarations visible to the subprogram. After analyzing the
131 -- package, the defining entity for the subprogram is touched-up so that
132 -- it appears declared in the current scope, and not inside the container
135 -- If the instantiation is a compilation unit, the container package is
136 -- given the same name as the subprogram instance. This ensures that
137 -- the elaboration procedure called by the binder, using the compilation
138 -- unit name, calls in fact the elaboration procedure for the package.
140 -- Not surprisingly, private types complicate this approach. By saving in
141 -- the original generic object the non-local references, we guarantee that
142 -- the proper entities are referenced at the point of instantiation.
143 -- However, for private types, this by itself does not insure that the
144 -- proper VIEW of the entity is used (the full type may be visible at the
145 -- point of generic definition, but not at instantiation, or vice-versa).
146 -- In order to reference the proper view, we special-case any reference
147 -- to private types in the generic object, by saving both views, one in
148 -- the generic and one in the semantic copy. At time of instantiation, we
149 -- check whether the two views are consistent, and exchange declarations if
150 -- necessary, in order to restore the correct visibility. Similarly, if
151 -- the instance view is private when the generic view was not, we perform
152 -- the exchange. After completing the instantiation, we restore the
153 -- current visibility. The flag Has_Private_View marks identifiers in the
154 -- the generic unit that require checking.
156 -- Visibility within nested generic units requires special handling.
157 -- Consider the following scheme:
159 -- type Global is ... -- outside of generic unit.
163 -- type Semi_Global is ... -- global to inner.
166 -- procedure inner (X1 : Global; X2 : Semi_Global);
168 -- procedure in2 is new inner (...); -- 4
171 -- package New_Outer is new Outer (...); -- 2
172 -- procedure New_Inner is new New_Outer.Inner (...); -- 3
174 -- The semantic analysis of Outer captures all occurrences of Global.
175 -- The semantic analysis of Inner (at 1) captures both occurrences of
176 -- Global and Semi_Global.
178 -- At point 2 (instantiation of Outer), we also produce a generic copy
179 -- of Inner, even though Inner is, at that point, not being instantiated.
180 -- (This is just part of the semantic analysis of New_Outer).
182 -- Critically, references to Global within Inner must be preserved, while
183 -- references to Semi_Global should not preserved, because they must now
184 -- resolve to an entity within New_Outer. To distinguish between these, we
185 -- use a global variable, Current_Instantiated_Parent, which is set when
186 -- performing a generic copy during instantiation (at 2). This variable is
187 -- used when performing a generic copy that is not an instantiation, but
188 -- that is nested within one, as the occurrence of 1 within 2. The analysis
189 -- of a nested generic only preserves references that are global to the
190 -- enclosing Current_Instantiated_Parent. We use the Scope_Depth value to
191 -- determine whether a reference is external to the given parent.
193 -- The instantiation at point 3 requires no special treatment. The method
194 -- works as well for further nestings of generic units, but of course the
195 -- variable Current_Instantiated_Parent must be stacked because nested
196 -- instantiations can occur, e.g. the occurrence of 4 within 2.
198 -- The instantiation of package and subprogram bodies is handled in a
199 -- similar manner, except that it is delayed until after semantic
200 -- analysis is complete. In this fashion complex cross-dependencies
201 -- between several package declarations and bodies containing generics
202 -- can be compiled which otherwise would diagnose spurious circularities.
204 -- For example, it is possible to compile two packages A and B that
205 -- have the following structure:
207 -- package A is package B is
208 -- generic ... generic ...
209 -- package G_A is package G_B is
212 -- package body A is package body B is
213 -- package N_B is new G_B (..) package N_A is new G_A (..)
215 -- The table Pending_Instantiations in package Inline is used to keep
216 -- track of body instantiations that are delayed in this manner. Inline
217 -- handles the actual calls to do the body instantiations. This activity
218 -- is part of Inline, since the processing occurs at the same point, and
219 -- for essentially the same reason, as the handling of inlined routines.
221 ----------------------------------------------
222 -- Detection of Instantiation Circularities --
223 ----------------------------------------------
225 -- If we have a chain of instantiations that is circular, this is static
226 -- error which must be detected at compile time. The detection of these
227 -- circularities is carried out at the point that we insert a generic
228 -- instance spec or body. If there is a circularity, then the analysis of
229 -- the offending spec or body will eventually result in trying to load the
230 -- same unit again, and we detect this problem as we analyze the package
231 -- instantiation for the second time.
233 -- At least in some cases after we have detected the circularity, we get
234 -- into trouble if we try to keep going. The following flag is set if a
235 -- circularity is detected, and used to abandon compilation after the
236 -- messages have been posted.
238 Circularity_Detected : Boolean := False;
239 -- This should really be reset on encountering a new main unit, but in
240 -- practice we are not using multiple main units so it is not critical.
242 -------------------------------------------------
243 -- Formal packages and partial parametrization --
244 -------------------------------------------------
246 -- When compiling a generic, a formal package is a local instantiation. If
247 -- declared with a box, its generic formals are visible in the enclosing
248 -- generic. If declared with a partial list of actuals, those actuals that
249 -- are defaulted (covered by an Others clause, or given an explicit box
250 -- initialization) are also visible in the enclosing generic, while those
251 -- that have a corresponding actual are not.
253 -- In our source model of instantiation, the same visibility must be
254 -- present in the spec and body of an instance: the names of the formals
255 -- that are defaulted must be made visible within the instance, and made
256 -- invisible (hidden) after the instantiation is complete, so that they
257 -- are not accessible outside of the instance.
259 -- In a generic, a formal package is treated like a special instantiation.
260 -- Our Ada95 compiler handled formals with and without box in different
261 -- ways. With partial parametrization, we use a single model for both.
262 -- We create a package declaration that consists of the specification of
263 -- the generic package, and a set of declarations that map the actuals
264 -- into local renamings, just as we do for bona fide instantiations. For
265 -- defaulted parameters and formals with a box, we copy directly the
266 -- declarations of the formal into this local package. The result is a
267 -- a package whose visible declarations may include generic formals. This
268 -- package is only used for type checking and visibility analysis, and
269 -- never reaches the back-end, so it can freely violate the placement
270 -- rules for generic formal declarations.
272 -- The list of declarations (renamings and copies of formals) is built
273 -- by Analyze_Associations, just as for regular instantiations.
275 -- At the point of instantiation, conformance checking must be applied only
276 -- to those parameters that were specified in the formal. We perform this
277 -- checking by creating another internal instantiation, this one including
278 -- only the renamings and the formals (the rest of the package spec is not
279 -- relevant to conformance checking). We can then traverse two lists: the
280 -- list of actuals in the instance that corresponds to the formal package,
281 -- and the list of actuals produced for this bogus instantiation. We apply
282 -- the conformance rules to those actuals that are not defaulted (i.e.
283 -- which still appear as generic formals.
285 -- When we compile an instance body we must make the right parameters
286 -- visible again. The predicate Is_Generic_Formal indicates which of the
287 -- formals should have its Is_Hidden flag reset.
289 -----------------------
290 -- Local subprograms --
291 -----------------------
293 procedure Abandon_Instantiation (N : Node_Id);
294 pragma No_Return (Abandon_Instantiation);
295 -- Posts an error message "instantiation abandoned" at the indicated node
296 -- and then raises the exception Instantiation_Error to do it.
298 procedure Analyze_Formal_Array_Type
299 (T : in out Entity_Id;
301 -- A formal array type is treated like an array type declaration, and
302 -- invokes Array_Type_Declaration (sem_ch3) whose first parameter is
303 -- in-out, because in the case of an anonymous type the entity is
304 -- actually created in the procedure.
306 -- The following procedures treat other kinds of formal parameters
308 procedure Analyze_Formal_Derived_Interface_Type
313 procedure Analyze_Formal_Derived_Type
318 procedure Analyze_Formal_Interface_Type
323 -- The following subprograms create abbreviated declarations for formal
324 -- scalar types. We introduce an anonymous base of the proper class for
325 -- each of them, and define the formals as constrained first subtypes of
326 -- their bases. The bounds are expressions that are non-static in the
329 procedure Analyze_Formal_Decimal_Fixed_Point_Type
330 (T : Entity_Id; Def : Node_Id);
331 procedure Analyze_Formal_Discrete_Type (T : Entity_Id; Def : Node_Id);
332 procedure Analyze_Formal_Floating_Type (T : Entity_Id; Def : Node_Id);
333 procedure Analyze_Formal_Signed_Integer_Type (T : Entity_Id; Def : Node_Id);
334 procedure Analyze_Formal_Modular_Type (T : Entity_Id; Def : Node_Id);
335 procedure Analyze_Formal_Ordinary_Fixed_Point_Type
336 (T : Entity_Id; Def : Node_Id);
338 procedure Analyze_Formal_Private_Type
342 -- Creates a new private type, which does not require completion
344 procedure Analyze_Generic_Formal_Part (N : Node_Id);
346 procedure Analyze_Generic_Access_Type (T : Entity_Id; Def : Node_Id);
347 -- Create a new access type with the given designated type
349 function Analyze_Associations
352 F_Copy : List_Id) return List_Id;
353 -- At instantiation time, build the list of associations between formals
354 -- and actuals. Each association becomes a renaming declaration for the
355 -- formal entity. F_Copy is the analyzed list of formals in the generic
356 -- copy. It is used to apply legality checks to the actuals. I_Node is the
357 -- instantiation node itself.
359 procedure Analyze_Subprogram_Instantiation
363 procedure Build_Instance_Compilation_Unit_Nodes
367 -- This procedure is used in the case where the generic instance of a
368 -- subprogram body or package body is a library unit. In this case, the
369 -- original library unit node for the generic instantiation must be
370 -- replaced by the resulting generic body, and a link made to a new
371 -- compilation unit node for the generic declaration. The argument N is
372 -- the original generic instantiation. Act_Body and Act_Decl are the body
373 -- and declaration of the instance (either package body and declaration
374 -- nodes or subprogram body and declaration nodes depending on the case).
375 -- On return, the node N has been rewritten with the actual body.
377 procedure Check_Access_Definition (N : Node_Id);
378 -- Subsidiary routine to null exclusion processing. Perform an assertion
379 -- check on Ada version and the presence of an access definition in N.
381 procedure Check_Formal_Packages (P_Id : Entity_Id);
382 -- Apply the following to all formal packages in generic associations
384 procedure Check_Formal_Package_Instance
385 (Formal_Pack : Entity_Id;
386 Actual_Pack : Entity_Id);
387 -- Verify that the actuals of the actual instance match the actuals of
388 -- the template for a formal package that is not declared with a box.
390 procedure Check_Forward_Instantiation (Decl : Node_Id);
391 -- If the generic is a local entity and the corresponding body has not
392 -- been seen yet, flag enclosing packages to indicate that it will be
393 -- elaborated after the generic body. Subprograms declared in the same
394 -- package cannot be inlined by the front-end because front-end inlining
395 -- requires a strict linear order of elaboration.
397 procedure Check_Hidden_Child_Unit
399 Gen_Unit : Entity_Id;
400 Act_Decl_Id : Entity_Id);
401 -- If the generic unit is an implicit child instance within a parent
402 -- instance, we need to make an explicit test that it is not hidden by
403 -- a child instance of the same name and parent.
405 procedure Check_Generic_Actuals
406 (Instance : Entity_Id;
407 Is_Formal_Box : Boolean);
408 -- Similar to previous one. Check the actuals in the instantiation,
409 -- whose views can change between the point of instantiation and the point
410 -- of instantiation of the body. In addition, mark the generic renamings
411 -- as generic actuals, so that they are not compatible with other actuals.
412 -- Recurse on an actual that is a formal package whose declaration has
415 function Contains_Instance_Of
418 N : Node_Id) return Boolean;
419 -- Inner is instantiated within the generic Outer. Check whether Inner
420 -- directly or indirectly contains an instance of Outer or of one of its
421 -- parents, in the case of a subunit. Each generic unit holds a list of
422 -- the entities instantiated within (at any depth). This procedure
423 -- determines whether the set of such lists contains a cycle, i.e. an
424 -- illegal circular instantiation.
426 function Denotes_Formal_Package
428 On_Exit : Boolean := False;
429 Instance : Entity_Id := Empty) return Boolean;
430 -- Returns True if E is a formal package of an enclosing generic, or
431 -- the actual for such a formal in an enclosing instantiation. If such
432 -- a package is used as a formal in an nested generic, or as an actual
433 -- in a nested instantiation, the visibility of ITS formals should not
434 -- be modified. When called from within Restore_Private_Views, the flag
435 -- On_Exit is true, to indicate that the search for a possible enclosing
436 -- instance should ignore the current one. In that case Instance denotes
437 -- the declaration for which this is an actual. This declaration may be
438 -- an instantiation in the source, or the internal instantiation that
439 -- corresponds to the actual for a formal package.
441 function Find_Actual_Type
443 Gen_Type : Entity_Id) return Entity_Id;
444 -- When validating the actual types of a child instance, check whether
445 -- the formal is a formal type of the parent unit, and retrieve the current
446 -- actual for it. Typ is the entity in the analyzed formal type declaration
447 -- (component or index type of an array type, or designated type of an
448 -- access formal) and Gen_Type is the enclosing analyzed formal array
449 -- or access type. The desired actual may be a formal of a parent, or may
450 -- be declared in a formal package of a parent. In both cases it is a
451 -- generic actual type because it appears within a visible instance.
452 -- Finally, it may be declared in a parent unit without being a formal
453 -- of that unit, in which case it must be retrieved by visibility.
454 -- Ambiguities may still arise if two homonyms are declared in two formal
455 -- packages, and the prefix of the formal type may be needed to resolve
456 -- the ambiguity in the instance ???
458 function In_Same_Declarative_Part
460 Inst : Node_Id) return Boolean;
461 -- True if the instantiation Inst and the given freeze_node F_Node appear
462 -- within the same declarative part, ignoring subunits, but with no inter-
463 -- vening subprograms or concurrent units. If true, the freeze node
464 -- of the instance can be placed after the freeze node of the parent,
465 -- which it itself an instance.
467 function In_Main_Context (E : Entity_Id) return Boolean;
468 -- Check whether an instantiation is in the context of the main unit.
469 -- Used to determine whether its body should be elaborated to allow
470 -- front-end inlining.
472 function Is_Generic_Formal (E : Entity_Id) return Boolean;
473 -- Utility to determine whether a given entity is declared by means of
474 -- of a formal parameter declaration. Used to set properly the visibility
475 -- of generic formals of a generic package declared with a box or with
476 -- partial parametrization.
478 procedure Set_Instance_Env
479 (Gen_Unit : Entity_Id;
480 Act_Unit : Entity_Id);
481 -- Save current instance on saved environment, to be used to determine
482 -- the global status of entities in nested instances. Part of Save_Env.
483 -- called after verifying that the generic unit is legal for the instance,
484 -- The procedure also examines whether the generic unit is a predefined
485 -- unit, in order to set configuration switches accordingly. As a result
486 -- the procedure must be called after analyzing and freezing the actuals.
488 procedure Set_Instance_Of (A : Entity_Id; B : Entity_Id);
489 -- Associate analyzed generic parameter with corresponding
490 -- instance. Used for semantic checks at instantiation time.
492 function Has_Been_Exchanged (E : Entity_Id) return Boolean;
493 -- Traverse the Exchanged_Views list to see if a type was private
494 -- and has already been flipped during this phase of instantiation.
496 procedure Hide_Current_Scope;
497 -- When instantiating a generic child unit, the parent context must be
498 -- present, but the instance and all entities that may be generated
499 -- must be inserted in the current scope. We leave the current scope
500 -- on the stack, but make its entities invisible to avoid visibility
501 -- problems. This is reversed at the end of the instantiation. This is
502 -- not done for the instantiation of the bodies, which only require the
503 -- instances of the generic parents to be in scope.
505 procedure Install_Body
510 -- If the instantiation happens textually before the body of the generic,
511 -- the instantiation of the body must be analyzed after the generic body,
512 -- and not at the point of instantiation. Such early instantiations can
513 -- happen if the generic and the instance appear in a package declaration
514 -- because the generic body can only appear in the corresponding package
515 -- body. Early instantiations can also appear if generic, instance and
516 -- body are all in the declarative part of a subprogram or entry. Entities
517 -- of packages that are early instantiations are delayed, and their freeze
518 -- node appears after the generic body.
520 procedure Insert_After_Last_Decl (N : Node_Id; F_Node : Node_Id);
521 -- Insert freeze node at the end of the declarative part that includes the
522 -- instance node N. If N is in the visible part of an enclosing package
523 -- declaration, the freeze node has to be inserted at the end of the
524 -- private declarations, if any.
526 procedure Freeze_Subprogram_Body
527 (Inst_Node : Node_Id;
529 Pack_Id : Entity_Id);
530 -- The generic body may appear textually after the instance, including
531 -- in the proper body of a stub, or within a different package instance.
532 -- Given that the instance can only be elaborated after the generic, we
533 -- place freeze_nodes for the instance and/or for packages that may enclose
534 -- the instance and the generic, so that the back-end can establish the
535 -- proper order of elaboration.
538 -- Establish environment for subsequent instantiation. Separated from
539 -- Save_Env because data-structures for visibility handling must be
540 -- initialized before call to Check_Generic_Child_Unit.
542 procedure Install_Formal_Packages (Par : Entity_Id);
543 -- If any of the formals of the parent are formal packages with box,
544 -- their formal parts are visible in the parent and thus in the child
545 -- unit as well. Analogous to what is done in Check_Generic_Actuals
546 -- for the unit itself. This procedure is also used in an instance, to
547 -- make visible the proper entities of the actual for a formal package
548 -- declared with a box.
550 procedure Install_Parent (P : Entity_Id; In_Body : Boolean := False);
551 -- When compiling an instance of a child unit the parent (which is
552 -- itself an instance) is an enclosing scope that must be made
553 -- immediately visible. This procedure is also used to install the non-
554 -- generic parent of a generic child unit when compiling its body, so
555 -- that full views of types in the parent are made visible.
557 procedure Remove_Parent (In_Body : Boolean := False);
558 -- Reverse effect after instantiation of child is complete
560 procedure Inline_Instance_Body
562 Gen_Unit : Entity_Id;
564 -- If front-end inlining is requested, instantiate the package body,
565 -- and preserve the visibility of its compilation unit, to insure
566 -- that successive instantiations succeed.
568 -- The functions Instantiate_XXX perform various legality checks and build
569 -- the declarations for instantiated generic parameters. In all of these
570 -- Formal is the entity in the generic unit, Actual is the entity of
571 -- expression in the generic associations, and Analyzed_Formal is the
572 -- formal in the generic copy, which contains the semantic information to
573 -- be used to validate the actual.
575 function Instantiate_Object
578 Analyzed_Formal : Node_Id) return List_Id;
580 function Instantiate_Type
583 Analyzed_Formal : Node_Id;
584 Actual_Decls : List_Id) return List_Id;
586 function Instantiate_Formal_Subprogram
589 Analyzed_Formal : Node_Id) return Node_Id;
591 function Instantiate_Formal_Package
594 Analyzed_Formal : Node_Id) return List_Id;
595 -- If the formal package is declared with a box, special visibility rules
596 -- apply to its formals: they are in the visible part of the package. This
597 -- is true in the declarative region of the formal package, that is to say
598 -- in the enclosing generic or instantiation. For an instantiation, the
599 -- parameters of the formal package are made visible in an explicit step.
600 -- Furthermore, if the actual has a visible USE clause, these formals must
601 -- be made potentially use-visible as well. On exit from the enclosing
602 -- instantiation, the reverse must be done.
604 -- For a formal package declared without a box, there are conformance rules
605 -- that apply to the actuals in the generic declaration and the actuals of
606 -- the actual package in the enclosing instantiation. The simplest way to
607 -- apply these rules is to repeat the instantiation of the formal package
608 -- in the context of the enclosing instance, and compare the generic
609 -- associations of this instantiation with those of the actual package.
610 -- This internal instantiation only needs to contain the renamings of the
611 -- formals: the visible and private declarations themselves need not be
614 -- In Ada 2005, the formal package may be only partially parametrized. In
615 -- that case the visibility step must make visible those actuals whose
616 -- corresponding formals were given with a box. A final complication
617 -- involves inherited operations from formal derived types, which must be
618 -- visible if the type is.
620 function Is_In_Main_Unit (N : Node_Id) return Boolean;
621 -- Test if given node is in the main unit
623 procedure Load_Parent_Of_Generic
626 Body_Optional : Boolean := False);
627 -- If the generic appears in a separate non-generic library unit, load the
628 -- corresponding body to retrieve the body of the generic. N is the node
629 -- for the generic instantiation, Spec is the generic package declaration.
631 -- Body_Optional is a flag that indicates that the body is being loaded to
632 -- ensure that temporaries are generated consistently when there are other
633 -- instances in the current declarative part that precede the one being
634 -- loaded. In that case a missing body is acceptable.
636 procedure Inherit_Context (Gen_Decl : Node_Id; Inst : Node_Id);
637 -- Add the context clause of the unit containing a generic unit to an
638 -- instantiation that is a compilation unit.
640 function Get_Associated_Node (N : Node_Id) return Node_Id;
641 -- In order to propagate semantic information back from the analyzed copy
642 -- to the original generic, we maintain links between selected nodes in the
643 -- generic and their corresponding copies. At the end of generic analysis,
644 -- the routine Save_Global_References traverses the generic tree, examines
645 -- the semantic information, and preserves the links to those nodes that
646 -- contain global information. At instantiation, the information from the
647 -- associated node is placed on the new copy, so that name resolution is
650 -- Three kinds of source nodes have associated nodes:
652 -- a) those that can reference (denote) entities, that is identifiers,
653 -- character literals, expanded_names, operator symbols, operators,
654 -- and attribute reference nodes. These nodes have an Entity field
655 -- and are the set of nodes that are in N_Has_Entity.
657 -- b) aggregates (N_Aggregate and N_Extension_Aggregate)
659 -- c) selected components (N_Selected_Component)
661 -- For the first class, the associated node preserves the entity if it is
662 -- global. If the generic contains nested instantiations, the associated
663 -- node itself has been recopied, and a chain of them must be followed.
665 -- For aggregates, the associated node allows retrieval of the type, which
666 -- may otherwise not appear in the generic. The view of this type may be
667 -- different between generic and instantiation, and the full view can be
668 -- installed before the instantiation is analyzed. For aggregates of type
669 -- extensions, the same view exchange may have to be performed for some of
670 -- the ancestor types, if their view is private at the point of
673 -- Nodes that are selected components in the parse tree may be rewritten
674 -- as expanded names after resolution, and must be treated as potential
675 -- entity holders, which is why they also have an Associated_Node.
677 -- Nodes that do not come from source, such as freeze nodes, do not appear
678 -- in the generic tree, and need not have an associated node.
680 -- The associated node is stored in the Associated_Node field. Note that
681 -- this field overlaps Entity, which is fine, because the whole point is
682 -- that we don't need or want the normal Entity field in this situation.
684 procedure Map_Formal_Package_Entities (Form : Entity_Id; Act : Entity_Id);
685 -- Within the generic part, entities in the formal package are
686 -- visible. To validate subsequent type declarations, indicate
687 -- the correspondence between the entities in the analyzed formal,
688 -- and the entities in the actual package. There are three packages
689 -- involved in the instantiation of a formal package: the parent
690 -- generic P1 which appears in the generic declaration, the fake
691 -- instantiation P2 which appears in the analyzed generic, and whose
692 -- visible entities may be used in subsequent formals, and the actual
693 -- P3 in the instance. To validate subsequent formals, me indicate
694 -- that the entities in P2 are mapped into those of P3. The mapping of
695 -- entities has to be done recursively for nested packages.
697 procedure Move_Freeze_Nodes
701 -- Freeze nodes can be generated in the analysis of a generic unit, but
702 -- will not be seen by the back-end. It is necessary to move those nodes
703 -- to the enclosing scope if they freeze an outer entity. We place them
704 -- at the end of the enclosing generic package, which is semantically
707 procedure Preanalyze_Actuals (N : Node_Id);
708 -- Analyze actuals to perform name resolution. Full resolution is done
709 -- later, when the expected types are known, but names have to be captured
710 -- before installing parents of generics, that are not visible for the
711 -- actuals themselves.
713 procedure Valid_Default_Attribute (Nam : Entity_Id; Def : Node_Id);
714 -- Verify that an attribute that appears as the default for a formal
715 -- subprogram is a function or procedure with the correct profile.
717 -------------------------------------------
718 -- Data Structures for Generic Renamings --
719 -------------------------------------------
721 -- The map Generic_Renamings associates generic entities with their
722 -- corresponding actuals. Currently used to validate type instances. It
723 -- will eventually be used for all generic parameters to eliminate the
724 -- need for overload resolution in the instance.
726 type Assoc_Ptr is new Int;
728 Assoc_Null : constant Assoc_Ptr := -1;
733 Next_In_HTable : Assoc_Ptr;
736 package Generic_Renamings is new Table.Table
737 (Table_Component_Type => Assoc,
738 Table_Index_Type => Assoc_Ptr,
739 Table_Low_Bound => 0,
741 Table_Increment => 100,
742 Table_Name => "Generic_Renamings");
744 -- Variable to hold enclosing instantiation. When the environment is
745 -- saved for a subprogram inlining, the corresponding Act_Id is empty.
747 Current_Instantiated_Parent : Assoc := (Empty, Empty, Assoc_Null);
749 -- Hash table for associations
751 HTable_Size : constant := 37;
752 type HTable_Range is range 0 .. HTable_Size - 1;
754 procedure Set_Next_Assoc (E : Assoc_Ptr; Next : Assoc_Ptr);
755 function Next_Assoc (E : Assoc_Ptr) return Assoc_Ptr;
756 function Get_Gen_Id (E : Assoc_Ptr) return Entity_Id;
757 function Hash (F : Entity_Id) return HTable_Range;
759 package Generic_Renamings_HTable is new GNAT.HTable.Static_HTable (
760 Header_Num => HTable_Range,
762 Elmt_Ptr => Assoc_Ptr,
763 Null_Ptr => Assoc_Null,
764 Set_Next => Set_Next_Assoc,
767 Get_Key => Get_Gen_Id,
771 Exchanged_Views : Elist_Id;
772 -- This list holds the private views that have been exchanged during
773 -- instantiation to restore the visibility of the generic declaration.
774 -- (see comments above). After instantiation, the current visibility is
775 -- reestablished by means of a traversal of this list.
777 Hidden_Entities : Elist_Id;
778 -- This list holds the entities of the current scope that are removed
779 -- from immediate visibility when instantiating a child unit. Their
780 -- visibility is restored in Remove_Parent.
782 -- Because instantiations can be recursive, the following must be saved
783 -- on entry and restored on exit from an instantiation (spec or body).
784 -- This is done by the two procedures Save_Env and Restore_Env. For
785 -- package and subprogram instantiations (but not for the body instances)
786 -- the action of Save_Env is done in two steps: Init_Env is called before
787 -- Check_Generic_Child_Unit, because setting the parent instances requires
788 -- that the visibility data structures be properly initialized. Once the
789 -- generic is unit is validated, Set_Instance_Env completes Save_Env.
791 Parent_Unit_Visible : Boolean := False;
792 -- Parent_Unit_Visible is used when the generic is a child unit, and
793 -- indicates whether the ultimate parent of the generic is visible in the
794 -- instantiation environment. It is used to reset the visibility of the
795 -- parent at the end of the instantiation (see Remove_Parent).
797 Instance_Parent_Unit : Entity_Id := Empty;
798 -- This records the ultimate parent unit of an instance of a generic
799 -- child unit and is used in conjunction with Parent_Unit_Visible to
800 -- indicate the unit to which the Parent_Unit_Visible flag corresponds.
802 type Instance_Env is record
803 Instantiated_Parent : Assoc;
804 Exchanged_Views : Elist_Id;
805 Hidden_Entities : Elist_Id;
806 Current_Sem_Unit : Unit_Number_Type;
807 Parent_Unit_Visible : Boolean := False;
808 Instance_Parent_Unit : Entity_Id := Empty;
809 Switches : Config_Switches_Type;
812 package Instance_Envs is new Table.Table (
813 Table_Component_Type => Instance_Env,
814 Table_Index_Type => Int,
815 Table_Low_Bound => 0,
817 Table_Increment => 100,
818 Table_Name => "Instance_Envs");
820 procedure Restore_Private_Views
821 (Pack_Id : Entity_Id;
822 Is_Package : Boolean := True);
823 -- Restore the private views of external types, and unmark the generic
824 -- renamings of actuals, so that they become compatible subtypes again.
825 -- For subprograms, Pack_Id is the package constructed to hold the
828 procedure Switch_View (T : Entity_Id);
829 -- Switch the partial and full views of a type and its private
830 -- dependents (i.e. its subtypes and derived types).
832 ------------------------------------
833 -- Structures for Error Reporting --
834 ------------------------------------
836 Instantiation_Node : Node_Id;
837 -- Used by subprograms that validate instantiation of formal parameters
838 -- where there might be no actual on which to place the error message.
839 -- Also used to locate the instantiation node for generic subunits.
841 Instantiation_Error : exception;
842 -- When there is a semantic error in the generic parameter matching,
843 -- there is no point in continuing the instantiation, because the
844 -- number of cascaded errors is unpredictable. This exception aborts
845 -- the instantiation process altogether.
847 S_Adjustment : Sloc_Adjustment;
848 -- Offset created for each node in an instantiation, in order to keep
849 -- track of the source position of the instantiation in each of its nodes.
850 -- A subsequent semantic error or warning on a construct of the instance
851 -- points to both places: the original generic node, and the point of
852 -- instantiation. See Sinput and Sinput.L for additional details.
854 ------------------------------------------------------------
855 -- Data structure for keeping track when inside a Generic --
856 ------------------------------------------------------------
858 -- The following table is used to save values of the Inside_A_Generic
859 -- flag (see spec of Sem) when they are saved by Start_Generic.
861 package Generic_Flags is new Table.Table (
862 Table_Component_Type => Boolean,
863 Table_Index_Type => Int,
864 Table_Low_Bound => 0,
866 Table_Increment => 200,
867 Table_Name => "Generic_Flags");
869 ---------------------------
870 -- Abandon_Instantiation --
871 ---------------------------
873 procedure Abandon_Instantiation (N : Node_Id) is
875 Error_Msg_N ("\instantiation abandoned!", N);
876 raise Instantiation_Error;
877 end Abandon_Instantiation;
879 --------------------------
880 -- Analyze_Associations --
881 --------------------------
883 function Analyze_Associations
886 F_Copy : List_Id) return List_Id
888 Actual_Types : constant Elist_Id := New_Elmt_List;
889 Assoc : constant List_Id := New_List;
890 Default_Actuals : constant Elist_Id := New_Elmt_List;
891 Gen_Unit : constant Entity_Id := Defining_Entity (Parent (F_Copy));
895 Next_Formal : Node_Id;
896 Temp_Formal : Node_Id;
897 Analyzed_Formal : Node_Id;
900 First_Named : Node_Id := Empty;
902 Default_Formals : constant List_Id := New_List;
903 -- If an Other_Choice is present, some of the formals may be defaulted.
904 -- To simplify the treatment of visibility in an instance, we introduce
905 -- individual defaults for each such formal. These defaults are
906 -- appended to the list of associations and replace the Others_Choice.
908 Found_Assoc : Node_Id;
909 -- Association for the current formal being match. Empty if there are
910 -- no remaining actuals, or if there is no named association with the
911 -- name of the formal.
913 Is_Named_Assoc : Boolean;
914 Num_Matched : Int := 0;
915 Num_Actuals : Int := 0;
917 Others_Present : Boolean := False;
918 -- In Ada 2005, indicates partial parametrization of a formal
919 -- package. As usual an other association must be last in the list.
921 function Matching_Actual
923 A_F : Entity_Id) return Node_Id;
924 -- Find actual that corresponds to a given a formal parameter. If the
925 -- actuals are positional, return the next one, if any. If the actuals
926 -- are named, scan the parameter associations to find the right one.
927 -- A_F is the corresponding entity in the analyzed generic,which is
928 -- placed on the selector name for ASIS use.
930 -- In Ada 2005, a named association may be given with a box, in which
931 -- case Matching_Actual sets Found_Assoc to the generic association,
932 -- but return Empty for the actual itself. In this case the code below
933 -- creates a corresponding declaration for the formal.
935 function Partial_Parametrization return Boolean;
936 -- Ada 2005: if no match is found for a given formal, check if the
937 -- association for it includes a box, or whether the associations
938 -- include an Others clause.
940 procedure Process_Default (F : Entity_Id);
941 -- Add a copy of the declaration of generic formal F to the list of
942 -- associations, and add an explicit box association for F if there
943 -- is none yet, and the default comes from an Others_Choice.
945 procedure Set_Analyzed_Formal;
946 -- Find the node in the generic copy that corresponds to a given formal.
947 -- The semantic information on this node is used to perform legality
948 -- checks on the actuals. Because semantic analysis can introduce some
949 -- anonymous entities or modify the declaration node itself, the
950 -- correspondence between the two lists is not one-one. In addition to
951 -- anonymous types, the presence a formal equality will introduce an
952 -- implicit declaration for the corresponding inequality.
954 ---------------------
955 -- Matching_Actual --
956 ---------------------
958 function Matching_Actual
960 A_F : Entity_Id) return Node_Id
966 Is_Named_Assoc := False;
968 -- End of list of purely positional parameters
971 or else Nkind (Actual) = N_Others_Choice
973 Found_Assoc := Empty;
976 -- Case of positional parameter corresponding to current formal
978 elsif No (Selector_Name (Actual)) then
979 Found_Assoc := Actual;
980 Act := Explicit_Generic_Actual_Parameter (Actual);
981 Num_Matched := Num_Matched + 1;
984 -- Otherwise scan list of named actuals to find the one with the
985 -- desired name. All remaining actuals have explicit names.
988 Is_Named_Assoc := True;
989 Found_Assoc := Empty;
993 while Present (Actual) loop
994 if Chars (Selector_Name (Actual)) = Chars (F) then
995 Set_Entity (Selector_Name (Actual), A_F);
996 Set_Etype (Selector_Name (Actual), Etype (A_F));
997 Generate_Reference (A_F, Selector_Name (Actual));
998 Found_Assoc := Actual;
999 Act := Explicit_Generic_Actual_Parameter (Actual);
1000 Num_Matched := Num_Matched + 1;
1008 -- Reset for subsequent searches. In most cases the named
1009 -- associations are in order. If they are not, we reorder them
1010 -- to avoid scanning twice the same actual. This is not just a
1011 -- question of efficiency: there may be multiple defaults with
1012 -- boxes that have the same name. In a nested instantiation we
1013 -- insert actuals for those defaults, and cannot rely on their
1014 -- names to disambiguate them.
1016 if Actual = First_Named then
1019 elsif Present (Actual) then
1020 Insert_Before (First_Named, Remove_Next (Prev));
1023 Actual := First_Named;
1026 if Is_Entity_Name (Act) and then Present (Entity (Act)) then
1027 Set_Used_As_Generic_Actual (Entity (Act));
1031 end Matching_Actual;
1033 -----------------------------
1034 -- Partial_Parametrization --
1035 -----------------------------
1037 function Partial_Parametrization return Boolean is
1039 return Others_Present
1040 or else (Present (Found_Assoc) and then Box_Present (Found_Assoc));
1041 end Partial_Parametrization;
1043 ---------------------
1044 -- Process_Default --
1045 ---------------------
1047 procedure Process_Default (F : Entity_Id) is
1048 Loc : constant Source_Ptr := Sloc (I_Node);
1049 F_Id : constant Entity_Id := Defining_Entity (F);
1056 -- Append copy of formal declaration to associations, and create
1057 -- new defining identifier for it.
1059 Decl := New_Copy_Tree (F);
1060 Id := Make_Defining_Identifier (Sloc (F_Id), Chars => Chars (F_Id));
1062 if Nkind (F) in N_Formal_Subprogram_Declaration then
1063 Set_Defining_Unit_Name (Specification (Decl), Id);
1066 Set_Defining_Identifier (Decl, Id);
1069 Append (Decl, Assoc);
1071 if No (Found_Assoc) then
1073 Make_Generic_Association (Loc,
1074 Selector_Name => New_Occurrence_Of (Id, Loc),
1075 Explicit_Generic_Actual_Parameter => Empty);
1076 Set_Box_Present (Default);
1077 Append (Default, Default_Formals);
1079 end Process_Default;
1081 -------------------------
1082 -- Set_Analyzed_Formal --
1083 -------------------------
1085 procedure Set_Analyzed_Formal is
1089 while Present (Analyzed_Formal) loop
1090 Kind := Nkind (Analyzed_Formal);
1092 case Nkind (Formal) is
1094 when N_Formal_Subprogram_Declaration =>
1095 exit when Kind in N_Formal_Subprogram_Declaration
1098 (Defining_Unit_Name (Specification (Formal))) =
1100 (Defining_Unit_Name (Specification (Analyzed_Formal)));
1102 when N_Formal_Package_Declaration =>
1103 exit when Nkind_In (Kind, N_Formal_Package_Declaration,
1104 N_Generic_Package_Declaration,
1105 N_Package_Declaration);
1107 when N_Use_Package_Clause | N_Use_Type_Clause => exit;
1111 -- Skip freeze nodes, and nodes inserted to replace
1112 -- unrecognized pragmas.
1115 Kind not in N_Formal_Subprogram_Declaration
1116 and then not Nkind_In (Kind, N_Subprogram_Declaration,
1120 and then Chars (Defining_Identifier (Formal)) =
1121 Chars (Defining_Identifier (Analyzed_Formal));
1124 Next (Analyzed_Formal);
1126 end Set_Analyzed_Formal;
1128 -- Start of processing for Analyze_Associations
1131 Actuals := Generic_Associations (I_Node);
1133 if Present (Actuals) then
1135 -- check for an Others choice, indicating a partial parametrization
1136 -- for a formal package.
1138 Actual := First (Actuals);
1139 while Present (Actual) loop
1140 if Nkind (Actual) = N_Others_Choice then
1141 Others_Present := True;
1143 if Present (Next (Actual)) then
1144 Error_Msg_N ("others must be last association", Actual);
1147 -- This subprogram is used both for formal packages and for
1148 -- instantiations. For the latter, associations must all be
1151 if Nkind (I_Node) /= N_Formal_Package_Declaration
1152 and then Comes_From_Source (I_Node)
1155 ("others association not allowed in an instance",
1159 -- In any case, nothing to do after the others association
1163 elsif Box_Present (Actual)
1164 and then Comes_From_Source (I_Node)
1165 and then Nkind (I_Node) /= N_Formal_Package_Declaration
1168 ("box association not allowed in an instance", Actual);
1174 -- If named associations are present, save first named association
1175 -- (it may of course be Empty) to facilitate subsequent name search.
1177 First_Named := First (Actuals);
1178 while Present (First_Named)
1179 and then Nkind (First_Named) /= N_Others_Choice
1180 and then No (Selector_Name (First_Named))
1182 Num_Actuals := Num_Actuals + 1;
1187 Named := First_Named;
1188 while Present (Named) loop
1189 if Nkind (Named) /= N_Others_Choice
1190 and then No (Selector_Name (Named))
1192 Error_Msg_N ("invalid positional actual after named one", Named);
1193 Abandon_Instantiation (Named);
1196 -- A named association may lack an actual parameter, if it was
1197 -- introduced for a default subprogram that turns out to be local
1198 -- to the outer instantiation.
1200 if Nkind (Named) /= N_Others_Choice
1201 and then Present (Explicit_Generic_Actual_Parameter (Named))
1203 Num_Actuals := Num_Actuals + 1;
1209 if Present (Formals) then
1210 Formal := First_Non_Pragma (Formals);
1211 Analyzed_Formal := First_Non_Pragma (F_Copy);
1213 if Present (Actuals) then
1214 Actual := First (Actuals);
1216 -- All formals should have default values
1222 while Present (Formal) loop
1223 Set_Analyzed_Formal;
1224 Next_Formal := Next_Non_Pragma (Formal);
1226 case Nkind (Formal) is
1227 when N_Formal_Object_Declaration =>
1230 Defining_Identifier (Formal),
1231 Defining_Identifier (Analyzed_Formal));
1233 if No (Match) and then Partial_Parametrization then
1234 Process_Default (Formal);
1237 (Instantiate_Object (Formal, Match, Analyzed_Formal),
1241 when N_Formal_Type_Declaration =>
1244 Defining_Identifier (Formal),
1245 Defining_Identifier (Analyzed_Formal));
1248 if Partial_Parametrization then
1249 Process_Default (Formal);
1252 Error_Msg_Sloc := Sloc (Gen_Unit);
1256 Defining_Identifier (Formal));
1257 Error_Msg_NE ("\in instantiation of & declared#",
1258 Instantiation_Node, Gen_Unit);
1259 Abandon_Instantiation (Instantiation_Node);
1266 (Formal, Match, Analyzed_Formal, Assoc),
1269 -- An instantiation is a freeze point for the actuals,
1270 -- unless this is a rewritten formal package.
1272 if Nkind (I_Node) /= N_Formal_Package_Declaration then
1273 Append_Elmt (Entity (Match), Actual_Types);
1277 -- A remote access-to-class-wide type must not be an
1278 -- actual parameter for a generic formal of an access
1279 -- type (E.2.2 (17)).
1281 if Nkind (Analyzed_Formal) = N_Formal_Type_Declaration
1283 Nkind (Formal_Type_Definition (Analyzed_Formal)) =
1284 N_Access_To_Object_Definition
1286 Validate_Remote_Access_To_Class_Wide_Type (Match);
1289 when N_Formal_Subprogram_Declaration =>
1292 Defining_Unit_Name (Specification (Formal)),
1293 Defining_Unit_Name (Specification (Analyzed_Formal)));
1295 -- If the formal subprogram has the same name as
1296 -- another formal subprogram of the generic, then
1297 -- a named association is illegal (12.3(9)). Exclude
1298 -- named associations that are generated for a nested
1302 and then Is_Named_Assoc
1303 and then Comes_From_Source (Found_Assoc)
1305 Temp_Formal := First (Formals);
1306 while Present (Temp_Formal) loop
1307 if Nkind (Temp_Formal) in
1308 N_Formal_Subprogram_Declaration
1309 and then Temp_Formal /= Formal
1311 Chars (Selector_Name (Found_Assoc)) =
1312 Chars (Defining_Unit_Name
1313 (Specification (Temp_Formal)))
1316 ("name not allowed for overloaded formal",
1318 Abandon_Instantiation (Instantiation_Node);
1325 -- If there is no corresponding actual, this may be case of
1326 -- partial parametrization, or else the formal has a default
1330 and then Partial_Parametrization
1332 Process_Default (Formal);
1335 Instantiate_Formal_Subprogram
1336 (Formal, Match, Analyzed_Formal));
1339 -- If this is a nested generic, preserve default for later
1343 and then Box_Present (Formal)
1346 (Defining_Unit_Name (Specification (Last (Assoc))),
1350 when N_Formal_Package_Declaration =>
1353 Defining_Identifier (Formal),
1354 Defining_Identifier (Original_Node (Analyzed_Formal)));
1357 if Partial_Parametrization then
1358 Process_Default (Formal);
1361 Error_Msg_Sloc := Sloc (Gen_Unit);
1364 Instantiation_Node, Defining_Identifier (Formal));
1365 Error_Msg_NE ("\in instantiation of & declared#",
1366 Instantiation_Node, Gen_Unit);
1368 Abandon_Instantiation (Instantiation_Node);
1374 (Instantiate_Formal_Package
1375 (Formal, Match, Analyzed_Formal),
1379 -- For use type and use package appearing in the generic part,
1380 -- we have already copied them, so we can just move them where
1381 -- they belong (we mustn't recopy them since this would mess up
1382 -- the Sloc values).
1384 when N_Use_Package_Clause |
1385 N_Use_Type_Clause =>
1386 if Nkind (Original_Node (I_Node)) =
1387 N_Formal_Package_Declaration
1389 Append (New_Copy_Tree (Formal), Assoc);
1392 Append (Formal, Assoc);
1396 raise Program_Error;
1400 Formal := Next_Formal;
1401 Next_Non_Pragma (Analyzed_Formal);
1404 if Num_Actuals > Num_Matched then
1405 Error_Msg_Sloc := Sloc (Gen_Unit);
1407 if Present (Selector_Name (Actual)) then
1409 ("unmatched actual&",
1410 Actual, Selector_Name (Actual));
1411 Error_Msg_NE ("\in instantiation of& declared#",
1415 ("unmatched actual in instantiation of& declared#",
1420 elsif Present (Actuals) then
1422 ("too many actuals in generic instantiation", Instantiation_Node);
1426 Elmt : Elmt_Id := First_Elmt (Actual_Types);
1429 while Present (Elmt) loop
1430 Freeze_Before (I_Node, Node (Elmt));
1435 -- If there are default subprograms, normalize the tree by adding
1436 -- explicit associations for them. This is required if the instance
1437 -- appears within a generic.
1445 Elmt := First_Elmt (Default_Actuals);
1446 while Present (Elmt) loop
1447 if No (Actuals) then
1448 Actuals := New_List;
1449 Set_Generic_Associations (I_Node, Actuals);
1452 Subp := Node (Elmt);
1454 Make_Generic_Association (Sloc (Subp),
1455 Selector_Name => New_Occurrence_Of (Subp, Sloc (Subp)),
1456 Explicit_Generic_Actual_Parameter =>
1457 New_Occurrence_Of (Subp, Sloc (Subp)));
1458 Mark_Rewrite_Insertion (New_D);
1459 Append_To (Actuals, New_D);
1464 -- If this is a formal package, normalize the parameter list by adding
1465 -- explicit box associations for the formals that are covered by an
1468 if not Is_Empty_List (Default_Formals) then
1469 Append_List (Default_Formals, Formals);
1473 end Analyze_Associations;
1475 -------------------------------
1476 -- Analyze_Formal_Array_Type --
1477 -------------------------------
1479 procedure Analyze_Formal_Array_Type
1480 (T : in out Entity_Id;
1486 -- Treated like a non-generic array declaration, with additional
1491 if Nkind (Def) = N_Constrained_Array_Definition then
1492 DSS := First (Discrete_Subtype_Definitions (Def));
1493 while Present (DSS) loop
1494 if Nkind_In (DSS, N_Subtype_Indication,
1496 N_Attribute_Reference)
1498 Error_Msg_N ("only a subtype mark is allowed in a formal", DSS);
1505 Array_Type_Declaration (T, Def);
1506 Set_Is_Generic_Type (Base_Type (T));
1508 if Ekind (Component_Type (T)) = E_Incomplete_Type
1509 and then No (Full_View (Component_Type (T)))
1511 Error_Msg_N ("premature usage of incomplete type", Def);
1513 -- Check that range constraint is not allowed on the component type
1514 -- of a generic formal array type (AARM 12.5.3(3))
1516 elsif Is_Internal (Component_Type (T))
1517 and then Present (Subtype_Indication (Component_Definition (Def)))
1518 and then Nkind (Original_Node
1519 (Subtype_Indication (Component_Definition (Def)))) =
1520 N_Subtype_Indication
1523 ("in a formal, a subtype indication can only be "
1524 & "a subtype mark (RM 12.5.3(3))",
1525 Subtype_Indication (Component_Definition (Def)));
1528 end Analyze_Formal_Array_Type;
1530 ---------------------------------------------
1531 -- Analyze_Formal_Decimal_Fixed_Point_Type --
1532 ---------------------------------------------
1534 -- As for other generic types, we create a valid type representation with
1535 -- legal but arbitrary attributes, whose values are never considered
1536 -- static. For all scalar types we introduce an anonymous base type, with
1537 -- the same attributes. We choose the corresponding integer type to be
1538 -- Standard_Integer.
1540 procedure Analyze_Formal_Decimal_Fixed_Point_Type
1544 Loc : constant Source_Ptr := Sloc (Def);
1545 Base : constant Entity_Id :=
1547 (E_Decimal_Fixed_Point_Type,
1548 Current_Scope, Sloc (Def), 'G');
1549 Int_Base : constant Entity_Id := Standard_Integer;
1550 Delta_Val : constant Ureal := Ureal_1;
1551 Digs_Val : constant Uint := Uint_6;
1556 Set_Etype (Base, Base);
1557 Set_Size_Info (Base, Int_Base);
1558 Set_RM_Size (Base, RM_Size (Int_Base));
1559 Set_First_Rep_Item (Base, First_Rep_Item (Int_Base));
1560 Set_Digits_Value (Base, Digs_Val);
1561 Set_Delta_Value (Base, Delta_Val);
1562 Set_Small_Value (Base, Delta_Val);
1563 Set_Scalar_Range (Base,
1565 Low_Bound => Make_Real_Literal (Loc, Ureal_1),
1566 High_Bound => Make_Real_Literal (Loc, Ureal_1)));
1568 Set_Is_Generic_Type (Base);
1569 Set_Parent (Base, Parent (Def));
1571 Set_Ekind (T, E_Decimal_Fixed_Point_Subtype);
1572 Set_Etype (T, Base);
1573 Set_Size_Info (T, Int_Base);
1574 Set_RM_Size (T, RM_Size (Int_Base));
1575 Set_First_Rep_Item (T, First_Rep_Item (Int_Base));
1576 Set_Digits_Value (T, Digs_Val);
1577 Set_Delta_Value (T, Delta_Val);
1578 Set_Small_Value (T, Delta_Val);
1579 Set_Scalar_Range (T, Scalar_Range (Base));
1580 Set_Is_Constrained (T);
1582 Check_Restriction (No_Fixed_Point, Def);
1583 end Analyze_Formal_Decimal_Fixed_Point_Type;
1585 -------------------------------------------
1586 -- Analyze_Formal_Derived_Interface_Type --
1587 -------------------------------------------
1589 procedure Analyze_Formal_Derived_Interface_Type
1594 Loc : constant Source_Ptr := Sloc (Def);
1597 -- Rewrite as a type declaration of a derived type. This ensures that
1598 -- the interface list and primitive operations are properly captured.
1601 Make_Full_Type_Declaration (Loc,
1602 Defining_Identifier => T,
1603 Type_Definition => Def));
1605 Set_Is_Generic_Type (T);
1606 end Analyze_Formal_Derived_Interface_Type;
1608 ---------------------------------
1609 -- Analyze_Formal_Derived_Type --
1610 ---------------------------------
1612 procedure Analyze_Formal_Derived_Type
1617 Loc : constant Source_Ptr := Sloc (Def);
1618 Unk_Disc : constant Boolean := Unknown_Discriminants_Present (N);
1622 Set_Is_Generic_Type (T);
1624 if Private_Present (Def) then
1626 Make_Private_Extension_Declaration (Loc,
1627 Defining_Identifier => T,
1628 Discriminant_Specifications => Discriminant_Specifications (N),
1629 Unknown_Discriminants_Present => Unk_Disc,
1630 Subtype_Indication => Subtype_Mark (Def),
1631 Interface_List => Interface_List (Def));
1633 Set_Abstract_Present (New_N, Abstract_Present (Def));
1634 Set_Limited_Present (New_N, Limited_Present (Def));
1635 Set_Synchronized_Present (New_N, Synchronized_Present (Def));
1639 Make_Full_Type_Declaration (Loc,
1640 Defining_Identifier => T,
1641 Discriminant_Specifications =>
1642 Discriminant_Specifications (Parent (T)),
1644 Make_Derived_Type_Definition (Loc,
1645 Subtype_Indication => Subtype_Mark (Def)));
1647 Set_Abstract_Present
1648 (Type_Definition (New_N), Abstract_Present (Def));
1650 (Type_Definition (New_N), Limited_Present (Def));
1657 if not Is_Composite_Type (T) then
1659 ("unknown discriminants not allowed for elementary types", N);
1661 Set_Has_Unknown_Discriminants (T);
1662 Set_Is_Constrained (T, False);
1666 -- If the parent type has a known size, so does the formal, which makes
1667 -- legal representation clauses that involve the formal.
1669 Set_Size_Known_At_Compile_Time
1670 (T, Size_Known_At_Compile_Time (Entity (Subtype_Mark (Def))));
1671 end Analyze_Formal_Derived_Type;
1673 ----------------------------------
1674 -- Analyze_Formal_Discrete_Type --
1675 ----------------------------------
1677 -- The operations defined for a discrete types are those of an enumeration
1678 -- type. The size is set to an arbitrary value, for use in analyzing the
1681 procedure Analyze_Formal_Discrete_Type (T : Entity_Id; Def : Node_Id) is
1682 Loc : constant Source_Ptr := Sloc (Def);
1686 Base : constant Entity_Id :=
1688 (E_Floating_Point_Type, Current_Scope, Sloc (Def), 'G');
1691 Set_Ekind (T, E_Enumeration_Subtype);
1692 Set_Etype (T, Base);
1695 Set_Is_Generic_Type (T);
1696 Set_Is_Constrained (T);
1698 -- For semantic analysis, the bounds of the type must be set to some
1699 -- non-static value. The simplest is to create attribute nodes for those
1700 -- bounds, that refer to the type itself. These bounds are never
1701 -- analyzed but serve as place-holders.
1704 Make_Attribute_Reference (Loc,
1705 Attribute_Name => Name_First,
1706 Prefix => New_Reference_To (T, Loc));
1710 Make_Attribute_Reference (Loc,
1711 Attribute_Name => Name_Last,
1712 Prefix => New_Reference_To (T, Loc));
1715 Set_Scalar_Range (T,
1720 Set_Ekind (Base, E_Enumeration_Type);
1721 Set_Etype (Base, Base);
1722 Init_Size (Base, 8);
1723 Init_Alignment (Base);
1724 Set_Is_Generic_Type (Base);
1725 Set_Scalar_Range (Base, Scalar_Range (T));
1726 Set_Parent (Base, Parent (Def));
1727 end Analyze_Formal_Discrete_Type;
1729 ----------------------------------
1730 -- Analyze_Formal_Floating_Type --
1731 ---------------------------------
1733 procedure Analyze_Formal_Floating_Type (T : Entity_Id; Def : Node_Id) is
1734 Base : constant Entity_Id :=
1736 (E_Floating_Point_Type, Current_Scope, Sloc (Def), 'G');
1739 -- The various semantic attributes are taken from the predefined type
1740 -- Float, just so that all of them are initialized. Their values are
1741 -- never used because no constant folding or expansion takes place in
1742 -- the generic itself.
1745 Set_Ekind (T, E_Floating_Point_Subtype);
1746 Set_Etype (T, Base);
1747 Set_Size_Info (T, (Standard_Float));
1748 Set_RM_Size (T, RM_Size (Standard_Float));
1749 Set_Digits_Value (T, Digits_Value (Standard_Float));
1750 Set_Scalar_Range (T, Scalar_Range (Standard_Float));
1751 Set_Is_Constrained (T);
1753 Set_Is_Generic_Type (Base);
1754 Set_Etype (Base, Base);
1755 Set_Size_Info (Base, (Standard_Float));
1756 Set_RM_Size (Base, RM_Size (Standard_Float));
1757 Set_Digits_Value (Base, Digits_Value (Standard_Float));
1758 Set_Scalar_Range (Base, Scalar_Range (Standard_Float));
1759 Set_Parent (Base, Parent (Def));
1761 Check_Restriction (No_Floating_Point, Def);
1762 end Analyze_Formal_Floating_Type;
1764 -----------------------------------
1765 -- Analyze_Formal_Interface_Type;--
1766 -----------------------------------
1768 procedure Analyze_Formal_Interface_Type
1773 Loc : constant Source_Ptr := Sloc (N);
1778 Make_Full_Type_Declaration (Loc,
1779 Defining_Identifier => T,
1780 Type_Definition => Def);
1784 Set_Is_Generic_Type (T);
1785 end Analyze_Formal_Interface_Type;
1787 ---------------------------------
1788 -- Analyze_Formal_Modular_Type --
1789 ---------------------------------
1791 procedure Analyze_Formal_Modular_Type (T : Entity_Id; Def : Node_Id) is
1793 -- Apart from their entity kind, generic modular types are treated like
1794 -- signed integer types, and have the same attributes.
1796 Analyze_Formal_Signed_Integer_Type (T, Def);
1797 Set_Ekind (T, E_Modular_Integer_Subtype);
1798 Set_Ekind (Etype (T), E_Modular_Integer_Type);
1800 end Analyze_Formal_Modular_Type;
1802 ---------------------------------------
1803 -- Analyze_Formal_Object_Declaration --
1804 ---------------------------------------
1806 procedure Analyze_Formal_Object_Declaration (N : Node_Id) is
1807 E : constant Node_Id := Default_Expression (N);
1808 Id : constant Node_Id := Defining_Identifier (N);
1815 -- Determine the mode of the formal object
1817 if Out_Present (N) then
1818 K := E_Generic_In_Out_Parameter;
1820 if not In_Present (N) then
1821 Error_Msg_N ("formal generic objects cannot have mode OUT", N);
1825 K := E_Generic_In_Parameter;
1828 if Present (Subtype_Mark (N)) then
1829 Find_Type (Subtype_Mark (N));
1830 T := Entity (Subtype_Mark (N));
1832 -- Verify that there is no redundant null exclusion
1834 if Null_Exclusion_Present (N) then
1835 if not Is_Access_Type (T) then
1837 ("null exclusion can only apply to an access type", N);
1839 elsif Can_Never_Be_Null (T) then
1841 ("`NOT NULL` not allowed (& already excludes null)",
1846 -- Ada 2005 (AI-423): Formal object with an access definition
1849 Check_Access_Definition (N);
1850 T := Access_Definition
1852 N => Access_Definition (N));
1855 if Ekind (T) = E_Incomplete_Type then
1857 Error_Node : Node_Id;
1860 if Present (Subtype_Mark (N)) then
1861 Error_Node := Subtype_Mark (N);
1863 Check_Access_Definition (N);
1864 Error_Node := Access_Definition (N);
1867 Error_Msg_N ("premature usage of incomplete type", Error_Node);
1871 if K = E_Generic_In_Parameter then
1873 -- Ada 2005 (AI-287): Limited aggregates allowed in generic formals
1875 if Ada_Version < Ada_05 and then Is_Limited_Type (T) then
1877 ("generic formal of mode IN must not be of limited type", N);
1878 Explain_Limited_Type (T, N);
1881 if Is_Abstract_Type (T) then
1883 ("generic formal of mode IN must not be of abstract type", N);
1887 Preanalyze_Spec_Expression (E, T);
1889 if Is_Limited_Type (T) and then not OK_For_Limited_Init (E) then
1891 ("initialization not allowed for limited types", E);
1892 Explain_Limited_Type (T, E);
1899 -- Case of generic IN OUT parameter
1902 -- If the formal has an unconstrained type, construct its actual
1903 -- subtype, as is done for subprogram formals. In this fashion, all
1904 -- its uses can refer to specific bounds.
1909 if (Is_Array_Type (T)
1910 and then not Is_Constrained (T))
1912 (Ekind (T) = E_Record_Type
1913 and then Has_Discriminants (T))
1916 Non_Freezing_Ref : constant Node_Id :=
1917 New_Reference_To (Id, Sloc (Id));
1921 -- Make sure the actual subtype doesn't generate bogus freezing
1923 Set_Must_Not_Freeze (Non_Freezing_Ref);
1924 Decl := Build_Actual_Subtype (T, Non_Freezing_Ref);
1925 Insert_Before_And_Analyze (N, Decl);
1926 Set_Actual_Subtype (Id, Defining_Identifier (Decl));
1929 Set_Actual_Subtype (Id, T);
1934 ("initialization not allowed for `IN OUT` formals", N);
1938 end Analyze_Formal_Object_Declaration;
1940 ----------------------------------------------
1941 -- Analyze_Formal_Ordinary_Fixed_Point_Type --
1942 ----------------------------------------------
1944 procedure Analyze_Formal_Ordinary_Fixed_Point_Type
1948 Loc : constant Source_Ptr := Sloc (Def);
1949 Base : constant Entity_Id :=
1951 (E_Ordinary_Fixed_Point_Type, Current_Scope, Sloc (Def), 'G');
1953 -- The semantic attributes are set for completeness only, their values
1954 -- will never be used, since all properties of the type are non-static.
1957 Set_Ekind (T, E_Ordinary_Fixed_Point_Subtype);
1958 Set_Etype (T, Base);
1959 Set_Size_Info (T, Standard_Integer);
1960 Set_RM_Size (T, RM_Size (Standard_Integer));
1961 Set_Small_Value (T, Ureal_1);
1962 Set_Delta_Value (T, Ureal_1);
1963 Set_Scalar_Range (T,
1965 Low_Bound => Make_Real_Literal (Loc, Ureal_1),
1966 High_Bound => Make_Real_Literal (Loc, Ureal_1)));
1967 Set_Is_Constrained (T);
1969 Set_Is_Generic_Type (Base);
1970 Set_Etype (Base, Base);
1971 Set_Size_Info (Base, Standard_Integer);
1972 Set_RM_Size (Base, RM_Size (Standard_Integer));
1973 Set_Small_Value (Base, Ureal_1);
1974 Set_Delta_Value (Base, Ureal_1);
1975 Set_Scalar_Range (Base, Scalar_Range (T));
1976 Set_Parent (Base, Parent (Def));
1978 Check_Restriction (No_Fixed_Point, Def);
1979 end Analyze_Formal_Ordinary_Fixed_Point_Type;
1981 ----------------------------
1982 -- Analyze_Formal_Package --
1983 ----------------------------
1985 procedure Analyze_Formal_Package (N : Node_Id) is
1986 Loc : constant Source_Ptr := Sloc (N);
1987 Pack_Id : constant Entity_Id := Defining_Identifier (N);
1989 Gen_Id : constant Node_Id := Name (N);
1991 Gen_Unit : Entity_Id;
1993 Parent_Installed : Boolean := False;
1995 Parent_Instance : Entity_Id;
1996 Renaming_In_Par : Entity_Id;
1997 No_Associations : Boolean := False;
1999 function Build_Local_Package return Node_Id;
2000 -- The formal package is rewritten so that its parameters are replaced
2001 -- with corresponding declarations. For parameters with bona fide
2002 -- associations these declarations are created by Analyze_Associations
2003 -- as for a regular instantiation. For boxed parameters, we preserve
2004 -- the formal declarations and analyze them, in order to introduce
2005 -- entities of the right kind in the environment of the formal.
2007 -------------------------
2008 -- Build_Local_Package --
2009 -------------------------
2011 function Build_Local_Package return Node_Id is
2013 Pack_Decl : Node_Id;
2016 -- Within the formal, the name of the generic package is a renaming
2017 -- of the formal (as for a regular instantiation).
2020 Make_Package_Declaration (Loc,
2023 (Specification (Original_Node (Gen_Decl)),
2024 Empty, Instantiating => True));
2026 Renaming := Make_Package_Renaming_Declaration (Loc,
2027 Defining_Unit_Name =>
2028 Make_Defining_Identifier (Loc, Chars (Gen_Unit)),
2029 Name => New_Occurrence_Of (Formal, Loc));
2031 if Nkind (Gen_Id) = N_Identifier
2032 and then Chars (Gen_Id) = Chars (Pack_Id)
2035 ("& is hidden within declaration of instance", Gen_Id, Gen_Unit);
2038 -- If the formal is declared with a box, or with an others choice,
2039 -- create corresponding declarations for all entities in the formal
2040 -- part, so that names with the proper types are available in the
2041 -- specification of the formal package.
2042 -- On the other hand, if there are no associations, then all the
2043 -- formals must have defaults, and this will be checked by the
2044 -- call to Analyze_Associations.
2047 or else Nkind (First (Generic_Associations (N))) = N_Others_Choice
2050 Formal_Decl : Node_Id;
2053 -- TBA : for a formal package, need to recurse ???
2058 (Generic_Formal_Declarations (Original_Node (Gen_Decl)));
2059 while Present (Formal_Decl) loop
2061 (Decls, Copy_Generic_Node (Formal_Decl, Empty, True));
2066 -- If generic associations are present, use Analyze_Associations to
2067 -- create the proper renaming declarations.
2071 Act_Tree : constant Node_Id :=
2073 (Original_Node (Gen_Decl), Empty,
2074 Instantiating => True);
2077 Generic_Renamings.Set_Last (0);
2078 Generic_Renamings_HTable.Reset;
2079 Instantiation_Node := N;
2082 Analyze_Associations
2084 Generic_Formal_Declarations (Act_Tree),
2085 Generic_Formal_Declarations (Gen_Decl));
2089 Append (Renaming, To => Decls);
2091 -- Add generated declarations ahead of local declarations in
2094 if No (Visible_Declarations (Specification (Pack_Decl))) then
2095 Set_Visible_Declarations (Specification (Pack_Decl), Decls);
2098 (First (Visible_Declarations (Specification (Pack_Decl))),
2103 end Build_Local_Package;
2105 -- Start of processing for Analyze_Formal_Package
2108 Text_IO_Kludge (Gen_Id);
2111 Check_Generic_Child_Unit (Gen_Id, Parent_Installed);
2112 Gen_Unit := Entity (Gen_Id);
2114 -- Check for a formal package that is a package renaming
2116 if Present (Renamed_Object (Gen_Unit)) then
2117 Gen_Unit := Renamed_Object (Gen_Unit);
2120 if Ekind (Gen_Unit) /= E_Generic_Package then
2121 Error_Msg_N ("expect generic package name", Gen_Id);
2125 elsif Gen_Unit = Current_Scope then
2127 ("generic package cannot be used as a formal package of itself",
2132 elsif In_Open_Scopes (Gen_Unit) then
2133 if Is_Compilation_Unit (Gen_Unit)
2134 and then Is_Child_Unit (Current_Scope)
2136 -- Special-case the error when the formal is a parent, and
2137 -- continue analysis to minimize cascaded errors.
2140 ("generic parent cannot be used as formal package "
2141 & "of a child unit",
2146 ("generic package cannot be used as a formal package "
2155 or else No (Generic_Associations (N))
2156 or else Nkind (First (Generic_Associations (N))) = N_Others_Choice
2158 No_Associations := True;
2161 -- If there are no generic associations, the generic parameters appear
2162 -- as local entities and are instantiated like them. We copy the generic
2163 -- package declaration as if it were an instantiation, and analyze it
2164 -- like a regular package, except that we treat the formals as
2165 -- additional visible components.
2167 Gen_Decl := Unit_Declaration_Node (Gen_Unit);
2169 if In_Extended_Main_Source_Unit (N) then
2170 Set_Is_Instantiated (Gen_Unit);
2171 Generate_Reference (Gen_Unit, N);
2174 Formal := New_Copy (Pack_Id);
2175 Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment);
2178 -- Make local generic without formals. The formals will be replaced
2179 -- with internal declarations.
2181 New_N := Build_Local_Package;
2183 -- If there are errors in the parameter list, Analyze_Associations
2184 -- raises Instantiation_Error. Patch the declaration to prevent
2185 -- further exception propagation.
2188 when Instantiation_Error =>
2190 Enter_Name (Formal);
2191 Set_Ekind (Formal, E_Variable);
2192 Set_Etype (Formal, Any_Type);
2194 if Parent_Installed then
2202 Set_Defining_Unit_Name (Specification (New_N), Formal);
2203 Set_Generic_Parent (Specification (N), Gen_Unit);
2204 Set_Instance_Env (Gen_Unit, Formal);
2205 Set_Is_Generic_Instance (Formal);
2207 Enter_Name (Formal);
2208 Set_Ekind (Formal, E_Package);
2209 Set_Etype (Formal, Standard_Void_Type);
2210 Set_Inner_Instances (Formal, New_Elmt_List);
2211 Push_Scope (Formal);
2213 if Is_Child_Unit (Gen_Unit)
2214 and then Parent_Installed
2216 -- Similarly, we have to make the name of the formal visible in the
2217 -- parent instance, to resolve properly fully qualified names that
2218 -- may appear in the generic unit. The parent instance has been
2219 -- placed on the scope stack ahead of the current scope.
2221 Parent_Instance := Scope_Stack.Table (Scope_Stack.Last - 1).Entity;
2224 Make_Defining_Identifier (Loc, Chars (Gen_Unit));
2225 Set_Ekind (Renaming_In_Par, E_Package);
2226 Set_Etype (Renaming_In_Par, Standard_Void_Type);
2227 Set_Scope (Renaming_In_Par, Parent_Instance);
2228 Set_Parent (Renaming_In_Par, Parent (Formal));
2229 Set_Renamed_Object (Renaming_In_Par, Formal);
2230 Append_Entity (Renaming_In_Par, Parent_Instance);
2233 Analyze (Specification (N));
2235 -- The formals for which associations are provided are not visible
2236 -- outside of the formal package. The others are still declared by a
2237 -- formal parameter declaration.
2239 if not No_Associations then
2244 E := First_Entity (Formal);
2245 while Present (E) loop
2246 exit when Ekind (E) = E_Package
2247 and then Renamed_Entity (E) = Formal;
2249 if not Is_Generic_Formal (E) then
2258 End_Package_Scope (Formal);
2260 if Parent_Installed then
2266 -- Inside the generic unit, the formal package is a regular package, but
2267 -- no body is needed for it. Note that after instantiation, the defining
2268 -- unit name we need is in the new tree and not in the original (see
2269 -- Package_Instantiation). A generic formal package is an instance, and
2270 -- can be used as an actual for an inner instance.
2272 Set_Has_Completion (Formal, True);
2274 -- Add semantic information to the original defining identifier.
2277 Set_Ekind (Pack_Id, E_Package);
2278 Set_Etype (Pack_Id, Standard_Void_Type);
2279 Set_Scope (Pack_Id, Scope (Formal));
2280 Set_Has_Completion (Pack_Id, True);
2281 end Analyze_Formal_Package;
2283 ---------------------------------
2284 -- Analyze_Formal_Private_Type --
2285 ---------------------------------
2287 procedure Analyze_Formal_Private_Type
2293 New_Private_Type (N, T, Def);
2295 -- Set the size to an arbitrary but legal value
2297 Set_Size_Info (T, Standard_Integer);
2298 Set_RM_Size (T, RM_Size (Standard_Integer));
2299 end Analyze_Formal_Private_Type;
2301 ----------------------------------------
2302 -- Analyze_Formal_Signed_Integer_Type --
2303 ----------------------------------------
2305 procedure Analyze_Formal_Signed_Integer_Type
2309 Base : constant Entity_Id :=
2311 (E_Signed_Integer_Type, Current_Scope, Sloc (Def), 'G');
2316 Set_Ekind (T, E_Signed_Integer_Subtype);
2317 Set_Etype (T, Base);
2318 Set_Size_Info (T, Standard_Integer);
2319 Set_RM_Size (T, RM_Size (Standard_Integer));
2320 Set_Scalar_Range (T, Scalar_Range (Standard_Integer));
2321 Set_Is_Constrained (T);
2323 Set_Is_Generic_Type (Base);
2324 Set_Size_Info (Base, Standard_Integer);
2325 Set_RM_Size (Base, RM_Size (Standard_Integer));
2326 Set_Etype (Base, Base);
2327 Set_Scalar_Range (Base, Scalar_Range (Standard_Integer));
2328 Set_Parent (Base, Parent (Def));
2329 end Analyze_Formal_Signed_Integer_Type;
2331 -------------------------------
2332 -- Analyze_Formal_Subprogram --
2333 -------------------------------
2335 procedure Analyze_Formal_Subprogram (N : Node_Id) is
2336 Spec : constant Node_Id := Specification (N);
2337 Def : constant Node_Id := Default_Name (N);
2338 Nam : constant Entity_Id := Defining_Unit_Name (Spec);
2346 if Nkind (Nam) = N_Defining_Program_Unit_Name then
2347 Error_Msg_N ("name of formal subprogram must be a direct name", Nam);
2351 Analyze_Subprogram_Declaration (N);
2352 Set_Is_Formal_Subprogram (Nam);
2353 Set_Has_Completion (Nam);
2355 if Nkind (N) = N_Formal_Abstract_Subprogram_Declaration then
2356 Set_Is_Abstract_Subprogram (Nam);
2357 Set_Is_Dispatching_Operation (Nam);
2360 Ctrl_Type : constant Entity_Id := Find_Dispatching_Type (Nam);
2362 if No (Ctrl_Type) then
2364 ("abstract formal subprogram must have a controlling type",
2367 Check_Controlling_Formals (Ctrl_Type, Nam);
2372 -- Default name is resolved at the point of instantiation
2374 if Box_Present (N) then
2377 -- Else default is bound at the point of generic declaration
2379 elsif Present (Def) then
2380 if Nkind (Def) = N_Operator_Symbol then
2381 Find_Direct_Name (Def);
2383 elsif Nkind (Def) /= N_Attribute_Reference then
2387 -- For an attribute reference, analyze the prefix and verify
2388 -- that it has the proper profile for the subprogram.
2390 Analyze (Prefix (Def));
2391 Valid_Default_Attribute (Nam, Def);
2395 -- Default name may be overloaded, in which case the interpretation
2396 -- with the correct profile must be selected, as for a renaming.
2397 -- If the definition is an indexed component, it must denote a
2398 -- member of an entry family. If it is a selected component, it
2399 -- can be a protected operation.
2401 if Etype (Def) = Any_Type then
2404 elsif Nkind (Def) = N_Selected_Component then
2405 if not Is_Overloadable (Entity (Selector_Name (Def))) then
2406 Error_Msg_N ("expect valid subprogram name as default", Def);
2409 elsif Nkind (Def) = N_Indexed_Component then
2410 if Is_Entity_Name (Prefix (Def)) then
2411 if Ekind (Entity (Prefix (Def))) /= E_Entry_Family then
2412 Error_Msg_N ("expect valid subprogram name as default", Def);
2415 elsif Nkind (Prefix (Def)) = N_Selected_Component then
2416 if Ekind (Entity (Selector_Name (Prefix (Def))))
2419 Error_Msg_N ("expect valid subprogram name as default", Def);
2423 Error_Msg_N ("expect valid subprogram name as default", Def);
2427 elsif Nkind (Def) = N_Character_Literal then
2429 -- Needs some type checks: subprogram should be parameterless???
2431 Resolve (Def, (Etype (Nam)));
2433 elsif not Is_Entity_Name (Def)
2434 or else not Is_Overloadable (Entity (Def))
2436 Error_Msg_N ("expect valid subprogram name as default", Def);
2439 elsif not Is_Overloaded (Def) then
2440 Subp := Entity (Def);
2443 Error_Msg_N ("premature usage of formal subprogram", Def);
2445 elsif not Entity_Matches_Spec (Subp, Nam) then
2446 Error_Msg_N ("no visible entity matches specification", Def);
2449 -- More than one interpretation, so disambiguate as for a renaming
2454 I1 : Interp_Index := 0;
2460 Get_First_Interp (Def, I, It);
2461 while Present (It.Nam) loop
2462 if Entity_Matches_Spec (It.Nam, Nam) then
2463 if Subp /= Any_Id then
2464 It1 := Disambiguate (Def, I1, I, Etype (Subp));
2466 if It1 = No_Interp then
2467 Error_Msg_N ("ambiguous default subprogram", Def);
2480 Get_Next_Interp (I, It);
2484 if Subp /= Any_Id then
2485 Set_Entity (Def, Subp);
2488 Error_Msg_N ("premature usage of formal subprogram", Def);
2490 elsif Ekind (Subp) /= E_Operator then
2491 Check_Mode_Conformant (Subp, Nam);
2495 Error_Msg_N ("no visible subprogram matches specification", N);
2499 end Analyze_Formal_Subprogram;
2501 -------------------------------------
2502 -- Analyze_Formal_Type_Declaration --
2503 -------------------------------------
2505 procedure Analyze_Formal_Type_Declaration (N : Node_Id) is
2506 Def : constant Node_Id := Formal_Type_Definition (N);
2510 T := Defining_Identifier (N);
2512 if Present (Discriminant_Specifications (N))
2513 and then Nkind (Def) /= N_Formal_Private_Type_Definition
2516 ("discriminants not allowed for this formal type", T);
2519 -- Enter the new name, and branch to specific routine
2522 when N_Formal_Private_Type_Definition =>
2523 Analyze_Formal_Private_Type (N, T, Def);
2525 when N_Formal_Derived_Type_Definition =>
2526 Analyze_Formal_Derived_Type (N, T, Def);
2528 when N_Formal_Discrete_Type_Definition =>
2529 Analyze_Formal_Discrete_Type (T, Def);
2531 when N_Formal_Signed_Integer_Type_Definition =>
2532 Analyze_Formal_Signed_Integer_Type (T, Def);
2534 when N_Formal_Modular_Type_Definition =>
2535 Analyze_Formal_Modular_Type (T, Def);
2537 when N_Formal_Floating_Point_Definition =>
2538 Analyze_Formal_Floating_Type (T, Def);
2540 when N_Formal_Ordinary_Fixed_Point_Definition =>
2541 Analyze_Formal_Ordinary_Fixed_Point_Type (T, Def);
2543 when N_Formal_Decimal_Fixed_Point_Definition =>
2544 Analyze_Formal_Decimal_Fixed_Point_Type (T, Def);
2546 when N_Array_Type_Definition =>
2547 Analyze_Formal_Array_Type (T, Def);
2549 when N_Access_To_Object_Definition |
2550 N_Access_Function_Definition |
2551 N_Access_Procedure_Definition =>
2552 Analyze_Generic_Access_Type (T, Def);
2554 -- Ada 2005: a interface declaration is encoded as an abstract
2555 -- record declaration or a abstract type derivation.
2557 when N_Record_Definition =>
2558 Analyze_Formal_Interface_Type (N, T, Def);
2560 when N_Derived_Type_Definition =>
2561 Analyze_Formal_Derived_Interface_Type (N, T, Def);
2567 raise Program_Error;
2571 Set_Is_Generic_Type (T);
2572 end Analyze_Formal_Type_Declaration;
2574 ------------------------------------
2575 -- Analyze_Function_Instantiation --
2576 ------------------------------------
2578 procedure Analyze_Function_Instantiation (N : Node_Id) is
2580 Analyze_Subprogram_Instantiation (N, E_Function);
2581 end Analyze_Function_Instantiation;
2583 ---------------------------------
2584 -- Analyze_Generic_Access_Type --
2585 ---------------------------------
2587 procedure Analyze_Generic_Access_Type (T : Entity_Id; Def : Node_Id) is
2591 if Nkind (Def) = N_Access_To_Object_Definition then
2592 Access_Type_Declaration (T, Def);
2594 if Is_Incomplete_Or_Private_Type (Designated_Type (T))
2595 and then No (Full_View (Designated_Type (T)))
2596 and then not Is_Generic_Type (Designated_Type (T))
2598 Error_Msg_N ("premature usage of incomplete type", Def);
2600 elsif Is_Internal (Designated_Type (T)) then
2602 ("only a subtype mark is allowed in a formal", Def);
2606 Access_Subprogram_Declaration (T, Def);
2608 end Analyze_Generic_Access_Type;
2610 ---------------------------------
2611 -- Analyze_Generic_Formal_Part --
2612 ---------------------------------
2614 procedure Analyze_Generic_Formal_Part (N : Node_Id) is
2615 Gen_Parm_Decl : Node_Id;
2618 -- The generic formals are processed in the scope of the generic unit,
2619 -- where they are immediately visible. The scope is installed by the
2622 Gen_Parm_Decl := First (Generic_Formal_Declarations (N));
2624 while Present (Gen_Parm_Decl) loop
2625 Analyze (Gen_Parm_Decl);
2626 Next (Gen_Parm_Decl);
2629 Generate_Reference_To_Generic_Formals (Current_Scope);
2630 end Analyze_Generic_Formal_Part;
2632 ------------------------------------------
2633 -- Analyze_Generic_Package_Declaration --
2634 ------------------------------------------
2636 procedure Analyze_Generic_Package_Declaration (N : Node_Id) is
2637 Loc : constant Source_Ptr := Sloc (N);
2640 Save_Parent : Node_Id;
2642 Decls : constant List_Id :=
2643 Visible_Declarations (Specification (N));
2647 -- We introduce a renaming of the enclosing package, to have a usable
2648 -- entity as the prefix of an expanded name for a local entity of the
2649 -- form Par.P.Q, where P is the generic package. This is because a local
2650 -- entity named P may hide it, so that the usual visibility rules in
2651 -- the instance will not resolve properly.
2654 Make_Package_Renaming_Declaration (Loc,
2655 Defining_Unit_Name =>
2656 Make_Defining_Identifier (Loc,
2657 Chars => New_External_Name (Chars (Defining_Entity (N)), "GH")),
2658 Name => Make_Identifier (Loc, Chars (Defining_Entity (N))));
2660 if Present (Decls) then
2661 Decl := First (Decls);
2662 while Present (Decl)
2663 and then Nkind (Decl) = N_Pragma
2668 if Present (Decl) then
2669 Insert_Before (Decl, Renaming);
2671 Append (Renaming, Visible_Declarations (Specification (N)));
2675 Set_Visible_Declarations (Specification (N), New_List (Renaming));
2678 -- Create copy of generic unit, and save for instantiation. If the unit
2679 -- is a child unit, do not copy the specifications for the parent, which
2680 -- are not part of the generic tree.
2682 Save_Parent := Parent_Spec (N);
2683 Set_Parent_Spec (N, Empty);
2685 New_N := Copy_Generic_Node (N, Empty, Instantiating => False);
2686 Set_Parent_Spec (New_N, Save_Parent);
2688 Id := Defining_Entity (N);
2689 Generate_Definition (Id);
2691 -- Expansion is not applied to generic units
2696 Set_Ekind (Id, E_Generic_Package);
2697 Set_Etype (Id, Standard_Void_Type);
2699 Enter_Generic_Scope (Id);
2700 Set_Inner_Instances (Id, New_Elmt_List);
2702 Set_Categorization_From_Pragmas (N);
2703 Set_Is_Pure (Id, Is_Pure (Current_Scope));
2705 -- Link the declaration of the generic homonym in the generic copy to
2706 -- the package it renames, so that it is always resolved properly.
2708 Set_Generic_Homonym (Id, Defining_Unit_Name (Renaming));
2709 Set_Entity (Associated_Node (Name (Renaming)), Id);
2711 -- For a library unit, we have reconstructed the entity for the unit,
2712 -- and must reset it in the library tables.
2714 if Nkind (Parent (N)) = N_Compilation_Unit then
2715 Set_Cunit_Entity (Current_Sem_Unit, Id);
2718 Analyze_Generic_Formal_Part (N);
2720 -- After processing the generic formals, analysis proceeds as for a
2721 -- non-generic package.
2723 Analyze (Specification (N));
2725 Validate_Categorization_Dependency (N, Id);
2729 End_Package_Scope (Id);
2730 Exit_Generic_Scope (Id);
2732 if Nkind (Parent (N)) /= N_Compilation_Unit then
2733 Move_Freeze_Nodes (Id, N, Visible_Declarations (Specification (N)));
2734 Move_Freeze_Nodes (Id, N, Private_Declarations (Specification (N)));
2735 Move_Freeze_Nodes (Id, N, Generic_Formal_Declarations (N));
2738 Set_Body_Required (Parent (N), Unit_Requires_Body (Id));
2739 Validate_RT_RAT_Component (N);
2741 -- If this is a spec without a body, check that generic parameters
2744 if not Body_Required (Parent (N)) then
2745 Check_References (Id);
2748 end Analyze_Generic_Package_Declaration;
2750 --------------------------------------------
2751 -- Analyze_Generic_Subprogram_Declaration --
2752 --------------------------------------------
2754 procedure Analyze_Generic_Subprogram_Declaration (N : Node_Id) is
2759 Result_Type : Entity_Id;
2760 Save_Parent : Node_Id;
2764 -- Create copy of generic unit, and save for instantiation. If the unit
2765 -- is a child unit, do not copy the specifications for the parent, which
2766 -- are not part of the generic tree.
2768 Save_Parent := Parent_Spec (N);
2769 Set_Parent_Spec (N, Empty);
2771 New_N := Copy_Generic_Node (N, Empty, Instantiating => False);
2772 Set_Parent_Spec (New_N, Save_Parent);
2775 Spec := Specification (N);
2776 Id := Defining_Entity (Spec);
2777 Generate_Definition (Id);
2779 if Nkind (Id) = N_Defining_Operator_Symbol then
2781 ("operator symbol not allowed for generic subprogram", Id);
2788 Set_Scope_Depth_Value (Id, Scope_Depth (Current_Scope) + 1);
2790 Enter_Generic_Scope (Id);
2791 Set_Inner_Instances (Id, New_Elmt_List);
2792 Set_Is_Pure (Id, Is_Pure (Current_Scope));
2794 Analyze_Generic_Formal_Part (N);
2796 Formals := Parameter_Specifications (Spec);
2798 if Present (Formals) then
2799 Process_Formals (Formals, Spec);
2802 if Nkind (Spec) = N_Function_Specification then
2803 Set_Ekind (Id, E_Generic_Function);
2805 if Nkind (Result_Definition (Spec)) = N_Access_Definition then
2806 Result_Type := Access_Definition (Spec, Result_Definition (Spec));
2807 Set_Etype (Id, Result_Type);
2809 Find_Type (Result_Definition (Spec));
2810 Typ := Entity (Result_Definition (Spec));
2812 -- If a null exclusion is imposed on the result type, then create
2813 -- a null-excluding itype (an access subtype) and use it as the
2814 -- function's Etype.
2816 if Is_Access_Type (Typ)
2817 and then Null_Exclusion_Present (Spec)
2820 Create_Null_Excluding_Itype
2822 Related_Nod => Spec,
2823 Scope_Id => Defining_Unit_Name (Spec)));
2825 Set_Etype (Id, Typ);
2830 Set_Ekind (Id, E_Generic_Procedure);
2831 Set_Etype (Id, Standard_Void_Type);
2834 -- For a library unit, we have reconstructed the entity for the unit,
2835 -- and must reset it in the library tables. We also make sure that
2836 -- Body_Required is set properly in the original compilation unit node.
2838 if Nkind (Parent (N)) = N_Compilation_Unit then
2839 Set_Cunit_Entity (Current_Sem_Unit, Id);
2840 Set_Body_Required (Parent (N), Unit_Requires_Body (Id));
2843 Set_Categorization_From_Pragmas (N);
2844 Validate_Categorization_Dependency (N, Id);
2846 Save_Global_References (Original_Node (N));
2850 Exit_Generic_Scope (Id);
2851 Generate_Reference_To_Formals (Id);
2852 end Analyze_Generic_Subprogram_Declaration;
2854 -----------------------------------
2855 -- Analyze_Package_Instantiation --
2856 -----------------------------------
2858 procedure Analyze_Package_Instantiation (N : Node_Id) is
2859 Loc : constant Source_Ptr := Sloc (N);
2860 Gen_Id : constant Node_Id := Name (N);
2863 Act_Decl_Name : Node_Id;
2864 Act_Decl_Id : Entity_Id;
2869 Gen_Unit : Entity_Id;
2871 Is_Actual_Pack : constant Boolean :=
2872 Is_Internal (Defining_Entity (N));
2874 Env_Installed : Boolean := False;
2875 Parent_Installed : Boolean := False;
2876 Renaming_List : List_Id;
2877 Unit_Renaming : Node_Id;
2878 Needs_Body : Boolean;
2879 Inline_Now : Boolean := False;
2881 procedure Delay_Descriptors (E : Entity_Id);
2882 -- Delay generation of subprogram descriptors for given entity
2884 function Might_Inline_Subp return Boolean;
2885 -- If inlining is active and the generic contains inlined subprograms,
2886 -- we instantiate the body. This may cause superfluous instantiations,
2887 -- but it is simpler than detecting the need for the body at the point
2888 -- of inlining, when the context of the instance is not available.
2890 -----------------------
2891 -- Delay_Descriptors --
2892 -----------------------
2894 procedure Delay_Descriptors (E : Entity_Id) is
2896 if not Delay_Subprogram_Descriptors (E) then
2897 Set_Delay_Subprogram_Descriptors (E);
2898 Pending_Descriptor.Append (E);
2900 end Delay_Descriptors;
2902 -----------------------
2903 -- Might_Inline_Subp --
2904 -----------------------
2906 function Might_Inline_Subp return Boolean is
2910 if not Inline_Processing_Required then
2914 E := First_Entity (Gen_Unit);
2915 while Present (E) loop
2916 if Is_Subprogram (E)
2917 and then Is_Inlined (E)
2927 end Might_Inline_Subp;
2929 -- Start of processing for Analyze_Package_Instantiation
2932 -- Very first thing: apply the special kludge for Text_IO processing
2933 -- in case we are instantiating one of the children of [Wide_]Text_IO.
2935 Text_IO_Kludge (Name (N));
2937 -- Make node global for error reporting
2939 Instantiation_Node := N;
2941 -- Case of instantiation of a generic package
2943 if Nkind (N) = N_Package_Instantiation then
2944 Act_Decl_Id := New_Copy (Defining_Entity (N));
2945 Set_Comes_From_Source (Act_Decl_Id, True);
2947 if Nkind (Defining_Unit_Name (N)) = N_Defining_Program_Unit_Name then
2949 Make_Defining_Program_Unit_Name (Loc,
2950 Name => New_Copy_Tree (Name (Defining_Unit_Name (N))),
2951 Defining_Identifier => Act_Decl_Id);
2953 Act_Decl_Name := Act_Decl_Id;
2956 -- Case of instantiation of a formal package
2959 Act_Decl_Id := Defining_Identifier (N);
2960 Act_Decl_Name := Act_Decl_Id;
2963 Generate_Definition (Act_Decl_Id);
2964 Preanalyze_Actuals (N);
2967 Env_Installed := True;
2969 -- Reset renaming map for formal types. The mapping is established
2970 -- when analyzing the generic associations, but some mappings are
2971 -- inherited from formal packages of parent units, and these are
2972 -- constructed when the parents are installed.
2974 Generic_Renamings.Set_Last (0);
2975 Generic_Renamings_HTable.Reset;
2977 Check_Generic_Child_Unit (Gen_Id, Parent_Installed);
2978 Gen_Unit := Entity (Gen_Id);
2980 -- Verify that it is the name of a generic package
2982 -- A visibility glitch: if the instance is a child unit and the generic
2983 -- is the generic unit of a parent instance (i.e. both the parent and
2984 -- the child units are instances of the same package) the name now
2985 -- denotes the renaming within the parent, not the intended generic
2986 -- unit. See if there is a homonym that is the desired generic. The
2987 -- renaming declaration must be visible inside the instance of the
2988 -- child, but not when analyzing the name in the instantiation itself.
2990 if Ekind (Gen_Unit) = E_Package
2991 and then Present (Renamed_Entity (Gen_Unit))
2992 and then In_Open_Scopes (Renamed_Entity (Gen_Unit))
2993 and then Is_Generic_Instance (Renamed_Entity (Gen_Unit))
2994 and then Present (Homonym (Gen_Unit))
2996 Gen_Unit := Homonym (Gen_Unit);
2999 if Etype (Gen_Unit) = Any_Type then
3003 elsif Ekind (Gen_Unit) /= E_Generic_Package then
3005 -- Ada 2005 (AI-50217): Cannot use instance in limited with_clause
3007 if From_With_Type (Gen_Unit) then
3009 ("cannot instantiate a limited withed package", Gen_Id);
3012 ("expect name of generic package in instantiation", Gen_Id);
3019 if In_Extended_Main_Source_Unit (N) then
3020 Set_Is_Instantiated (Gen_Unit);
3021 Generate_Reference (Gen_Unit, N);
3023 if Present (Renamed_Object (Gen_Unit)) then
3024 Set_Is_Instantiated (Renamed_Object (Gen_Unit));
3025 Generate_Reference (Renamed_Object (Gen_Unit), N);
3029 if Nkind (Gen_Id) = N_Identifier
3030 and then Chars (Gen_Unit) = Chars (Defining_Entity (N))
3033 ("& is hidden within declaration of instance", Gen_Id, Gen_Unit);
3035 elsif Nkind (Gen_Id) = N_Expanded_Name
3036 and then Is_Child_Unit (Gen_Unit)
3037 and then Nkind (Prefix (Gen_Id)) = N_Identifier
3038 and then Chars (Act_Decl_Id) = Chars (Prefix (Gen_Id))
3041 ("& is hidden within declaration of instance ", Prefix (Gen_Id));
3044 Set_Entity (Gen_Id, Gen_Unit);
3046 -- If generic is a renaming, get original generic unit
3048 if Present (Renamed_Object (Gen_Unit))
3049 and then Ekind (Renamed_Object (Gen_Unit)) = E_Generic_Package
3051 Gen_Unit := Renamed_Object (Gen_Unit);
3054 -- Verify that there are no circular instantiations
3056 if In_Open_Scopes (Gen_Unit) then
3057 Error_Msg_NE ("instantiation of & within itself", N, Gen_Unit);
3061 elsif Contains_Instance_Of (Gen_Unit, Current_Scope, Gen_Id) then
3062 Error_Msg_Node_2 := Current_Scope;
3064 ("circular Instantiation: & instantiated in &!", N, Gen_Unit);
3065 Circularity_Detected := True;
3070 Gen_Decl := Unit_Declaration_Node (Gen_Unit);
3072 -- Initialize renamings map, for error checking, and the list that
3073 -- holds private entities whose views have changed between generic
3074 -- definition and instantiation. If this is the instance created to
3075 -- validate an actual package, the instantiation environment is that
3076 -- of the enclosing instance.
3078 Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment);
3080 -- Copy original generic tree, to produce text for instantiation
3084 (Original_Node (Gen_Decl), Empty, Instantiating => True);
3086 Act_Spec := Specification (Act_Tree);
3088 -- If this is the instance created to validate an actual package,
3089 -- only the formals matter, do not examine the package spec itself.
3091 if Is_Actual_Pack then
3092 Set_Visible_Declarations (Act_Spec, New_List);
3093 Set_Private_Declarations (Act_Spec, New_List);
3097 Analyze_Associations
3099 Generic_Formal_Declarations (Act_Tree),
3100 Generic_Formal_Declarations (Gen_Decl));
3102 Set_Instance_Env (Gen_Unit, Act_Decl_Id);
3103 Set_Defining_Unit_Name (Act_Spec, Act_Decl_Name);
3104 Set_Is_Generic_Instance (Act_Decl_Id);
3106 Set_Generic_Parent (Act_Spec, Gen_Unit);
3108 -- References to the generic in its own declaration or its body are
3109 -- references to the instance. Add a renaming declaration for the
3110 -- generic unit itself. This declaration, as well as the renaming
3111 -- declarations for the generic formals, must remain private to the
3112 -- unit: the formals, because this is the language semantics, and
3113 -- the unit because its use is an artifact of the implementation.
3116 Make_Package_Renaming_Declaration (Loc,
3117 Defining_Unit_Name =>
3118 Make_Defining_Identifier (Loc, Chars (Gen_Unit)),
3119 Name => New_Reference_To (Act_Decl_Id, Loc));
3121 Append (Unit_Renaming, Renaming_List);
3123 -- The renaming declarations are the first local declarations of
3126 if Is_Non_Empty_List (Visible_Declarations (Act_Spec)) then
3128 (First (Visible_Declarations (Act_Spec)), Renaming_List);
3130 Set_Visible_Declarations (Act_Spec, Renaming_List);
3134 Make_Package_Declaration (Loc,
3135 Specification => Act_Spec);
3137 -- Save the instantiation node, for subsequent instantiation of the
3138 -- body, if there is one and we are generating code for the current
3139 -- unit. Mark the unit as having a body, to avoid a premature error
3142 -- We instantiate the body if we are generating code, if we are
3143 -- generating cross-reference information, or if we are building
3144 -- trees for ASIS use.
3147 Enclosing_Body_Present : Boolean := False;
3148 -- If the generic unit is not a compilation unit, then a body may
3149 -- be present in its parent even if none is required. We create a
3150 -- tentative pending instantiation for the body, which will be
3151 -- discarded if none is actually present.
3156 if Scope (Gen_Unit) /= Standard_Standard
3157 and then not Is_Child_Unit (Gen_Unit)
3159 Scop := Scope (Gen_Unit);
3161 while Present (Scop)
3162 and then Scop /= Standard_Standard
3164 if Unit_Requires_Body (Scop) then
3165 Enclosing_Body_Present := True;
3168 elsif In_Open_Scopes (Scop)
3169 and then In_Package_Body (Scop)
3171 Enclosing_Body_Present := True;
3175 exit when Is_Compilation_Unit (Scop);
3176 Scop := Scope (Scop);
3180 -- If front-end inlining is enabled, and this is a unit for which
3181 -- code will be generated, we instantiate the body at once.
3183 -- This is done if the instance is not the main unit, and if the
3184 -- generic is not a child unit of another generic, to avoid scope
3185 -- problems and the reinstallation of parent instances.
3188 and then (not Is_Child_Unit (Gen_Unit)
3189 or else not Is_Generic_Unit (Scope (Gen_Unit)))
3190 and then Might_Inline_Subp
3191 and then not Is_Actual_Pack
3193 if Front_End_Inlining
3194 and then (Is_In_Main_Unit (N)
3195 or else In_Main_Context (Current_Scope))
3196 and then Nkind (Parent (N)) /= N_Compilation_Unit
3200 -- In configurable_run_time mode we force the inlining of
3201 -- predefined subprograms marked Inline_Always, to minimize
3202 -- the use of the run-time library.
3204 elsif Is_Predefined_File_Name
3205 (Unit_File_Name (Get_Source_Unit (Gen_Decl)))
3206 and then Configurable_Run_Time_Mode
3207 and then Nkind (Parent (N)) /= N_Compilation_Unit
3212 -- If the current scope is itself an instance within a child
3213 -- unit, there will be duplications in the scope stack, and the
3214 -- unstacking mechanism in Inline_Instance_Body will fail.
3215 -- This loses some rare cases of optimization, and might be
3216 -- improved some day, if we can find a proper abstraction for
3217 -- "the complete compilation context" that can be saved and
3220 if Is_Generic_Instance (Current_Scope) then
3222 Curr_Unit : constant Entity_Id :=
3223 Cunit_Entity (Current_Sem_Unit);
3225 if Curr_Unit /= Current_Scope
3226 and then Is_Child_Unit (Curr_Unit)
3228 Inline_Now := False;
3235 (Unit_Requires_Body (Gen_Unit)
3236 or else Enclosing_Body_Present
3237 or else Present (Corresponding_Body (Gen_Decl)))
3238 and then (Is_In_Main_Unit (N)
3239 or else Might_Inline_Subp)
3240 and then not Is_Actual_Pack
3241 and then not Inline_Now
3242 and then (Operating_Mode = Generate_Code
3243 or else (Operating_Mode = Check_Semantics
3244 and then ASIS_Mode));
3246 -- If front_end_inlining is enabled, do not instantiate body if
3247 -- within a generic context.
3249 if (Front_End_Inlining
3250 and then not Expander_Active)
3251 or else Is_Generic_Unit (Cunit_Entity (Main_Unit))
3253 Needs_Body := False;
3256 -- If the current context is generic, and the package being
3257 -- instantiated is declared within a formal package, there is no
3258 -- body to instantiate until the enclosing generic is instantiated
3259 -- and there is an actual for the formal package. If the formal
3260 -- package has parameters, we build a regular package instance for
3261 -- it, that precedes the original formal package declaration.
3263 if In_Open_Scopes (Scope (Scope (Gen_Unit))) then
3265 Decl : constant Node_Id :=
3267 (Unit_Declaration_Node (Scope (Gen_Unit)));
3269 if Nkind (Decl) = N_Formal_Package_Declaration
3270 or else (Nkind (Decl) = N_Package_Declaration
3271 and then Is_List_Member (Decl)
3272 and then Present (Next (Decl))
3274 Nkind (Next (Decl)) =
3275 N_Formal_Package_Declaration)
3277 Needs_Body := False;
3283 -- If we are generating the calling stubs from the instantiation of
3284 -- a generic RCI package, we will not use the body of the generic
3287 if Distribution_Stub_Mode = Generate_Caller_Stub_Body
3288 and then Is_Compilation_Unit (Defining_Entity (N))
3290 Needs_Body := False;
3295 -- Here is a defence against a ludicrous number of instantiations
3296 -- caused by a circular set of instantiation attempts.
3298 if Pending_Instantiations.Last >
3299 Hostparm.Max_Instantiations
3301 Error_Msg_N ("too many instantiations", N);
3302 raise Unrecoverable_Error;
3305 -- Indicate that the enclosing scopes contain an instantiation,
3306 -- and that cleanup actions should be delayed until after the
3307 -- instance body is expanded.
3309 Check_Forward_Instantiation (Gen_Decl);
3310 if Nkind (N) = N_Package_Instantiation then
3312 Enclosing_Master : Entity_Id;
3315 -- Loop to search enclosing masters
3317 Enclosing_Master := Current_Scope;
3318 Scope_Loop : while Enclosing_Master /= Standard_Standard loop
3319 if Ekind (Enclosing_Master) = E_Package then
3320 if Is_Compilation_Unit (Enclosing_Master) then
3321 if In_Package_Body (Enclosing_Master) then
3323 (Body_Entity (Enclosing_Master));
3332 Enclosing_Master := Scope (Enclosing_Master);
3335 elsif Ekind (Enclosing_Master) = E_Generic_Package then
3336 Enclosing_Master := Scope (Enclosing_Master);
3338 elsif Is_Generic_Subprogram (Enclosing_Master)
3339 or else Ekind (Enclosing_Master) = E_Void
3341 -- Cleanup actions will eventually be performed on the
3342 -- enclosing instance, if any. Enclosing scope is void
3343 -- in the formal part of a generic subprogram.
3348 if Ekind (Enclosing_Master) = E_Entry
3350 Ekind (Scope (Enclosing_Master)) = E_Protected_Type
3352 if not Expander_Active then
3356 Protected_Body_Subprogram (Enclosing_Master);
3360 Set_Delay_Cleanups (Enclosing_Master);
3362 while Ekind (Enclosing_Master) = E_Block loop
3363 Enclosing_Master := Scope (Enclosing_Master);
3366 if Is_Subprogram (Enclosing_Master) then
3367 Delay_Descriptors (Enclosing_Master);
3369 elsif Is_Task_Type (Enclosing_Master) then
3371 TBP : constant Node_Id :=
3372 Get_Task_Body_Procedure
3375 if Present (TBP) then
3376 Delay_Descriptors (TBP);
3377 Set_Delay_Cleanups (TBP);
3384 end loop Scope_Loop;
3387 -- Make entry in table
3389 Pending_Instantiations.Append
3391 Act_Decl => Act_Decl,
3392 Expander_Status => Expander_Active,
3393 Current_Sem_Unit => Current_Sem_Unit,
3394 Scope_Suppress => Scope_Suppress,
3395 Local_Suppress_Stack_Top => Local_Suppress_Stack_Top));
3399 Set_Categorization_From_Pragmas (Act_Decl);
3401 if Parent_Installed then
3405 Set_Instance_Spec (N, Act_Decl);
3407 -- If not a compilation unit, insert the package declaration before
3408 -- the original instantiation node.
3410 if Nkind (Parent (N)) /= N_Compilation_Unit then
3411 Mark_Rewrite_Insertion (Act_Decl);
3412 Insert_Before (N, Act_Decl);
3415 -- For an instantiation that is a compilation unit, place declaration
3416 -- on current node so context is complete for analysis (including
3417 -- nested instantiations). If this is the main unit, the declaration
3418 -- eventually replaces the instantiation node. If the instance body
3419 -- is created later, it replaces the instance node, and the
3420 -- declaration is attached to it (see
3421 -- Build_Instance_Compilation_Unit_Nodes).
3424 if Cunit_Entity (Current_Sem_Unit) = Defining_Entity (N) then
3426 -- The entity for the current unit is the newly created one,
3427 -- and all semantic information is attached to it.
3429 Set_Cunit_Entity (Current_Sem_Unit, Act_Decl_Id);
3431 -- If this is the main unit, replace the main entity as well
3433 if Current_Sem_Unit = Main_Unit then
3434 Main_Unit_Entity := Act_Decl_Id;
3438 Set_Unit (Parent (N), Act_Decl);
3439 Set_Parent_Spec (Act_Decl, Parent_Spec (N));
3440 Set_Package_Instantiation (Act_Decl_Id, N);
3442 Set_Unit (Parent (N), N);
3443 Set_Body_Required (Parent (N), False);
3445 -- We never need elaboration checks on instantiations, since by
3446 -- definition, the body instantiation is elaborated at the same
3447 -- time as the spec instantiation.
3449 Set_Suppress_Elaboration_Warnings (Act_Decl_Id);
3450 Set_Kill_Elaboration_Checks (Act_Decl_Id);
3453 Check_Elab_Instantiation (N);
3455 if ABE_Is_Certain (N) and then Needs_Body then
3456 Pending_Instantiations.Decrement_Last;
3459 Check_Hidden_Child_Unit (N, Gen_Unit, Act_Decl_Id);
3461 Set_First_Private_Entity (Defining_Unit_Name (Unit_Renaming),
3462 First_Private_Entity (Act_Decl_Id));
3464 -- If the instantiation will receive a body, the unit will be
3465 -- transformed into a package body, and receive its own elaboration
3466 -- entity. Otherwise, the nature of the unit is now a package
3469 if Nkind (Parent (N)) = N_Compilation_Unit
3470 and then not Needs_Body
3472 Rewrite (N, Act_Decl);
3475 if Present (Corresponding_Body (Gen_Decl))
3476 or else Unit_Requires_Body (Gen_Unit)
3478 Set_Has_Completion (Act_Decl_Id);
3481 Check_Formal_Packages (Act_Decl_Id);
3483 Restore_Private_Views (Act_Decl_Id);
3485 Inherit_Context (Gen_Decl, N);
3487 if Parent_Installed then
3492 Env_Installed := False;
3495 Validate_Categorization_Dependency (N, Act_Decl_Id);
3497 -- There used to be a check here to prevent instantiations in local
3498 -- contexts if the No_Local_Allocators restriction was active. This
3499 -- check was removed by a binding interpretation in AI-95-00130/07,
3500 -- but we retain the code for documentation purposes.
3502 -- if Ekind (Act_Decl_Id) /= E_Void
3503 -- and then not Is_Library_Level_Entity (Act_Decl_Id)
3505 -- Check_Restriction (No_Local_Allocators, N);
3509 Inline_Instance_Body (N, Gen_Unit, Act_Decl);
3512 -- The following is a tree patch for ASIS: ASIS needs separate nodes to
3513 -- be used as defining identifiers for a formal package and for the
3514 -- corresponding expanded package.
3516 if Nkind (N) = N_Formal_Package_Declaration then
3517 Act_Decl_Id := New_Copy (Defining_Entity (N));
3518 Set_Comes_From_Source (Act_Decl_Id, True);
3519 Set_Is_Generic_Instance (Act_Decl_Id, False);
3520 Set_Defining_Identifier (N, Act_Decl_Id);
3524 when Instantiation_Error =>
3525 if Parent_Installed then
3529 if Env_Installed then
3532 end Analyze_Package_Instantiation;
3534 --------------------------
3535 -- Inline_Instance_Body --
3536 --------------------------
3538 procedure Inline_Instance_Body
3540 Gen_Unit : Entity_Id;
3544 Gen_Comp : constant Entity_Id :=
3545 Cunit_Entity (Get_Source_Unit (Gen_Unit));
3546 Curr_Comp : constant Node_Id := Cunit (Current_Sem_Unit);
3547 Curr_Scope : Entity_Id := Empty;
3548 Curr_Unit : constant Entity_Id :=
3549 Cunit_Entity (Current_Sem_Unit);
3550 Removed : Boolean := False;
3551 Num_Scopes : Int := 0;
3553 Scope_Stack_Depth : constant Int :=
3554 Scope_Stack.Last - Scope_Stack.First + 1;
3556 Use_Clauses : array (1 .. Scope_Stack_Depth) of Node_Id;
3557 Instances : array (1 .. Scope_Stack_Depth) of Entity_Id;
3558 Inner_Scopes : array (1 .. Scope_Stack_Depth) of Entity_Id;
3559 Num_Inner : Int := 0;
3560 N_Instances : Int := 0;
3564 -- Case of generic unit defined in another unit. We must remove the
3565 -- complete context of the current unit to install that of the generic.
3567 if Gen_Comp /= Cunit_Entity (Current_Sem_Unit) then
3569 -- Add some comments for the following two loops ???
3572 while Present (S) and then S /= Standard_Standard loop
3574 Num_Scopes := Num_Scopes + 1;
3576 Use_Clauses (Num_Scopes) :=
3578 (Scope_Stack.Last - Num_Scopes + 1).
3580 End_Use_Clauses (Use_Clauses (Num_Scopes));
3582 exit when Scope_Stack.Last - Num_Scopes + 1 = Scope_Stack.First
3583 or else Scope_Stack.Table
3584 (Scope_Stack.Last - Num_Scopes).Entity
3588 exit when Is_Generic_Instance (S)
3589 and then (In_Package_Body (S)
3590 or else Ekind (S) = E_Procedure
3591 or else Ekind (S) = E_Function);
3595 Vis := Is_Immediately_Visible (Gen_Comp);
3597 -- Find and save all enclosing instances
3602 and then S /= Standard_Standard
3604 if Is_Generic_Instance (S) then
3605 N_Instances := N_Instances + 1;
3606 Instances (N_Instances) := S;
3608 exit when In_Package_Body (S);
3614 -- Remove context of current compilation unit, unless we are within a
3615 -- nested package instantiation, in which case the context has been
3616 -- removed previously.
3618 -- If current scope is the body of a child unit, remove context of
3619 -- spec as well. If an enclosing scope is an instance body, the
3620 -- context has already been removed, but the entities in the body
3621 -- must be made invisible as well.
3626 and then S /= Standard_Standard
3628 if Is_Generic_Instance (S)
3629 and then (In_Package_Body (S)
3630 or else Ekind (S) = E_Procedure
3631 or else Ekind (S) = E_Function)
3633 -- We still have to remove the entities of the enclosing
3634 -- instance from direct visibility.
3639 E := First_Entity (S);
3640 while Present (E) loop
3641 Set_Is_Immediately_Visible (E, False);
3650 or else (Ekind (Curr_Unit) = E_Package_Body
3651 and then S = Spec_Entity (Curr_Unit))
3652 or else (Ekind (Curr_Unit) = E_Subprogram_Body
3655 (Unit_Declaration_Node (Curr_Unit)))
3659 -- Remove entities in current scopes from visibility, so that
3660 -- instance body is compiled in a clean environment.
3662 Save_Scope_Stack (Handle_Use => False);
3664 if Is_Child_Unit (S) then
3666 -- Remove child unit from stack, as well as inner scopes.
3667 -- Removing the context of a child unit removes parent units
3670 while Current_Scope /= S loop
3671 Num_Inner := Num_Inner + 1;
3672 Inner_Scopes (Num_Inner) := Current_Scope;
3677 Remove_Context (Curr_Comp);
3681 Remove_Context (Curr_Comp);
3684 if Ekind (Curr_Unit) = E_Package_Body then
3685 Remove_Context (Library_Unit (Curr_Comp));
3691 pragma Assert (Num_Inner < Num_Scopes);
3693 Push_Scope (Standard_Standard);
3694 Scope_Stack.Table (Scope_Stack.Last).Is_Active_Stack_Base := True;
3695 Instantiate_Package_Body
3698 Act_Decl => Act_Decl,
3699 Expander_Status => Expander_Active,
3700 Current_Sem_Unit => Current_Sem_Unit,
3701 Scope_Suppress => Scope_Suppress,
3702 Local_Suppress_Stack_Top => Local_Suppress_Stack_Top)),
3703 Inlined_Body => True);
3709 Set_Is_Immediately_Visible (Gen_Comp, Vis);
3711 -- Reset Generic_Instance flag so that use clauses can be installed
3712 -- in the proper order. (See Use_One_Package for effect of enclosing
3713 -- instances on processing of use clauses).
3715 for J in 1 .. N_Instances loop
3716 Set_Is_Generic_Instance (Instances (J), False);
3720 Install_Context (Curr_Comp);
3722 if Present (Curr_Scope)
3723 and then Is_Child_Unit (Curr_Scope)
3725 Push_Scope (Curr_Scope);
3726 Set_Is_Immediately_Visible (Curr_Scope);
3728 -- Finally, restore inner scopes as well
3730 for J in reverse 1 .. Num_Inner loop
3731 Push_Scope (Inner_Scopes (J));
3735 Restore_Scope_Stack (Handle_Use => False);
3737 if Present (Curr_Scope)
3739 (In_Private_Part (Curr_Scope)
3740 or else In_Package_Body (Curr_Scope))
3742 -- Install private declaration of ancestor units, which are
3743 -- currently available. Restore_Scope_Stack and Install_Context
3744 -- only install the visible part of parents.
3749 Par := Scope (Curr_Scope);
3750 while (Present (Par))
3751 and then Par /= Standard_Standard
3753 Install_Private_Declarations (Par);
3760 -- Restore use clauses. For a child unit, use clauses in the parents
3761 -- are restored when installing the context, so only those in inner
3762 -- scopes (and those local to the child unit itself) need to be
3763 -- installed explicitly.
3765 if Is_Child_Unit (Curr_Unit)
3768 for J in reverse 1 .. Num_Inner + 1 loop
3769 Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause :=
3771 Install_Use_Clauses (Use_Clauses (J));
3775 for J in reverse 1 .. Num_Scopes loop
3776 Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause :=
3778 Install_Use_Clauses (Use_Clauses (J));
3782 -- Restore status of instances. If one of them is a body, make
3783 -- its local entities visible again.
3790 for J in 1 .. N_Instances loop
3791 Inst := Instances (J);
3792 Set_Is_Generic_Instance (Inst, True);
3794 if In_Package_Body (Inst)
3795 or else Ekind (S) = E_Procedure
3796 or else Ekind (S) = E_Function
3798 E := First_Entity (Instances (J));
3799 while Present (E) loop
3800 Set_Is_Immediately_Visible (E);
3807 -- If generic unit is in current unit, current context is correct
3810 Instantiate_Package_Body
3813 Act_Decl => Act_Decl,
3814 Expander_Status => Expander_Active,
3815 Current_Sem_Unit => Current_Sem_Unit,
3816 Scope_Suppress => Scope_Suppress,
3817 Local_Suppress_Stack_Top => Local_Suppress_Stack_Top)),
3818 Inlined_Body => True);
3820 end Inline_Instance_Body;
3822 -------------------------------------
3823 -- Analyze_Procedure_Instantiation --
3824 -------------------------------------
3826 procedure Analyze_Procedure_Instantiation (N : Node_Id) is
3828 Analyze_Subprogram_Instantiation (N, E_Procedure);
3829 end Analyze_Procedure_Instantiation;
3831 -----------------------------------
3832 -- Need_Subprogram_Instance_Body --
3833 -----------------------------------
3835 function Need_Subprogram_Instance_Body
3837 Subp : Entity_Id) return Boolean
3840 if (Is_In_Main_Unit (N)
3841 or else Is_Inlined (Subp)
3842 or else Is_Inlined (Alias (Subp)))
3843 and then (Operating_Mode = Generate_Code
3844 or else (Operating_Mode = Check_Semantics
3845 and then ASIS_Mode))
3846 and then (Expander_Active or else ASIS_Mode)
3847 and then not ABE_Is_Certain (N)
3848 and then not Is_Eliminated (Subp)
3850 Pending_Instantiations.Append
3852 Act_Decl => Unit_Declaration_Node (Subp),
3853 Expander_Status => Expander_Active,
3854 Current_Sem_Unit => Current_Sem_Unit,
3855 Scope_Suppress => Scope_Suppress,
3856 Local_Suppress_Stack_Top => Local_Suppress_Stack_Top));
3861 end Need_Subprogram_Instance_Body;
3863 --------------------------------------
3864 -- Analyze_Subprogram_Instantiation --
3865 --------------------------------------
3867 procedure Analyze_Subprogram_Instantiation
3871 Loc : constant Source_Ptr := Sloc (N);
3872 Gen_Id : constant Node_Id := Name (N);
3874 Anon_Id : constant Entity_Id :=
3875 Make_Defining_Identifier (Sloc (Defining_Entity (N)),
3876 Chars => New_External_Name
3877 (Chars (Defining_Entity (N)), 'R'));
3879 Act_Decl_Id : Entity_Id;
3884 Env_Installed : Boolean := False;
3885 Gen_Unit : Entity_Id;
3887 Pack_Id : Entity_Id;
3888 Parent_Installed : Boolean := False;
3889 Renaming_List : List_Id;
3891 procedure Analyze_Instance_And_Renamings;
3892 -- The instance must be analyzed in a context that includes the mappings
3893 -- of generic parameters into actuals. We create a package declaration
3894 -- for this purpose, and a subprogram with an internal name within the
3895 -- package. The subprogram instance is simply an alias for the internal
3896 -- subprogram, declared in the current scope.
3898 ------------------------------------
3899 -- Analyze_Instance_And_Renamings --
3900 ------------------------------------
3902 procedure Analyze_Instance_And_Renamings is
3903 Def_Ent : constant Entity_Id := Defining_Entity (N);
3904 Pack_Decl : Node_Id;
3907 if Nkind (Parent (N)) = N_Compilation_Unit then
3909 -- For the case of a compilation unit, the container package has
3910 -- the same name as the instantiation, to insure that the binder
3911 -- calls the elaboration procedure with the right name. Copy the
3912 -- entity of the instance, which may have compilation level flags
3913 -- (e.g. Is_Child_Unit) set.
3915 Pack_Id := New_Copy (Def_Ent);
3918 -- Otherwise we use the name of the instantiation concatenated
3919 -- with its source position to ensure uniqueness if there are
3920 -- several instantiations with the same name.
3923 Make_Defining_Identifier (Loc,
3924 Chars => New_External_Name
3925 (Related_Id => Chars (Def_Ent),
3927 Suffix_Index => Source_Offset (Sloc (Def_Ent))));
3930 Pack_Decl := Make_Package_Declaration (Loc,
3931 Specification => Make_Package_Specification (Loc,
3932 Defining_Unit_Name => Pack_Id,
3933 Visible_Declarations => Renaming_List,
3934 End_Label => Empty));
3936 Set_Instance_Spec (N, Pack_Decl);
3937 Set_Is_Generic_Instance (Pack_Id);
3938 Set_Debug_Info_Needed (Pack_Id);
3940 -- Case of not a compilation unit
3942 if Nkind (Parent (N)) /= N_Compilation_Unit then
3943 Mark_Rewrite_Insertion (Pack_Decl);
3944 Insert_Before (N, Pack_Decl);
3945 Set_Has_Completion (Pack_Id);
3947 -- Case of an instantiation that is a compilation unit
3949 -- Place declaration on current node so context is complete for
3950 -- analysis (including nested instantiations), and for use in a
3951 -- context_clause (see Analyze_With_Clause).
3954 Set_Unit (Parent (N), Pack_Decl);
3955 Set_Parent_Spec (Pack_Decl, Parent_Spec (N));
3958 Analyze (Pack_Decl);
3959 Check_Formal_Packages (Pack_Id);
3960 Set_Is_Generic_Instance (Pack_Id, False);
3962 -- Body of the enclosing package is supplied when instantiating the
3963 -- subprogram body, after semantic analysis is completed.
3965 if Nkind (Parent (N)) = N_Compilation_Unit then
3967 -- Remove package itself from visibility, so it does not
3968 -- conflict with subprogram.
3970 Set_Name_Entity_Id (Chars (Pack_Id), Homonym (Pack_Id));
3972 -- Set name and scope of internal subprogram so that the proper
3973 -- external name will be generated. The proper scope is the scope
3974 -- of the wrapper package. We need to generate debugging info for
3975 -- the internal subprogram, so set flag accordingly.
3977 Set_Chars (Anon_Id, Chars (Defining_Entity (N)));
3978 Set_Scope (Anon_Id, Scope (Pack_Id));
3980 -- Mark wrapper package as referenced, to avoid spurious warnings
3981 -- if the instantiation appears in various with_ clauses of
3982 -- subunits of the main unit.
3984 Set_Referenced (Pack_Id);
3987 Set_Is_Generic_Instance (Anon_Id);
3988 Set_Debug_Info_Needed (Anon_Id);
3989 Act_Decl_Id := New_Copy (Anon_Id);
3991 Set_Parent (Act_Decl_Id, Parent (Anon_Id));
3992 Set_Chars (Act_Decl_Id, Chars (Defining_Entity (N)));
3993 Set_Sloc (Act_Decl_Id, Sloc (Defining_Entity (N)));
3994 Set_Comes_From_Source (Act_Decl_Id, True);
3996 -- The signature may involve types that are not frozen yet, but the
3997 -- subprogram will be frozen at the point the wrapper package is
3998 -- frozen, so it does not need its own freeze node. In fact, if one
3999 -- is created, it might conflict with the freezing actions from the
4002 Set_Has_Delayed_Freeze (Anon_Id, False);
4004 -- If the instance is a child unit, mark the Id accordingly. Mark
4005 -- the anonymous entity as well, which is the real subprogram and
4006 -- which is used when the instance appears in a context clause.
4008 Set_Is_Child_Unit (Act_Decl_Id, Is_Child_Unit (Defining_Entity (N)));
4009 Set_Is_Child_Unit (Anon_Id, Is_Child_Unit (Defining_Entity (N)));
4010 New_Overloaded_Entity (Act_Decl_Id);
4011 Check_Eliminated (Act_Decl_Id);
4013 -- In compilation unit case, kill elaboration checks on the
4014 -- instantiation, since they are never needed -- the body is
4015 -- instantiated at the same point as the spec.
4017 if Nkind (Parent (N)) = N_Compilation_Unit then
4018 Set_Suppress_Elaboration_Warnings (Act_Decl_Id);
4019 Set_Kill_Elaboration_Checks (Act_Decl_Id);
4020 Set_Is_Compilation_Unit (Anon_Id);
4022 Set_Cunit_Entity (Current_Sem_Unit, Pack_Id);
4025 -- The instance is not a freezing point for the new subprogram
4027 Set_Is_Frozen (Act_Decl_Id, False);
4029 if Nkind (Defining_Entity (N)) = N_Defining_Operator_Symbol then
4030 Valid_Operator_Definition (Act_Decl_Id);
4033 Set_Alias (Act_Decl_Id, Anon_Id);
4034 Set_Parent (Act_Decl_Id, Parent (Anon_Id));
4035 Set_Has_Completion (Act_Decl_Id);
4036 Set_Related_Instance (Pack_Id, Act_Decl_Id);
4038 if Nkind (Parent (N)) = N_Compilation_Unit then
4039 Set_Body_Required (Parent (N), False);
4041 end Analyze_Instance_And_Renamings;
4043 -- Start of processing for Analyze_Subprogram_Instantiation
4046 -- Very first thing: apply the special kludge for Text_IO processing
4047 -- in case we are instantiating one of the children of [Wide_]Text_IO.
4048 -- Of course such an instantiation is bogus (these are packages, not
4049 -- subprograms), but we get a better error message if we do this.
4051 Text_IO_Kludge (Gen_Id);
4053 -- Make node global for error reporting
4055 Instantiation_Node := N;
4056 Preanalyze_Actuals (N);
4059 Env_Installed := True;
4060 Check_Generic_Child_Unit (Gen_Id, Parent_Installed);
4061 Gen_Unit := Entity (Gen_Id);
4063 Generate_Reference (Gen_Unit, Gen_Id);
4065 if Nkind (Gen_Id) = N_Identifier
4066 and then Chars (Gen_Unit) = Chars (Defining_Entity (N))
4069 ("& is hidden within declaration of instance", Gen_Id, Gen_Unit);
4072 if Etype (Gen_Unit) = Any_Type then
4077 -- Verify that it is a generic subprogram of the right kind, and that
4078 -- it does not lead to a circular instantiation.
4080 if Ekind (Gen_Unit) /= E_Generic_Procedure
4081 and then Ekind (Gen_Unit) /= E_Generic_Function
4083 Error_Msg_N ("expect generic subprogram in instantiation", Gen_Id);
4085 elsif In_Open_Scopes (Gen_Unit) then
4086 Error_Msg_NE ("instantiation of & within itself", N, Gen_Unit);
4088 elsif K = E_Procedure
4089 and then Ekind (Gen_Unit) /= E_Generic_Procedure
4091 if Ekind (Gen_Unit) = E_Generic_Function then
4093 ("cannot instantiate generic function as procedure", Gen_Id);
4096 ("expect name of generic procedure in instantiation", Gen_Id);
4099 elsif K = E_Function
4100 and then Ekind (Gen_Unit) /= E_Generic_Function
4102 if Ekind (Gen_Unit) = E_Generic_Procedure then
4104 ("cannot instantiate generic procedure as function", Gen_Id);
4107 ("expect name of generic function in instantiation", Gen_Id);
4111 Set_Entity (Gen_Id, Gen_Unit);
4112 Set_Is_Instantiated (Gen_Unit);
4114 if In_Extended_Main_Source_Unit (N) then
4115 Generate_Reference (Gen_Unit, N);
4118 -- If renaming, get original unit
4120 if Present (Renamed_Object (Gen_Unit))
4121 and then (Ekind (Renamed_Object (Gen_Unit)) = E_Generic_Procedure
4123 Ekind (Renamed_Object (Gen_Unit)) = E_Generic_Function)
4125 Gen_Unit := Renamed_Object (Gen_Unit);
4126 Set_Is_Instantiated (Gen_Unit);
4127 Generate_Reference (Gen_Unit, N);
4130 if Contains_Instance_Of (Gen_Unit, Current_Scope, Gen_Id) then
4131 Error_Msg_Node_2 := Current_Scope;
4133 ("circular Instantiation: & instantiated in &!", N, Gen_Unit);
4134 Circularity_Detected := True;
4138 Gen_Decl := Unit_Declaration_Node (Gen_Unit);
4140 -- Initialize renamings map, for error checking
4142 Generic_Renamings.Set_Last (0);
4143 Generic_Renamings_HTable.Reset;
4145 Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment);
4147 -- Copy original generic tree, to produce text for instantiation
4151 (Original_Node (Gen_Decl), Empty, Instantiating => True);
4153 -- Inherit overriding indicator from instance node
4155 Act_Spec := Specification (Act_Tree);
4156 Set_Must_Override (Act_Spec, Must_Override (N));
4157 Set_Must_Not_Override (Act_Spec, Must_Not_Override (N));
4160 Analyze_Associations
4162 Generic_Formal_Declarations (Act_Tree),
4163 Generic_Formal_Declarations (Gen_Decl));
4165 -- The subprogram itself cannot contain a nested instance, so the
4166 -- current parent is left empty.
4168 Set_Instance_Env (Gen_Unit, Empty);
4170 -- Build the subprogram declaration, which does not appear in the
4171 -- generic template, and give it a sloc consistent with that of the
4174 Set_Defining_Unit_Name (Act_Spec, Anon_Id);
4175 Set_Generic_Parent (Act_Spec, Gen_Unit);
4177 Make_Subprogram_Declaration (Sloc (Act_Spec),
4178 Specification => Act_Spec);
4180 Set_Categorization_From_Pragmas (Act_Decl);
4182 if Parent_Installed then
4186 Append (Act_Decl, Renaming_List);
4187 Analyze_Instance_And_Renamings;
4189 -- If the generic is marked Import (Intrinsic), then so is the
4190 -- instance. This indicates that there is no body to instantiate. If
4191 -- generic is marked inline, so it the instance, and the anonymous
4192 -- subprogram it renames. If inlined, or else if inlining is enabled
4193 -- for the compilation, we generate the instance body even if it is
4194 -- not within the main unit.
4196 -- Any other pragmas might also be inherited ???
4198 if Is_Intrinsic_Subprogram (Gen_Unit) then
4199 Set_Is_Intrinsic_Subprogram (Anon_Id);
4200 Set_Is_Intrinsic_Subprogram (Act_Decl_Id);
4202 if Chars (Gen_Unit) = Name_Unchecked_Conversion then
4203 Validate_Unchecked_Conversion (N, Act_Decl_Id);
4207 Generate_Definition (Act_Decl_Id);
4209 Set_Is_Inlined (Act_Decl_Id, Is_Inlined (Gen_Unit));
4210 Set_Is_Inlined (Anon_Id, Is_Inlined (Gen_Unit));
4212 if not Is_Intrinsic_Subprogram (Gen_Unit) then
4213 Check_Elab_Instantiation (N);
4216 if Is_Dispatching_Operation (Act_Decl_Id)
4217 and then Ada_Version >= Ada_05
4223 Formal := First_Formal (Act_Decl_Id);
4224 while Present (Formal) loop
4225 if Ekind (Etype (Formal)) = E_Anonymous_Access_Type
4226 and then Is_Controlling_Formal (Formal)
4227 and then not Can_Never_Be_Null (Formal)
4229 Error_Msg_NE ("access parameter& is controlling,",
4231 Error_Msg_NE ("\corresponding parameter of & must be"
4232 & " explicitly null-excluding", N, Gen_Id);
4235 Next_Formal (Formal);
4240 Check_Hidden_Child_Unit (N, Gen_Unit, Act_Decl_Id);
4242 -- Subject to change, pending on if other pragmas are inherited ???
4244 Validate_Categorization_Dependency (N, Act_Decl_Id);
4246 if not Is_Intrinsic_Subprogram (Act_Decl_Id) then
4247 Inherit_Context (Gen_Decl, N);
4249 Restore_Private_Views (Pack_Id, False);
4251 -- If the context requires a full instantiation, mark node for
4252 -- subsequent construction of the body.
4254 if Need_Subprogram_Instance_Body (N, Act_Decl_Id) then
4256 Check_Forward_Instantiation (Gen_Decl);
4258 -- The wrapper package is always delayed, because it does not
4259 -- constitute a freeze point, but to insure that the freeze
4260 -- node is placed properly, it is created directly when
4261 -- instantiating the body (otherwise the freeze node might
4262 -- appear to early for nested instantiations).
4264 elsif Nkind (Parent (N)) = N_Compilation_Unit then
4266 -- For ASIS purposes, indicate that the wrapper package has
4267 -- replaced the instantiation node.
4269 Rewrite (N, Unit (Parent (N)));
4270 Set_Unit (Parent (N), N);
4273 elsif Nkind (Parent (N)) = N_Compilation_Unit then
4275 -- Replace instance node for library-level instantiations of
4276 -- intrinsic subprograms, for ASIS use.
4278 Rewrite (N, Unit (Parent (N)));
4279 Set_Unit (Parent (N), N);
4282 if Parent_Installed then
4287 Env_Installed := False;
4288 Generic_Renamings.Set_Last (0);
4289 Generic_Renamings_HTable.Reset;
4293 when Instantiation_Error =>
4294 if Parent_Installed then
4298 if Env_Installed then
4301 end Analyze_Subprogram_Instantiation;
4303 -------------------------
4304 -- Get_Associated_Node --
4305 -------------------------
4307 function Get_Associated_Node (N : Node_Id) return Node_Id is
4311 Assoc := Associated_Node (N);
4313 if Nkind (Assoc) /= Nkind (N) then
4316 elsif Nkind_In (Assoc, N_Aggregate, N_Extension_Aggregate) then
4320 -- If the node is part of an inner generic, it may itself have been
4321 -- remapped into a further generic copy. Associated_Node is otherwise
4322 -- used for the entity of the node, and will be of a different node
4323 -- kind, or else N has been rewritten as a literal or function call.
4325 while Present (Associated_Node (Assoc))
4326 and then Nkind (Associated_Node (Assoc)) = Nkind (Assoc)
4328 Assoc := Associated_Node (Assoc);
4331 -- Follow and additional link in case the final node was rewritten.
4332 -- This can only happen with nested generic units.
4334 if (Nkind (Assoc) = N_Identifier or else Nkind (Assoc) in N_Op)
4335 and then Present (Associated_Node (Assoc))
4336 and then (Nkind_In (Associated_Node (Assoc), N_Function_Call,
4337 N_Explicit_Dereference,
4342 Assoc := Associated_Node (Assoc);
4347 end Get_Associated_Node;
4349 -------------------------------------------
4350 -- Build_Instance_Compilation_Unit_Nodes --
4351 -------------------------------------------
4353 procedure Build_Instance_Compilation_Unit_Nodes
4358 Decl_Cunit : Node_Id;
4359 Body_Cunit : Node_Id;
4361 New_Main : constant Entity_Id := Defining_Entity (Act_Decl);
4362 Old_Main : constant Entity_Id := Cunit_Entity (Main_Unit);
4365 -- A new compilation unit node is built for the instance declaration
4368 Make_Compilation_Unit (Sloc (N),
4369 Context_Items => Empty_List,
4372 Make_Compilation_Unit_Aux (Sloc (N)));
4374 Set_Parent_Spec (Act_Decl, Parent_Spec (N));
4375 Set_Body_Required (Decl_Cunit, True);
4377 -- We use the original instantiation compilation unit as the resulting
4378 -- compilation unit of the instance, since this is the main unit.
4380 Rewrite (N, Act_Body);
4381 Body_Cunit := Parent (N);
4383 -- The two compilation unit nodes are linked by the Library_Unit field
4385 Set_Library_Unit (Decl_Cunit, Body_Cunit);
4386 Set_Library_Unit (Body_Cunit, Decl_Cunit);
4388 -- Preserve the private nature of the package if needed
4390 Set_Private_Present (Decl_Cunit, Private_Present (Body_Cunit));
4392 -- If the instance is not the main unit, its context, categorization,
4393 -- and elaboration entity are not relevant to the compilation.
4395 if Parent (N) /= Cunit (Main_Unit) then
4399 -- The context clause items on the instantiation, which are now attached
4400 -- to the body compilation unit (since the body overwrote the original
4401 -- instantiation node), semantically belong on the spec, so copy them
4402 -- there. It's harmless to leave them on the body as well. In fact one
4403 -- could argue that they belong in both places.
4405 Citem := First (Context_Items (Body_Cunit));
4406 while Present (Citem) loop
4407 Append (New_Copy (Citem), Context_Items (Decl_Cunit));
4411 -- Propagate categorization flags on packages, so that they appear in
4412 -- the ali file for the spec of the unit.
4414 if Ekind (New_Main) = E_Package then
4415 Set_Is_Pure (Old_Main, Is_Pure (New_Main));
4416 Set_Is_Preelaborated (Old_Main, Is_Preelaborated (New_Main));
4417 Set_Is_Remote_Types (Old_Main, Is_Remote_Types (New_Main));
4418 Set_Is_Shared_Passive (Old_Main, Is_Shared_Passive (New_Main));
4419 Set_Is_Remote_Call_Interface
4420 (Old_Main, Is_Remote_Call_Interface (New_Main));
4423 -- Make entry in Units table, so that binder can generate call to
4424 -- elaboration procedure for body, if any.
4426 Make_Instance_Unit (Body_Cunit);
4427 Main_Unit_Entity := New_Main;
4428 Set_Cunit_Entity (Main_Unit, Main_Unit_Entity);
4430 -- Build elaboration entity, since the instance may certainly generate
4431 -- elaboration code requiring a flag for protection.
4433 Build_Elaboration_Entity (Decl_Cunit, New_Main);
4434 end Build_Instance_Compilation_Unit_Nodes;
4436 -----------------------------
4437 -- Check_Access_Definition --
4438 -----------------------------
4440 procedure Check_Access_Definition (N : Node_Id) is
4443 (Ada_Version >= Ada_05
4444 and then Present (Access_Definition (N)));
4446 end Check_Access_Definition;
4448 -----------------------------------
4449 -- Check_Formal_Package_Instance --
4450 -----------------------------------
4452 -- If the formal has specific parameters, they must match those of the
4453 -- actual. Both of them are instances, and the renaming declarations for
4454 -- their formal parameters appear in the same order in both. The analyzed
4455 -- formal has been analyzed in the context of the current instance.
4457 procedure Check_Formal_Package_Instance
4458 (Formal_Pack : Entity_Id;
4459 Actual_Pack : Entity_Id)
4461 E1 : Entity_Id := First_Entity (Actual_Pack);
4462 E2 : Entity_Id := First_Entity (Formal_Pack);
4467 procedure Check_Mismatch (B : Boolean);
4468 -- Common error routine for mismatch between the parameters of the
4469 -- actual instance and those of the formal package.
4471 function Same_Instantiated_Constant (E1, E2 : Entity_Id) return Boolean;
4472 -- The formal may come from a nested formal package, and the actual may
4473 -- have been constant-folded. To determine whether the two denote the
4474 -- same entity we may have to traverse several definitions to recover
4475 -- the ultimate entity that they refer to.
4477 function Same_Instantiated_Variable (E1, E2 : Entity_Id) return Boolean;
4478 -- Similarly, if the formal comes from a nested formal package, the
4479 -- actual may designate the formal through multiple renamings, which
4480 -- have to be followed to determine the original variable in question.
4482 --------------------
4483 -- Check_Mismatch --
4484 --------------------
4486 procedure Check_Mismatch (B : Boolean) is
4487 Kind : constant Node_Kind := Nkind (Parent (E2));
4490 if Kind = N_Formal_Type_Declaration then
4493 elsif Nkind_In (Kind, N_Formal_Object_Declaration,
4494 N_Formal_Package_Declaration)
4495 or else Kind in N_Formal_Subprogram_Declaration
4501 ("actual for & in actual instance does not match formal",
4502 Parent (Actual_Pack), E1);
4506 --------------------------------
4507 -- Same_Instantiated_Constant --
4508 --------------------------------
4510 function Same_Instantiated_Constant
4511 (E1, E2 : Entity_Id) return Boolean
4517 while Present (Ent) loop
4521 elsif Ekind (Ent) /= E_Constant then
4524 elsif Is_Entity_Name (Constant_Value (Ent)) then
4525 if Entity (Constant_Value (Ent)) = E1 then
4528 Ent := Entity (Constant_Value (Ent));
4531 -- The actual may be a constant that has been folded. Recover
4534 elsif Is_Entity_Name (Original_Node (Constant_Value (Ent))) then
4535 Ent := Entity (Original_Node (Constant_Value (Ent)));
4542 end Same_Instantiated_Constant;
4544 --------------------------------
4545 -- Same_Instantiated_Variable --
4546 --------------------------------
4548 function Same_Instantiated_Variable
4549 (E1, E2 : Entity_Id) return Boolean
4551 function Original_Entity (E : Entity_Id) return Entity_Id;
4552 -- Follow chain of renamings to the ultimate ancestor
4554 ---------------------
4555 -- Original_Entity --
4556 ---------------------
4558 function Original_Entity (E : Entity_Id) return Entity_Id is
4563 while Nkind (Parent (Orig)) = N_Object_Renaming_Declaration
4564 and then Present (Renamed_Object (Orig))
4565 and then Is_Entity_Name (Renamed_Object (Orig))
4567 Orig := Entity (Renamed_Object (Orig));
4571 end Original_Entity;
4573 -- Start of processing for Same_Instantiated_Variable
4576 return Ekind (E1) = Ekind (E2)
4577 and then Original_Entity (E1) = Original_Entity (E2);
4578 end Same_Instantiated_Variable;
4580 -- Start of processing for Check_Formal_Package_Instance
4584 and then Present (E2)
4586 exit when Ekind (E1) = E_Package
4587 and then Renamed_Entity (E1) = Renamed_Entity (Actual_Pack);
4589 -- If the formal is the renaming of the formal package, this
4590 -- is the end of its formal part, which may occur before the
4591 -- end of the formal part in the actual in the presence of
4592 -- defaulted parameters in the formal package.
4594 exit when Nkind (Parent (E2)) = N_Package_Renaming_Declaration
4595 and then Renamed_Entity (E2) = Scope (E2);
4597 -- The analysis of the actual may generate additional internal
4598 -- entities. If the formal is defaulted, there is no corresponding
4599 -- analysis and the internal entities must be skipped, until we
4600 -- find corresponding entities again.
4602 if Comes_From_Source (E2)
4603 and then not Comes_From_Source (E1)
4604 and then Chars (E1) /= Chars (E2)
4607 and then Chars (E1) /= Chars (E2)
4616 -- If the formal entity comes from a formal declaration, it was
4617 -- defaulted in the formal package, and no check is needed on it.
4619 elsif Nkind (Parent (E2)) = N_Formal_Object_Declaration then
4622 elsif Is_Type (E1) then
4624 -- Subtypes must statically match. E1, E2 are the local entities
4625 -- that are subtypes of the actuals. Itypes generated for other
4626 -- parameters need not be checked, the check will be performed
4627 -- on the parameters themselves.
4629 -- If E2 is a formal type declaration, it is a defaulted parameter
4630 -- and needs no checking.
4632 if not Is_Itype (E1)
4633 and then not Is_Itype (E2)
4637 or else Etype (E1) /= Etype (E2)
4638 or else not Subtypes_Statically_Match (E1, E2));
4641 elsif Ekind (E1) = E_Constant then
4643 -- IN parameters must denote the same static value, or the same
4644 -- constant, or the literal null.
4646 Expr1 := Expression (Parent (E1));
4648 if Ekind (E2) /= E_Constant then
4649 Check_Mismatch (True);
4652 Expr2 := Expression (Parent (E2));
4655 if Is_Static_Expression (Expr1) then
4657 if not Is_Static_Expression (Expr2) then
4658 Check_Mismatch (True);
4660 elsif Is_Discrete_Type (Etype (E1)) then
4662 V1 : constant Uint := Expr_Value (Expr1);
4663 V2 : constant Uint := Expr_Value (Expr2);
4665 Check_Mismatch (V1 /= V2);
4668 elsif Is_Real_Type (Etype (E1)) then
4670 V1 : constant Ureal := Expr_Value_R (Expr1);
4671 V2 : constant Ureal := Expr_Value_R (Expr2);
4673 Check_Mismatch (V1 /= V2);
4676 elsif Is_String_Type (Etype (E1))
4677 and then Nkind (Expr1) = N_String_Literal
4679 if Nkind (Expr2) /= N_String_Literal then
4680 Check_Mismatch (True);
4683 (not String_Equal (Strval (Expr1), Strval (Expr2)));
4687 elsif Is_Entity_Name (Expr1) then
4688 if Is_Entity_Name (Expr2) then
4689 if Entity (Expr1) = Entity (Expr2) then
4693 (not Same_Instantiated_Constant
4694 (Entity (Expr1), Entity (Expr2)));
4697 Check_Mismatch (True);
4700 elsif Is_Entity_Name (Original_Node (Expr1))
4701 and then Is_Entity_Name (Expr2)
4703 Same_Instantiated_Constant
4704 (Entity (Original_Node (Expr1)), Entity (Expr2))
4708 elsif Nkind (Expr1) = N_Null then
4709 Check_Mismatch (Nkind (Expr1) /= N_Null);
4712 Check_Mismatch (True);
4715 elsif Ekind (E1) = E_Variable then
4716 Check_Mismatch (not Same_Instantiated_Variable (E1, E2));
4718 elsif Ekind (E1) = E_Package then
4720 (Ekind (E1) /= Ekind (E2)
4721 or else Renamed_Object (E1) /= Renamed_Object (E2));
4723 elsif Is_Overloadable (E1) then
4725 -- Verify that the actual subprograms match. Note that actuals
4726 -- that are attributes are rewritten as subprograms. If the
4727 -- subprogram in the formal package is defaulted, no check is
4728 -- needed. Note that this can only happen in Ada 2005 when the
4729 -- formal package can be partially parametrized.
4731 if Nkind (Unit_Declaration_Node (E1)) =
4732 N_Subprogram_Renaming_Declaration
4733 and then From_Default (Unit_Declaration_Node (E1))
4739 (Ekind (E2) /= Ekind (E1) or else (Alias (E1)) /= Alias (E2));
4743 raise Program_Error;
4750 end Check_Formal_Package_Instance;
4752 ---------------------------
4753 -- Check_Formal_Packages --
4754 ---------------------------
4756 procedure Check_Formal_Packages (P_Id : Entity_Id) is
4758 Formal_P : Entity_Id;
4761 -- Iterate through the declarations in the instance, looking for package
4762 -- renaming declarations that denote instances of formal packages. Stop
4763 -- when we find the renaming of the current package itself. The
4764 -- declaration for a formal package without a box is followed by an
4765 -- internal entity that repeats the instantiation.
4767 E := First_Entity (P_Id);
4768 while Present (E) loop
4769 if Ekind (E) = E_Package then
4770 if Renamed_Object (E) = P_Id then
4773 elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then
4776 elsif not Box_Present (Parent (Associated_Formal_Package (E))) then
4777 Formal_P := Next_Entity (E);
4778 Check_Formal_Package_Instance (Formal_P, E);
4780 -- After checking, remove the internal validating package. It
4781 -- is only needed for semantic checks, and as it may contain
4782 -- generic formal declarations it should not reach gigi.
4784 Remove (Unit_Declaration_Node (Formal_P));
4790 end Check_Formal_Packages;
4792 ---------------------------------
4793 -- Check_Forward_Instantiation --
4794 ---------------------------------
4796 procedure Check_Forward_Instantiation (Decl : Node_Id) is
4798 Gen_Comp : Entity_Id := Cunit_Entity (Get_Source_Unit (Decl));
4801 -- The instantiation appears before the generic body if we are in the
4802 -- scope of the unit containing the generic, either in its spec or in
4803 -- the package body, and before the generic body.
4805 if Ekind (Gen_Comp) = E_Package_Body then
4806 Gen_Comp := Spec_Entity (Gen_Comp);
4809 if In_Open_Scopes (Gen_Comp)
4810 and then No (Corresponding_Body (Decl))
4815 and then not Is_Compilation_Unit (S)
4816 and then not Is_Child_Unit (S)
4818 if Ekind (S) = E_Package then
4819 Set_Has_Forward_Instantiation (S);
4825 end Check_Forward_Instantiation;
4827 ---------------------------
4828 -- Check_Generic_Actuals --
4829 ---------------------------
4831 -- The visibility of the actuals may be different between the point of
4832 -- generic instantiation and the instantiation of the body.
4834 procedure Check_Generic_Actuals
4835 (Instance : Entity_Id;
4836 Is_Formal_Box : Boolean)
4841 function Denotes_Previous_Actual (Typ : Entity_Id) return Boolean;
4842 -- For a formal that is an array type, the component type is often a
4843 -- previous formal in the same unit. The privacy status of the component
4844 -- type will have been examined earlier in the traversal of the
4845 -- corresponding actuals, and this status should not be modified for the
4846 -- array type itself.
4848 -- To detect this case we have to rescan the list of formals, which
4849 -- is usually short enough to ignore the resulting inefficiency.
4851 function Denotes_Previous_Actual (Typ : Entity_Id) return Boolean is
4854 Prev := First_Entity (Instance);
4855 while Present (Prev) loop
4857 and then Nkind (Parent (Prev)) = N_Subtype_Declaration
4858 and then Is_Entity_Name (Subtype_Indication (Parent (Prev)))
4859 and then Entity (Subtype_Indication (Parent (Prev))) = Typ
4869 end Denotes_Previous_Actual;
4871 -- Start of processing for Check_Generic_Actuals
4874 E := First_Entity (Instance);
4875 while Present (E) loop
4877 and then Nkind (Parent (E)) = N_Subtype_Declaration
4878 and then Scope (Etype (E)) /= Instance
4879 and then Is_Entity_Name (Subtype_Indication (Parent (E)))
4881 if Is_Array_Type (E)
4882 and then Denotes_Previous_Actual (Component_Type (E))
4886 Check_Private_View (Subtype_Indication (Parent (E)));
4888 Set_Is_Generic_Actual_Type (E, True);
4889 Set_Is_Hidden (E, False);
4890 Set_Is_Potentially_Use_Visible (E,
4893 -- We constructed the generic actual type as a subtype of the
4894 -- supplied type. This means that it normally would not inherit
4895 -- subtype specific attributes of the actual, which is wrong for
4896 -- the generic case.
4898 Astype := Ancestor_Subtype (E);
4902 -- This can happen when E is an itype that is the full view of
4903 -- a private type completed, e.g. with a constrained array. In
4904 -- that case, use the first subtype, which will carry size
4905 -- information. The base type itself is unconstrained and will
4908 Astype := First_Subtype (E);
4911 Set_Size_Info (E, (Astype));
4912 Set_RM_Size (E, RM_Size (Astype));
4913 Set_First_Rep_Item (E, First_Rep_Item (Astype));
4915 if Is_Discrete_Or_Fixed_Point_Type (E) then
4916 Set_RM_Size (E, RM_Size (Astype));
4918 -- In nested instances, the base type of an access actual
4919 -- may itself be private, and need to be exchanged.
4921 elsif Is_Access_Type (E)
4922 and then Is_Private_Type (Etype (E))
4925 (New_Occurrence_Of (Etype (E), Sloc (Instance)));
4928 elsif Ekind (E) = E_Package then
4930 -- If this is the renaming for the current instance, we're done.
4931 -- Otherwise it is a formal package. If the corresponding formal
4932 -- was declared with a box, the (instantiations of the) generic
4933 -- formal part are also visible. Otherwise, ignore the entity
4934 -- created to validate the actuals.
4936 if Renamed_Object (E) = Instance then
4939 elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then
4942 -- The visibility of a formal of an enclosing generic is already
4945 elsif Denotes_Formal_Package (E) then
4948 elsif Present (Associated_Formal_Package (E))
4949 and then not Is_Generic_Formal (E)
4951 if Box_Present (Parent (Associated_Formal_Package (E))) then
4952 Check_Generic_Actuals (Renamed_Object (E), True);
4955 Check_Generic_Actuals (Renamed_Object (E), False);
4958 Set_Is_Hidden (E, False);
4961 -- If this is a subprogram instance (in a wrapper package) the
4962 -- actual is fully visible.
4964 elsif Is_Wrapper_Package (Instance) then
4965 Set_Is_Hidden (E, False);
4967 -- If the formal package is declared with a box, or if the formal
4968 -- parameter is defaulted, it is visible in the body.
4971 or else Is_Visible_Formal (E)
4973 Set_Is_Hidden (E, False);
4978 end Check_Generic_Actuals;
4980 ------------------------------
4981 -- Check_Generic_Child_Unit --
4982 ------------------------------
4984 procedure Check_Generic_Child_Unit
4986 Parent_Installed : in out Boolean)
4988 Loc : constant Source_Ptr := Sloc (Gen_Id);
4989 Gen_Par : Entity_Id := Empty;
4991 Inst_Par : Entity_Id;
4994 function Find_Generic_Child
4996 Id : Node_Id) return Entity_Id;
4997 -- Search generic parent for possible child unit with the given name
4999 function In_Enclosing_Instance return Boolean;
5000 -- Within an instance of the parent, the child unit may be denoted
5001 -- by a simple name, or an abbreviated expanded name. Examine enclosing
5002 -- scopes to locate a possible parent instantiation.
5004 ------------------------
5005 -- Find_Generic_Child --
5006 ------------------------
5008 function Find_Generic_Child
5010 Id : Node_Id) return Entity_Id
5015 -- If entity of name is already set, instance has already been
5016 -- resolved, e.g. in an enclosing instantiation.
5018 if Present (Entity (Id)) then
5019 if Scope (Entity (Id)) = Scop then
5026 E := First_Entity (Scop);
5027 while Present (E) loop
5028 if Chars (E) = Chars (Id)
5029 and then Is_Child_Unit (E)
5031 if Is_Child_Unit (E)
5032 and then not Is_Visible_Child_Unit (E)
5035 ("generic child unit& is not visible", Gen_Id, E);
5047 end Find_Generic_Child;
5049 ---------------------------
5050 -- In_Enclosing_Instance --
5051 ---------------------------
5053 function In_Enclosing_Instance return Boolean is
5054 Enclosing_Instance : Node_Id;
5055 Instance_Decl : Node_Id;
5058 -- We do not inline any call that contains instantiations, except
5059 -- for instantiations of Unchecked_Conversion, so if we are within
5060 -- an inlined body the current instance does not require parents.
5062 if In_Inlined_Body then
5063 pragma Assert (Chars (Gen_Id) = Name_Unchecked_Conversion);
5067 -- Loop to check enclosing scopes
5069 Enclosing_Instance := Current_Scope;
5070 while Present (Enclosing_Instance) loop
5071 Instance_Decl := Unit_Declaration_Node (Enclosing_Instance);
5073 if Ekind (Enclosing_Instance) = E_Package
5074 and then Is_Generic_Instance (Enclosing_Instance)
5076 (Generic_Parent (Specification (Instance_Decl)))
5078 -- Check whether the generic we are looking for is a child of
5081 E := Find_Generic_Child
5082 (Generic_Parent (Specification (Instance_Decl)), Gen_Id);
5083 exit when Present (E);
5089 Enclosing_Instance := Scope (Enclosing_Instance);
5101 Make_Expanded_Name (Loc,
5103 Prefix => New_Occurrence_Of (Enclosing_Instance, Loc),
5104 Selector_Name => New_Occurrence_Of (E, Loc)));
5106 Set_Entity (Gen_Id, E);
5107 Set_Etype (Gen_Id, Etype (E));
5108 Parent_Installed := False; -- Already in scope.
5111 end In_Enclosing_Instance;
5113 -- Start of processing for Check_Generic_Child_Unit
5116 -- If the name of the generic is given by a selected component, it may
5117 -- be the name of a generic child unit, and the prefix is the name of an
5118 -- instance of the parent, in which case the child unit must be visible.
5119 -- If this instance is not in scope, it must be placed there and removed
5120 -- after instantiation, because what is being instantiated is not the
5121 -- original child, but the corresponding child present in the instance
5124 -- If the child is instantiated within the parent, it can be given by
5125 -- a simple name. In this case the instance is already in scope, but
5126 -- the child generic must be recovered from the generic parent as well.
5128 if Nkind (Gen_Id) = N_Selected_Component then
5129 S := Selector_Name (Gen_Id);
5130 Analyze (Prefix (Gen_Id));
5131 Inst_Par := Entity (Prefix (Gen_Id));
5133 if Ekind (Inst_Par) = E_Package
5134 and then Present (Renamed_Object (Inst_Par))
5136 Inst_Par := Renamed_Object (Inst_Par);
5139 if Ekind (Inst_Par) = E_Package then
5140 if Nkind (Parent (Inst_Par)) = N_Package_Specification then
5141 Gen_Par := Generic_Parent (Parent (Inst_Par));
5143 elsif Nkind (Parent (Inst_Par)) = N_Defining_Program_Unit_Name
5145 Nkind (Parent (Parent (Inst_Par))) = N_Package_Specification
5147 Gen_Par := Generic_Parent (Parent (Parent (Inst_Par)));
5150 elsif Ekind (Inst_Par) = E_Generic_Package
5151 and then Nkind (Parent (Gen_Id)) = N_Formal_Package_Declaration
5153 -- A formal package may be a real child package, and not the
5154 -- implicit instance within a parent. In this case the child is
5155 -- not visible and has to be retrieved explicitly as well.
5157 Gen_Par := Inst_Par;
5160 if Present (Gen_Par) then
5162 -- The prefix denotes an instantiation. The entity itself may be a
5163 -- nested generic, or a child unit.
5165 E := Find_Generic_Child (Gen_Par, S);
5168 Change_Selected_Component_To_Expanded_Name (Gen_Id);
5169 Set_Entity (Gen_Id, E);
5170 Set_Etype (Gen_Id, Etype (E));
5172 Set_Etype (S, Etype (E));
5174 -- Indicate that this is a reference to the parent
5176 if In_Extended_Main_Source_Unit (Gen_Id) then
5177 Set_Is_Instantiated (Inst_Par);
5180 -- A common mistake is to replicate the naming scheme of a
5181 -- hierarchy by instantiating a generic child directly, rather
5182 -- than the implicit child in a parent instance:
5184 -- generic .. package Gpar is ..
5185 -- generic .. package Gpar.Child is ..
5186 -- package Par is new Gpar ();
5189 -- package Par.Child is new Gpar.Child ();
5190 -- rather than Par.Child
5192 -- In this case the instantiation is within Par, which is an
5193 -- instance, but Gpar does not denote Par because we are not IN
5194 -- the instance of Gpar, so this is illegal. The test below
5195 -- recognizes this particular case.
5197 if Is_Child_Unit (E)
5198 and then not Comes_From_Source (Entity (Prefix (Gen_Id)))
5199 and then (not In_Instance
5200 or else Nkind (Parent (Parent (Gen_Id))) =
5204 ("prefix of generic child unit must be instance of parent",
5208 if not In_Open_Scopes (Inst_Par)
5209 and then Nkind (Parent (Gen_Id)) not in
5210 N_Generic_Renaming_Declaration
5212 Install_Parent (Inst_Par);
5213 Parent_Installed := True;
5215 elsif In_Open_Scopes (Inst_Par) then
5217 -- If the parent is already installed verify that the
5218 -- actuals for its formal packages declared with a box
5219 -- are already installed. This is necessary when the
5220 -- child instance is a child of the parent instance.
5221 -- In this case the parent is placed on the scope stack
5222 -- but the formal packages are not made visible.
5224 Install_Formal_Packages (Inst_Par);
5228 -- If the generic parent does not contain an entity that
5229 -- corresponds to the selector, the instance doesn't either.
5230 -- Analyzing the node will yield the appropriate error message.
5231 -- If the entity is not a child unit, then it is an inner
5232 -- generic in the parent.
5240 if Is_Child_Unit (Entity (Gen_Id))
5242 Nkind (Parent (Gen_Id)) not in N_Generic_Renaming_Declaration
5243 and then not In_Open_Scopes (Inst_Par)
5245 Install_Parent (Inst_Par);
5246 Parent_Installed := True;
5250 elsif Nkind (Gen_Id) = N_Expanded_Name then
5252 -- Entity already present, analyze prefix, whose meaning may be
5253 -- an instance in the current context. If it is an instance of
5254 -- a relative within another, the proper parent may still have
5255 -- to be installed, if they are not of the same generation.
5257 Analyze (Prefix (Gen_Id));
5259 -- In the unlikely case that a local declaration hides the name
5260 -- of the parent package, locate it on the homonym chain. If the
5261 -- context is an instance of the parent, the renaming entity is
5264 Inst_Par := Entity (Prefix (Gen_Id));
5265 while Present (Inst_Par)
5266 and then not Is_Package_Or_Generic_Package (Inst_Par)
5268 Inst_Par := Homonym (Inst_Par);
5271 pragma Assert (Present (Inst_Par));
5272 Set_Entity (Prefix (Gen_Id), Inst_Par);
5274 if In_Enclosing_Instance then
5277 elsif Present (Entity (Gen_Id))
5278 and then Is_Child_Unit (Entity (Gen_Id))
5279 and then not In_Open_Scopes (Inst_Par)
5281 Install_Parent (Inst_Par);
5282 Parent_Installed := True;
5285 elsif In_Enclosing_Instance then
5287 -- The child unit is found in some enclosing scope
5294 -- If this is the renaming of the implicit child in a parent
5295 -- instance, recover the parent name and install it.
5297 if Is_Entity_Name (Gen_Id) then
5298 E := Entity (Gen_Id);
5300 if Is_Generic_Unit (E)
5301 and then Nkind (Parent (E)) in N_Generic_Renaming_Declaration
5302 and then Is_Child_Unit (Renamed_Object (E))
5303 and then Is_Generic_Unit (Scope (Renamed_Object (E)))
5304 and then Nkind (Name (Parent (E))) = N_Expanded_Name
5307 New_Copy_Tree (Name (Parent (E))));
5308 Inst_Par := Entity (Prefix (Gen_Id));
5310 if not In_Open_Scopes (Inst_Par) then
5311 Install_Parent (Inst_Par);
5312 Parent_Installed := True;
5315 -- If it is a child unit of a non-generic parent, it may be
5316 -- use-visible and given by a direct name. Install parent as
5319 elsif Is_Generic_Unit (E)
5320 and then Is_Child_Unit (E)
5322 Nkind (Parent (Gen_Id)) not in N_Generic_Renaming_Declaration
5323 and then not Is_Generic_Unit (Scope (E))
5325 if not In_Open_Scopes (Scope (E)) then
5326 Install_Parent (Scope (E));
5327 Parent_Installed := True;
5332 end Check_Generic_Child_Unit;
5334 -----------------------------
5335 -- Check_Hidden_Child_Unit --
5336 -----------------------------
5338 procedure Check_Hidden_Child_Unit
5340 Gen_Unit : Entity_Id;
5341 Act_Decl_Id : Entity_Id)
5343 Gen_Id : constant Node_Id := Name (N);
5346 if Is_Child_Unit (Gen_Unit)
5347 and then Is_Child_Unit (Act_Decl_Id)
5348 and then Nkind (Gen_Id) = N_Expanded_Name
5349 and then Entity (Prefix (Gen_Id)) = Scope (Act_Decl_Id)
5350 and then Chars (Gen_Unit) = Chars (Act_Decl_Id)
5352 Error_Msg_Node_2 := Scope (Act_Decl_Id);
5354 ("generic unit & is implicitly declared in &",
5355 Defining_Unit_Name (N), Gen_Unit);
5356 Error_Msg_N ("\instance must have different name",
5357 Defining_Unit_Name (N));
5359 end Check_Hidden_Child_Unit;
5361 ------------------------
5362 -- Check_Private_View --
5363 ------------------------
5365 procedure Check_Private_View (N : Node_Id) is
5366 T : constant Entity_Id := Etype (N);
5370 -- Exchange views if the type was not private in the generic but is
5371 -- private at the point of instantiation. Do not exchange views if
5372 -- the scope of the type is in scope. This can happen if both generic
5373 -- and instance are sibling units, or if type is defined in a parent.
5374 -- In this case the visibility of the type will be correct for all
5378 BT := Base_Type (T);
5380 if Is_Private_Type (T)
5381 and then not Has_Private_View (N)
5382 and then Present (Full_View (T))
5383 and then not In_Open_Scopes (Scope (T))
5385 -- In the generic, the full type was visible. Save the private
5386 -- entity, for subsequent exchange.
5390 elsif Has_Private_View (N)
5391 and then not Is_Private_Type (T)
5392 and then not Has_Been_Exchanged (T)
5393 and then Etype (Get_Associated_Node (N)) /= T
5395 -- Only the private declaration was visible in the generic. If
5396 -- the type appears in a subtype declaration, the subtype in the
5397 -- instance must have a view compatible with that of its parent,
5398 -- which must be exchanged (see corresponding code in Restore_
5399 -- Private_Views). Otherwise, if the type is defined in a parent
5400 -- unit, leave full visibility within instance, which is safe.
5402 if In_Open_Scopes (Scope (Base_Type (T)))
5403 and then not Is_Private_Type (Base_Type (T))
5404 and then Comes_From_Source (Base_Type (T))
5408 elsif Nkind (Parent (N)) = N_Subtype_Declaration
5409 or else not In_Private_Part (Scope (Base_Type (T)))
5411 Prepend_Elmt (T, Exchanged_Views);
5412 Exchange_Declarations (Etype (Get_Associated_Node (N)));
5415 -- For composite types with inconsistent representation exchange
5416 -- component types accordingly.
5418 elsif Is_Access_Type (T)
5419 and then Is_Private_Type (Designated_Type (T))
5420 and then not Has_Private_View (N)
5421 and then Present (Full_View (Designated_Type (T)))
5423 Switch_View (Designated_Type (T));
5425 elsif Is_Array_Type (T) then
5426 if Is_Private_Type (Component_Type (T))
5427 and then not Has_Private_View (N)
5428 and then Present (Full_View (Component_Type (T)))
5430 Switch_View (Component_Type (T));
5433 -- The normal exchange mechanism relies on the setting of a
5434 -- flag on the reference in the generic. However, an additional
5435 -- mechanism is needed for types that are not explicitly mentioned
5436 -- in the generic, but may be needed in expanded code in the
5437 -- instance. This includes component types of arrays and
5438 -- designated types of access types. This processing must also
5439 -- include the index types of arrays which we take care of here.
5446 Indx := First_Index (T);
5447 Typ := Base_Type (Etype (Indx));
5448 while Present (Indx) loop
5449 if Is_Private_Type (Typ)
5450 and then Present (Full_View (Typ))
5459 elsif Is_Private_Type (T)
5460 and then Present (Full_View (T))
5461 and then Is_Array_Type (Full_View (T))
5462 and then Is_Private_Type (Component_Type (Full_View (T)))
5466 -- Finally, a non-private subtype may have a private base type, which
5467 -- must be exchanged for consistency. This can happen when a package
5468 -- body is instantiated, when the scope stack is empty but in fact
5469 -- the subtype and the base type are declared in an enclosing scope.
5471 -- Note that in this case we introduce an inconsistency in the view
5472 -- set, because we switch the base type BT, but there could be some
5473 -- private dependent subtypes of BT which remain unswitched. Such
5474 -- subtypes might need to be switched at a later point (see specific
5475 -- provision for that case in Switch_View).
5477 elsif not Is_Private_Type (T)
5478 and then not Has_Private_View (N)
5479 and then Is_Private_Type (BT)
5480 and then Present (Full_View (BT))
5481 and then not Is_Generic_Type (BT)
5482 and then not In_Open_Scopes (BT)
5484 Prepend_Elmt (Full_View (BT), Exchanged_Views);
5485 Exchange_Declarations (BT);
5488 end Check_Private_View;
5490 --------------------------
5491 -- Contains_Instance_Of --
5492 --------------------------
5494 function Contains_Instance_Of
5497 N : Node_Id) return Boolean
5505 -- Verify that there are no circular instantiations. We check whether
5506 -- the unit contains an instance of the current scope or some enclosing
5507 -- scope (in case one of the instances appears in a subunit). Longer
5508 -- circularities involving subunits might seem too pathological to
5509 -- consider, but they were not too pathological for the authors of
5510 -- DEC bc30vsq, so we loop over all enclosing scopes, and mark all
5511 -- enclosing generic scopes as containing an instance.
5514 -- Within a generic subprogram body, the scope is not generic, to
5515 -- allow for recursive subprograms. Use the declaration to determine
5516 -- whether this is a generic unit.
5518 if Ekind (Scop) = E_Generic_Package
5519 or else (Is_Subprogram (Scop)
5520 and then Nkind (Unit_Declaration_Node (Scop)) =
5521 N_Generic_Subprogram_Declaration)
5523 Elmt := First_Elmt (Inner_Instances (Inner));
5525 while Present (Elmt) loop
5526 if Node (Elmt) = Scop then
5527 Error_Msg_Node_2 := Inner;
5529 ("circular Instantiation: & instantiated within &!",
5533 elsif Node (Elmt) = Inner then
5536 elsif Contains_Instance_Of (Node (Elmt), Scop, N) then
5537 Error_Msg_Node_2 := Inner;
5539 ("circular Instantiation: & instantiated within &!",
5547 -- Indicate that Inner is being instantiated within Scop
5549 Append_Elmt (Inner, Inner_Instances (Scop));
5552 if Scop = Standard_Standard then
5555 Scop := Scope (Scop);
5560 end Contains_Instance_Of;
5562 -----------------------
5563 -- Copy_Generic_Node --
5564 -----------------------
5566 function Copy_Generic_Node
5568 Parent_Id : Node_Id;
5569 Instantiating : Boolean) return Node_Id
5574 function Copy_Generic_Descendant (D : Union_Id) return Union_Id;
5575 -- Check the given value of one of the Fields referenced by the
5576 -- current node to determine whether to copy it recursively. The
5577 -- field may hold a Node_Id, a List_Id, or an Elist_Id, or a plain
5578 -- value (Sloc, Uint, Char) in which case it need not be copied.
5580 procedure Copy_Descendants;
5581 -- Common utility for various nodes
5583 function Copy_Generic_Elist (E : Elist_Id) return Elist_Id;
5584 -- Make copy of element list
5586 function Copy_Generic_List
5588 Parent_Id : Node_Id) return List_Id;
5589 -- Apply Copy_Node recursively to the members of a node list
5591 function In_Defining_Unit_Name (Nam : Node_Id) return Boolean;
5592 -- True if an identifier is part of the defining program unit name
5593 -- of a child unit. The entity of such an identifier must be kept
5594 -- (for ASIS use) even though as the name of an enclosing generic
5595 -- it would otherwise not be preserved in the generic tree.
5597 ----------------------
5598 -- Copy_Descendants --
5599 ----------------------
5601 procedure Copy_Descendants is
5603 use Atree.Unchecked_Access;
5604 -- This code section is part of the implementation of an untyped
5605 -- tree traversal, so it needs direct access to node fields.
5608 Set_Field1 (New_N, Copy_Generic_Descendant (Field1 (N)));
5609 Set_Field2 (New_N, Copy_Generic_Descendant (Field2 (N)));
5610 Set_Field3 (New_N, Copy_Generic_Descendant (Field3 (N)));
5611 Set_Field4 (New_N, Copy_Generic_Descendant (Field4 (N)));
5612 Set_Field5 (New_N, Copy_Generic_Descendant (Field5 (N)));
5613 end Copy_Descendants;
5615 -----------------------------
5616 -- Copy_Generic_Descendant --
5617 -----------------------------
5619 function Copy_Generic_Descendant (D : Union_Id) return Union_Id is
5621 if D = Union_Id (Empty) then
5624 elsif D in Node_Range then
5626 (Copy_Generic_Node (Node_Id (D), New_N, Instantiating));
5628 elsif D in List_Range then
5629 return Union_Id (Copy_Generic_List (List_Id (D), New_N));
5631 elsif D in Elist_Range then
5632 return Union_Id (Copy_Generic_Elist (Elist_Id (D)));
5634 -- Nothing else is copyable (e.g. Uint values), return as is
5639 end Copy_Generic_Descendant;
5641 ------------------------
5642 -- Copy_Generic_Elist --
5643 ------------------------
5645 function Copy_Generic_Elist (E : Elist_Id) return Elist_Id is
5652 M := First_Elmt (E);
5653 while Present (M) loop
5655 (Copy_Generic_Node (Node (M), Empty, Instantiating), L);
5664 end Copy_Generic_Elist;
5666 -----------------------
5667 -- Copy_Generic_List --
5668 -----------------------
5670 function Copy_Generic_List
5672 Parent_Id : Node_Id) return List_Id
5680 Set_Parent (New_L, Parent_Id);
5683 while Present (N) loop
5684 Append (Copy_Generic_Node (N, Empty, Instantiating), New_L);
5693 end Copy_Generic_List;
5695 ---------------------------
5696 -- In_Defining_Unit_Name --
5697 ---------------------------
5699 function In_Defining_Unit_Name (Nam : Node_Id) return Boolean is
5701 return Present (Parent (Nam))
5702 and then (Nkind (Parent (Nam)) = N_Defining_Program_Unit_Name
5704 (Nkind (Parent (Nam)) = N_Expanded_Name
5705 and then In_Defining_Unit_Name (Parent (Nam))));
5706 end In_Defining_Unit_Name;
5708 -- Start of processing for Copy_Generic_Node
5715 New_N := New_Copy (N);
5717 if Instantiating then
5718 Adjust_Instantiation_Sloc (New_N, S_Adjustment);
5721 if not Is_List_Member (N) then
5722 Set_Parent (New_N, Parent_Id);
5725 -- If defining identifier, then all fields have been copied already
5727 if Nkind (New_N) in N_Entity then
5730 -- Special casing for identifiers and other entity names and operators
5732 elsif Nkind_In (New_N, N_Identifier,
5733 N_Character_Literal,
5736 or else Nkind (New_N) in N_Op
5738 if not Instantiating then
5740 -- Link both nodes in order to assign subsequently the
5741 -- entity of the copy to the original node, in case this
5742 -- is a global reference.
5744 Set_Associated_Node (N, New_N);
5746 -- If we are within an instantiation, this is a nested generic
5747 -- that has already been analyzed at the point of definition. We
5748 -- must preserve references that were global to the enclosing
5749 -- parent at that point. Other occurrences, whether global or
5750 -- local to the current generic, must be resolved anew, so we
5751 -- reset the entity in the generic copy. A global reference has a
5752 -- smaller depth than the parent, or else the same depth in case
5753 -- both are distinct compilation units.
5754 -- A child unit is implicitly declared within the enclosing parent
5755 -- but is in fact global to it, and must be preserved.
5757 -- It is also possible for Current_Instantiated_Parent to be
5758 -- defined, and for this not to be a nested generic, namely if the
5759 -- unit is loaded through Rtsfind. In that case, the entity of
5760 -- New_N is only a link to the associated node, and not a defining
5763 -- The entities for parent units in the defining_program_unit of a
5764 -- generic child unit are established when the context of the unit
5765 -- is first analyzed, before the generic copy is made. They are
5766 -- preserved in the copy for use in ASIS queries.
5768 Ent := Entity (New_N);
5770 if No (Current_Instantiated_Parent.Gen_Id) then
5772 or else Nkind (Ent) /= N_Defining_Identifier
5773 or else not In_Defining_Unit_Name (N)
5775 Set_Associated_Node (New_N, Empty);
5780 not Nkind_In (Ent, N_Defining_Identifier,
5781 N_Defining_Character_Literal,
5782 N_Defining_Operator_Symbol)
5783 or else No (Scope (Ent))
5785 (Scope (Ent) = Current_Instantiated_Parent.Gen_Id
5786 and then not Is_Child_Unit (Ent))
5788 (Scope_Depth (Scope (Ent)) >
5789 Scope_Depth (Current_Instantiated_Parent.Gen_Id)
5791 Get_Source_Unit (Ent) =
5792 Get_Source_Unit (Current_Instantiated_Parent.Gen_Id))
5794 Set_Associated_Node (New_N, Empty);
5797 -- Case of instantiating identifier or some other name or operator
5800 -- If the associated node is still defined, the entity in it is
5801 -- global, and must be copied to the instance. If this copy is
5802 -- being made for a body to inline, it is applied to an
5803 -- instantiated tree, and the entity is already present and must
5804 -- be also preserved.
5807 Assoc : constant Node_Id := Get_Associated_Node (N);
5810 if Present (Assoc) then
5811 if Nkind (Assoc) = Nkind (N) then
5812 Set_Entity (New_N, Entity (Assoc));
5813 Check_Private_View (N);
5815 elsif Nkind (Assoc) = N_Function_Call then
5816 Set_Entity (New_N, Entity (Name (Assoc)));
5818 elsif Nkind_In (Assoc, N_Defining_Identifier,
5819 N_Defining_Character_Literal,
5820 N_Defining_Operator_Symbol)
5821 and then Expander_Active
5823 -- Inlining case: we are copying a tree that contains
5824 -- global entities, which are preserved in the copy to be
5825 -- used for subsequent inlining.
5830 Set_Entity (New_N, Empty);
5836 -- For expanded name, we must copy the Prefix and Selector_Name
5838 if Nkind (N) = N_Expanded_Name then
5840 (New_N, Copy_Generic_Node (Prefix (N), New_N, Instantiating));
5842 Set_Selector_Name (New_N,
5843 Copy_Generic_Node (Selector_Name (N), New_N, Instantiating));
5845 -- For operators, we must copy the right operand
5847 elsif Nkind (N) in N_Op then
5848 Set_Right_Opnd (New_N,
5849 Copy_Generic_Node (Right_Opnd (N), New_N, Instantiating));
5851 -- And for binary operators, the left operand as well
5853 if Nkind (N) in N_Binary_Op then
5854 Set_Left_Opnd (New_N,
5855 Copy_Generic_Node (Left_Opnd (N), New_N, Instantiating));
5859 -- Special casing for stubs
5861 elsif Nkind (N) in N_Body_Stub then
5863 -- In any case, we must copy the specification or defining
5864 -- identifier as appropriate.
5866 if Nkind (N) = N_Subprogram_Body_Stub then
5867 Set_Specification (New_N,
5868 Copy_Generic_Node (Specification (N), New_N, Instantiating));
5871 Set_Defining_Identifier (New_N,
5873 (Defining_Identifier (N), New_N, Instantiating));
5876 -- If we are not instantiating, then this is where we load and
5877 -- analyze subunits, i.e. at the point where the stub occurs. A
5878 -- more permissible system might defer this analysis to the point
5879 -- of instantiation, but this seems to complicated for now.
5881 if not Instantiating then
5883 Subunit_Name : constant Unit_Name_Type := Get_Unit_Name (N);
5885 Unum : Unit_Number_Type;
5891 (Load_Name => Subunit_Name,
5896 -- If the proper body is not found, a warning message will be
5897 -- emitted when analyzing the stub, or later at the point
5898 -- of instantiation. Here we just leave the stub as is.
5900 if Unum = No_Unit then
5901 Subunits_Missing := True;
5902 goto Subunit_Not_Found;
5905 Subunit := Cunit (Unum);
5907 if Nkind (Unit (Subunit)) /= N_Subunit then
5909 ("found child unit instead of expected SEPARATE subunit",
5911 Error_Msg_Sloc := Sloc (N);
5912 Error_Msg_N ("\to complete stub #", Subunit);
5913 goto Subunit_Not_Found;
5916 -- We must create a generic copy of the subunit, in order to
5917 -- perform semantic analysis on it, and we must replace the
5918 -- stub in the original generic unit with the subunit, in order
5919 -- to preserve non-local references within.
5921 -- Only the proper body needs to be copied. Library_Unit and
5922 -- context clause are simply inherited by the generic copy.
5923 -- Note that the copy (which may be recursive if there are
5924 -- nested subunits) must be done first, before attaching it to
5925 -- the enclosing generic.
5929 (Proper_Body (Unit (Subunit)),
5930 Empty, Instantiating => False);
5932 -- Now place the original proper body in the original generic
5933 -- unit. This is a body, not a compilation unit.
5935 Rewrite (N, Proper_Body (Unit (Subunit)));
5936 Set_Is_Compilation_Unit (Defining_Entity (N), False);
5937 Set_Was_Originally_Stub (N);
5939 -- Finally replace the body of the subunit with its copy, and
5940 -- make this new subunit into the library unit of the generic
5941 -- copy, which does not have stubs any longer.
5943 Set_Proper_Body (Unit (Subunit), New_Body);
5944 Set_Library_Unit (New_N, Subunit);
5945 Inherit_Context (Unit (Subunit), N);
5948 -- If we are instantiating, this must be an error case, since
5949 -- otherwise we would have replaced the stub node by the proper body
5950 -- that corresponds. So just ignore it in the copy (i.e. we have
5951 -- copied it, and that is good enough).
5957 <<Subunit_Not_Found>> null;
5959 -- If the node is a compilation unit, it is the subunit of a stub, which
5960 -- has been loaded already (see code below). In this case, the library
5961 -- unit field of N points to the parent unit (which is a compilation
5962 -- unit) and need not (and cannot!) be copied.
5964 -- When the proper body of the stub is analyzed, the library_unit link
5965 -- is used to establish the proper context (see sem_ch10).
5967 -- The other fields of a compilation unit are copied as usual
5969 elsif Nkind (N) = N_Compilation_Unit then
5971 -- This code can only be executed when not instantiating, because in
5972 -- the copy made for an instantiation, the compilation unit node has
5973 -- disappeared at the point that a stub is replaced by its proper
5976 pragma Assert (not Instantiating);
5978 Set_Context_Items (New_N,
5979 Copy_Generic_List (Context_Items (N), New_N));
5982 Copy_Generic_Node (Unit (N), New_N, False));
5984 Set_First_Inlined_Subprogram (New_N,
5986 (First_Inlined_Subprogram (N), New_N, False));
5988 Set_Aux_Decls_Node (New_N,
5989 Copy_Generic_Node (Aux_Decls_Node (N), New_N, False));
5991 -- For an assignment node, the assignment is known to be semantically
5992 -- legal if we are instantiating the template. This avoids incorrect
5993 -- diagnostics in generated code.
5995 elsif Nkind (N) = N_Assignment_Statement then
5997 -- Copy name and expression fields in usual manner
6000 Copy_Generic_Node (Name (N), New_N, Instantiating));
6002 Set_Expression (New_N,
6003 Copy_Generic_Node (Expression (N), New_N, Instantiating));
6005 if Instantiating then
6006 Set_Assignment_OK (Name (New_N), True);
6009 elsif Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then
6010 if not Instantiating then
6011 Set_Associated_Node (N, New_N);
6014 if Present (Get_Associated_Node (N))
6015 and then Nkind (Get_Associated_Node (N)) = Nkind (N)
6017 -- In the generic the aggregate has some composite type. If at
6018 -- the point of instantiation the type has a private view,
6019 -- install the full view (and that of its ancestors, if any).
6022 T : Entity_Id := (Etype (Get_Associated_Node (New_N)));
6027 and then Is_Private_Type (T)
6033 and then Is_Tagged_Type (T)
6034 and then Is_Derived_Type (T)
6036 Rt := Root_Type (T);
6041 if Is_Private_Type (T) then
6052 -- Do not copy the associated node, which points to
6053 -- the generic copy of the aggregate.
6056 use Atree.Unchecked_Access;
6057 -- This code section is part of the implementation of an untyped
6058 -- tree traversal, so it needs direct access to node fields.
6061 Set_Field1 (New_N, Copy_Generic_Descendant (Field1 (N)));
6062 Set_Field2 (New_N, Copy_Generic_Descendant (Field2 (N)));
6063 Set_Field3 (New_N, Copy_Generic_Descendant (Field3 (N)));
6064 Set_Field5 (New_N, Copy_Generic_Descendant (Field5 (N)));
6067 -- Allocators do not have an identifier denoting the access type,
6068 -- so we must locate it through the expression to check whether
6069 -- the views are consistent.
6071 elsif Nkind (N) = N_Allocator
6072 and then Nkind (Expression (N)) = N_Qualified_Expression
6073 and then Is_Entity_Name (Subtype_Mark (Expression (N)))
6074 and then Instantiating
6077 T : constant Node_Id :=
6078 Get_Associated_Node (Subtype_Mark (Expression (N)));
6084 -- Retrieve the allocator node in the generic copy
6086 Acc_T := Etype (Parent (Parent (T)));
6088 and then Is_Private_Type (Acc_T)
6090 Switch_View (Acc_T);
6097 -- For a proper body, we must catch the case of a proper body that
6098 -- replaces a stub. This represents the point at which a separate
6099 -- compilation unit, and hence template file, may be referenced, so we
6100 -- must make a new source instantiation entry for the template of the
6101 -- subunit, and ensure that all nodes in the subunit are adjusted using
6102 -- this new source instantiation entry.
6104 elsif Nkind (N) in N_Proper_Body then
6106 Save_Adjustment : constant Sloc_Adjustment := S_Adjustment;
6109 if Instantiating and then Was_Originally_Stub (N) then
6110 Create_Instantiation_Source
6111 (Instantiation_Node,
6112 Defining_Entity (N),
6117 -- Now copy the fields of the proper body, using the new
6118 -- adjustment factor if one was needed as per test above.
6122 -- Restore the original adjustment factor in case changed
6124 S_Adjustment := Save_Adjustment;
6127 -- Don't copy Ident or Comment pragmas, since the comment belongs to the
6128 -- generic unit, not to the instantiating unit.
6130 elsif Nkind (N) = N_Pragma
6131 and then Instantiating
6134 Prag_Id : constant Pragma_Id := Get_Pragma_Id (N);
6136 if Prag_Id = Pragma_Ident
6137 or else Prag_Id = Pragma_Comment
6139 New_N := Make_Null_Statement (Sloc (N));
6145 elsif Nkind_In (N, N_Integer_Literal,
6149 -- No descendant fields need traversing
6153 -- For the remaining nodes, copy recursively their descendants
6159 and then Nkind (N) = N_Subprogram_Body
6161 Set_Generic_Parent (Specification (New_N), N);
6166 end Copy_Generic_Node;
6168 ----------------------------
6169 -- Denotes_Formal_Package --
6170 ----------------------------
6172 function Denotes_Formal_Package
6174 On_Exit : Boolean := False;
6175 Instance : Entity_Id := Empty) return Boolean
6178 Scop : constant Entity_Id := Scope (Pack);
6181 function Is_Actual_Of_Previous_Formal (P : Entity_Id) return Boolean;
6182 -- The package in question may be an actual for a previous formal
6183 -- package P of the current instance, so examine its actuals as well.
6184 -- This must be recursive over other formal packages.
6186 ----------------------------------
6187 -- Is_Actual_Of_Previous_Formal --
6188 ----------------------------------
6190 function Is_Actual_Of_Previous_Formal (P : Entity_Id) return Boolean is
6194 E1 := First_Entity (P);
6195 while Present (E1) and then E1 /= Instance loop
6196 if Ekind (E1) = E_Package
6197 and then Nkind (Parent (E1)) = N_Package_Renaming_Declaration
6199 if Renamed_Object (E1) = Pack then
6203 or else Renamed_Object (E1) = P
6207 elsif Is_Actual_Of_Previous_Formal (E1) then
6216 end Is_Actual_Of_Previous_Formal;
6218 -- Start of processing for Denotes_Formal_Package
6224 (Instance_Envs.Last).Instantiated_Parent.Act_Id;
6226 Par := Current_Instantiated_Parent.Act_Id;
6229 if Ekind (Scop) = E_Generic_Package
6230 or else Nkind (Unit_Declaration_Node (Scop)) =
6231 N_Generic_Subprogram_Declaration
6235 elsif Nkind (Original_Node (Unit_Declaration_Node (Pack))) =
6236 N_Formal_Package_Declaration
6244 -- Check whether this package is associated with a formal package of
6245 -- the enclosing instantiation. Iterate over the list of renamings.
6247 E := First_Entity (Par);
6248 while Present (E) loop
6249 if Ekind (E) /= E_Package
6250 or else Nkind (Parent (E)) /= N_Package_Renaming_Declaration
6254 elsif Renamed_Object (E) = Par then
6257 elsif Renamed_Object (E) = Pack then
6260 elsif Is_Actual_Of_Previous_Formal (E) then
6270 end Denotes_Formal_Package;
6276 procedure End_Generic is
6278 -- ??? More things could be factored out in this routine. Should
6279 -- probably be done at a later stage.
6281 Inside_A_Generic := Generic_Flags.Table (Generic_Flags.Last);
6282 Generic_Flags.Decrement_Last;
6284 Expander_Mode_Restore;
6287 ----------------------
6288 -- Find_Actual_Type --
6289 ----------------------
6291 function Find_Actual_Type
6293 Gen_Type : Entity_Id) return Entity_Id
6295 Gen_Scope : constant Entity_Id := Scope (Gen_Type);
6299 -- Special processing only applies to child units
6301 if not Is_Child_Unit (Gen_Scope) then
6302 return Get_Instance_Of (Typ);
6304 -- If designated or component type is itself a formal of the child unit,
6305 -- its instance is available.
6307 elsif Scope (Typ) = Gen_Scope then
6308 return Get_Instance_Of (Typ);
6310 -- If the array or access type is not declared in the parent unit,
6311 -- no special processing needed.
6313 elsif not Is_Generic_Type (Typ)
6314 and then Scope (Gen_Scope) /= Scope (Typ)
6316 return Get_Instance_Of (Typ);
6318 -- Otherwise, retrieve designated or component type by visibility
6321 T := Current_Entity (Typ);
6322 while Present (T) loop
6323 if In_Open_Scopes (Scope (T)) then
6326 elsif Is_Generic_Actual_Type (T) then
6335 end Find_Actual_Type;
6337 ----------------------------
6338 -- Freeze_Subprogram_Body --
6339 ----------------------------
6341 procedure Freeze_Subprogram_Body
6342 (Inst_Node : Node_Id;
6344 Pack_Id : Entity_Id)
6347 Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node);
6348 Par : constant Entity_Id := Scope (Gen_Unit);
6353 function Earlier (N1, N2 : Node_Id) return Boolean;
6354 -- Yields True if N1 and N2 appear in the same compilation unit,
6355 -- ignoring subunits, and if N1 is to the left of N2 in a left-to-right
6356 -- traversal of the tree for the unit.
6358 function Enclosing_Body (N : Node_Id) return Node_Id;
6359 -- Find innermost package body that encloses the given node, and which
6360 -- is not a compilation unit. Freeze nodes for the instance, or for its
6361 -- enclosing body, may be inserted after the enclosing_body of the
6364 function Package_Freeze_Node (B : Node_Id) return Node_Id;
6365 -- Find entity for given package body, and locate or create a freeze
6368 function True_Parent (N : Node_Id) return Node_Id;
6369 -- For a subunit, return parent of corresponding stub
6375 function Earlier (N1, N2 : Node_Id) return Boolean is
6381 procedure Find_Depth (P : in out Node_Id; D : in out Integer);
6382 -- Find distance from given node to enclosing compilation unit
6388 procedure Find_Depth (P : in out Node_Id; D : in out Integer) is
6391 and then Nkind (P) /= N_Compilation_Unit
6393 P := True_Parent (P);
6398 -- Start of processing for Earlier
6401 Find_Depth (P1, D1);
6402 Find_Depth (P2, D2);
6412 P1 := True_Parent (P1);
6417 P2 := True_Parent (P2);
6421 -- At this point P1 and P2 are at the same distance from the root.
6422 -- We examine their parents until we find a common declarative
6423 -- list, at which point we can establish their relative placement
6424 -- by comparing their ultimate slocs. If we reach the root,
6425 -- N1 and N2 do not descend from the same declarative list (e.g.
6426 -- one is nested in the declarative part and the other is in a block
6427 -- in the statement part) and the earlier one is already frozen.
6429 while not Is_List_Member (P1)
6430 or else not Is_List_Member (P2)
6431 or else List_Containing (P1) /= List_Containing (P2)
6433 P1 := True_Parent (P1);
6434 P2 := True_Parent (P2);
6436 if Nkind (Parent (P1)) = N_Subunit then
6437 P1 := Corresponding_Stub (Parent (P1));
6440 if Nkind (Parent (P2)) = N_Subunit then
6441 P2 := Corresponding_Stub (Parent (P2));
6450 Top_Level_Location (Sloc (P1)) < Top_Level_Location (Sloc (P2));
6453 --------------------
6454 -- Enclosing_Body --
6455 --------------------
6457 function Enclosing_Body (N : Node_Id) return Node_Id is
6458 P : Node_Id := Parent (N);
6462 and then Nkind (Parent (P)) /= N_Compilation_Unit
6464 if Nkind (P) = N_Package_Body then
6466 if Nkind (Parent (P)) = N_Subunit then
6467 return Corresponding_Stub (Parent (P));
6473 P := True_Parent (P);
6479 -------------------------
6480 -- Package_Freeze_Node --
6481 -------------------------
6483 function Package_Freeze_Node (B : Node_Id) return Node_Id is
6487 if Nkind (B) = N_Package_Body then
6488 Id := Corresponding_Spec (B);
6490 else pragma Assert (Nkind (B) = N_Package_Body_Stub);
6491 Id := Corresponding_Spec (Proper_Body (Unit (Library_Unit (B))));
6494 Ensure_Freeze_Node (Id);
6495 return Freeze_Node (Id);
6496 end Package_Freeze_Node;
6502 function True_Parent (N : Node_Id) return Node_Id is
6504 if Nkind (Parent (N)) = N_Subunit then
6505 return Parent (Corresponding_Stub (Parent (N)));
6511 -- Start of processing of Freeze_Subprogram_Body
6514 -- If the instance and the generic body appear within the same unit, and
6515 -- the instance precedes the generic, the freeze node for the instance
6516 -- must appear after that of the generic. If the generic is nested
6517 -- within another instance I2, then current instance must be frozen
6518 -- after I2. In both cases, the freeze nodes are those of enclosing
6519 -- packages. Otherwise, the freeze node is placed at the end of the
6520 -- current declarative part.
6522 Enc_G := Enclosing_Body (Gen_Body);
6523 Enc_I := Enclosing_Body (Inst_Node);
6524 Ensure_Freeze_Node (Pack_Id);
6525 F_Node := Freeze_Node (Pack_Id);
6527 if Is_Generic_Instance (Par)
6528 and then Present (Freeze_Node (Par))
6530 In_Same_Declarative_Part (Freeze_Node (Par), Inst_Node)
6532 if ABE_Is_Certain (Get_Package_Instantiation_Node (Par)) then
6534 -- The parent was a premature instantiation. Insert freeze node at
6535 -- the end the current declarative part.
6537 Insert_After_Last_Decl (Inst_Node, F_Node);
6540 Insert_After (Freeze_Node (Par), F_Node);
6543 -- The body enclosing the instance should be frozen after the body that
6544 -- includes the generic, because the body of the instance may make
6545 -- references to entities therein. If the two are not in the same
6546 -- declarative part, or if the one enclosing the instance is frozen
6547 -- already, freeze the instance at the end of the current declarative
6550 elsif Is_Generic_Instance (Par)
6551 and then Present (Freeze_Node (Par))
6552 and then Present (Enc_I)
6554 if In_Same_Declarative_Part (Freeze_Node (Par), Enc_I)
6556 (Nkind (Enc_I) = N_Package_Body
6558 In_Same_Declarative_Part (Freeze_Node (Par), Parent (Enc_I)))
6560 -- The enclosing package may contain several instances. Rather
6561 -- than computing the earliest point at which to insert its
6562 -- freeze node, we place it at the end of the declarative part
6563 -- of the parent of the generic.
6565 Insert_After_Last_Decl
6566 (Freeze_Node (Par), Package_Freeze_Node (Enc_I));
6569 Insert_After_Last_Decl (Inst_Node, F_Node);
6571 elsif Present (Enc_G)
6572 and then Present (Enc_I)
6573 and then Enc_G /= Enc_I
6574 and then Earlier (Inst_Node, Gen_Body)
6576 if Nkind (Enc_G) = N_Package_Body then
6577 E_G_Id := Corresponding_Spec (Enc_G);
6578 else pragma Assert (Nkind (Enc_G) = N_Package_Body_Stub);
6580 Corresponding_Spec (Proper_Body (Unit (Library_Unit (Enc_G))));
6583 -- Freeze package that encloses instance, and place node after
6584 -- package that encloses generic. If enclosing package is already
6585 -- frozen we have to assume it is at the proper place. This may be
6586 -- a potential ABE that requires dynamic checking. Do not add a
6587 -- freeze node if the package that encloses the generic is inside
6588 -- the body that encloses the instance, because the freeze node
6589 -- would be in the wrong scope. Additional contortions needed if
6590 -- the bodies are within a subunit.
6593 Enclosing_Body : Node_Id;
6596 if Nkind (Enc_I) = N_Package_Body_Stub then
6597 Enclosing_Body := Proper_Body (Unit (Library_Unit (Enc_I)));
6599 Enclosing_Body := Enc_I;
6602 if Parent (List_Containing (Enc_G)) /= Enclosing_Body then
6603 Insert_After_Last_Decl (Enc_G, Package_Freeze_Node (Enc_I));
6607 -- Freeze enclosing subunit before instance
6609 Ensure_Freeze_Node (E_G_Id);
6611 if not Is_List_Member (Freeze_Node (E_G_Id)) then
6612 Insert_After (Enc_G, Freeze_Node (E_G_Id));
6615 Insert_After_Last_Decl (Inst_Node, F_Node);
6618 -- If none of the above, insert freeze node at the end of the current
6619 -- declarative part.
6621 Insert_After_Last_Decl (Inst_Node, F_Node);
6623 end Freeze_Subprogram_Body;
6629 function Get_Gen_Id (E : Assoc_Ptr) return Entity_Id is
6631 return Generic_Renamings.Table (E).Gen_Id;
6634 ---------------------
6635 -- Get_Instance_Of --
6636 ---------------------
6638 function Get_Instance_Of (A : Entity_Id) return Entity_Id is
6639 Res : constant Assoc_Ptr := Generic_Renamings_HTable.Get (A);
6642 if Res /= Assoc_Null then
6643 return Generic_Renamings.Table (Res).Act_Id;
6645 -- On exit, entity is not instantiated: not a generic parameter, or
6646 -- else parameter of an inner generic unit.
6650 end Get_Instance_Of;
6652 ------------------------------------
6653 -- Get_Package_Instantiation_Node --
6654 ------------------------------------
6656 function Get_Package_Instantiation_Node (A : Entity_Id) return Node_Id is
6657 Decl : Node_Id := Unit_Declaration_Node (A);
6661 -- If the Package_Instantiation attribute has been set on the package
6662 -- entity, then use it directly when it (or its Original_Node) refers
6663 -- to an N_Package_Instantiation node. In principle it should be
6664 -- possible to have this field set in all cases, which should be
6665 -- investigated, and would allow this function to be significantly
6668 if Present (Package_Instantiation (A)) then
6669 if Nkind (Package_Instantiation (A)) = N_Package_Instantiation then
6670 return Package_Instantiation (A);
6672 elsif Nkind (Original_Node (Package_Instantiation (A))) =
6673 N_Package_Instantiation
6675 return Original_Node (Package_Instantiation (A));
6679 -- If the instantiation is a compilation unit that does not need body
6680 -- then the instantiation node has been rewritten as a package
6681 -- declaration for the instance, and we return the original node.
6683 -- If it is a compilation unit and the instance node has not been
6684 -- rewritten, then it is still the unit of the compilation. Finally, if
6685 -- a body is present, this is a parent of the main unit whose body has
6686 -- been compiled for inlining purposes, and the instantiation node has
6687 -- been rewritten with the instance body.
6689 -- Otherwise the instantiation node appears after the declaration. If
6690 -- the entity is a formal package, the declaration may have been
6691 -- rewritten as a generic declaration (in the case of a formal with box)
6692 -- or left as a formal package declaration if it has actuals, and is
6693 -- found with a forward search.
6695 if Nkind (Parent (Decl)) = N_Compilation_Unit then
6696 if Nkind (Decl) = N_Package_Declaration
6697 and then Present (Corresponding_Body (Decl))
6699 Decl := Unit_Declaration_Node (Corresponding_Body (Decl));
6702 if Nkind (Original_Node (Decl)) = N_Package_Instantiation then
6703 return Original_Node (Decl);
6705 return Unit (Parent (Decl));
6708 elsif Nkind (Decl) = N_Package_Declaration
6709 and then Nkind (Original_Node (Decl)) = N_Formal_Package_Declaration
6711 return Original_Node (Decl);
6714 Inst := Next (Decl);
6715 while not Nkind_In (Inst, N_Package_Instantiation,
6716 N_Formal_Package_Declaration)
6723 end Get_Package_Instantiation_Node;
6725 ------------------------
6726 -- Has_Been_Exchanged --
6727 ------------------------
6729 function Has_Been_Exchanged (E : Entity_Id) return Boolean is
6733 Next := First_Elmt (Exchanged_Views);
6734 while Present (Next) loop
6735 if Full_View (Node (Next)) = E then
6743 end Has_Been_Exchanged;
6749 function Hash (F : Entity_Id) return HTable_Range is
6751 return HTable_Range (F mod HTable_Size);
6754 ------------------------
6755 -- Hide_Current_Scope --
6756 ------------------------
6758 procedure Hide_Current_Scope is
6759 C : constant Entity_Id := Current_Scope;
6763 Set_Is_Hidden_Open_Scope (C);
6765 E := First_Entity (C);
6766 while Present (E) loop
6767 if Is_Immediately_Visible (E) then
6768 Set_Is_Immediately_Visible (E, False);
6769 Append_Elmt (E, Hidden_Entities);
6775 -- Make the scope name invisible as well. This is necessary, but might
6776 -- conflict with calls to Rtsfind later on, in case the scope is a
6777 -- predefined one. There is no clean solution to this problem, so for
6778 -- now we depend on the user not redefining Standard itself in one of
6779 -- the parent units.
6781 if Is_Immediately_Visible (C)
6782 and then C /= Standard_Standard
6784 Set_Is_Immediately_Visible (C, False);
6785 Append_Elmt (C, Hidden_Entities);
6788 end Hide_Current_Scope;
6794 procedure Init_Env is
6795 Saved : Instance_Env;
6798 Saved.Instantiated_Parent := Current_Instantiated_Parent;
6799 Saved.Exchanged_Views := Exchanged_Views;
6800 Saved.Hidden_Entities := Hidden_Entities;
6801 Saved.Current_Sem_Unit := Current_Sem_Unit;
6802 Saved.Parent_Unit_Visible := Parent_Unit_Visible;
6803 Saved.Instance_Parent_Unit := Instance_Parent_Unit;
6805 -- Save configuration switches. These may be reset if the unit is a
6806 -- predefined unit, and the current mode is not Ada 2005.
6808 Save_Opt_Config_Switches (Saved.Switches);
6810 Instance_Envs.Append (Saved);
6812 Exchanged_Views := New_Elmt_List;
6813 Hidden_Entities := New_Elmt_List;
6815 -- Make dummy entry for Instantiated parent. If generic unit is legal,
6816 -- this is set properly in Set_Instance_Env.
6818 Current_Instantiated_Parent :=
6819 (Current_Scope, Current_Scope, Assoc_Null);
6822 ------------------------------
6823 -- In_Same_Declarative_Part --
6824 ------------------------------
6826 function In_Same_Declarative_Part
6828 Inst : Node_Id) return Boolean
6830 Decls : constant Node_Id := Parent (F_Node);
6831 Nod : Node_Id := Parent (Inst);
6834 while Present (Nod) loop
6838 elsif Nkind_In (Nod, N_Subprogram_Body,
6846 elsif Nkind (Nod) = N_Subunit then
6847 Nod := Corresponding_Stub (Nod);
6849 elsif Nkind (Nod) = N_Compilation_Unit then
6853 Nod := Parent (Nod);
6858 end In_Same_Declarative_Part;
6860 ---------------------
6861 -- In_Main_Context --
6862 ---------------------
6864 function In_Main_Context (E : Entity_Id) return Boolean is
6870 if not Is_Compilation_Unit (E)
6871 or else Ekind (E) /= E_Package
6872 or else In_Private_Part (E)
6877 Context := Context_Items (Cunit (Main_Unit));
6879 Clause := First (Context);
6880 while Present (Clause) loop
6881 if Nkind (Clause) = N_With_Clause then
6882 Nam := Name (Clause);
6884 -- If the current scope is part of the context of the main unit,
6885 -- analysis of the corresponding with_clause is not complete, and
6886 -- the entity is not set. We use the Chars field directly, which
6887 -- might produce false positives in rare cases, but guarantees
6888 -- that we produce all the instance bodies we will need.
6890 if (Is_Entity_Name (Nam)
6891 and then Chars (Nam) = Chars (E))
6892 or else (Nkind (Nam) = N_Selected_Component
6893 and then Chars (Selector_Name (Nam)) = Chars (E))
6903 end In_Main_Context;
6905 ---------------------
6906 -- Inherit_Context --
6907 ---------------------
6909 procedure Inherit_Context (Gen_Decl : Node_Id; Inst : Node_Id) is
6910 Current_Context : List_Id;
6911 Current_Unit : Node_Id;
6916 if Nkind (Parent (Gen_Decl)) = N_Compilation_Unit then
6918 -- The inherited context is attached to the enclosing compilation
6919 -- unit. This is either the main unit, or the declaration for the
6920 -- main unit (in case the instantiation appears within the package
6921 -- declaration and the main unit is its body).
6923 Current_Unit := Parent (Inst);
6924 while Present (Current_Unit)
6925 and then Nkind (Current_Unit) /= N_Compilation_Unit
6927 Current_Unit := Parent (Current_Unit);
6930 Current_Context := Context_Items (Current_Unit);
6932 Item := First (Context_Items (Parent (Gen_Decl)));
6933 while Present (Item) loop
6934 if Nkind (Item) = N_With_Clause then
6935 New_I := New_Copy (Item);
6936 Set_Implicit_With (New_I, True);
6937 Append (New_I, Current_Context);
6943 end Inherit_Context;
6949 procedure Initialize is
6951 Generic_Renamings.Init;
6954 Generic_Renamings_HTable.Reset;
6955 Circularity_Detected := False;
6956 Exchanged_Views := No_Elist;
6957 Hidden_Entities := No_Elist;
6960 ----------------------------
6961 -- Insert_After_Last_Decl --
6962 ----------------------------
6964 procedure Insert_After_Last_Decl (N : Node_Id; F_Node : Node_Id) is
6965 L : List_Id := List_Containing (N);
6966 P : constant Node_Id := Parent (L);
6969 if not Is_List_Member (F_Node) then
6970 if Nkind (P) = N_Package_Specification
6971 and then L = Visible_Declarations (P)
6972 and then Present (Private_Declarations (P))
6973 and then not Is_Empty_List (Private_Declarations (P))
6975 L := Private_Declarations (P);
6978 Insert_After (Last (L), F_Node);
6980 end Insert_After_Last_Decl;
6986 procedure Install_Body
6987 (Act_Body : Node_Id;
6992 Act_Id : constant Entity_Id := Corresponding_Spec (Act_Body);
6993 Act_Unit : constant Node_Id := Unit (Cunit (Get_Source_Unit (N)));
6994 Gen_Id : constant Entity_Id := Corresponding_Spec (Gen_Body);
6995 Par : constant Entity_Id := Scope (Gen_Id);
6996 Gen_Unit : constant Node_Id :=
6997 Unit (Cunit (Get_Source_Unit (Gen_Decl)));
6998 Orig_Body : Node_Id := Gen_Body;
7000 Body_Unit : Node_Id;
7002 Must_Delay : Boolean;
7004 function Enclosing_Subp (Id : Entity_Id) return Entity_Id;
7005 -- Find subprogram (if any) that encloses instance and/or generic body
7007 function True_Sloc (N : Node_Id) return Source_Ptr;
7008 -- If the instance is nested inside a generic unit, the Sloc of the
7009 -- instance indicates the place of the original definition, not the
7010 -- point of the current enclosing instance. Pending a better usage of
7011 -- Slocs to indicate instantiation places, we determine the place of
7012 -- origin of a node by finding the maximum sloc of any ancestor node.
7013 -- Why is this not equivalent to Top_Level_Location ???
7015 --------------------
7016 -- Enclosing_Subp --
7017 --------------------
7019 function Enclosing_Subp (Id : Entity_Id) return Entity_Id is
7020 Scop : Entity_Id := Scope (Id);
7023 while Scop /= Standard_Standard
7024 and then not Is_Overloadable (Scop)
7026 Scop := Scope (Scop);
7036 function True_Sloc (N : Node_Id) return Source_Ptr is
7043 while Present (N1) and then N1 /= Act_Unit loop
7044 if Sloc (N1) > Res then
7054 -- Start of processing for Install_Body
7058 -- If the body is a subunit, the freeze point is the corresponding
7059 -- stub in the current compilation, not the subunit itself.
7061 if Nkind (Parent (Gen_Body)) = N_Subunit then
7062 Orig_Body := Corresponding_Stub (Parent (Gen_Body));
7064 Orig_Body := Gen_Body;
7067 Body_Unit := Unit (Cunit (Get_Source_Unit (Orig_Body)));
7069 -- If the instantiation and the generic definition appear in the same
7070 -- package declaration, this is an early instantiation. If they appear
7071 -- in the same declarative part, it is an early instantiation only if
7072 -- the generic body appears textually later, and the generic body is
7073 -- also in the main unit.
7075 -- If instance is nested within a subprogram, and the generic body is
7076 -- not, the instance is delayed because the enclosing body is. If
7077 -- instance and body are within the same scope, or the same sub-
7078 -- program body, indicate explicitly that the instance is delayed.
7081 (Gen_Unit = Act_Unit
7082 and then (Nkind_In (Gen_Unit, N_Package_Declaration,
7083 N_Generic_Package_Declaration)
7084 or else (Gen_Unit = Body_Unit
7085 and then True_Sloc (N) < Sloc (Orig_Body)))
7086 and then Is_In_Main_Unit (Gen_Unit)
7087 and then (Scope (Act_Id) = Scope (Gen_Id)
7089 Enclosing_Subp (Act_Id) = Enclosing_Subp (Gen_Id)));
7091 -- If this is an early instantiation, the freeze node is placed after
7092 -- the generic body. Otherwise, if the generic appears in an instance,
7093 -- we cannot freeze the current instance until the outer one is frozen.
7094 -- This is only relevant if the current instance is nested within some
7095 -- inner scope not itself within the outer instance. If this scope is
7096 -- a package body in the same declarative part as the outer instance,
7097 -- then that body needs to be frozen after the outer instance. Finally,
7098 -- if no delay is needed, we place the freeze node at the end of the
7099 -- current declarative part.
7101 if Expander_Active then
7102 Ensure_Freeze_Node (Act_Id);
7103 F_Node := Freeze_Node (Act_Id);
7106 Insert_After (Orig_Body, F_Node);
7108 elsif Is_Generic_Instance (Par)
7109 and then Present (Freeze_Node (Par))
7110 and then Scope (Act_Id) /= Par
7112 -- Freeze instance of inner generic after instance of enclosing
7115 if In_Same_Declarative_Part (Freeze_Node (Par), N) then
7116 Insert_After (Freeze_Node (Par), F_Node);
7118 -- Freeze package enclosing instance of inner generic after
7119 -- instance of enclosing generic.
7121 elsif Nkind (Parent (N)) = N_Package_Body
7122 and then In_Same_Declarative_Part (Freeze_Node (Par), Parent (N))
7126 Enclosing : constant Entity_Id :=
7127 Corresponding_Spec (Parent (N));
7130 Insert_After_Last_Decl (N, F_Node);
7131 Ensure_Freeze_Node (Enclosing);
7133 if not Is_List_Member (Freeze_Node (Enclosing)) then
7134 Insert_After (Freeze_Node (Par), Freeze_Node (Enclosing));
7139 Insert_After_Last_Decl (N, F_Node);
7143 Insert_After_Last_Decl (N, F_Node);
7147 Set_Is_Frozen (Act_Id);
7148 Insert_Before (N, Act_Body);
7149 Mark_Rewrite_Insertion (Act_Body);
7152 -----------------------------
7153 -- Install_Formal_Packages --
7154 -----------------------------
7156 procedure Install_Formal_Packages (Par : Entity_Id) is
7159 Gen_E : Entity_Id := Empty;
7162 E := First_Entity (Par);
7164 -- In we are installing an instance parent, locate the formal packages
7165 -- of its generic parent.
7167 if Is_Generic_Instance (Par) then
7168 Gen := Generic_Parent (Specification (Unit_Declaration_Node (Par)));
7169 Gen_E := First_Entity (Gen);
7172 while Present (E) loop
7173 if Ekind (E) = E_Package
7174 and then Nkind (Parent (E)) = N_Package_Renaming_Declaration
7176 -- If this is the renaming for the parent instance, done
7178 if Renamed_Object (E) = Par then
7181 -- The visibility of a formal of an enclosing generic is
7184 elsif Denotes_Formal_Package (E) then
7187 elsif Present (Associated_Formal_Package (E))
7188 and then Box_Present (Parent (Associated_Formal_Package (E)))
7190 Check_Generic_Actuals (Renamed_Object (E), True);
7191 Set_Is_Hidden (E, False);
7193 -- Find formal package in generic unit that corresponds to
7194 -- (instance of) formal package in instance.
7196 while Present (Gen_E)
7197 and then Chars (Gen_E) /= Chars (E)
7199 Next_Entity (Gen_E);
7202 if Present (Gen_E) then
7203 Map_Formal_Package_Entities (Gen_E, E);
7209 if Present (Gen_E) then
7210 Next_Entity (Gen_E);
7213 end Install_Formal_Packages;
7215 --------------------
7216 -- Install_Parent --
7217 --------------------
7219 procedure Install_Parent (P : Entity_Id; In_Body : Boolean := False) is
7220 Ancestors : constant Elist_Id := New_Elmt_List;
7221 S : constant Entity_Id := Current_Scope;
7222 Inst_Par : Entity_Id;
7223 First_Par : Entity_Id;
7224 Inst_Node : Node_Id;
7225 Gen_Par : Entity_Id;
7226 First_Gen : Entity_Id;
7229 procedure Install_Noninstance_Specs (Par : Entity_Id);
7230 -- Install the scopes of noninstance parent units ending with Par
7232 procedure Install_Spec (Par : Entity_Id);
7233 -- The child unit is within the declarative part of the parent, so
7234 -- the declarations within the parent are immediately visible.
7236 -------------------------------
7237 -- Install_Noninstance_Specs --
7238 -------------------------------
7240 procedure Install_Noninstance_Specs (Par : Entity_Id) is
7243 and then Par /= Standard_Standard
7244 and then not In_Open_Scopes (Par)
7246 Install_Noninstance_Specs (Scope (Par));
7249 end Install_Noninstance_Specs;
7255 procedure Install_Spec (Par : Entity_Id) is
7256 Spec : constant Node_Id :=
7257 Specification (Unit_Declaration_Node (Par));
7260 -- If this parent of the child instance is a top-level unit,
7261 -- then record the unit and its visibility for later resetting
7262 -- in Remove_Parent. We exclude units that are generic instances,
7263 -- as we only want to record this information for the ultimate
7264 -- top-level noninstance parent (is that always correct???).
7266 if Scope (Par) = Standard_Standard
7267 and then not Is_Generic_Instance (Par)
7269 Parent_Unit_Visible := Is_Immediately_Visible (Par);
7270 Instance_Parent_Unit := Par;
7273 -- Open the parent scope and make it and its declarations visible.
7274 -- If this point is not within a body, then only the visible
7275 -- declarations should be made visible, and installation of the
7276 -- private declarations is deferred until the appropriate point
7277 -- within analysis of the spec being instantiated (see the handling
7278 -- of parent visibility in Analyze_Package_Specification). This is
7279 -- relaxed in the case where the parent unit is Ada.Tags, to avoid
7280 -- private view problems that occur when compiling instantiations of
7281 -- a generic child of that package (Generic_Dispatching_Constructor).
7282 -- If the instance freezes a tagged type, inlinings of operations
7283 -- from Ada.Tags may need the full view of type Tag. If inlining took
7284 -- proper account of establishing visibility of inlined subprograms'
7285 -- parents then it should be possible to remove this
7286 -- special check. ???
7289 Set_Is_Immediately_Visible (Par);
7290 Install_Visible_Declarations (Par);
7291 Set_Use (Visible_Declarations (Spec));
7293 if In_Body or else Is_RTU (Par, Ada_Tags) then
7294 Install_Private_Declarations (Par);
7295 Set_Use (Private_Declarations (Spec));
7299 -- Start of processing for Install_Parent
7302 -- We need to install the parent instance to compile the instantiation
7303 -- of the child, but the child instance must appear in the current
7304 -- scope. Given that we cannot place the parent above the current scope
7305 -- in the scope stack, we duplicate the current scope and unstack both
7306 -- after the instantiation is complete.
7308 -- If the parent is itself the instantiation of a child unit, we must
7309 -- also stack the instantiation of its parent, and so on. Each such
7310 -- ancestor is the prefix of the name in a prior instantiation.
7312 -- If this is a nested instance, the parent unit itself resolves to
7313 -- a renaming of the parent instance, whose declaration we need.
7315 -- Finally, the parent may be a generic (not an instance) when the
7316 -- child unit appears as a formal package.
7320 if Present (Renamed_Entity (Inst_Par)) then
7321 Inst_Par := Renamed_Entity (Inst_Par);
7324 First_Par := Inst_Par;
7327 Generic_Parent (Specification (Unit_Declaration_Node (Inst_Par)));
7329 First_Gen := Gen_Par;
7331 while Present (Gen_Par)
7332 and then Is_Child_Unit (Gen_Par)
7334 -- Load grandparent instance as well
7336 Inst_Node := Get_Package_Instantiation_Node (Inst_Par);
7338 if Nkind (Name (Inst_Node)) = N_Expanded_Name then
7339 Inst_Par := Entity (Prefix (Name (Inst_Node)));
7341 if Present (Renamed_Entity (Inst_Par)) then
7342 Inst_Par := Renamed_Entity (Inst_Par);
7347 (Specification (Unit_Declaration_Node (Inst_Par)));
7349 if Present (Gen_Par) then
7350 Prepend_Elmt (Inst_Par, Ancestors);
7353 -- Parent is not the name of an instantiation
7355 Install_Noninstance_Specs (Inst_Par);
7367 if Present (First_Gen) then
7368 Append_Elmt (First_Par, Ancestors);
7371 Install_Noninstance_Specs (First_Par);
7374 if not Is_Empty_Elmt_List (Ancestors) then
7375 Elmt := First_Elmt (Ancestors);
7377 while Present (Elmt) loop
7378 Install_Spec (Node (Elmt));
7379 Install_Formal_Packages (Node (Elmt));
7390 --------------------------------
7391 -- Instantiate_Formal_Package --
7392 --------------------------------
7394 function Instantiate_Formal_Package
7397 Analyzed_Formal : Node_Id) return List_Id
7399 Loc : constant Source_Ptr := Sloc (Actual);
7400 Actual_Pack : Entity_Id;
7401 Formal_Pack : Entity_Id;
7402 Gen_Parent : Entity_Id;
7405 Parent_Spec : Node_Id;
7407 procedure Find_Matching_Actual
7409 Act : in out Entity_Id);
7410 -- We need to associate each formal entity in the formal package
7411 -- with the corresponding entity in the actual package. The actual
7412 -- package has been analyzed and possibly expanded, and as a result
7413 -- there is no one-to-one correspondence between the two lists (for
7414 -- example, the actual may include subtypes, itypes, and inherited
7415 -- primitive operations, interspersed among the renaming declarations
7416 -- for the actuals) . We retrieve the corresponding actual by name
7417 -- because each actual has the same name as the formal, and they do
7418 -- appear in the same order.
7420 function Get_Formal_Entity (N : Node_Id) return Entity_Id;
7421 -- Retrieve entity of defining entity of generic formal parameter.
7422 -- Only the declarations of formals need to be considered when
7423 -- linking them to actuals, but the declarative list may include
7424 -- internal entities generated during analysis, and those are ignored.
7426 procedure Match_Formal_Entity
7427 (Formal_Node : Node_Id;
7428 Formal_Ent : Entity_Id;
7429 Actual_Ent : Entity_Id);
7430 -- Associates the formal entity with the actual. In the case
7431 -- where Formal_Ent is a formal package, this procedure iterates
7432 -- through all of its formals and enters associations between the
7433 -- actuals occurring in the formal package's corresponding actual
7434 -- package (given by Actual_Ent) and the formal package's formal
7435 -- parameters. This procedure recurses if any of the parameters is
7436 -- itself a package.
7438 function Is_Instance_Of
7439 (Act_Spec : Entity_Id;
7440 Gen_Anc : Entity_Id) return Boolean;
7441 -- The actual can be an instantiation of a generic within another
7442 -- instance, in which case there is no direct link from it to the
7443 -- original generic ancestor. In that case, we recognize that the
7444 -- ultimate ancestor is the same by examining names and scopes.
7446 procedure Process_Nested_Formal (Formal : Entity_Id);
7447 -- If the current formal is declared with a box, its own formals are
7448 -- visible in the instance, as they were in the generic, and their
7449 -- Hidden flag must be reset. If some of these formals are themselves
7450 -- packages declared with a box, the processing must be recursive.
7452 --------------------------
7453 -- Find_Matching_Actual --
7454 --------------------------
7456 procedure Find_Matching_Actual
7458 Act : in out Entity_Id)
7460 Formal_Ent : Entity_Id;
7463 case Nkind (Original_Node (F)) is
7464 when N_Formal_Object_Declaration |
7465 N_Formal_Type_Declaration =>
7466 Formal_Ent := Defining_Identifier (F);
7468 while Chars (Act) /= Chars (Formal_Ent) loop
7472 when N_Formal_Subprogram_Declaration |
7473 N_Formal_Package_Declaration |
7474 N_Package_Declaration |
7475 N_Generic_Package_Declaration =>
7476 Formal_Ent := Defining_Entity (F);
7478 while Chars (Act) /= Chars (Formal_Ent) loop
7483 raise Program_Error;
7485 end Find_Matching_Actual;
7487 -------------------------
7488 -- Match_Formal_Entity --
7489 -------------------------
7491 procedure Match_Formal_Entity
7492 (Formal_Node : Node_Id;
7493 Formal_Ent : Entity_Id;
7494 Actual_Ent : Entity_Id)
7496 Act_Pkg : Entity_Id;
7499 Set_Instance_Of (Formal_Ent, Actual_Ent);
7501 if Ekind (Actual_Ent) = E_Package then
7503 -- Record associations for each parameter
7505 Act_Pkg := Actual_Ent;
7508 A_Ent : Entity_Id := First_Entity (Act_Pkg);
7517 -- Retrieve the actual given in the formal package declaration
7519 Actual := Entity (Name (Original_Node (Formal_Node)));
7521 -- The actual in the formal package declaration may be a
7522 -- renamed generic package, in which case we want to retrieve
7523 -- the original generic in order to traverse its formal part.
7525 if Present (Renamed_Entity (Actual)) then
7526 Gen_Decl := Unit_Declaration_Node (Renamed_Entity (Actual));
7528 Gen_Decl := Unit_Declaration_Node (Actual);
7531 Formals := Generic_Formal_Declarations (Gen_Decl);
7533 if Present (Formals) then
7534 F_Node := First_Non_Pragma (Formals);
7539 while Present (A_Ent)
7540 and then Present (F_Node)
7541 and then A_Ent /= First_Private_Entity (Act_Pkg)
7543 F_Ent := Get_Formal_Entity (F_Node);
7545 if Present (F_Ent) then
7547 -- This is a formal of the original package. Record
7548 -- association and recurse.
7550 Find_Matching_Actual (F_Node, A_Ent);
7551 Match_Formal_Entity (F_Node, F_Ent, A_Ent);
7552 Next_Entity (A_Ent);
7555 Next_Non_Pragma (F_Node);
7559 end Match_Formal_Entity;
7561 -----------------------
7562 -- Get_Formal_Entity --
7563 -----------------------
7565 function Get_Formal_Entity (N : Node_Id) return Entity_Id is
7566 Kind : constant Node_Kind := Nkind (Original_Node (N));
7569 when N_Formal_Object_Declaration =>
7570 return Defining_Identifier (N);
7572 when N_Formal_Type_Declaration =>
7573 return Defining_Identifier (N);
7575 when N_Formal_Subprogram_Declaration =>
7576 return Defining_Unit_Name (Specification (N));
7578 when N_Formal_Package_Declaration =>
7579 return Defining_Identifier (Original_Node (N));
7581 when N_Generic_Package_Declaration =>
7582 return Defining_Identifier (Original_Node (N));
7584 -- All other declarations are introduced by semantic analysis and
7585 -- have no match in the actual.
7590 end Get_Formal_Entity;
7592 --------------------
7593 -- Is_Instance_Of --
7594 --------------------
7596 function Is_Instance_Of
7597 (Act_Spec : Entity_Id;
7598 Gen_Anc : Entity_Id) return Boolean
7600 Gen_Par : constant Entity_Id := Generic_Parent (Act_Spec);
7603 if No (Gen_Par) then
7606 -- Simplest case: the generic parent of the actual is the formal
7608 elsif Gen_Par = Gen_Anc then
7611 elsif Chars (Gen_Par) /= Chars (Gen_Anc) then
7614 -- The actual may be obtained through several instantiations. Its
7615 -- scope must itself be an instance of a generic declared in the
7616 -- same scope as the formal. Any other case is detected above.
7618 elsif not Is_Generic_Instance (Scope (Gen_Par)) then
7622 return Generic_Parent (Parent (Scope (Gen_Par))) = Scope (Gen_Anc);
7626 ---------------------------
7627 -- Process_Nested_Formal --
7628 ---------------------------
7630 procedure Process_Nested_Formal (Formal : Entity_Id) is
7634 if Present (Associated_Formal_Package (Formal))
7635 and then Box_Present (Parent (Associated_Formal_Package (Formal)))
7637 Ent := First_Entity (Formal);
7638 while Present (Ent) loop
7639 Set_Is_Hidden (Ent, False);
7640 Set_Is_Visible_Formal (Ent);
7641 Set_Is_Potentially_Use_Visible
7642 (Ent, Is_Potentially_Use_Visible (Formal));
7644 if Ekind (Ent) = E_Package then
7645 exit when Renamed_Entity (Ent) = Renamed_Entity (Formal);
7646 Process_Nested_Formal (Ent);
7652 end Process_Nested_Formal;
7654 -- Start of processing for Instantiate_Formal_Package
7659 if not Is_Entity_Name (Actual)
7660 or else Ekind (Entity (Actual)) /= E_Package
7663 ("expect package instance to instantiate formal", Actual);
7664 Abandon_Instantiation (Actual);
7665 raise Program_Error;
7668 Actual_Pack := Entity (Actual);
7669 Set_Is_Instantiated (Actual_Pack);
7671 -- The actual may be a renamed package, or an outer generic formal
7672 -- package whose instantiation is converted into a renaming.
7674 if Present (Renamed_Object (Actual_Pack)) then
7675 Actual_Pack := Renamed_Object (Actual_Pack);
7678 if Nkind (Analyzed_Formal) = N_Formal_Package_Declaration then
7679 Gen_Parent := Get_Instance_Of (Entity (Name (Analyzed_Formal)));
7680 Formal_Pack := Defining_Identifier (Analyzed_Formal);
7683 Generic_Parent (Specification (Analyzed_Formal));
7685 Defining_Unit_Name (Specification (Analyzed_Formal));
7688 if Nkind (Parent (Actual_Pack)) = N_Defining_Program_Unit_Name then
7689 Parent_Spec := Specification (Unit_Declaration_Node (Actual_Pack));
7691 Parent_Spec := Parent (Actual_Pack);
7694 if Gen_Parent = Any_Id then
7696 ("previous error in declaration of formal package", Actual);
7697 Abandon_Instantiation (Actual);
7700 Is_Instance_Of (Parent_Spec, Get_Instance_Of (Gen_Parent))
7706 ("actual parameter must be instance of&", Actual, Gen_Parent);
7707 Abandon_Instantiation (Actual);
7710 Set_Instance_Of (Defining_Identifier (Formal), Actual_Pack);
7711 Map_Formal_Package_Entities (Formal_Pack, Actual_Pack);
7714 Make_Package_Renaming_Declaration (Loc,
7715 Defining_Unit_Name => New_Copy (Defining_Identifier (Formal)),
7716 Name => New_Reference_To (Actual_Pack, Loc));
7718 Set_Associated_Formal_Package (Defining_Unit_Name (Nod),
7719 Defining_Identifier (Formal));
7720 Decls := New_List (Nod);
7722 -- If the formal F has a box, then the generic declarations are
7723 -- visible in the generic G. In an instance of G, the corresponding
7724 -- entities in the actual for F (which are the actuals for the
7725 -- instantiation of the generic that F denotes) must also be made
7726 -- visible for analysis of the current instance. On exit from the
7727 -- current instance, those entities are made private again. If the
7728 -- actual is currently in use, these entities are also use-visible.
7730 -- The loop through the actual entities also steps through the formal
7731 -- entities and enters associations from formals to actuals into the
7732 -- renaming map. This is necessary to properly handle checking of
7733 -- actual parameter associations for later formals that depend on
7734 -- actuals declared in the formal package.
7736 -- In Ada 2005, partial parametrization requires that we make visible
7737 -- the actuals corresponding to formals that were defaulted in the
7738 -- formal package. There formals are identified because they remain
7739 -- formal generics within the formal package, rather than being
7740 -- renamings of the actuals supplied.
7743 Gen_Decl : constant Node_Id :=
7744 Unit_Declaration_Node (Gen_Parent);
7745 Formals : constant List_Id :=
7746 Generic_Formal_Declarations (Gen_Decl);
7748 Actual_Ent : Entity_Id;
7749 Actual_Of_Formal : Node_Id;
7750 Formal_Node : Node_Id;
7751 Formal_Ent : Entity_Id;
7754 if Present (Formals) then
7755 Formal_Node := First_Non_Pragma (Formals);
7757 Formal_Node := Empty;
7760 Actual_Ent := First_Entity (Actual_Pack);
7762 First (Visible_Declarations (Specification (Analyzed_Formal)));
7763 while Present (Actual_Ent)
7764 and then Actual_Ent /= First_Private_Entity (Actual_Pack)
7766 if Present (Formal_Node) then
7767 Formal_Ent := Get_Formal_Entity (Formal_Node);
7769 if Present (Formal_Ent) then
7770 Find_Matching_Actual (Formal_Node, Actual_Ent);
7772 (Formal_Node, Formal_Ent, Actual_Ent);
7774 -- We iterate at the same time over the actuals of the
7775 -- local package created for the formal, to determine
7776 -- which one of the formals of the original generic were
7777 -- defaulted in the formal. The corresponding actual
7778 -- entities are visible in the enclosing instance.
7780 if Box_Present (Formal)
7782 (Present (Actual_Of_Formal)
7785 (Get_Formal_Entity (Actual_Of_Formal)))
7787 Set_Is_Hidden (Actual_Ent, False);
7788 Set_Is_Visible_Formal (Actual_Ent);
7789 Set_Is_Potentially_Use_Visible
7790 (Actual_Ent, In_Use (Actual_Pack));
7792 if Ekind (Actual_Ent) = E_Package then
7793 Process_Nested_Formal (Actual_Ent);
7797 Set_Is_Hidden (Actual_Ent);
7798 Set_Is_Potentially_Use_Visible (Actual_Ent, False);
7802 Next_Non_Pragma (Formal_Node);
7803 Next (Actual_Of_Formal);
7806 -- No further formals to match, but the generic part may
7807 -- contain inherited operation that are not hidden in the
7808 -- enclosing instance.
7810 Next_Entity (Actual_Ent);
7814 -- Inherited subprograms generated by formal derived types are
7815 -- also visible if the types are.
7817 Actual_Ent := First_Entity (Actual_Pack);
7818 while Present (Actual_Ent)
7819 and then Actual_Ent /= First_Private_Entity (Actual_Pack)
7821 if Is_Overloadable (Actual_Ent)
7823 Nkind (Parent (Actual_Ent)) = N_Subtype_Declaration
7825 not Is_Hidden (Defining_Identifier (Parent (Actual_Ent)))
7827 Set_Is_Hidden (Actual_Ent, False);
7828 Set_Is_Potentially_Use_Visible
7829 (Actual_Ent, In_Use (Actual_Pack));
7832 Next_Entity (Actual_Ent);
7836 -- If the formal is not declared with a box, reanalyze it as an
7837 -- abbreviated instantiation, to verify the matching rules of 12.7.
7838 -- The actual checks are performed after the generic associations
7839 -- have been analyzed, to guarantee the same visibility for this
7840 -- instantiation and for the actuals.
7842 -- In Ada 2005, the generic associations for the formal can include
7843 -- defaulted parameters. These are ignored during check. This
7844 -- internal instantiation is removed from the tree after conformance
7845 -- checking, because it contains formal declarations for those
7846 -- defaulted parameters, and those should not reach the back-end.
7848 if not Box_Present (Formal) then
7850 I_Pack : constant Entity_Id :=
7851 Make_Defining_Identifier (Sloc (Actual),
7852 Chars => New_Internal_Name ('P'));
7855 Set_Is_Internal (I_Pack);
7858 Make_Package_Instantiation (Sloc (Actual),
7859 Defining_Unit_Name => I_Pack,
7862 (Get_Instance_Of (Gen_Parent), Sloc (Actual)),
7863 Generic_Associations =>
7864 Generic_Associations (Formal)));
7870 end Instantiate_Formal_Package;
7872 -----------------------------------
7873 -- Instantiate_Formal_Subprogram --
7874 -----------------------------------
7876 function Instantiate_Formal_Subprogram
7879 Analyzed_Formal : Node_Id) return Node_Id
7882 Formal_Sub : constant Entity_Id :=
7883 Defining_Unit_Name (Specification (Formal));
7884 Analyzed_S : constant Entity_Id :=
7885 Defining_Unit_Name (Specification (Analyzed_Formal));
7886 Decl_Node : Node_Id;
7890 function From_Parent_Scope (Subp : Entity_Id) return Boolean;
7891 -- If the generic is a child unit, the parent has been installed on the
7892 -- scope stack, but a default subprogram cannot resolve to something on
7893 -- the parent because that parent is not really part of the visible
7894 -- context (it is there to resolve explicit local entities). If the
7895 -- default has resolved in this way, we remove the entity from
7896 -- immediate visibility and analyze the node again to emit an error
7897 -- message or find another visible candidate.
7899 procedure Valid_Actual_Subprogram (Act : Node_Id);
7900 -- Perform legality check and raise exception on failure
7902 -----------------------
7903 -- From_Parent_Scope --
7904 -----------------------
7906 function From_Parent_Scope (Subp : Entity_Id) return Boolean is
7907 Gen_Scope : Node_Id;
7910 Gen_Scope := Scope (Analyzed_S);
7911 while Present (Gen_Scope)
7912 and then Is_Child_Unit (Gen_Scope)
7914 if Scope (Subp) = Scope (Gen_Scope) then
7918 Gen_Scope := Scope (Gen_Scope);
7922 end From_Parent_Scope;
7924 -----------------------------
7925 -- Valid_Actual_Subprogram --
7926 -----------------------------
7928 procedure Valid_Actual_Subprogram (Act : Node_Id) is
7932 if Is_Entity_Name (Act) then
7933 Act_E := Entity (Act);
7935 elsif Nkind (Act) = N_Selected_Component
7936 and then Is_Entity_Name (Selector_Name (Act))
7938 Act_E := Entity (Selector_Name (Act));
7944 if (Present (Act_E) and then Is_Overloadable (Act_E))
7945 or else Nkind_In (Act, N_Attribute_Reference,
7946 N_Indexed_Component,
7947 N_Character_Literal,
7948 N_Explicit_Dereference)
7954 ("expect subprogram or entry name in instantiation of&",
7955 Instantiation_Node, Formal_Sub);
7956 Abandon_Instantiation (Instantiation_Node);
7958 end Valid_Actual_Subprogram;
7960 -- Start of processing for Instantiate_Formal_Subprogram
7963 New_Spec := New_Copy_Tree (Specification (Formal));
7965 -- The tree copy has created the proper instantiation sloc for the
7966 -- new specification. Use this location for all other constructed
7969 Loc := Sloc (Defining_Unit_Name (New_Spec));
7971 -- Create new entity for the actual (New_Copy_Tree does not)
7973 Set_Defining_Unit_Name
7974 (New_Spec, Make_Defining_Identifier (Loc, Chars (Formal_Sub)));
7976 -- Create new entities for the each of the formals in the
7977 -- specification of the renaming declaration built for the actual.
7979 if Present (Parameter_Specifications (New_Spec)) then
7983 F := First (Parameter_Specifications (New_Spec));
7984 while Present (F) loop
7985 Set_Defining_Identifier (F,
7986 Make_Defining_Identifier (Sloc (F),
7987 Chars => Chars (Defining_Identifier (F))));
7993 -- Find entity of actual. If the actual is an attribute reference, it
7994 -- cannot be resolved here (its formal is missing) but is handled
7995 -- instead in Attribute_Renaming. If the actual is overloaded, it is
7996 -- fully resolved subsequently, when the renaming declaration for the
7997 -- formal is analyzed. If it is an explicit dereference, resolve the
7998 -- prefix but not the actual itself, to prevent interpretation as call.
8000 if Present (Actual) then
8001 Loc := Sloc (Actual);
8002 Set_Sloc (New_Spec, Loc);
8004 if Nkind (Actual) = N_Operator_Symbol then
8005 Find_Direct_Name (Actual);
8007 elsif Nkind (Actual) = N_Explicit_Dereference then
8008 Analyze (Prefix (Actual));
8010 elsif Nkind (Actual) /= N_Attribute_Reference then
8014 Valid_Actual_Subprogram (Actual);
8017 elsif Present (Default_Name (Formal)) then
8018 if not Nkind_In (Default_Name (Formal), N_Attribute_Reference,
8019 N_Selected_Component,
8020 N_Indexed_Component,
8021 N_Character_Literal)
8022 and then Present (Entity (Default_Name (Formal)))
8024 Nam := New_Occurrence_Of (Entity (Default_Name (Formal)), Loc);
8026 Nam := New_Copy (Default_Name (Formal));
8027 Set_Sloc (Nam, Loc);
8030 elsif Box_Present (Formal) then
8032 -- Actual is resolved at the point of instantiation. Create an
8033 -- identifier or operator with the same name as the formal.
8035 if Nkind (Formal_Sub) = N_Defining_Operator_Symbol then
8036 Nam := Make_Operator_Symbol (Loc,
8037 Chars => Chars (Formal_Sub),
8038 Strval => No_String);
8040 Nam := Make_Identifier (Loc, Chars (Formal_Sub));
8043 elsif Nkind (Specification (Formal)) = N_Procedure_Specification
8044 and then Null_Present (Specification (Formal))
8046 -- Generate null body for procedure, for use in the instance
8049 Make_Subprogram_Body (Loc,
8050 Specification => New_Spec,
8051 Declarations => New_List,
8052 Handled_Statement_Sequence =>
8053 Make_Handled_Sequence_Of_Statements (Loc,
8054 Statements => New_List (Make_Null_Statement (Loc))));
8056 Set_Is_Intrinsic_Subprogram (Defining_Unit_Name (New_Spec));
8060 Error_Msg_Sloc := Sloc (Scope (Analyzed_S));
8062 ("missing actual&", Instantiation_Node, Formal_Sub);
8064 ("\in instantiation of & declared#",
8065 Instantiation_Node, Scope (Analyzed_S));
8066 Abandon_Instantiation (Instantiation_Node);
8070 Make_Subprogram_Renaming_Declaration (Loc,
8071 Specification => New_Spec,
8074 -- If we do not have an actual and the formal specified <> then set to
8075 -- get proper default.
8077 if No (Actual) and then Box_Present (Formal) then
8078 Set_From_Default (Decl_Node);
8081 -- Gather possible interpretations for the actual before analyzing the
8082 -- instance. If overloaded, it will be resolved when analyzing the
8083 -- renaming declaration.
8085 if Box_Present (Formal)
8086 and then No (Actual)
8090 if Is_Child_Unit (Scope (Analyzed_S))
8091 and then Present (Entity (Nam))
8093 if not Is_Overloaded (Nam) then
8095 if From_Parent_Scope (Entity (Nam)) then
8096 Set_Is_Immediately_Visible (Entity (Nam), False);
8097 Set_Entity (Nam, Empty);
8098 Set_Etype (Nam, Empty);
8102 Set_Is_Immediately_Visible (Entity (Nam));
8111 Get_First_Interp (Nam, I, It);
8113 while Present (It.Nam) loop
8114 if From_Parent_Scope (It.Nam) then
8118 Get_Next_Interp (I, It);
8125 -- The generic instantiation freezes the actual. This can only be done
8126 -- once the actual is resolved, in the analysis of the renaming
8127 -- declaration. To make the formal subprogram entity available, we set
8128 -- Corresponding_Formal_Spec to point to the formal subprogram entity.
8129 -- This is also needed in Analyze_Subprogram_Renaming for the processing
8130 -- of formal abstract subprograms.
8132 Set_Corresponding_Formal_Spec (Decl_Node, Analyzed_S);
8134 -- We cannot analyze the renaming declaration, and thus find the actual,
8135 -- until all the actuals are assembled in the instance. For subsequent
8136 -- checks of other actuals, indicate the node that will hold the
8137 -- instance of this formal.
8139 Set_Instance_Of (Analyzed_S, Nam);
8141 if Nkind (Actual) = N_Selected_Component
8142 and then Is_Task_Type (Etype (Prefix (Actual)))
8143 and then not Is_Frozen (Etype (Prefix (Actual)))
8145 -- The renaming declaration will create a body, which must appear
8146 -- outside of the instantiation, We move the renaming declaration
8147 -- out of the instance, and create an additional renaming inside,
8148 -- to prevent freezing anomalies.
8151 Anon_Id : constant Entity_Id :=
8152 Make_Defining_Identifier
8153 (Loc, New_Internal_Name ('E'));
8155 Set_Defining_Unit_Name (New_Spec, Anon_Id);
8156 Insert_Before (Instantiation_Node, Decl_Node);
8157 Analyze (Decl_Node);
8159 -- Now create renaming within the instance
8162 Make_Subprogram_Renaming_Declaration (Loc,
8163 Specification => New_Copy_Tree (New_Spec),
8164 Name => New_Occurrence_Of (Anon_Id, Loc));
8166 Set_Defining_Unit_Name (Specification (Decl_Node),
8167 Make_Defining_Identifier (Loc, Chars (Formal_Sub)));
8172 end Instantiate_Formal_Subprogram;
8174 ------------------------
8175 -- Instantiate_Object --
8176 ------------------------
8178 function Instantiate_Object
8181 Analyzed_Formal : Node_Id) return List_Id
8183 Acc_Def : Node_Id := Empty;
8184 Act_Assoc : constant Node_Id := Parent (Actual);
8185 Actual_Decl : Node_Id := Empty;
8186 Formal_Id : constant Entity_Id := Defining_Identifier (Formal);
8187 Decl_Node : Node_Id;
8190 List : constant List_Id := New_List;
8191 Loc : constant Source_Ptr := Sloc (Actual);
8192 Orig_Ftyp : constant Entity_Id :=
8193 Etype (Defining_Identifier (Analyzed_Formal));
8194 Subt_Decl : Node_Id := Empty;
8195 Subt_Mark : Node_Id := Empty;
8198 if Present (Subtype_Mark (Formal)) then
8199 Subt_Mark := Subtype_Mark (Formal);
8201 Check_Access_Definition (Formal);
8202 Acc_Def := Access_Definition (Formal);
8205 -- Sloc for error message on missing actual
8207 Error_Msg_Sloc := Sloc (Scope (Defining_Identifier (Analyzed_Formal)));
8209 if Get_Instance_Of (Formal_Id) /= Formal_Id then
8210 Error_Msg_N ("duplicate instantiation of generic parameter", Actual);
8213 Set_Parent (List, Parent (Actual));
8217 if Out_Present (Formal) then
8219 -- An IN OUT generic actual must be a name. The instantiation is a
8220 -- renaming declaration. The actual is the name being renamed. We
8221 -- use the actual directly, rather than a copy, because it is not
8222 -- used further in the list of actuals, and because a copy or a use
8223 -- of relocate_node is incorrect if the instance is nested within a
8224 -- generic. In order to simplify ASIS searches, the Generic_Parent
8225 -- field links the declaration to the generic association.
8230 Instantiation_Node, Formal_Id);
8232 ("\in instantiation of & declared#",
8234 Scope (Defining_Identifier (Analyzed_Formal)));
8235 Abandon_Instantiation (Instantiation_Node);
8238 if Present (Subt_Mark) then
8240 Make_Object_Renaming_Declaration (Loc,
8241 Defining_Identifier => New_Copy (Formal_Id),
8242 Subtype_Mark => New_Copy_Tree (Subt_Mark),
8245 else pragma Assert (Present (Acc_Def));
8247 Make_Object_Renaming_Declaration (Loc,
8248 Defining_Identifier => New_Copy (Formal_Id),
8249 Access_Definition => New_Copy_Tree (Acc_Def),
8253 Set_Corresponding_Generic_Association (Decl_Node, Act_Assoc);
8255 -- The analysis of the actual may produce insert_action nodes, so
8256 -- the declaration must have a context in which to attach them.
8258 Append (Decl_Node, List);
8261 -- Return if the analysis of the actual reported some error
8263 if Etype (Actual) = Any_Type then
8267 -- This check is performed here because Analyze_Object_Renaming will
8268 -- not check it when Comes_From_Source is False. Note though that the
8269 -- check for the actual being the name of an object will be performed
8270 -- in Analyze_Object_Renaming.
8272 if Is_Object_Reference (Actual)
8273 and then Is_Dependent_Component_Of_Mutable_Object (Actual)
8276 ("illegal discriminant-dependent component for in out parameter",
8280 -- The actual has to be resolved in order to check that it is a
8281 -- variable (due to cases such as F(1), where F returns
8282 -- access to an array, and for overloaded prefixes).
8285 Get_Instance_Of (Etype (Defining_Identifier (Analyzed_Formal)));
8287 if Is_Private_Type (Ftyp)
8288 and then not Is_Private_Type (Etype (Actual))
8289 and then (Base_Type (Full_View (Ftyp)) = Base_Type (Etype (Actual))
8290 or else Base_Type (Etype (Actual)) = Ftyp)
8292 -- If the actual has the type of the full view of the formal, or
8293 -- else a non-private subtype of the formal, then the visibility
8294 -- of the formal type has changed. Add to the actuals a subtype
8295 -- declaration that will force the exchange of views in the body
8296 -- of the instance as well.
8299 Make_Subtype_Declaration (Loc,
8300 Defining_Identifier =>
8301 Make_Defining_Identifier (Loc, New_Internal_Name ('P')),
8302 Subtype_Indication => New_Occurrence_Of (Ftyp, Loc));
8304 Prepend (Subt_Decl, List);
8306 Prepend_Elmt (Full_View (Ftyp), Exchanged_Views);
8307 Exchange_Declarations (Ftyp);
8310 Resolve (Actual, Ftyp);
8312 if not Denotes_Variable (Actual) then
8314 ("actual for& must be a variable", Actual, Formal_Id);
8316 elsif Base_Type (Ftyp) /= Base_Type (Etype (Actual)) then
8318 -- Ada 2005 (AI-423): For a generic formal object of mode in out,
8319 -- the type of the actual shall resolve to a specific anonymous
8322 if Ada_Version < Ada_05
8324 Ekind (Base_Type (Ftyp)) /=
8325 E_Anonymous_Access_Type
8327 Ekind (Base_Type (Etype (Actual))) /=
8328 E_Anonymous_Access_Type
8330 Error_Msg_NE ("type of actual does not match type of&",
8335 Note_Possible_Modification (Actual, Sure => True);
8337 -- Check for instantiation of atomic/volatile actual for
8338 -- non-atomic/volatile formal (RM C.6 (12)).
8340 if Is_Atomic_Object (Actual)
8341 and then not Is_Atomic (Orig_Ftyp)
8344 ("cannot instantiate non-atomic formal object " &
8345 "with atomic actual", Actual);
8347 elsif Is_Volatile_Object (Actual)
8348 and then not Is_Volatile (Orig_Ftyp)
8351 ("cannot instantiate non-volatile formal object " &
8352 "with volatile actual", Actual);
8355 -- formal in-parameter
8358 -- The instantiation of a generic formal in-parameter is constant
8359 -- declaration. The actual is the expression for that declaration.
8361 if Present (Actual) then
8362 if Present (Subt_Mark) then
8364 else pragma Assert (Present (Acc_Def));
8369 Make_Object_Declaration (Loc,
8370 Defining_Identifier => New_Copy (Formal_Id),
8371 Constant_Present => True,
8372 Null_Exclusion_Present => Null_Exclusion_Present (Formal),
8373 Object_Definition => New_Copy_Tree (Def),
8374 Expression => Actual);
8376 Set_Corresponding_Generic_Association (Decl_Node, Act_Assoc);
8378 -- A generic formal object of a tagged type is defined to be
8379 -- aliased so the new constant must also be treated as aliased.
8382 (Etype (Defining_Identifier (Analyzed_Formal)))
8384 Set_Aliased_Present (Decl_Node);
8387 Append (Decl_Node, List);
8389 -- No need to repeat (pre-)analysis of some expression nodes
8390 -- already handled in Preanalyze_Actuals.
8392 if Nkind (Actual) /= N_Allocator then
8395 -- Return if the analysis of the actual reported some error
8397 if Etype (Actual) = Any_Type then
8403 Formal_Object : constant Entity_Id :=
8404 Defining_Identifier (Analyzed_Formal);
8405 Formal_Type : constant Entity_Id := Etype (Formal_Object);
8410 Typ := Get_Instance_Of (Formal_Type);
8412 Freeze_Before (Instantiation_Node, Typ);
8414 -- If the actual is an aggregate, perform name resolution on
8415 -- its components (the analysis of an aggregate does not do it)
8416 -- to capture local names that may be hidden if the generic is
8419 if Nkind (Actual) = N_Aggregate then
8420 Preanalyze_And_Resolve (Actual, Typ);
8423 if Is_Limited_Type (Typ)
8424 and then not OK_For_Limited_Init (Actual)
8427 ("initialization not allowed for limited types", Actual);
8428 Explain_Limited_Type (Typ, Actual);
8432 elsif Present (Default_Expression (Formal)) then
8434 -- Use default to construct declaration
8436 if Present (Subt_Mark) then
8438 else pragma Assert (Present (Acc_Def));
8443 Make_Object_Declaration (Sloc (Formal),
8444 Defining_Identifier => New_Copy (Formal_Id),
8445 Constant_Present => True,
8446 Null_Exclusion_Present => Null_Exclusion_Present (Formal),
8447 Object_Definition => New_Copy (Def),
8448 Expression => New_Copy_Tree
8449 (Default_Expression (Formal)));
8451 Append (Decl_Node, List);
8452 Set_Analyzed (Expression (Decl_Node), False);
8457 Instantiation_Node, Formal_Id);
8458 Error_Msg_NE ("\in instantiation of & declared#",
8460 Scope (Defining_Identifier (Analyzed_Formal)));
8463 (Etype (Defining_Identifier (Analyzed_Formal)))
8465 -- Create dummy constant declaration so that instance can be
8466 -- analyzed, to minimize cascaded visibility errors.
8468 if Present (Subt_Mark) then
8470 else pragma Assert (Present (Acc_Def));
8475 Make_Object_Declaration (Loc,
8476 Defining_Identifier => New_Copy (Formal_Id),
8477 Constant_Present => True,
8478 Null_Exclusion_Present => Null_Exclusion_Present (Formal),
8479 Object_Definition => New_Copy (Def),
8481 Make_Attribute_Reference (Sloc (Formal_Id),
8482 Attribute_Name => Name_First,
8483 Prefix => New_Copy (Def)));
8485 Append (Decl_Node, List);
8488 Abandon_Instantiation (Instantiation_Node);
8493 if Nkind (Actual) in N_Has_Entity then
8494 Actual_Decl := Parent (Entity (Actual));
8497 -- Ada 2005 (AI-423): For a formal object declaration with a null
8498 -- exclusion or an access definition that has a null exclusion: If the
8499 -- actual matching the formal object declaration denotes a generic
8500 -- formal object of another generic unit G, and the instantiation
8501 -- containing the actual occurs within the body of G or within the body
8502 -- of a generic unit declared within the declarative region of G, then
8503 -- the declaration of the formal object of G must have a null exclusion.
8504 -- Otherwise, the subtype of the actual matching the formal object
8505 -- declaration shall exclude null.
8507 if Ada_Version >= Ada_05
8508 and then Present (Actual_Decl)
8510 Nkind_In (Actual_Decl, N_Formal_Object_Declaration,
8511 N_Object_Declaration)
8512 and then Nkind (Analyzed_Formal) = N_Formal_Object_Declaration
8513 and then not Has_Null_Exclusion (Actual_Decl)
8514 and then Has_Null_Exclusion (Analyzed_Formal)
8516 Error_Msg_Sloc := Sloc (Analyzed_Formal);
8518 ("actual must exclude null to match generic formal#", Actual);
8522 end Instantiate_Object;
8524 ------------------------------
8525 -- Instantiate_Package_Body --
8526 ------------------------------
8528 procedure Instantiate_Package_Body
8529 (Body_Info : Pending_Body_Info;
8530 Inlined_Body : Boolean := False;
8531 Body_Optional : Boolean := False)
8533 Act_Decl : constant Node_Id := Body_Info.Act_Decl;
8534 Inst_Node : constant Node_Id := Body_Info.Inst_Node;
8535 Loc : constant Source_Ptr := Sloc (Inst_Node);
8537 Gen_Id : constant Node_Id := Name (Inst_Node);
8538 Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node);
8539 Gen_Decl : constant Node_Id := Unit_Declaration_Node (Gen_Unit);
8540 Act_Spec : constant Node_Id := Specification (Act_Decl);
8541 Act_Decl_Id : constant Entity_Id := Defining_Entity (Act_Spec);
8543 Act_Body_Name : Node_Id;
8545 Gen_Body_Id : Node_Id;
8547 Act_Body_Id : Entity_Id;
8549 Parent_Installed : Boolean := False;
8550 Save_Style_Check : constant Boolean := Style_Check;
8553 Gen_Body_Id := Corresponding_Body (Gen_Decl);
8555 -- The instance body may already have been processed, as the parent of
8556 -- another instance that is inlined (Load_Parent_Of_Generic).
8558 if Present (Corresponding_Body (Instance_Spec (Inst_Node))) then
8562 Expander_Mode_Save_And_Set (Body_Info.Expander_Status);
8564 -- Re-establish the state of information on which checks are suppressed.
8565 -- This information was set in Body_Info at the point of instantiation,
8566 -- and now we restore it so that the instance is compiled using the
8567 -- check status at the instantiation (RM 11.5 (7.2/2), AI95-00224-01).
8569 Local_Suppress_Stack_Top := Body_Info.Local_Suppress_Stack_Top;
8570 Scope_Suppress := Body_Info.Scope_Suppress;
8572 if No (Gen_Body_Id) then
8573 Load_Parent_Of_Generic
8574 (Inst_Node, Specification (Gen_Decl), Body_Optional);
8575 Gen_Body_Id := Corresponding_Body (Gen_Decl);
8578 -- Establish global variable for sloc adjustment and for error recovery
8580 Instantiation_Node := Inst_Node;
8582 if Present (Gen_Body_Id) then
8583 Save_Env (Gen_Unit, Act_Decl_Id);
8584 Style_Check := False;
8585 Current_Sem_Unit := Body_Info.Current_Sem_Unit;
8587 Gen_Body := Unit_Declaration_Node (Gen_Body_Id);
8589 Create_Instantiation_Source
8590 (Inst_Node, Gen_Body_Id, False, S_Adjustment);
8594 (Original_Node (Gen_Body), Empty, Instantiating => True);
8596 -- Build new name (possibly qualified) for body declaration
8598 Act_Body_Id := New_Copy (Act_Decl_Id);
8600 -- Some attributes of spec entity are not inherited by body entity
8602 Set_Handler_Records (Act_Body_Id, No_List);
8604 if Nkind (Defining_Unit_Name (Act_Spec)) =
8605 N_Defining_Program_Unit_Name
8608 Make_Defining_Program_Unit_Name (Loc,
8609 Name => New_Copy_Tree (Name (Defining_Unit_Name (Act_Spec))),
8610 Defining_Identifier => Act_Body_Id);
8612 Act_Body_Name := Act_Body_Id;
8615 Set_Defining_Unit_Name (Act_Body, Act_Body_Name);
8617 Set_Corresponding_Spec (Act_Body, Act_Decl_Id);
8618 Check_Generic_Actuals (Act_Decl_Id, False);
8620 -- If it is a child unit, make the parent instance (which is an
8621 -- instance of the parent of the generic) visible. The parent
8622 -- instance is the prefix of the name of the generic unit.
8624 if Ekind (Scope (Gen_Unit)) = E_Generic_Package
8625 and then Nkind (Gen_Id) = N_Expanded_Name
8627 Install_Parent (Entity (Prefix (Gen_Id)), In_Body => True);
8628 Parent_Installed := True;
8630 elsif Is_Child_Unit (Gen_Unit) then
8631 Install_Parent (Scope (Gen_Unit), In_Body => True);
8632 Parent_Installed := True;
8635 -- If the instantiation is a library unit, and this is the main unit,
8636 -- then build the resulting compilation unit nodes for the instance.
8637 -- If this is a compilation unit but it is not the main unit, then it
8638 -- is the body of a unit in the context, that is being compiled
8639 -- because it is encloses some inlined unit or another generic unit
8640 -- being instantiated. In that case, this body is not part of the
8641 -- current compilation, and is not attached to the tree, but its
8642 -- parent must be set for analysis.
8644 if Nkind (Parent (Inst_Node)) = N_Compilation_Unit then
8646 -- Replace instance node with body of instance, and create new
8647 -- node for corresponding instance declaration.
8649 Build_Instance_Compilation_Unit_Nodes
8650 (Inst_Node, Act_Body, Act_Decl);
8651 Analyze (Inst_Node);
8653 if Parent (Inst_Node) = Cunit (Main_Unit) then
8655 -- If the instance is a child unit itself, then set the scope
8656 -- of the expanded body to be the parent of the instantiation
8657 -- (ensuring that the fully qualified name will be generated
8658 -- for the elaboration subprogram).
8660 if Nkind (Defining_Unit_Name (Act_Spec)) =
8661 N_Defining_Program_Unit_Name
8664 (Defining_Entity (Inst_Node), Scope (Act_Decl_Id));
8668 -- Case where instantiation is not a library unit
8671 -- If this is an early instantiation, i.e. appears textually
8672 -- before the corresponding body and must be elaborated first,
8673 -- indicate that the body instance is to be delayed.
8675 Install_Body (Act_Body, Inst_Node, Gen_Body, Gen_Decl);
8677 -- Now analyze the body. We turn off all checks if this is an
8678 -- internal unit, since there is no reason to have checks on for
8679 -- any predefined run-time library code. All such code is designed
8680 -- to be compiled with checks off.
8682 -- Note that we do NOT apply this criterion to children of GNAT
8683 -- (or on VMS, children of DEC). The latter units must suppress
8684 -- checks explicitly if this is needed.
8686 if Is_Predefined_File_Name
8687 (Unit_File_Name (Get_Source_Unit (Gen_Decl)))
8689 Analyze (Act_Body, Suppress => All_Checks);
8695 Inherit_Context (Gen_Body, Inst_Node);
8697 -- Remove the parent instances if they have been placed on the scope
8698 -- stack to compile the body.
8700 if Parent_Installed then
8701 Remove_Parent (In_Body => True);
8704 Restore_Private_Views (Act_Decl_Id);
8706 -- Remove the current unit from visibility if this is an instance
8707 -- that is not elaborated on the fly for inlining purposes.
8709 if not Inlined_Body then
8710 Set_Is_Immediately_Visible (Act_Decl_Id, False);
8714 Style_Check := Save_Style_Check;
8716 -- If we have no body, and the unit requires a body, then complain. This
8717 -- complaint is suppressed if we have detected other errors (since a
8718 -- common reason for missing the body is that it had errors).
8720 elsif Unit_Requires_Body (Gen_Unit)
8721 and then not Body_Optional
8723 if Serious_Errors_Detected = 0 then
8725 ("cannot find body of generic package &", Inst_Node, Gen_Unit);
8727 -- Don't attempt to perform any cleanup actions if some other error
8728 -- was already detected, since this can cause blowups.
8734 -- Case of package that does not need a body
8737 -- If the instantiation of the declaration is a library unit, rewrite
8738 -- the original package instantiation as a package declaration in the
8739 -- compilation unit node.
8741 if Nkind (Parent (Inst_Node)) = N_Compilation_Unit then
8742 Set_Parent_Spec (Act_Decl, Parent_Spec (Inst_Node));
8743 Rewrite (Inst_Node, Act_Decl);
8745 -- Generate elaboration entity, in case spec has elaboration code.
8746 -- This cannot be done when the instance is analyzed, because it
8747 -- is not known yet whether the body exists.
8749 Set_Elaboration_Entity_Required (Act_Decl_Id, False);
8750 Build_Elaboration_Entity (Parent (Inst_Node), Act_Decl_Id);
8752 -- If the instantiation is not a library unit, then append the
8753 -- declaration to the list of implicitly generated entities, unless
8754 -- it is already a list member which means that it was already
8757 elsif not Is_List_Member (Act_Decl) then
8758 Mark_Rewrite_Insertion (Act_Decl);
8759 Insert_Before (Inst_Node, Act_Decl);
8763 Expander_Mode_Restore;
8764 end Instantiate_Package_Body;
8766 ---------------------------------
8767 -- Instantiate_Subprogram_Body --
8768 ---------------------------------
8770 procedure Instantiate_Subprogram_Body
8771 (Body_Info : Pending_Body_Info;
8772 Body_Optional : Boolean := False)
8774 Act_Decl : constant Node_Id := Body_Info.Act_Decl;
8775 Inst_Node : constant Node_Id := Body_Info.Inst_Node;
8776 Loc : constant Source_Ptr := Sloc (Inst_Node);
8777 Gen_Id : constant Node_Id := Name (Inst_Node);
8778 Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node);
8779 Gen_Decl : constant Node_Id := Unit_Declaration_Node (Gen_Unit);
8780 Anon_Id : constant Entity_Id :=
8781 Defining_Unit_Name (Specification (Act_Decl));
8782 Pack_Id : constant Entity_Id :=
8783 Defining_Unit_Name (Parent (Act_Decl));
8786 Gen_Body_Id : Node_Id;
8788 Pack_Body : Node_Id;
8789 Prev_Formal : Entity_Id;
8791 Unit_Renaming : Node_Id;
8793 Parent_Installed : Boolean := False;
8794 Save_Style_Check : constant Boolean := Style_Check;
8797 Gen_Body_Id := Corresponding_Body (Gen_Decl);
8799 -- Subprogram body may have been created already because of an inline
8800 -- pragma, or because of multiple elaborations of the enclosing package
8801 -- when several instances of the subprogram appear in the main unit.
8803 if Present (Corresponding_Body (Act_Decl)) then
8807 Expander_Mode_Save_And_Set (Body_Info.Expander_Status);
8809 -- Re-establish the state of information on which checks are suppressed.
8810 -- This information was set in Body_Info at the point of instantiation,
8811 -- and now we restore it so that the instance is compiled using the
8812 -- check status at the instantiation (RM 11.5 (7.2/2), AI95-00224-01).
8814 Local_Suppress_Stack_Top := Body_Info.Local_Suppress_Stack_Top;
8815 Scope_Suppress := Body_Info.Scope_Suppress;
8817 if No (Gen_Body_Id) then
8819 -- For imported generic subprogram, no body to compile, complete
8820 -- the spec entity appropriately.
8822 if Is_Imported (Gen_Unit) then
8823 Set_Is_Imported (Anon_Id);
8824 Set_First_Rep_Item (Anon_Id, First_Rep_Item (Gen_Unit));
8825 Set_Interface_Name (Anon_Id, Interface_Name (Gen_Unit));
8826 Set_Convention (Anon_Id, Convention (Gen_Unit));
8827 Set_Has_Completion (Anon_Id);
8830 -- For other cases, compile the body
8833 Load_Parent_Of_Generic
8834 (Inst_Node, Specification (Gen_Decl), Body_Optional);
8835 Gen_Body_Id := Corresponding_Body (Gen_Decl);
8839 Instantiation_Node := Inst_Node;
8841 if Present (Gen_Body_Id) then
8842 Gen_Body := Unit_Declaration_Node (Gen_Body_Id);
8844 if Nkind (Gen_Body) = N_Subprogram_Body_Stub then
8846 -- Either body is not present, or context is non-expanding, as
8847 -- when compiling a subunit. Mark the instance as completed, and
8848 -- diagnose a missing body when needed.
8851 and then Operating_Mode = Generate_Code
8854 ("missing proper body for instantiation", Gen_Body);
8857 Set_Has_Completion (Anon_Id);
8861 Save_Env (Gen_Unit, Anon_Id);
8862 Style_Check := False;
8863 Current_Sem_Unit := Body_Info.Current_Sem_Unit;
8864 Create_Instantiation_Source
8872 (Original_Node (Gen_Body), Empty, Instantiating => True);
8874 -- Create proper defining name for the body, to correspond to
8875 -- the one in the spec.
8877 Set_Defining_Unit_Name (Specification (Act_Body),
8878 Make_Defining_Identifier
8879 (Sloc (Defining_Entity (Inst_Node)), Chars (Anon_Id)));
8880 Set_Corresponding_Spec (Act_Body, Anon_Id);
8881 Set_Has_Completion (Anon_Id);
8882 Check_Generic_Actuals (Pack_Id, False);
8884 -- Generate a reference to link the visible subprogram instance to
8885 -- the generic body, which for navigation purposes is the only
8886 -- available source for the instance.
8889 (Related_Instance (Pack_Id),
8890 Gen_Body_Id, 'b', Set_Ref => False, Force => True);
8892 -- If it is a child unit, make the parent instance (which is an
8893 -- instance of the parent of the generic) visible. The parent
8894 -- instance is the prefix of the name of the generic unit.
8896 if Ekind (Scope (Gen_Unit)) = E_Generic_Package
8897 and then Nkind (Gen_Id) = N_Expanded_Name
8899 Install_Parent (Entity (Prefix (Gen_Id)), In_Body => True);
8900 Parent_Installed := True;
8902 elsif Is_Child_Unit (Gen_Unit) then
8903 Install_Parent (Scope (Gen_Unit), In_Body => True);
8904 Parent_Installed := True;
8907 -- Inside its body, a reference to the generic unit is a reference
8908 -- to the instance. The corresponding renaming is the first
8909 -- declaration in the body.
8912 Make_Subprogram_Renaming_Declaration (Loc,
8915 Specification (Original_Node (Gen_Body)),
8917 Instantiating => True),
8918 Name => New_Occurrence_Of (Anon_Id, Loc));
8920 -- If there is a formal subprogram with the same name as the unit
8921 -- itself, do not add this renaming declaration. This is a temporary
8922 -- fix for one ACVC test. ???
8924 Prev_Formal := First_Entity (Pack_Id);
8925 while Present (Prev_Formal) loop
8926 if Chars (Prev_Formal) = Chars (Gen_Unit)
8927 and then Is_Overloadable (Prev_Formal)
8932 Next_Entity (Prev_Formal);
8935 if Present (Prev_Formal) then
8936 Decls := New_List (Act_Body);
8938 Decls := New_List (Unit_Renaming, Act_Body);
8941 -- The subprogram body is placed in the body of a dummy package body,
8942 -- whose spec contains the subprogram declaration as well as the
8943 -- renaming declarations for the generic parameters.
8945 Pack_Body := Make_Package_Body (Loc,
8946 Defining_Unit_Name => New_Copy (Pack_Id),
8947 Declarations => Decls);
8949 Set_Corresponding_Spec (Pack_Body, Pack_Id);
8951 -- If the instantiation is a library unit, then build resulting
8952 -- compilation unit nodes for the instance. The declaration of
8953 -- the enclosing package is the grandparent of the subprogram
8954 -- declaration. First replace the instantiation node as the unit
8955 -- of the corresponding compilation.
8957 if Nkind (Parent (Inst_Node)) = N_Compilation_Unit then
8958 if Parent (Inst_Node) = Cunit (Main_Unit) then
8959 Set_Unit (Parent (Inst_Node), Inst_Node);
8960 Build_Instance_Compilation_Unit_Nodes
8961 (Inst_Node, Pack_Body, Parent (Parent (Act_Decl)));
8962 Analyze (Inst_Node);
8964 Set_Parent (Pack_Body, Parent (Inst_Node));
8965 Analyze (Pack_Body);
8969 Insert_Before (Inst_Node, Pack_Body);
8970 Mark_Rewrite_Insertion (Pack_Body);
8971 Analyze (Pack_Body);
8973 if Expander_Active then
8974 Freeze_Subprogram_Body (Inst_Node, Gen_Body, Pack_Id);
8978 Inherit_Context (Gen_Body, Inst_Node);
8980 Restore_Private_Views (Pack_Id, False);
8982 if Parent_Installed then
8983 Remove_Parent (In_Body => True);
8987 Style_Check := Save_Style_Check;
8989 -- Body not found. Error was emitted already. If there were no previous
8990 -- errors, this may be an instance whose scope is a premature instance.
8991 -- In that case we must insure that the (legal) program does raise
8992 -- program error if executed. We generate a subprogram body for this
8993 -- purpose. See DEC ac30vso.
8995 -- Should not reference proprietary DEC tests in comments ???
8997 elsif Serious_Errors_Detected = 0
8998 and then Nkind (Parent (Inst_Node)) /= N_Compilation_Unit
9000 if Body_Optional then
9003 elsif Ekind (Anon_Id) = E_Procedure then
9005 Make_Subprogram_Body (Loc,
9007 Make_Procedure_Specification (Loc,
9008 Defining_Unit_Name =>
9009 Make_Defining_Identifier (Loc, Chars (Anon_Id)),
9010 Parameter_Specifications =>
9012 (Parameter_Specifications (Parent (Anon_Id)))),
9014 Declarations => Empty_List,
9015 Handled_Statement_Sequence =>
9016 Make_Handled_Sequence_Of_Statements (Loc,
9019 Make_Raise_Program_Error (Loc,
9021 PE_Access_Before_Elaboration))));
9025 Make_Raise_Program_Error (Loc,
9026 Reason => PE_Access_Before_Elaboration);
9028 Set_Etype (Ret_Expr, (Etype (Anon_Id)));
9029 Set_Analyzed (Ret_Expr);
9032 Make_Subprogram_Body (Loc,
9034 Make_Function_Specification (Loc,
9035 Defining_Unit_Name =>
9036 Make_Defining_Identifier (Loc, Chars (Anon_Id)),
9037 Parameter_Specifications =>
9039 (Parameter_Specifications (Parent (Anon_Id))),
9040 Result_Definition =>
9041 New_Occurrence_Of (Etype (Anon_Id), Loc)),
9043 Declarations => Empty_List,
9044 Handled_Statement_Sequence =>
9045 Make_Handled_Sequence_Of_Statements (Loc,
9048 (Make_Simple_Return_Statement (Loc, Ret_Expr))));
9051 Pack_Body := Make_Package_Body (Loc,
9052 Defining_Unit_Name => New_Copy (Pack_Id),
9053 Declarations => New_List (Act_Body));
9055 Insert_After (Inst_Node, Pack_Body);
9056 Set_Corresponding_Spec (Pack_Body, Pack_Id);
9057 Analyze (Pack_Body);
9060 Expander_Mode_Restore;
9061 end Instantiate_Subprogram_Body;
9063 ----------------------
9064 -- Instantiate_Type --
9065 ----------------------
9067 function Instantiate_Type
9070 Analyzed_Formal : Node_Id;
9071 Actual_Decls : List_Id) return List_Id
9073 Gen_T : constant Entity_Id := Defining_Identifier (Formal);
9074 A_Gen_T : constant Entity_Id :=
9075 Defining_Identifier (Analyzed_Formal);
9076 Ancestor : Entity_Id := Empty;
9077 Def : constant Node_Id := Formal_Type_Definition (Formal);
9079 Decl_Node : Node_Id;
9080 Decl_Nodes : List_Id;
9084 procedure Validate_Array_Type_Instance;
9085 procedure Validate_Access_Subprogram_Instance;
9086 procedure Validate_Access_Type_Instance;
9087 procedure Validate_Derived_Type_Instance;
9088 procedure Validate_Derived_Interface_Type_Instance;
9089 procedure Validate_Interface_Type_Instance;
9090 procedure Validate_Private_Type_Instance;
9091 -- These procedures perform validation tests for the named case
9093 function Subtypes_Match (Gen_T, Act_T : Entity_Id) return Boolean;
9094 -- Check that base types are the same and that the subtypes match
9095 -- statically. Used in several of the above.
9097 --------------------
9098 -- Subtypes_Match --
9099 --------------------
9101 function Subtypes_Match (Gen_T, Act_T : Entity_Id) return Boolean is
9102 T : constant Entity_Id := Get_Instance_Of (Gen_T);
9105 return (Base_Type (T) = Base_Type (Act_T)
9106 and then Subtypes_Statically_Match (T, Act_T))
9108 or else (Is_Class_Wide_Type (Gen_T)
9109 and then Is_Class_Wide_Type (Act_T)
9112 (Get_Instance_Of (Root_Type (Gen_T)),
9116 ((Ekind (Gen_T) = E_Anonymous_Access_Subprogram_Type
9117 or else Ekind (Gen_T) = E_Anonymous_Access_Type)
9118 and then Ekind (Act_T) = Ekind (Gen_T)
9120 Subtypes_Statically_Match
9121 (Designated_Type (Gen_T), Designated_Type (Act_T)));
9124 -----------------------------------------
9125 -- Validate_Access_Subprogram_Instance --
9126 -----------------------------------------
9128 procedure Validate_Access_Subprogram_Instance is
9130 if not Is_Access_Type (Act_T)
9131 or else Ekind (Designated_Type (Act_T)) /= E_Subprogram_Type
9134 ("expect access type in instantiation of &", Actual, Gen_T);
9135 Abandon_Instantiation (Actual);
9138 Check_Mode_Conformant
9139 (Designated_Type (Act_T),
9140 Designated_Type (A_Gen_T),
9144 if Ekind (Base_Type (Act_T)) = E_Access_Protected_Subprogram_Type then
9145 if Ekind (A_Gen_T) = E_Access_Subprogram_Type then
9147 ("protected access type not allowed for formal &",
9151 elsif Ekind (A_Gen_T) = E_Access_Protected_Subprogram_Type then
9153 ("expect protected access type for formal &",
9156 end Validate_Access_Subprogram_Instance;
9158 -----------------------------------
9159 -- Validate_Access_Type_Instance --
9160 -----------------------------------
9162 procedure Validate_Access_Type_Instance is
9163 Desig_Type : constant Entity_Id :=
9164 Find_Actual_Type (Designated_Type (A_Gen_T), A_Gen_T);
9165 Desig_Act : Entity_Id;
9168 if not Is_Access_Type (Act_T) then
9170 ("expect access type in instantiation of &", Actual, Gen_T);
9171 Abandon_Instantiation (Actual);
9174 if Is_Access_Constant (A_Gen_T) then
9175 if not Is_Access_Constant (Act_T) then
9177 ("actual type must be access-to-constant type", Actual);
9178 Abandon_Instantiation (Actual);
9181 if Is_Access_Constant (Act_T) then
9183 ("actual type must be access-to-variable type", Actual);
9184 Abandon_Instantiation (Actual);
9186 elsif Ekind (A_Gen_T) = E_General_Access_Type
9187 and then Ekind (Base_Type (Act_T)) /= E_General_Access_Type
9189 Error_Msg_N ("actual must be general access type!", Actual);
9190 Error_Msg_NE ("add ALL to }!", Actual, Act_T);
9191 Abandon_Instantiation (Actual);
9195 -- The designated subtypes, that is to say the subtypes introduced
9196 -- by an access type declaration (and not by a subtype declaration)
9199 Desig_Act := Designated_Type (Base_Type (Act_T));
9201 -- The designated type may have been introduced through a limited_
9202 -- with clause, in which case retrieve the non-limited view. This
9203 -- applies to incomplete types as well as to class-wide types.
9205 if From_With_Type (Desig_Act) then
9206 Desig_Act := Available_View (Desig_Act);
9209 if not Subtypes_Match
9210 (Desig_Type, Desig_Act) then
9212 ("designated type of actual does not match that of formal &",
9214 Abandon_Instantiation (Actual);
9216 elsif Is_Access_Type (Designated_Type (Act_T))
9217 and then Is_Constrained (Designated_Type (Designated_Type (Act_T)))
9219 Is_Constrained (Designated_Type (Desig_Type))
9222 ("designated type of actual does not match that of formal &",
9224 Abandon_Instantiation (Actual);
9227 -- Ada 2005: null-exclusion indicators of the two types must agree
9229 if Can_Never_Be_Null (A_Gen_T) /= Can_Never_Be_Null (Act_T) then
9231 ("non null exclusion of actual and formal & do not match",
9234 end Validate_Access_Type_Instance;
9236 ----------------------------------
9237 -- Validate_Array_Type_Instance --
9238 ----------------------------------
9240 procedure Validate_Array_Type_Instance is
9245 function Formal_Dimensions return Int;
9246 -- Count number of dimensions in array type formal
9248 -----------------------
9249 -- Formal_Dimensions --
9250 -----------------------
9252 function Formal_Dimensions return Int is
9257 if Nkind (Def) = N_Constrained_Array_Definition then
9258 Index := First (Discrete_Subtype_Definitions (Def));
9260 Index := First (Subtype_Marks (Def));
9263 while Present (Index) loop
9269 end Formal_Dimensions;
9271 -- Start of processing for Validate_Array_Type_Instance
9274 if not Is_Array_Type (Act_T) then
9276 ("expect array type in instantiation of &", Actual, Gen_T);
9277 Abandon_Instantiation (Actual);
9279 elsif Nkind (Def) = N_Constrained_Array_Definition then
9280 if not (Is_Constrained (Act_T)) then
9282 ("expect constrained array in instantiation of &",
9284 Abandon_Instantiation (Actual);
9288 if Is_Constrained (Act_T) then
9290 ("expect unconstrained array in instantiation of &",
9292 Abandon_Instantiation (Actual);
9296 if Formal_Dimensions /= Number_Dimensions (Act_T) then
9298 ("dimensions of actual do not match formal &", Actual, Gen_T);
9299 Abandon_Instantiation (Actual);
9302 I1 := First_Index (A_Gen_T);
9303 I2 := First_Index (Act_T);
9304 for J in 1 .. Formal_Dimensions loop
9306 -- If the indices of the actual were given by a subtype_mark,
9307 -- the index was transformed into a range attribute. Retrieve
9308 -- the original type mark for checking.
9310 if Is_Entity_Name (Original_Node (I2)) then
9311 T2 := Entity (Original_Node (I2));
9316 if not Subtypes_Match
9317 (Find_Actual_Type (Etype (I1), A_Gen_T), T2)
9320 ("index types of actual do not match those of formal &",
9322 Abandon_Instantiation (Actual);
9329 -- Check matching subtypes. Note that there are complex visibility
9330 -- issues when the generic is a child unit and some aspect of the
9331 -- generic type is declared in a parent unit of the generic. We do
9332 -- the test to handle this special case only after a direct check
9333 -- for static matching has failed.
9336 (Component_Type (A_Gen_T), Component_Type (Act_T))
9337 or else Subtypes_Match
9338 (Find_Actual_Type (Component_Type (A_Gen_T), A_Gen_T),
9339 Component_Type (Act_T))
9344 ("component subtype of actual does not match that of formal &",
9346 Abandon_Instantiation (Actual);
9349 if Has_Aliased_Components (A_Gen_T)
9350 and then not Has_Aliased_Components (Act_T)
9353 ("actual must have aliased components to match formal type &",
9356 end Validate_Array_Type_Instance;
9358 -----------------------------------------------
9359 -- Validate_Derived_Interface_Type_Instance --
9360 -----------------------------------------------
9362 procedure Validate_Derived_Interface_Type_Instance is
9363 Par : constant Entity_Id := Entity (Subtype_Indication (Def));
9367 -- First apply interface instance checks
9369 Validate_Interface_Type_Instance;
9371 -- Verify that immediate parent interface is an ancestor of
9375 and then not Interface_Present_In_Ancestor (Act_T, Par)
9378 ("interface actual must include progenitor&", Actual, Par);
9381 -- Now verify that the actual includes all other ancestors of
9384 Elmt := First_Elmt (Interfaces (A_Gen_T));
9385 while Present (Elmt) loop
9386 if not Interface_Present_In_Ancestor
9387 (Act_T, Get_Instance_Of (Node (Elmt)))
9390 ("interface actual must include progenitor&",
9391 Actual, Node (Elmt));
9396 end Validate_Derived_Interface_Type_Instance;
9398 ------------------------------------
9399 -- Validate_Derived_Type_Instance --
9400 ------------------------------------
9402 procedure Validate_Derived_Type_Instance is
9403 Actual_Discr : Entity_Id;
9404 Ancestor_Discr : Entity_Id;
9407 -- If the parent type in the generic declaration is itself a previous
9408 -- formal type, then it is local to the generic and absent from the
9409 -- analyzed generic definition. In that case the ancestor is the
9410 -- instance of the formal (which must have been instantiated
9411 -- previously), unless the ancestor is itself a formal derived type.
9412 -- In this latter case (which is the subject of Corrigendum 8652/0038
9413 -- (AI-202) the ancestor of the formals is the ancestor of its
9414 -- parent. Otherwise, the analyzed generic carries the parent type.
9415 -- If the parent type is defined in a previous formal package, then
9416 -- the scope of that formal package is that of the generic type
9417 -- itself, and it has already been mapped into the corresponding type
9418 -- in the actual package.
9420 -- Common case: parent type defined outside of the generic
9422 if Is_Entity_Name (Subtype_Mark (Def))
9423 and then Present (Entity (Subtype_Mark (Def)))
9425 Ancestor := Get_Instance_Of (Entity (Subtype_Mark (Def)));
9427 -- Check whether parent is defined in a previous formal package
9430 Scope (Scope (Base_Type (Etype (A_Gen_T)))) = Scope (A_Gen_T)
9433 Get_Instance_Of (Base_Type (Etype (A_Gen_T)));
9435 -- The type may be a local derivation, or a type extension of a
9436 -- previous formal, or of a formal of a parent package.
9438 elsif Is_Derived_Type (Get_Instance_Of (A_Gen_T))
9440 Ekind (Get_Instance_Of (A_Gen_T)) = E_Record_Type_With_Private
9442 -- Check whether the parent is another derived formal type in the
9443 -- same generic unit.
9445 if Etype (A_Gen_T) /= A_Gen_T
9446 and then Is_Generic_Type (Etype (A_Gen_T))
9447 and then Scope (Etype (A_Gen_T)) = Scope (A_Gen_T)
9448 and then Etype (Etype (A_Gen_T)) /= Etype (A_Gen_T)
9450 -- Locate ancestor of parent from the subtype declaration
9451 -- created for the actual.
9457 Decl := First (Actual_Decls);
9458 while Present (Decl) loop
9459 if Nkind (Decl) = N_Subtype_Declaration
9460 and then Chars (Defining_Identifier (Decl)) =
9461 Chars (Etype (A_Gen_T))
9463 Ancestor := Generic_Parent_Type (Decl);
9471 pragma Assert (Present (Ancestor));
9475 Get_Instance_Of (Base_Type (Get_Instance_Of (A_Gen_T)));
9479 Ancestor := Get_Instance_Of (Etype (Base_Type (A_Gen_T)));
9482 -- If the formal derived type has pragma Preelaborable_Initialization
9483 -- then the actual type must have preelaborable initialization.
9485 if Known_To_Have_Preelab_Init (A_Gen_T)
9486 and then not Has_Preelaborable_Initialization (Act_T)
9489 ("actual for & must have preelaborable initialization",
9493 -- Ada 2005 (AI-251)
9495 if Ada_Version >= Ada_05
9496 and then Is_Interface (Ancestor)
9498 if not Interface_Present_In_Ancestor (Act_T, Ancestor) then
9500 ("(Ada 2005) expected type implementing & in instantiation",
9504 elsif not Is_Ancestor (Base_Type (Ancestor), Act_T) then
9506 ("expect type derived from & in instantiation",
9507 Actual, First_Subtype (Ancestor));
9508 Abandon_Instantiation (Actual);
9511 -- Ada 2005 (AI-443): Synchronized formal derived type checks. Note
9512 -- that the formal type declaration has been rewritten as a private
9515 if Ada_Version >= Ada_05
9516 and then Nkind (Parent (A_Gen_T)) = N_Private_Extension_Declaration
9517 and then Synchronized_Present (Parent (A_Gen_T))
9519 -- The actual must be a synchronized tagged type
9521 if not Is_Tagged_Type (Act_T) then
9523 ("actual of synchronized type must be tagged", Actual);
9524 Abandon_Instantiation (Actual);
9526 elsif Nkind (Parent (Act_T)) = N_Full_Type_Declaration
9527 and then Nkind (Type_Definition (Parent (Act_T))) =
9528 N_Derived_Type_Definition
9529 and then not Synchronized_Present (Type_Definition
9533 ("actual of synchronized type must be synchronized", Actual);
9534 Abandon_Instantiation (Actual);
9538 -- Perform atomic/volatile checks (RM C.6(12))
9540 if Is_Atomic (Act_T) and then not Is_Atomic (Ancestor) then
9542 ("cannot have atomic actual type for non-atomic formal type",
9545 elsif Is_Volatile (Act_T)
9546 and then not Is_Volatile (Ancestor)
9547 and then Is_By_Reference_Type (Ancestor)
9550 ("cannot have volatile actual type for non-volatile formal type",
9554 -- It should not be necessary to check for unknown discriminants on
9555 -- Formal, but for some reason Has_Unknown_Discriminants is false for
9556 -- A_Gen_T, so Is_Indefinite_Subtype incorrectly returns False. This
9557 -- needs fixing. ???
9559 if not Is_Indefinite_Subtype (A_Gen_T)
9560 and then not Unknown_Discriminants_Present (Formal)
9561 and then Is_Indefinite_Subtype (Act_T)
9564 ("actual subtype must be constrained", Actual);
9565 Abandon_Instantiation (Actual);
9568 if not Unknown_Discriminants_Present (Formal) then
9569 if Is_Constrained (Ancestor) then
9570 if not Is_Constrained (Act_T) then
9572 ("actual subtype must be constrained", Actual);
9573 Abandon_Instantiation (Actual);
9576 -- Ancestor is unconstrained, Check if generic formal and actual
9577 -- agree on constrainedness. The check only applies to array types
9578 -- and discriminated types.
9580 elsif Is_Constrained (Act_T) then
9581 if Ekind (Ancestor) = E_Access_Type
9583 (not Is_Constrained (A_Gen_T)
9584 and then Is_Composite_Type (A_Gen_T))
9587 ("actual subtype must be unconstrained", Actual);
9588 Abandon_Instantiation (Actual);
9591 -- A class-wide type is only allowed if the formal has unknown
9594 elsif Is_Class_Wide_Type (Act_T)
9595 and then not Has_Unknown_Discriminants (Ancestor)
9598 ("actual for & cannot be a class-wide type", Actual, Gen_T);
9599 Abandon_Instantiation (Actual);
9601 -- Otherwise, the formal and actual shall have the same number
9602 -- of discriminants and each discriminant of the actual must
9603 -- correspond to a discriminant of the formal.
9605 elsif Has_Discriminants (Act_T)
9606 and then not Has_Unknown_Discriminants (Act_T)
9607 and then Has_Discriminants (Ancestor)
9609 Actual_Discr := First_Discriminant (Act_T);
9610 Ancestor_Discr := First_Discriminant (Ancestor);
9611 while Present (Actual_Discr)
9612 and then Present (Ancestor_Discr)
9614 if Base_Type (Act_T) /= Base_Type (Ancestor) and then
9615 No (Corresponding_Discriminant (Actual_Discr))
9618 ("discriminant & does not correspond " &
9619 "to ancestor discriminant", Actual, Actual_Discr);
9620 Abandon_Instantiation (Actual);
9623 Next_Discriminant (Actual_Discr);
9624 Next_Discriminant (Ancestor_Discr);
9627 if Present (Actual_Discr) or else Present (Ancestor_Discr) then
9629 ("actual for & must have same number of discriminants",
9631 Abandon_Instantiation (Actual);
9634 -- This case should be caught by the earlier check for
9635 -- constrainedness, but the check here is added for completeness.
9637 elsif Has_Discriminants (Act_T)
9638 and then not Has_Unknown_Discriminants (Act_T)
9641 ("actual for & must not have discriminants", Actual, Gen_T);
9642 Abandon_Instantiation (Actual);
9644 elsif Has_Discriminants (Ancestor) then
9646 ("actual for & must have known discriminants", Actual, Gen_T);
9647 Abandon_Instantiation (Actual);
9650 if not Subtypes_Statically_Compatible (Act_T, Ancestor) then
9652 ("constraint on actual is incompatible with formal", Actual);
9653 Abandon_Instantiation (Actual);
9657 -- If the formal and actual types are abstract, check that there
9658 -- are no abstract primitives of the actual type that correspond to
9659 -- nonabstract primitives of the formal type (second sentence of
9662 if Is_Abstract_Type (A_Gen_T) and then Is_Abstract_Type (Act_T) then
9663 Check_Abstract_Primitives : declare
9664 Gen_Prims : constant Elist_Id :=
9665 Primitive_Operations (A_Gen_T);
9667 Gen_Subp : Entity_Id;
9668 Anc_Subp : Entity_Id;
9669 Anc_Formal : Entity_Id;
9670 Anc_F_Type : Entity_Id;
9672 Act_Prims : constant Elist_Id := Primitive_Operations (Act_T);
9674 Act_Subp : Entity_Id;
9675 Act_Formal : Entity_Id;
9676 Act_F_Type : Entity_Id;
9678 Subprograms_Correspond : Boolean;
9680 function Is_Tagged_Ancestor (T1, T2 : Entity_Id) return Boolean;
9681 -- Returns true if T2 is derived directly or indirectly from
9682 -- T1, including derivations from interfaces. T1 and T2 are
9683 -- required to be specific tagged base types.
9685 ------------------------
9686 -- Is_Tagged_Ancestor --
9687 ------------------------
9689 function Is_Tagged_Ancestor (T1, T2 : Entity_Id) return Boolean
9691 Intfc_Elmt : Elmt_Id;
9694 -- The predicate is satisfied if the types are the same
9699 -- If we've reached the top of the derivation chain then
9700 -- we know that T1 is not an ancestor of T2.
9702 elsif Etype (T2) = T2 then
9705 -- Proceed to check T2's immediate parent
9707 elsif Is_Ancestor (T1, Base_Type (Etype (T2))) then
9710 -- Finally, check to see if T1 is an ancestor of any of T2's
9714 Intfc_Elmt := First_Elmt (Interfaces (T2));
9715 while Present (Intfc_Elmt) loop
9716 if Is_Ancestor (T1, Node (Intfc_Elmt)) then
9720 Next_Elmt (Intfc_Elmt);
9725 end Is_Tagged_Ancestor;
9727 -- Start of processing for Check_Abstract_Primitives
9730 -- Loop over all of the formal derived type's primitives
9732 Gen_Elmt := First_Elmt (Gen_Prims);
9733 while Present (Gen_Elmt) loop
9734 Gen_Subp := Node (Gen_Elmt);
9736 -- If the primitive of the formal is not abstract, then
9737 -- determine whether there is a corresponding primitive of
9738 -- the actual type that's abstract.
9740 if not Is_Abstract_Subprogram (Gen_Subp) then
9741 Act_Elmt := First_Elmt (Act_Prims);
9742 while Present (Act_Elmt) loop
9743 Act_Subp := Node (Act_Elmt);
9745 -- If we find an abstract primitive of the actual,
9746 -- then we need to test whether it corresponds to the
9747 -- subprogram from which the generic formal primitive
9750 if Is_Abstract_Subprogram (Act_Subp) then
9751 Anc_Subp := Alias (Gen_Subp);
9753 -- Test whether we have a corresponding primitive
9754 -- by comparing names, kinds, formal types, and
9757 if Chars (Anc_Subp) = Chars (Act_Subp)
9758 and then Ekind (Anc_Subp) = Ekind (Act_Subp)
9760 Anc_Formal := First_Formal (Anc_Subp);
9761 Act_Formal := First_Formal (Act_Subp);
9762 while Present (Anc_Formal)
9763 and then Present (Act_Formal)
9765 Anc_F_Type := Etype (Anc_Formal);
9766 Act_F_Type := Etype (Act_Formal);
9768 if Ekind (Anc_F_Type)
9769 = E_Anonymous_Access_Type
9771 Anc_F_Type := Designated_Type (Anc_F_Type);
9773 if Ekind (Act_F_Type)
9774 = E_Anonymous_Access_Type
9777 Designated_Type (Act_F_Type);
9783 Ekind (Act_F_Type) = E_Anonymous_Access_Type
9788 Anc_F_Type := Base_Type (Anc_F_Type);
9789 Act_F_Type := Base_Type (Act_F_Type);
9791 -- If the formal is controlling, then the
9792 -- the type of the actual primitive's formal
9793 -- must be derived directly or indirectly
9794 -- from the type of the ancestor primitive's
9797 if Is_Controlling_Formal (Anc_Formal) then
9798 if not Is_Tagged_Ancestor
9799 (Anc_F_Type, Act_F_Type)
9804 -- Otherwise the types of the formals must
9807 elsif Anc_F_Type /= Act_F_Type then
9811 Next_Entity (Anc_Formal);
9812 Next_Entity (Act_Formal);
9815 -- If we traversed through all of the formals
9816 -- then so far the subprograms correspond, so
9817 -- now check that any result types correspond.
9820 and then No (Act_Formal)
9822 Subprograms_Correspond := True;
9824 if Ekind (Act_Subp) = E_Function then
9825 Anc_F_Type := Etype (Anc_Subp);
9826 Act_F_Type := Etype (Act_Subp);
9828 if Ekind (Anc_F_Type)
9829 = E_Anonymous_Access_Type
9832 Designated_Type (Anc_F_Type);
9834 if Ekind (Act_F_Type)
9835 = E_Anonymous_Access_Type
9838 Designated_Type (Act_F_Type);
9840 Subprograms_Correspond := False;
9845 = E_Anonymous_Access_Type
9847 Subprograms_Correspond := False;
9850 Anc_F_Type := Base_Type (Anc_F_Type);
9851 Act_F_Type := Base_Type (Act_F_Type);
9853 -- Now either the result types must be
9854 -- the same or, if the result type is
9855 -- controlling, the result type of the
9856 -- actual primitive must descend from the
9857 -- result type of the ancestor primitive.
9859 if Subprograms_Correspond
9860 and then Anc_F_Type /= Act_F_Type
9862 Has_Controlling_Result (Anc_Subp)
9864 not Is_Tagged_Ancestor
9865 (Anc_F_Type, Act_F_Type)
9867 Subprograms_Correspond := False;
9871 -- Found a matching subprogram belonging to
9872 -- formal ancestor type, so actual subprogram
9873 -- corresponds and this violates 3.9.3(9).
9875 if Subprograms_Correspond then
9877 ("abstract subprogram & overrides " &
9878 "nonabstract subprogram of ancestor",
9886 Next_Elmt (Act_Elmt);
9890 Next_Elmt (Gen_Elmt);
9892 end Check_Abstract_Primitives;
9895 -- Verify that limitedness matches. If parent is a limited
9896 -- interface then the generic formal is not unless declared
9897 -- explicitly so. If not declared limited, the actual cannot be
9898 -- limited (see AI05-0087).
9899 -- Disable check for now, limited interfaces implemented by
9900 -- protected types are common, Need to update tests ???
9902 if Is_Limited_Type (Act_T)
9903 and then not Is_Limited_Type (A_Gen_T)
9907 ("actual for non-limited & cannot be a limited type", Actual,
9909 Explain_Limited_Type (Act_T, Actual);
9910 Abandon_Instantiation (Actual);
9912 end Validate_Derived_Type_Instance;
9914 --------------------------------------
9915 -- Validate_Interface_Type_Instance --
9916 --------------------------------------
9918 procedure Validate_Interface_Type_Instance is
9920 if not Is_Interface (Act_T) then
9922 ("actual for formal interface type must be an interface",
9925 elsif Is_Limited_Type (Act_T) /= Is_Limited_Type (A_Gen_T)
9927 Is_Task_Interface (A_Gen_T) /= Is_Task_Interface (Act_T)
9929 Is_Protected_Interface (A_Gen_T) /=
9930 Is_Protected_Interface (Act_T)
9932 Is_Synchronized_Interface (A_Gen_T) /=
9933 Is_Synchronized_Interface (Act_T)
9936 ("actual for interface& does not match (RM 12.5.5(4))",
9939 end Validate_Interface_Type_Instance;
9941 ------------------------------------
9942 -- Validate_Private_Type_Instance --
9943 ------------------------------------
9945 procedure Validate_Private_Type_Instance is
9946 Formal_Discr : Entity_Id;
9947 Actual_Discr : Entity_Id;
9948 Formal_Subt : Entity_Id;
9951 if Is_Limited_Type (Act_T)
9952 and then not Is_Limited_Type (A_Gen_T)
9955 ("actual for non-limited & cannot be a limited type", Actual,
9957 Explain_Limited_Type (Act_T, Actual);
9958 Abandon_Instantiation (Actual);
9960 elsif Known_To_Have_Preelab_Init (A_Gen_T)
9961 and then not Has_Preelaborable_Initialization (Act_T)
9964 ("actual for & must have preelaborable initialization", Actual,
9967 elsif Is_Indefinite_Subtype (Act_T)
9968 and then not Is_Indefinite_Subtype (A_Gen_T)
9969 and then Ada_Version >= Ada_95
9972 ("actual for & must be a definite subtype", Actual, Gen_T);
9974 elsif not Is_Tagged_Type (Act_T)
9975 and then Is_Tagged_Type (A_Gen_T)
9978 ("actual for & must be a tagged type", Actual, Gen_T);
9980 elsif Has_Discriminants (A_Gen_T) then
9981 if not Has_Discriminants (Act_T) then
9983 ("actual for & must have discriminants", Actual, Gen_T);
9984 Abandon_Instantiation (Actual);
9986 elsif Is_Constrained (Act_T) then
9988 ("actual for & must be unconstrained", Actual, Gen_T);
9989 Abandon_Instantiation (Actual);
9992 Formal_Discr := First_Discriminant (A_Gen_T);
9993 Actual_Discr := First_Discriminant (Act_T);
9994 while Formal_Discr /= Empty loop
9995 if Actual_Discr = Empty then
9997 ("discriminants on actual do not match formal",
9999 Abandon_Instantiation (Actual);
10002 Formal_Subt := Get_Instance_Of (Etype (Formal_Discr));
10004 -- Access discriminants match if designated types do
10006 if Ekind (Base_Type (Formal_Subt)) = E_Anonymous_Access_Type
10007 and then (Ekind (Base_Type (Etype (Actual_Discr)))) =
10008 E_Anonymous_Access_Type
10011 (Designated_Type (Base_Type (Formal_Subt))) =
10012 Designated_Type (Base_Type (Etype (Actual_Discr)))
10016 elsif Base_Type (Formal_Subt) /=
10017 Base_Type (Etype (Actual_Discr))
10020 ("types of actual discriminants must match formal",
10022 Abandon_Instantiation (Actual);
10024 elsif not Subtypes_Statically_Match
10025 (Formal_Subt, Etype (Actual_Discr))
10026 and then Ada_Version >= Ada_95
10029 ("subtypes of actual discriminants must match formal",
10031 Abandon_Instantiation (Actual);
10034 Next_Discriminant (Formal_Discr);
10035 Next_Discriminant (Actual_Discr);
10038 if Actual_Discr /= Empty then
10040 ("discriminants on actual do not match formal",
10042 Abandon_Instantiation (Actual);
10049 end Validate_Private_Type_Instance;
10051 -- Start of processing for Instantiate_Type
10054 if Get_Instance_Of (A_Gen_T) /= A_Gen_T then
10055 Error_Msg_N ("duplicate instantiation of generic type", Actual);
10056 return New_List (Error);
10058 elsif not Is_Entity_Name (Actual)
10059 or else not Is_Type (Entity (Actual))
10062 ("expect valid subtype mark to instantiate &", Actual, Gen_T);
10063 Abandon_Instantiation (Actual);
10066 Act_T := Entity (Actual);
10068 -- Ada 2005 (AI-216): An Unchecked_Union subtype shall only be passed
10069 -- as a generic actual parameter if the corresponding formal type
10070 -- does not have a known_discriminant_part, or is a formal derived
10071 -- type that is an Unchecked_Union type.
10073 if Is_Unchecked_Union (Base_Type (Act_T)) then
10074 if not Has_Discriminants (A_Gen_T)
10076 (Is_Derived_Type (A_Gen_T)
10078 Is_Unchecked_Union (A_Gen_T))
10082 Error_Msg_N ("Unchecked_Union cannot be the actual for a" &
10083 " discriminated formal type", Act_T);
10088 -- Deal with fixed/floating restrictions
10090 if Is_Floating_Point_Type (Act_T) then
10091 Check_Restriction (No_Floating_Point, Actual);
10092 elsif Is_Fixed_Point_Type (Act_T) then
10093 Check_Restriction (No_Fixed_Point, Actual);
10096 -- Deal with error of using incomplete type as generic actual.
10097 -- This includes limited views of a type, even if the non-limited
10098 -- view may be available.
10100 if Ekind (Act_T) = E_Incomplete_Type
10101 or else (Is_Class_Wide_Type (Act_T)
10103 Ekind (Root_Type (Act_T)) = E_Incomplete_Type)
10105 if Is_Class_Wide_Type (Act_T)
10106 or else No (Full_View (Act_T))
10108 Error_Msg_N ("premature use of incomplete type", Actual);
10109 Abandon_Instantiation (Actual);
10111 Act_T := Full_View (Act_T);
10112 Set_Entity (Actual, Act_T);
10114 if Has_Private_Component (Act_T) then
10116 ("premature use of type with private component", Actual);
10120 -- Deal with error of premature use of private type as generic actual
10122 elsif Is_Private_Type (Act_T)
10123 and then Is_Private_Type (Base_Type (Act_T))
10124 and then not Is_Generic_Type (Act_T)
10125 and then not Is_Derived_Type (Act_T)
10126 and then No (Full_View (Root_Type (Act_T)))
10128 Error_Msg_N ("premature use of private type", Actual);
10130 elsif Has_Private_Component (Act_T) then
10132 ("premature use of type with private component", Actual);
10135 Set_Instance_Of (A_Gen_T, Act_T);
10137 -- If the type is generic, the class-wide type may also be used
10139 if Is_Tagged_Type (A_Gen_T)
10140 and then Is_Tagged_Type (Act_T)
10141 and then not Is_Class_Wide_Type (A_Gen_T)
10143 Set_Instance_Of (Class_Wide_Type (A_Gen_T),
10144 Class_Wide_Type (Act_T));
10147 if not Is_Abstract_Type (A_Gen_T)
10148 and then Is_Abstract_Type (Act_T)
10151 ("actual of non-abstract formal cannot be abstract", Actual);
10154 -- A generic scalar type is a first subtype for which we generate
10155 -- an anonymous base type. Indicate that the instance of this base
10156 -- is the base type of the actual.
10158 if Is_Scalar_Type (A_Gen_T) then
10159 Set_Instance_Of (Etype (A_Gen_T), Etype (Act_T));
10163 if Error_Posted (Act_T) then
10166 case Nkind (Def) is
10167 when N_Formal_Private_Type_Definition =>
10168 Validate_Private_Type_Instance;
10170 when N_Formal_Derived_Type_Definition =>
10171 Validate_Derived_Type_Instance;
10173 when N_Formal_Discrete_Type_Definition =>
10174 if not Is_Discrete_Type (Act_T) then
10176 ("expect discrete type in instantiation of&",
10178 Abandon_Instantiation (Actual);
10181 when N_Formal_Signed_Integer_Type_Definition =>
10182 if not Is_Signed_Integer_Type (Act_T) then
10184 ("expect signed integer type in instantiation of&",
10186 Abandon_Instantiation (Actual);
10189 when N_Formal_Modular_Type_Definition =>
10190 if not Is_Modular_Integer_Type (Act_T) then
10192 ("expect modular type in instantiation of &",
10194 Abandon_Instantiation (Actual);
10197 when N_Formal_Floating_Point_Definition =>
10198 if not Is_Floating_Point_Type (Act_T) then
10200 ("expect float type in instantiation of &", Actual, Gen_T);
10201 Abandon_Instantiation (Actual);
10204 when N_Formal_Ordinary_Fixed_Point_Definition =>
10205 if not Is_Ordinary_Fixed_Point_Type (Act_T) then
10207 ("expect ordinary fixed point type in instantiation of &",
10209 Abandon_Instantiation (Actual);
10212 when N_Formal_Decimal_Fixed_Point_Definition =>
10213 if not Is_Decimal_Fixed_Point_Type (Act_T) then
10215 ("expect decimal type in instantiation of &",
10217 Abandon_Instantiation (Actual);
10220 when N_Array_Type_Definition =>
10221 Validate_Array_Type_Instance;
10223 when N_Access_To_Object_Definition =>
10224 Validate_Access_Type_Instance;
10226 when N_Access_Function_Definition |
10227 N_Access_Procedure_Definition =>
10228 Validate_Access_Subprogram_Instance;
10230 when N_Record_Definition =>
10231 Validate_Interface_Type_Instance;
10233 when N_Derived_Type_Definition =>
10234 Validate_Derived_Interface_Type_Instance;
10237 raise Program_Error;
10242 Subt := New_Copy (Gen_T);
10244 -- Use adjusted sloc of subtype name as the location for other nodes in
10245 -- the subtype declaration.
10247 Loc := Sloc (Subt);
10250 Make_Subtype_Declaration (Loc,
10251 Defining_Identifier => Subt,
10252 Subtype_Indication => New_Reference_To (Act_T, Loc));
10254 if Is_Private_Type (Act_T) then
10255 Set_Has_Private_View (Subtype_Indication (Decl_Node));
10257 elsif Is_Access_Type (Act_T)
10258 and then Is_Private_Type (Designated_Type (Act_T))
10260 Set_Has_Private_View (Subtype_Indication (Decl_Node));
10263 Decl_Nodes := New_List (Decl_Node);
10265 -- Flag actual derived types so their elaboration produces the
10266 -- appropriate renamings for the primitive operations of the ancestor.
10267 -- Flag actual for formal private types as well, to determine whether
10268 -- operations in the private part may override inherited operations.
10269 -- If the formal has an interface list, the ancestor is not the
10270 -- parent, but the analyzed formal that includes the interface
10271 -- operations of all its progenitors.
10273 if Nkind (Def) = N_Formal_Derived_Type_Definition then
10274 if Present (Interface_List (Def)) then
10275 Set_Generic_Parent_Type (Decl_Node, A_Gen_T);
10277 Set_Generic_Parent_Type (Decl_Node, Ancestor);
10280 elsif Nkind (Def) = N_Formal_Private_Type_Definition then
10281 Set_Generic_Parent_Type (Decl_Node, Ancestor);
10284 -- If the actual is a synchronized type that implements an interface,
10285 -- the primitive operations are attached to the corresponding record,
10286 -- and we have to treat it as an additional generic actual, so that its
10287 -- primitive operations become visible in the instance. The task or
10288 -- protected type itself does not carry primitive operations.
10290 if Is_Concurrent_Type (Act_T)
10291 and then Is_Tagged_Type (Act_T)
10292 and then Present (Corresponding_Record_Type (Act_T))
10293 and then Present (Ancestor)
10294 and then Is_Interface (Ancestor)
10297 Corr_Rec : constant Entity_Id :=
10298 Corresponding_Record_Type (Act_T);
10299 New_Corr : Entity_Id;
10300 Corr_Decl : Node_Id;
10303 New_Corr := Make_Defining_Identifier (Loc,
10304 Chars => New_Internal_Name ('S'));
10306 Make_Subtype_Declaration (Loc,
10307 Defining_Identifier => New_Corr,
10308 Subtype_Indication =>
10309 New_Reference_To (Corr_Rec, Loc));
10310 Append_To (Decl_Nodes, Corr_Decl);
10312 if Ekind (Act_T) = E_Task_Type then
10313 Set_Ekind (Subt, E_Task_Subtype);
10315 Set_Ekind (Subt, E_Protected_Subtype);
10318 Set_Corresponding_Record_Type (Subt, Corr_Rec);
10319 Set_Generic_Parent_Type (Corr_Decl, Ancestor);
10320 Set_Generic_Parent_Type (Decl_Node, Empty);
10325 end Instantiate_Type;
10327 -----------------------
10328 -- Is_Generic_Formal --
10329 -----------------------
10331 function Is_Generic_Formal (E : Entity_Id) return Boolean is
10337 Kind := Nkind (Parent (E));
10339 Nkind_In (Kind, N_Formal_Object_Declaration,
10340 N_Formal_Package_Declaration,
10341 N_Formal_Type_Declaration)
10343 (Is_Formal_Subprogram (E)
10345 Nkind (Parent (Parent (E))) in
10346 N_Formal_Subprogram_Declaration);
10348 end Is_Generic_Formal;
10350 ---------------------
10351 -- Is_In_Main_Unit --
10352 ---------------------
10354 function Is_In_Main_Unit (N : Node_Id) return Boolean is
10355 Unum : constant Unit_Number_Type := Get_Source_Unit (N);
10356 Current_Unit : Node_Id;
10359 if Unum = Main_Unit then
10362 -- If the current unit is a subunit then it is either the main unit or
10363 -- is being compiled as part of the main unit.
10365 elsif Nkind (N) = N_Compilation_Unit then
10366 return Nkind (Unit (N)) = N_Subunit;
10369 Current_Unit := Parent (N);
10370 while Present (Current_Unit)
10371 and then Nkind (Current_Unit) /= N_Compilation_Unit
10373 Current_Unit := Parent (Current_Unit);
10376 -- The instantiation node is in the main unit, or else the current node
10377 -- (perhaps as the result of nested instantiations) is in the main unit,
10378 -- or in the declaration of the main unit, which in this last case must
10381 return Unum = Main_Unit
10382 or else Current_Unit = Cunit (Main_Unit)
10383 or else Current_Unit = Library_Unit (Cunit (Main_Unit))
10384 or else (Present (Library_Unit (Current_Unit))
10385 and then Is_In_Main_Unit (Library_Unit (Current_Unit)));
10386 end Is_In_Main_Unit;
10388 ----------------------------
10389 -- Load_Parent_Of_Generic --
10390 ----------------------------
10392 procedure Load_Parent_Of_Generic
10395 Body_Optional : Boolean := False)
10397 Comp_Unit : constant Node_Id := Cunit (Get_Source_Unit (Spec));
10398 Save_Style_Check : constant Boolean := Style_Check;
10399 True_Parent : Node_Id;
10400 Inst_Node : Node_Id;
10402 Previous_Instances : constant Elist_Id := New_Elmt_List;
10404 procedure Collect_Previous_Instances (Decls : List_Id);
10405 -- Collect all instantiations in the given list of declarations, that
10406 -- precede the generic that we need to load. If the bodies of these
10407 -- instantiations are available, we must analyze them, to ensure that
10408 -- the public symbols generated are the same when the unit is compiled
10409 -- to generate code, and when it is compiled in the context of a unit
10410 -- that needs a particular nested instance. This process is applied
10411 -- to both package and subprogram instances.
10413 --------------------------------
10414 -- Collect_Previous_Instances --
10415 --------------------------------
10417 procedure Collect_Previous_Instances (Decls : List_Id) is
10421 Decl := First (Decls);
10422 while Present (Decl) loop
10423 if Sloc (Decl) >= Sloc (Inst_Node) then
10426 -- If Decl is an instantiation, then record it as requiring
10427 -- instantiation of the corresponding body, except if it is an
10428 -- abbreviated instantiation generated internally for conformance
10429 -- checking purposes only for the case of a formal package
10430 -- declared without a box (see Instantiate_Formal_Package). Such
10431 -- an instantiation does not generate any code (the actual code
10432 -- comes from actual) and thus does not need to be analyzed here.
10434 elsif Nkind (Decl) = N_Package_Instantiation
10435 and then not Is_Internal (Defining_Entity (Decl))
10437 Append_Elmt (Decl, Previous_Instances);
10439 -- For a subprogram instantiation, omit instantiations of
10440 -- intrinsic operations (Unchecked_Conversions, etc.) that
10443 elsif Nkind_In (Decl, N_Function_Instantiation,
10444 N_Procedure_Instantiation)
10445 and then not Is_Intrinsic_Subprogram (Entity (Name (Decl)))
10447 Append_Elmt (Decl, Previous_Instances);
10449 elsif Nkind (Decl) = N_Package_Declaration then
10450 Collect_Previous_Instances
10451 (Visible_Declarations (Specification (Decl)));
10452 Collect_Previous_Instances
10453 (Private_Declarations (Specification (Decl)));
10455 elsif Nkind (Decl) = N_Package_Body then
10456 Collect_Previous_Instances (Declarations (Decl));
10461 end Collect_Previous_Instances;
10463 -- Start of processing for Load_Parent_Of_Generic
10466 if not In_Same_Source_Unit (N, Spec)
10467 or else Nkind (Unit (Comp_Unit)) = N_Package_Declaration
10468 or else (Nkind (Unit (Comp_Unit)) = N_Package_Body
10469 and then not Is_In_Main_Unit (Spec))
10471 -- Find body of parent of spec, and analyze it. A special case arises
10472 -- when the parent is an instantiation, that is to say when we are
10473 -- currently instantiating a nested generic. In that case, there is
10474 -- no separate file for the body of the enclosing instance. Instead,
10475 -- the enclosing body must be instantiated as if it were a pending
10476 -- instantiation, in order to produce the body for the nested generic
10477 -- we require now. Note that in that case the generic may be defined
10478 -- in a package body, the instance defined in the same package body,
10479 -- and the original enclosing body may not be in the main unit.
10481 Inst_Node := Empty;
10483 True_Parent := Parent (Spec);
10484 while Present (True_Parent)
10485 and then Nkind (True_Parent) /= N_Compilation_Unit
10487 if Nkind (True_Parent) = N_Package_Declaration
10489 Nkind (Original_Node (True_Parent)) = N_Package_Instantiation
10491 -- Parent is a compilation unit that is an instantiation.
10492 -- Instantiation node has been replaced with package decl.
10494 Inst_Node := Original_Node (True_Parent);
10497 elsif Nkind (True_Parent) = N_Package_Declaration
10498 and then Present (Generic_Parent (Specification (True_Parent)))
10499 and then Nkind (Parent (True_Parent)) /= N_Compilation_Unit
10501 -- Parent is an instantiation within another specification.
10502 -- Declaration for instance has been inserted before original
10503 -- instantiation node. A direct link would be preferable?
10505 Inst_Node := Next (True_Parent);
10506 while Present (Inst_Node)
10507 and then Nkind (Inst_Node) /= N_Package_Instantiation
10512 -- If the instance appears within a generic, and the generic
10513 -- unit is defined within a formal package of the enclosing
10514 -- generic, there is no generic body available, and none
10515 -- needed. A more precise test should be used ???
10517 if No (Inst_Node) then
10524 True_Parent := Parent (True_Parent);
10528 -- Case where we are currently instantiating a nested generic
10530 if Present (Inst_Node) then
10531 if Nkind (Parent (True_Parent)) = N_Compilation_Unit then
10533 -- Instantiation node and declaration of instantiated package
10534 -- were exchanged when only the declaration was needed.
10535 -- Restore instantiation node before proceeding with body.
10537 Set_Unit (Parent (True_Parent), Inst_Node);
10540 -- Now complete instantiation of enclosing body, if it appears
10541 -- in some other unit. If it appears in the current unit, the
10542 -- body will have been instantiated already.
10544 if No (Corresponding_Body (Instance_Spec (Inst_Node))) then
10546 -- We need to determine the expander mode to instantiate the
10547 -- enclosing body. Because the generic body we need may use
10548 -- global entities declared in the enclosing package (including
10549 -- aggregates) it is in general necessary to compile this body
10550 -- with expansion enabled. The exception is if we are within a
10551 -- generic package, in which case the usual generic rule
10555 Exp_Status : Boolean := True;
10559 -- Loop through scopes looking for generic package
10561 Scop := Scope (Defining_Entity (Instance_Spec (Inst_Node)));
10562 while Present (Scop)
10563 and then Scop /= Standard_Standard
10565 if Ekind (Scop) = E_Generic_Package then
10566 Exp_Status := False;
10570 Scop := Scope (Scop);
10573 -- Collect previous instantiations in the unit that
10574 -- contains the desired generic.
10576 if Nkind (Parent (True_Parent)) /= N_Compilation_Unit
10577 and then not Body_Optional
10581 Info : Pending_Body_Info;
10585 Par := Parent (Inst_Node);
10586 while Present (Par) loop
10587 exit when Nkind (Parent (Par)) = N_Compilation_Unit;
10588 Par := Parent (Par);
10591 pragma Assert (Present (Par));
10593 if Nkind (Par) = N_Package_Body then
10594 Collect_Previous_Instances (Declarations (Par));
10596 elsif Nkind (Par) = N_Package_Declaration then
10597 Collect_Previous_Instances
10598 (Visible_Declarations (Specification (Par)));
10599 Collect_Previous_Instances
10600 (Private_Declarations (Specification (Par)));
10603 -- Enclosing unit is a subprogram body, In this
10604 -- case all instance bodies are processed in order
10605 -- and there is no need to collect them separately.
10610 Decl := First_Elmt (Previous_Instances);
10611 while Present (Decl) loop
10613 (Inst_Node => Node (Decl),
10615 Instance_Spec (Node (Decl)),
10616 Expander_Status => Exp_Status,
10617 Current_Sem_Unit =>
10618 Get_Code_Unit (Sloc (Node (Decl))),
10619 Scope_Suppress => Scope_Suppress,
10620 Local_Suppress_Stack_Top =>
10621 Local_Suppress_Stack_Top);
10623 -- Package instance
10626 Nkind (Node (Decl)) = N_Package_Instantiation
10628 Instantiate_Package_Body
10629 (Info, Body_Optional => True);
10631 -- Subprogram instance
10634 -- The instance_spec is the wrapper package,
10635 -- and the subprogram declaration is the last
10636 -- declaration in the wrapper.
10640 (Visible_Declarations
10641 (Specification (Info.Act_Decl)));
10643 Instantiate_Subprogram_Body
10644 (Info, Body_Optional => True);
10652 Instantiate_Package_Body
10654 ((Inst_Node => Inst_Node,
10655 Act_Decl => True_Parent,
10656 Expander_Status => Exp_Status,
10657 Current_Sem_Unit =>
10658 Get_Code_Unit (Sloc (Inst_Node)),
10659 Scope_Suppress => Scope_Suppress,
10660 Local_Suppress_Stack_Top =>
10661 Local_Suppress_Stack_Top)),
10662 Body_Optional => Body_Optional);
10666 -- Case where we are not instantiating a nested generic
10669 Opt.Style_Check := False;
10670 Expander_Mode_Save_And_Set (True);
10671 Load_Needed_Body (Comp_Unit, OK);
10672 Opt.Style_Check := Save_Style_Check;
10673 Expander_Mode_Restore;
10676 and then Unit_Requires_Body (Defining_Entity (Spec))
10677 and then not Body_Optional
10680 Bname : constant Unit_Name_Type :=
10681 Get_Body_Name (Get_Unit_Name (Unit (Comp_Unit)));
10684 Error_Msg_Unit_1 := Bname;
10685 Error_Msg_N ("this instantiation requires$!", N);
10686 Error_Msg_File_1 := Get_File_Name (Bname, Subunit => False);
10687 Error_Msg_N ("\but file{ was not found!", N);
10688 raise Unrecoverable_Error;
10694 -- If loading parent of the generic caused an instantiation circularity,
10695 -- we abandon compilation at this point, because otherwise in some cases
10696 -- we get into trouble with infinite recursions after this point.
10698 if Circularity_Detected then
10699 raise Unrecoverable_Error;
10701 end Load_Parent_Of_Generic;
10703 ---------------------------------
10704 -- Map_Formal_Package_Entities --
10705 ---------------------------------
10707 procedure Map_Formal_Package_Entities (Form : Entity_Id; Act : Entity_Id) is
10712 Set_Instance_Of (Form, Act);
10714 -- Traverse formal and actual package to map the corresponding entities.
10715 -- We skip over internal entities that may be generated during semantic
10716 -- analysis, and find the matching entities by name, given that they
10717 -- must appear in the same order.
10719 E1 := First_Entity (Form);
10720 E2 := First_Entity (Act);
10722 and then E1 /= First_Private_Entity (Form)
10724 -- Could this test be a single condition???
10725 -- Seems like it could, and isn't FPE (Form) a constant anyway???
10727 if not Is_Internal (E1)
10728 and then Present (Parent (E1))
10729 and then not Is_Class_Wide_Type (E1)
10730 and then not Is_Internal_Name (Chars (E1))
10733 and then Chars (E2) /= Chars (E1)
10741 Set_Instance_Of (E1, E2);
10744 and then Is_Tagged_Type (E2)
10747 (Class_Wide_Type (E1), Class_Wide_Type (E2));
10750 if Is_Constrained (E1) then
10752 (Base_Type (E1), Base_Type (E2));
10755 if Ekind (E1) = E_Package
10756 and then No (Renamed_Object (E1))
10758 Map_Formal_Package_Entities (E1, E2);
10765 end Map_Formal_Package_Entities;
10767 -----------------------
10768 -- Move_Freeze_Nodes --
10769 -----------------------
10771 procedure Move_Freeze_Nodes
10772 (Out_Of : Entity_Id;
10777 Next_Decl : Node_Id;
10778 Next_Node : Node_Id := After;
10781 function Is_Outer_Type (T : Entity_Id) return Boolean;
10782 -- Check whether entity is declared in a scope external to that of the
10785 -------------------
10786 -- Is_Outer_Type --
10787 -------------------
10789 function Is_Outer_Type (T : Entity_Id) return Boolean is
10790 Scop : Entity_Id := Scope (T);
10793 if Scope_Depth (Scop) < Scope_Depth (Out_Of) then
10797 while Scop /= Standard_Standard loop
10798 if Scop = Out_Of then
10801 Scop := Scope (Scop);
10809 -- Start of processing for Move_Freeze_Nodes
10816 -- First remove the freeze nodes that may appear before all other
10820 while Present (Decl)
10821 and then Nkind (Decl) = N_Freeze_Entity
10822 and then Is_Outer_Type (Entity (Decl))
10824 Decl := Remove_Head (L);
10825 Insert_After (Next_Node, Decl);
10826 Set_Analyzed (Decl, False);
10831 -- Next scan the list of declarations and remove each freeze node that
10832 -- appears ahead of the current node.
10834 while Present (Decl) loop
10835 while Present (Next (Decl))
10836 and then Nkind (Next (Decl)) = N_Freeze_Entity
10837 and then Is_Outer_Type (Entity (Next (Decl)))
10839 Next_Decl := Remove_Next (Decl);
10840 Insert_After (Next_Node, Next_Decl);
10841 Set_Analyzed (Next_Decl, False);
10842 Next_Node := Next_Decl;
10845 -- If the declaration is a nested package or concurrent type, then
10846 -- recurse. Nested generic packages will have been processed from the
10849 if Nkind (Decl) = N_Package_Declaration then
10850 Spec := Specification (Decl);
10852 elsif Nkind (Decl) = N_Task_Type_Declaration then
10853 Spec := Task_Definition (Decl);
10855 elsif Nkind (Decl) = N_Protected_Type_Declaration then
10856 Spec := Protected_Definition (Decl);
10862 if Present (Spec) then
10863 Move_Freeze_Nodes (Out_Of, Next_Node,
10864 Visible_Declarations (Spec));
10865 Move_Freeze_Nodes (Out_Of, Next_Node,
10866 Private_Declarations (Spec));
10871 end Move_Freeze_Nodes;
10877 function Next_Assoc (E : Assoc_Ptr) return Assoc_Ptr is
10879 return Generic_Renamings.Table (E).Next_In_HTable;
10882 ------------------------
10883 -- Preanalyze_Actuals --
10884 ------------------------
10886 procedure Preanalyze_Actuals (N : Node_Id) is
10889 Errs : constant Int := Serious_Errors_Detected;
10892 Assoc := First (Generic_Associations (N));
10893 while Present (Assoc) loop
10894 if Nkind (Assoc) /= N_Others_Choice then
10895 Act := Explicit_Generic_Actual_Parameter (Assoc);
10897 -- Within a nested instantiation, a defaulted actual is an empty
10898 -- association, so nothing to analyze. If the subprogram actual
10899 -- is an attribute, analyze prefix only, because actual is not a
10900 -- complete attribute reference.
10902 -- If actual is an allocator, analyze expression only. The full
10903 -- analysis can generate code, and if instance is a compilation
10904 -- unit we have to wait until the package instance is installed
10905 -- to have a proper place to insert this code.
10907 -- String literals may be operators, but at this point we do not
10908 -- know whether the actual is a formal subprogram or a string.
10913 elsif Nkind (Act) = N_Attribute_Reference then
10914 Analyze (Prefix (Act));
10916 elsif Nkind (Act) = N_Explicit_Dereference then
10917 Analyze (Prefix (Act));
10919 elsif Nkind (Act) = N_Allocator then
10921 Expr : constant Node_Id := Expression (Act);
10924 if Nkind (Expr) = N_Subtype_Indication then
10925 Analyze (Subtype_Mark (Expr));
10927 -- Analyze separately each discriminant constraint,
10928 -- when given with a named association.
10934 Constr := First (Constraints (Constraint (Expr)));
10935 while Present (Constr) loop
10936 if Nkind (Constr) = N_Discriminant_Association then
10937 Analyze (Expression (Constr));
10951 elsif Nkind (Act) /= N_Operator_Symbol then
10955 if Errs /= Serious_Errors_Detected then
10957 -- Do a minimal analysis of the generic, to prevent spurious
10958 -- warnings complaining about the generic being unreferenced,
10959 -- before abandoning the instantiation.
10961 Analyze (Name (N));
10963 if Is_Entity_Name (Name (N))
10964 and then Etype (Name (N)) /= Any_Type
10966 Generate_Reference (Entity (Name (N)), Name (N));
10967 Set_Is_Instantiated (Entity (Name (N)));
10970 Abandon_Instantiation (Act);
10976 end Preanalyze_Actuals;
10978 -------------------
10979 -- Remove_Parent --
10980 -------------------
10982 procedure Remove_Parent (In_Body : Boolean := False) is
10983 S : Entity_Id := Current_Scope;
10984 -- S is the scope containing the instantiation just completed. The
10985 -- scope stack contains the parent instances of the instantiation,
10986 -- followed by the original S.
10993 -- After child instantiation is complete, remove from scope stack the
10994 -- extra copy of the current scope, and then remove parent instances.
10996 if not In_Body then
10999 while Current_Scope /= S loop
11000 P := Current_Scope;
11001 End_Package_Scope (Current_Scope);
11003 if In_Open_Scopes (P) then
11004 E := First_Entity (P);
11005 while Present (E) loop
11006 Set_Is_Immediately_Visible (E, True);
11010 if Is_Generic_Instance (Current_Scope)
11011 and then P /= Current_Scope
11013 -- We are within an instance of some sibling. Retain
11014 -- visibility of parent, for proper subsequent cleanup,
11015 -- and reinstall private declarations as well.
11017 Set_In_Private_Part (P);
11018 Install_Private_Declarations (P);
11021 -- If the ultimate parent is a top-level unit recorded in
11022 -- Instance_Parent_Unit, then reset its visibility to what
11023 -- it was before instantiation. (It's not clear what the
11024 -- purpose is of testing whether Scope (P) is In_Open_Scopes,
11025 -- but that test was present before the ultimate parent test
11028 elsif not In_Open_Scopes (Scope (P))
11029 or else (P = Instance_Parent_Unit
11030 and then not Parent_Unit_Visible)
11032 Set_Is_Immediately_Visible (P, False);
11034 -- If the current scope is itself an instantiation of a generic
11035 -- nested within P, and we are in the private part of body of this
11036 -- instantiation, restore the full views of P, that were removed
11037 -- in End_Package_Scope above. This obscure case can occur when a
11038 -- subunit of a generic contains an instance of a child unit of
11039 -- its generic parent unit.
11041 elsif S = Current_Scope
11042 and then Is_Generic_Instance (S)
11045 Par : constant Entity_Id :=
11047 (Specification (Unit_Declaration_Node (S)));
11050 and then P = Scope (Par)
11051 and then (In_Package_Body (S) or else In_Private_Part (S))
11053 Set_In_Private_Part (P);
11054 Install_Private_Declarations (P);
11060 -- Reset visibility of entities in the enclosing scope
11062 Set_Is_Hidden_Open_Scope (Current_Scope, False);
11064 Hidden := First_Elmt (Hidden_Entities);
11065 while Present (Hidden) loop
11066 Set_Is_Immediately_Visible (Node (Hidden), True);
11067 Next_Elmt (Hidden);
11071 -- Each body is analyzed separately, and there is no context
11072 -- that needs preserving from one body instance to the next,
11073 -- so remove all parent scopes that have been installed.
11075 while Present (S) loop
11076 End_Package_Scope (S);
11077 Set_Is_Immediately_Visible (S, False);
11078 S := Current_Scope;
11079 exit when S = Standard_Standard;
11088 procedure Restore_Env is
11089 Saved : Instance_Env renames Instance_Envs.Table (Instance_Envs.Last);
11092 if No (Current_Instantiated_Parent.Act_Id) then
11094 -- Restore environment after subprogram inlining
11096 Restore_Private_Views (Empty);
11099 Current_Instantiated_Parent := Saved.Instantiated_Parent;
11100 Exchanged_Views := Saved.Exchanged_Views;
11101 Hidden_Entities := Saved.Hidden_Entities;
11102 Current_Sem_Unit := Saved.Current_Sem_Unit;
11103 Parent_Unit_Visible := Saved.Parent_Unit_Visible;
11104 Instance_Parent_Unit := Saved.Instance_Parent_Unit;
11106 Restore_Opt_Config_Switches (Saved.Switches);
11108 Instance_Envs.Decrement_Last;
11111 ---------------------------
11112 -- Restore_Private_Views --
11113 ---------------------------
11115 procedure Restore_Private_Views
11116 (Pack_Id : Entity_Id;
11117 Is_Package : Boolean := True)
11122 Dep_Elmt : Elmt_Id;
11125 procedure Restore_Nested_Formal (Formal : Entity_Id);
11126 -- Hide the generic formals of formal packages declared with box
11127 -- which were reachable in the current instantiation.
11129 ---------------------------
11130 -- Restore_Nested_Formal --
11131 ---------------------------
11133 procedure Restore_Nested_Formal (Formal : Entity_Id) is
11137 if Present (Renamed_Object (Formal))
11138 and then Denotes_Formal_Package (Renamed_Object (Formal), True)
11142 elsif Present (Associated_Formal_Package (Formal)) then
11143 Ent := First_Entity (Formal);
11144 while Present (Ent) loop
11145 exit when Ekind (Ent) = E_Package
11146 and then Renamed_Entity (Ent) = Renamed_Entity (Formal);
11148 Set_Is_Hidden (Ent);
11149 Set_Is_Potentially_Use_Visible (Ent, False);
11151 -- If package, then recurse
11153 if Ekind (Ent) = E_Package then
11154 Restore_Nested_Formal (Ent);
11160 end Restore_Nested_Formal;
11162 -- Start of processing for Restore_Private_Views
11165 M := First_Elmt (Exchanged_Views);
11166 while Present (M) loop
11169 -- Subtypes of types whose views have been exchanged, and that
11170 -- are defined within the instance, were not on the list of
11171 -- Private_Dependents on entry to the instance, so they have to
11172 -- be exchanged explicitly now, in order to remain consistent with
11173 -- the view of the parent type.
11175 if Ekind (Typ) = E_Private_Type
11176 or else Ekind (Typ) = E_Limited_Private_Type
11177 or else Ekind (Typ) = E_Record_Type_With_Private
11179 Dep_Elmt := First_Elmt (Private_Dependents (Typ));
11180 while Present (Dep_Elmt) loop
11181 Dep_Typ := Node (Dep_Elmt);
11183 if Scope (Dep_Typ) = Pack_Id
11184 and then Present (Full_View (Dep_Typ))
11186 Replace_Elmt (Dep_Elmt, Full_View (Dep_Typ));
11187 Exchange_Declarations (Dep_Typ);
11190 Next_Elmt (Dep_Elmt);
11194 Exchange_Declarations (Node (M));
11198 if No (Pack_Id) then
11202 -- Make the generic formal parameters private, and make the formal
11203 -- types into subtypes of the actuals again.
11205 E := First_Entity (Pack_Id);
11206 while Present (E) loop
11207 Set_Is_Hidden (E, True);
11210 and then Nkind (Parent (E)) = N_Subtype_Declaration
11212 Set_Is_Generic_Actual_Type (E, False);
11214 -- An unusual case of aliasing: the actual may also be directly
11215 -- visible in the generic, and be private there, while it is fully
11216 -- visible in the context of the instance. The internal subtype
11217 -- is private in the instance, but has full visibility like its
11218 -- parent in the enclosing scope. This enforces the invariant that
11219 -- the privacy status of all private dependents of a type coincide
11220 -- with that of the parent type. This can only happen when a
11221 -- generic child unit is instantiated within sibling.
11223 if Is_Private_Type (E)
11224 and then not Is_Private_Type (Etype (E))
11226 Exchange_Declarations (E);
11229 elsif Ekind (E) = E_Package then
11231 -- The end of the renaming list is the renaming of the generic
11232 -- package itself. If the instance is a subprogram, all entities
11233 -- in the corresponding package are renamings. If this entity is
11234 -- a formal package, make its own formals private as well. The
11235 -- actual in this case is itself the renaming of an instantiation.
11236 -- If the entity is not a package renaming, it is the entity
11237 -- created to validate formal package actuals: ignore.
11239 -- If the actual is itself a formal package for the enclosing
11240 -- generic, or the actual for such a formal package, it remains
11241 -- visible on exit from the instance, and therefore nothing needs
11242 -- to be done either, except to keep it accessible.
11245 and then Renamed_Object (E) = Pack_Id
11249 elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then
11253 Denotes_Formal_Package (Renamed_Object (E), True, Pack_Id)
11255 Set_Is_Hidden (E, False);
11259 Act_P : constant Entity_Id := Renamed_Object (E);
11263 Id := First_Entity (Act_P);
11265 and then Id /= First_Private_Entity (Act_P)
11267 exit when Ekind (Id) = E_Package
11268 and then Renamed_Object (Id) = Act_P;
11270 Set_Is_Hidden (Id, True);
11271 Set_Is_Potentially_Use_Visible (Id, In_Use (Act_P));
11273 if Ekind (Id) = E_Package then
11274 Restore_Nested_Formal (Id);
11285 end Restore_Private_Views;
11292 (Gen_Unit : Entity_Id;
11293 Act_Unit : Entity_Id)
11297 Set_Instance_Env (Gen_Unit, Act_Unit);
11300 ----------------------------
11301 -- Save_Global_References --
11302 ----------------------------
11304 procedure Save_Global_References (N : Node_Id) is
11305 Gen_Scope : Entity_Id;
11309 function Is_Global (E : Entity_Id) return Boolean;
11310 -- Check whether entity is defined outside of generic unit. Examine the
11311 -- scope of an entity, and the scope of the scope, etc, until we find
11312 -- either Standard, in which case the entity is global, or the generic
11313 -- unit itself, which indicates that the entity is local. If the entity
11314 -- is the generic unit itself, as in the case of a recursive call, or
11315 -- the enclosing generic unit, if different from the current scope, then
11316 -- it is local as well, because it will be replaced at the point of
11317 -- instantiation. On the other hand, if it is a reference to a child
11318 -- unit of a common ancestor, which appears in an instantiation, it is
11319 -- global because it is used to denote a specific compilation unit at
11320 -- the time the instantiations will be analyzed.
11322 procedure Reset_Entity (N : Node_Id);
11323 -- Save semantic information on global entity, so that it is not
11324 -- resolved again at instantiation time.
11326 procedure Save_Entity_Descendants (N : Node_Id);
11327 -- Apply Save_Global_References to the two syntactic descendants of
11328 -- non-terminal nodes that carry an Associated_Node and are processed
11329 -- through Reset_Entity. Once the global entity (if any) has been
11330 -- captured together with its type, only two syntactic descendants need
11331 -- to be traversed to complete the processing of the tree rooted at N.
11332 -- This applies to Selected_Components, Expanded_Names, and to Operator
11333 -- nodes. N can also be a character literal, identifier, or operator
11334 -- symbol node, but the call has no effect in these cases.
11336 procedure Save_Global_Defaults (N1, N2 : Node_Id);
11337 -- Default actuals in nested instances must be handled specially
11338 -- because there is no link to them from the original tree. When an
11339 -- actual subprogram is given by a default, we add an explicit generic
11340 -- association for it in the instantiation node. When we save the
11341 -- global references on the name of the instance, we recover the list
11342 -- of generic associations, and add an explicit one to the original
11343 -- generic tree, through which a global actual can be preserved.
11344 -- Similarly, if a child unit is instantiated within a sibling, in the
11345 -- context of the parent, we must preserve the identifier of the parent
11346 -- so that it can be properly resolved in a subsequent instantiation.
11348 procedure Save_Global_Descendant (D : Union_Id);
11349 -- Apply Save_Global_References recursively to the descendents of the
11352 procedure Save_References (N : Node_Id);
11353 -- This is the recursive procedure that does the work, once the
11354 -- enclosing generic scope has been established.
11360 function Is_Global (E : Entity_Id) return Boolean is
11363 function Is_Instance_Node (Decl : Node_Id) return Boolean;
11364 -- Determine whether the parent node of a reference to a child unit
11365 -- denotes an instantiation or a formal package, in which case the
11366 -- reference to the child unit is global, even if it appears within
11367 -- the current scope (e.g. when the instance appears within the body
11368 -- of an ancestor).
11370 ----------------------
11371 -- Is_Instance_Node --
11372 ----------------------
11374 function Is_Instance_Node (Decl : Node_Id) return Boolean is
11376 return (Nkind (Decl) in N_Generic_Instantiation
11378 Nkind (Original_Node (Decl)) = N_Formal_Package_Declaration);
11379 end Is_Instance_Node;
11381 -- Start of processing for Is_Global
11384 if E = Gen_Scope then
11387 elsif E = Standard_Standard then
11390 elsif Is_Child_Unit (E)
11391 and then (Is_Instance_Node (Parent (N2))
11392 or else (Nkind (Parent (N2)) = N_Expanded_Name
11393 and then N2 = Selector_Name (Parent (N2))
11395 Is_Instance_Node (Parent (Parent (N2)))))
11401 while Se /= Gen_Scope loop
11402 if Se = Standard_Standard then
11417 procedure Reset_Entity (N : Node_Id) is
11419 procedure Set_Global_Type (N : Node_Id; N2 : Node_Id);
11420 -- If the type of N2 is global to the generic unit. Save
11421 -- the type in the generic node.
11423 function Top_Ancestor (E : Entity_Id) return Entity_Id;
11424 -- Find the ultimate ancestor of the current unit. If it is
11425 -- not a generic unit, then the name of the current unit
11426 -- in the prefix of an expanded name must be replaced with
11427 -- its generic homonym to ensure that it will be properly
11428 -- resolved in an instance.
11430 ---------------------
11431 -- Set_Global_Type --
11432 ---------------------
11434 procedure Set_Global_Type (N : Node_Id; N2 : Node_Id) is
11435 Typ : constant Entity_Id := Etype (N2);
11438 Set_Etype (N, Typ);
11440 if Entity (N) /= N2
11441 and then Has_Private_View (Entity (N))
11443 -- If the entity of N is not the associated node, this is
11444 -- a nested generic and it has an associated node as well,
11445 -- whose type is already the full view (see below). Indicate
11446 -- that the original node has a private view.
11448 Set_Has_Private_View (N);
11451 -- If not a private type, nothing else to do
11453 if not Is_Private_Type (Typ) then
11454 if Is_Array_Type (Typ)
11455 and then Is_Private_Type (Component_Type (Typ))
11457 Set_Has_Private_View (N);
11460 -- If it is a derivation of a private type in a context where
11461 -- no full view is needed, nothing to do either.
11463 elsif No (Full_View (Typ)) and then Typ /= Etype (Typ) then
11466 -- Otherwise mark the type for flipping and use the full_view
11470 Set_Has_Private_View (N);
11472 if Present (Full_View (Typ)) then
11473 Set_Etype (N2, Full_View (Typ));
11476 end Set_Global_Type;
11482 function Top_Ancestor (E : Entity_Id) return Entity_Id is
11487 while Is_Child_Unit (Par) loop
11488 Par := Scope (Par);
11494 -- Start of processing for Reset_Entity
11497 N2 := Get_Associated_Node (N);
11500 if Present (E) then
11501 if Is_Global (E) then
11502 Set_Global_Type (N, N2);
11504 elsif Nkind (N) = N_Op_Concat
11505 and then Is_Generic_Type (Etype (N2))
11507 (Base_Type (Etype (Right_Opnd (N2))) = Etype (N2)
11508 or else Base_Type (Etype (Left_Opnd (N2))) = Etype (N2))
11509 and then Is_Intrinsic_Subprogram (E)
11514 -- Entity is local. Mark generic node as unresolved.
11515 -- Note that now it does not have an entity.
11517 Set_Associated_Node (N, Empty);
11518 Set_Etype (N, Empty);
11521 if Nkind (Parent (N)) in N_Generic_Instantiation
11522 and then N = Name (Parent (N))
11524 Save_Global_Defaults (Parent (N), Parent (N2));
11527 elsif Nkind (Parent (N)) = N_Selected_Component
11528 and then Nkind (Parent (N2)) = N_Expanded_Name
11530 if Is_Global (Entity (Parent (N2))) then
11531 Change_Selected_Component_To_Expanded_Name (Parent (N));
11532 Set_Associated_Node (Parent (N), Parent (N2));
11533 Set_Global_Type (Parent (N), Parent (N2));
11534 Save_Entity_Descendants (N);
11536 -- If this is a reference to the current generic entity, replace
11537 -- by the name of the generic homonym of the current package. This
11538 -- is because in an instantiation Par.P.Q will not resolve to the
11539 -- name of the instance, whose enclosing scope is not necessarily
11540 -- Par. We use the generic homonym rather that the name of the
11541 -- generic itself, because it may be hidden by a local
11544 elsif In_Open_Scopes (Entity (Parent (N2)))
11546 Is_Generic_Unit (Top_Ancestor (Entity (Prefix (Parent (N2)))))
11548 if Ekind (Entity (Parent (N2))) = E_Generic_Package then
11549 Rewrite (Parent (N),
11550 Make_Identifier (Sloc (N),
11552 Chars (Generic_Homonym (Entity (Parent (N2))))));
11554 Rewrite (Parent (N),
11555 Make_Identifier (Sloc (N),
11556 Chars => Chars (Selector_Name (Parent (N2)))));
11560 if Nkind (Parent (Parent (N))) in N_Generic_Instantiation
11561 and then Parent (N) = Name (Parent (Parent (N)))
11563 Save_Global_Defaults
11564 (Parent (Parent (N)), Parent (Parent ((N2))));
11567 -- A selected component may denote a static constant that has been
11568 -- folded. If the static constant is global to the generic, capture
11569 -- its value. Otherwise the folding will happen in any instantiation,
11571 elsif Nkind (Parent (N)) = N_Selected_Component
11572 and then Nkind_In (Parent (N2), N_Integer_Literal, N_Real_Literal)
11574 if Present (Entity (Original_Node (Parent (N2))))
11575 and then Is_Global (Entity (Original_Node (Parent (N2))))
11577 Rewrite (Parent (N), New_Copy (Parent (N2)));
11578 Set_Analyzed (Parent (N), False);
11584 -- A selected component may be transformed into a parameterless
11585 -- function call. If the called entity is global, rewrite the node
11586 -- appropriately, i.e. as an extended name for the global entity.
11588 elsif Nkind (Parent (N)) = N_Selected_Component
11589 and then Nkind (Parent (N2)) = N_Function_Call
11590 and then N = Selector_Name (Parent (N))
11592 if No (Parameter_Associations (Parent (N2))) then
11593 if Is_Global (Entity (Name (Parent (N2)))) then
11594 Change_Selected_Component_To_Expanded_Name (Parent (N));
11595 Set_Associated_Node (Parent (N), Name (Parent (N2)));
11596 Set_Global_Type (Parent (N), Name (Parent (N2)));
11597 Save_Entity_Descendants (N);
11600 Set_Associated_Node (N, Empty);
11601 Set_Etype (N, Empty);
11604 -- In Ada 2005, X.F may be a call to a primitive operation,
11605 -- rewritten as F (X). This rewriting will be done again in an
11606 -- instance, so keep the original node. Global entities will be
11607 -- captured as for other constructs.
11613 -- Entity is local. Reset in generic unit, so that node is resolved
11614 -- anew at the point of instantiation.
11617 Set_Associated_Node (N, Empty);
11618 Set_Etype (N, Empty);
11622 -----------------------------
11623 -- Save_Entity_Descendants --
11624 -----------------------------
11626 procedure Save_Entity_Descendants (N : Node_Id) is
11629 when N_Binary_Op =>
11630 Save_Global_Descendant (Union_Id (Left_Opnd (N)));
11631 Save_Global_Descendant (Union_Id (Right_Opnd (N)));
11634 Save_Global_Descendant (Union_Id (Right_Opnd (N)));
11636 when N_Expanded_Name | N_Selected_Component =>
11637 Save_Global_Descendant (Union_Id (Prefix (N)));
11638 Save_Global_Descendant (Union_Id (Selector_Name (N)));
11640 when N_Identifier | N_Character_Literal | N_Operator_Symbol =>
11644 raise Program_Error;
11646 end Save_Entity_Descendants;
11648 --------------------------
11649 -- Save_Global_Defaults --
11650 --------------------------
11652 procedure Save_Global_Defaults (N1, N2 : Node_Id) is
11653 Loc : constant Source_Ptr := Sloc (N1);
11654 Assoc2 : constant List_Id := Generic_Associations (N2);
11655 Gen_Id : constant Entity_Id := Get_Generic_Entity (N2);
11662 Actual : Entity_Id;
11665 Assoc1 := Generic_Associations (N1);
11667 if Present (Assoc1) then
11668 Act1 := First (Assoc1);
11671 Set_Generic_Associations (N1, New_List);
11672 Assoc1 := Generic_Associations (N1);
11675 if Present (Assoc2) then
11676 Act2 := First (Assoc2);
11681 while Present (Act1) and then Present (Act2) loop
11686 -- Find the associations added for default subprograms
11688 if Present (Act2) then
11689 while Nkind (Act2) /= N_Generic_Association
11690 or else No (Entity (Selector_Name (Act2)))
11691 or else not Is_Overloadable (Entity (Selector_Name (Act2)))
11696 -- Add a similar association if the default is global. The
11697 -- renaming declaration for the actual has been analyzed, and
11698 -- its alias is the program it renames. Link the actual in the
11699 -- original generic tree with the node in the analyzed tree.
11701 while Present (Act2) loop
11702 Subp := Entity (Selector_Name (Act2));
11703 Def := Explicit_Generic_Actual_Parameter (Act2);
11705 -- Following test is defence against rubbish errors
11707 if No (Alias (Subp)) then
11711 -- Retrieve the resolved actual from the renaming declaration
11712 -- created for the instantiated formal.
11714 Actual := Entity (Name (Parent (Parent (Subp))));
11715 Set_Entity (Def, Actual);
11716 Set_Etype (Def, Etype (Actual));
11718 if Is_Global (Actual) then
11720 Make_Generic_Association (Loc,
11721 Selector_Name => New_Occurrence_Of (Subp, Loc),
11722 Explicit_Generic_Actual_Parameter =>
11723 New_Occurrence_Of (Actual, Loc));
11725 Set_Associated_Node
11726 (Explicit_Generic_Actual_Parameter (Ndec), Def);
11728 Append (Ndec, Assoc1);
11730 -- If there are other defaults, add a dummy association in case
11731 -- there are other defaulted formals with the same name.
11733 elsif Present (Next (Act2)) then
11735 Make_Generic_Association (Loc,
11736 Selector_Name => New_Occurrence_Of (Subp, Loc),
11737 Explicit_Generic_Actual_Parameter => Empty);
11739 Append (Ndec, Assoc1);
11746 if Nkind (Name (N1)) = N_Identifier
11747 and then Is_Child_Unit (Gen_Id)
11748 and then Is_Global (Gen_Id)
11749 and then Is_Generic_Unit (Scope (Gen_Id))
11750 and then In_Open_Scopes (Scope (Gen_Id))
11752 -- This is an instantiation of a child unit within a sibling,
11753 -- so that the generic parent is in scope. An eventual instance
11754 -- must occur within the scope of an instance of the parent.
11755 -- Make name in instance into an expanded name, to preserve the
11756 -- identifier of the parent, so it can be resolved subsequently.
11758 Rewrite (Name (N2),
11759 Make_Expanded_Name (Loc,
11760 Chars => Chars (Gen_Id),
11761 Prefix => New_Occurrence_Of (Scope (Gen_Id), Loc),
11762 Selector_Name => New_Occurrence_Of (Gen_Id, Loc)));
11763 Set_Entity (Name (N2), Gen_Id);
11765 Rewrite (Name (N1),
11766 Make_Expanded_Name (Loc,
11767 Chars => Chars (Gen_Id),
11768 Prefix => New_Occurrence_Of (Scope (Gen_Id), Loc),
11769 Selector_Name => New_Occurrence_Of (Gen_Id, Loc)));
11771 Set_Associated_Node (Name (N1), Name (N2));
11772 Set_Associated_Node (Prefix (Name (N1)), Empty);
11773 Set_Associated_Node
11774 (Selector_Name (Name (N1)), Selector_Name (Name (N2)));
11775 Set_Etype (Name (N1), Etype (Gen_Id));
11778 end Save_Global_Defaults;
11780 ----------------------------
11781 -- Save_Global_Descendant --
11782 ----------------------------
11784 procedure Save_Global_Descendant (D : Union_Id) is
11788 if D in Node_Range then
11789 if D = Union_Id (Empty) then
11792 elsif Nkind (Node_Id (D)) /= N_Compilation_Unit then
11793 Save_References (Node_Id (D));
11796 elsif D in List_Range then
11797 if D = Union_Id (No_List)
11798 or else Is_Empty_List (List_Id (D))
11803 N1 := First (List_Id (D));
11804 while Present (N1) loop
11805 Save_References (N1);
11810 -- Element list or other non-node field, nothing to do
11815 end Save_Global_Descendant;
11817 ---------------------
11818 -- Save_References --
11819 ---------------------
11821 -- This is the recursive procedure that does the work, once the
11822 -- enclosing generic scope has been established. We have to treat
11823 -- specially a number of node rewritings that are required by semantic
11824 -- processing and which change the kind of nodes in the generic copy:
11825 -- typically constant-folding, replacing an operator node by a string
11826 -- literal, or a selected component by an expanded name. In each of
11827 -- those cases, the transformation is propagated to the generic unit.
11829 procedure Save_References (N : Node_Id) is
11834 elsif Nkind_In (N, N_Character_Literal, N_Operator_Symbol) then
11835 if Nkind (N) = Nkind (Get_Associated_Node (N)) then
11838 elsif Nkind (N) = N_Operator_Symbol
11839 and then Nkind (Get_Associated_Node (N)) = N_String_Literal
11841 Change_Operator_Symbol_To_String_Literal (N);
11844 elsif Nkind (N) in N_Op then
11845 if Nkind (N) = Nkind (Get_Associated_Node (N)) then
11846 if Nkind (N) = N_Op_Concat then
11847 Set_Is_Component_Left_Opnd (N,
11848 Is_Component_Left_Opnd (Get_Associated_Node (N)));
11850 Set_Is_Component_Right_Opnd (N,
11851 Is_Component_Right_Opnd (Get_Associated_Node (N)));
11857 -- Node may be transformed into call to a user-defined operator
11859 N2 := Get_Associated_Node (N);
11861 if Nkind (N2) = N_Function_Call then
11862 E := Entity (Name (N2));
11865 and then Is_Global (E)
11867 Set_Etype (N, Etype (N2));
11869 Set_Associated_Node (N, Empty);
11870 Set_Etype (N, Empty);
11873 elsif Nkind_In (N2, N_Integer_Literal,
11877 if Present (Original_Node (N2))
11878 and then Nkind (Original_Node (N2)) = Nkind (N)
11881 -- Operation was constant-folded. Whenever possible,
11882 -- recover semantic information from unfolded node,
11885 Set_Associated_Node (N, Original_Node (N2));
11887 if Nkind (N) = N_Op_Concat then
11888 Set_Is_Component_Left_Opnd (N,
11889 Is_Component_Left_Opnd (Get_Associated_Node (N)));
11890 Set_Is_Component_Right_Opnd (N,
11891 Is_Component_Right_Opnd (Get_Associated_Node (N)));
11897 -- If original node is already modified, propagate
11898 -- constant-folding to template.
11900 Rewrite (N, New_Copy (N2));
11901 Set_Analyzed (N, False);
11904 elsif Nkind (N2) = N_Identifier
11905 and then Ekind (Entity (N2)) = E_Enumeration_Literal
11907 -- Same if call was folded into a literal, but in this case
11908 -- retain the entity to avoid spurious ambiguities if id is
11909 -- overloaded at the point of instantiation or inlining.
11911 Rewrite (N, New_Copy (N2));
11912 Set_Analyzed (N, False);
11916 -- Complete operands check if node has not been constant-folded
11918 if Nkind (N) in N_Op then
11919 Save_Entity_Descendants (N);
11922 elsif Nkind (N) = N_Identifier then
11923 if Nkind (N) = Nkind (Get_Associated_Node (N)) then
11925 -- If this is a discriminant reference, always save it. It is
11926 -- used in the instance to find the corresponding discriminant
11927 -- positionally rather than by name.
11929 Set_Original_Discriminant
11930 (N, Original_Discriminant (Get_Associated_Node (N)));
11934 N2 := Get_Associated_Node (N);
11936 if Nkind (N2) = N_Function_Call then
11937 E := Entity (Name (N2));
11939 -- Name resolves to a call to parameterless function. If
11940 -- original entity is global, mark node as resolved.
11943 and then Is_Global (E)
11945 Set_Etype (N, Etype (N2));
11947 Set_Associated_Node (N, Empty);
11948 Set_Etype (N, Empty);
11951 elsif Nkind_In (N2, N_Integer_Literal, N_Real_Literal)
11952 and then Is_Entity_Name (Original_Node (N2))
11954 -- Name resolves to named number that is constant-folded,
11955 -- We must preserve the original name for ASIS use, and
11956 -- undo the constant-folding, which will be repeated in
11959 Set_Associated_Node (N, Original_Node (N2));
11962 elsif Nkind (N2) = N_String_Literal then
11964 -- Name resolves to string literal. Perform the same
11965 -- replacement in generic.
11967 Rewrite (N, New_Copy (N2));
11969 elsif Nkind (N2) = N_Explicit_Dereference then
11971 -- An identifier is rewritten as a dereference if it is
11972 -- the prefix in a selected component, and it denotes an
11973 -- access to a composite type, or a parameterless function
11974 -- call that returns an access type.
11976 -- Check whether corresponding entity in prefix is global
11978 if Is_Entity_Name (Prefix (N2))
11979 and then Present (Entity (Prefix (N2)))
11980 and then Is_Global (Entity (Prefix (N2)))
11983 Make_Explicit_Dereference (Sloc (N),
11984 Prefix => Make_Identifier (Sloc (N),
11985 Chars => Chars (N))));
11986 Set_Associated_Node (Prefix (N), Prefix (N2));
11988 elsif Nkind (Prefix (N2)) = N_Function_Call
11989 and then Is_Global (Entity (Name (Prefix (N2))))
11992 Make_Explicit_Dereference (Sloc (N),
11993 Prefix => Make_Function_Call (Sloc (N),
11995 Make_Identifier (Sloc (N),
11996 Chars => Chars (N)))));
11998 Set_Associated_Node
11999 (Name (Prefix (N)), Name (Prefix (N2)));
12002 Set_Associated_Node (N, Empty);
12003 Set_Etype (N, Empty);
12006 -- The subtype mark of a nominally unconstrained object is
12007 -- rewritten as a subtype indication using the bounds of the
12008 -- expression. Recover the original subtype mark.
12010 elsif Nkind (N2) = N_Subtype_Indication
12011 and then Is_Entity_Name (Original_Node (N2))
12013 Set_Associated_Node (N, Original_Node (N2));
12021 elsif Nkind (N) in N_Entity then
12026 Loc : constant Source_Ptr := Sloc (N);
12027 Qual : Node_Id := Empty;
12028 Typ : Entity_Id := Empty;
12031 use Atree.Unchecked_Access;
12032 -- This code section is part of implementing an untyped tree
12033 -- traversal, so it needs direct access to node fields.
12036 if Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then
12037 N2 := Get_Associated_Node (N);
12044 -- In an instance within a generic, use the name of the
12045 -- actual and not the original generic parameter. If the
12046 -- actual is global in the current generic it must be
12047 -- preserved for its instantiation.
12049 if Nkind (Parent (Typ)) = N_Subtype_Declaration
12051 Present (Generic_Parent_Type (Parent (Typ)))
12053 Typ := Base_Type (Typ);
12054 Set_Etype (N2, Typ);
12060 or else not Is_Global (Typ)
12062 Set_Associated_Node (N, Empty);
12064 -- If the aggregate is an actual in a call, it has been
12065 -- resolved in the current context, to some local type.
12066 -- The enclosing call may have been disambiguated by the
12067 -- aggregate, and this disambiguation might fail at
12068 -- instantiation time because the type to which the
12069 -- aggregate did resolve is not preserved. In order to
12070 -- preserve some of this information, we wrap the
12071 -- aggregate in a qualified expression, using the id of
12072 -- its type. For further disambiguation we qualify the
12073 -- type name with its scope (if visible) because both
12074 -- id's will have corresponding entities in an instance.
12075 -- This resolves most of the problems with missing type
12076 -- information on aggregates in instances.
12078 if Nkind (N2) = Nkind (N)
12080 Nkind_In (Parent (N2), N_Procedure_Call_Statement,
12082 and then Comes_From_Source (Typ)
12084 if Is_Immediately_Visible (Scope (Typ)) then
12085 Nam := Make_Selected_Component (Loc,
12087 Make_Identifier (Loc, Chars (Scope (Typ))),
12089 Make_Identifier (Loc, Chars (Typ)));
12091 Nam := Make_Identifier (Loc, Chars (Typ));
12095 Make_Qualified_Expression (Loc,
12096 Subtype_Mark => Nam,
12097 Expression => Relocate_Node (N));
12101 Save_Global_Descendant (Field1 (N));
12102 Save_Global_Descendant (Field2 (N));
12103 Save_Global_Descendant (Field3 (N));
12104 Save_Global_Descendant (Field5 (N));
12106 if Present (Qual) then
12110 -- All other cases than aggregates
12113 Save_Global_Descendant (Field1 (N));
12114 Save_Global_Descendant (Field2 (N));
12115 Save_Global_Descendant (Field3 (N));
12116 Save_Global_Descendant (Field4 (N));
12117 Save_Global_Descendant (Field5 (N));
12121 end Save_References;
12123 -- Start of processing for Save_Global_References
12126 Gen_Scope := Current_Scope;
12128 -- If the generic unit is a child unit, references to entities in the
12129 -- parent are treated as local, because they will be resolved anew in
12130 -- the context of the instance of the parent.
12132 while Is_Child_Unit (Gen_Scope)
12133 and then Ekind (Scope (Gen_Scope)) = E_Generic_Package
12135 Gen_Scope := Scope (Gen_Scope);
12138 Save_References (N);
12139 end Save_Global_References;
12141 --------------------------------------
12142 -- Set_Copied_Sloc_For_Inlined_Body --
12143 --------------------------------------
12145 procedure Set_Copied_Sloc_For_Inlined_Body (N : Node_Id; E : Entity_Id) is
12147 Create_Instantiation_Source (N, E, True, S_Adjustment);
12148 end Set_Copied_Sloc_For_Inlined_Body;
12150 ---------------------
12151 -- Set_Instance_Of --
12152 ---------------------
12154 procedure Set_Instance_Of (A : Entity_Id; B : Entity_Id) is
12156 Generic_Renamings.Table (Generic_Renamings.Last) := (A, B, Assoc_Null);
12157 Generic_Renamings_HTable.Set (Generic_Renamings.Last);
12158 Generic_Renamings.Increment_Last;
12159 end Set_Instance_Of;
12161 --------------------
12162 -- Set_Next_Assoc --
12163 --------------------
12165 procedure Set_Next_Assoc (E : Assoc_Ptr; Next : Assoc_Ptr) is
12167 Generic_Renamings.Table (E).Next_In_HTable := Next;
12168 end Set_Next_Assoc;
12170 -------------------
12171 -- Start_Generic --
12172 -------------------
12174 procedure Start_Generic is
12176 -- ??? More things could be factored out in this routine.
12177 -- Should probably be done at a later stage.
12179 Generic_Flags.Append (Inside_A_Generic);
12180 Inside_A_Generic := True;
12182 Expander_Mode_Save_And_Set (False);
12185 ----------------------
12186 -- Set_Instance_Env --
12187 ----------------------
12189 procedure Set_Instance_Env
12190 (Gen_Unit : Entity_Id;
12191 Act_Unit : Entity_Id)
12194 -- Regardless of the current mode, predefined units are analyzed in
12195 -- the most current Ada mode, and earlier version Ada checks do not
12196 -- apply to predefined units. Nothing needs to be done for non-internal
12197 -- units. These are always analyzed in the current mode.
12199 if Is_Internal_File_Name
12200 (Fname => Unit_File_Name (Get_Source_Unit (Gen_Unit)),
12201 Renamings_Included => True)
12203 Set_Opt_Config_Switches (True, Current_Sem_Unit = Main_Unit);
12206 Current_Instantiated_Parent := (Gen_Unit, Act_Unit, Assoc_Null);
12207 end Set_Instance_Env;
12213 procedure Switch_View (T : Entity_Id) is
12214 BT : constant Entity_Id := Base_Type (T);
12215 Priv_Elmt : Elmt_Id := No_Elmt;
12216 Priv_Sub : Entity_Id;
12219 -- T may be private but its base type may have been exchanged through
12220 -- some other occurrence, in which case there is nothing to switch
12221 -- besides T itself. Note that a private dependent subtype of a private
12222 -- type might not have been switched even if the base type has been,
12223 -- because of the last branch of Check_Private_View (see comment there).
12225 if not Is_Private_Type (BT) then
12226 Prepend_Elmt (Full_View (T), Exchanged_Views);
12227 Exchange_Declarations (T);
12231 Priv_Elmt := First_Elmt (Private_Dependents (BT));
12233 if Present (Full_View (BT)) then
12234 Prepend_Elmt (Full_View (BT), Exchanged_Views);
12235 Exchange_Declarations (BT);
12238 while Present (Priv_Elmt) loop
12239 Priv_Sub := (Node (Priv_Elmt));
12241 -- We avoid flipping the subtype if the Etype of its full view is
12242 -- private because this would result in a malformed subtype. This
12243 -- occurs when the Etype of the subtype full view is the full view of
12244 -- the base type (and since the base types were just switched, the
12245 -- subtype is pointing to the wrong view). This is currently the case
12246 -- for tagged record types, access types (maybe more?) and needs to
12247 -- be resolved. ???
12249 if Present (Full_View (Priv_Sub))
12250 and then not Is_Private_Type (Etype (Full_View (Priv_Sub)))
12252 Prepend_Elmt (Full_View (Priv_Sub), Exchanged_Views);
12253 Exchange_Declarations (Priv_Sub);
12256 Next_Elmt (Priv_Elmt);
12260 -----------------------------
12261 -- Valid_Default_Attribute --
12262 -----------------------------
12264 procedure Valid_Default_Attribute (Nam : Entity_Id; Def : Node_Id) is
12265 Attr_Id : constant Attribute_Id :=
12266 Get_Attribute_Id (Attribute_Name (Def));
12267 T : constant Entity_Id := Entity (Prefix (Def));
12268 Is_Fun : constant Boolean := (Ekind (Nam) = E_Function);
12281 F := First_Formal (Nam);
12282 while Present (F) loop
12283 Num_F := Num_F + 1;
12288 when Attribute_Adjacent | Attribute_Ceiling | Attribute_Copy_Sign |
12289 Attribute_Floor | Attribute_Fraction | Attribute_Machine |
12290 Attribute_Model | Attribute_Remainder | Attribute_Rounding |
12291 Attribute_Unbiased_Rounding =>
12294 and then Is_Floating_Point_Type (T);
12296 when Attribute_Image | Attribute_Pred | Attribute_Succ |
12297 Attribute_Value | Attribute_Wide_Image |
12298 Attribute_Wide_Value =>
12299 OK := (Is_Fun and then Num_F = 1 and then Is_Scalar_Type (T));
12301 when Attribute_Max | Attribute_Min =>
12302 OK := (Is_Fun and then Num_F = 2 and then Is_Scalar_Type (T));
12304 when Attribute_Input =>
12305 OK := (Is_Fun and then Num_F = 1);
12307 when Attribute_Output | Attribute_Read | Attribute_Write =>
12308 OK := (not Is_Fun and then Num_F = 2);
12315 Error_Msg_N ("attribute reference has wrong profile for subprogram",
12318 end Valid_Default_Attribute;