1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2018, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Aspects
; use Aspects
;
27 with Atree
; use Atree
;
28 with Contracts
; use Contracts
;
29 with Einfo
; use Einfo
;
30 with Elists
; use Elists
;
31 with Errout
; use Errout
;
32 with Expander
; use Expander
;
33 with Fname
; use Fname
;
34 with Fname
.UF
; use Fname
.UF
;
35 with Freeze
; use Freeze
;
36 with Ghost
; use Ghost
;
37 with Itypes
; use Itypes
;
39 with Lib
.Load
; use Lib
.Load
;
40 with Lib
.Xref
; use Lib
.Xref
;
41 with Nlists
; use Nlists
;
42 with Namet
; use Namet
;
43 with Nmake
; use Nmake
;
45 with Rident
; use Rident
;
46 with Restrict
; use Restrict
;
47 with Rtsfind
; use Rtsfind
;
49 with Sem_Aux
; use Sem_Aux
;
50 with Sem_Cat
; use Sem_Cat
;
51 with Sem_Ch3
; use Sem_Ch3
;
52 with Sem_Ch6
; use Sem_Ch6
;
53 with Sem_Ch7
; use Sem_Ch7
;
54 with Sem_Ch8
; use Sem_Ch8
;
55 with Sem_Ch10
; use Sem_Ch10
;
56 with Sem_Ch13
; use Sem_Ch13
;
57 with Sem_Dim
; use Sem_Dim
;
58 with Sem_Disp
; use Sem_Disp
;
59 with Sem_Elab
; use Sem_Elab
;
60 with Sem_Elim
; use Sem_Elim
;
61 with Sem_Eval
; use Sem_Eval
;
62 with Sem_Prag
; use Sem_Prag
;
63 with Sem_Res
; use Sem_Res
;
64 with Sem_Type
; use Sem_Type
;
65 with Sem_Util
; use Sem_Util
;
66 with Sem_Warn
; use Sem_Warn
;
67 with Stand
; use Stand
;
68 with Sinfo
; use Sinfo
;
69 with Sinfo
.CN
; use Sinfo
.CN
;
70 with Sinput
; use Sinput
;
71 with Sinput
.L
; use Sinput
.L
;
72 with Snames
; use Snames
;
73 with Stringt
; use Stringt
;
74 with Uname
; use Uname
;
76 with Tbuild
; use Tbuild
;
77 with Uintp
; use Uintp
;
78 with Urealp
; use Urealp
;
79 with Warnsw
; use Warnsw
;
83 package body Sem_Ch12
is
85 ----------------------------------------------------------
86 -- Implementation of Generic Analysis and Instantiation --
87 ----------------------------------------------------------
89 -- GNAT implements generics by macro expansion. No attempt is made to share
90 -- generic instantiations (for now). Analysis of a generic definition does
91 -- not perform any expansion action, but the expander must be called on the
92 -- tree for each instantiation, because the expansion may of course depend
93 -- on the generic actuals. All of this is best achieved as follows:
95 -- a) Semantic analysis of a generic unit is performed on a copy of the
96 -- tree for the generic unit. All tree modifications that follow analysis
97 -- do not affect the original tree. Links are kept between the original
98 -- tree and the copy, in order to recognize non-local references within
99 -- the generic, and propagate them to each instance (recall that name
100 -- resolution is done on the generic declaration: generics are not really
101 -- macros). This is summarized in the following diagram:
103 -- .-----------. .----------.
104 -- | semantic |<--------------| generic |
106 -- | |==============>| |
107 -- |___________| global |__________|
118 -- b) Each instantiation copies the original tree, and inserts into it a
119 -- series of declarations that describe the mapping between generic formals
120 -- and actuals. For example, a generic In OUT parameter is an object
121 -- renaming of the corresponding actual, etc. Generic IN parameters are
122 -- constant declarations.
124 -- c) In order to give the right visibility for these renamings, we use
125 -- a different scheme for package and subprogram instantiations. For
126 -- packages, the list of renamings is inserted into the package
127 -- specification, before the visible declarations of the package. The
128 -- renamings are analyzed before any of the text of the instance, and are
129 -- thus visible at the right place. Furthermore, outside of the instance,
130 -- the generic parameters are visible and denote their corresponding
133 -- For subprograms, we create a container package to hold the renamings
134 -- and the subprogram instance itself. Analysis of the package makes the
135 -- renaming declarations visible to the subprogram. After analyzing the
136 -- package, the defining entity for the subprogram is touched-up so that
137 -- it appears declared in the current scope, and not inside the container
140 -- If the instantiation is a compilation unit, the container package is
141 -- given the same name as the subprogram instance. This ensures that
142 -- the elaboration procedure called by the binder, using the compilation
143 -- unit name, calls in fact the elaboration procedure for the package.
145 -- Not surprisingly, private types complicate this approach. By saving in
146 -- the original generic object the non-local references, we guarantee that
147 -- the proper entities are referenced at the point of instantiation.
148 -- However, for private types, this by itself does not insure that the
149 -- proper VIEW of the entity is used (the full type may be visible at the
150 -- point of generic definition, but not at instantiation, or vice-versa).
151 -- In order to reference the proper view, we special-case any reference
152 -- to private types in the generic object, by saving both views, one in
153 -- the generic and one in the semantic copy. At time of instantiation, we
154 -- check whether the two views are consistent, and exchange declarations if
155 -- necessary, in order to restore the correct visibility. Similarly, if
156 -- the instance view is private when the generic view was not, we perform
157 -- the exchange. After completing the instantiation, we restore the
158 -- current visibility. The flag Has_Private_View marks identifiers in the
159 -- the generic unit that require checking.
161 -- Visibility within nested generic units requires special handling.
162 -- Consider the following scheme:
164 -- type Global is ... -- outside of generic unit.
168 -- type Semi_Global is ... -- global to inner.
171 -- procedure inner (X1 : Global; X2 : Semi_Global);
173 -- procedure in2 is new inner (...); -- 4
176 -- package New_Outer is new Outer (...); -- 2
177 -- procedure New_Inner is new New_Outer.Inner (...); -- 3
179 -- The semantic analysis of Outer captures all occurrences of Global.
180 -- The semantic analysis of Inner (at 1) captures both occurrences of
181 -- Global and Semi_Global.
183 -- At point 2 (instantiation of Outer), we also produce a generic copy
184 -- of Inner, even though Inner is, at that point, not being instantiated.
185 -- (This is just part of the semantic analysis of New_Outer).
187 -- Critically, references to Global within Inner must be preserved, while
188 -- references to Semi_Global should not preserved, because they must now
189 -- resolve to an entity within New_Outer. To distinguish between these, we
190 -- use a global variable, Current_Instantiated_Parent, which is set when
191 -- performing a generic copy during instantiation (at 2). This variable is
192 -- used when performing a generic copy that is not an instantiation, but
193 -- that is nested within one, as the occurrence of 1 within 2. The analysis
194 -- of a nested generic only preserves references that are global to the
195 -- enclosing Current_Instantiated_Parent. We use the Scope_Depth value to
196 -- determine whether a reference is external to the given parent.
198 -- The instantiation at point 3 requires no special treatment. The method
199 -- works as well for further nestings of generic units, but of course the
200 -- variable Current_Instantiated_Parent must be stacked because nested
201 -- instantiations can occur, e.g. the occurrence of 4 within 2.
203 -- The instantiation of package and subprogram bodies is handled in a
204 -- similar manner, except that it is delayed until after semantic
205 -- analysis is complete. In this fashion complex cross-dependencies
206 -- between several package declarations and bodies containing generics
207 -- can be compiled which otherwise would diagnose spurious circularities.
209 -- For example, it is possible to compile two packages A and B that
210 -- have the following structure:
212 -- package A is package B is
213 -- generic ... generic ...
214 -- package G_A is package G_B is
217 -- package body A is package body B is
218 -- package N_B is new G_B (..) package N_A is new G_A (..)
220 -- The table Pending_Instantiations in package Inline is used to keep
221 -- track of body instantiations that are delayed in this manner. Inline
222 -- handles the actual calls to do the body instantiations. This activity
223 -- is part of Inline, since the processing occurs at the same point, and
224 -- for essentially the same reason, as the handling of inlined routines.
226 ----------------------------------------------
227 -- Detection of Instantiation Circularities --
228 ----------------------------------------------
230 -- If we have a chain of instantiations that is circular, this is static
231 -- error which must be detected at compile time. The detection of these
232 -- circularities is carried out at the point that we insert a generic
233 -- instance spec or body. If there is a circularity, then the analysis of
234 -- the offending spec or body will eventually result in trying to load the
235 -- same unit again, and we detect this problem as we analyze the package
236 -- instantiation for the second time.
238 -- At least in some cases after we have detected the circularity, we get
239 -- into trouble if we try to keep going. The following flag is set if a
240 -- circularity is detected, and used to abandon compilation after the
241 -- messages have been posted.
243 -----------------------------------------
244 -- Implementation of Generic Contracts --
245 -----------------------------------------
247 -- A "contract" is a collection of aspects and pragmas that either verify a
248 -- property of a construct at runtime or classify the data flow to and from
249 -- the construct in some fashion.
251 -- Generic packages, subprograms and their respective bodies may be subject
252 -- to the following contract-related aspects or pragmas collectively known
255 -- package subprogram [body]
256 -- Abstract_State Contract_Cases
257 -- Initial_Condition Depends
258 -- Initializes Extensions_Visible
261 -- Refined_State Post_Class
271 -- Most package contract annotations utilize forward references to classify
272 -- data declared within the package [body]. Subprogram annotations then use
273 -- the classifications to further refine them. These inter dependencies are
274 -- problematic with respect to the implementation of generics because their
275 -- analysis, capture of global references and instantiation does not mesh
276 -- well with the existing mechanism.
278 -- 1) Analysis of generic contracts is carried out the same way non-generic
279 -- contracts are analyzed:
281 -- 1.1) General rule - a contract is analyzed after all related aspects
282 -- and pragmas are analyzed. This is done by routines
284 -- Analyze_Package_Body_Contract
285 -- Analyze_Package_Contract
286 -- Analyze_Subprogram_Body_Contract
287 -- Analyze_Subprogram_Contract
289 -- 1.2) Compilation unit - the contract is analyzed after Pragmas_After
292 -- 1.3) Compilation unit body - the contract is analyzed at the end of
293 -- the body declaration list.
295 -- 1.4) Package - the contract is analyzed at the end of the private or
296 -- visible declarations, prior to analyzing the contracts of any nested
297 -- packages or subprograms.
299 -- 1.5) Package body - the contract is analyzed at the end of the body
300 -- declaration list, prior to analyzing the contracts of any nested
301 -- packages or subprograms.
303 -- 1.6) Subprogram - if the subprogram is declared inside a block, a
304 -- package or a subprogram, then its contract is analyzed at the end of
305 -- the enclosing declarations, otherwise the subprogram is a compilation
308 -- 1.7) Subprogram body - if the subprogram body is declared inside a
309 -- block, a package body or a subprogram body, then its contract is
310 -- analyzed at the end of the enclosing declarations, otherwise the
311 -- subprogram is a compilation unit 1.3).
313 -- 2) Capture of global references within contracts is done after capturing
314 -- global references within the generic template. There are two reasons for
315 -- this delay - pragma annotations are not part of the generic template in
316 -- the case of a generic subprogram declaration, and analysis of contracts
319 -- Contract-related source pragmas within generic templates are prepared
320 -- for delayed capture of global references by routine
322 -- Create_Generic_Contract
324 -- The routine associates these pragmas with the contract of the template.
325 -- In the case of a generic subprogram declaration, the routine creates
326 -- generic templates for the pragmas declared after the subprogram because
327 -- they are not part of the template.
329 -- generic -- template starts
330 -- procedure Gen_Proc (Input : Integer); -- template ends
331 -- pragma Precondition (Input > 0); -- requires own template
333 -- 2.1) The capture of global references with aspect specifications and
334 -- source pragmas that apply to a generic unit must be suppressed when
335 -- the generic template is being processed because the contracts have not
336 -- been analyzed yet. Any attempts to capture global references at that
337 -- point will destroy the Associated_Node linkages and leave the template
338 -- undecorated. This delay is controlled by routine
340 -- Requires_Delayed_Save
342 -- 2.2) The real capture of global references within a contract is done
343 -- after the contract has been analyzed, by routine
345 -- Save_Global_References_In_Contract
347 -- 3) The instantiation of a generic contract occurs as part of the
348 -- instantiation of the contract owner. Generic subprogram declarations
349 -- require additional processing when the contract is specified by pragmas
350 -- because the pragmas are not part of the generic template. This is done
353 -- Instantiate_Subprogram_Contract
355 Circularity_Detected
: Boolean := False;
356 -- This should really be reset on encountering a new main unit, but in
357 -- practice we are not using multiple main units so it is not critical.
359 --------------------------------------------------
360 -- Formal packages and partial parameterization --
361 --------------------------------------------------
363 -- When compiling a generic, a formal package is a local instantiation. If
364 -- declared with a box, its generic formals are visible in the enclosing
365 -- generic. If declared with a partial list of actuals, those actuals that
366 -- are defaulted (covered by an Others clause, or given an explicit box
367 -- initialization) are also visible in the enclosing generic, while those
368 -- that have a corresponding actual are not.
370 -- In our source model of instantiation, the same visibility must be
371 -- present in the spec and body of an instance: the names of the formals
372 -- that are defaulted must be made visible within the instance, and made
373 -- invisible (hidden) after the instantiation is complete, so that they
374 -- are not accessible outside of the instance.
376 -- In a generic, a formal package is treated like a special instantiation.
377 -- Our Ada 95 compiler handled formals with and without box in different
378 -- ways. With partial parameterization, we use a single model for both.
379 -- We create a package declaration that consists of the specification of
380 -- the generic package, and a set of declarations that map the actuals
381 -- into local renamings, just as we do for bona fide instantiations. For
382 -- defaulted parameters and formals with a box, we copy directly the
383 -- declarations of the formal into this local package. The result is a
384 -- a package whose visible declarations may include generic formals. This
385 -- package is only used for type checking and visibility analysis, and
386 -- never reaches the back-end, so it can freely violate the placement
387 -- rules for generic formal declarations.
389 -- The list of declarations (renamings and copies of formals) is built
390 -- by Analyze_Associations, just as for regular instantiations.
392 -- At the point of instantiation, conformance checking must be applied only
393 -- to those parameters that were specified in the formal. We perform this
394 -- checking by creating another internal instantiation, this one including
395 -- only the renamings and the formals (the rest of the package spec is not
396 -- relevant to conformance checking). We can then traverse two lists: the
397 -- list of actuals in the instance that corresponds to the formal package,
398 -- and the list of actuals produced for this bogus instantiation. We apply
399 -- the conformance rules to those actuals that are not defaulted (i.e.
400 -- which still appear as generic formals.
402 -- When we compile an instance body we must make the right parameters
403 -- visible again. The predicate Is_Generic_Formal indicates which of the
404 -- formals should have its Is_Hidden flag reset.
406 -----------------------
407 -- Local subprograms --
408 -----------------------
410 procedure Abandon_Instantiation
(N
: Node_Id
);
411 pragma No_Return
(Abandon_Instantiation
);
412 -- Posts an error message "instantiation abandoned" at the indicated node
413 -- and then raises the exception Instantiation_Error to do it.
415 procedure Analyze_Formal_Array_Type
416 (T
: in out Entity_Id
;
418 -- A formal array type is treated like an array type declaration, and
419 -- invokes Array_Type_Declaration (sem_ch3) whose first parameter is
420 -- in-out, because in the case of an anonymous type the entity is
421 -- actually created in the procedure.
423 -- The following procedures treat other kinds of formal parameters
425 procedure Analyze_Formal_Derived_Interface_Type
430 procedure Analyze_Formal_Derived_Type
435 procedure Analyze_Formal_Interface_Type
440 -- The following subprograms create abbreviated declarations for formal
441 -- scalar types. We introduce an anonymous base of the proper class for
442 -- each of them, and define the formals as constrained first subtypes of
443 -- their bases. The bounds are expressions that are non-static in the
446 procedure Analyze_Formal_Decimal_Fixed_Point_Type
447 (T
: Entity_Id
; Def
: Node_Id
);
448 procedure Analyze_Formal_Discrete_Type
(T
: Entity_Id
; Def
: Node_Id
);
449 procedure Analyze_Formal_Floating_Type
(T
: Entity_Id
; Def
: Node_Id
);
450 procedure Analyze_Formal_Signed_Integer_Type
(T
: Entity_Id
; Def
: Node_Id
);
451 procedure Analyze_Formal_Modular_Type
(T
: Entity_Id
; Def
: Node_Id
);
452 procedure Analyze_Formal_Ordinary_Fixed_Point_Type
453 (T
: Entity_Id
; Def
: Node_Id
);
455 procedure Analyze_Formal_Private_Type
459 -- Creates a new private type, which does not require completion
461 procedure Analyze_Formal_Incomplete_Type
(T
: Entity_Id
; Def
: Node_Id
);
462 -- Ada 2012: Creates a new incomplete type whose actual does not freeze
464 procedure Analyze_Generic_Formal_Part
(N
: Node_Id
);
465 -- Analyze generic formal part
467 procedure Analyze_Generic_Access_Type
(T
: Entity_Id
; Def
: Node_Id
);
468 -- Create a new access type with the given designated type
470 function Analyze_Associations
473 F_Copy
: List_Id
) return List_Id
;
474 -- At instantiation time, build the list of associations between formals
475 -- and actuals. Each association becomes a renaming declaration for the
476 -- formal entity. F_Copy is the analyzed list of formals in the generic
477 -- copy. It is used to apply legality checks to the actuals. I_Node is the
478 -- instantiation node itself.
480 procedure Analyze_Subprogram_Instantiation
484 procedure Build_Instance_Compilation_Unit_Nodes
488 -- This procedure is used in the case where the generic instance of a
489 -- subprogram body or package body is a library unit. In this case, the
490 -- original library unit node for the generic instantiation must be
491 -- replaced by the resulting generic body, and a link made to a new
492 -- compilation unit node for the generic declaration. The argument N is
493 -- the original generic instantiation. Act_Body and Act_Decl are the body
494 -- and declaration of the instance (either package body and declaration
495 -- nodes or subprogram body and declaration nodes depending on the case).
496 -- On return, the node N has been rewritten with the actual body.
498 procedure Check_Access_Definition
(N
: Node_Id
);
499 -- Subsidiary routine to null exclusion processing. Perform an assertion
500 -- check on Ada version and the presence of an access definition in N.
502 procedure Check_Formal_Packages
(P_Id
: Entity_Id
);
503 -- Apply the following to all formal packages in generic associations
505 procedure Check_Formal_Package_Instance
506 (Formal_Pack
: Entity_Id
;
507 Actual_Pack
: Entity_Id
);
508 -- Verify that the actuals of the actual instance match the actuals of
509 -- the template for a formal package that is not declared with a box.
511 procedure Check_Forward_Instantiation
(Decl
: Node_Id
);
512 -- If the generic is a local entity and the corresponding body has not
513 -- been seen yet, flag enclosing packages to indicate that it will be
514 -- elaborated after the generic body. Subprograms declared in the same
515 -- package cannot be inlined by the front end because front-end inlining
516 -- requires a strict linear order of elaboration.
518 function Check_Hidden_Primitives
(Assoc_List
: List_Id
) return Elist_Id
;
519 -- Check if some association between formals and actuals requires to make
520 -- visible primitives of a tagged type, and make those primitives visible.
521 -- Return the list of primitives whose visibility is modified (to restore
522 -- their visibility later through Restore_Hidden_Primitives). If no
523 -- candidate is found then return No_Elist.
525 procedure Check_Hidden_Child_Unit
527 Gen_Unit
: Entity_Id
;
528 Act_Decl_Id
: Entity_Id
);
529 -- If the generic unit is an implicit child instance within a parent
530 -- instance, we need to make an explicit test that it is not hidden by
531 -- a child instance of the same name and parent.
533 procedure Check_Generic_Actuals
534 (Instance
: Entity_Id
;
535 Is_Formal_Box
: Boolean);
536 -- Similar to previous one. Check the actuals in the instantiation,
537 -- whose views can change between the point of instantiation and the point
538 -- of instantiation of the body. In addition, mark the generic renamings
539 -- as generic actuals, so that they are not compatible with other actuals.
540 -- Recurse on an actual that is a formal package whose declaration has
543 function Contains_Instance_Of
546 N
: Node_Id
) return Boolean;
547 -- Inner is instantiated within the generic Outer. Check whether Inner
548 -- directly or indirectly contains an instance of Outer or of one of its
549 -- parents, in the case of a subunit. Each generic unit holds a list of
550 -- the entities instantiated within (at any depth). This procedure
551 -- determines whether the set of such lists contains a cycle, i.e. an
552 -- illegal circular instantiation.
554 function Denotes_Formal_Package
556 On_Exit
: Boolean := False;
557 Instance
: Entity_Id
:= Empty
) return Boolean;
558 -- Returns True if E is a formal package of an enclosing generic, or
559 -- the actual for such a formal in an enclosing instantiation. If such
560 -- a package is used as a formal in an nested generic, or as an actual
561 -- in a nested instantiation, the visibility of ITS formals should not
562 -- be modified. When called from within Restore_Private_Views, the flag
563 -- On_Exit is true, to indicate that the search for a possible enclosing
564 -- instance should ignore the current one. In that case Instance denotes
565 -- the declaration for which this is an actual. This declaration may be
566 -- an instantiation in the source, or the internal instantiation that
567 -- corresponds to the actual for a formal package.
569 function Earlier
(N1
, N2
: Node_Id
) return Boolean;
570 -- Yields True if N1 and N2 appear in the same compilation unit,
571 -- ignoring subunits, and if N1 is to the left of N2 in a left-to-right
572 -- traversal of the tree for the unit. Used to determine the placement
573 -- of freeze nodes for instance bodies that may depend on other instances.
575 function Find_Actual_Type
577 Gen_Type
: Entity_Id
) return Entity_Id
;
578 -- When validating the actual types of a child instance, check whether
579 -- the formal is a formal type of the parent unit, and retrieve the current
580 -- actual for it. Typ is the entity in the analyzed formal type declaration
581 -- (component or index type of an array type, or designated type of an
582 -- access formal) and Gen_Type is the enclosing analyzed formal array
583 -- or access type. The desired actual may be a formal of a parent, or may
584 -- be declared in a formal package of a parent. In both cases it is a
585 -- generic actual type because it appears within a visible instance.
586 -- Finally, it may be declared in a parent unit without being a formal
587 -- of that unit, in which case it must be retrieved by visibility.
588 -- Ambiguities may still arise if two homonyms are declared in two formal
589 -- packages, and the prefix of the formal type may be needed to resolve
590 -- the ambiguity in the instance ???
592 procedure Freeze_Subprogram_Body
593 (Inst_Node
: Node_Id
;
595 Pack_Id
: Entity_Id
);
596 -- The generic body may appear textually after the instance, including
597 -- in the proper body of a stub, or within a different package instance.
598 -- Given that the instance can only be elaborated after the generic, we
599 -- place freeze_nodes for the instance and/or for packages that may enclose
600 -- the instance and the generic, so that the back-end can establish the
601 -- proper order of elaboration.
603 function Get_Associated_Node
(N
: Node_Id
) return Node_Id
;
604 -- In order to propagate semantic information back from the analyzed copy
605 -- to the original generic, we maintain links between selected nodes in the
606 -- generic and their corresponding copies. At the end of generic analysis,
607 -- the routine Save_Global_References traverses the generic tree, examines
608 -- the semantic information, and preserves the links to those nodes that
609 -- contain global information. At instantiation, the information from the
610 -- associated node is placed on the new copy, so that name resolution is
613 -- Three kinds of source nodes have associated nodes:
615 -- a) those that can reference (denote) entities, that is identifiers,
616 -- character literals, expanded_names, operator symbols, operators,
617 -- and attribute reference nodes. These nodes have an Entity field
618 -- and are the set of nodes that are in N_Has_Entity.
620 -- b) aggregates (N_Aggregate and N_Extension_Aggregate)
622 -- c) selected components (N_Selected_Component)
624 -- For the first class, the associated node preserves the entity if it is
625 -- global. If the generic contains nested instantiations, the associated
626 -- node itself has been recopied, and a chain of them must be followed.
628 -- For aggregates, the associated node allows retrieval of the type, which
629 -- may otherwise not appear in the generic. The view of this type may be
630 -- different between generic and instantiation, and the full view can be
631 -- installed before the instantiation is analyzed. For aggregates of type
632 -- extensions, the same view exchange may have to be performed for some of
633 -- the ancestor types, if their view is private at the point of
636 -- Nodes that are selected components in the parse tree may be rewritten
637 -- as expanded names after resolution, and must be treated as potential
638 -- entity holders, which is why they also have an Associated_Node.
640 -- Nodes that do not come from source, such as freeze nodes, do not appear
641 -- in the generic tree, and need not have an associated node.
643 -- The associated node is stored in the Associated_Node field. Note that
644 -- this field overlaps Entity, which is fine, because the whole point is
645 -- that we don't need or want the normal Entity field in this situation.
647 function Has_Been_Exchanged
(E
: Entity_Id
) return Boolean;
648 -- Traverse the Exchanged_Views list to see if a type was private
649 -- and has already been flipped during this phase of instantiation.
651 procedure Hide_Current_Scope
;
652 -- When instantiating a generic child unit, the parent context must be
653 -- present, but the instance and all entities that may be generated
654 -- must be inserted in the current scope. We leave the current scope
655 -- on the stack, but make its entities invisible to avoid visibility
656 -- problems. This is reversed at the end of the instantiation. This is
657 -- not done for the instantiation of the bodies, which only require the
658 -- instances of the generic parents to be in scope.
660 function In_Same_Declarative_Part
662 Inst
: Node_Id
) return Boolean;
663 -- True if the instantiation Inst and the given freeze_node F_Node appear
664 -- within the same declarative part, ignoring subunits, but with no inter-
665 -- vening subprograms or concurrent units. Used to find the proper plave
666 -- for the freeze node of an instance, when the generic is declared in a
667 -- previous instance. If predicate is true, the freeze node of the instance
668 -- can be placed after the freeze node of the previous instance, Otherwise
669 -- it has to be placed at the end of the current declarative part.
671 function In_Main_Context
(E
: Entity_Id
) return Boolean;
672 -- Check whether an instantiation is in the context of the main unit.
673 -- Used to determine whether its body should be elaborated to allow
674 -- front-end inlining.
676 procedure Inherit_Context
(Gen_Decl
: Node_Id
; Inst
: Node_Id
);
677 -- Add the context clause of the unit containing a generic unit to a
678 -- compilation unit that is, or contains, an instantiation.
681 -- Establish environment for subsequent instantiation. Separated from
682 -- Save_Env because data-structures for visibility handling must be
683 -- initialized before call to Check_Generic_Child_Unit.
685 procedure Inline_Instance_Body
687 Gen_Unit
: Entity_Id
;
689 -- If front-end inlining is requested, instantiate the package body,
690 -- and preserve the visibility of its compilation unit, to insure
691 -- that successive instantiations succeed.
693 procedure Insert_Freeze_Node_For_Instance
696 -- N denotes a package or a subprogram instantiation and F_Node is the
697 -- associated freeze node. Insert the freeze node before the first source
698 -- body which follows immediately after N. If no such body is found, the
699 -- freeze node is inserted at the end of the declarative region which
702 procedure Install_Body
707 -- If the instantiation happens textually before the body of the generic,
708 -- the instantiation of the body must be analyzed after the generic body,
709 -- and not at the point of instantiation. Such early instantiations can
710 -- happen if the generic and the instance appear in a package declaration
711 -- because the generic body can only appear in the corresponding package
712 -- body. Early instantiations can also appear if generic, instance and
713 -- body are all in the declarative part of a subprogram or entry. Entities
714 -- of packages that are early instantiations are delayed, and their freeze
715 -- node appears after the generic body. This rather complex machinery is
716 -- needed when nested instantiations are present, because the source does
717 -- not carry any indication of where the corresponding instance bodies must
718 -- be installed and frozen.
720 procedure Install_Formal_Packages
(Par
: Entity_Id
);
721 -- Install the visible part of any formal of the parent that is a formal
722 -- package. Note that for the case of a formal package with a box, this
723 -- includes the formal part of the formal package (12.7(10/2)).
725 procedure Install_Hidden_Primitives
726 (Prims_List
: in out Elist_Id
;
729 -- Remove suffix 'P' from hidden primitives of Act_T to match the
730 -- visibility of primitives of Gen_T. The list of primitives to which
731 -- the suffix is removed is added to Prims_List to restore them later.
733 procedure Install_Parent
(P
: Entity_Id
; In_Body
: Boolean := False);
734 -- When compiling an instance of a child unit the parent (which is
735 -- itself an instance) is an enclosing scope that must be made
736 -- immediately visible. This procedure is also used to install the non-
737 -- generic parent of a generic child unit when compiling its body, so
738 -- that full views of types in the parent are made visible.
740 -- The functions Instantiate_XXX perform various legality checks and build
741 -- the declarations for instantiated generic parameters. In all of these
742 -- Formal is the entity in the generic unit, Actual is the entity of
743 -- expression in the generic associations, and Analyzed_Formal is the
744 -- formal in the generic copy, which contains the semantic information to
745 -- be used to validate the actual.
747 function Instantiate_Object
750 Analyzed_Formal
: Node_Id
) return List_Id
;
752 function Instantiate_Type
755 Analyzed_Formal
: Node_Id
;
756 Actual_Decls
: List_Id
) return List_Id
;
758 function Instantiate_Formal_Subprogram
761 Analyzed_Formal
: Node_Id
) return Node_Id
;
763 function Instantiate_Formal_Package
766 Analyzed_Formal
: Node_Id
) return List_Id
;
767 -- If the formal package is declared with a box, special visibility rules
768 -- apply to its formals: they are in the visible part of the package. This
769 -- is true in the declarative region of the formal package, that is to say
770 -- in the enclosing generic or instantiation. For an instantiation, the
771 -- parameters of the formal package are made visible in an explicit step.
772 -- Furthermore, if the actual has a visible USE clause, these formals must
773 -- be made potentially use-visible as well. On exit from the enclosing
774 -- instantiation, the reverse must be done.
776 -- For a formal package declared without a box, there are conformance rules
777 -- that apply to the actuals in the generic declaration and the actuals of
778 -- the actual package in the enclosing instantiation. The simplest way to
779 -- apply these rules is to repeat the instantiation of the formal package
780 -- in the context of the enclosing instance, and compare the generic
781 -- associations of this instantiation with those of the actual package.
782 -- This internal instantiation only needs to contain the renamings of the
783 -- formals: the visible and private declarations themselves need not be
786 -- In Ada 2005, the formal package may be only partially parameterized.
787 -- In that case the visibility step must make visible those actuals whose
788 -- corresponding formals were given with a box. A final complication
789 -- involves inherited operations from formal derived types, which must
790 -- be visible if the type is.
792 function Is_In_Main_Unit
(N
: Node_Id
) return Boolean;
793 -- Test if given node is in the main unit
795 procedure Load_Parent_Of_Generic
798 Body_Optional
: Boolean := False);
799 -- If the generic appears in a separate non-generic library unit, load the
800 -- corresponding body to retrieve the body of the generic. N is the node
801 -- for the generic instantiation, Spec is the generic package declaration.
803 -- Body_Optional is a flag that indicates that the body is being loaded to
804 -- ensure that temporaries are generated consistently when there are other
805 -- instances in the current declarative part that precede the one being
806 -- loaded. In that case a missing body is acceptable.
808 procedure Map_Formal_Package_Entities
(Form
: Entity_Id
; Act
: Entity_Id
);
809 -- Within the generic part, entities in the formal package are
810 -- visible. To validate subsequent type declarations, indicate
811 -- the correspondence between the entities in the analyzed formal,
812 -- and the entities in the actual package. There are three packages
813 -- involved in the instantiation of a formal package: the parent
814 -- generic P1 which appears in the generic declaration, the fake
815 -- instantiation P2 which appears in the analyzed generic, and whose
816 -- visible entities may be used in subsequent formals, and the actual
817 -- P3 in the instance. To validate subsequent formals, me indicate
818 -- that the entities in P2 are mapped into those of P3. The mapping of
819 -- entities has to be done recursively for nested packages.
821 procedure Move_Freeze_Nodes
825 -- Freeze nodes can be generated in the analysis of a generic unit, but
826 -- will not be seen by the back-end. It is necessary to move those nodes
827 -- to the enclosing scope if they freeze an outer entity. We place them
828 -- at the end of the enclosing generic package, which is semantically
831 procedure Preanalyze_Actuals
(N
: Node_Id
; Inst
: Entity_Id
:= Empty
);
832 -- Analyze actuals to perform name resolution. Full resolution is done
833 -- later, when the expected types are known, but names have to be captured
834 -- before installing parents of generics, that are not visible for the
835 -- actuals themselves.
837 -- If Inst is present, it is the entity of the package instance. This
838 -- entity is marked as having a limited_view actual when some actual is
839 -- a limited view. This is used to place the instance body properly.
841 procedure Provide_Completing_Bodies
(N
: Node_Id
);
842 -- Generate completing bodies for all subprograms found within package or
843 -- subprogram declaration N.
845 procedure Remove_Parent
(In_Body
: Boolean := False);
846 -- Reverse effect after instantiation of child is complete
848 procedure Restore_Hidden_Primitives
(Prims_List
: in out Elist_Id
);
849 -- Restore suffix 'P' to primitives of Prims_List and leave Prims_List
852 procedure Set_Instance_Env
853 (Gen_Unit
: Entity_Id
;
854 Act_Unit
: Entity_Id
);
855 -- Save current instance on saved environment, to be used to determine
856 -- the global status of entities in nested instances. Part of Save_Env.
857 -- called after verifying that the generic unit is legal for the instance,
858 -- The procedure also examines whether the generic unit is a predefined
859 -- unit, in order to set configuration switches accordingly. As a result
860 -- the procedure must be called after analyzing and freezing the actuals.
862 procedure Set_Instance_Of
(A
: Entity_Id
; B
: Entity_Id
);
863 -- Associate analyzed generic parameter with corresponding instance. Used
864 -- for semantic checks at instantiation time.
866 function True_Parent
(N
: Node_Id
) return Node_Id
;
867 -- For a subunit, return parent of corresponding stub, else return
870 procedure Valid_Default_Attribute
(Nam
: Entity_Id
; Def
: Node_Id
);
871 -- Verify that an attribute that appears as the default for a formal
872 -- subprogram is a function or procedure with the correct profile.
874 -------------------------------------------
875 -- Data Structures for Generic Renamings --
876 -------------------------------------------
878 -- The map Generic_Renamings associates generic entities with their
879 -- corresponding actuals. Currently used to validate type instances. It
880 -- will eventually be used for all generic parameters to eliminate the
881 -- need for overload resolution in the instance.
883 type Assoc_Ptr
is new Int
;
885 Assoc_Null
: constant Assoc_Ptr
:= -1;
890 Next_In_HTable
: Assoc_Ptr
;
893 package Generic_Renamings
is new Table
.Table
894 (Table_Component_Type
=> Assoc
,
895 Table_Index_Type
=> Assoc_Ptr
,
896 Table_Low_Bound
=> 0,
898 Table_Increment
=> 100,
899 Table_Name
=> "Generic_Renamings");
901 -- Variable to hold enclosing instantiation. When the environment is
902 -- saved for a subprogram inlining, the corresponding Act_Id is empty.
904 Current_Instantiated_Parent
: Assoc
:= (Empty
, Empty
, Assoc_Null
);
906 -- Hash table for associations
908 HTable_Size
: constant := 37;
909 type HTable_Range
is range 0 .. HTable_Size
- 1;
911 procedure Set_Next_Assoc
(E
: Assoc_Ptr
; Next
: Assoc_Ptr
);
912 function Next_Assoc
(E
: Assoc_Ptr
) return Assoc_Ptr
;
913 function Get_Gen_Id
(E
: Assoc_Ptr
) return Entity_Id
;
914 function Hash
(F
: Entity_Id
) return HTable_Range
;
916 package Generic_Renamings_HTable
is new GNAT
.HTable
.Static_HTable
(
917 Header_Num
=> HTable_Range
,
919 Elmt_Ptr
=> Assoc_Ptr
,
920 Null_Ptr
=> Assoc_Null
,
921 Set_Next
=> Set_Next_Assoc
,
924 Get_Key
=> Get_Gen_Id
,
928 Exchanged_Views
: Elist_Id
;
929 -- This list holds the private views that have been exchanged during
930 -- instantiation to restore the visibility of the generic declaration.
931 -- (see comments above). After instantiation, the current visibility is
932 -- reestablished by means of a traversal of this list.
934 Hidden_Entities
: Elist_Id
;
935 -- This list holds the entities of the current scope that are removed
936 -- from immediate visibility when instantiating a child unit. Their
937 -- visibility is restored in Remove_Parent.
939 -- Because instantiations can be recursive, the following must be saved
940 -- on entry and restored on exit from an instantiation (spec or body).
941 -- This is done by the two procedures Save_Env and Restore_Env. For
942 -- package and subprogram instantiations (but not for the body instances)
943 -- the action of Save_Env is done in two steps: Init_Env is called before
944 -- Check_Generic_Child_Unit, because setting the parent instances requires
945 -- that the visibility data structures be properly initialized. Once the
946 -- generic is unit is validated, Set_Instance_Env completes Save_Env.
948 Parent_Unit_Visible
: Boolean := False;
949 -- Parent_Unit_Visible is used when the generic is a child unit, and
950 -- indicates whether the ultimate parent of the generic is visible in the
951 -- instantiation environment. It is used to reset the visibility of the
952 -- parent at the end of the instantiation (see Remove_Parent).
954 Instance_Parent_Unit
: Entity_Id
:= Empty
;
955 -- This records the ultimate parent unit of an instance of a generic
956 -- child unit and is used in conjunction with Parent_Unit_Visible to
957 -- indicate the unit to which the Parent_Unit_Visible flag corresponds.
959 type Instance_Env
is record
960 Instantiated_Parent
: Assoc
;
961 Exchanged_Views
: Elist_Id
;
962 Hidden_Entities
: Elist_Id
;
963 Current_Sem_Unit
: Unit_Number_Type
;
964 Parent_Unit_Visible
: Boolean := False;
965 Instance_Parent_Unit
: Entity_Id
:= Empty
;
966 Switches
: Config_Switches_Type
;
969 package Instance_Envs
is new Table
.Table
(
970 Table_Component_Type
=> Instance_Env
,
971 Table_Index_Type
=> Int
,
972 Table_Low_Bound
=> 0,
974 Table_Increment
=> 100,
975 Table_Name
=> "Instance_Envs");
977 procedure Restore_Private_Views
978 (Pack_Id
: Entity_Id
;
979 Is_Package
: Boolean := True);
980 -- Restore the private views of external types, and unmark the generic
981 -- renamings of actuals, so that they become compatible subtypes again.
982 -- For subprograms, Pack_Id is the package constructed to hold the
985 procedure Switch_View
(T
: Entity_Id
);
986 -- Switch the partial and full views of a type and its private
987 -- dependents (i.e. its subtypes and derived types).
989 ------------------------------------
990 -- Structures for Error Reporting --
991 ------------------------------------
993 Instantiation_Node
: Node_Id
;
994 -- Used by subprograms that validate instantiation of formal parameters
995 -- where there might be no actual on which to place the error message.
996 -- Also used to locate the instantiation node for generic subunits.
998 Instantiation_Error
: exception;
999 -- When there is a semantic error in the generic parameter matching,
1000 -- there is no point in continuing the instantiation, because the
1001 -- number of cascaded errors is unpredictable. This exception aborts
1002 -- the instantiation process altogether.
1004 S_Adjustment
: Sloc_Adjustment
;
1005 -- Offset created for each node in an instantiation, in order to keep
1006 -- track of the source position of the instantiation in each of its nodes.
1007 -- A subsequent semantic error or warning on a construct of the instance
1008 -- points to both places: the original generic node, and the point of
1009 -- instantiation. See Sinput and Sinput.L for additional details.
1011 ------------------------------------------------------------
1012 -- Data structure for keeping track when inside a Generic --
1013 ------------------------------------------------------------
1015 -- The following table is used to save values of the Inside_A_Generic
1016 -- flag (see spec of Sem) when they are saved by Start_Generic.
1018 package Generic_Flags
is new Table
.Table
(
1019 Table_Component_Type
=> Boolean,
1020 Table_Index_Type
=> Int
,
1021 Table_Low_Bound
=> 0,
1022 Table_Initial
=> 32,
1023 Table_Increment
=> 200,
1024 Table_Name
=> "Generic_Flags");
1026 ---------------------------
1027 -- Abandon_Instantiation --
1028 ---------------------------
1030 procedure Abandon_Instantiation
(N
: Node_Id
) is
1032 Error_Msg_N
("\instantiation abandoned!", N
);
1033 raise Instantiation_Error
;
1034 end Abandon_Instantiation
;
1036 --------------------------------
1037 -- Add_Pending_Instantiation --
1038 --------------------------------
1040 procedure Add_Pending_Instantiation
(Inst
: Node_Id
; Act_Decl
: Node_Id
) is
1043 -- Add to the instantiation node and the corresponding unit declaration
1044 -- the current values of global flags to be used when analyzing the
1047 Pending_Instantiations
.Append
1048 ((Inst_Node
=> Inst
,
1049 Act_Decl
=> Act_Decl
,
1050 Expander_Status
=> Expander_Active
,
1051 Current_Sem_Unit
=> Current_Sem_Unit
,
1052 Scope_Suppress
=> Scope_Suppress
,
1053 Local_Suppress_Stack_Top
=> Local_Suppress_Stack_Top
,
1054 Version
=> Ada_Version
,
1055 Version_Pragma
=> Ada_Version_Pragma
,
1056 Warnings
=> Save_Warnings
,
1057 SPARK_Mode
=> SPARK_Mode
,
1058 SPARK_Mode_Pragma
=> SPARK_Mode_Pragma
));
1059 end Add_Pending_Instantiation
;
1061 ----------------------------------
1062 -- Adjust_Inherited_Pragma_Sloc --
1063 ----------------------------------
1065 procedure Adjust_Inherited_Pragma_Sloc
(N
: Node_Id
) is
1067 Adjust_Instantiation_Sloc
(N
, S_Adjustment
);
1068 end Adjust_Inherited_Pragma_Sloc
;
1070 --------------------------
1071 -- Analyze_Associations --
1072 --------------------------
1074 function Analyze_Associations
1077 F_Copy
: List_Id
) return List_Id
1079 Actuals_To_Freeze
: constant Elist_Id
:= New_Elmt_List
;
1080 Assoc_List
: constant List_Id
:= New_List
;
1081 Default_Actuals
: constant List_Id
:= New_List
;
1082 Gen_Unit
: constant Entity_Id
:=
1083 Defining_Entity
(Parent
(F_Copy
));
1087 Analyzed_Formal
: Node_Id
;
1088 First_Named
: Node_Id
:= Empty
;
1092 Saved_Formal
: Node_Id
;
1094 Default_Formals
: constant List_Id
:= New_List
;
1095 -- If an Others_Choice is present, some of the formals may be defaulted.
1096 -- To simplify the treatment of visibility in an instance, we introduce
1097 -- individual defaults for each such formal. These defaults are
1098 -- appended to the list of associations and replace the Others_Choice.
1100 Found_Assoc
: Node_Id
;
1101 -- Association for the current formal being match. Empty if there are
1102 -- no remaining actuals, or if there is no named association with the
1103 -- name of the formal.
1105 Is_Named_Assoc
: Boolean;
1106 Num_Matched
: Nat
:= 0;
1107 Num_Actuals
: Nat
:= 0;
1109 Others_Present
: Boolean := False;
1110 Others_Choice
: Node_Id
:= Empty
;
1111 -- In Ada 2005, indicates partial parameterization of a formal
1112 -- package. As usual an other association must be last in the list.
1114 procedure Check_Fixed_Point_Actual
(Actual
: Node_Id
);
1115 -- Warn if an actual fixed-point type has user-defined arithmetic
1116 -- operations, but there is no corresponding formal in the generic,
1117 -- in which case the predefined operations will be used. This merits
1118 -- a warning because of the special semantics of fixed point ops.
1120 procedure Check_Overloaded_Formal_Subprogram
(Formal
: Entity_Id
);
1121 -- Apply RM 12.3(9): if a formal subprogram is overloaded, the instance
1122 -- cannot have a named association for it. AI05-0025 extends this rule
1123 -- to formals of formal packages by AI05-0025, and it also applies to
1124 -- box-initialized formals.
1126 function Has_Fully_Defined_Profile
(Subp
: Entity_Id
) return Boolean;
1127 -- Determine whether the parameter types and the return type of Subp
1128 -- are fully defined at the point of instantiation.
1130 function Matching_Actual
1132 A_F
: Entity_Id
) return Node_Id
;
1133 -- Find actual that corresponds to a given a formal parameter. If the
1134 -- actuals are positional, return the next one, if any. If the actuals
1135 -- are named, scan the parameter associations to find the right one.
1136 -- A_F is the corresponding entity in the analyzed generic, which is
1137 -- placed on the selector name for ASIS use.
1139 -- In Ada 2005, a named association may be given with a box, in which
1140 -- case Matching_Actual sets Found_Assoc to the generic association,
1141 -- but return Empty for the actual itself. In this case the code below
1142 -- creates a corresponding declaration for the formal.
1144 function Partial_Parameterization
return Boolean;
1145 -- Ada 2005: if no match is found for a given formal, check if the
1146 -- association for it includes a box, or whether the associations
1147 -- include an Others clause.
1149 procedure Process_Default
(F
: Entity_Id
);
1150 -- Add a copy of the declaration of generic formal F to the list of
1151 -- associations, and add an explicit box association for F if there
1152 -- is none yet, and the default comes from an Others_Choice.
1154 function Renames_Standard_Subprogram
(Subp
: Entity_Id
) return Boolean;
1155 -- Determine whether Subp renames one of the subprograms defined in the
1156 -- generated package Standard.
1158 procedure Set_Analyzed_Formal
;
1159 -- Find the node in the generic copy that corresponds to a given formal.
1160 -- The semantic information on this node is used to perform legality
1161 -- checks on the actuals. Because semantic analysis can introduce some
1162 -- anonymous entities or modify the declaration node itself, the
1163 -- correspondence between the two lists is not one-one. In addition to
1164 -- anonymous types, the presence a formal equality will introduce an
1165 -- implicit declaration for the corresponding inequality.
1167 ----------------------------------------
1168 -- Check_Overloaded_Formal_Subprogram --
1169 ----------------------------------------
1171 procedure Check_Overloaded_Formal_Subprogram
(Formal
: Entity_Id
) is
1172 Temp_Formal
: Entity_Id
;
1175 Temp_Formal
:= First
(Formals
);
1176 while Present
(Temp_Formal
) loop
1177 if Nkind
(Temp_Formal
) in N_Formal_Subprogram_Declaration
1178 and then Temp_Formal
/= Formal
1180 Chars
(Defining_Unit_Name
(Specification
(Formal
))) =
1181 Chars
(Defining_Unit_Name
(Specification
(Temp_Formal
)))
1183 if Present
(Found_Assoc
) then
1185 ("named association not allowed for overloaded formal",
1190 ("named association not allowed for overloaded formal",
1194 Abandon_Instantiation
(Instantiation_Node
);
1199 end Check_Overloaded_Formal_Subprogram
;
1201 -------------------------------
1202 -- Check_Fixed_Point_Actual --
1203 -------------------------------
1205 procedure Check_Fixed_Point_Actual
(Actual
: Node_Id
) is
1206 Typ
: constant Entity_Id
:= Entity
(Actual
);
1207 Prims
: constant Elist_Id
:= Collect_Primitive_Operations
(Typ
);
1213 -- Locate primitive operations of the type that are arithmetic
1216 Elem
:= First_Elmt
(Prims
);
1217 while Present
(Elem
) loop
1218 if Nkind
(Node
(Elem
)) = N_Defining_Operator_Symbol
then
1220 -- Check whether the generic unit has a formal subprogram of
1221 -- the same name. This does not check types but is good enough
1222 -- to justify a warning.
1224 Formal
:= First_Non_Pragma
(Formals
);
1225 Op
:= Alias
(Node
(Elem
));
1227 while Present
(Formal
) loop
1228 if Nkind
(Formal
) = N_Formal_Concrete_Subprogram_Declaration
1229 and then Chars
(Defining_Entity
(Formal
)) =
1234 elsif Nkind
(Formal
) = N_Formal_Package_Declaration
then
1240 -- Locate corresponding actual, and check whether it
1241 -- includes a fixed-point type.
1243 Assoc
:= First
(Assoc_List
);
1244 while Present
(Assoc
) loop
1246 Nkind
(Assoc
) = N_Package_Renaming_Declaration
1247 and then Chars
(Defining_Unit_Name
(Assoc
)) =
1248 Chars
(Defining_Identifier
(Formal
));
1253 if Present
(Assoc
) then
1255 -- If formal package declares a fixed-point type,
1256 -- and the user-defined operator is derived from
1257 -- a generic instance package, the fixed-point type
1258 -- does not use the corresponding predefined op.
1260 Ent
:= First_Entity
(Entity
(Name
(Assoc
)));
1261 while Present
(Ent
) loop
1262 if Is_Fixed_Point_Type
(Ent
)
1263 and then Present
(Op
)
1264 and then Is_Generic_Instance
(Scope
(Op
))
1279 Error_Msg_Sloc
:= Sloc
(Node
(Elem
));
1281 ("?instance uses predefined operation, not primitive "
1282 & "operation&#", Actual
, Node
(Elem
));
1288 end Check_Fixed_Point_Actual
;
1290 -------------------------------
1291 -- Has_Fully_Defined_Profile --
1292 -------------------------------
1294 function Has_Fully_Defined_Profile
(Subp
: Entity_Id
) return Boolean is
1295 function Is_Fully_Defined_Type
(Typ
: Entity_Id
) return Boolean;
1296 -- Determine whethet type Typ is fully defined
1298 ---------------------------
1299 -- Is_Fully_Defined_Type --
1300 ---------------------------
1302 function Is_Fully_Defined_Type
(Typ
: Entity_Id
) return Boolean is
1304 -- A private type without a full view is not fully defined
1306 if Is_Private_Type
(Typ
)
1307 and then No
(Full_View
(Typ
))
1311 -- An incomplete type is never fully defined
1313 elsif Is_Incomplete_Type
(Typ
) then
1316 -- All other types are fully defined
1321 end Is_Fully_Defined_Type
;
1323 -- Local declarations
1327 -- Start of processing for Has_Fully_Defined_Profile
1330 -- Check the parameters
1332 Param
:= First_Formal
(Subp
);
1333 while Present
(Param
) loop
1334 if not Is_Fully_Defined_Type
(Etype
(Param
)) then
1338 Next_Formal
(Param
);
1341 -- Check the return type
1343 return Is_Fully_Defined_Type
(Etype
(Subp
));
1344 end Has_Fully_Defined_Profile
;
1346 ---------------------
1347 -- Matching_Actual --
1348 ---------------------
1350 function Matching_Actual
1352 A_F
: Entity_Id
) return Node_Id
1358 Is_Named_Assoc
:= False;
1360 -- End of list of purely positional parameters
1362 if No
(Actual
) or else Nkind
(Actual
) = N_Others_Choice
then
1363 Found_Assoc
:= Empty
;
1366 -- Case of positional parameter corresponding to current formal
1368 elsif No
(Selector_Name
(Actual
)) then
1369 Found_Assoc
:= Actual
;
1370 Act
:= Explicit_Generic_Actual_Parameter
(Actual
);
1371 Num_Matched
:= Num_Matched
+ 1;
1374 -- Otherwise scan list of named actuals to find the one with the
1375 -- desired name. All remaining actuals have explicit names.
1378 Is_Named_Assoc
:= True;
1379 Found_Assoc
:= Empty
;
1383 while Present
(Actual
) loop
1384 if Nkind
(Actual
) = N_Others_Choice
then
1385 Found_Assoc
:= Empty
;
1388 elsif Chars
(Selector_Name
(Actual
)) = Chars
(F
) then
1389 Set_Entity
(Selector_Name
(Actual
), A_F
);
1390 Set_Etype
(Selector_Name
(Actual
), Etype
(A_F
));
1391 Generate_Reference
(A_F
, Selector_Name
(Actual
));
1393 Found_Assoc
:= Actual
;
1394 Act
:= Explicit_Generic_Actual_Parameter
(Actual
);
1395 Num_Matched
:= Num_Matched
+ 1;
1403 -- Reset for subsequent searches. In most cases the named
1404 -- associations are in order. If they are not, we reorder them
1405 -- to avoid scanning twice the same actual. This is not just a
1406 -- question of efficiency: there may be multiple defaults with
1407 -- boxes that have the same name. In a nested instantiation we
1408 -- insert actuals for those defaults, and cannot rely on their
1409 -- names to disambiguate them.
1411 if Actual
= First_Named
then
1414 elsif Present
(Actual
) then
1415 Insert_Before
(First_Named
, Remove_Next
(Prev
));
1418 Actual
:= First_Named
;
1421 if Is_Entity_Name
(Act
) and then Present
(Entity
(Act
)) then
1422 Set_Used_As_Generic_Actual
(Entity
(Act
));
1426 end Matching_Actual
;
1428 ------------------------------
1429 -- Partial_Parameterization --
1430 ------------------------------
1432 function Partial_Parameterization
return Boolean is
1434 return Others_Present
1435 or else (Present
(Found_Assoc
) and then Box_Present
(Found_Assoc
));
1436 end Partial_Parameterization
;
1438 ---------------------
1439 -- Process_Default --
1440 ---------------------
1442 procedure Process_Default
(F
: Entity_Id
) is
1443 Loc
: constant Source_Ptr
:= Sloc
(I_Node
);
1444 F_Id
: constant Entity_Id
:= Defining_Entity
(F
);
1450 -- Append copy of formal declaration to associations, and create new
1451 -- defining identifier for it.
1453 Decl
:= New_Copy_Tree
(F
);
1454 Id
:= Make_Defining_Identifier
(Sloc
(F_Id
), Chars
(F_Id
));
1456 if Nkind
(F
) in N_Formal_Subprogram_Declaration
then
1457 Set_Defining_Unit_Name
(Specification
(Decl
), Id
);
1460 Set_Defining_Identifier
(Decl
, Id
);
1463 Append
(Decl
, Assoc_List
);
1465 if No
(Found_Assoc
) then
1467 Make_Generic_Association
(Loc
,
1469 New_Occurrence_Of
(Id
, Loc
),
1470 Explicit_Generic_Actual_Parameter
=> Empty
);
1471 Set_Box_Present
(Default
);
1472 Append
(Default
, Default_Formals
);
1474 end Process_Default
;
1476 ---------------------------------
1477 -- Renames_Standard_Subprogram --
1478 ---------------------------------
1480 function Renames_Standard_Subprogram
(Subp
: Entity_Id
) return Boolean is
1485 while Present
(Id
) loop
1486 if Scope
(Id
) = Standard_Standard
then
1494 end Renames_Standard_Subprogram
;
1496 -------------------------
1497 -- Set_Analyzed_Formal --
1498 -------------------------
1500 procedure Set_Analyzed_Formal
is
1504 while Present
(Analyzed_Formal
) loop
1505 Kind
:= Nkind
(Analyzed_Formal
);
1507 case Nkind
(Formal
) is
1508 when N_Formal_Subprogram_Declaration
=>
1509 exit when Kind
in N_Formal_Subprogram_Declaration
1512 (Defining_Unit_Name
(Specification
(Formal
))) =
1514 (Defining_Unit_Name
(Specification
(Analyzed_Formal
)));
1516 when N_Formal_Package_Declaration
=>
1517 exit when Nkind_In
(Kind
, N_Formal_Package_Declaration
,
1518 N_Generic_Package_Declaration
,
1519 N_Package_Declaration
);
1521 when N_Use_Package_Clause
1528 -- Skip freeze nodes, and nodes inserted to replace
1529 -- unrecognized pragmas.
1532 Kind
not in N_Formal_Subprogram_Declaration
1533 and then not Nkind_In
(Kind
, N_Subprogram_Declaration
,
1537 and then Chars
(Defining_Identifier
(Formal
)) =
1538 Chars
(Defining_Identifier
(Analyzed_Formal
));
1541 Next
(Analyzed_Formal
);
1543 end Set_Analyzed_Formal
;
1545 -- Start of processing for Analyze_Associations
1548 Actuals
:= Generic_Associations
(I_Node
);
1550 if Present
(Actuals
) then
1552 -- Check for an Others choice, indicating a partial parameterization
1553 -- for a formal package.
1555 Actual
:= First
(Actuals
);
1556 while Present
(Actual
) loop
1557 if Nkind
(Actual
) = N_Others_Choice
then
1558 Others_Present
:= True;
1559 Others_Choice
:= Actual
;
1561 if Present
(Next
(Actual
)) then
1562 Error_Msg_N
("others must be last association", Actual
);
1565 -- This subprogram is used both for formal packages and for
1566 -- instantiations. For the latter, associations must all be
1569 if Nkind
(I_Node
) /= N_Formal_Package_Declaration
1570 and then Comes_From_Source
(I_Node
)
1573 ("others association not allowed in an instance",
1577 -- In any case, nothing to do after the others association
1581 elsif Box_Present
(Actual
)
1582 and then Comes_From_Source
(I_Node
)
1583 and then Nkind
(I_Node
) /= N_Formal_Package_Declaration
1586 ("box association not allowed in an instance", Actual
);
1592 -- If named associations are present, save first named association
1593 -- (it may of course be Empty) to facilitate subsequent name search.
1595 First_Named
:= First
(Actuals
);
1596 while Present
(First_Named
)
1597 and then Nkind
(First_Named
) /= N_Others_Choice
1598 and then No
(Selector_Name
(First_Named
))
1600 Num_Actuals
:= Num_Actuals
+ 1;
1605 Named
:= First_Named
;
1606 while Present
(Named
) loop
1607 if Nkind
(Named
) /= N_Others_Choice
1608 and then No
(Selector_Name
(Named
))
1610 Error_Msg_N
("invalid positional actual after named one", Named
);
1611 Abandon_Instantiation
(Named
);
1614 -- A named association may lack an actual parameter, if it was
1615 -- introduced for a default subprogram that turns out to be local
1616 -- to the outer instantiation. If it has a box association it must
1617 -- correspond to some formal in the generic.
1619 if Nkind
(Named
) /= N_Others_Choice
1620 and then (Present
(Explicit_Generic_Actual_Parameter
(Named
))
1621 or else Box_Present
(Named
))
1623 Num_Actuals
:= Num_Actuals
+ 1;
1629 if Present
(Formals
) then
1630 Formal
:= First_Non_Pragma
(Formals
);
1631 Analyzed_Formal
:= First_Non_Pragma
(F_Copy
);
1633 if Present
(Actuals
) then
1634 Actual
:= First
(Actuals
);
1636 -- All formals should have default values
1642 while Present
(Formal
) loop
1643 Set_Analyzed_Formal
;
1644 Saved_Formal
:= Next_Non_Pragma
(Formal
);
1646 case Nkind
(Formal
) is
1647 when N_Formal_Object_Declaration
=>
1650 (Defining_Identifier
(Formal
),
1651 Defining_Identifier
(Analyzed_Formal
));
1653 if No
(Match
) and then Partial_Parameterization
then
1654 Process_Default
(Formal
);
1658 (Instantiate_Object
(Formal
, Match
, Analyzed_Formal
),
1661 -- For a defaulted in_parameter, create an entry in the
1662 -- the list of defaulted actuals, for GNATProve use. Do
1663 -- not included these defaults for an instance nested
1664 -- within a generic, because the defaults are also used
1665 -- in the analysis of the enclosing generic, and only
1666 -- defaulted subprograms are relevant there.
1668 if No
(Match
) and then not Inside_A_Generic
then
1669 Append_To
(Default_Actuals
,
1670 Make_Generic_Association
(Sloc
(I_Node
),
1673 (Defining_Identifier
(Formal
), Sloc
(I_Node
)),
1674 Explicit_Generic_Actual_Parameter
=>
1675 New_Copy_Tree
(Default_Expression
(Formal
))));
1679 -- If the object is a call to an expression function, this
1680 -- is a freezing point for it.
1682 if Is_Entity_Name
(Match
)
1683 and then Present
(Entity
(Match
))
1685 (Original_Node
(Unit_Declaration_Node
(Entity
(Match
))))
1686 = N_Expression_Function
1688 Append_Elmt
(Entity
(Match
), Actuals_To_Freeze
);
1691 when N_Formal_Type_Declaration
=>
1694 (Defining_Identifier
(Formal
),
1695 Defining_Identifier
(Analyzed_Formal
));
1698 if Partial_Parameterization
then
1699 Process_Default
(Formal
);
1702 Error_Msg_Sloc
:= Sloc
(Gen_Unit
);
1705 Instantiation_Node
, Defining_Identifier
(Formal
));
1707 ("\in instantiation of & declared#",
1708 Instantiation_Node
, Gen_Unit
);
1709 Abandon_Instantiation
(Instantiation_Node
);
1716 (Formal
, Match
, Analyzed_Formal
, Assoc_List
),
1719 -- Warn when an actual is a fixed-point with user-
1720 -- defined promitives. The warning is superfluous
1721 -- if the fornal is private, because there can be
1722 -- no arithmetic operations in the generic so there
1723 -- no danger of confusion.
1725 if Is_Fixed_Point_Type
(Entity
(Match
))
1726 and then not Is_Private_Type
1727 (Defining_Identifier
(Analyzed_Formal
))
1729 Check_Fixed_Point_Actual
(Match
);
1732 -- An instantiation is a freeze point for the actuals,
1733 -- unless this is a rewritten formal package, or the
1734 -- formal is an Ada 2012 formal incomplete type.
1736 if Nkind
(I_Node
) = N_Formal_Package_Declaration
1738 (Ada_Version
>= Ada_2012
1740 Ekind
(Defining_Identifier
(Analyzed_Formal
)) =
1746 Append_Elmt
(Entity
(Match
), Actuals_To_Freeze
);
1750 -- A remote access-to-class-wide type is not a legal actual
1751 -- for a generic formal of an access type (E.2.2(17/2)).
1752 -- In GNAT an exception to this rule is introduced when
1753 -- the formal is marked as remote using implementation
1754 -- defined aspect/pragma Remote_Access_Type. In that case
1755 -- the actual must be remote as well.
1757 -- If the current instantiation is the construction of a
1758 -- local copy for a formal package the actuals may be
1759 -- defaulted, and there is no matching actual to check.
1761 if Nkind
(Analyzed_Formal
) = N_Formal_Type_Declaration
1763 Nkind
(Formal_Type_Definition
(Analyzed_Formal
)) =
1764 N_Access_To_Object_Definition
1765 and then Present
(Match
)
1768 Formal_Ent
: constant Entity_Id
:=
1769 Defining_Identifier
(Analyzed_Formal
);
1771 if Is_Remote_Access_To_Class_Wide_Type
(Entity
(Match
))
1772 = Is_Remote_Types
(Formal_Ent
)
1774 -- Remoteness of formal and actual match
1778 elsif Is_Remote_Types
(Formal_Ent
) then
1780 -- Remote formal, non-remote actual
1783 ("actual for& must be remote", Match
, Formal_Ent
);
1786 -- Non-remote formal, remote actual
1789 ("actual for& may not be remote",
1795 when N_Formal_Subprogram_Declaration
=>
1798 (Defining_Unit_Name
(Specification
(Formal
)),
1799 Defining_Unit_Name
(Specification
(Analyzed_Formal
)));
1801 -- If the formal subprogram has the same name as another
1802 -- formal subprogram of the generic, then a named
1803 -- association is illegal (12.3(9)). Exclude named
1804 -- associations that are generated for a nested instance.
1807 and then Is_Named_Assoc
1808 and then Comes_From_Source
(Found_Assoc
)
1810 Check_Overloaded_Formal_Subprogram
(Formal
);
1813 -- If there is no corresponding actual, this may be case
1814 -- of partial parameterization, or else the formal has a
1815 -- default or a box.
1817 if No
(Match
) and then Partial_Parameterization
then
1818 Process_Default
(Formal
);
1820 if Nkind
(I_Node
) = N_Formal_Package_Declaration
then
1821 Check_Overloaded_Formal_Subprogram
(Formal
);
1825 Append_To
(Assoc_List
,
1826 Instantiate_Formal_Subprogram
1827 (Formal
, Match
, Analyzed_Formal
));
1829 -- An instantiation is a freeze point for the actuals,
1830 -- unless this is a rewritten formal package.
1832 if Nkind
(I_Node
) /= N_Formal_Package_Declaration
1833 and then Nkind
(Match
) = N_Identifier
1834 and then Is_Subprogram
(Entity
(Match
))
1836 -- The actual subprogram may rename a routine defined
1837 -- in Standard. Avoid freezing such renamings because
1838 -- subprograms coming from Standard cannot be frozen.
1841 not Renames_Standard_Subprogram
(Entity
(Match
))
1843 -- If the actual subprogram comes from a different
1844 -- unit, it is already frozen, either by a body in
1845 -- that unit or by the end of the declarative part
1846 -- of the unit. This check avoids the freezing of
1847 -- subprograms defined in Standard which are used
1848 -- as generic actuals.
1850 and then In_Same_Code_Unit
(Entity
(Match
), I_Node
)
1851 and then Has_Fully_Defined_Profile
(Entity
(Match
))
1853 -- Mark the subprogram as having a delayed freeze
1854 -- since this may be an out-of-order action.
1856 Set_Has_Delayed_Freeze
(Entity
(Match
));
1857 Append_Elmt
(Entity
(Match
), Actuals_To_Freeze
);
1861 -- If this is a nested generic, preserve default for later
1862 -- instantiations. We do this as well for GNATProve use,
1863 -- so that the list of generic associations is complete.
1865 if No
(Match
) and then Box_Present
(Formal
) then
1867 Subp
: constant Entity_Id
:=
1869 (Specification
(Last
(Assoc_List
)));
1872 Append_To
(Default_Actuals
,
1873 Make_Generic_Association
(Sloc
(I_Node
),
1875 New_Occurrence_Of
(Subp
, Sloc
(I_Node
)),
1876 Explicit_Generic_Actual_Parameter
=>
1877 New_Occurrence_Of
(Subp
, Sloc
(I_Node
))));
1881 when N_Formal_Package_Declaration
=>
1884 (Defining_Identifier
(Formal
),
1885 Defining_Identifier
(Original_Node
(Analyzed_Formal
)));
1888 if Partial_Parameterization
then
1889 Process_Default
(Formal
);
1892 Error_Msg_Sloc
:= Sloc
(Gen_Unit
);
1895 Instantiation_Node
, Defining_Identifier
(Formal
));
1897 ("\in instantiation of & declared#",
1898 Instantiation_Node
, Gen_Unit
);
1900 Abandon_Instantiation
(Instantiation_Node
);
1906 (Instantiate_Formal_Package
1907 (Formal
, Match
, Analyzed_Formal
),
1910 -- Determine whether the actual package needs an explicit
1911 -- freeze node. This is only the case if the actual is
1912 -- declared in the same unit and has a body. Normally
1913 -- packages do not have explicit freeze nodes, and gigi
1914 -- only uses them to elaborate entities in a package
1917 Explicit_Freeze_Check
: declare
1918 Actual
: constant Entity_Id
:= Entity
(Match
);
1919 Gen_Par
: Entity_Id
;
1921 Needs_Freezing
: Boolean;
1924 procedure Check_Generic_Parent
;
1925 -- The actual may be an instantiation of a unit
1926 -- declared in a previous instantiation. If that
1927 -- one is also in the current compilation, it must
1928 -- itself be frozen before the actual. The actual
1929 -- may be an instantiation of a generic child unit,
1930 -- in which case the same applies to the instance
1931 -- of the parent which must be frozen before the
1933 -- Should this itself be recursive ???
1935 --------------------------
1936 -- Check_Generic_Parent --
1937 --------------------------
1939 procedure Check_Generic_Parent
is
1940 Inst
: constant Node_Id
:=
1941 Next
(Unit_Declaration_Node
(Actual
));
1947 if Nkind
(Parent
(Actual
)) = N_Package_Specification
1949 Par
:= Scope
(Generic_Parent
(Parent
(Actual
)));
1951 if Is_Generic_Instance
(Par
) then
1954 -- If the actual is a child generic unit, check
1955 -- whether the instantiation of the parent is
1956 -- also local and must also be frozen now. We
1957 -- must retrieve the instance node to locate the
1958 -- parent instance if any.
1960 elsif Ekind
(Par
) = E_Generic_Package
1961 and then Is_Child_Unit
(Gen_Par
)
1962 and then Ekind
(Scope
(Gen_Par
)) =
1965 if Nkind
(Inst
) = N_Package_Instantiation
1966 and then Nkind
(Name
(Inst
)) =
1969 -- Retrieve entity of parent instance
1971 Par
:= Entity
(Prefix
(Name
(Inst
)));
1980 and then Is_Generic_Instance
(Par
)
1981 and then Scope
(Par
) = Current_Scope
1983 (No
(Freeze_Node
(Par
))
1985 not Is_List_Member
(Freeze_Node
(Par
)))
1987 Set_Has_Delayed_Freeze
(Par
);
1988 Append_Elmt
(Par
, Actuals_To_Freeze
);
1990 end Check_Generic_Parent
;
1992 -- Start of processing for Explicit_Freeze_Check
1995 if Present
(Renamed_Entity
(Actual
)) then
1997 Generic_Parent
(Specification
1998 (Unit_Declaration_Node
1999 (Renamed_Entity
(Actual
))));
2002 Generic_Parent
(Specification
2003 (Unit_Declaration_Node
(Actual
)));
2006 if not Expander_Active
2007 or else not Has_Completion
(Actual
)
2008 or else not In_Same_Source_Unit
(I_Node
, Actual
)
2009 or else Is_Frozen
(Actual
)
2011 (Present
(Renamed_Entity
(Actual
))
2013 not In_Same_Source_Unit
2014 (I_Node
, (Renamed_Entity
(Actual
))))
2019 -- Finally we want to exclude such freeze nodes
2020 -- from statement sequences, which freeze
2021 -- everything before them.
2022 -- Is this strictly necessary ???
2024 Needs_Freezing
:= True;
2027 while Present
(S
) loop
2028 if Ekind_In
(S
, E_Block
,
2033 Needs_Freezing
:= False;
2040 if Needs_Freezing
then
2041 Check_Generic_Parent
;
2043 -- If the actual is a renaming of a proper
2044 -- instance of the formal package, indicate
2045 -- that it is the instance that must be frozen.
2047 if Nkind
(Parent
(Actual
)) =
2048 N_Package_Renaming_Declaration
2050 Set_Has_Delayed_Freeze
2051 (Renamed_Entity
(Actual
));
2053 (Renamed_Entity
(Actual
),
2056 Set_Has_Delayed_Freeze
(Actual
);
2057 Append_Elmt
(Actual
, Actuals_To_Freeze
);
2061 end Explicit_Freeze_Check
;
2064 -- For use type and use package appearing in the generic part,
2065 -- we have already copied them, so we can just move them where
2066 -- they belong (we mustn't recopy them since this would mess up
2067 -- the Sloc values).
2069 when N_Use_Package_Clause
2072 if Nkind
(Original_Node
(I_Node
)) =
2073 N_Formal_Package_Declaration
2075 Append
(New_Copy_Tree
(Formal
), Assoc_List
);
2078 Append
(Formal
, Assoc_List
);
2082 raise Program_Error
;
2085 Formal
:= Saved_Formal
;
2086 Next_Non_Pragma
(Analyzed_Formal
);
2089 if Num_Actuals
> Num_Matched
then
2090 Error_Msg_Sloc
:= Sloc
(Gen_Unit
);
2092 if Present
(Selector_Name
(Actual
)) then
2094 ("unmatched actual &", Actual
, Selector_Name
(Actual
));
2096 ("\in instantiation of & declared#", Actual
, Gen_Unit
);
2099 ("unmatched actual in instantiation of & declared#",
2104 elsif Present
(Actuals
) then
2106 ("too many actuals in generic instantiation", Instantiation_Node
);
2109 -- An instantiation freezes all generic actuals. The only exceptions
2110 -- to this are incomplete types and subprograms which are not fully
2111 -- defined at the point of instantiation.
2114 Elmt
: Elmt_Id
:= First_Elmt
(Actuals_To_Freeze
);
2116 while Present
(Elmt
) loop
2117 Freeze_Before
(I_Node
, Node
(Elmt
));
2122 -- If there are default subprograms, normalize the tree by adding
2123 -- explicit associations for them. This is required if the instance
2124 -- appears within a generic.
2126 if not Is_Empty_List
(Default_Actuals
) then
2131 Default
:= First
(Default_Actuals
);
2132 while Present
(Default
) loop
2133 Mark_Rewrite_Insertion
(Default
);
2137 if No
(Actuals
) then
2138 Set_Generic_Associations
(I_Node
, Default_Actuals
);
2140 Append_List_To
(Actuals
, Default_Actuals
);
2145 -- If this is a formal package, normalize the parameter list by adding
2146 -- explicit box associations for the formals that are covered by an
2149 if not Is_Empty_List
(Default_Formals
) then
2150 Append_List
(Default_Formals
, Formals
);
2154 end Analyze_Associations
;
2156 -------------------------------
2157 -- Analyze_Formal_Array_Type --
2158 -------------------------------
2160 procedure Analyze_Formal_Array_Type
2161 (T
: in out Entity_Id
;
2167 -- Treated like a non-generic array declaration, with additional
2172 if Nkind
(Def
) = N_Constrained_Array_Definition
then
2173 DSS
:= First
(Discrete_Subtype_Definitions
(Def
));
2174 while Present
(DSS
) loop
2175 if Nkind_In
(DSS
, N_Subtype_Indication
,
2177 N_Attribute_Reference
)
2179 Error_Msg_N
("only a subtype mark is allowed in a formal", DSS
);
2186 Array_Type_Declaration
(T
, Def
);
2187 Set_Is_Generic_Type
(Base_Type
(T
));
2189 if Ekind
(Component_Type
(T
)) = E_Incomplete_Type
2190 and then No
(Full_View
(Component_Type
(T
)))
2192 Error_Msg_N
("premature usage of incomplete type", Def
);
2194 -- Check that range constraint is not allowed on the component type
2195 -- of a generic formal array type (AARM 12.5.3(3))
2197 elsif Is_Internal
(Component_Type
(T
))
2198 and then Present
(Subtype_Indication
(Component_Definition
(Def
)))
2199 and then Nkind
(Original_Node
2200 (Subtype_Indication
(Component_Definition
(Def
)))) =
2201 N_Subtype_Indication
2204 ("in a formal, a subtype indication can only be "
2205 & "a subtype mark (RM 12.5.3(3))",
2206 Subtype_Indication
(Component_Definition
(Def
)));
2209 end Analyze_Formal_Array_Type
;
2211 ---------------------------------------------
2212 -- Analyze_Formal_Decimal_Fixed_Point_Type --
2213 ---------------------------------------------
2215 -- As for other generic types, we create a valid type representation with
2216 -- legal but arbitrary attributes, whose values are never considered
2217 -- static. For all scalar types we introduce an anonymous base type, with
2218 -- the same attributes. We choose the corresponding integer type to be
2219 -- Standard_Integer.
2220 -- Here and in other similar routines, the Sloc of the generated internal
2221 -- type must be the same as the sloc of the defining identifier of the
2222 -- formal type declaration, to provide proper source navigation.
2224 procedure Analyze_Formal_Decimal_Fixed_Point_Type
2228 Loc
: constant Source_Ptr
:= Sloc
(Def
);
2230 Base
: constant Entity_Id
:=
2232 (E_Decimal_Fixed_Point_Type
,
2234 Sloc
(Defining_Identifier
(Parent
(Def
))), 'G');
2236 Int_Base
: constant Entity_Id
:= Standard_Integer
;
2237 Delta_Val
: constant Ureal
:= Ureal_1
;
2238 Digs_Val
: constant Uint
:= Uint_6
;
2240 function Make_Dummy_Bound
return Node_Id
;
2241 -- Return a properly typed universal real literal to use as a bound
2243 ----------------------
2244 -- Make_Dummy_Bound --
2245 ----------------------
2247 function Make_Dummy_Bound
return Node_Id
is
2248 Bound
: constant Node_Id
:= Make_Real_Literal
(Loc
, Ureal_1
);
2250 Set_Etype
(Bound
, Universal_Real
);
2252 end Make_Dummy_Bound
;
2254 -- Start of processing for Analyze_Formal_Decimal_Fixed_Point_Type
2259 Set_Etype
(Base
, Base
);
2260 Set_Size_Info
(Base
, Int_Base
);
2261 Set_RM_Size
(Base
, RM_Size
(Int_Base
));
2262 Set_First_Rep_Item
(Base
, First_Rep_Item
(Int_Base
));
2263 Set_Digits_Value
(Base
, Digs_Val
);
2264 Set_Delta_Value
(Base
, Delta_Val
);
2265 Set_Small_Value
(Base
, Delta_Val
);
2266 Set_Scalar_Range
(Base
,
2268 Low_Bound
=> Make_Dummy_Bound
,
2269 High_Bound
=> Make_Dummy_Bound
));
2271 Set_Is_Generic_Type
(Base
);
2272 Set_Parent
(Base
, Parent
(Def
));
2274 Set_Ekind
(T
, E_Decimal_Fixed_Point_Subtype
);
2275 Set_Etype
(T
, Base
);
2276 Set_Size_Info
(T
, Int_Base
);
2277 Set_RM_Size
(T
, RM_Size
(Int_Base
));
2278 Set_First_Rep_Item
(T
, First_Rep_Item
(Int_Base
));
2279 Set_Digits_Value
(T
, Digs_Val
);
2280 Set_Delta_Value
(T
, Delta_Val
);
2281 Set_Small_Value
(T
, Delta_Val
);
2282 Set_Scalar_Range
(T
, Scalar_Range
(Base
));
2283 Set_Is_Constrained
(T
);
2285 Check_Restriction
(No_Fixed_Point
, Def
);
2286 end Analyze_Formal_Decimal_Fixed_Point_Type
;
2288 -------------------------------------------
2289 -- Analyze_Formal_Derived_Interface_Type --
2290 -------------------------------------------
2292 procedure Analyze_Formal_Derived_Interface_Type
2297 Loc
: constant Source_Ptr
:= Sloc
(Def
);
2300 -- Rewrite as a type declaration of a derived type. This ensures that
2301 -- the interface list and primitive operations are properly captured.
2304 Make_Full_Type_Declaration
(Loc
,
2305 Defining_Identifier
=> T
,
2306 Type_Definition
=> Def
));
2308 Set_Is_Generic_Type
(T
);
2309 end Analyze_Formal_Derived_Interface_Type
;
2311 ---------------------------------
2312 -- Analyze_Formal_Derived_Type --
2313 ---------------------------------
2315 procedure Analyze_Formal_Derived_Type
2320 Loc
: constant Source_Ptr
:= Sloc
(Def
);
2321 Unk_Disc
: constant Boolean := Unknown_Discriminants_Present
(N
);
2325 Set_Is_Generic_Type
(T
);
2327 if Private_Present
(Def
) then
2329 Make_Private_Extension_Declaration
(Loc
,
2330 Defining_Identifier
=> T
,
2331 Discriminant_Specifications
=> Discriminant_Specifications
(N
),
2332 Unknown_Discriminants_Present
=> Unk_Disc
,
2333 Subtype_Indication
=> Subtype_Mark
(Def
),
2334 Interface_List
=> Interface_List
(Def
));
2336 Set_Abstract_Present
(New_N
, Abstract_Present
(Def
));
2337 Set_Limited_Present
(New_N
, Limited_Present
(Def
));
2338 Set_Synchronized_Present
(New_N
, Synchronized_Present
(Def
));
2342 Make_Full_Type_Declaration
(Loc
,
2343 Defining_Identifier
=> T
,
2344 Discriminant_Specifications
=>
2345 Discriminant_Specifications
(Parent
(T
)),
2347 Make_Derived_Type_Definition
(Loc
,
2348 Subtype_Indication
=> Subtype_Mark
(Def
)));
2350 Set_Abstract_Present
2351 (Type_Definition
(New_N
), Abstract_Present
(Def
));
2353 (Type_Definition
(New_N
), Limited_Present
(Def
));
2360 if not Is_Composite_Type
(T
) then
2362 ("unknown discriminants not allowed for elementary types", N
);
2364 Set_Has_Unknown_Discriminants
(T
);
2365 Set_Is_Constrained
(T
, False);
2369 -- If the parent type has a known size, so does the formal, which makes
2370 -- legal representation clauses that involve the formal.
2372 Set_Size_Known_At_Compile_Time
2373 (T
, Size_Known_At_Compile_Time
(Entity
(Subtype_Mark
(Def
))));
2374 end Analyze_Formal_Derived_Type
;
2376 ----------------------------------
2377 -- Analyze_Formal_Discrete_Type --
2378 ----------------------------------
2380 -- The operations defined for a discrete types are those of an enumeration
2381 -- type. The size is set to an arbitrary value, for use in analyzing the
2384 procedure Analyze_Formal_Discrete_Type
(T
: Entity_Id
; Def
: Node_Id
) is
2385 Loc
: constant Source_Ptr
:= Sloc
(Def
);
2389 Base
: constant Entity_Id
:=
2391 (E_Floating_Point_Type
, Current_Scope
,
2392 Sloc
(Defining_Identifier
(Parent
(Def
))), 'G');
2396 Set_Ekind
(T
, E_Enumeration_Subtype
);
2397 Set_Etype
(T
, Base
);
2400 Set_Is_Generic_Type
(T
);
2401 Set_Is_Constrained
(T
);
2403 -- For semantic analysis, the bounds of the type must be set to some
2404 -- non-static value. The simplest is to create attribute nodes for those
2405 -- bounds, that refer to the type itself. These bounds are never
2406 -- analyzed but serve as place-holders.
2409 Make_Attribute_Reference
(Loc
,
2410 Attribute_Name
=> Name_First
,
2411 Prefix
=> New_Occurrence_Of
(T
, Loc
));
2415 Make_Attribute_Reference
(Loc
,
2416 Attribute_Name
=> Name_Last
,
2417 Prefix
=> New_Occurrence_Of
(T
, Loc
));
2420 Set_Scalar_Range
(T
,
2425 Set_Ekind
(Base
, E_Enumeration_Type
);
2426 Set_Etype
(Base
, Base
);
2427 Init_Size
(Base
, 8);
2428 Init_Alignment
(Base
);
2429 Set_Is_Generic_Type
(Base
);
2430 Set_Scalar_Range
(Base
, Scalar_Range
(T
));
2431 Set_Parent
(Base
, Parent
(Def
));
2432 end Analyze_Formal_Discrete_Type
;
2434 ----------------------------------
2435 -- Analyze_Formal_Floating_Type --
2436 ---------------------------------
2438 procedure Analyze_Formal_Floating_Type
(T
: Entity_Id
; Def
: Node_Id
) is
2439 Base
: constant Entity_Id
:=
2441 (E_Floating_Point_Type
, Current_Scope
,
2442 Sloc
(Defining_Identifier
(Parent
(Def
))), 'G');
2445 -- The various semantic attributes are taken from the predefined type
2446 -- Float, just so that all of them are initialized. Their values are
2447 -- never used because no constant folding or expansion takes place in
2448 -- the generic itself.
2451 Set_Ekind
(T
, E_Floating_Point_Subtype
);
2452 Set_Etype
(T
, Base
);
2453 Set_Size_Info
(T
, (Standard_Float
));
2454 Set_RM_Size
(T
, RM_Size
(Standard_Float
));
2455 Set_Digits_Value
(T
, Digits_Value
(Standard_Float
));
2456 Set_Scalar_Range
(T
, Scalar_Range
(Standard_Float
));
2457 Set_Is_Constrained
(T
);
2459 Set_Is_Generic_Type
(Base
);
2460 Set_Etype
(Base
, Base
);
2461 Set_Size_Info
(Base
, (Standard_Float
));
2462 Set_RM_Size
(Base
, RM_Size
(Standard_Float
));
2463 Set_Digits_Value
(Base
, Digits_Value
(Standard_Float
));
2464 Set_Scalar_Range
(Base
, Scalar_Range
(Standard_Float
));
2465 Set_Parent
(Base
, Parent
(Def
));
2467 Check_Restriction
(No_Floating_Point
, Def
);
2468 end Analyze_Formal_Floating_Type
;
2470 -----------------------------------
2471 -- Analyze_Formal_Interface_Type;--
2472 -----------------------------------
2474 procedure Analyze_Formal_Interface_Type
2479 Loc
: constant Source_Ptr
:= Sloc
(N
);
2484 Make_Full_Type_Declaration
(Loc
,
2485 Defining_Identifier
=> T
,
2486 Type_Definition
=> Def
);
2490 Set_Is_Generic_Type
(T
);
2491 end Analyze_Formal_Interface_Type
;
2493 ---------------------------------
2494 -- Analyze_Formal_Modular_Type --
2495 ---------------------------------
2497 procedure Analyze_Formal_Modular_Type
(T
: Entity_Id
; Def
: Node_Id
) is
2499 -- Apart from their entity kind, generic modular types are treated like
2500 -- signed integer types, and have the same attributes.
2502 Analyze_Formal_Signed_Integer_Type
(T
, Def
);
2503 Set_Ekind
(T
, E_Modular_Integer_Subtype
);
2504 Set_Ekind
(Etype
(T
), E_Modular_Integer_Type
);
2506 end Analyze_Formal_Modular_Type
;
2508 ---------------------------------------
2509 -- Analyze_Formal_Object_Declaration --
2510 ---------------------------------------
2512 procedure Analyze_Formal_Object_Declaration
(N
: Node_Id
) is
2513 E
: constant Node_Id
:= Default_Expression
(N
);
2514 Id
: constant Node_Id
:= Defining_Identifier
(N
);
2521 -- Determine the mode of the formal object
2523 if Out_Present
(N
) then
2524 K
:= E_Generic_In_Out_Parameter
;
2526 if not In_Present
(N
) then
2527 Error_Msg_N
("formal generic objects cannot have mode OUT", N
);
2531 K
:= E_Generic_In_Parameter
;
2534 if Present
(Subtype_Mark
(N
)) then
2535 Find_Type
(Subtype_Mark
(N
));
2536 T
:= Entity
(Subtype_Mark
(N
));
2538 -- Verify that there is no redundant null exclusion
2540 if Null_Exclusion_Present
(N
) then
2541 if not Is_Access_Type
(T
) then
2543 ("null exclusion can only apply to an access type", N
);
2545 elsif Can_Never_Be_Null
(T
) then
2547 ("`NOT NULL` not allowed (& already excludes null)", N
, T
);
2551 -- Ada 2005 (AI-423): Formal object with an access definition
2554 Check_Access_Definition
(N
);
2555 T
:= Access_Definition
2557 N
=> Access_Definition
(N
));
2560 if Ekind
(T
) = E_Incomplete_Type
then
2562 Error_Node
: Node_Id
;
2565 if Present
(Subtype_Mark
(N
)) then
2566 Error_Node
:= Subtype_Mark
(N
);
2568 Check_Access_Definition
(N
);
2569 Error_Node
:= Access_Definition
(N
);
2572 Error_Msg_N
("premature usage of incomplete type", Error_Node
);
2576 if K
= E_Generic_In_Parameter
then
2578 -- Ada 2005 (AI-287): Limited aggregates allowed in generic formals
2580 if Ada_Version
< Ada_2005
and then Is_Limited_Type
(T
) then
2582 ("generic formal of mode IN must not be of limited type", N
);
2583 Explain_Limited_Type
(T
, N
);
2586 if Is_Abstract_Type
(T
) then
2588 ("generic formal of mode IN must not be of abstract type", N
);
2592 Preanalyze_Spec_Expression
(E
, T
);
2594 if Is_Limited_Type
(T
) and then not OK_For_Limited_Init
(T
, E
) then
2596 ("initialization not allowed for limited types", E
);
2597 Explain_Limited_Type
(T
, E
);
2604 -- Case of generic IN OUT parameter
2607 -- If the formal has an unconstrained type, construct its actual
2608 -- subtype, as is done for subprogram formals. In this fashion, all
2609 -- its uses can refer to specific bounds.
2614 if (Is_Array_Type
(T
) and then not Is_Constrained
(T
))
2615 or else (Ekind
(T
) = E_Record_Type
and then Has_Discriminants
(T
))
2618 Non_Freezing_Ref
: constant Node_Id
:=
2619 New_Occurrence_Of
(Id
, Sloc
(Id
));
2623 -- Make sure the actual subtype doesn't generate bogus freezing
2625 Set_Must_Not_Freeze
(Non_Freezing_Ref
);
2626 Decl
:= Build_Actual_Subtype
(T
, Non_Freezing_Ref
);
2627 Insert_Before_And_Analyze
(N
, Decl
);
2628 Set_Actual_Subtype
(Id
, Defining_Identifier
(Decl
));
2631 Set_Actual_Subtype
(Id
, T
);
2636 ("initialization not allowed for `IN OUT` formals", N
);
2640 if Has_Aspects
(N
) then
2641 Analyze_Aspect_Specifications
(N
, Id
);
2643 end Analyze_Formal_Object_Declaration
;
2645 ----------------------------------------------
2646 -- Analyze_Formal_Ordinary_Fixed_Point_Type --
2647 ----------------------------------------------
2649 procedure Analyze_Formal_Ordinary_Fixed_Point_Type
2653 Loc
: constant Source_Ptr
:= Sloc
(Def
);
2654 Base
: constant Entity_Id
:=
2656 (E_Ordinary_Fixed_Point_Type
, Current_Scope
,
2657 Sloc
(Defining_Identifier
(Parent
(Def
))), 'G');
2660 -- The semantic attributes are set for completeness only, their values
2661 -- will never be used, since all properties of the type are non-static.
2664 Set_Ekind
(T
, E_Ordinary_Fixed_Point_Subtype
);
2665 Set_Etype
(T
, Base
);
2666 Set_Size_Info
(T
, Standard_Integer
);
2667 Set_RM_Size
(T
, RM_Size
(Standard_Integer
));
2668 Set_Small_Value
(T
, Ureal_1
);
2669 Set_Delta_Value
(T
, Ureal_1
);
2670 Set_Scalar_Range
(T
,
2672 Low_Bound
=> Make_Real_Literal
(Loc
, Ureal_1
),
2673 High_Bound
=> Make_Real_Literal
(Loc
, Ureal_1
)));
2674 Set_Is_Constrained
(T
);
2676 Set_Is_Generic_Type
(Base
);
2677 Set_Etype
(Base
, Base
);
2678 Set_Size_Info
(Base
, Standard_Integer
);
2679 Set_RM_Size
(Base
, RM_Size
(Standard_Integer
));
2680 Set_Small_Value
(Base
, Ureal_1
);
2681 Set_Delta_Value
(Base
, Ureal_1
);
2682 Set_Scalar_Range
(Base
, Scalar_Range
(T
));
2683 Set_Parent
(Base
, Parent
(Def
));
2685 Check_Restriction
(No_Fixed_Point
, Def
);
2686 end Analyze_Formal_Ordinary_Fixed_Point_Type
;
2688 ----------------------------------------
2689 -- Analyze_Formal_Package_Declaration --
2690 ----------------------------------------
2692 procedure Analyze_Formal_Package_Declaration
(N
: Node_Id
) is
2693 Gen_Id
: constant Node_Id
:= Name
(N
);
2694 Loc
: constant Source_Ptr
:= Sloc
(N
);
2695 Pack_Id
: constant Entity_Id
:= Defining_Identifier
(N
);
2698 Gen_Unit
: Entity_Id
;
2701 Vis_Prims_List
: Elist_Id
:= No_Elist
;
2702 -- List of primitives made temporarily visible in the instantiation
2703 -- to match the visibility of the formal type.
2705 function Build_Local_Package
return Node_Id
;
2706 -- The formal package is rewritten so that its parameters are replaced
2707 -- with corresponding declarations. For parameters with bona fide
2708 -- associations these declarations are created by Analyze_Associations
2709 -- as for a regular instantiation. For boxed parameters, we preserve
2710 -- the formal declarations and analyze them, in order to introduce
2711 -- entities of the right kind in the environment of the formal.
2713 -------------------------
2714 -- Build_Local_Package --
2715 -------------------------
2717 function Build_Local_Package
return Node_Id
is
2719 Pack_Decl
: Node_Id
;
2722 -- Within the formal, the name of the generic package is a renaming
2723 -- of the formal (as for a regular instantiation).
2726 Make_Package_Declaration
(Loc
,
2729 (Specification
(Original_Node
(Gen_Decl
)),
2730 Empty
, Instantiating
=> True));
2733 Make_Package_Renaming_Declaration
(Loc
,
2734 Defining_Unit_Name
=>
2735 Make_Defining_Identifier
(Loc
, Chars
(Gen_Unit
)),
2736 Name
=> New_Occurrence_Of
(Formal
, Loc
));
2738 if Nkind
(Gen_Id
) = N_Identifier
2739 and then Chars
(Gen_Id
) = Chars
(Pack_Id
)
2742 ("& is hidden within declaration of instance", Gen_Id
, Gen_Unit
);
2745 -- If the formal is declared with a box, or with an others choice,
2746 -- create corresponding declarations for all entities in the formal
2747 -- part, so that names with the proper types are available in the
2748 -- specification of the formal package.
2750 -- On the other hand, if there are no associations, then all the
2751 -- formals must have defaults, and this will be checked by the
2752 -- call to Analyze_Associations.
2755 or else Nkind
(First
(Generic_Associations
(N
))) = N_Others_Choice
2758 Formal_Decl
: Node_Id
;
2761 -- TBA : for a formal package, need to recurse ???
2766 (Generic_Formal_Declarations
(Original_Node
(Gen_Decl
)));
2767 while Present
(Formal_Decl
) loop
2771 (Formal_Decl
, Empty
, Instantiating
=> True));
2776 -- If generic associations are present, use Analyze_Associations to
2777 -- create the proper renaming declarations.
2781 Act_Tree
: constant Node_Id
:=
2783 (Original_Node
(Gen_Decl
), Empty
,
2784 Instantiating
=> True);
2787 Generic_Renamings
.Set_Last
(0);
2788 Generic_Renamings_HTable
.Reset
;
2789 Instantiation_Node
:= N
;
2792 Analyze_Associations
2793 (I_Node
=> Original_Node
(N
),
2794 Formals
=> Generic_Formal_Declarations
(Act_Tree
),
2795 F_Copy
=> Generic_Formal_Declarations
(Gen_Decl
));
2797 Vis_Prims_List
:= Check_Hidden_Primitives
(Decls
);
2801 Append
(Renaming
, To
=> Decls
);
2803 -- Add generated declarations ahead of local declarations in
2806 if No
(Visible_Declarations
(Specification
(Pack_Decl
))) then
2807 Set_Visible_Declarations
(Specification
(Pack_Decl
), Decls
);
2810 (First
(Visible_Declarations
(Specification
(Pack_Decl
))),
2815 end Build_Local_Package
;
2819 Save_ISMP
: constant Boolean := Ignore_SPARK_Mode_Pragmas_In_Instance
;
2820 -- Save flag Ignore_SPARK_Mode_Pragmas_In_Instance for restore on exit
2822 Associations
: Boolean := True;
2824 Parent_Installed
: Boolean := False;
2825 Parent_Instance
: Entity_Id
;
2826 Renaming_In_Par
: Entity_Id
;
2828 -- Start of processing for Analyze_Formal_Package_Declaration
2831 Check_Text_IO_Special_Unit
(Gen_Id
);
2834 Check_Generic_Child_Unit
(Gen_Id
, Parent_Installed
);
2835 Gen_Unit
:= Entity
(Gen_Id
);
2837 -- Check for a formal package that is a package renaming
2839 if Present
(Renamed_Object
(Gen_Unit
)) then
2841 -- Indicate that unit is used, before replacing it with renamed
2842 -- entity for use below.
2844 if In_Extended_Main_Source_Unit
(N
) then
2845 Set_Is_Instantiated
(Gen_Unit
);
2846 Generate_Reference
(Gen_Unit
, N
);
2849 Gen_Unit
:= Renamed_Object
(Gen_Unit
);
2852 if Ekind
(Gen_Unit
) /= E_Generic_Package
then
2853 Error_Msg_N
("expect generic package name", Gen_Id
);
2857 elsif Gen_Unit
= Current_Scope
then
2859 ("generic package cannot be used as a formal package of itself",
2864 elsif In_Open_Scopes
(Gen_Unit
) then
2865 if Is_Compilation_Unit
(Gen_Unit
)
2866 and then Is_Child_Unit
(Current_Scope
)
2868 -- Special-case the error when the formal is a parent, and
2869 -- continue analysis to minimize cascaded errors.
2872 ("generic parent cannot be used as formal package of a child "
2877 ("generic package cannot be used as a formal package within "
2878 & "itself", Gen_Id
);
2884 -- Check that name of formal package does not hide name of generic,
2885 -- or its leading prefix. This check must be done separately because
2886 -- the name of the generic has already been analyzed.
2889 Gen_Name
: Entity_Id
;
2893 while Nkind
(Gen_Name
) = N_Expanded_Name
loop
2894 Gen_Name
:= Prefix
(Gen_Name
);
2897 if Chars
(Gen_Name
) = Chars
(Pack_Id
) then
2899 ("& is hidden within declaration of formal package",
2905 or else No
(Generic_Associations
(N
))
2906 or else Nkind
(First
(Generic_Associations
(N
))) = N_Others_Choice
2908 Associations
:= False;
2911 -- If there are no generic associations, the generic parameters appear
2912 -- as local entities and are instantiated like them. We copy the generic
2913 -- package declaration as if it were an instantiation, and analyze it
2914 -- like a regular package, except that we treat the formals as
2915 -- additional visible components.
2917 Gen_Decl
:= Unit_Declaration_Node
(Gen_Unit
);
2919 if In_Extended_Main_Source_Unit
(N
) then
2920 Set_Is_Instantiated
(Gen_Unit
);
2921 Generate_Reference
(Gen_Unit
, N
);
2924 Formal
:= New_Copy
(Pack_Id
);
2925 Create_Instantiation_Source
(N
, Gen_Unit
, S_Adjustment
);
2927 -- Make local generic without formals. The formals will be replaced with
2928 -- internal declarations.
2931 New_N
:= Build_Local_Package
;
2933 -- If there are errors in the parameter list, Analyze_Associations
2934 -- raises Instantiation_Error. Patch the declaration to prevent further
2935 -- exception propagation.
2938 when Instantiation_Error
=>
2939 Enter_Name
(Formal
);
2940 Set_Ekind
(Formal
, E_Variable
);
2941 Set_Etype
(Formal
, Any_Type
);
2942 Restore_Hidden_Primitives
(Vis_Prims_List
);
2944 if Parent_Installed
then
2952 Set_Defining_Unit_Name
(Specification
(New_N
), Formal
);
2953 Set_Generic_Parent
(Specification
(N
), Gen_Unit
);
2954 Set_Instance_Env
(Gen_Unit
, Formal
);
2955 Set_Is_Generic_Instance
(Formal
);
2957 Enter_Name
(Formal
);
2958 Set_Ekind
(Formal
, E_Package
);
2959 Set_Etype
(Formal
, Standard_Void_Type
);
2960 Set_Inner_Instances
(Formal
, New_Elmt_List
);
2961 Push_Scope
(Formal
);
2963 -- Manually set the SPARK_Mode from the context because the package
2964 -- declaration is never analyzed.
2966 Set_SPARK_Pragma
(Formal
, SPARK_Mode_Pragma
);
2967 Set_SPARK_Aux_Pragma
(Formal
, SPARK_Mode_Pragma
);
2968 Set_SPARK_Pragma_Inherited
(Formal
);
2969 Set_SPARK_Aux_Pragma_Inherited
(Formal
);
2971 if Is_Child_Unit
(Gen_Unit
) and then Parent_Installed
then
2973 -- Similarly, we have to make the name of the formal visible in the
2974 -- parent instance, to resolve properly fully qualified names that
2975 -- may appear in the generic unit. The parent instance has been
2976 -- placed on the scope stack ahead of the current scope.
2978 Parent_Instance
:= Scope_Stack
.Table
(Scope_Stack
.Last
- 1).Entity
;
2981 Make_Defining_Identifier
(Loc
, Chars
(Gen_Unit
));
2982 Set_Ekind
(Renaming_In_Par
, E_Package
);
2983 Set_Etype
(Renaming_In_Par
, Standard_Void_Type
);
2984 Set_Scope
(Renaming_In_Par
, Parent_Instance
);
2985 Set_Parent
(Renaming_In_Par
, Parent
(Formal
));
2986 Set_Renamed_Object
(Renaming_In_Par
, Formal
);
2987 Append_Entity
(Renaming_In_Par
, Parent_Instance
);
2990 -- A formal package declaration behaves as a package instantiation with
2991 -- respect to SPARK_Mode "off". If the annotation is "off" or altogether
2992 -- missing, set the global flag which signals Analyze_Pragma to ingnore
2993 -- all SPARK_Mode pragmas within the generic_package_name.
2995 if SPARK_Mode
/= On
then
2996 Ignore_SPARK_Mode_Pragmas_In_Instance
:= True;
2998 -- Mark the formal spec in case the body is instantiated at a later
2999 -- pass. This preserves the original context in effect for the body.
3001 Set_Ignore_SPARK_Mode_Pragmas
(Formal
);
3004 Analyze
(Specification
(N
));
3006 -- The formals for which associations are provided are not visible
3007 -- outside of the formal package. The others are still declared by a
3008 -- formal parameter declaration.
3010 -- If there are no associations, the only local entity to hide is the
3011 -- generated package renaming itself.
3017 E
:= First_Entity
(Formal
);
3018 while Present
(E
) loop
3019 if Associations
and then not Is_Generic_Formal
(E
) then
3023 if Ekind
(E
) = E_Package
and then Renamed_Entity
(E
) = Formal
then
3032 End_Package_Scope
(Formal
);
3033 Restore_Hidden_Primitives
(Vis_Prims_List
);
3035 if Parent_Installed
then
3041 -- Inside the generic unit, the formal package is a regular package, but
3042 -- no body is needed for it. Note that after instantiation, the defining
3043 -- unit name we need is in the new tree and not in the original (see
3044 -- Package_Instantiation). A generic formal package is an instance, and
3045 -- can be used as an actual for an inner instance.
3047 Set_Has_Completion
(Formal
, True);
3049 -- Add semantic information to the original defining identifier for ASIS
3052 Set_Ekind
(Pack_Id
, E_Package
);
3053 Set_Etype
(Pack_Id
, Standard_Void_Type
);
3054 Set_Scope
(Pack_Id
, Scope
(Formal
));
3055 Set_Has_Completion
(Pack_Id
, True);
3058 if Has_Aspects
(N
) then
3059 Analyze_Aspect_Specifications
(N
, Pack_Id
);
3062 Ignore_SPARK_Mode_Pragmas_In_Instance
:= Save_ISMP
;
3063 end Analyze_Formal_Package_Declaration
;
3065 ---------------------------------
3066 -- Analyze_Formal_Private_Type --
3067 ---------------------------------
3069 procedure Analyze_Formal_Private_Type
3075 New_Private_Type
(N
, T
, Def
);
3077 -- Set the size to an arbitrary but legal value
3079 Set_Size_Info
(T
, Standard_Integer
);
3080 Set_RM_Size
(T
, RM_Size
(Standard_Integer
));
3081 end Analyze_Formal_Private_Type
;
3083 ------------------------------------
3084 -- Analyze_Formal_Incomplete_Type --
3085 ------------------------------------
3087 procedure Analyze_Formal_Incomplete_Type
3093 Set_Ekind
(T
, E_Incomplete_Type
);
3095 Set_Private_Dependents
(T
, New_Elmt_List
);
3097 if Tagged_Present
(Def
) then
3098 Set_Is_Tagged_Type
(T
);
3099 Make_Class_Wide_Type
(T
);
3100 Set_Direct_Primitive_Operations
(T
, New_Elmt_List
);
3102 end Analyze_Formal_Incomplete_Type
;
3104 ----------------------------------------
3105 -- Analyze_Formal_Signed_Integer_Type --
3106 ----------------------------------------
3108 procedure Analyze_Formal_Signed_Integer_Type
3112 Base
: constant Entity_Id
:=
3114 (E_Signed_Integer_Type
,
3116 Sloc
(Defining_Identifier
(Parent
(Def
))), 'G');
3121 Set_Ekind
(T
, E_Signed_Integer_Subtype
);
3122 Set_Etype
(T
, Base
);
3123 Set_Size_Info
(T
, Standard_Integer
);
3124 Set_RM_Size
(T
, RM_Size
(Standard_Integer
));
3125 Set_Scalar_Range
(T
, Scalar_Range
(Standard_Integer
));
3126 Set_Is_Constrained
(T
);
3128 Set_Is_Generic_Type
(Base
);
3129 Set_Size_Info
(Base
, Standard_Integer
);
3130 Set_RM_Size
(Base
, RM_Size
(Standard_Integer
));
3131 Set_Etype
(Base
, Base
);
3132 Set_Scalar_Range
(Base
, Scalar_Range
(Standard_Integer
));
3133 Set_Parent
(Base
, Parent
(Def
));
3134 end Analyze_Formal_Signed_Integer_Type
;
3136 -------------------------------------------
3137 -- Analyze_Formal_Subprogram_Declaration --
3138 -------------------------------------------
3140 procedure Analyze_Formal_Subprogram_Declaration
(N
: Node_Id
) is
3141 Spec
: constant Node_Id
:= Specification
(N
);
3142 Def
: constant Node_Id
:= Default_Name
(N
);
3143 Nam
: constant Entity_Id
:= Defining_Unit_Name
(Spec
);
3151 if Nkind
(Nam
) = N_Defining_Program_Unit_Name
then
3152 Error_Msg_N
("name of formal subprogram must be a direct name", Nam
);
3156 Analyze_Subprogram_Declaration
(N
);
3157 Set_Is_Formal_Subprogram
(Nam
);
3158 Set_Has_Completion
(Nam
);
3160 if Nkind
(N
) = N_Formal_Abstract_Subprogram_Declaration
then
3161 Set_Is_Abstract_Subprogram
(Nam
);
3163 Set_Is_Dispatching_Operation
(Nam
);
3165 -- A formal abstract procedure cannot have a null default
3166 -- (RM 12.6(4.1/2)).
3168 if Nkind
(Spec
) = N_Procedure_Specification
3169 and then Null_Present
(Spec
)
3172 ("a formal abstract subprogram cannot default to null", Spec
);
3176 Ctrl_Type
: constant Entity_Id
:= Find_Dispatching_Type
(Nam
);
3178 if No
(Ctrl_Type
) then
3180 ("abstract formal subprogram must have a controlling type",
3183 elsif Ada_Version
>= Ada_2012
3184 and then Is_Incomplete_Type
(Ctrl_Type
)
3187 ("controlling type of abstract formal subprogram cannot "
3188 & "be incomplete type", N
, Ctrl_Type
);
3191 Check_Controlling_Formals
(Ctrl_Type
, Nam
);
3196 -- Default name is resolved at the point of instantiation
3198 if Box_Present
(N
) then
3201 -- Else default is bound at the point of generic declaration
3203 elsif Present
(Def
) then
3204 if Nkind
(Def
) = N_Operator_Symbol
then
3205 Find_Direct_Name
(Def
);
3207 elsif Nkind
(Def
) /= N_Attribute_Reference
then
3211 -- For an attribute reference, analyze the prefix and verify
3212 -- that it has the proper profile for the subprogram.
3214 Analyze
(Prefix
(Def
));
3215 Valid_Default_Attribute
(Nam
, Def
);
3219 -- Default name may be overloaded, in which case the interpretation
3220 -- with the correct profile must be selected, as for a renaming.
3221 -- If the definition is an indexed component, it must denote a
3222 -- member of an entry family. If it is a selected component, it
3223 -- can be a protected operation.
3225 if Etype
(Def
) = Any_Type
then
3228 elsif Nkind
(Def
) = N_Selected_Component
then
3229 if not Is_Overloadable
(Entity
(Selector_Name
(Def
))) then
3230 Error_Msg_N
("expect valid subprogram name as default", Def
);
3233 elsif Nkind
(Def
) = N_Indexed_Component
then
3234 if Is_Entity_Name
(Prefix
(Def
)) then
3235 if Ekind
(Entity
(Prefix
(Def
))) /= E_Entry_Family
then
3236 Error_Msg_N
("expect valid subprogram name as default", Def
);
3239 elsif Nkind
(Prefix
(Def
)) = N_Selected_Component
then
3240 if Ekind
(Entity
(Selector_Name
(Prefix
(Def
)))) /=
3243 Error_Msg_N
("expect valid subprogram name as default", Def
);
3247 Error_Msg_N
("expect valid subprogram name as default", Def
);
3251 elsif Nkind
(Def
) = N_Character_Literal
then
3253 -- Needs some type checks: subprogram should be parameterless???
3255 Resolve
(Def
, (Etype
(Nam
)));
3257 elsif not Is_Entity_Name
(Def
)
3258 or else not Is_Overloadable
(Entity
(Def
))
3260 Error_Msg_N
("expect valid subprogram name as default", Def
);
3263 elsif not Is_Overloaded
(Def
) then
3264 Subp
:= Entity
(Def
);
3267 Error_Msg_N
("premature usage of formal subprogram", Def
);
3269 elsif not Entity_Matches_Spec
(Subp
, Nam
) then
3270 Error_Msg_N
("no visible entity matches specification", Def
);
3273 -- More than one interpretation, so disambiguate as for a renaming
3278 I1
: Interp_Index
:= 0;
3284 Get_First_Interp
(Def
, I
, It
);
3285 while Present
(It
.Nam
) loop
3286 if Entity_Matches_Spec
(It
.Nam
, Nam
) then
3287 if Subp
/= Any_Id
then
3288 It1
:= Disambiguate
(Def
, I1
, I
, Etype
(Subp
));
3290 if It1
= No_Interp
then
3291 Error_Msg_N
("ambiguous default subprogram", Def
);
3304 Get_Next_Interp
(I
, It
);
3308 if Subp
/= Any_Id
then
3310 -- Subprogram found, generate reference to it
3312 Set_Entity
(Def
, Subp
);
3313 Generate_Reference
(Subp
, Def
);
3316 Error_Msg_N
("premature usage of formal subprogram", Def
);
3318 elsif Ekind
(Subp
) /= E_Operator
then
3319 Check_Mode_Conformant
(Subp
, Nam
);
3323 Error_Msg_N
("no visible subprogram matches specification", N
);
3329 if Has_Aspects
(N
) then
3330 Analyze_Aspect_Specifications
(N
, Nam
);
3333 end Analyze_Formal_Subprogram_Declaration
;
3335 -------------------------------------
3336 -- Analyze_Formal_Type_Declaration --
3337 -------------------------------------
3339 procedure Analyze_Formal_Type_Declaration
(N
: Node_Id
) is
3340 Def
: constant Node_Id
:= Formal_Type_Definition
(N
);
3344 T
:= Defining_Identifier
(N
);
3346 if Present
(Discriminant_Specifications
(N
))
3347 and then Nkind
(Def
) /= N_Formal_Private_Type_Definition
3350 ("discriminants not allowed for this formal type", T
);
3353 -- Enter the new name, and branch to specific routine
3356 when N_Formal_Private_Type_Definition
=>
3357 Analyze_Formal_Private_Type
(N
, T
, Def
);
3359 when N_Formal_Derived_Type_Definition
=>
3360 Analyze_Formal_Derived_Type
(N
, T
, Def
);
3362 when N_Formal_Incomplete_Type_Definition
=>
3363 Analyze_Formal_Incomplete_Type
(T
, Def
);
3365 when N_Formal_Discrete_Type_Definition
=>
3366 Analyze_Formal_Discrete_Type
(T
, Def
);
3368 when N_Formal_Signed_Integer_Type_Definition
=>
3369 Analyze_Formal_Signed_Integer_Type
(T
, Def
);
3371 when N_Formal_Modular_Type_Definition
=>
3372 Analyze_Formal_Modular_Type
(T
, Def
);
3374 when N_Formal_Floating_Point_Definition
=>
3375 Analyze_Formal_Floating_Type
(T
, Def
);
3377 when N_Formal_Ordinary_Fixed_Point_Definition
=>
3378 Analyze_Formal_Ordinary_Fixed_Point_Type
(T
, Def
);
3380 when N_Formal_Decimal_Fixed_Point_Definition
=>
3381 Analyze_Formal_Decimal_Fixed_Point_Type
(T
, Def
);
3383 when N_Array_Type_Definition
=>
3384 Analyze_Formal_Array_Type
(T
, Def
);
3386 when N_Access_Function_Definition
3387 | N_Access_Procedure_Definition
3388 | N_Access_To_Object_Definition
3390 Analyze_Generic_Access_Type
(T
, Def
);
3392 -- Ada 2005: a interface declaration is encoded as an abstract
3393 -- record declaration or a abstract type derivation.
3395 when N_Record_Definition
=>
3396 Analyze_Formal_Interface_Type
(N
, T
, Def
);
3398 when N_Derived_Type_Definition
=>
3399 Analyze_Formal_Derived_Interface_Type
(N
, T
, Def
);
3405 raise Program_Error
;
3408 Set_Is_Generic_Type
(T
);
3410 if Has_Aspects
(N
) then
3411 Analyze_Aspect_Specifications
(N
, T
);
3413 end Analyze_Formal_Type_Declaration
;
3415 ------------------------------------
3416 -- Analyze_Function_Instantiation --
3417 ------------------------------------
3419 procedure Analyze_Function_Instantiation
(N
: Node_Id
) is
3421 Analyze_Subprogram_Instantiation
(N
, E_Function
);
3422 end Analyze_Function_Instantiation
;
3424 ---------------------------------
3425 -- Analyze_Generic_Access_Type --
3426 ---------------------------------
3428 procedure Analyze_Generic_Access_Type
(T
: Entity_Id
; Def
: Node_Id
) is
3432 if Nkind
(Def
) = N_Access_To_Object_Definition
then
3433 Access_Type_Declaration
(T
, Def
);
3435 if Is_Incomplete_Or_Private_Type
(Designated_Type
(T
))
3436 and then No
(Full_View
(Designated_Type
(T
)))
3437 and then not Is_Generic_Type
(Designated_Type
(T
))
3439 Error_Msg_N
("premature usage of incomplete type", Def
);
3441 elsif not Is_Entity_Name
(Subtype_Indication
(Def
)) then
3443 ("only a subtype mark is allowed in a formal", Def
);
3447 Access_Subprogram_Declaration
(T
, Def
);
3449 end Analyze_Generic_Access_Type
;
3451 ---------------------------------
3452 -- Analyze_Generic_Formal_Part --
3453 ---------------------------------
3455 procedure Analyze_Generic_Formal_Part
(N
: Node_Id
) is
3456 Gen_Parm_Decl
: Node_Id
;
3459 -- The generic formals are processed in the scope of the generic unit,
3460 -- where they are immediately visible. The scope is installed by the
3463 Gen_Parm_Decl
:= First
(Generic_Formal_Declarations
(N
));
3464 while Present
(Gen_Parm_Decl
) loop
3465 Analyze
(Gen_Parm_Decl
);
3466 Next
(Gen_Parm_Decl
);
3469 Generate_Reference_To_Generic_Formals
(Current_Scope
);
3470 end Analyze_Generic_Formal_Part
;
3472 ------------------------------------------
3473 -- Analyze_Generic_Package_Declaration --
3474 ------------------------------------------
3476 procedure Analyze_Generic_Package_Declaration
(N
: Node_Id
) is
3477 Decls
: constant List_Id
:= Visible_Declarations
(Specification
(N
));
3478 Loc
: constant Source_Ptr
:= Sloc
(N
);
3484 Save_Parent
: Node_Id
;
3487 Check_SPARK_05_Restriction
("generic is not allowed", N
);
3489 -- We introduce a renaming of the enclosing package, to have a usable
3490 -- entity as the prefix of an expanded name for a local entity of the
3491 -- form Par.P.Q, where P is the generic package. This is because a local
3492 -- entity named P may hide it, so that the usual visibility rules in
3493 -- the instance will not resolve properly.
3496 Make_Package_Renaming_Declaration
(Loc
,
3497 Defining_Unit_Name
=>
3498 Make_Defining_Identifier
(Loc
,
3499 Chars
=> New_External_Name
(Chars
(Defining_Entity
(N
)), "GH")),
3501 Make_Identifier
(Loc
, Chars
(Defining_Entity
(N
))));
3503 -- The declaration is inserted before other declarations, but before
3504 -- pragmas that may be library-unit pragmas and must appear before other
3505 -- declarations. The pragma Compile_Time_Error is not in this class, and
3506 -- may contain an expression that includes such a qualified name, so the
3507 -- renaming declaration must appear before it.
3509 -- Are there other pragmas that require this special handling ???
3511 if Present
(Decls
) then
3512 Decl
:= First
(Decls
);
3513 while Present
(Decl
)
3514 and then Nkind
(Decl
) = N_Pragma
3515 and then Get_Pragma_Id
(Decl
) /= Pragma_Compile_Time_Error
3520 if Present
(Decl
) then
3521 Insert_Before
(Decl
, Renaming
);
3523 Append
(Renaming
, Visible_Declarations
(Specification
(N
)));
3527 Set_Visible_Declarations
(Specification
(N
), New_List
(Renaming
));
3530 -- Create copy of generic unit, and save for instantiation. If the unit
3531 -- is a child unit, do not copy the specifications for the parent, which
3532 -- are not part of the generic tree.
3534 Save_Parent
:= Parent_Spec
(N
);
3535 Set_Parent_Spec
(N
, Empty
);
3537 New_N
:= Copy_Generic_Node
(N
, Empty
, Instantiating
=> False);
3538 Set_Parent_Spec
(New_N
, Save_Parent
);
3541 -- Once the contents of the generic copy and the template are swapped,
3542 -- do the same for their respective aspect specifications.
3544 Exchange_Aspects
(N
, New_N
);
3546 -- Collect all contract-related source pragmas found within the template
3547 -- and attach them to the contract of the package spec. This contract is
3548 -- used in the capture of global references within annotations.
3550 Create_Generic_Contract
(N
);
3552 Id
:= Defining_Entity
(N
);
3553 Generate_Definition
(Id
);
3555 -- Expansion is not applied to generic units
3560 Set_Ekind
(Id
, E_Generic_Package
);
3561 Set_Etype
(Id
, Standard_Void_Type
);
3563 -- Set SPARK_Mode from context
3565 Set_SPARK_Pragma
(Id
, SPARK_Mode_Pragma
);
3566 Set_SPARK_Aux_Pragma
(Id
, SPARK_Mode_Pragma
);
3567 Set_SPARK_Pragma_Inherited
(Id
);
3568 Set_SPARK_Aux_Pragma_Inherited
(Id
);
3570 -- Preserve relevant elaboration-related attributes of the context which
3571 -- are no longer available or very expensive to recompute once analysis,
3572 -- resolution, and expansion are over.
3574 Mark_Elaboration_Attributes
3578 -- Analyze aspects now, so that generated pragmas appear in the
3579 -- declarations before building and analyzing the generic copy.
3581 if Has_Aspects
(N
) then
3582 Analyze_Aspect_Specifications
(N
, Id
);
3586 Enter_Generic_Scope
(Id
);
3587 Set_Inner_Instances
(Id
, New_Elmt_List
);
3589 Set_Categorization_From_Pragmas
(N
);
3590 Set_Is_Pure
(Id
, Is_Pure
(Current_Scope
));
3592 -- Link the declaration of the generic homonym in the generic copy to
3593 -- the package it renames, so that it is always resolved properly.
3595 Set_Generic_Homonym
(Id
, Defining_Unit_Name
(Renaming
));
3596 Set_Entity
(Associated_Node
(Name
(Renaming
)), Id
);
3598 -- For a library unit, we have reconstructed the entity for the unit,
3599 -- and must reset it in the library tables.
3601 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
3602 Set_Cunit_Entity
(Current_Sem_Unit
, Id
);
3605 Analyze_Generic_Formal_Part
(N
);
3607 -- After processing the generic formals, analysis proceeds as for a
3608 -- non-generic package.
3610 Analyze
(Specification
(N
));
3612 Validate_Categorization_Dependency
(N
, Id
);
3616 End_Package_Scope
(Id
);
3617 Exit_Generic_Scope
(Id
);
3619 -- If the generic appears within a package unit, the body of that unit
3620 -- has to be present for instantiation and inlining.
3622 if Nkind
(Unit
(Cunit
(Current_Sem_Unit
))) = N_Package_Declaration
then
3623 Set_Body_Needed_For_Inlining
3624 (Defining_Entity
(Unit
(Cunit
(Current_Sem_Unit
))));
3627 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
3628 Move_Freeze_Nodes
(Id
, N
, Visible_Declarations
(Specification
(N
)));
3629 Move_Freeze_Nodes
(Id
, N
, Private_Declarations
(Specification
(N
)));
3630 Move_Freeze_Nodes
(Id
, N
, Generic_Formal_Declarations
(N
));
3633 Set_Body_Required
(Parent
(N
), Unit_Requires_Body
(Id
));
3634 Validate_RT_RAT_Component
(N
);
3636 -- If this is a spec without a body, check that generic parameters
3639 if not Body_Required
(Parent
(N
)) then
3640 Check_References
(Id
);
3644 -- If there is a specified storage pool in the context, create an
3645 -- aspect on the package declaration, so that it is used in any
3646 -- instance that does not override it.
3648 if Present
(Default_Pool
) then
3654 Make_Aspect_Specification
(Loc
,
3655 Identifier
=> Make_Identifier
(Loc
, Name_Default_Storage_Pool
),
3656 Expression
=> New_Copy
(Default_Pool
));
3658 if No
(Aspect_Specifications
(Specification
(N
))) then
3659 Set_Aspect_Specifications
(Specification
(N
), New_List
(ASN
));
3661 Append
(ASN
, Aspect_Specifications
(Specification
(N
)));
3665 end Analyze_Generic_Package_Declaration
;
3667 --------------------------------------------
3668 -- Analyze_Generic_Subprogram_Declaration --
3669 --------------------------------------------
3671 procedure Analyze_Generic_Subprogram_Declaration
(N
: Node_Id
) is
3675 Result_Type
: Entity_Id
;
3676 Save_Parent
: Node_Id
;
3681 Check_SPARK_05_Restriction
("generic is not allowed", N
);
3683 -- Create copy of generic unit, and save for instantiation. If the unit
3684 -- is a child unit, do not copy the specifications for the parent, which
3685 -- are not part of the generic tree.
3687 Save_Parent
:= Parent_Spec
(N
);
3688 Set_Parent_Spec
(N
, Empty
);
3690 New_N
:= Copy_Generic_Node
(N
, Empty
, Instantiating
=> False);
3691 Set_Parent_Spec
(New_N
, Save_Parent
);
3694 -- Once the contents of the generic copy and the template are swapped,
3695 -- do the same for their respective aspect specifications.
3697 Exchange_Aspects
(N
, New_N
);
3699 -- Collect all contract-related source pragmas found within the template
3700 -- and attach them to the contract of the subprogram spec. This contract
3701 -- is used in the capture of global references within annotations.
3703 Create_Generic_Contract
(N
);
3705 Spec
:= Specification
(N
);
3706 Id
:= Defining_Entity
(Spec
);
3707 Generate_Definition
(Id
);
3709 if Nkind
(Id
) = N_Defining_Operator_Symbol
then
3711 ("operator symbol not allowed for generic subprogram", Id
);
3717 Set_Scope_Depth_Value
(Id
, Scope_Depth
(Current_Scope
) + 1);
3719 -- Analyze the aspects of the generic copy to ensure that all generated
3720 -- pragmas (if any) perform their semantic effects.
3722 if Has_Aspects
(N
) then
3723 Analyze_Aspect_Specifications
(N
, Id
);
3727 Enter_Generic_Scope
(Id
);
3728 Set_Inner_Instances
(Id
, New_Elmt_List
);
3729 Set_Is_Pure
(Id
, Is_Pure
(Current_Scope
));
3731 Analyze_Generic_Formal_Part
(N
);
3733 if Nkind
(Spec
) = N_Function_Specification
then
3734 Set_Ekind
(Id
, E_Generic_Function
);
3736 Set_Ekind
(Id
, E_Generic_Procedure
);
3739 -- Set SPARK_Mode from context
3741 Set_SPARK_Pragma
(Id
, SPARK_Mode_Pragma
);
3742 Set_SPARK_Pragma_Inherited
(Id
);
3744 -- Preserve relevant elaboration-related attributes of the context which
3745 -- are no longer available or very expensive to recompute once analysis,
3746 -- resolution, and expansion are over.
3748 Mark_Elaboration_Attributes
3752 Formals
:= Parameter_Specifications
(Spec
);
3754 if Present
(Formals
) then
3755 Process_Formals
(Formals
, Spec
);
3758 if Nkind
(Spec
) = N_Function_Specification
then
3759 if Nkind
(Result_Definition
(Spec
)) = N_Access_Definition
then
3760 Result_Type
:= Access_Definition
(Spec
, Result_Definition
(Spec
));
3761 Set_Etype
(Id
, Result_Type
);
3763 -- Check restriction imposed by AI05-073: a generic function
3764 -- cannot return an abstract type or an access to such.
3766 -- This is a binding interpretation should it apply to earlier
3767 -- versions of Ada as well as Ada 2012???
3769 if Is_Abstract_Type
(Designated_Type
(Result_Type
))
3770 and then Ada_Version
>= Ada_2012
3773 ("generic function cannot have an access result "
3774 & "that designates an abstract type", Spec
);
3778 Find_Type
(Result_Definition
(Spec
));
3779 Typ
:= Entity
(Result_Definition
(Spec
));
3781 if Is_Abstract_Type
(Typ
)
3782 and then Ada_Version
>= Ada_2012
3785 ("generic function cannot have abstract result type", Spec
);
3788 -- If a null exclusion is imposed on the result type, then create
3789 -- a null-excluding itype (an access subtype) and use it as the
3790 -- function's Etype.
3792 if Is_Access_Type
(Typ
)
3793 and then Null_Exclusion_Present
(Spec
)
3796 Create_Null_Excluding_Itype
3798 Related_Nod
=> Spec
,
3799 Scope_Id
=> Defining_Unit_Name
(Spec
)));
3801 Set_Etype
(Id
, Typ
);
3806 Set_Etype
(Id
, Standard_Void_Type
);
3809 -- For a library unit, we have reconstructed the entity for the unit,
3810 -- and must reset it in the library tables. We also make sure that
3811 -- Body_Required is set properly in the original compilation unit node.
3813 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
3814 Set_Cunit_Entity
(Current_Sem_Unit
, Id
);
3815 Set_Body_Required
(Parent
(N
), Unit_Requires_Body
(Id
));
3818 -- If the generic appears within a package unit, the body of that unit
3819 -- has to be present for instantiation and inlining.
3821 if Nkind
(Unit
(Cunit
(Current_Sem_Unit
))) = N_Package_Declaration
3822 and then Unit_Requires_Body
(Id
)
3824 Set_Body_Needed_For_Inlining
3825 (Defining_Entity
(Unit
(Cunit
(Current_Sem_Unit
))));
3828 Set_Categorization_From_Pragmas
(N
);
3829 Validate_Categorization_Dependency
(N
, Id
);
3831 -- Capture all global references that occur within the profile of the
3832 -- generic subprogram. Aspects are not part of this processing because
3833 -- they must be delayed. If processed now, Save_Global_References will
3834 -- destroy the Associated_Node links and prevent the capture of global
3835 -- references when the contract of the generic subprogram is analyzed.
3837 Save_Global_References
(Original_Node
(N
));
3841 Exit_Generic_Scope
(Id
);
3842 Generate_Reference_To_Formals
(Id
);
3844 List_Inherited_Pre_Post_Aspects
(Id
);
3845 end Analyze_Generic_Subprogram_Declaration
;
3847 -----------------------------------
3848 -- Analyze_Package_Instantiation --
3849 -----------------------------------
3851 -- WARNING: This routine manages Ghost and SPARK regions. Return statements
3852 -- must be replaced by gotos which jump to the end of the routine in order
3853 -- to restore the Ghost and SPARK modes.
3855 procedure Analyze_Package_Instantiation
(N
: Node_Id
) is
3856 Has_Inline_Always
: Boolean := False;
3858 procedure Delay_Descriptors
(E
: Entity_Id
);
3859 -- Delay generation of subprogram descriptors for given entity
3861 function Might_Inline_Subp
(Gen_Unit
: Entity_Id
) return Boolean;
3862 -- If inlining is active and the generic contains inlined subprograms,
3863 -- we instantiate the body. This may cause superfluous instantiations,
3864 -- but it is simpler than detecting the need for the body at the point
3865 -- of inlining, when the context of the instance is not available.
3867 -----------------------
3868 -- Delay_Descriptors --
3869 -----------------------
3871 procedure Delay_Descriptors
(E
: Entity_Id
) is
3873 if not Delay_Subprogram_Descriptors
(E
) then
3874 Set_Delay_Subprogram_Descriptors
(E
);
3875 Pending_Descriptor
.Append
(E
);
3877 end Delay_Descriptors
;
3879 -----------------------
3880 -- Might_Inline_Subp --
3881 -----------------------
3883 function Might_Inline_Subp
(Gen_Unit
: Entity_Id
) return Boolean is
3887 if not Inline_Processing_Required
then
3891 E
:= First_Entity
(Gen_Unit
);
3892 while Present
(E
) loop
3893 if Is_Subprogram
(E
) and then Is_Inlined
(E
) then
3894 -- Remember if there are any subprograms with Inline_Always
3896 if Has_Pragma_Inline_Always
(E
) then
3897 Has_Inline_Always
:= True;
3908 end Might_Inline_Subp
;
3910 -- Local declarations
3912 Gen_Id
: constant Node_Id
:= Name
(N
);
3913 Is_Actual_Pack
: constant Boolean :=
3914 Is_Internal
(Defining_Entity
(N
));
3915 Loc
: constant Source_Ptr
:= Sloc
(N
);
3917 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
3918 Saved_ISMP
: constant Boolean :=
3919 Ignore_SPARK_Mode_Pragmas_In_Instance
;
3920 Saved_SM
: constant SPARK_Mode_Type
:= SPARK_Mode
;
3921 Saved_SMP
: constant Node_Id
:= SPARK_Mode_Pragma
;
3922 -- Save the Ghost and SPARK mode-related data to restore on exit
3924 Saved_Style_Check
: constant Boolean := Style_Check
;
3925 -- Save style check mode for restore on exit
3928 Act_Decl_Name
: Node_Id
;
3929 Act_Decl_Id
: Entity_Id
;
3932 Env_Installed
: Boolean := False;
3935 Gen_Unit
: Entity_Id
;
3936 Inline_Now
: Boolean := False;
3937 Needs_Body
: Boolean;
3938 Parent_Installed
: Boolean := False;
3939 Renaming_List
: List_Id
;
3940 Unit_Renaming
: Node_Id
;
3942 Vis_Prims_List
: Elist_Id
:= No_Elist
;
3943 -- List of primitives made temporarily visible in the instantiation
3944 -- to match the visibility of the formal type
3946 -- Start of processing for Analyze_Package_Instantiation
3949 -- Preserve relevant elaboration-related attributes of the context which
3950 -- are no longer available or very expensive to recompute once analysis,
3951 -- resolution, and expansion are over.
3953 Mark_Elaboration_Attributes
3960 Check_SPARK_05_Restriction
("generic is not allowed", N
);
3962 -- Very first thing: check for Text_IO special unit in case we are
3963 -- instantiating one of the children of [[Wide_]Wide_]Text_IO.
3965 Check_Text_IO_Special_Unit
(Name
(N
));
3967 -- Make node global for error reporting
3969 Instantiation_Node
:= N
;
3971 -- Case of instantiation of a generic package
3973 if Nkind
(N
) = N_Package_Instantiation
then
3974 Act_Decl_Id
:= New_Copy
(Defining_Entity
(N
));
3975 Set_Comes_From_Source
(Act_Decl_Id
, True);
3977 if Nkind
(Defining_Unit_Name
(N
)) = N_Defining_Program_Unit_Name
then
3979 Make_Defining_Program_Unit_Name
(Loc
,
3981 New_Copy_Tree
(Name
(Defining_Unit_Name
(N
))),
3982 Defining_Identifier
=> Act_Decl_Id
);
3984 Act_Decl_Name
:= Act_Decl_Id
;
3987 -- Case of instantiation of a formal package
3990 Act_Decl_Id
:= Defining_Identifier
(N
);
3991 Act_Decl_Name
:= Act_Decl_Id
;
3994 Generate_Definition
(Act_Decl_Id
);
3995 Set_Ekind
(Act_Decl_Id
, E_Package
);
3997 -- Initialize list of incomplete actuals before analysis
3999 Set_Incomplete_Actuals
(Act_Decl_Id
, New_Elmt_List
);
4001 Preanalyze_Actuals
(N
, Act_Decl_Id
);
4003 -- Turn off style checking in instances. If the check is enabled on the
4004 -- generic unit, a warning in an instance would just be noise. If not
4005 -- enabled on the generic, then a warning in an instance is just wrong.
4006 -- This must be done after analyzing the actuals, which do come from
4007 -- source and are subject to style checking.
4009 Style_Check
:= False;
4012 Env_Installed
:= True;
4014 -- Reset renaming map for formal types. The mapping is established
4015 -- when analyzing the generic associations, but some mappings are
4016 -- inherited from formal packages of parent units, and these are
4017 -- constructed when the parents are installed.
4019 Generic_Renamings
.Set_Last
(0);
4020 Generic_Renamings_HTable
.Reset
;
4022 Check_Generic_Child_Unit
(Gen_Id
, Parent_Installed
);
4023 Gen_Unit
:= Entity
(Gen_Id
);
4025 -- A package instantiation is Ghost when it is subject to pragma Ghost
4026 -- or the generic template is Ghost. Set the mode now to ensure that
4027 -- any nodes generated during analysis and expansion are marked as
4030 Mark_And_Set_Ghost_Instantiation
(N
, Gen_Unit
);
4032 -- Verify that it is the name of a generic package
4034 -- A visibility glitch: if the instance is a child unit and the generic
4035 -- is the generic unit of a parent instance (i.e. both the parent and
4036 -- the child units are instances of the same package) the name now
4037 -- denotes the renaming within the parent, not the intended generic
4038 -- unit. See if there is a homonym that is the desired generic. The
4039 -- renaming declaration must be visible inside the instance of the
4040 -- child, but not when analyzing the name in the instantiation itself.
4042 if Ekind
(Gen_Unit
) = E_Package
4043 and then Present
(Renamed_Entity
(Gen_Unit
))
4044 and then In_Open_Scopes
(Renamed_Entity
(Gen_Unit
))
4045 and then Is_Generic_Instance
(Renamed_Entity
(Gen_Unit
))
4046 and then Present
(Homonym
(Gen_Unit
))
4048 Gen_Unit
:= Homonym
(Gen_Unit
);
4051 if Etype
(Gen_Unit
) = Any_Type
then
4055 elsif Ekind
(Gen_Unit
) /= E_Generic_Package
then
4057 -- Ada 2005 (AI-50217): Cannot use instance in limited with_clause
4059 if From_Limited_With
(Gen_Unit
) then
4061 ("cannot instantiate a limited withed package", Gen_Id
);
4064 ("& is not the name of a generic package", Gen_Id
, Gen_Unit
);
4071 if In_Extended_Main_Source_Unit
(N
) then
4072 Set_Is_Instantiated
(Gen_Unit
);
4073 Generate_Reference
(Gen_Unit
, N
);
4075 if Present
(Renamed_Object
(Gen_Unit
)) then
4076 Set_Is_Instantiated
(Renamed_Object
(Gen_Unit
));
4077 Generate_Reference
(Renamed_Object
(Gen_Unit
), N
);
4081 if Nkind
(Gen_Id
) = N_Identifier
4082 and then Chars
(Gen_Unit
) = Chars
(Defining_Entity
(N
))
4085 ("& is hidden within declaration of instance", Gen_Id
, Gen_Unit
);
4087 elsif Nkind
(Gen_Id
) = N_Expanded_Name
4088 and then Is_Child_Unit
(Gen_Unit
)
4089 and then Nkind
(Prefix
(Gen_Id
)) = N_Identifier
4090 and then Chars
(Act_Decl_Id
) = Chars
(Prefix
(Gen_Id
))
4093 ("& is hidden within declaration of instance ", Prefix
(Gen_Id
));
4096 Set_Entity
(Gen_Id
, Gen_Unit
);
4098 -- If generic is a renaming, get original generic unit
4100 if Present
(Renamed_Object
(Gen_Unit
))
4101 and then Ekind
(Renamed_Object
(Gen_Unit
)) = E_Generic_Package
4103 Gen_Unit
:= Renamed_Object
(Gen_Unit
);
4106 -- Verify that there are no circular instantiations
4108 if In_Open_Scopes
(Gen_Unit
) then
4109 Error_Msg_NE
("instantiation of & within itself", N
, Gen_Unit
);
4113 elsif Contains_Instance_Of
(Gen_Unit
, Current_Scope
, Gen_Id
) then
4114 Error_Msg_Node_2
:= Current_Scope
;
4116 ("circular Instantiation: & instantiated in &!", N
, Gen_Unit
);
4117 Circularity_Detected
:= True;
4122 -- If the context of the instance is subject to SPARK_Mode "off" or
4123 -- the annotation is altogether missing, set the global flag which
4124 -- signals Analyze_Pragma to ignore all SPARK_Mode pragmas within
4127 if SPARK_Mode
/= On
then
4128 Ignore_SPARK_Mode_Pragmas_In_Instance
:= True;
4130 -- Mark the instance spec in case the body is instantiated at a
4131 -- later pass. This preserves the original context in effect for
4134 Set_Ignore_SPARK_Mode_Pragmas
(Act_Decl_Id
);
4137 Gen_Decl
:= Unit_Declaration_Node
(Gen_Unit
);
4138 Gen_Spec
:= Specification
(Gen_Decl
);
4140 -- Initialize renamings map, for error checking, and the list that
4141 -- holds private entities whose views have changed between generic
4142 -- definition and instantiation. If this is the instance created to
4143 -- validate an actual package, the instantiation environment is that
4144 -- of the enclosing instance.
4146 Create_Instantiation_Source
(N
, Gen_Unit
, S_Adjustment
);
4148 -- Copy original generic tree, to produce text for instantiation
4152 (Original_Node
(Gen_Decl
), Empty
, Instantiating
=> True);
4154 Act_Spec
:= Specification
(Act_Tree
);
4156 -- If this is the instance created to validate an actual package,
4157 -- only the formals matter, do not examine the package spec itself.
4159 if Is_Actual_Pack
then
4160 Set_Visible_Declarations
(Act_Spec
, New_List
);
4161 Set_Private_Declarations
(Act_Spec
, New_List
);
4165 Analyze_Associations
4167 Formals
=> Generic_Formal_Declarations
(Act_Tree
),
4168 F_Copy
=> Generic_Formal_Declarations
(Gen_Decl
));
4170 Vis_Prims_List
:= Check_Hidden_Primitives
(Renaming_List
);
4172 Set_Instance_Env
(Gen_Unit
, Act_Decl_Id
);
4173 Set_Defining_Unit_Name
(Act_Spec
, Act_Decl_Name
);
4174 Set_Is_Generic_Instance
(Act_Decl_Id
);
4175 Set_Generic_Parent
(Act_Spec
, Gen_Unit
);
4177 -- References to the generic in its own declaration or its body are
4178 -- references to the instance. Add a renaming declaration for the
4179 -- generic unit itself. This declaration, as well as the renaming
4180 -- declarations for the generic formals, must remain private to the
4181 -- unit: the formals, because this is the language semantics, and
4182 -- the unit because its use is an artifact of the implementation.
4185 Make_Package_Renaming_Declaration
(Loc
,
4186 Defining_Unit_Name
=>
4187 Make_Defining_Identifier
(Loc
, Chars
(Gen_Unit
)),
4188 Name
=> New_Occurrence_Of
(Act_Decl_Id
, Loc
));
4190 Append
(Unit_Renaming
, Renaming_List
);
4192 -- The renaming declarations are the first local declarations of the
4195 if Is_Non_Empty_List
(Visible_Declarations
(Act_Spec
)) then
4197 (First
(Visible_Declarations
(Act_Spec
)), Renaming_List
);
4199 Set_Visible_Declarations
(Act_Spec
, Renaming_List
);
4202 Act_Decl
:= Make_Package_Declaration
(Loc
, Specification
=> Act_Spec
);
4204 -- Propagate the aspect specifications from the package declaration
4205 -- template to the instantiated version of the package declaration.
4207 if Has_Aspects
(Act_Tree
) then
4208 Set_Aspect_Specifications
(Act_Decl
,
4209 New_Copy_List_Tree
(Aspect_Specifications
(Act_Tree
)));
4212 -- The generic may have a generated Default_Storage_Pool aspect,
4213 -- set at the point of generic declaration. If the instance has
4214 -- that aspect, it overrides the one inherited from the generic.
4216 if Has_Aspects
(Gen_Spec
) then
4217 if No
(Aspect_Specifications
(N
)) then
4218 Set_Aspect_Specifications
(N
,
4220 (Aspect_Specifications
(Gen_Spec
))));
4224 ASN1
, ASN2
: Node_Id
;
4227 ASN1
:= First
(Aspect_Specifications
(N
));
4228 while Present
(ASN1
) loop
4229 if Chars
(Identifier
(ASN1
)) = Name_Default_Storage_Pool
4231 -- If generic carries a default storage pool, remove
4232 -- it in favor of the instance one.
4234 ASN2
:= First
(Aspect_Specifications
(Gen_Spec
));
4235 while Present
(ASN2
) loop
4236 if Chars
(Identifier
(ASN2
)) =
4237 Name_Default_Storage_Pool
4250 Prepend_List_To
(Aspect_Specifications
(N
),
4252 (Aspect_Specifications
(Gen_Spec
))));
4257 -- Save the instantiation node, for subsequent instantiation of the
4258 -- body, if there is one and we are generating code for the current
4259 -- unit. Mark unit as having a body (avoids premature error message).
4261 -- We instantiate the body if we are generating code, if we are
4262 -- generating cross-reference information, or if we are building
4263 -- trees for ASIS use or GNATprove use.
4266 Enclosing_Body_Present
: Boolean := False;
4267 -- If the generic unit is not a compilation unit, then a body may
4268 -- be present in its parent even if none is required. We create a
4269 -- tentative pending instantiation for the body, which will be
4270 -- discarded if none is actually present.
4275 if Scope
(Gen_Unit
) /= Standard_Standard
4276 and then not Is_Child_Unit
(Gen_Unit
)
4278 Scop
:= Scope
(Gen_Unit
);
4279 while Present
(Scop
) and then Scop
/= Standard_Standard
loop
4280 if Unit_Requires_Body
(Scop
) then
4281 Enclosing_Body_Present
:= True;
4284 elsif In_Open_Scopes
(Scop
)
4285 and then In_Package_Body
(Scop
)
4287 Enclosing_Body_Present
:= True;
4291 exit when Is_Compilation_Unit
(Scop
);
4292 Scop
:= Scope
(Scop
);
4296 -- If front-end inlining is enabled or there are any subprograms
4297 -- marked with Inline_Always, and this is a unit for which code
4298 -- will be generated, we instantiate the body at once.
4300 -- This is done if the instance is not the main unit, and if the
4301 -- generic is not a child unit of another generic, to avoid scope
4302 -- problems and the reinstallation of parent instances.
4305 and then (not Is_Child_Unit
(Gen_Unit
)
4306 or else not Is_Generic_Unit
(Scope
(Gen_Unit
)))
4307 and then Might_Inline_Subp
(Gen_Unit
)
4308 and then not Is_Actual_Pack
4310 if not Back_End_Inlining
4311 and then (Front_End_Inlining
or else Has_Inline_Always
)
4312 and then (Is_In_Main_Unit
(N
)
4313 or else In_Main_Context
(Current_Scope
))
4314 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit
4318 -- In configurable_run_time mode we force the inlining of
4319 -- predefined subprograms marked Inline_Always, to minimize
4320 -- the use of the run-time library.
4322 elsif In_Predefined_Unit
(Gen_Decl
)
4323 and then Configurable_Run_Time_Mode
4324 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit
4329 -- If the current scope is itself an instance within a child
4330 -- unit, there will be duplications in the scope stack, and the
4331 -- unstacking mechanism in Inline_Instance_Body will fail.
4332 -- This loses some rare cases of optimization, and might be
4333 -- improved some day, if we can find a proper abstraction for
4334 -- "the complete compilation context" that can be saved and
4337 if Is_Generic_Instance
(Current_Scope
) then
4339 Curr_Unit
: constant Entity_Id
:=
4340 Cunit_Entity
(Current_Sem_Unit
);
4342 if Curr_Unit
/= Current_Scope
4343 and then Is_Child_Unit
(Curr_Unit
)
4345 Inline_Now
:= False;
4352 (Unit_Requires_Body
(Gen_Unit
)
4353 or else Enclosing_Body_Present
4354 or else Present
(Corresponding_Body
(Gen_Decl
)))
4355 and then (Is_In_Main_Unit
(N
)
4356 or else Might_Inline_Subp
(Gen_Unit
))
4357 and then not Is_Actual_Pack
4358 and then not Inline_Now
4359 and then (Operating_Mode
= Generate_Code
4361 -- Need comment for this check ???
4363 or else (Operating_Mode
= Check_Semantics
4364 and then (ASIS_Mode
or GNATprove_Mode
)));
4366 -- If front-end inlining is enabled or there are any subprograms
4367 -- marked with Inline_Always, do not instantiate body when within
4368 -- a generic context.
4370 if ((Front_End_Inlining
or else Has_Inline_Always
)
4371 and then not Expander_Active
)
4372 or else Is_Generic_Unit
(Cunit_Entity
(Main_Unit
))
4374 Needs_Body
:= False;
4377 -- If the current context is generic, and the package being
4378 -- instantiated is declared within a formal package, there is no
4379 -- body to instantiate until the enclosing generic is instantiated
4380 -- and there is an actual for the formal package. If the formal
4381 -- package has parameters, we build a regular package instance for
4382 -- it, that precedes the original formal package declaration.
4384 if In_Open_Scopes
(Scope
(Scope
(Gen_Unit
))) then
4386 Decl
: constant Node_Id
:=
4388 (Unit_Declaration_Node
(Scope
(Gen_Unit
)));
4390 if Nkind
(Decl
) = N_Formal_Package_Declaration
4391 or else (Nkind
(Decl
) = N_Package_Declaration
4392 and then Is_List_Member
(Decl
)
4393 and then Present
(Next
(Decl
))
4395 Nkind
(Next
(Decl
)) =
4396 N_Formal_Package_Declaration
)
4398 Needs_Body
:= False;
4404 -- For RCI unit calling stubs, we omit the instance body if the
4405 -- instance is the RCI library unit itself.
4407 -- However there is a special case for nested instances: in this case
4408 -- we do generate the instance body, as it might be required, e.g.
4409 -- because it provides stream attributes for some type used in the
4410 -- profile of a remote subprogram. This is consistent with 12.3(12),
4411 -- which indicates that the instance body occurs at the place of the
4412 -- instantiation, and thus is part of the RCI declaration, which is
4413 -- present on all client partitions (this is E.2.3(18)).
4415 -- Note that AI12-0002 may make it illegal at some point to have
4416 -- stream attributes defined in an RCI unit, in which case this
4417 -- special case will become unnecessary. In the meantime, there
4418 -- is known application code in production that depends on this
4419 -- being possible, so we definitely cannot eliminate the body in
4420 -- the case of nested instances for the time being.
4422 -- When we generate a nested instance body, calling stubs for any
4423 -- relevant subprogram will be be inserted immediately after the
4424 -- subprogram declarations, and will take precedence over the
4425 -- subsequent (original) body. (The stub and original body will be
4426 -- complete homographs, but this is permitted in an instance).
4427 -- (Could we do better and remove the original body???)
4429 if Distribution_Stub_Mode
= Generate_Caller_Stub_Body
4430 and then Comes_From_Source
(N
)
4431 and then Nkind
(Parent
(N
)) = N_Compilation_Unit
4433 Needs_Body
:= False;
4438 -- Here is a defence against a ludicrous number of instantiations
4439 -- caused by a circular set of instantiation attempts.
4441 if Pending_Instantiations
.Last
> Maximum_Instantiations
then
4442 Error_Msg_Uint_1
:= UI_From_Int
(Maximum_Instantiations
);
4443 Error_Msg_N
("too many instantiations, exceeds max of^", N
);
4444 Error_Msg_N
("\limit can be changed using -gnateinn switch", N
);
4445 raise Unrecoverable_Error
;
4448 -- Indicate that the enclosing scopes contain an instantiation,
4449 -- and that cleanup actions should be delayed until after the
4450 -- instance body is expanded.
4452 Check_Forward_Instantiation
(Gen_Decl
);
4453 if Nkind
(N
) = N_Package_Instantiation
then
4455 Enclosing_Master
: Entity_Id
;
4458 -- Loop to search enclosing masters
4460 Enclosing_Master
:= Current_Scope
;
4461 Scope_Loop
: while Enclosing_Master
/= Standard_Standard
loop
4462 if Ekind
(Enclosing_Master
) = E_Package
then
4463 if Is_Compilation_Unit
(Enclosing_Master
) then
4464 if In_Package_Body
(Enclosing_Master
) then
4466 (Body_Entity
(Enclosing_Master
));
4475 Enclosing_Master
:= Scope
(Enclosing_Master
);
4478 elsif Is_Generic_Unit
(Enclosing_Master
)
4479 or else Ekind
(Enclosing_Master
) = E_Void
4481 -- Cleanup actions will eventually be performed on the
4482 -- enclosing subprogram or package instance, if any.
4483 -- Enclosing scope is void in the formal part of a
4484 -- generic subprogram.
4489 if Ekind
(Enclosing_Master
) = E_Entry
4491 Ekind
(Scope
(Enclosing_Master
)) = E_Protected_Type
4493 if not Expander_Active
then
4497 Protected_Body_Subprogram
(Enclosing_Master
);
4501 Set_Delay_Cleanups
(Enclosing_Master
);
4503 while Ekind
(Enclosing_Master
) = E_Block
loop
4504 Enclosing_Master
:= Scope
(Enclosing_Master
);
4507 if Is_Subprogram
(Enclosing_Master
) then
4508 Delay_Descriptors
(Enclosing_Master
);
4510 elsif Is_Task_Type
(Enclosing_Master
) then
4512 TBP
: constant Node_Id
:=
4513 Get_Task_Body_Procedure
4516 if Present
(TBP
) then
4517 Delay_Descriptors
(TBP
);
4518 Set_Delay_Cleanups
(TBP
);
4525 end loop Scope_Loop
;
4528 -- Make entry in table
4530 Add_Pending_Instantiation
(N
, Act_Decl
);
4534 Set_Categorization_From_Pragmas
(Act_Decl
);
4536 if Parent_Installed
then
4540 Set_Instance_Spec
(N
, Act_Decl
);
4542 -- If not a compilation unit, insert the package declaration before
4543 -- the original instantiation node.
4545 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
4546 Mark_Rewrite_Insertion
(Act_Decl
);
4547 Insert_Before
(N
, Act_Decl
);
4549 if Has_Aspects
(N
) then
4550 Analyze_Aspect_Specifications
(N
, Act_Decl_Id
);
4552 -- The pragma created for a Default_Storage_Pool aspect must
4553 -- appear ahead of the declarations in the instance spec.
4554 -- Analysis has placed it after the instance node, so remove
4555 -- it and reinsert it properly now.
4558 ASN
: constant Node_Id
:= First
(Aspect_Specifications
(N
));
4559 A_Name
: constant Name_Id
:= Chars
(Identifier
(ASN
));
4563 if A_Name
= Name_Default_Storage_Pool
then
4564 if No
(Visible_Declarations
(Act_Spec
)) then
4565 Set_Visible_Declarations
(Act_Spec
, New_List
);
4569 while Present
(Decl
) loop
4570 if Nkind
(Decl
) = N_Pragma
then
4572 Prepend
(Decl
, Visible_Declarations
(Act_Spec
));
4584 -- For an instantiation that is a compilation unit, place
4585 -- declaration on current node so context is complete for analysis
4586 -- (including nested instantiations). If this is the main unit,
4587 -- the declaration eventually replaces the instantiation node.
4588 -- If the instance body is created later, it replaces the
4589 -- instance node, and the declaration is attached to it
4590 -- (see Build_Instance_Compilation_Unit_Nodes).
4593 if Cunit_Entity
(Current_Sem_Unit
) = Defining_Entity
(N
) then
4595 -- The entity for the current unit is the newly created one,
4596 -- and all semantic information is attached to it.
4598 Set_Cunit_Entity
(Current_Sem_Unit
, Act_Decl_Id
);
4600 -- If this is the main unit, replace the main entity as well
4602 if Current_Sem_Unit
= Main_Unit
then
4603 Main_Unit_Entity
:= Act_Decl_Id
;
4607 Set_Unit
(Parent
(N
), Act_Decl
);
4608 Set_Parent_Spec
(Act_Decl
, Parent_Spec
(N
));
4609 Set_Package_Instantiation
(Act_Decl_Id
, N
);
4611 -- Process aspect specifications of the instance node, if any, to
4612 -- take into account categorization pragmas before analyzing the
4615 if Has_Aspects
(N
) then
4616 Analyze_Aspect_Specifications
(N
, Act_Decl_Id
);
4620 Set_Unit
(Parent
(N
), N
);
4621 Set_Body_Required
(Parent
(N
), False);
4623 -- We never need elaboration checks on instantiations, since by
4624 -- definition, the body instantiation is elaborated at the same
4625 -- time as the spec instantiation.
4627 if Legacy_Elaboration_Checks
then
4628 Set_Kill_Elaboration_Checks
(Act_Decl_Id
);
4629 Set_Suppress_Elaboration_Warnings
(Act_Decl_Id
);
4633 if Legacy_Elaboration_Checks
then
4634 Check_Elab_Instantiation
(N
);
4637 -- Save the scenario for later examination by the ABE Processing
4640 Record_Elaboration_Scenario
(N
);
4642 -- The instantiation results in a guaranteed ABE
4644 if Is_Known_Guaranteed_ABE
(N
) and then Needs_Body
then
4646 -- Do not instantiate the corresponding body because gigi cannot
4647 -- handle certain types of premature instantiations.
4649 Pending_Instantiations
.Decrement_Last
;
4651 -- Create completing bodies for all subprogram declarations since
4652 -- their real bodies will not be instantiated.
4654 Provide_Completing_Bodies
(Instance_Spec
(N
));
4657 Check_Hidden_Child_Unit
(N
, Gen_Unit
, Act_Decl_Id
);
4659 Set_First_Private_Entity
(Defining_Unit_Name
(Unit_Renaming
),
4660 First_Private_Entity
(Act_Decl_Id
));
4662 -- If the instantiation will receive a body, the unit will be
4663 -- transformed into a package body, and receive its own elaboration
4664 -- entity. Otherwise, the nature of the unit is now a package
4667 if Nkind
(Parent
(N
)) = N_Compilation_Unit
4668 and then not Needs_Body
4670 Rewrite
(N
, Act_Decl
);
4673 if Present
(Corresponding_Body
(Gen_Decl
))
4674 or else Unit_Requires_Body
(Gen_Unit
)
4676 Set_Has_Completion
(Act_Decl_Id
);
4679 Check_Formal_Packages
(Act_Decl_Id
);
4681 Restore_Hidden_Primitives
(Vis_Prims_List
);
4682 Restore_Private_Views
(Act_Decl_Id
);
4684 Inherit_Context
(Gen_Decl
, N
);
4686 if Parent_Installed
then
4691 Env_Installed
:= False;
4694 Validate_Categorization_Dependency
(N
, Act_Decl_Id
);
4696 -- There used to be a check here to prevent instantiations in local
4697 -- contexts if the No_Local_Allocators restriction was active. This
4698 -- check was removed by a binding interpretation in AI-95-00130/07,
4699 -- but we retain the code for documentation purposes.
4701 -- if Ekind (Act_Decl_Id) /= E_Void
4702 -- and then not Is_Library_Level_Entity (Act_Decl_Id)
4704 -- Check_Restriction (No_Local_Allocators, N);
4708 Inline_Instance_Body
(N
, Gen_Unit
, Act_Decl
);
4711 -- The following is a tree patch for ASIS: ASIS needs separate nodes to
4712 -- be used as defining identifiers for a formal package and for the
4713 -- corresponding expanded package.
4715 if Nkind
(N
) = N_Formal_Package_Declaration
then
4716 Act_Decl_Id
:= New_Copy
(Defining_Entity
(N
));
4717 Set_Comes_From_Source
(Act_Decl_Id
, True);
4718 Set_Is_Generic_Instance
(Act_Decl_Id
, False);
4719 Set_Defining_Identifier
(N
, Act_Decl_Id
);
4722 -- Check that if N is an instantiation of System.Dim_Float_IO or
4723 -- System.Dim_Integer_IO, the formal type has a dimension system.
4725 if Nkind
(N
) = N_Package_Instantiation
4726 and then Is_Dim_IO_Package_Instantiation
(N
)
4729 Assoc
: constant Node_Id
:= First
(Generic_Associations
(N
));
4731 if not Has_Dimension_System
4732 (Etype
(Explicit_Generic_Actual_Parameter
(Assoc
)))
4734 Error_Msg_N
("type with a dimension system expected", Assoc
);
4740 if Has_Aspects
(N
) and then Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
4741 Analyze_Aspect_Specifications
(N
, Act_Decl_Id
);
4744 Ignore_SPARK_Mode_Pragmas_In_Instance
:= Saved_ISMP
;
4745 Restore_Ghost_Mode
(Saved_GM
);
4746 Restore_SPARK_Mode
(Saved_SM
, Saved_SMP
);
4747 Style_Check
:= Saved_Style_Check
;
4750 when Instantiation_Error
=>
4751 if Parent_Installed
then
4755 if Env_Installed
then
4759 Ignore_SPARK_Mode_Pragmas_In_Instance
:= Saved_ISMP
;
4760 Restore_Ghost_Mode
(Saved_GM
);
4761 Restore_SPARK_Mode
(Saved_SM
, Saved_SMP
);
4762 Style_Check
:= Saved_Style_Check
;
4763 end Analyze_Package_Instantiation
;
4765 --------------------------
4766 -- Inline_Instance_Body --
4767 --------------------------
4769 -- WARNING: This routine manages SPARK regions. Return statements must be
4770 -- replaced by gotos which jump to the end of the routine and restore the
4773 procedure Inline_Instance_Body
4775 Gen_Unit
: Entity_Id
;
4778 Curr_Comp
: constant Node_Id
:= Cunit
(Current_Sem_Unit
);
4779 Curr_Unit
: constant Entity_Id
:= Cunit_Entity
(Current_Sem_Unit
);
4780 Gen_Comp
: constant Entity_Id
:=
4781 Cunit_Entity
(Get_Source_Unit
(Gen_Unit
));
4783 Saved_SM
: constant SPARK_Mode_Type
:= SPARK_Mode
;
4784 Saved_SMP
: constant Node_Id
:= SPARK_Mode_Pragma
;
4785 -- Save the SPARK mode-related data to restore on exit. Removing
4786 -- enclosing scopes to provide a clean environment for analysis of
4787 -- the inlined body will eliminate any previously set SPARK_Mode.
4789 Scope_Stack_Depth
: constant Pos
:=
4790 Scope_Stack
.Last
- Scope_Stack
.First
+ 1;
4792 Inner_Scopes
: array (1 .. Scope_Stack_Depth
) of Entity_Id
;
4793 Instances
: array (1 .. Scope_Stack_Depth
) of Entity_Id
;
4794 Use_Clauses
: array (1 .. Scope_Stack_Depth
) of Node_Id
;
4796 Curr_Scope
: Entity_Id
:= Empty
;
4797 List
: Elist_Id
:= No_Elist
; -- init to avoid warning
4798 N_Instances
: Nat
:= 0;
4799 Num_Inner
: Nat
:= 0;
4800 Num_Scopes
: Nat
:= 0;
4801 Removed
: Boolean := False;
4806 -- Case of generic unit defined in another unit. We must remove the
4807 -- complete context of the current unit to install that of the generic.
4809 if Gen_Comp
/= Cunit_Entity
(Current_Sem_Unit
) then
4811 -- Add some comments for the following two loops ???
4814 while Present
(S
) and then S
/= Standard_Standard
loop
4816 Num_Scopes
:= Num_Scopes
+ 1;
4818 Use_Clauses
(Num_Scopes
) :=
4820 (Scope_Stack
.Last
- Num_Scopes
+ 1).
4822 End_Use_Clauses
(Use_Clauses
(Num_Scopes
));
4824 exit when Scope_Stack
.Last
- Num_Scopes
+ 1 = Scope_Stack
.First
4825 or else Scope_Stack
.Table
4826 (Scope_Stack
.Last
- Num_Scopes
).Entity
= Scope
(S
);
4829 exit when Is_Generic_Instance
(S
)
4830 and then (In_Package_Body
(S
)
4831 or else Ekind
(S
) = E_Procedure
4832 or else Ekind
(S
) = E_Function
);
4836 Vis
:= Is_Immediately_Visible
(Gen_Comp
);
4838 -- Find and save all enclosing instances
4843 and then S
/= Standard_Standard
4845 if Is_Generic_Instance
(S
) then
4846 N_Instances
:= N_Instances
+ 1;
4847 Instances
(N_Instances
) := S
;
4849 exit when In_Package_Body
(S
);
4855 -- Remove context of current compilation unit, unless we are within a
4856 -- nested package instantiation, in which case the context has been
4857 -- removed previously.
4859 -- If current scope is the body of a child unit, remove context of
4860 -- spec as well. If an enclosing scope is an instance body, the
4861 -- context has already been removed, but the entities in the body
4862 -- must be made invisible as well.
4865 while Present
(S
) and then S
/= Standard_Standard
loop
4866 if Is_Generic_Instance
(S
)
4867 and then (In_Package_Body
(S
)
4868 or else Ekind_In
(S
, E_Procedure
, E_Function
))
4870 -- We still have to remove the entities of the enclosing
4871 -- instance from direct visibility.
4876 E
:= First_Entity
(S
);
4877 while Present
(E
) loop
4878 Set_Is_Immediately_Visible
(E
, False);
4887 or else (Ekind
(Curr_Unit
) = E_Package_Body
4888 and then S
= Spec_Entity
(Curr_Unit
))
4889 or else (Ekind
(Curr_Unit
) = E_Subprogram_Body
4890 and then S
= Corresponding_Spec
4891 (Unit_Declaration_Node
(Curr_Unit
)))
4895 -- Remove entities in current scopes from visibility, so that
4896 -- instance body is compiled in a clean environment.
4898 List
:= Save_Scope_Stack
(Handle_Use
=> False);
4900 if Is_Child_Unit
(S
) then
4902 -- Remove child unit from stack, as well as inner scopes.
4903 -- Removing the context of a child unit removes parent units
4906 while Current_Scope
/= S
loop
4907 Num_Inner
:= Num_Inner
+ 1;
4908 Inner_Scopes
(Num_Inner
) := Current_Scope
;
4913 Remove_Context
(Curr_Comp
);
4917 Remove_Context
(Curr_Comp
);
4920 if Ekind
(Curr_Unit
) = E_Package_Body
then
4921 Remove_Context
(Library_Unit
(Curr_Comp
));
4928 pragma Assert
(Num_Inner
< Num_Scopes
);
4930 -- The inlined package body must be analyzed with the SPARK_Mode of
4931 -- the enclosing context, otherwise the body may cause bogus errors
4932 -- if a configuration SPARK_Mode pragma in in effect.
4934 Push_Scope
(Standard_Standard
);
4935 Scope_Stack
.Table
(Scope_Stack
.Last
).Is_Active_Stack_Base
:= True;
4936 Instantiate_Package_Body
4939 Act_Decl
=> Act_Decl
,
4940 Expander_Status
=> Expander_Active
,
4941 Current_Sem_Unit
=> Current_Sem_Unit
,
4942 Scope_Suppress
=> Scope_Suppress
,
4943 Local_Suppress_Stack_Top
=> Local_Suppress_Stack_Top
,
4944 Version
=> Ada_Version
,
4945 Version_Pragma
=> Ada_Version_Pragma
,
4946 Warnings
=> Save_Warnings
,
4947 SPARK_Mode
=> Saved_SM
,
4948 SPARK_Mode_Pragma
=> Saved_SMP
)),
4949 Inlined_Body
=> True);
4955 Set_Is_Immediately_Visible
(Gen_Comp
, Vis
);
4957 -- Reset Generic_Instance flag so that use clauses can be installed
4958 -- in the proper order. (See Use_One_Package for effect of enclosing
4959 -- instances on processing of use clauses).
4961 for J
in 1 .. N_Instances
loop
4962 Set_Is_Generic_Instance
(Instances
(J
), False);
4966 Install_Context
(Curr_Comp
, Chain
=> False);
4968 if Present
(Curr_Scope
)
4969 and then Is_Child_Unit
(Curr_Scope
)
4971 Push_Scope
(Curr_Scope
);
4972 Set_Is_Immediately_Visible
(Curr_Scope
);
4974 -- Finally, restore inner scopes as well
4976 for J
in reverse 1 .. Num_Inner
loop
4977 Push_Scope
(Inner_Scopes
(J
));
4981 Restore_Scope_Stack
(List
, Handle_Use
=> False);
4983 if Present
(Curr_Scope
)
4985 (In_Private_Part
(Curr_Scope
)
4986 or else In_Package_Body
(Curr_Scope
))
4988 -- Install private declaration of ancestor units, which are
4989 -- currently available. Restore_Scope_Stack and Install_Context
4990 -- only install the visible part of parents.
4995 Par
:= Scope
(Curr_Scope
);
4996 while (Present
(Par
)) and then Par
/= Standard_Standard
loop
4997 Install_Private_Declarations
(Par
);
5004 -- Restore use clauses. For a child unit, use clauses in the parents
5005 -- are restored when installing the context, so only those in inner
5006 -- scopes (and those local to the child unit itself) need to be
5007 -- installed explicitly.
5009 if Is_Child_Unit
(Curr_Unit
) and then Removed
then
5010 for J
in reverse 1 .. Num_Inner
+ 1 loop
5011 Scope_Stack
.Table
(Scope_Stack
.Last
- J
+ 1).First_Use_Clause
:=
5013 Install_Use_Clauses
(Use_Clauses
(J
));
5017 for J
in reverse 1 .. Num_Scopes
loop
5018 Scope_Stack
.Table
(Scope_Stack
.Last
- J
+ 1).First_Use_Clause
:=
5020 Install_Use_Clauses
(Use_Clauses
(J
));
5024 -- Restore status of instances. If one of them is a body, make its
5025 -- local entities visible again.
5032 for J
in 1 .. N_Instances
loop
5033 Inst
:= Instances
(J
);
5034 Set_Is_Generic_Instance
(Inst
, True);
5036 if In_Package_Body
(Inst
)
5037 or else Ekind_In
(S
, E_Procedure
, E_Function
)
5039 E
:= First_Entity
(Instances
(J
));
5040 while Present
(E
) loop
5041 Set_Is_Immediately_Visible
(E
);
5048 -- If generic unit is in current unit, current context is correct. Note
5049 -- that the context is guaranteed to carry the correct SPARK_Mode as no
5050 -- enclosing scopes were removed.
5053 Instantiate_Package_Body
5056 Act_Decl
=> Act_Decl
,
5057 Expander_Status
=> Expander_Active
,
5058 Current_Sem_Unit
=> Current_Sem_Unit
,
5059 Scope_Suppress
=> Scope_Suppress
,
5060 Local_Suppress_Stack_Top
=> Local_Suppress_Stack_Top
,
5061 Version
=> Ada_Version
,
5062 Version_Pragma
=> Ada_Version_Pragma
,
5063 Warnings
=> Save_Warnings
,
5064 SPARK_Mode
=> SPARK_Mode
,
5065 SPARK_Mode_Pragma
=> SPARK_Mode_Pragma
)),
5066 Inlined_Body
=> True);
5068 end Inline_Instance_Body
;
5070 -------------------------------------
5071 -- Analyze_Procedure_Instantiation --
5072 -------------------------------------
5074 procedure Analyze_Procedure_Instantiation
(N
: Node_Id
) is
5076 Analyze_Subprogram_Instantiation
(N
, E_Procedure
);
5077 end Analyze_Procedure_Instantiation
;
5079 -----------------------------------
5080 -- Need_Subprogram_Instance_Body --
5081 -----------------------------------
5083 function Need_Subprogram_Instance_Body
5085 Subp
: Entity_Id
) return Boolean
5087 function Is_Inlined_Or_Child_Of_Inlined
(E
: Entity_Id
) return Boolean;
5088 -- Return True if E is an inlined subprogram, an inlined renaming or a
5089 -- subprogram nested in an inlined subprogram. The inlining machinery
5090 -- totally disregards nested subprograms since it considers that they
5091 -- will always be compiled if the parent is (see Inline.Is_Nested).
5093 ------------------------------------
5094 -- Is_Inlined_Or_Child_Of_Inlined --
5095 ------------------------------------
5097 function Is_Inlined_Or_Child_Of_Inlined
(E
: Entity_Id
) return Boolean is
5101 if Is_Inlined
(E
) or else Is_Inlined
(Alias
(E
)) then
5106 while Scop
/= Standard_Standard
loop
5107 if Ekind
(Scop
) in Subprogram_Kind
and then Is_Inlined
(Scop
) then
5111 Scop
:= Scope
(Scop
);
5115 end Is_Inlined_Or_Child_Of_Inlined
;
5118 -- Must be in the main unit or inlined (or child of inlined)
5120 if (Is_In_Main_Unit
(N
) or else Is_Inlined_Or_Child_Of_Inlined
(Subp
))
5122 -- Must be generating code or analyzing code in ASIS/GNATprove mode
5124 and then (Operating_Mode
= Generate_Code
5125 or else (Operating_Mode
= Check_Semantics
5126 and then (ASIS_Mode
or GNATprove_Mode
)))
5128 -- The body is needed when generating code (full expansion), in ASIS
5129 -- mode for other tools, and in GNATprove mode (special expansion) for
5130 -- formal verification of the body itself.
5132 and then (Expander_Active
or ASIS_Mode
or GNATprove_Mode
)
5134 -- No point in inlining if ABE is inevitable
5136 and then not Is_Known_Guaranteed_ABE
(N
)
5138 -- Or if subprogram is eliminated
5140 and then not Is_Eliminated
(Subp
)
5142 Add_Pending_Instantiation
(N
, Unit_Declaration_Node
(Subp
));
5145 -- Here if not inlined, or we ignore the inlining
5150 end Need_Subprogram_Instance_Body
;
5152 --------------------------------------
5153 -- Analyze_Subprogram_Instantiation --
5154 --------------------------------------
5156 -- WARNING: This routine manages Ghost and SPARK regions. Return statements
5157 -- must be replaced by gotos which jump to the end of the routine in order
5158 -- to restore the Ghost and SPARK modes.
5160 procedure Analyze_Subprogram_Instantiation
5164 Loc
: constant Source_Ptr
:= Sloc
(N
);
5165 Gen_Id
: constant Node_Id
:= Name
(N
);
5166 Errs
: constant Nat
:= Serious_Errors_Detected
;
5168 Anon_Id
: constant Entity_Id
:=
5169 Make_Defining_Identifier
(Sloc
(Defining_Entity
(N
)),
5170 Chars
=> New_External_Name
5171 (Chars
(Defining_Entity
(N
)), 'R'));
5173 Act_Decl_Id
: Entity_Id
:= Empty
; -- init to avoid warning
5178 Env_Installed
: Boolean := False;
5179 Gen_Unit
: Entity_Id
;
5181 Pack_Id
: Entity_Id
;
5182 Parent_Installed
: Boolean := False;
5184 Renaming_List
: List_Id
;
5185 -- The list of declarations that link formals and actuals of the
5186 -- instance. These are subtype declarations for formal types, and
5187 -- renaming declarations for other formals. The subprogram declaration
5188 -- for the instance is then appended to the list, and the last item on
5189 -- the list is the renaming declaration for the instance.
5191 procedure Analyze_Instance_And_Renamings
;
5192 -- The instance must be analyzed in a context that includes the mappings
5193 -- of generic parameters into actuals. We create a package declaration
5194 -- for this purpose, and a subprogram with an internal name within the
5195 -- package. The subprogram instance is simply an alias for the internal
5196 -- subprogram, declared in the current scope.
5198 procedure Build_Subprogram_Renaming
;
5199 -- If the subprogram is recursive, there are occurrences of the name of
5200 -- the generic within the body, which must resolve to the current
5201 -- instance. We add a renaming declaration after the declaration, which
5202 -- is available in the instance body, as well as in the analysis of
5203 -- aspects that appear in the generic. This renaming declaration is
5204 -- inserted after the instance declaration which it renames.
5206 ------------------------------------
5207 -- Analyze_Instance_And_Renamings --
5208 ------------------------------------
5210 procedure Analyze_Instance_And_Renamings
is
5211 Def_Ent
: constant Entity_Id
:= Defining_Entity
(N
);
5212 Pack_Decl
: Node_Id
;
5215 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
5217 -- For the case of a compilation unit, the container package has
5218 -- the same name as the instantiation, to insure that the binder
5219 -- calls the elaboration procedure with the right name. Copy the
5220 -- entity of the instance, which may have compilation level flags
5221 -- (e.g. Is_Child_Unit) set.
5223 Pack_Id
:= New_Copy
(Def_Ent
);
5226 -- Otherwise we use the name of the instantiation concatenated
5227 -- with its source position to ensure uniqueness if there are
5228 -- several instantiations with the same name.
5231 Make_Defining_Identifier
(Loc
,
5232 Chars
=> New_External_Name
5233 (Related_Id
=> Chars
(Def_Ent
),
5235 Suffix_Index
=> Source_Offset
(Sloc
(Def_Ent
))));
5239 Make_Package_Declaration
(Loc
,
5240 Specification
=> Make_Package_Specification
(Loc
,
5241 Defining_Unit_Name
=> Pack_Id
,
5242 Visible_Declarations
=> Renaming_List
,
5243 End_Label
=> Empty
));
5245 Set_Instance_Spec
(N
, Pack_Decl
);
5246 Set_Is_Generic_Instance
(Pack_Id
);
5247 Set_Debug_Info_Needed
(Pack_Id
);
5249 -- Case of not a compilation unit
5251 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
5252 Mark_Rewrite_Insertion
(Pack_Decl
);
5253 Insert_Before
(N
, Pack_Decl
);
5254 Set_Has_Completion
(Pack_Id
);
5256 -- Case of an instantiation that is a compilation unit
5258 -- Place declaration on current node so context is complete for
5259 -- analysis (including nested instantiations), and for use in a
5260 -- context_clause (see Analyze_With_Clause).
5263 Set_Unit
(Parent
(N
), Pack_Decl
);
5264 Set_Parent_Spec
(Pack_Decl
, Parent_Spec
(N
));
5267 Analyze
(Pack_Decl
);
5268 Check_Formal_Packages
(Pack_Id
);
5269 Set_Is_Generic_Instance
(Pack_Id
, False);
5271 -- Why do we clear Is_Generic_Instance??? We set it 20 lines
5274 -- Body of the enclosing package is supplied when instantiating the
5275 -- subprogram body, after semantic analysis is completed.
5277 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
5279 -- Remove package itself from visibility, so it does not
5280 -- conflict with subprogram.
5282 Set_Name_Entity_Id
(Chars
(Pack_Id
), Homonym
(Pack_Id
));
5284 -- Set name and scope of internal subprogram so that the proper
5285 -- external name will be generated. The proper scope is the scope
5286 -- of the wrapper package. We need to generate debugging info for
5287 -- the internal subprogram, so set flag accordingly.
5289 Set_Chars
(Anon_Id
, Chars
(Defining_Entity
(N
)));
5290 Set_Scope
(Anon_Id
, Scope
(Pack_Id
));
5292 -- Mark wrapper package as referenced, to avoid spurious warnings
5293 -- if the instantiation appears in various with_ clauses of
5294 -- subunits of the main unit.
5296 Set_Referenced
(Pack_Id
);
5299 Set_Is_Generic_Instance
(Anon_Id
);
5300 Set_Debug_Info_Needed
(Anon_Id
);
5301 Act_Decl_Id
:= New_Copy
(Anon_Id
);
5303 Set_Parent
(Act_Decl_Id
, Parent
(Anon_Id
));
5304 Set_Chars
(Act_Decl_Id
, Chars
(Defining_Entity
(N
)));
5305 Set_Sloc
(Act_Decl_Id
, Sloc
(Defining_Entity
(N
)));
5307 -- Subprogram instance comes from source only if generic does
5309 Set_Comes_From_Source
(Act_Decl_Id
, Comes_From_Source
(Gen_Unit
));
5311 -- If the instance is a child unit, mark the Id accordingly. Mark
5312 -- the anonymous entity as well, which is the real subprogram and
5313 -- which is used when the instance appears in a context clause.
5314 -- Similarly, propagate the Is_Eliminated flag to handle properly
5315 -- nested eliminated subprograms.
5317 Set_Is_Child_Unit
(Act_Decl_Id
, Is_Child_Unit
(Defining_Entity
(N
)));
5318 Set_Is_Child_Unit
(Anon_Id
, Is_Child_Unit
(Defining_Entity
(N
)));
5319 New_Overloaded_Entity
(Act_Decl_Id
);
5320 Check_Eliminated
(Act_Decl_Id
);
5321 Set_Is_Eliminated
(Anon_Id
, Is_Eliminated
(Act_Decl_Id
));
5323 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
5325 -- In compilation unit case, kill elaboration checks on the
5326 -- instantiation, since they are never needed - the body is
5327 -- instantiated at the same point as the spec.
5329 if Legacy_Elaboration_Checks
then
5330 Set_Kill_Elaboration_Checks
(Act_Decl_Id
);
5331 Set_Suppress_Elaboration_Warnings
(Act_Decl_Id
);
5334 Set_Is_Compilation_Unit
(Anon_Id
);
5335 Set_Cunit_Entity
(Current_Sem_Unit
, Pack_Id
);
5338 -- The instance is not a freezing point for the new subprogram.
5339 -- The anonymous subprogram may have a freeze node, created for
5340 -- some delayed aspects. This freeze node must not be inherited
5341 -- by the visible subprogram entity.
5343 Set_Is_Frozen
(Act_Decl_Id
, False);
5344 Set_Freeze_Node
(Act_Decl_Id
, Empty
);
5346 if Nkind
(Defining_Entity
(N
)) = N_Defining_Operator_Symbol
then
5347 Valid_Operator_Definition
(Act_Decl_Id
);
5350 Set_Alias
(Act_Decl_Id
, Anon_Id
);
5351 Set_Has_Completion
(Act_Decl_Id
);
5352 Set_Related_Instance
(Pack_Id
, Act_Decl_Id
);
5354 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
5355 Set_Body_Required
(Parent
(N
), False);
5357 end Analyze_Instance_And_Renamings
;
5359 -------------------------------
5360 -- Build_Subprogram_Renaming --
5361 -------------------------------
5363 procedure Build_Subprogram_Renaming
is
5364 Renaming_Decl
: Node_Id
;
5365 Unit_Renaming
: Node_Id
;
5369 Make_Subprogram_Renaming_Declaration
(Loc
,
5372 (Specification
(Original_Node
(Gen_Decl
)),
5374 Instantiating
=> True),
5375 Name
=> New_Occurrence_Of
(Anon_Id
, Loc
));
5377 -- The generic may be a a child unit. The renaming needs an
5378 -- identifier with the proper name.
5380 Set_Defining_Unit_Name
(Specification
(Unit_Renaming
),
5381 Make_Defining_Identifier
(Loc
, Chars
(Gen_Unit
)));
5383 -- If there is a formal subprogram with the same name as the unit
5384 -- itself, do not add this renaming declaration, to prevent
5385 -- ambiguities when there is a call with that name in the body.
5386 -- This is a partial and ugly fix for one ACATS test. ???
5388 Renaming_Decl
:= First
(Renaming_List
);
5389 while Present
(Renaming_Decl
) loop
5390 if Nkind
(Renaming_Decl
) = N_Subprogram_Renaming_Declaration
5392 Chars
(Defining_Entity
(Renaming_Decl
)) = Chars
(Gen_Unit
)
5397 Next
(Renaming_Decl
);
5400 if No
(Renaming_Decl
) then
5401 Append
(Unit_Renaming
, Renaming_List
);
5403 end Build_Subprogram_Renaming
;
5407 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
5408 Saved_ISMP
: constant Boolean :=
5409 Ignore_SPARK_Mode_Pragmas_In_Instance
;
5410 Saved_SM
: constant SPARK_Mode_Type
:= SPARK_Mode
;
5411 Saved_SMP
: constant Node_Id
:= SPARK_Mode_Pragma
;
5412 -- Save the Ghost and SPARK mode-related data to restore on exit
5414 Vis_Prims_List
: Elist_Id
:= No_Elist
;
5415 -- List of primitives made temporarily visible in the instantiation
5416 -- to match the visibility of the formal type
5418 -- Start of processing for Analyze_Subprogram_Instantiation
5421 -- Preserve relevant elaboration-related attributes of the context which
5422 -- are no longer available or very expensive to recompute once analysis,
5423 -- resolution, and expansion are over.
5425 Mark_Elaboration_Attributes
5432 Check_SPARK_05_Restriction
("generic is not allowed", N
);
5434 -- Very first thing: check for special Text_IO unit in case we are
5435 -- instantiating one of the children of [[Wide_]Wide_]Text_IO. Of course
5436 -- such an instantiation is bogus (these are packages, not subprograms),
5437 -- but we get a better error message if we do this.
5439 Check_Text_IO_Special_Unit
(Gen_Id
);
5441 -- Make node global for error reporting
5443 Instantiation_Node
:= N
;
5445 -- For package instantiations we turn off style checks, because they
5446 -- will have been emitted in the generic. For subprogram instantiations
5447 -- we want to apply at least the check on overriding indicators so we
5448 -- do not modify the style check status.
5450 -- The renaming declarations for the actuals do not come from source and
5451 -- will not generate spurious warnings.
5453 Preanalyze_Actuals
(N
);
5456 Env_Installed
:= True;
5457 Check_Generic_Child_Unit
(Gen_Id
, Parent_Installed
);
5458 Gen_Unit
:= Entity
(Gen_Id
);
5460 -- A subprogram instantiation is Ghost when it is subject to pragma
5461 -- Ghost or the generic template is Ghost. Set the mode now to ensure
5462 -- that any nodes generated during analysis and expansion are marked as
5465 Mark_And_Set_Ghost_Instantiation
(N
, Gen_Unit
);
5467 Generate_Reference
(Gen_Unit
, Gen_Id
);
5469 if Nkind
(Gen_Id
) = N_Identifier
5470 and then Chars
(Gen_Unit
) = Chars
(Defining_Entity
(N
))
5473 ("& is hidden within declaration of instance", Gen_Id
, Gen_Unit
);
5476 if Etype
(Gen_Unit
) = Any_Type
then
5481 -- Verify that it is a generic subprogram of the right kind, and that
5482 -- it does not lead to a circular instantiation.
5484 if K
= E_Procedure
and then Ekind
(Gen_Unit
) /= E_Generic_Procedure
then
5486 ("& is not the name of a generic procedure", Gen_Id
, Gen_Unit
);
5488 elsif K
= E_Function
and then Ekind
(Gen_Unit
) /= E_Generic_Function
then
5490 ("& is not the name of a generic function", Gen_Id
, Gen_Unit
);
5492 elsif In_Open_Scopes
(Gen_Unit
) then
5493 Error_Msg_NE
("instantiation of & within itself", N
, Gen_Unit
);
5496 Set_Entity
(Gen_Id
, Gen_Unit
);
5497 Set_Is_Instantiated
(Gen_Unit
);
5499 if In_Extended_Main_Source_Unit
(N
) then
5500 Generate_Reference
(Gen_Unit
, N
);
5503 -- If renaming, get original unit
5505 if Present
(Renamed_Object
(Gen_Unit
))
5506 and then Ekind_In
(Renamed_Object
(Gen_Unit
), E_Generic_Procedure
,
5509 Gen_Unit
:= Renamed_Object
(Gen_Unit
);
5510 Set_Is_Instantiated
(Gen_Unit
);
5511 Generate_Reference
(Gen_Unit
, N
);
5514 if Contains_Instance_Of
(Gen_Unit
, Current_Scope
, Gen_Id
) then
5515 Error_Msg_Node_2
:= Current_Scope
;
5517 ("circular Instantiation: & instantiated in &!", N
, Gen_Unit
);
5518 Circularity_Detected
:= True;
5519 Restore_Hidden_Primitives
(Vis_Prims_List
);
5523 Gen_Decl
:= Unit_Declaration_Node
(Gen_Unit
);
5525 -- Initialize renamings map, for error checking
5527 Generic_Renamings
.Set_Last
(0);
5528 Generic_Renamings_HTable
.Reset
;
5530 Create_Instantiation_Source
(N
, Gen_Unit
, S_Adjustment
);
5532 -- Copy original generic tree, to produce text for instantiation
5536 (Original_Node
(Gen_Decl
), Empty
, Instantiating
=> True);
5538 -- Inherit overriding indicator from instance node
5540 Act_Spec
:= Specification
(Act_Tree
);
5541 Set_Must_Override
(Act_Spec
, Must_Override
(N
));
5542 Set_Must_Not_Override
(Act_Spec
, Must_Not_Override
(N
));
5545 Analyze_Associations
5547 Formals
=> Generic_Formal_Declarations
(Act_Tree
),
5548 F_Copy
=> Generic_Formal_Declarations
(Gen_Decl
));
5550 Vis_Prims_List
:= Check_Hidden_Primitives
(Renaming_List
);
5552 -- The subprogram itself cannot contain a nested instance, so the
5553 -- current parent is left empty.
5555 Set_Instance_Env
(Gen_Unit
, Empty
);
5557 -- Build the subprogram declaration, which does not appear in the
5558 -- generic template, and give it a sloc consistent with that of the
5561 Set_Defining_Unit_Name
(Act_Spec
, Anon_Id
);
5562 Set_Generic_Parent
(Act_Spec
, Gen_Unit
);
5564 Make_Subprogram_Declaration
(Sloc
(Act_Spec
),
5565 Specification
=> Act_Spec
);
5567 -- The aspects have been copied previously, but they have to be
5568 -- linked explicitly to the new subprogram declaration. Explicit
5569 -- pre/postconditions on the instance are analyzed below, in a
5572 Move_Aspects
(Act_Tree
, To
=> Act_Decl
);
5573 Set_Categorization_From_Pragmas
(Act_Decl
);
5575 if Parent_Installed
then
5579 Append
(Act_Decl
, Renaming_List
);
5581 -- Contract-related source pragmas that follow a generic subprogram
5582 -- must be instantiated explicitly because they are not part of the
5583 -- subprogram template.
5585 Instantiate_Subprogram_Contract
5586 (Original_Node
(Gen_Decl
), Renaming_List
);
5588 Build_Subprogram_Renaming
;
5590 -- If the context of the instance is subject to SPARK_Mode "off" or
5591 -- the annotation is altogether missing, set the global flag which
5592 -- signals Analyze_Pragma to ignore all SPARK_Mode pragmas within
5593 -- the instance. This should be done prior to analyzing the instance.
5595 if SPARK_Mode
/= On
then
5596 Ignore_SPARK_Mode_Pragmas_In_Instance
:= True;
5599 -- If the context of an instance is not subject to SPARK_Mode "off",
5600 -- and the generic spec is subject to an explicit SPARK_Mode pragma,
5601 -- the latter should be the one applicable to the instance.
5603 if not Ignore_SPARK_Mode_Pragmas_In_Instance
5604 and then Saved_SM
/= Off
5605 and then Present
(SPARK_Pragma
(Gen_Unit
))
5607 Set_SPARK_Mode
(Gen_Unit
);
5610 Analyze_Instance_And_Renamings
;
5612 -- Restore SPARK_Mode from the context after analysis of the package
5613 -- declaration, so that the SPARK_Mode on the generic spec does not
5614 -- apply to the pending instance for the instance body.
5616 if not Ignore_SPARK_Mode_Pragmas_In_Instance
5617 and then Saved_SM
/= Off
5618 and then Present
(SPARK_Pragma
(Gen_Unit
))
5620 Restore_SPARK_Mode
(Saved_SM
, Saved_SMP
);
5623 -- If the generic is marked Import (Intrinsic), then so is the
5624 -- instance. This indicates that there is no body to instantiate. If
5625 -- generic is marked inline, so it the instance, and the anonymous
5626 -- subprogram it renames. If inlined, or else if inlining is enabled
5627 -- for the compilation, we generate the instance body even if it is
5628 -- not within the main unit.
5630 if Is_Intrinsic_Subprogram
(Gen_Unit
) then
5631 Set_Is_Intrinsic_Subprogram
(Anon_Id
);
5632 Set_Is_Intrinsic_Subprogram
(Act_Decl_Id
);
5634 if Chars
(Gen_Unit
) = Name_Unchecked_Conversion
then
5635 Validate_Unchecked_Conversion
(N
, Act_Decl_Id
);
5639 -- Inherit convention from generic unit. Intrinsic convention, as for
5640 -- an instance of unchecked conversion, is not inherited because an
5641 -- explicit Ada instance has been created.
5643 if Has_Convention_Pragma
(Gen_Unit
)
5644 and then Convention
(Gen_Unit
) /= Convention_Intrinsic
5646 Set_Convention
(Act_Decl_Id
, Convention
(Gen_Unit
));
5647 Set_Is_Exported
(Act_Decl_Id
, Is_Exported
(Gen_Unit
));
5650 Generate_Definition
(Act_Decl_Id
);
5652 -- Inherit all inlining-related flags which apply to the generic in
5653 -- the subprogram and its declaration.
5655 Set_Is_Inlined
(Act_Decl_Id
, Is_Inlined
(Gen_Unit
));
5656 Set_Is_Inlined
(Anon_Id
, Is_Inlined
(Gen_Unit
));
5658 Set_Has_Pragma_Inline
(Act_Decl_Id
, Has_Pragma_Inline
(Gen_Unit
));
5659 Set_Has_Pragma_Inline
(Anon_Id
, Has_Pragma_Inline
(Gen_Unit
));
5661 -- Propagate No_Return if pragma applied to generic unit. This must
5662 -- be done explicitly because pragma does not appear in generic
5663 -- declaration (unlike the aspect case).
5665 if No_Return
(Gen_Unit
) then
5666 Set_No_Return
(Act_Decl_Id
);
5667 Set_No_Return
(Anon_Id
);
5670 Set_Has_Pragma_Inline_Always
5671 (Act_Decl_Id
, Has_Pragma_Inline_Always
(Gen_Unit
));
5672 Set_Has_Pragma_Inline_Always
5673 (Anon_Id
, Has_Pragma_Inline_Always
(Gen_Unit
));
5675 -- Mark both the instance spec and the anonymous package in case the
5676 -- body is instantiated at a later pass. This preserves the original
5677 -- context in effect for the body.
5679 if SPARK_Mode
/= On
then
5680 Set_Ignore_SPARK_Mode_Pragmas
(Act_Decl_Id
);
5681 Set_Ignore_SPARK_Mode_Pragmas
(Anon_Id
);
5684 if Legacy_Elaboration_Checks
5685 and then not Is_Intrinsic_Subprogram
(Gen_Unit
)
5687 Check_Elab_Instantiation
(N
);
5690 -- Save the scenario for later examination by the ABE Processing
5693 Record_Elaboration_Scenario
(N
);
5695 -- The instantiation results in a guaranteed ABE. Create a completing
5696 -- body for the subprogram declaration because the real body will not
5699 if Is_Known_Guaranteed_ABE
(N
) then
5700 Provide_Completing_Bodies
(Instance_Spec
(N
));
5703 if Is_Dispatching_Operation
(Act_Decl_Id
)
5704 and then Ada_Version
>= Ada_2005
5710 Formal
:= First_Formal
(Act_Decl_Id
);
5711 while Present
(Formal
) loop
5712 if Ekind
(Etype
(Formal
)) = E_Anonymous_Access_Type
5713 and then Is_Controlling_Formal
(Formal
)
5714 and then not Can_Never_Be_Null
(Formal
)
5717 ("access parameter& is controlling,", N
, Formal
);
5719 ("\corresponding parameter of & must be explicitly "
5720 & "null-excluding", N
, Gen_Id
);
5723 Next_Formal
(Formal
);
5728 Check_Hidden_Child_Unit
(N
, Gen_Unit
, Act_Decl_Id
);
5730 Validate_Categorization_Dependency
(N
, Act_Decl_Id
);
5732 if not Is_Intrinsic_Subprogram
(Act_Decl_Id
) then
5733 Inherit_Context
(Gen_Decl
, N
);
5735 Restore_Private_Views
(Pack_Id
, False);
5737 -- If the context requires a full instantiation, mark node for
5738 -- subsequent construction of the body.
5740 if Need_Subprogram_Instance_Body
(N
, Act_Decl_Id
) then
5741 Check_Forward_Instantiation
(Gen_Decl
);
5743 -- The wrapper package is always delayed, because it does not
5744 -- constitute a freeze point, but to insure that the freeze node
5745 -- is placed properly, it is created directly when instantiating
5746 -- the body (otherwise the freeze node might appear to early for
5747 -- nested instantiations). For ASIS purposes, indicate that the
5748 -- wrapper package has replaced the instantiation node.
5750 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
then
5751 Rewrite
(N
, Unit
(Parent
(N
)));
5752 Set_Unit
(Parent
(N
), N
);
5755 -- Replace instance node for library-level instantiations of
5756 -- intrinsic subprograms, for ASIS use.
5758 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
then
5759 Rewrite
(N
, Unit
(Parent
(N
)));
5760 Set_Unit
(Parent
(N
), N
);
5763 if Parent_Installed
then
5767 Restore_Hidden_Primitives
(Vis_Prims_List
);
5769 Env_Installed
:= False;
5770 Generic_Renamings
.Set_Last
(0);
5771 Generic_Renamings_HTable
.Reset
;
5775 -- Analyze aspects in declaration if no errors appear in the instance.
5777 if Has_Aspects
(N
) and then Serious_Errors_Detected
= Errs
then
5778 Analyze_Aspect_Specifications
(N
, Act_Decl_Id
);
5781 Ignore_SPARK_Mode_Pragmas_In_Instance
:= Saved_ISMP
;
5782 Restore_Ghost_Mode
(Saved_GM
);
5783 Restore_SPARK_Mode
(Saved_SM
, Saved_SMP
);
5786 when Instantiation_Error
=>
5787 if Parent_Installed
then
5791 if Env_Installed
then
5795 Ignore_SPARK_Mode_Pragmas_In_Instance
:= Saved_ISMP
;
5796 Restore_Ghost_Mode
(Saved_GM
);
5797 Restore_SPARK_Mode
(Saved_SM
, Saved_SMP
);
5798 end Analyze_Subprogram_Instantiation
;
5800 -------------------------
5801 -- Get_Associated_Node --
5802 -------------------------
5804 function Get_Associated_Node
(N
: Node_Id
) return Node_Id
is
5808 Assoc
:= Associated_Node
(N
);
5810 if Nkind
(Assoc
) /= Nkind
(N
) then
5813 elsif Nkind_In
(Assoc
, N_Aggregate
, N_Extension_Aggregate
) then
5817 -- If the node is part of an inner generic, it may itself have been
5818 -- remapped into a further generic copy. Associated_Node is otherwise
5819 -- used for the entity of the node, and will be of a different node
5820 -- kind, or else N has been rewritten as a literal or function call.
5822 while Present
(Associated_Node
(Assoc
))
5823 and then Nkind
(Associated_Node
(Assoc
)) = Nkind
(Assoc
)
5825 Assoc
:= Associated_Node
(Assoc
);
5828 -- Follow an additional link in case the final node was rewritten.
5829 -- This can only happen with nested generic units.
5831 if (Nkind
(Assoc
) = N_Identifier
or else Nkind
(Assoc
) in N_Op
)
5832 and then Present
(Associated_Node
(Assoc
))
5833 and then (Nkind_In
(Associated_Node
(Assoc
), N_Function_Call
,
5834 N_Explicit_Dereference
,
5839 Assoc
:= Associated_Node
(Assoc
);
5842 -- An additional special case: an unconstrained type in an object
5843 -- declaration may have been rewritten as a local subtype constrained
5844 -- by the expression in the declaration. We need to recover the
5845 -- original entity, which may be global.
5847 if Present
(Original_Node
(Assoc
))
5848 and then Nkind
(Parent
(N
)) = N_Object_Declaration
5850 Assoc
:= Original_Node
(Assoc
);
5855 end Get_Associated_Node
;
5857 ----------------------------
5858 -- Build_Function_Wrapper --
5859 ----------------------------
5861 function Build_Function_Wrapper
5862 (Formal_Subp
: Entity_Id
;
5863 Actual_Subp
: Entity_Id
) return Node_Id
5865 Loc
: constant Source_Ptr
:= Sloc
(Current_Scope
);
5866 Ret_Type
: constant Entity_Id
:= Get_Instance_Of
(Etype
(Formal_Subp
));
5869 Func_Name
: Node_Id
;
5871 Parm_Type
: Node_Id
;
5872 Profile
: List_Id
:= New_List
;
5879 Func_Name
:= New_Occurrence_Of
(Actual_Subp
, Loc
);
5881 Func
:= Make_Defining_Identifier
(Loc
, Chars
(Formal_Subp
));
5882 Set_Ekind
(Func
, E_Function
);
5883 Set_Is_Generic_Actual_Subprogram
(Func
);
5885 Actuals
:= New_List
;
5886 Profile
:= New_List
;
5888 Act_F
:= First_Formal
(Actual_Subp
);
5889 Form_F
:= First_Formal
(Formal_Subp
);
5890 while Present
(Form_F
) loop
5892 -- Create new formal for profile of wrapper, and add a reference
5893 -- to it in the list of actuals for the enclosing call. The name
5894 -- must be that of the formal in the formal subprogram, because
5895 -- calls to it in the generic body may use named associations.
5897 New_F
:= Make_Defining_Identifier
(Loc
, Chars
(Form_F
));
5900 New_Occurrence_Of
(Get_Instance_Of
(Etype
(Form_F
)), Loc
);
5903 Make_Parameter_Specification
(Loc
,
5904 Defining_Identifier
=> New_F
,
5905 Parameter_Type
=> Parm_Type
));
5907 Append_To
(Actuals
, New_Occurrence_Of
(New_F
, Loc
));
5908 Next_Formal
(Form_F
);
5910 if Present
(Act_F
) then
5911 Next_Formal
(Act_F
);
5916 Make_Function_Specification
(Loc
,
5917 Defining_Unit_Name
=> Func
,
5918 Parameter_Specifications
=> Profile
,
5919 Result_Definition
=> New_Occurrence_Of
(Ret_Type
, Loc
));
5922 Make_Expression_Function
(Loc
,
5923 Specification
=> Spec
,
5925 Make_Function_Call
(Loc
,
5927 Parameter_Associations
=> Actuals
));
5930 end Build_Function_Wrapper
;
5932 ----------------------------
5933 -- Build_Operator_Wrapper --
5934 ----------------------------
5936 function Build_Operator_Wrapper
5937 (Formal_Subp
: Entity_Id
;
5938 Actual_Subp
: Entity_Id
) return Node_Id
5940 Loc
: constant Source_Ptr
:= Sloc
(Current_Scope
);
5941 Ret_Type
: constant Entity_Id
:=
5942 Get_Instance_Of
(Etype
(Formal_Subp
));
5943 Op_Type
: constant Entity_Id
:=
5944 Get_Instance_Of
(Etype
(First_Formal
(Formal_Subp
)));
5945 Is_Binary
: constant Boolean :=
5946 Present
(Next_Formal
(First_Formal
(Formal_Subp
)));
5949 Expr
: Node_Id
:= Empty
;
5957 Op_Name
:= Chars
(Actual_Subp
);
5959 -- Create entities for wrapper function and its formals
5961 F1
:= Make_Temporary
(Loc
, 'A');
5962 F2
:= Make_Temporary
(Loc
, 'B');
5963 L
:= New_Occurrence_Of
(F1
, Loc
);
5964 R
:= New_Occurrence_Of
(F2
, Loc
);
5966 Func
:= Make_Defining_Identifier
(Loc
, Chars
(Formal_Subp
));
5967 Set_Ekind
(Func
, E_Function
);
5968 Set_Is_Generic_Actual_Subprogram
(Func
);
5971 Make_Function_Specification
(Loc
,
5972 Defining_Unit_Name
=> Func
,
5973 Parameter_Specifications
=> New_List
(
5974 Make_Parameter_Specification
(Loc
,
5975 Defining_Identifier
=> F1
,
5976 Parameter_Type
=> New_Occurrence_Of
(Op_Type
, Loc
))),
5977 Result_Definition
=> New_Occurrence_Of
(Ret_Type
, Loc
));
5980 Append_To
(Parameter_Specifications
(Spec
),
5981 Make_Parameter_Specification
(Loc
,
5982 Defining_Identifier
=> F2
,
5983 Parameter_Type
=> New_Occurrence_Of
(Op_Type
, Loc
)));
5986 -- Build expression as a function call, or as an operator node
5987 -- that corresponds to the name of the actual, starting with
5988 -- binary operators.
5990 if Op_Name
not in Any_Operator_Name
then
5992 Make_Function_Call
(Loc
,
5994 New_Occurrence_Of
(Actual_Subp
, Loc
),
5995 Parameter_Associations
=> New_List
(L
));
5998 Append_To
(Parameter_Associations
(Expr
), R
);
6003 elsif Is_Binary
then
6004 if Op_Name
= Name_Op_And
then
6005 Expr
:= Make_Op_And
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
6006 elsif Op_Name
= Name_Op_Or
then
6007 Expr
:= Make_Op_Or
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
6008 elsif Op_Name
= Name_Op_Xor
then
6009 Expr
:= Make_Op_Xor
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
6010 elsif Op_Name
= Name_Op_Eq
then
6011 Expr
:= Make_Op_Eq
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
6012 elsif Op_Name
= Name_Op_Ne
then
6013 Expr
:= Make_Op_Ne
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
6014 elsif Op_Name
= Name_Op_Le
then
6015 Expr
:= Make_Op_Le
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
6016 elsif Op_Name
= Name_Op_Gt
then
6017 Expr
:= Make_Op_Gt
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
6018 elsif Op_Name
= Name_Op_Ge
then
6019 Expr
:= Make_Op_Ge
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
6020 elsif Op_Name
= Name_Op_Lt
then
6021 Expr
:= Make_Op_Lt
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
6022 elsif Op_Name
= Name_Op_Add
then
6023 Expr
:= Make_Op_Add
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
6024 elsif Op_Name
= Name_Op_Subtract
then
6025 Expr
:= Make_Op_Subtract
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
6026 elsif Op_Name
= Name_Op_Concat
then
6027 Expr
:= Make_Op_Concat
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
6028 elsif Op_Name
= Name_Op_Multiply
then
6029 Expr
:= Make_Op_Multiply
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
6030 elsif Op_Name
= Name_Op_Divide
then
6031 Expr
:= Make_Op_Divide
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
6032 elsif Op_Name
= Name_Op_Mod
then
6033 Expr
:= Make_Op_Mod
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
6034 elsif Op_Name
= Name_Op_Rem
then
6035 Expr
:= Make_Op_Rem
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
6036 elsif Op_Name
= Name_Op_Expon
then
6037 Expr
:= Make_Op_Expon
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
6043 if Op_Name
= Name_Op_Add
then
6044 Expr
:= Make_Op_Plus
(Loc
, Right_Opnd
=> L
);
6045 elsif Op_Name
= Name_Op_Subtract
then
6046 Expr
:= Make_Op_Minus
(Loc
, Right_Opnd
=> L
);
6047 elsif Op_Name
= Name_Op_Abs
then
6048 Expr
:= Make_Op_Abs
(Loc
, Right_Opnd
=> L
);
6049 elsif Op_Name
= Name_Op_Not
then
6050 Expr
:= Make_Op_Not
(Loc
, Right_Opnd
=> L
);
6055 Make_Expression_Function
(Loc
,
6056 Specification
=> Spec
,
6057 Expression
=> Expr
);
6060 end Build_Operator_Wrapper
;
6062 -------------------------------------------
6063 -- Build_Instance_Compilation_Unit_Nodes --
6064 -------------------------------------------
6066 procedure Build_Instance_Compilation_Unit_Nodes
6071 Decl_Cunit
: Node_Id
;
6072 Body_Cunit
: Node_Id
;
6074 New_Main
: constant Entity_Id
:= Defining_Entity
(Act_Decl
);
6075 Old_Main
: constant Entity_Id
:= Cunit_Entity
(Main_Unit
);
6078 -- A new compilation unit node is built for the instance declaration
6081 Make_Compilation_Unit
(Sloc
(N
),
6082 Context_Items
=> Empty_List
,
6084 Aux_Decls_Node
=> Make_Compilation_Unit_Aux
(Sloc
(N
)));
6086 Set_Parent_Spec
(Act_Decl
, Parent_Spec
(N
));
6088 -- The new compilation unit is linked to its body, but both share the
6089 -- same file, so we do not set Body_Required on the new unit so as not
6090 -- to create a spurious dependency on a non-existent body in the ali.
6091 -- This simplifies CodePeer unit traversal.
6093 -- We use the original instantiation compilation unit as the resulting
6094 -- compilation unit of the instance, since this is the main unit.
6096 Rewrite
(N
, Act_Body
);
6098 -- Propagate the aspect specifications from the package body template to
6099 -- the instantiated version of the package body.
6101 if Has_Aspects
(Act_Body
) then
6102 Set_Aspect_Specifications
6103 (N
, New_Copy_List_Tree
(Aspect_Specifications
(Act_Body
)));
6106 Body_Cunit
:= Parent
(N
);
6108 -- The two compilation unit nodes are linked by the Library_Unit field
6110 Set_Library_Unit
(Decl_Cunit
, Body_Cunit
);
6111 Set_Library_Unit
(Body_Cunit
, Decl_Cunit
);
6113 -- Preserve the private nature of the package if needed
6115 Set_Private_Present
(Decl_Cunit
, Private_Present
(Body_Cunit
));
6117 -- If the instance is not the main unit, its context, categorization
6118 -- and elaboration entity are not relevant to the compilation.
6120 if Body_Cunit
/= Cunit
(Main_Unit
) then
6121 Make_Instance_Unit
(Body_Cunit
, In_Main
=> False);
6125 -- The context clause items on the instantiation, which are now attached
6126 -- to the body compilation unit (since the body overwrote the original
6127 -- instantiation node), semantically belong on the spec, so copy them
6128 -- there. It's harmless to leave them on the body as well. In fact one
6129 -- could argue that they belong in both places.
6131 Citem
:= First
(Context_Items
(Body_Cunit
));
6132 while Present
(Citem
) loop
6133 Append
(New_Copy
(Citem
), Context_Items
(Decl_Cunit
));
6137 -- Propagate categorization flags on packages, so that they appear in
6138 -- the ali file for the spec of the unit.
6140 if Ekind
(New_Main
) = E_Package
then
6141 Set_Is_Pure
(Old_Main
, Is_Pure
(New_Main
));
6142 Set_Is_Preelaborated
(Old_Main
, Is_Preelaborated
(New_Main
));
6143 Set_Is_Remote_Types
(Old_Main
, Is_Remote_Types
(New_Main
));
6144 Set_Is_Shared_Passive
(Old_Main
, Is_Shared_Passive
(New_Main
));
6145 Set_Is_Remote_Call_Interface
6146 (Old_Main
, Is_Remote_Call_Interface
(New_Main
));
6149 -- Make entry in Units table, so that binder can generate call to
6150 -- elaboration procedure for body, if any.
6152 Make_Instance_Unit
(Body_Cunit
, In_Main
=> True);
6153 Main_Unit_Entity
:= New_Main
;
6154 Set_Cunit_Entity
(Main_Unit
, Main_Unit_Entity
);
6156 -- Build elaboration entity, since the instance may certainly generate
6157 -- elaboration code requiring a flag for protection.
6159 Build_Elaboration_Entity
(Decl_Cunit
, New_Main
);
6160 end Build_Instance_Compilation_Unit_Nodes
;
6162 -----------------------------
6163 -- Check_Access_Definition --
6164 -----------------------------
6166 procedure Check_Access_Definition
(N
: Node_Id
) is
6169 (Ada_Version
>= Ada_2005
and then Present
(Access_Definition
(N
)));
6171 end Check_Access_Definition
;
6173 -----------------------------------
6174 -- Check_Formal_Package_Instance --
6175 -----------------------------------
6177 -- If the formal has specific parameters, they must match those of the
6178 -- actual. Both of them are instances, and the renaming declarations for
6179 -- their formal parameters appear in the same order in both. The analyzed
6180 -- formal has been analyzed in the context of the current instance.
6182 procedure Check_Formal_Package_Instance
6183 (Formal_Pack
: Entity_Id
;
6184 Actual_Pack
: Entity_Id
)
6186 E1
: Entity_Id
:= First_Entity
(Actual_Pack
);
6187 E2
: Entity_Id
:= First_Entity
(Formal_Pack
);
6188 Prev_E1
: Entity_Id
;
6193 procedure Check_Mismatch
(B
: Boolean);
6194 -- Common error routine for mismatch between the parameters of the
6195 -- actual instance and those of the formal package.
6197 function Same_Instantiated_Constant
(E1
, E2
: Entity_Id
) return Boolean;
6198 -- The formal may come from a nested formal package, and the actual may
6199 -- have been constant-folded. To determine whether the two denote the
6200 -- same entity we may have to traverse several definitions to recover
6201 -- the ultimate entity that they refer to.
6203 function Same_Instantiated_Function
(E1
, E2
: Entity_Id
) return Boolean;
6204 -- The formal and the actual must be identical, but if both are
6205 -- given by attributes they end up renaming different generated bodies,
6206 -- and we must verify that the attributes themselves match.
6208 function Same_Instantiated_Variable
(E1
, E2
: Entity_Id
) return Boolean;
6209 -- Similarly, if the formal comes from a nested formal package, the
6210 -- actual may designate the formal through multiple renamings, which
6211 -- have to be followed to determine the original variable in question.
6213 --------------------
6214 -- Check_Mismatch --
6215 --------------------
6217 procedure Check_Mismatch
(B
: Boolean) is
6218 -- A Formal_Type_Declaration for a derived private type is rewritten
6219 -- as a private extension decl. (see Analyze_Formal_Derived_Type),
6220 -- which is why we examine the original node.
6222 Kind
: constant Node_Kind
:= Nkind
(Original_Node
(Parent
(E2
)));
6225 if Kind
= N_Formal_Type_Declaration
then
6228 elsif Nkind_In
(Kind
, N_Formal_Object_Declaration
,
6229 N_Formal_Package_Declaration
)
6230 or else Kind
in N_Formal_Subprogram_Declaration
6234 -- Ada 2012: If both formal and actual are incomplete types they
6237 elsif Is_Incomplete_Type
(E1
) and then Is_Incomplete_Type
(E2
) then
6242 ("actual for & in actual instance does not match formal",
6243 Parent
(Actual_Pack
), E1
);
6247 --------------------------------
6248 -- Same_Instantiated_Constant --
6249 --------------------------------
6251 function Same_Instantiated_Constant
6252 (E1
, E2
: Entity_Id
) return Boolean
6258 while Present
(Ent
) loop
6262 elsif Ekind
(Ent
) /= E_Constant
then
6265 elsif Is_Entity_Name
(Constant_Value
(Ent
)) then
6266 if Entity
(Constant_Value
(Ent
)) = E1
then
6269 Ent
:= Entity
(Constant_Value
(Ent
));
6272 -- The actual may be a constant that has been folded. Recover
6275 elsif Is_Entity_Name
(Original_Node
(Constant_Value
(Ent
))) then
6276 Ent
:= Entity
(Original_Node
(Constant_Value
(Ent
)));
6284 end Same_Instantiated_Constant
;
6286 --------------------------------
6287 -- Same_Instantiated_Function --
6288 --------------------------------
6290 function Same_Instantiated_Function
6291 (E1
, E2
: Entity_Id
) return Boolean
6295 if Alias
(E1
) = Alias
(E2
) then
6298 elsif Present
(Alias
(E2
)) then
6299 U1
:= Original_Node
(Unit_Declaration_Node
(E1
));
6300 U2
:= Original_Node
(Unit_Declaration_Node
(Alias
(E2
)));
6302 return Nkind
(U1
) = N_Subprogram_Renaming_Declaration
6303 and then Nkind
(Name
(U1
)) = N_Attribute_Reference
6305 and then Nkind
(U2
) = N_Subprogram_Renaming_Declaration
6306 and then Nkind
(Name
(U2
)) = N_Attribute_Reference
6309 Attribute_Name
(Name
(U1
)) = Attribute_Name
(Name
(U2
));
6313 end Same_Instantiated_Function
;
6315 --------------------------------
6316 -- Same_Instantiated_Variable --
6317 --------------------------------
6319 function Same_Instantiated_Variable
6320 (E1
, E2
: Entity_Id
) return Boolean
6322 function Original_Entity
(E
: Entity_Id
) return Entity_Id
;
6323 -- Follow chain of renamings to the ultimate ancestor
6325 ---------------------
6326 -- Original_Entity --
6327 ---------------------
6329 function Original_Entity
(E
: Entity_Id
) return Entity_Id
is
6334 while Nkind
(Parent
(Orig
)) = N_Object_Renaming_Declaration
6335 and then Present
(Renamed_Object
(Orig
))
6336 and then Is_Entity_Name
(Renamed_Object
(Orig
))
6338 Orig
:= Entity
(Renamed_Object
(Orig
));
6342 end Original_Entity
;
6344 -- Start of processing for Same_Instantiated_Variable
6347 return Ekind
(E1
) = Ekind
(E2
)
6348 and then Original_Entity
(E1
) = Original_Entity
(E2
);
6349 end Same_Instantiated_Variable
;
6351 -- Start of processing for Check_Formal_Package_Instance
6355 while Present
(E1
) and then Present
(E2
) loop
6356 exit when Ekind
(E1
) = E_Package
6357 and then Renamed_Entity
(E1
) = Renamed_Entity
(Actual_Pack
);
6359 -- If the formal is the renaming of the formal package, this
6360 -- is the end of its formal part, which may occur before the
6361 -- end of the formal part in the actual in the presence of
6362 -- defaulted parameters in the formal package.
6364 exit when Nkind
(Parent
(E2
)) = N_Package_Renaming_Declaration
6365 and then Renamed_Entity
(E2
) = Scope
(E2
);
6367 -- The analysis of the actual may generate additional internal
6368 -- entities. If the formal is defaulted, there is no corresponding
6369 -- analysis and the internal entities must be skipped, until we
6370 -- find corresponding entities again.
6372 if Comes_From_Source
(E2
)
6373 and then not Comes_From_Source
(E1
)
6374 and then Chars
(E1
) /= Chars
(E2
)
6376 while Present
(E1
) and then Chars
(E1
) /= Chars
(E2
) loop
6384 -- Entities may be declared without full declaration, such as
6385 -- itypes and predefined operators (concatenation for arrays, eg).
6386 -- Skip it and keep the formal entity to find a later match for it.
6388 elsif No
(Parent
(E2
)) and then Ekind
(E1
) /= Ekind
(E2
) then
6392 -- If the formal entity comes from a formal declaration, it was
6393 -- defaulted in the formal package, and no check is needed on it.
6395 elsif Nkind_In
(Original_Node
(Parent
(E2
)),
6396 N_Formal_Object_Declaration
,
6397 N_Formal_Type_Declaration
)
6399 -- If the formal is a tagged type the corresponding class-wide
6400 -- type has been generated as well, and it must be skipped.
6402 if Is_Type
(E2
) and then Is_Tagged_Type
(E2
) then
6408 -- Ditto for defaulted formal subprograms.
6410 elsif Is_Overloadable
(E1
)
6411 and then Nkind
(Unit_Declaration_Node
(E2
)) in
6412 N_Formal_Subprogram_Declaration
6416 elsif Is_Type
(E1
) then
6418 -- Subtypes must statically match. E1, E2 are the local entities
6419 -- that are subtypes of the actuals. Itypes generated for other
6420 -- parameters need not be checked, the check will be performed
6421 -- on the parameters themselves.
6423 -- If E2 is a formal type declaration, it is a defaulted parameter
6424 -- and needs no checking.
6426 if not Is_Itype
(E1
) and then not Is_Itype
(E2
) then
6429 or else Etype
(E1
) /= Etype
(E2
)
6430 or else not Subtypes_Statically_Match
(E1
, E2
));
6433 elsif Ekind
(E1
) = E_Constant
then
6435 -- IN parameters must denote the same static value, or the same
6436 -- constant, or the literal null.
6438 Expr1
:= Expression
(Parent
(E1
));
6440 if Ekind
(E2
) /= E_Constant
then
6441 Check_Mismatch
(True);
6444 Expr2
:= Expression
(Parent
(E2
));
6447 if Is_OK_Static_Expression
(Expr1
) then
6448 if not Is_OK_Static_Expression
(Expr2
) then
6449 Check_Mismatch
(True);
6451 elsif Is_Discrete_Type
(Etype
(E1
)) then
6453 V1
: constant Uint
:= Expr_Value
(Expr1
);
6454 V2
: constant Uint
:= Expr_Value
(Expr2
);
6456 Check_Mismatch
(V1
/= V2
);
6459 elsif Is_Real_Type
(Etype
(E1
)) then
6461 V1
: constant Ureal
:= Expr_Value_R
(Expr1
);
6462 V2
: constant Ureal
:= Expr_Value_R
(Expr2
);
6464 Check_Mismatch
(V1
/= V2
);
6467 elsif Is_String_Type
(Etype
(E1
))
6468 and then Nkind
(Expr1
) = N_String_Literal
6470 if Nkind
(Expr2
) /= N_String_Literal
then
6471 Check_Mismatch
(True);
6474 (not String_Equal
(Strval
(Expr1
), Strval
(Expr2
)));
6478 elsif Is_Entity_Name
(Expr1
) then
6479 if Is_Entity_Name
(Expr2
) then
6480 if Entity
(Expr1
) = Entity
(Expr2
) then
6484 (not Same_Instantiated_Constant
6485 (Entity
(Expr1
), Entity
(Expr2
)));
6489 Check_Mismatch
(True);
6492 elsif Is_Entity_Name
(Original_Node
(Expr1
))
6493 and then Is_Entity_Name
(Expr2
)
6494 and then Same_Instantiated_Constant
6495 (Entity
(Original_Node
(Expr1
)), Entity
(Expr2
))
6499 elsif Nkind
(Expr1
) = N_Null
then
6500 Check_Mismatch
(Nkind
(Expr1
) /= N_Null
);
6503 Check_Mismatch
(True);
6506 elsif Ekind
(E1
) = E_Variable
then
6507 Check_Mismatch
(not Same_Instantiated_Variable
(E1
, E2
));
6509 elsif Ekind
(E1
) = E_Package
then
6511 (Ekind
(E1
) /= Ekind
(E2
)
6512 or else (Present
(Renamed_Object
(E2
))
6513 and then Renamed_Object
(E1
) /=
6514 Renamed_Object
(E2
)));
6516 elsif Is_Overloadable
(E1
) then
6517 -- Verify that the actual subprograms match. Note that actuals
6518 -- that are attributes are rewritten as subprograms. If the
6519 -- subprogram in the formal package is defaulted, no check is
6520 -- needed. Note that this can only happen in Ada 2005 when the
6521 -- formal package can be partially parameterized.
6523 if Nkind
(Unit_Declaration_Node
(E1
)) =
6524 N_Subprogram_Renaming_Declaration
6525 and then From_Default
(Unit_Declaration_Node
(E1
))
6529 -- If the formal package has an "others" box association that
6530 -- covers this formal, there is no need for a check either.
6532 elsif Nkind
(Unit_Declaration_Node
(E2
)) in
6533 N_Formal_Subprogram_Declaration
6534 and then Box_Present
(Unit_Declaration_Node
(E2
))
6538 -- No check needed if subprogram is a defaulted null procedure
6540 elsif No
(Alias
(E2
))
6541 and then Ekind
(E2
) = E_Procedure
6543 Null_Present
(Specification
(Unit_Declaration_Node
(E2
)))
6547 -- Otherwise the actual in the formal and the actual in the
6548 -- instantiation of the formal must match, up to renamings.
6552 (Ekind
(E2
) /= Ekind
(E1
)
6553 or else not Same_Instantiated_Function
(E1
, E2
));
6557 raise Program_Error
;
6565 end Check_Formal_Package_Instance
;
6567 ---------------------------
6568 -- Check_Formal_Packages --
6569 ---------------------------
6571 procedure Check_Formal_Packages
(P_Id
: Entity_Id
) is
6573 Formal_P
: Entity_Id
;
6574 Formal_Decl
: Node_Id
;
6577 -- Iterate through the declarations in the instance, looking for package
6578 -- renaming declarations that denote instances of formal packages. Stop
6579 -- when we find the renaming of the current package itself. The
6580 -- declaration for a formal package without a box is followed by an
6581 -- internal entity that repeats the instantiation.
6583 E
:= First_Entity
(P_Id
);
6584 while Present
(E
) loop
6585 if Ekind
(E
) = E_Package
then
6586 if Renamed_Object
(E
) = P_Id
then
6589 elsif Nkind
(Parent
(E
)) /= N_Package_Renaming_Declaration
then
6593 Formal_Decl
:= Parent
(Associated_Formal_Package
(E
));
6595 -- Nothing to check if the formal has a box or an others_clause
6596 -- (necessarily with a box).
6598 if Box_Present
(Formal_Decl
) then
6601 elsif Nkind
(First
(Generic_Associations
(Formal_Decl
))) =
6604 -- The internal validating package was generated but formal
6605 -- and instance are known to be compatible.
6607 Formal_P
:= Next_Entity
(E
);
6608 Remove
(Unit_Declaration_Node
(Formal_P
));
6611 Formal_P
:= Next_Entity
(E
);
6613 -- If the instance is within an enclosing instance body
6614 -- there is no need to verify the legality of current formal
6615 -- packages because they were legal in the generic body.
6616 -- This optimization may be applicable elsewhere, and it
6617 -- also removes spurious errors that may arise with
6618 -- on-the-fly inlining and confusion between private and
6621 if not In_Instance_Body
then
6622 Check_Formal_Package_Instance
(Formal_P
, E
);
6625 -- After checking, remove the internal validating package.
6626 -- It is only needed for semantic checks, and as it may
6627 -- contain generic formal declarations it should not reach
6630 Remove
(Unit_Declaration_Node
(Formal_P
));
6637 end Check_Formal_Packages
;
6639 ---------------------------------
6640 -- Check_Forward_Instantiation --
6641 ---------------------------------
6643 procedure Check_Forward_Instantiation
(Decl
: Node_Id
) is
6645 Gen_Comp
: Entity_Id
:= Cunit_Entity
(Get_Source_Unit
(Decl
));
6648 -- The instantiation appears before the generic body if we are in the
6649 -- scope of the unit containing the generic, either in its spec or in
6650 -- the package body, and before the generic body.
6652 if Ekind
(Gen_Comp
) = E_Package_Body
then
6653 Gen_Comp
:= Spec_Entity
(Gen_Comp
);
6656 if In_Open_Scopes
(Gen_Comp
)
6657 and then No
(Corresponding_Body
(Decl
))
6662 and then not Is_Compilation_Unit
(S
)
6663 and then not Is_Child_Unit
(S
)
6665 if Ekind
(S
) = E_Package
then
6666 Set_Has_Forward_Instantiation
(S
);
6672 end Check_Forward_Instantiation
;
6674 ---------------------------
6675 -- Check_Generic_Actuals --
6676 ---------------------------
6678 -- The visibility of the actuals may be different between the point of
6679 -- generic instantiation and the instantiation of the body.
6681 procedure Check_Generic_Actuals
6682 (Instance
: Entity_Id
;
6683 Is_Formal_Box
: Boolean)
6688 function Denotes_Previous_Actual
(Typ
: Entity_Id
) return Boolean;
6689 -- For a formal that is an array type, the component type is often a
6690 -- previous formal in the same unit. The privacy status of the component
6691 -- type will have been examined earlier in the traversal of the
6692 -- corresponding actuals, and this status should not be modified for
6693 -- the array (sub)type itself. However, if the base type of the array
6694 -- (sub)type is private, its full view must be restored in the body to
6695 -- be consistent with subsequent index subtypes, etc.
6697 -- To detect this case we have to rescan the list of formals, which is
6698 -- usually short enough to ignore the resulting inefficiency.
6700 -----------------------------
6701 -- Denotes_Previous_Actual --
6702 -----------------------------
6704 function Denotes_Previous_Actual
(Typ
: Entity_Id
) return Boolean is
6708 Prev
:= First_Entity
(Instance
);
6709 while Present
(Prev
) loop
6711 and then Nkind
(Parent
(Prev
)) = N_Subtype_Declaration
6712 and then Is_Entity_Name
(Subtype_Indication
(Parent
(Prev
)))
6713 and then Entity
(Subtype_Indication
(Parent
(Prev
))) = Typ
6726 end Denotes_Previous_Actual
;
6728 -- Start of processing for Check_Generic_Actuals
6731 E
:= First_Entity
(Instance
);
6732 while Present
(E
) loop
6734 and then Nkind
(Parent
(E
)) = N_Subtype_Declaration
6735 and then Scope
(Etype
(E
)) /= Instance
6736 and then Is_Entity_Name
(Subtype_Indication
(Parent
(E
)))
6738 if Is_Array_Type
(E
)
6739 and then not Is_Private_Type
(Etype
(E
))
6740 and then Denotes_Previous_Actual
(Component_Type
(E
))
6744 Check_Private_View
(Subtype_Indication
(Parent
(E
)));
6747 Set_Is_Generic_Actual_Type
(E
, True);
6748 Set_Is_Hidden
(E
, False);
6749 Set_Is_Potentially_Use_Visible
(E
, In_Use
(Instance
));
6751 -- We constructed the generic actual type as a subtype of the
6752 -- supplied type. This means that it normally would not inherit
6753 -- subtype specific attributes of the actual, which is wrong for
6754 -- the generic case.
6756 Astype
:= Ancestor_Subtype
(E
);
6760 -- This can happen when E is an itype that is the full view of
6761 -- a private type completed, e.g. with a constrained array. In
6762 -- that case, use the first subtype, which will carry size
6763 -- information. The base type itself is unconstrained and will
6766 Astype
:= First_Subtype
(E
);
6769 Set_Size_Info
(E
, (Astype
));
6770 Set_RM_Size
(E
, RM_Size
(Astype
));
6771 Set_First_Rep_Item
(E
, First_Rep_Item
(Astype
));
6773 if Is_Discrete_Or_Fixed_Point_Type
(E
) then
6774 Set_RM_Size
(E
, RM_Size
(Astype
));
6776 -- In nested instances, the base type of an access actual may
6777 -- itself be private, and need to be exchanged.
6779 elsif Is_Access_Type
(E
)
6780 and then Is_Private_Type
(Etype
(E
))
6783 (New_Occurrence_Of
(Etype
(E
), Sloc
(Instance
)));
6786 elsif Ekind
(E
) = E_Package
then
6788 -- If this is the renaming for the current instance, we're done.
6789 -- Otherwise it is a formal package. If the corresponding formal
6790 -- was declared with a box, the (instantiations of the) generic
6791 -- formal part are also visible. Otherwise, ignore the entity
6792 -- created to validate the actuals.
6794 if Renamed_Object
(E
) = Instance
then
6797 elsif Nkind
(Parent
(E
)) /= N_Package_Renaming_Declaration
then
6800 -- The visibility of a formal of an enclosing generic is already
6803 elsif Denotes_Formal_Package
(E
) then
6806 elsif Present
(Associated_Formal_Package
(E
))
6807 and then not Is_Generic_Formal
(E
)
6809 if Box_Present
(Parent
(Associated_Formal_Package
(E
))) then
6810 Check_Generic_Actuals
(Renamed_Object
(E
), True);
6813 Check_Generic_Actuals
(Renamed_Object
(E
), False);
6816 Set_Is_Hidden
(E
, False);
6819 -- If this is a subprogram instance (in a wrapper package) the
6820 -- actual is fully visible.
6822 elsif Is_Wrapper_Package
(Instance
) then
6823 Set_Is_Hidden
(E
, False);
6825 -- If the formal package is declared with a box, or if the formal
6826 -- parameter is defaulted, it is visible in the body.
6828 elsif Is_Formal_Box
or else Is_Visible_Formal
(E
) then
6829 Set_Is_Hidden
(E
, False);
6832 if Ekind
(E
) = E_Constant
then
6834 -- If the type of the actual is a private type declared in the
6835 -- enclosing scope of the generic unit, the body of the generic
6836 -- sees the full view of the type (because it has to appear in
6837 -- the corresponding package body). If the type is private now,
6838 -- exchange views to restore the proper visiblity in the instance.
6841 Typ
: constant Entity_Id
:= Base_Type
(Etype
(E
));
6842 -- The type of the actual
6847 Parent_Scope
: Entity_Id
;
6848 -- The enclosing scope of the generic unit
6851 if Is_Wrapper_Package
(Instance
) then
6855 (Unit_Declaration_Node
6856 (Related_Instance
(Instance
))));
6859 Generic_Parent
(Package_Specification
(Instance
));
6862 Parent_Scope
:= Scope
(Gen_Id
);
6864 -- The exchange is only needed if the generic is defined
6865 -- within a package which is not a common ancestor of the
6866 -- scope of the instance, and is not already in scope.
6868 if Is_Private_Type
(Typ
)
6869 and then Scope
(Typ
) = Parent_Scope
6870 and then Scope
(Instance
) /= Parent_Scope
6871 and then Ekind
(Parent_Scope
) = E_Package
6872 and then not Is_Child_Unit
(Gen_Id
)
6876 -- If the type of the entity is a subtype, it may also have
6877 -- to be made visible, together with the base type of its
6878 -- full view, after exchange.
6880 if Is_Private_Type
(Etype
(E
)) then
6881 Switch_View
(Etype
(E
));
6882 Switch_View
(Base_Type
(Etype
(E
)));
6890 end Check_Generic_Actuals
;
6892 ------------------------------
6893 -- Check_Generic_Child_Unit --
6894 ------------------------------
6896 procedure Check_Generic_Child_Unit
6898 Parent_Installed
: in out Boolean)
6900 Loc
: constant Source_Ptr
:= Sloc
(Gen_Id
);
6901 Gen_Par
: Entity_Id
:= Empty
;
6903 Inst_Par
: Entity_Id
;
6906 function Find_Generic_Child
6908 Id
: Node_Id
) return Entity_Id
;
6909 -- Search generic parent for possible child unit with the given name
6911 function In_Enclosing_Instance
return Boolean;
6912 -- Within an instance of the parent, the child unit may be denoted by
6913 -- a simple name, or an abbreviated expanded name. Examine enclosing
6914 -- scopes to locate a possible parent instantiation.
6916 ------------------------
6917 -- Find_Generic_Child --
6918 ------------------------
6920 function Find_Generic_Child
6922 Id
: Node_Id
) return Entity_Id
6927 -- If entity of name is already set, instance has already been
6928 -- resolved, e.g. in an enclosing instantiation.
6930 if Present
(Entity
(Id
)) then
6931 if Scope
(Entity
(Id
)) = Scop
then
6938 E
:= First_Entity
(Scop
);
6939 while Present
(E
) loop
6940 if Chars
(E
) = Chars
(Id
)
6941 and then Is_Child_Unit
(E
)
6943 if Is_Child_Unit
(E
)
6944 and then not Is_Visible_Lib_Unit
(E
)
6947 ("generic child unit& is not visible", Gen_Id
, E
);
6959 end Find_Generic_Child
;
6961 ---------------------------
6962 -- In_Enclosing_Instance --
6963 ---------------------------
6965 function In_Enclosing_Instance
return Boolean is
6966 Enclosing_Instance
: Node_Id
;
6967 Instance_Decl
: Node_Id
;
6970 -- We do not inline any call that contains instantiations, except
6971 -- for instantiations of Unchecked_Conversion, so if we are within
6972 -- an inlined body the current instance does not require parents.
6974 if In_Inlined_Body
then
6975 pragma Assert
(Chars
(Gen_Id
) = Name_Unchecked_Conversion
);
6979 -- Loop to check enclosing scopes
6981 Enclosing_Instance
:= Current_Scope
;
6982 while Present
(Enclosing_Instance
) loop
6983 Instance_Decl
:= Unit_Declaration_Node
(Enclosing_Instance
);
6985 if Ekind
(Enclosing_Instance
) = E_Package
6986 and then Is_Generic_Instance
(Enclosing_Instance
)
6988 (Generic_Parent
(Specification
(Instance_Decl
)))
6990 -- Check whether the generic we are looking for is a child of
6993 E
:= Find_Generic_Child
6994 (Generic_Parent
(Specification
(Instance_Decl
)), Gen_Id
);
6995 exit when Present
(E
);
7001 Enclosing_Instance
:= Scope
(Enclosing_Instance
);
7013 Make_Expanded_Name
(Loc
,
7015 Prefix
=> New_Occurrence_Of
(Enclosing_Instance
, Loc
),
7016 Selector_Name
=> New_Occurrence_Of
(E
, Loc
)));
7018 Set_Entity
(Gen_Id
, E
);
7019 Set_Etype
(Gen_Id
, Etype
(E
));
7020 Parent_Installed
:= False; -- Already in scope.
7023 end In_Enclosing_Instance
;
7025 -- Start of processing for Check_Generic_Child_Unit
7028 -- If the name of the generic is given by a selected component, it may
7029 -- be the name of a generic child unit, and the prefix is the name of an
7030 -- instance of the parent, in which case the child unit must be visible.
7031 -- If this instance is not in scope, it must be placed there and removed
7032 -- after instantiation, because what is being instantiated is not the
7033 -- original child, but the corresponding child present in the instance
7036 -- If the child is instantiated within the parent, it can be given by
7037 -- a simple name. In this case the instance is already in scope, but
7038 -- the child generic must be recovered from the generic parent as well.
7040 if Nkind
(Gen_Id
) = N_Selected_Component
then
7041 S
:= Selector_Name
(Gen_Id
);
7042 Analyze
(Prefix
(Gen_Id
));
7043 Inst_Par
:= Entity
(Prefix
(Gen_Id
));
7045 if Ekind
(Inst_Par
) = E_Package
7046 and then Present
(Renamed_Object
(Inst_Par
))
7048 Inst_Par
:= Renamed_Object
(Inst_Par
);
7051 if Ekind
(Inst_Par
) = E_Package
then
7052 if Nkind
(Parent
(Inst_Par
)) = N_Package_Specification
then
7053 Gen_Par
:= Generic_Parent
(Parent
(Inst_Par
));
7055 elsif Nkind
(Parent
(Inst_Par
)) = N_Defining_Program_Unit_Name
7057 Nkind
(Parent
(Parent
(Inst_Par
))) = N_Package_Specification
7059 Gen_Par
:= Generic_Parent
(Parent
(Parent
(Inst_Par
)));
7062 elsif Ekind
(Inst_Par
) = E_Generic_Package
7063 and then Nkind
(Parent
(Gen_Id
)) = N_Formal_Package_Declaration
7065 -- A formal package may be a real child package, and not the
7066 -- implicit instance within a parent. In this case the child is
7067 -- not visible and has to be retrieved explicitly as well.
7069 Gen_Par
:= Inst_Par
;
7072 if Present
(Gen_Par
) then
7074 -- The prefix denotes an instantiation. The entity itself may be a
7075 -- nested generic, or a child unit.
7077 E
:= Find_Generic_Child
(Gen_Par
, S
);
7080 Change_Selected_Component_To_Expanded_Name
(Gen_Id
);
7081 Set_Entity
(Gen_Id
, E
);
7082 Set_Etype
(Gen_Id
, Etype
(E
));
7084 Set_Etype
(S
, Etype
(E
));
7086 -- Indicate that this is a reference to the parent
7088 if In_Extended_Main_Source_Unit
(Gen_Id
) then
7089 Set_Is_Instantiated
(Inst_Par
);
7092 -- A common mistake is to replicate the naming scheme of a
7093 -- hierarchy by instantiating a generic child directly, rather
7094 -- than the implicit child in a parent instance:
7096 -- generic .. package Gpar is ..
7097 -- generic .. package Gpar.Child is ..
7098 -- package Par is new Gpar ();
7101 -- package Par.Child is new Gpar.Child ();
7102 -- rather than Par.Child
7104 -- In this case the instantiation is within Par, which is an
7105 -- instance, but Gpar does not denote Par because we are not IN
7106 -- the instance of Gpar, so this is illegal. The test below
7107 -- recognizes this particular case.
7109 if Is_Child_Unit
(E
)
7110 and then not Comes_From_Source
(Entity
(Prefix
(Gen_Id
)))
7111 and then (not In_Instance
7112 or else Nkind
(Parent
(Parent
(Gen_Id
))) =
7116 ("prefix of generic child unit must be instance of parent",
7120 if not In_Open_Scopes
(Inst_Par
)
7121 and then Nkind
(Parent
(Gen_Id
)) not in
7122 N_Generic_Renaming_Declaration
7124 Install_Parent
(Inst_Par
);
7125 Parent_Installed
:= True;
7127 elsif In_Open_Scopes
(Inst_Par
) then
7129 -- If the parent is already installed, install the actuals
7130 -- for its formal packages. This is necessary when the child
7131 -- instance is a child of the parent instance: in this case,
7132 -- the parent is placed on the scope stack but the formal
7133 -- packages are not made visible.
7135 Install_Formal_Packages
(Inst_Par
);
7139 -- If the generic parent does not contain an entity that
7140 -- corresponds to the selector, the instance doesn't either.
7141 -- Analyzing the node will yield the appropriate error message.
7142 -- If the entity is not a child unit, then it is an inner
7143 -- generic in the parent.
7151 if Is_Child_Unit
(Entity
(Gen_Id
))
7153 Nkind
(Parent
(Gen_Id
)) not in N_Generic_Renaming_Declaration
7154 and then not In_Open_Scopes
(Inst_Par
)
7156 Install_Parent
(Inst_Par
);
7157 Parent_Installed
:= True;
7159 -- The generic unit may be the renaming of the implicit child
7160 -- present in an instance. In that case the parent instance is
7161 -- obtained from the name of the renamed entity.
7163 elsif Ekind
(Entity
(Gen_Id
)) = E_Generic_Package
7164 and then Present
(Renamed_Entity
(Entity
(Gen_Id
)))
7165 and then Is_Child_Unit
(Renamed_Entity
(Entity
(Gen_Id
)))
7168 Renamed_Package
: constant Node_Id
:=
7169 Name
(Parent
(Entity
(Gen_Id
)));
7171 if Nkind
(Renamed_Package
) = N_Expanded_Name
then
7172 Inst_Par
:= Entity
(Prefix
(Renamed_Package
));
7173 Install_Parent
(Inst_Par
);
7174 Parent_Installed
:= True;
7180 elsif Nkind
(Gen_Id
) = N_Expanded_Name
then
7182 -- Entity already present, analyze prefix, whose meaning may be an
7183 -- instance in the current context. If it is an instance of a
7184 -- relative within another, the proper parent may still have to be
7185 -- installed, if they are not of the same generation.
7187 Analyze
(Prefix
(Gen_Id
));
7189 -- Prevent cascaded errors
7191 if Etype
(Prefix
(Gen_Id
)) = Any_Type
then
7195 -- In the unlikely case that a local declaration hides the name of
7196 -- the parent package, locate it on the homonym chain. If the context
7197 -- is an instance of the parent, the renaming entity is flagged as
7200 Inst_Par
:= Entity
(Prefix
(Gen_Id
));
7201 while Present
(Inst_Par
)
7202 and then not Is_Package_Or_Generic_Package
(Inst_Par
)
7204 Inst_Par
:= Homonym
(Inst_Par
);
7207 pragma Assert
(Present
(Inst_Par
));
7208 Set_Entity
(Prefix
(Gen_Id
), Inst_Par
);
7210 if In_Enclosing_Instance
then
7213 elsif Present
(Entity
(Gen_Id
))
7214 and then Is_Child_Unit
(Entity
(Gen_Id
))
7215 and then not In_Open_Scopes
(Inst_Par
)
7217 Install_Parent
(Inst_Par
);
7218 Parent_Installed
:= True;
7221 elsif In_Enclosing_Instance
then
7223 -- The child unit is found in some enclosing scope
7230 -- If this is the renaming of the implicit child in a parent
7231 -- instance, recover the parent name and install it.
7233 if Is_Entity_Name
(Gen_Id
) then
7234 E
:= Entity
(Gen_Id
);
7236 if Is_Generic_Unit
(E
)
7237 and then Nkind
(Parent
(E
)) in N_Generic_Renaming_Declaration
7238 and then Is_Child_Unit
(Renamed_Object
(E
))
7239 and then Is_Generic_Unit
(Scope
(Renamed_Object
(E
)))
7240 and then Nkind
(Name
(Parent
(E
))) = N_Expanded_Name
7242 Rewrite
(Gen_Id
, New_Copy_Tree
(Name
(Parent
(E
))));
7243 Inst_Par
:= Entity
(Prefix
(Gen_Id
));
7245 if not In_Open_Scopes
(Inst_Par
) then
7246 Install_Parent
(Inst_Par
);
7247 Parent_Installed
:= True;
7250 -- If it is a child unit of a non-generic parent, it may be
7251 -- use-visible and given by a direct name. Install parent as
7254 elsif Is_Generic_Unit
(E
)
7255 and then Is_Child_Unit
(E
)
7257 Nkind
(Parent
(Gen_Id
)) not in N_Generic_Renaming_Declaration
7258 and then not Is_Generic_Unit
(Scope
(E
))
7260 if not In_Open_Scopes
(Scope
(E
)) then
7261 Install_Parent
(Scope
(E
));
7262 Parent_Installed
:= True;
7267 end Check_Generic_Child_Unit
;
7269 -----------------------------
7270 -- Check_Hidden_Child_Unit --
7271 -----------------------------
7273 procedure Check_Hidden_Child_Unit
7275 Gen_Unit
: Entity_Id
;
7276 Act_Decl_Id
: Entity_Id
)
7278 Gen_Id
: constant Node_Id
:= Name
(N
);
7281 if Is_Child_Unit
(Gen_Unit
)
7282 and then Is_Child_Unit
(Act_Decl_Id
)
7283 and then Nkind
(Gen_Id
) = N_Expanded_Name
7284 and then Entity
(Prefix
(Gen_Id
)) = Scope
(Act_Decl_Id
)
7285 and then Chars
(Gen_Unit
) = Chars
(Act_Decl_Id
)
7287 Error_Msg_Node_2
:= Scope
(Act_Decl_Id
);
7289 ("generic unit & is implicitly declared in &",
7290 Defining_Unit_Name
(N
), Gen_Unit
);
7291 Error_Msg_N
("\instance must have different name",
7292 Defining_Unit_Name
(N
));
7294 end Check_Hidden_Child_Unit
;
7296 ------------------------
7297 -- Check_Private_View --
7298 ------------------------
7300 procedure Check_Private_View
(N
: Node_Id
) is
7301 T
: constant Entity_Id
:= Etype
(N
);
7305 -- Exchange views if the type was not private in the generic but is
7306 -- private at the point of instantiation. Do not exchange views if
7307 -- the scope of the type is in scope. This can happen if both generic
7308 -- and instance are sibling units, or if type is defined in a parent.
7309 -- In this case the visibility of the type will be correct for all
7313 BT
:= Base_Type
(T
);
7315 if Is_Private_Type
(T
)
7316 and then not Has_Private_View
(N
)
7317 and then Present
(Full_View
(T
))
7318 and then not In_Open_Scopes
(Scope
(T
))
7320 -- In the generic, the full type was visible. Save the private
7321 -- entity, for subsequent exchange.
7325 elsif Has_Private_View
(N
)
7326 and then not Is_Private_Type
(T
)
7327 and then not Has_Been_Exchanged
(T
)
7328 and then Etype
(Get_Associated_Node
(N
)) /= T
7330 -- Only the private declaration was visible in the generic. If
7331 -- the type appears in a subtype declaration, the subtype in the
7332 -- instance must have a view compatible with that of its parent,
7333 -- which must be exchanged (see corresponding code in Restore_
7334 -- Private_Views). Otherwise, if the type is defined in a parent
7335 -- unit, leave full visibility within instance, which is safe.
7337 if In_Open_Scopes
(Scope
(Base_Type
(T
)))
7338 and then not Is_Private_Type
(Base_Type
(T
))
7339 and then Comes_From_Source
(Base_Type
(T
))
7343 elsif Nkind
(Parent
(N
)) = N_Subtype_Declaration
7344 or else not In_Private_Part
(Scope
(Base_Type
(T
)))
7346 Prepend_Elmt
(T
, Exchanged_Views
);
7347 Exchange_Declarations
(Etype
(Get_Associated_Node
(N
)));
7350 -- For composite types with inconsistent representation exchange
7351 -- component types accordingly.
7353 elsif Is_Access_Type
(T
)
7354 and then Is_Private_Type
(Designated_Type
(T
))
7355 and then not Has_Private_View
(N
)
7356 and then Present
(Full_View
(Designated_Type
(T
)))
7358 Switch_View
(Designated_Type
(T
));
7360 elsif Is_Array_Type
(T
) then
7361 if Is_Private_Type
(Component_Type
(T
))
7362 and then not Has_Private_View
(N
)
7363 and then Present
(Full_View
(Component_Type
(T
)))
7365 Switch_View
(Component_Type
(T
));
7368 -- The normal exchange mechanism relies on the setting of a
7369 -- flag on the reference in the generic. However, an additional
7370 -- mechanism is needed for types that are not explicitly
7371 -- mentioned in the generic, but may be needed in expanded code
7372 -- in the instance. This includes component types of arrays and
7373 -- designated types of access types. This processing must also
7374 -- include the index types of arrays which we take care of here.
7381 Indx
:= First_Index
(T
);
7382 while Present
(Indx
) loop
7383 Typ
:= Base_Type
(Etype
(Indx
));
7385 if Is_Private_Type
(Typ
)
7386 and then Present
(Full_View
(Typ
))
7395 elsif Is_Private_Type
(T
)
7396 and then Present
(Full_View
(T
))
7397 and then Is_Array_Type
(Full_View
(T
))
7398 and then Is_Private_Type
(Component_Type
(Full_View
(T
)))
7402 -- Finally, a non-private subtype may have a private base type, which
7403 -- must be exchanged for consistency. This can happen when a package
7404 -- body is instantiated, when the scope stack is empty but in fact
7405 -- the subtype and the base type are declared in an enclosing scope.
7407 -- Note that in this case we introduce an inconsistency in the view
7408 -- set, because we switch the base type BT, but there could be some
7409 -- private dependent subtypes of BT which remain unswitched. Such
7410 -- subtypes might need to be switched at a later point (see specific
7411 -- provision for that case in Switch_View).
7413 elsif not Is_Private_Type
(T
)
7414 and then not Has_Private_View
(N
)
7415 and then Is_Private_Type
(BT
)
7416 and then Present
(Full_View
(BT
))
7417 and then not Is_Generic_Type
(BT
)
7418 and then not In_Open_Scopes
(BT
)
7420 Prepend_Elmt
(Full_View
(BT
), Exchanged_Views
);
7421 Exchange_Declarations
(BT
);
7424 end Check_Private_View
;
7426 -----------------------------
7427 -- Check_Hidden_Primitives --
7428 -----------------------------
7430 function Check_Hidden_Primitives
(Assoc_List
: List_Id
) return Elist_Id
is
7433 Result
: Elist_Id
:= No_Elist
;
7436 if No
(Assoc_List
) then
7440 -- Traverse the list of associations between formals and actuals
7441 -- searching for renamings of tagged types
7443 Actual
:= First
(Assoc_List
);
7444 while Present
(Actual
) loop
7445 if Nkind
(Actual
) = N_Subtype_Declaration
then
7446 Gen_T
:= Generic_Parent_Type
(Actual
);
7448 if Present
(Gen_T
) and then Is_Tagged_Type
(Gen_T
) then
7450 -- Traverse the list of primitives of the actual types
7451 -- searching for hidden primitives that are visible in the
7452 -- corresponding generic formal; leave them visible and
7453 -- append them to Result to restore their decoration later.
7455 Install_Hidden_Primitives
7456 (Prims_List
=> Result
,
7458 Act_T
=> Entity
(Subtype_Indication
(Actual
)));
7466 end Check_Hidden_Primitives
;
7468 --------------------------
7469 -- Contains_Instance_Of --
7470 --------------------------
7472 function Contains_Instance_Of
7475 N
: Node_Id
) return Boolean
7483 -- Verify that there are no circular instantiations. We check whether
7484 -- the unit contains an instance of the current scope or some enclosing
7485 -- scope (in case one of the instances appears in a subunit). Longer
7486 -- circularities involving subunits might seem too pathological to
7487 -- consider, but they were not too pathological for the authors of
7488 -- DEC bc30vsq, so we loop over all enclosing scopes, and mark all
7489 -- enclosing generic scopes as containing an instance.
7492 -- Within a generic subprogram body, the scope is not generic, to
7493 -- allow for recursive subprograms. Use the declaration to determine
7494 -- whether this is a generic unit.
7496 if Ekind
(Scop
) = E_Generic_Package
7497 or else (Is_Subprogram
(Scop
)
7498 and then Nkind
(Unit_Declaration_Node
(Scop
)) =
7499 N_Generic_Subprogram_Declaration
)
7501 Elmt
:= First_Elmt
(Inner_Instances
(Inner
));
7503 while Present
(Elmt
) loop
7504 if Node
(Elmt
) = Scop
then
7505 Error_Msg_Node_2
:= Inner
;
7507 ("circular Instantiation: & instantiated within &!",
7511 elsif Node
(Elmt
) = Inner
then
7514 elsif Contains_Instance_Of
(Node
(Elmt
), Scop
, N
) then
7515 Error_Msg_Node_2
:= Inner
;
7517 ("circular Instantiation: & instantiated within &!",
7525 -- Indicate that Inner is being instantiated within Scop
7527 Append_Elmt
(Inner
, Inner_Instances
(Scop
));
7530 if Scop
= Standard_Standard
then
7533 Scop
:= Scope
(Scop
);
7538 end Contains_Instance_Of
;
7540 -----------------------
7541 -- Copy_Generic_Node --
7542 -----------------------
7544 function Copy_Generic_Node
7546 Parent_Id
: Node_Id
;
7547 Instantiating
: Boolean) return Node_Id
7552 function Copy_Generic_Descendant
(D
: Union_Id
) return Union_Id
;
7553 -- Check the given value of one of the Fields referenced by the current
7554 -- node to determine whether to copy it recursively. The field may hold
7555 -- a Node_Id, a List_Id, or an Elist_Id, or a plain value (Sloc, Uint,
7556 -- Char) in which case it need not be copied.
7558 procedure Copy_Descendants
;
7559 -- Common utility for various nodes
7561 function Copy_Generic_Elist
(E
: Elist_Id
) return Elist_Id
;
7562 -- Make copy of element list
7564 function Copy_Generic_List
7566 Parent_Id
: Node_Id
) return List_Id
;
7567 -- Apply Copy_Node recursively to the members of a node list
7569 function In_Defining_Unit_Name
(Nam
: Node_Id
) return Boolean;
7570 -- True if an identifier is part of the defining program unit name of
7571 -- a child unit. The entity of such an identifier must be kept (for
7572 -- ASIS use) even though as the name of an enclosing generic it would
7573 -- otherwise not be preserved in the generic tree.
7575 ----------------------
7576 -- Copy_Descendants --
7577 ----------------------
7579 procedure Copy_Descendants
is
7580 use Atree
.Unchecked_Access
;
7581 -- This code section is part of the implementation of an untyped
7582 -- tree traversal, so it needs direct access to node fields.
7585 Set_Field1
(New_N
, Copy_Generic_Descendant
(Field1
(N
)));
7586 Set_Field2
(New_N
, Copy_Generic_Descendant
(Field2
(N
)));
7587 Set_Field3
(New_N
, Copy_Generic_Descendant
(Field3
(N
)));
7588 Set_Field4
(New_N
, Copy_Generic_Descendant
(Field4
(N
)));
7589 Set_Field5
(New_N
, Copy_Generic_Descendant
(Field5
(N
)));
7590 end Copy_Descendants
;
7592 -----------------------------
7593 -- Copy_Generic_Descendant --
7594 -----------------------------
7596 function Copy_Generic_Descendant
(D
: Union_Id
) return Union_Id
is
7598 if D
= Union_Id
(Empty
) then
7601 elsif D
in Node_Range
then
7603 (Copy_Generic_Node
(Node_Id
(D
), New_N
, Instantiating
));
7605 elsif D
in List_Range
then
7606 return Union_Id
(Copy_Generic_List
(List_Id
(D
), New_N
));
7608 elsif D
in Elist_Range
then
7609 return Union_Id
(Copy_Generic_Elist
(Elist_Id
(D
)));
7611 -- Nothing else is copyable (e.g. Uint values), return as is
7616 end Copy_Generic_Descendant
;
7618 ------------------------
7619 -- Copy_Generic_Elist --
7620 ------------------------
7622 function Copy_Generic_Elist
(E
: Elist_Id
) return Elist_Id
is
7629 M
:= First_Elmt
(E
);
7630 while Present
(M
) loop
7632 (Copy_Generic_Node
(Node
(M
), Empty
, Instantiating
), L
);
7641 end Copy_Generic_Elist
;
7643 -----------------------
7644 -- Copy_Generic_List --
7645 -----------------------
7647 function Copy_Generic_List
7649 Parent_Id
: Node_Id
) return List_Id
7657 Set_Parent
(New_L
, Parent_Id
);
7660 while Present
(N
) loop
7661 Append
(Copy_Generic_Node
(N
, Empty
, Instantiating
), New_L
);
7670 end Copy_Generic_List
;
7672 ---------------------------
7673 -- In_Defining_Unit_Name --
7674 ---------------------------
7676 function In_Defining_Unit_Name
(Nam
: Node_Id
) return Boolean is
7679 Present
(Parent
(Nam
))
7680 and then (Nkind
(Parent
(Nam
)) = N_Defining_Program_Unit_Name
7682 (Nkind
(Parent
(Nam
)) = N_Expanded_Name
7683 and then In_Defining_Unit_Name
(Parent
(Nam
))));
7684 end In_Defining_Unit_Name
;
7686 -- Start of processing for Copy_Generic_Node
7693 New_N
:= New_Copy
(N
);
7695 -- Copy aspects if present
7697 if Has_Aspects
(N
) then
7698 Set_Has_Aspects
(New_N
, False);
7699 Set_Aspect_Specifications
7700 (New_N
, Copy_Generic_List
(Aspect_Specifications
(N
), Parent_Id
));
7703 -- If we are instantiating, we want to adjust the sloc based on the
7704 -- current S_Adjustment. However, if this is the root node of a subunit,
7705 -- we need to defer that adjustment to below (see "elsif Instantiating
7706 -- and Was_Stub"), so it comes after Create_Instantiation_Source has
7707 -- computed the adjustment.
7710 and then not (Nkind
(N
) in N_Proper_Body
7711 and then Was_Originally_Stub
(N
))
7713 Adjust_Instantiation_Sloc
(New_N
, S_Adjustment
);
7716 if not Is_List_Member
(N
) then
7717 Set_Parent
(New_N
, Parent_Id
);
7720 -- Special casing for identifiers and other entity names and operators
7722 if Nkind_In
(New_N
, N_Character_Literal
,
7726 or else Nkind
(New_N
) in N_Op
7728 if not Instantiating
then
7730 -- Link both nodes in order to assign subsequently the entity of
7731 -- the copy to the original node, in case this is a global
7734 Set_Associated_Node
(N
, New_N
);
7736 -- If we are within an instantiation, this is a nested generic
7737 -- that has already been analyzed at the point of definition.
7738 -- We must preserve references that were global to the enclosing
7739 -- parent at that point. Other occurrences, whether global or
7740 -- local to the current generic, must be resolved anew, so we
7741 -- reset the entity in the generic copy. A global reference has a
7742 -- smaller depth than the parent, or else the same depth in case
7743 -- both are distinct compilation units.
7745 -- A child unit is implicitly declared within the enclosing parent
7746 -- but is in fact global to it, and must be preserved.
7748 -- It is also possible for Current_Instantiated_Parent to be
7749 -- defined, and for this not to be a nested generic, namely if
7750 -- the unit is loaded through Rtsfind. In that case, the entity of
7751 -- New_N is only a link to the associated node, and not a defining
7754 -- The entities for parent units in the defining_program_unit of a
7755 -- generic child unit are established when the context of the unit
7756 -- is first analyzed, before the generic copy is made. They are
7757 -- preserved in the copy for use in ASIS queries.
7759 Ent
:= Entity
(New_N
);
7761 if No
(Current_Instantiated_Parent
.Gen_Id
) then
7763 or else Nkind
(Ent
) /= N_Defining_Identifier
7764 or else not In_Defining_Unit_Name
(N
)
7766 Set_Associated_Node
(New_N
, Empty
);
7771 not Nkind_In
(Ent
, N_Defining_Identifier
,
7772 N_Defining_Character_Literal
,
7773 N_Defining_Operator_Symbol
)
7774 or else No
(Scope
(Ent
))
7776 (Scope
(Ent
) = Current_Instantiated_Parent
.Gen_Id
7777 and then not Is_Child_Unit
(Ent
))
7779 (Scope_Depth
(Scope
(Ent
)) >
7780 Scope_Depth
(Current_Instantiated_Parent
.Gen_Id
)
7782 Get_Source_Unit
(Ent
) =
7783 Get_Source_Unit
(Current_Instantiated_Parent
.Gen_Id
))
7785 Set_Associated_Node
(New_N
, Empty
);
7788 -- Case of instantiating identifier or some other name or operator
7791 -- If the associated node is still defined, the entity in it
7792 -- is global, and must be copied to the instance. If this copy
7793 -- is being made for a body to inline, it is applied to an
7794 -- instantiated tree, and the entity is already present and
7795 -- must be also preserved.
7798 Assoc
: constant Node_Id
:= Get_Associated_Node
(N
);
7801 if Present
(Assoc
) then
7802 if Nkind
(Assoc
) = Nkind
(N
) then
7803 Set_Entity
(New_N
, Entity
(Assoc
));
7804 Check_Private_View
(N
);
7806 -- The node is a reference to a global type and acts as the
7807 -- subtype mark of a qualified expression created in order
7808 -- to aid resolution of accidental overloading in instances.
7809 -- Since N is a reference to a type, the Associated_Node of
7810 -- N denotes an entity rather than another identifier. See
7811 -- Qualify_Universal_Operands for details.
7813 elsif Nkind
(N
) = N_Identifier
7814 and then Nkind
(Parent
(N
)) = N_Qualified_Expression
7815 and then Subtype_Mark
(Parent
(N
)) = N
7816 and then Is_Qualified_Universal_Literal
(Parent
(N
))
7818 Set_Entity
(New_N
, Assoc
);
7820 -- The name in the call may be a selected component if the
7821 -- call has not been analyzed yet, as may be the case for
7822 -- pre/post conditions in a generic unit.
7824 elsif Nkind
(Assoc
) = N_Function_Call
7825 and then Is_Entity_Name
(Name
(Assoc
))
7827 Set_Entity
(New_N
, Entity
(Name
(Assoc
)));
7829 elsif Nkind_In
(Assoc
, N_Defining_Identifier
,
7830 N_Defining_Character_Literal
,
7831 N_Defining_Operator_Symbol
)
7832 and then Expander_Active
7834 -- Inlining case: we are copying a tree that contains
7835 -- global entities, which are preserved in the copy to be
7836 -- used for subsequent inlining.
7841 Set_Entity
(New_N
, Empty
);
7847 -- For expanded name, we must copy the Prefix and Selector_Name
7849 if Nkind
(N
) = N_Expanded_Name
then
7851 (New_N
, Copy_Generic_Node
(Prefix
(N
), New_N
, Instantiating
));
7853 Set_Selector_Name
(New_N
,
7854 Copy_Generic_Node
(Selector_Name
(N
), New_N
, Instantiating
));
7856 -- For operators, copy the operands
7858 elsif Nkind
(N
) in N_Op
then
7859 if Nkind
(N
) in N_Binary_Op
then
7860 Set_Left_Opnd
(New_N
,
7861 Copy_Generic_Node
(Left_Opnd
(N
), New_N
, Instantiating
));
7864 Set_Right_Opnd
(New_N
,
7865 Copy_Generic_Node
(Right_Opnd
(N
), New_N
, Instantiating
));
7868 -- Establish a link between an entity from the generic template and the
7869 -- corresponding entity in the generic copy to be analyzed.
7871 elsif Nkind
(N
) in N_Entity
then
7872 if not Instantiating
then
7873 Set_Associated_Entity
(N
, New_N
);
7876 -- Clear any existing link the copy may inherit from the replicated
7877 -- generic template entity.
7879 Set_Associated_Entity
(New_N
, Empty
);
7881 -- Special casing for stubs
7883 elsif Nkind
(N
) in N_Body_Stub
then
7885 -- In any case, we must copy the specification or defining
7886 -- identifier as appropriate.
7888 if Nkind
(N
) = N_Subprogram_Body_Stub
then
7889 Set_Specification
(New_N
,
7890 Copy_Generic_Node
(Specification
(N
), New_N
, Instantiating
));
7893 Set_Defining_Identifier
(New_N
,
7895 (Defining_Identifier
(N
), New_N
, Instantiating
));
7898 -- If we are not instantiating, then this is where we load and
7899 -- analyze subunits, i.e. at the point where the stub occurs. A
7900 -- more permissive system might defer this analysis to the point
7901 -- of instantiation, but this seems too complicated for now.
7903 if not Instantiating
then
7905 Subunit_Name
: constant Unit_Name_Type
:= Get_Unit_Name
(N
);
7907 Unum
: Unit_Number_Type
;
7911 -- Make sure that, if it is a subunit of the main unit that is
7912 -- preprocessed and if -gnateG is specified, the preprocessed
7913 -- file will be written.
7915 Lib
.Analysing_Subunit_Of_Main
:=
7916 Lib
.In_Extended_Main_Source_Unit
(N
);
7919 (Load_Name
=> Subunit_Name
,
7923 Lib
.Analysing_Subunit_Of_Main
:= False;
7925 -- If the proper body is not found, a warning message will be
7926 -- emitted when analyzing the stub, or later at the point of
7927 -- instantiation. Here we just leave the stub as is.
7929 if Unum
= No_Unit
then
7930 Subunits_Missing
:= True;
7931 goto Subunit_Not_Found
;
7934 Subunit
:= Cunit
(Unum
);
7936 if Nkind
(Unit
(Subunit
)) /= N_Subunit
then
7938 ("found child unit instead of expected SEPARATE subunit",
7940 Error_Msg_Sloc
:= Sloc
(N
);
7941 Error_Msg_N
("\to complete stub #", Subunit
);
7942 goto Subunit_Not_Found
;
7945 -- We must create a generic copy of the subunit, in order to
7946 -- perform semantic analysis on it, and we must replace the
7947 -- stub in the original generic unit with the subunit, in order
7948 -- to preserve non-local references within.
7950 -- Only the proper body needs to be copied. Library_Unit and
7951 -- context clause are simply inherited by the generic copy.
7952 -- Note that the copy (which may be recursive if there are
7953 -- nested subunits) must be done first, before attaching it to
7954 -- the enclosing generic.
7958 (Proper_Body
(Unit
(Subunit
)),
7959 Empty
, Instantiating
=> False);
7961 -- Now place the original proper body in the original generic
7962 -- unit. This is a body, not a compilation unit.
7964 Rewrite
(N
, Proper_Body
(Unit
(Subunit
)));
7965 Set_Is_Compilation_Unit
(Defining_Entity
(N
), False);
7966 Set_Was_Originally_Stub
(N
);
7968 -- Finally replace the body of the subunit with its copy, and
7969 -- make this new subunit into the library unit of the generic
7970 -- copy, which does not have stubs any longer.
7972 Set_Proper_Body
(Unit
(Subunit
), New_Body
);
7973 Set_Library_Unit
(New_N
, Subunit
);
7974 Inherit_Context
(Unit
(Subunit
), N
);
7977 -- If we are instantiating, this must be an error case, since
7978 -- otherwise we would have replaced the stub node by the proper body
7979 -- that corresponds. So just ignore it in the copy (i.e. we have
7980 -- copied it, and that is good enough).
7986 <<Subunit_Not_Found
>> null;
7988 -- If the node is a compilation unit, it is the subunit of a stub, which
7989 -- has been loaded already (see code below). In this case, the library
7990 -- unit field of N points to the parent unit (which is a compilation
7991 -- unit) and need not (and cannot) be copied.
7993 -- When the proper body of the stub is analyzed, the library_unit link
7994 -- is used to establish the proper context (see sem_ch10).
7996 -- The other fields of a compilation unit are copied as usual
7998 elsif Nkind
(N
) = N_Compilation_Unit
then
8000 -- This code can only be executed when not instantiating, because in
8001 -- the copy made for an instantiation, the compilation unit node has
8002 -- disappeared at the point that a stub is replaced by its proper
8005 pragma Assert
(not Instantiating
);
8007 Set_Context_Items
(New_N
,
8008 Copy_Generic_List
(Context_Items
(N
), New_N
));
8011 Copy_Generic_Node
(Unit
(N
), New_N
, Instantiating
=> False));
8013 Set_First_Inlined_Subprogram
(New_N
,
8015 (First_Inlined_Subprogram
(N
), New_N
, Instantiating
=> False));
8020 (Aux_Decls_Node
(N
), New_N
, Instantiating
=> False));
8022 -- For an assignment node, the assignment is known to be semantically
8023 -- legal if we are instantiating the template. This avoids incorrect
8024 -- diagnostics in generated code.
8026 elsif Nkind
(N
) = N_Assignment_Statement
then
8028 -- Copy name and expression fields in usual manner
8031 Copy_Generic_Node
(Name
(N
), New_N
, Instantiating
));
8033 Set_Expression
(New_N
,
8034 Copy_Generic_Node
(Expression
(N
), New_N
, Instantiating
));
8036 if Instantiating
then
8037 Set_Assignment_OK
(Name
(New_N
), True);
8040 elsif Nkind_In
(N
, N_Aggregate
, N_Extension_Aggregate
) then
8041 if not Instantiating
then
8042 Set_Associated_Node
(N
, New_N
);
8045 if Present
(Get_Associated_Node
(N
))
8046 and then Nkind
(Get_Associated_Node
(N
)) = Nkind
(N
)
8048 -- In the generic the aggregate has some composite type. If at
8049 -- the point of instantiation the type has a private view,
8050 -- install the full view (and that of its ancestors, if any).
8053 T
: Entity_Id
:= (Etype
(Get_Associated_Node
(New_N
)));
8057 if Present
(T
) and then Is_Private_Type
(T
) then
8062 and then Is_Tagged_Type
(T
)
8063 and then Is_Derived_Type
(T
)
8065 Rt
:= Root_Type
(T
);
8070 if Is_Private_Type
(T
) then
8081 -- Do not copy the associated node, which points to the generic copy
8082 -- of the aggregate.
8085 use Atree
.Unchecked_Access
;
8086 -- This code section is part of the implementation of an untyped
8087 -- tree traversal, so it needs direct access to node fields.
8090 Set_Field1
(New_N
, Copy_Generic_Descendant
(Field1
(N
)));
8091 Set_Field2
(New_N
, Copy_Generic_Descendant
(Field2
(N
)));
8092 Set_Field3
(New_N
, Copy_Generic_Descendant
(Field3
(N
)));
8093 Set_Field5
(New_N
, Copy_Generic_Descendant
(Field5
(N
)));
8096 -- Allocators do not have an identifier denoting the access type, so we
8097 -- must locate it through the expression to check whether the views are
8100 elsif Nkind
(N
) = N_Allocator
8101 and then Nkind
(Expression
(N
)) = N_Qualified_Expression
8102 and then Is_Entity_Name
(Subtype_Mark
(Expression
(N
)))
8103 and then Instantiating
8106 T
: constant Node_Id
:=
8107 Get_Associated_Node
(Subtype_Mark
(Expression
(N
)));
8113 -- Retrieve the allocator node in the generic copy
8115 Acc_T
:= Etype
(Parent
(Parent
(T
)));
8117 if Present
(Acc_T
) and then Is_Private_Type
(Acc_T
) then
8118 Switch_View
(Acc_T
);
8125 -- For a proper body, we must catch the case of a proper body that
8126 -- replaces a stub. This represents the point at which a separate
8127 -- compilation unit, and hence template file, may be referenced, so we
8128 -- must make a new source instantiation entry for the template of the
8129 -- subunit, and ensure that all nodes in the subunit are adjusted using
8130 -- this new source instantiation entry.
8132 elsif Nkind
(N
) in N_Proper_Body
then
8134 Save_Adjustment
: constant Sloc_Adjustment
:= S_Adjustment
;
8136 if Instantiating
and then Was_Originally_Stub
(N
) then
8137 Create_Instantiation_Source
8138 (Instantiation_Node
,
8139 Defining_Entity
(N
),
8142 Adjust_Instantiation_Sloc
(New_N
, S_Adjustment
);
8145 -- Now copy the fields of the proper body, using the new
8146 -- adjustment factor if one was needed as per test above.
8150 -- Restore the original adjustment factor
8152 S_Adjustment
:= Save_Adjustment
;
8155 elsif Nkind
(N
) = N_Pragma
and then Instantiating
then
8157 -- Do not copy Comment or Ident pragmas their content is relevant to
8158 -- the generic unit, not to the instantiating unit.
8160 if Nam_In
(Pragma_Name_Unmapped
(N
), Name_Comment
, Name_Ident
) then
8161 New_N
:= Make_Null_Statement
(Sloc
(N
));
8163 -- Do not copy pragmas generated from aspects because the pragmas do
8164 -- not carry any semantic information, plus they will be regenerated
8167 -- However, generating C we need to copy them since postconditions
8168 -- are inlined by the front end, and the front-end inlining machinery
8169 -- relies on this routine to perform inlining.
8171 elsif From_Aspect_Specification
(N
)
8172 and then not Modify_Tree_For_C
8174 New_N
:= Make_Null_Statement
(Sloc
(N
));
8180 elsif Nkind_In
(N
, N_Integer_Literal
, N_Real_Literal
) then
8182 -- No descendant fields need traversing
8186 elsif Nkind
(N
) = N_String_Literal
8187 and then Present
(Etype
(N
))
8188 and then Instantiating
8190 -- If the string is declared in an outer scope, the string_literal
8191 -- subtype created for it may have the wrong scope. Force reanalysis
8192 -- of the constant to generate a new itype in the proper context.
8194 Set_Etype
(New_N
, Empty
);
8195 Set_Analyzed
(New_N
, False);
8197 -- For the remaining nodes, copy their descendants recursively
8202 if Instantiating
and then Nkind
(N
) = N_Subprogram_Body
then
8203 Set_Generic_Parent
(Specification
(New_N
), N
);
8205 -- Should preserve Corresponding_Spec??? (12.3(14))
8209 -- Propagate dimensions if present, so that they are reflected in the
8212 if Nkind
(N
) in N_Has_Etype
8213 and then (Nkind
(N
) in N_Op
or else Is_Entity_Name
(N
))
8214 and then Present
(Etype
(N
))
8215 and then Is_Floating_Point_Type
(Etype
(N
))
8216 and then Has_Dimension_System
(Etype
(N
))
8218 Copy_Dimensions
(N
, New_N
);
8222 end Copy_Generic_Node
;
8224 ----------------------------
8225 -- Denotes_Formal_Package --
8226 ----------------------------
8228 function Denotes_Formal_Package
8230 On_Exit
: Boolean := False;
8231 Instance
: Entity_Id
:= Empty
) return Boolean
8234 Scop
: constant Entity_Id
:= Scope
(Pack
);
8237 function Is_Actual_Of_Previous_Formal
(P
: Entity_Id
) return Boolean;
8238 -- The package in question may be an actual for a previous formal
8239 -- package P of the current instance, so examine its actuals as well.
8240 -- This must be recursive over other formal packages.
8242 ----------------------------------
8243 -- Is_Actual_Of_Previous_Formal --
8244 ----------------------------------
8246 function Is_Actual_Of_Previous_Formal
(P
: Entity_Id
) return Boolean is
8250 E1
:= First_Entity
(P
);
8251 while Present
(E1
) and then E1
/= Instance
loop
8252 if Ekind
(E1
) = E_Package
8253 and then Nkind
(Parent
(E1
)) = N_Package_Renaming_Declaration
8255 if Renamed_Object
(E1
) = Pack
then
8258 elsif E1
= P
or else Renamed_Object
(E1
) = P
then
8261 elsif Is_Actual_Of_Previous_Formal
(E1
) then
8270 end Is_Actual_Of_Previous_Formal
;
8272 -- Start of processing for Denotes_Formal_Package
8278 (Instance_Envs
.Last
).Instantiated_Parent
.Act_Id
;
8280 Par
:= Current_Instantiated_Parent
.Act_Id
;
8283 if Ekind
(Scop
) = E_Generic_Package
8284 or else Nkind
(Unit_Declaration_Node
(Scop
)) =
8285 N_Generic_Subprogram_Declaration
8289 elsif Nkind
(Original_Node
(Unit_Declaration_Node
(Pack
))) =
8290 N_Formal_Package_Declaration
8298 -- Check whether this package is associated with a formal package of
8299 -- the enclosing instantiation. Iterate over the list of renamings.
8301 E
:= First_Entity
(Par
);
8302 while Present
(E
) loop
8303 if Ekind
(E
) /= E_Package
8304 or else Nkind
(Parent
(E
)) /= N_Package_Renaming_Declaration
8308 elsif Renamed_Object
(E
) = Par
then
8311 elsif Renamed_Object
(E
) = Pack
then
8314 elsif Is_Actual_Of_Previous_Formal
(E
) then
8324 end Denotes_Formal_Package
;
8330 procedure End_Generic
is
8332 -- ??? More things could be factored out in this routine. Should
8333 -- probably be done at a later stage.
8335 Inside_A_Generic
:= Generic_Flags
.Table
(Generic_Flags
.Last
);
8336 Generic_Flags
.Decrement_Last
;
8338 Expander_Mode_Restore
;
8345 function Earlier
(N1
, N2
: Node_Id
) return Boolean is
8346 procedure Find_Depth
(P
: in out Node_Id
; D
: in out Integer);
8347 -- Find distance from given node to enclosing compilation unit
8353 procedure Find_Depth
(P
: in out Node_Id
; D
: in out Integer) is
8356 and then Nkind
(P
) /= N_Compilation_Unit
8358 P
:= True_Parent
(P
);
8363 -- Local declarations
8372 -- Start of processing for Earlier
8375 Find_Depth
(P1
, D1
);
8376 Find_Depth
(P2
, D2
);
8386 P1
:= True_Parent
(P1
);
8391 P2
:= True_Parent
(P2
);
8395 -- At this point P1 and P2 are at the same distance from the root.
8396 -- We examine their parents until we find a common declarative list.
8397 -- If we reach the root, N1 and N2 do not descend from the same
8398 -- declarative list (e.g. one is nested in the declarative part and
8399 -- the other is in a block in the statement part) and the earlier
8400 -- one is already frozen.
8402 while not Is_List_Member
(P1
)
8403 or else not Is_List_Member
(P2
)
8404 or else List_Containing
(P1
) /= List_Containing
(P2
)
8406 P1
:= True_Parent
(P1
);
8407 P2
:= True_Parent
(P2
);
8409 if Nkind
(Parent
(P1
)) = N_Subunit
then
8410 P1
:= Corresponding_Stub
(Parent
(P1
));
8413 if Nkind
(Parent
(P2
)) = N_Subunit
then
8414 P2
:= Corresponding_Stub
(Parent
(P2
));
8422 -- Expanded code usually shares the source location of the original
8423 -- construct it was generated for. This however may not necessarily
8424 -- reflect the true location of the code within the tree.
8426 -- Before comparing the slocs of the two nodes, make sure that we are
8427 -- working with correct source locations. Assume that P1 is to the left
8428 -- of P2. If either one does not come from source, traverse the common
8429 -- list heading towards the other node and locate the first source
8433 -- ----+===+===+--------------+===+===+----
8434 -- expanded code expanded code
8436 if not Comes_From_Source
(P1
) then
8437 while Present
(P1
) loop
8439 -- Neither P2 nor a source statement were located during the
8440 -- search. If we reach the end of the list, then P1 does not
8441 -- occur earlier than P2.
8444 -- start --- P2 ----- P1 --- end
8446 if No
(Next
(P1
)) then
8449 -- We encounter P2 while going to the right of the list. This
8450 -- means that P1 does indeed appear earlier.
8453 -- start --- P1 ===== P2 --- end
8454 -- expanded code in between
8459 -- No need to look any further since we have located a source
8462 elsif Comes_From_Source
(P1
) then
8472 if not Comes_From_Source
(P2
) then
8473 while Present
(P2
) loop
8475 -- Neither P1 nor a source statement were located during the
8476 -- search. If we reach the start of the list, then P1 does not
8477 -- occur earlier than P2.
8480 -- start --- P2 --- P1 --- end
8482 if No
(Prev
(P2
)) then
8485 -- We encounter P1 while going to the left of the list. This
8486 -- means that P1 does indeed appear earlier.
8489 -- start --- P1 ===== P2 --- end
8490 -- expanded code in between
8495 -- No need to look any further since we have located a source
8498 elsif Comes_From_Source
(P2
) then
8508 -- At this point either both nodes came from source or we approximated
8509 -- their source locations through neighboring source statements.
8511 T1
:= Top_Level_Location
(Sloc
(P1
));
8512 T2
:= Top_Level_Location
(Sloc
(P2
));
8514 -- When two nodes come from the same instance, they have identical top
8515 -- level locations. To determine proper relation within the tree, check
8516 -- their locations within the template.
8519 return Sloc
(P1
) < Sloc
(P2
);
8521 -- The two nodes either come from unrelated instances or do not come
8522 -- from instantiated code at all.
8529 ----------------------
8530 -- Find_Actual_Type --
8531 ----------------------
8533 function Find_Actual_Type
8535 Gen_Type
: Entity_Id
) return Entity_Id
8537 Gen_Scope
: constant Entity_Id
:= Scope
(Gen_Type
);
8541 -- Special processing only applies to child units
8543 if not Is_Child_Unit
(Gen_Scope
) then
8544 return Get_Instance_Of
(Typ
);
8546 -- If designated or component type is itself a formal of the child unit,
8547 -- its instance is available.
8549 elsif Scope
(Typ
) = Gen_Scope
then
8550 return Get_Instance_Of
(Typ
);
8552 -- If the array or access type is not declared in the parent unit,
8553 -- no special processing needed.
8555 elsif not Is_Generic_Type
(Typ
)
8556 and then Scope
(Gen_Scope
) /= Scope
(Typ
)
8558 return Get_Instance_Of
(Typ
);
8560 -- Otherwise, retrieve designated or component type by visibility
8563 T
:= Current_Entity
(Typ
);
8564 while Present
(T
) loop
8565 if In_Open_Scopes
(Scope
(T
)) then
8567 elsif Is_Generic_Actual_Type
(T
) then
8576 end Find_Actual_Type
;
8578 ----------------------------
8579 -- Freeze_Subprogram_Body --
8580 ----------------------------
8582 procedure Freeze_Subprogram_Body
8583 (Inst_Node
: Node_Id
;
8585 Pack_Id
: Entity_Id
)
8587 Gen_Unit
: constant Entity_Id
:= Get_Generic_Entity
(Inst_Node
);
8588 Par
: constant Entity_Id
:= Scope
(Gen_Unit
);
8594 function Enclosing_Package_Body
(N
: Node_Id
) return Node_Id
;
8595 -- Find innermost package body that encloses the given node, and which
8596 -- is not a compilation unit. Freeze nodes for the instance, or for its
8597 -- enclosing body, may be inserted after the enclosing_body of the
8598 -- generic unit. Used to determine proper placement of freeze node for
8599 -- both package and subprogram instances.
8601 function Package_Freeze_Node
(B
: Node_Id
) return Node_Id
;
8602 -- Find entity for given package body, and locate or create a freeze
8605 ----------------------------
8606 -- Enclosing_Package_Body --
8607 ----------------------------
8609 function Enclosing_Package_Body
(N
: Node_Id
) return Node_Id
is
8615 and then Nkind
(Parent
(P
)) /= N_Compilation_Unit
8617 if Nkind
(P
) = N_Package_Body
then
8618 if Nkind
(Parent
(P
)) = N_Subunit
then
8619 return Corresponding_Stub
(Parent
(P
));
8625 P
:= True_Parent
(P
);
8629 end Enclosing_Package_Body
;
8631 -------------------------
8632 -- Package_Freeze_Node --
8633 -------------------------
8635 function Package_Freeze_Node
(B
: Node_Id
) return Node_Id
is
8639 if Nkind
(B
) = N_Package_Body
then
8640 Id
:= Corresponding_Spec
(B
);
8641 else pragma Assert
(Nkind
(B
) = N_Package_Body_Stub
);
8642 Id
:= Corresponding_Spec
(Proper_Body
(Unit
(Library_Unit
(B
))));
8645 Ensure_Freeze_Node
(Id
);
8646 return Freeze_Node
(Id
);
8647 end Package_Freeze_Node
;
8649 -- Start of processing for Freeze_Subprogram_Body
8652 -- If the instance and the generic body appear within the same unit, and
8653 -- the instance precedes the generic, the freeze node for the instance
8654 -- must appear after that of the generic. If the generic is nested
8655 -- within another instance I2, then current instance must be frozen
8656 -- after I2. In both cases, the freeze nodes are those of enclosing
8657 -- packages. Otherwise, the freeze node is placed at the end of the
8658 -- current declarative part.
8660 Enc_G
:= Enclosing_Package_Body
(Gen_Body
);
8661 Enc_I
:= Enclosing_Package_Body
(Inst_Node
);
8662 Ensure_Freeze_Node
(Pack_Id
);
8663 F_Node
:= Freeze_Node
(Pack_Id
);
8665 if Is_Generic_Instance
(Par
)
8666 and then Present
(Freeze_Node
(Par
))
8667 and then In_Same_Declarative_Part
(Freeze_Node
(Par
), Inst_Node
)
8669 -- The parent was a premature instantiation. Insert freeze node at
8670 -- the end the current declarative part.
8672 if Is_Known_Guaranteed_ABE
(Get_Unit_Instantiation_Node
(Par
)) then
8673 Insert_Freeze_Node_For_Instance
(Inst_Node
, F_Node
);
8675 -- Handle the following case:
8677 -- package Parent_Inst is new ...
8680 -- procedure P ... -- this body freezes Parent_Inst
8682 -- package Inst is new ...
8684 -- In this particular scenario, the freeze node for Inst must be
8685 -- inserted in the same manner as that of Parent_Inst - before the
8686 -- next source body or at the end of the declarative list (body not
8687 -- available). If body P did not exist and Parent_Inst was frozen
8688 -- after Inst, either by a body following Inst or at the end of the
8689 -- declarative region, the freeze node for Inst must be inserted
8690 -- after that of Parent_Inst. This relation is established by
8691 -- comparing the Slocs of Parent_Inst freeze node and Inst.
8693 elsif List_Containing
(Get_Unit_Instantiation_Node
(Par
)) =
8694 List_Containing
(Inst_Node
)
8695 and then Sloc
(Freeze_Node
(Par
)) < Sloc
(Inst_Node
)
8697 Insert_Freeze_Node_For_Instance
(Inst_Node
, F_Node
);
8700 Insert_After
(Freeze_Node
(Par
), F_Node
);
8703 -- The body enclosing the instance should be frozen after the body that
8704 -- includes the generic, because the body of the instance may make
8705 -- references to entities therein. If the two are not in the same
8706 -- declarative part, or if the one enclosing the instance is frozen
8707 -- already, freeze the instance at the end of the current declarative
8710 elsif Is_Generic_Instance
(Par
)
8711 and then Present
(Freeze_Node
(Par
))
8712 and then Present
(Enc_I
)
8714 if In_Same_Declarative_Part
(Freeze_Node
(Par
), Enc_I
)
8716 (Nkind
(Enc_I
) = N_Package_Body
8718 In_Same_Declarative_Part
(Freeze_Node
(Par
), Parent
(Enc_I
)))
8720 -- The enclosing package may contain several instances. Rather
8721 -- than computing the earliest point at which to insert its freeze
8722 -- node, we place it at the end of the declarative part of the
8723 -- parent of the generic.
8725 Insert_Freeze_Node_For_Instance
8726 (Freeze_Node
(Par
), Package_Freeze_Node
(Enc_I
));
8729 Insert_Freeze_Node_For_Instance
(Inst_Node
, F_Node
);
8731 elsif Present
(Enc_G
)
8732 and then Present
(Enc_I
)
8733 and then Enc_G
/= Enc_I
8734 and then Earlier
(Inst_Node
, Gen_Body
)
8736 if Nkind
(Enc_G
) = N_Package_Body
then
8738 Corresponding_Spec
(Enc_G
);
8739 else pragma Assert
(Nkind
(Enc_G
) = N_Package_Body_Stub
);
8741 Corresponding_Spec
(Proper_Body
(Unit
(Library_Unit
(Enc_G
))));
8744 -- Freeze package that encloses instance, and place node after the
8745 -- package that encloses generic. If enclosing package is already
8746 -- frozen we have to assume it is at the proper place. This may be a
8747 -- potential ABE that requires dynamic checking. Do not add a freeze
8748 -- node if the package that encloses the generic is inside the body
8749 -- that encloses the instance, because the freeze node would be in
8750 -- the wrong scope. Additional contortions needed if the bodies are
8751 -- within a subunit.
8754 Enclosing_Body
: Node_Id
;
8757 if Nkind
(Enc_I
) = N_Package_Body_Stub
then
8758 Enclosing_Body
:= Proper_Body
(Unit
(Library_Unit
(Enc_I
)));
8760 Enclosing_Body
:= Enc_I
;
8763 if Parent
(List_Containing
(Enc_G
)) /= Enclosing_Body
then
8764 Insert_Freeze_Node_For_Instance
8765 (Enc_G
, Package_Freeze_Node
(Enc_I
));
8769 -- Freeze enclosing subunit before instance
8771 Ensure_Freeze_Node
(E_G_Id
);
8773 if not Is_List_Member
(Freeze_Node
(E_G_Id
)) then
8774 Insert_After
(Enc_G
, Freeze_Node
(E_G_Id
));
8777 Insert_Freeze_Node_For_Instance
(Inst_Node
, F_Node
);
8780 -- If none of the above, insert freeze node at the end of the current
8781 -- declarative part.
8783 Insert_Freeze_Node_For_Instance
(Inst_Node
, F_Node
);
8785 end Freeze_Subprogram_Body
;
8791 function Get_Gen_Id
(E
: Assoc_Ptr
) return Entity_Id
is
8793 return Generic_Renamings
.Table
(E
).Gen_Id
;
8796 ---------------------
8797 -- Get_Instance_Of --
8798 ---------------------
8800 function Get_Instance_Of
(A
: Entity_Id
) return Entity_Id
is
8801 Res
: constant Assoc_Ptr
:= Generic_Renamings_HTable
.Get
(A
);
8804 if Res
/= Assoc_Null
then
8805 return Generic_Renamings
.Table
(Res
).Act_Id
;
8808 -- On exit, entity is not instantiated: not a generic parameter, or
8809 -- else parameter of an inner generic unit.
8813 end Get_Instance_Of
;
8815 ---------------------------------
8816 -- Get_Unit_Instantiation_Node --
8817 ---------------------------------
8819 function Get_Unit_Instantiation_Node
(A
: Entity_Id
) return Node_Id
is
8820 Decl
: Node_Id
:= Unit_Declaration_Node
(A
);
8824 -- If the Package_Instantiation attribute has been set on the package
8825 -- entity, then use it directly when it (or its Original_Node) refers
8826 -- to an N_Package_Instantiation node. In principle it should be
8827 -- possible to have this field set in all cases, which should be
8828 -- investigated, and would allow this function to be significantly
8831 Inst
:= Package_Instantiation
(A
);
8833 if Present
(Inst
) then
8834 if Nkind
(Inst
) = N_Package_Instantiation
then
8837 elsif Nkind
(Original_Node
(Inst
)) = N_Package_Instantiation
then
8838 return Original_Node
(Inst
);
8842 -- If the instantiation is a compilation unit that does not need body
8843 -- then the instantiation node has been rewritten as a package
8844 -- declaration for the instance, and we return the original node.
8846 -- If it is a compilation unit and the instance node has not been
8847 -- rewritten, then it is still the unit of the compilation. Finally, if
8848 -- a body is present, this is a parent of the main unit whose body has
8849 -- been compiled for inlining purposes, and the instantiation node has
8850 -- been rewritten with the instance body.
8852 -- Otherwise the instantiation node appears after the declaration. If
8853 -- the entity is a formal package, the declaration may have been
8854 -- rewritten as a generic declaration (in the case of a formal with box)
8855 -- or left as a formal package declaration if it has actuals, and is
8856 -- found with a forward search.
8858 if Nkind
(Parent
(Decl
)) = N_Compilation_Unit
then
8859 if Nkind
(Decl
) = N_Package_Declaration
8860 and then Present
(Corresponding_Body
(Decl
))
8862 Decl
:= Unit_Declaration_Node
(Corresponding_Body
(Decl
));
8865 if Nkind_In
(Original_Node
(Decl
), N_Function_Instantiation
,
8866 N_Package_Instantiation
,
8867 N_Procedure_Instantiation
)
8869 return Original_Node
(Decl
);
8871 return Unit
(Parent
(Decl
));
8874 elsif Nkind
(Decl
) = N_Package_Declaration
8875 and then Nkind
(Original_Node
(Decl
)) = N_Formal_Package_Declaration
8877 return Original_Node
(Decl
);
8880 Inst
:= Next
(Decl
);
8881 while not Nkind_In
(Inst
, N_Formal_Package_Declaration
,
8882 N_Function_Instantiation
,
8883 N_Package_Instantiation
,
8884 N_Procedure_Instantiation
)
8891 end Get_Unit_Instantiation_Node
;
8893 ------------------------
8894 -- Has_Been_Exchanged --
8895 ------------------------
8897 function Has_Been_Exchanged
(E
: Entity_Id
) return Boolean is
8901 Next
:= First_Elmt
(Exchanged_Views
);
8902 while Present
(Next
) loop
8903 if Full_View
(Node
(Next
)) = E
then
8911 end Has_Been_Exchanged
;
8917 function Hash
(F
: Entity_Id
) return HTable_Range
is
8919 return HTable_Range
(F
mod HTable_Size
);
8922 ------------------------
8923 -- Hide_Current_Scope --
8924 ------------------------
8926 procedure Hide_Current_Scope
is
8927 C
: constant Entity_Id
:= Current_Scope
;
8931 Set_Is_Hidden_Open_Scope
(C
);
8933 E
:= First_Entity
(C
);
8934 while Present
(E
) loop
8935 if Is_Immediately_Visible
(E
) then
8936 Set_Is_Immediately_Visible
(E
, False);
8937 Append_Elmt
(E
, Hidden_Entities
);
8943 -- Make the scope name invisible as well. This is necessary, but might
8944 -- conflict with calls to Rtsfind later on, in case the scope is a
8945 -- predefined one. There is no clean solution to this problem, so for
8946 -- now we depend on the user not redefining Standard itself in one of
8947 -- the parent units.
8949 if Is_Immediately_Visible
(C
) and then C
/= Standard_Standard
then
8950 Set_Is_Immediately_Visible
(C
, False);
8951 Append_Elmt
(C
, Hidden_Entities
);
8954 end Hide_Current_Scope
;
8960 procedure Init_Env
is
8961 Saved
: Instance_Env
;
8964 Saved
.Instantiated_Parent
:= Current_Instantiated_Parent
;
8965 Saved
.Exchanged_Views
:= Exchanged_Views
;
8966 Saved
.Hidden_Entities
:= Hidden_Entities
;
8967 Saved
.Current_Sem_Unit
:= Current_Sem_Unit
;
8968 Saved
.Parent_Unit_Visible
:= Parent_Unit_Visible
;
8969 Saved
.Instance_Parent_Unit
:= Instance_Parent_Unit
;
8971 -- Save configuration switches. These may be reset if the unit is a
8972 -- predefined unit, and the current mode is not Ada 2005.
8974 Save_Opt_Config_Switches
(Saved
.Switches
);
8976 Instance_Envs
.Append
(Saved
);
8978 Exchanged_Views
:= New_Elmt_List
;
8979 Hidden_Entities
:= New_Elmt_List
;
8981 -- Make dummy entry for Instantiated parent. If generic unit is legal,
8982 -- this is set properly in Set_Instance_Env.
8984 Current_Instantiated_Parent
:=
8985 (Current_Scope
, Current_Scope
, Assoc_Null
);
8988 ------------------------------
8989 -- In_Same_Declarative_Part --
8990 ------------------------------
8992 function In_Same_Declarative_Part
8994 Inst
: Node_Id
) return Boolean
8996 Decls
: constant Node_Id
:= Parent
(F_Node
);
9000 Nod
:= Parent
(Inst
);
9001 while Present
(Nod
) loop
9005 elsif Nkind_In
(Nod
, N_Subprogram_Body
,
9007 N_Package_Declaration
,
9014 elsif Nkind
(Nod
) = N_Subunit
then
9015 Nod
:= Corresponding_Stub
(Nod
);
9017 elsif Nkind
(Nod
) = N_Compilation_Unit
then
9021 Nod
:= Parent
(Nod
);
9026 end In_Same_Declarative_Part
;
9028 ---------------------
9029 -- In_Main_Context --
9030 ---------------------
9032 function In_Main_Context
(E
: Entity_Id
) return Boolean is
9038 if not Is_Compilation_Unit
(E
)
9039 or else Ekind
(E
) /= E_Package
9040 or else In_Private_Part
(E
)
9045 Context
:= Context_Items
(Cunit
(Main_Unit
));
9047 Clause
:= First
(Context
);
9048 while Present
(Clause
) loop
9049 if Nkind
(Clause
) = N_With_Clause
then
9050 Nam
:= Name
(Clause
);
9052 -- If the current scope is part of the context of the main unit,
9053 -- analysis of the corresponding with_clause is not complete, and
9054 -- the entity is not set. We use the Chars field directly, which
9055 -- might produce false positives in rare cases, but guarantees
9056 -- that we produce all the instance bodies we will need.
9058 if (Is_Entity_Name
(Nam
) and then Chars
(Nam
) = Chars
(E
))
9059 or else (Nkind
(Nam
) = N_Selected_Component
9060 and then Chars
(Selector_Name
(Nam
)) = Chars
(E
))
9070 end In_Main_Context
;
9072 ---------------------
9073 -- Inherit_Context --
9074 ---------------------
9076 procedure Inherit_Context
(Gen_Decl
: Node_Id
; Inst
: Node_Id
) is
9077 Current_Context
: List_Id
;
9078 Current_Unit
: Node_Id
;
9087 if Nkind
(Parent
(Gen_Decl
)) = N_Compilation_Unit
then
9089 -- The inherited context is attached to the enclosing compilation
9090 -- unit. This is either the main unit, or the declaration for the
9091 -- main unit (in case the instantiation appears within the package
9092 -- declaration and the main unit is its body).
9094 Current_Unit
:= Parent
(Inst
);
9095 while Present
(Current_Unit
)
9096 and then Nkind
(Current_Unit
) /= N_Compilation_Unit
9098 Current_Unit
:= Parent
(Current_Unit
);
9101 Current_Context
:= Context_Items
(Current_Unit
);
9103 Item
:= First
(Context_Items
(Parent
(Gen_Decl
)));
9104 while Present
(Item
) loop
9105 if Nkind
(Item
) = N_With_Clause
then
9106 Lib_Unit
:= Library_Unit
(Item
);
9108 -- Take care to prevent direct cyclic with's
9110 if Lib_Unit
/= Current_Unit
then
9112 -- Do not add a unit if it is already in the context
9114 Clause
:= First
(Current_Context
);
9116 while Present
(Clause
) loop
9117 if Nkind
(Clause
) = N_With_Clause
9118 and then Library_Unit
(Clause
) = Lib_Unit
9128 New_I
:= New_Copy
(Item
);
9129 Set_Implicit_With
(New_I
);
9131 Append
(New_I
, Current_Context
);
9139 end Inherit_Context
;
9145 procedure Initialize
is
9147 Generic_Renamings
.Init
;
9150 Generic_Renamings_HTable
.Reset
;
9151 Circularity_Detected
:= False;
9152 Exchanged_Views
:= No_Elist
;
9153 Hidden_Entities
:= No_Elist
;
9156 -------------------------------------
9157 -- Insert_Freeze_Node_For_Instance --
9158 -------------------------------------
9160 procedure Insert_Freeze_Node_For_Instance
9169 function Enclosing_Body
(N
: Node_Id
) return Node_Id
;
9170 -- Find enclosing package or subprogram body, if any. Freeze node may
9171 -- be placed at end of current declarative list if previous instance
9172 -- and current one have different enclosing bodies.
9174 function Previous_Instance
(Gen
: Entity_Id
) return Entity_Id
;
9175 -- Find the local instance, if any, that declares the generic that is
9176 -- being instantiated. If present, the freeze node for this instance
9177 -- must follow the freeze node for the previous instance.
9179 --------------------
9180 -- Enclosing_Body --
9181 --------------------
9183 function Enclosing_Body
(N
: Node_Id
) return Node_Id
is
9189 and then Nkind
(Parent
(P
)) /= N_Compilation_Unit
9191 if Nkind_In
(P
, N_Package_Body
, N_Subprogram_Body
) then
9192 if Nkind
(Parent
(P
)) = N_Subunit
then
9193 return Corresponding_Stub
(Parent
(P
));
9199 P
:= True_Parent
(P
);
9205 -----------------------
9206 -- Previous_Instance --
9207 -----------------------
9209 function Previous_Instance
(Gen
: Entity_Id
) return Entity_Id
is
9214 while Present
(S
) and then S
/= Standard_Standard
loop
9215 if Is_Generic_Instance
(S
)
9216 and then In_Same_Source_Unit
(S
, N
)
9225 end Previous_Instance
;
9227 -- Start of processing for Insert_Freeze_Node_For_Instance
9230 if not Is_List_Member
(F_Node
) then
9232 Decls
:= List_Containing
(N
);
9233 Inst
:= Entity
(F_Node
);
9234 Par_N
:= Parent
(Decls
);
9236 -- When processing a subprogram instantiation, utilize the actual
9237 -- subprogram instantiation rather than its package wrapper as it
9238 -- carries all the context information.
9240 if Is_Wrapper_Package
(Inst
) then
9241 Inst
:= Related_Instance
(Inst
);
9244 -- If this is a package instance, check whether the generic is
9245 -- declared in a previous instance and the current instance is
9246 -- not within the previous one.
9248 if Present
(Generic_Parent
(Parent
(Inst
)))
9249 and then Is_In_Main_Unit
(N
)
9252 Enclosing_N
: constant Node_Id
:= Enclosing_Body
(N
);
9253 Par_I
: constant Entity_Id
:=
9255 (Generic_Parent
(Parent
(Inst
)));
9260 and then Earlier
(N
, Freeze_Node
(Par_I
))
9262 Scop
:= Scope
(Inst
);
9264 -- If the current instance is within the one that contains
9265 -- the generic, the freeze node for the current one must
9266 -- appear in the current declarative part. Ditto, if the
9267 -- current instance is within another package instance or
9268 -- within a body that does not enclose the current instance.
9269 -- In these three cases the freeze node of the previous
9270 -- instance is not relevant.
9272 while Present
(Scop
) and then Scop
/= Standard_Standard
loop
9273 exit when Scop
= Par_I
9275 (Is_Generic_Instance
(Scop
)
9276 and then Scope_Depth
(Scop
) > Scope_Depth
(Par_I
));
9277 Scop
:= Scope
(Scop
);
9280 -- Previous instance encloses current instance
9282 if Scop
= Par_I
then
9285 -- If the next node is a source body we must freeze in
9286 -- the current scope as well.
9288 elsif Present
(Next
(N
))
9289 and then Nkind_In
(Next
(N
), N_Subprogram_Body
,
9291 and then Comes_From_Source
(Next
(N
))
9295 -- Current instance is within an unrelated instance
9297 elsif Is_Generic_Instance
(Scop
) then
9300 -- Current instance is within an unrelated body
9302 elsif Present
(Enclosing_N
)
9303 and then Enclosing_N
/= Enclosing_Body
(Par_I
)
9308 Insert_After
(Freeze_Node
(Par_I
), F_Node
);
9315 -- When the instantiation occurs in a package declaration, append the
9316 -- freeze node to the private declarations (if any).
9318 if Nkind
(Par_N
) = N_Package_Specification
9319 and then Decls
= Visible_Declarations
(Par_N
)
9320 and then Present
(Private_Declarations
(Par_N
))
9321 and then not Is_Empty_List
(Private_Declarations
(Par_N
))
9323 Decls
:= Private_Declarations
(Par_N
);
9324 Decl
:= First
(Decls
);
9327 -- Determine the proper freeze point of a package instantiation. We
9328 -- adhere to the general rule of a package or subprogram body causing
9329 -- freezing of anything before it in the same declarative region. In
9330 -- this case, the proper freeze point of a package instantiation is
9331 -- before the first source body which follows, or before a stub. This
9332 -- ensures that entities coming from the instance are already frozen
9333 -- and usable in source bodies.
9335 if Nkind
(Par_N
) /= N_Package_Declaration
9336 and then Ekind
(Inst
) = E_Package
9337 and then Is_Generic_Instance
(Inst
)
9339 not In_Same_Source_Unit
(Generic_Parent
(Parent
(Inst
)), Inst
)
9341 while Present
(Decl
) loop
9342 if (Nkind
(Decl
) in N_Unit_Body
9344 Nkind
(Decl
) in N_Body_Stub
)
9345 and then Comes_From_Source
(Decl
)
9347 Insert_Before
(Decl
, F_Node
);
9355 -- In a package declaration, or if no previous body, insert at end
9358 Set_Sloc
(F_Node
, Sloc
(Last
(Decls
)));
9359 Insert_After
(Last
(Decls
), F_Node
);
9361 end Insert_Freeze_Node_For_Instance
;
9367 procedure Install_Body
9368 (Act_Body
: Node_Id
;
9373 function In_Same_Scope
(Gen_Id
, Act_Id
: Node_Id
) return Boolean;
9374 -- Check if the generic definition and the instantiation come from
9375 -- a common scope, in which case the instance must be frozen after
9376 -- the generic body.
9378 function True_Sloc
(N
, Act_Unit
: Node_Id
) return Source_Ptr
;
9379 -- If the instance is nested inside a generic unit, the Sloc of the
9380 -- instance indicates the place of the original definition, not the
9381 -- point of the current enclosing instance. Pending a better usage of
9382 -- Slocs to indicate instantiation places, we determine the place of
9383 -- origin of a node by finding the maximum sloc of any ancestor node.
9384 -- Why is this not equivalent to Top_Level_Location ???
9390 function In_Same_Scope
(Gen_Id
, Act_Id
: Node_Id
) return Boolean is
9391 Act_Scop
: Entity_Id
:= Scope
(Act_Id
);
9392 Gen_Scop
: Entity_Id
:= Scope
(Gen_Id
);
9395 while Act_Scop
/= Standard_Standard
9396 and then Gen_Scop
/= Standard_Standard
9398 if Act_Scop
= Gen_Scop
then
9402 Act_Scop
:= Scope
(Act_Scop
);
9403 Gen_Scop
:= Scope
(Gen_Scop
);
9413 function True_Sloc
(N
, Act_Unit
: Node_Id
) return Source_Ptr
is
9420 while Present
(N1
) and then N1
/= Act_Unit
loop
9421 if Sloc
(N1
) > Res
then
9431 Act_Id
: constant Entity_Id
:= Corresponding_Spec
(Act_Body
);
9432 Act_Unit
: constant Node_Id
:= Unit
(Cunit
(Get_Source_Unit
(N
)));
9433 Gen_Id
: constant Entity_Id
:= Corresponding_Spec
(Gen_Body
);
9434 Par
: constant Entity_Id
:= Scope
(Gen_Id
);
9435 Gen_Unit
: constant Node_Id
:=
9436 Unit
(Cunit
(Get_Source_Unit
(Gen_Decl
)));
9438 Body_Unit
: Node_Id
;
9440 Must_Delay
: Boolean;
9441 Orig_Body
: Node_Id
:= Gen_Body
;
9443 -- Start of processing for Install_Body
9446 -- Handle first the case of an instance with incomplete actual types.
9447 -- The instance body cannot be placed after the declaration because
9448 -- full views have not been seen yet. Any use of the non-limited views
9449 -- in the instance body requires the presence of a regular with_clause
9450 -- in the enclosing unit, and will fail if this with_clause is missing.
9451 -- We place the instance body at the beginning of the enclosing body,
9452 -- which is the unit being compiled. The freeze node for the instance
9453 -- is then placed after the instance body.
9455 if not Is_Empty_Elmt_List
(Incomplete_Actuals
(Act_Id
))
9456 and then Expander_Active
9457 and then Ekind
(Scope
(Act_Id
)) = E_Package
9460 Scop
: constant Entity_Id
:= Scope
(Act_Id
);
9461 Body_Id
: constant Node_Id
:=
9462 Corresponding_Body
(Unit_Declaration_Node
(Scop
));
9465 Ensure_Freeze_Node
(Act_Id
);
9466 F_Node
:= Freeze_Node
(Act_Id
);
9467 if Present
(Body_Id
) then
9468 Set_Is_Frozen
(Act_Id
, False);
9469 Prepend
(Act_Body
, Declarations
(Parent
(Body_Id
)));
9470 if Is_List_Member
(F_Node
) then
9474 Insert_After
(Act_Body
, F_Node
);
9480 -- If the body is a subunit, the freeze point is the corresponding stub
9481 -- in the current compilation, not the subunit itself.
9483 if Nkind
(Parent
(Gen_Body
)) = N_Subunit
then
9484 Orig_Body
:= Corresponding_Stub
(Parent
(Gen_Body
));
9486 Orig_Body
:= Gen_Body
;
9489 Body_Unit
:= Unit
(Cunit
(Get_Source_Unit
(Orig_Body
)));
9491 -- If the instantiation and the generic definition appear in the same
9492 -- package declaration, this is an early instantiation. If they appear
9493 -- in the same declarative part, it is an early instantiation only if
9494 -- the generic body appears textually later, and the generic body is
9495 -- also in the main unit.
9497 -- If instance is nested within a subprogram, and the generic body
9498 -- is not, the instance is delayed because the enclosing body is. If
9499 -- instance and body are within the same scope, or the same subprogram
9500 -- body, indicate explicitly that the instance is delayed.
9503 (Gen_Unit
= Act_Unit
9504 and then (Nkind_In
(Gen_Unit
, N_Generic_Package_Declaration
,
9505 N_Package_Declaration
)
9506 or else (Gen_Unit
= Body_Unit
9507 and then True_Sloc
(N
, Act_Unit
) <
9509 and then Is_In_Main_Unit
(Original_Node
(Gen_Unit
))
9510 and then In_Same_Scope
(Gen_Id
, Act_Id
));
9512 -- If this is an early instantiation, the freeze node is placed after
9513 -- the generic body. Otherwise, if the generic appears in an instance,
9514 -- we cannot freeze the current instance until the outer one is frozen.
9515 -- This is only relevant if the current instance is nested within some
9516 -- inner scope not itself within the outer instance. If this scope is
9517 -- a package body in the same declarative part as the outer instance,
9518 -- then that body needs to be frozen after the outer instance. Finally,
9519 -- if no delay is needed, we place the freeze node at the end of the
9520 -- current declarative part.
9523 and then (No
(Freeze_Node
(Act_Id
))
9524 or else not Is_List_Member
(Freeze_Node
(Act_Id
)))
9526 Ensure_Freeze_Node
(Act_Id
);
9527 F_Node
:= Freeze_Node
(Act_Id
);
9530 Insert_After
(Orig_Body
, F_Node
);
9532 elsif Is_Generic_Instance
(Par
)
9533 and then Present
(Freeze_Node
(Par
))
9534 and then Scope
(Act_Id
) /= Par
9536 -- Freeze instance of inner generic after instance of enclosing
9539 if In_Same_Declarative_Part
(Freeze_Node
(Par
), N
) then
9541 -- Handle the following case:
9543 -- package Parent_Inst is new ...
9546 -- procedure P ... -- this body freezes Parent_Inst
9548 -- package Inst is new ...
9550 -- In this particular scenario, the freeze node for Inst must
9551 -- be inserted in the same manner as that of Parent_Inst,
9552 -- before the next source body or at the end of the declarative
9553 -- list (body not available). If body P did not exist and
9554 -- Parent_Inst was frozen after Inst, either by a body
9555 -- following Inst or at the end of the declarative region,
9556 -- the freeze node for Inst must be inserted after that of
9557 -- Parent_Inst. This relation is established by comparing
9558 -- the Slocs of Parent_Inst freeze node and Inst.
9560 if List_Containing
(Get_Unit_Instantiation_Node
(Par
)) =
9562 and then Sloc
(Freeze_Node
(Par
)) < Sloc
(N
)
9564 Insert_Freeze_Node_For_Instance
(N
, F_Node
);
9566 Insert_After
(Freeze_Node
(Par
), F_Node
);
9569 -- Freeze package enclosing instance of inner generic after
9570 -- instance of enclosing generic.
9572 elsif Nkind_In
(Parent
(N
), N_Package_Body
, N_Subprogram_Body
)
9573 and then In_Same_Declarative_Part
(Freeze_Node
(Par
), Parent
(N
))
9576 Enclosing
: Entity_Id
;
9579 Enclosing
:= Corresponding_Spec
(Parent
(N
));
9581 if No
(Enclosing
) then
9582 Enclosing
:= Defining_Entity
(Parent
(N
));
9585 Insert_Freeze_Node_For_Instance
(N
, F_Node
);
9586 Ensure_Freeze_Node
(Enclosing
);
9588 if not Is_List_Member
(Freeze_Node
(Enclosing
)) then
9590 -- The enclosing context is a subunit, insert the freeze
9591 -- node after the stub.
9593 if Nkind
(Parent
(Parent
(N
))) = N_Subunit
then
9594 Insert_Freeze_Node_For_Instance
9595 (Corresponding_Stub
(Parent
(Parent
(N
))),
9596 Freeze_Node
(Enclosing
));
9598 -- The enclosing context is a package with a stub body
9599 -- which has already been replaced by the real body.
9600 -- Insert the freeze node after the actual body.
9602 elsif Ekind
(Enclosing
) = E_Package
9603 and then Present
(Body_Entity
(Enclosing
))
9604 and then Was_Originally_Stub
9605 (Parent
(Body_Entity
(Enclosing
)))
9607 Insert_Freeze_Node_For_Instance
9608 (Parent
(Body_Entity
(Enclosing
)),
9609 Freeze_Node
(Enclosing
));
9611 -- The parent instance has been frozen before the body of
9612 -- the enclosing package, insert the freeze node after
9615 elsif List_Containing
(Freeze_Node
(Par
)) =
9616 List_Containing
(Parent
(N
))
9617 and then Sloc
(Freeze_Node
(Par
)) < Sloc
(Parent
(N
))
9619 Insert_Freeze_Node_For_Instance
9620 (Parent
(N
), Freeze_Node
(Enclosing
));
9624 (Freeze_Node
(Par
), Freeze_Node
(Enclosing
));
9630 Insert_Freeze_Node_For_Instance
(N
, F_Node
);
9634 Insert_Freeze_Node_For_Instance
(N
, F_Node
);
9638 Set_Is_Frozen
(Act_Id
);
9639 Insert_Before
(N
, Act_Body
);
9640 Mark_Rewrite_Insertion
(Act_Body
);
9643 -----------------------------
9644 -- Install_Formal_Packages --
9645 -----------------------------
9647 procedure Install_Formal_Packages
(Par
: Entity_Id
) is
9650 Gen_E
: Entity_Id
:= Empty
;
9653 E
:= First_Entity
(Par
);
9655 -- If we are installing an instance parent, locate the formal packages
9656 -- of its generic parent.
9658 if Is_Generic_Instance
(Par
) then
9659 Gen
:= Generic_Parent
(Package_Specification
(Par
));
9660 Gen_E
:= First_Entity
(Gen
);
9663 while Present
(E
) loop
9664 if Ekind
(E
) = E_Package
9665 and then Nkind
(Parent
(E
)) = N_Package_Renaming_Declaration
9667 -- If this is the renaming for the parent instance, done
9669 if Renamed_Object
(E
) = Par
then
9672 -- The visibility of a formal of an enclosing generic is already
9675 elsif Denotes_Formal_Package
(E
) then
9678 elsif Present
(Associated_Formal_Package
(E
)) then
9679 Check_Generic_Actuals
(Renamed_Object
(E
), True);
9680 Set_Is_Hidden
(E
, False);
9682 -- Find formal package in generic unit that corresponds to
9683 -- (instance of) formal package in instance.
9685 while Present
(Gen_E
) and then Chars
(Gen_E
) /= Chars
(E
) loop
9686 Next_Entity
(Gen_E
);
9689 if Present
(Gen_E
) then
9690 Map_Formal_Package_Entities
(Gen_E
, E
);
9697 if Present
(Gen_E
) then
9698 Next_Entity
(Gen_E
);
9701 end Install_Formal_Packages
;
9703 --------------------
9704 -- Install_Parent --
9705 --------------------
9707 procedure Install_Parent
(P
: Entity_Id
; In_Body
: Boolean := False) is
9708 Ancestors
: constant Elist_Id
:= New_Elmt_List
;
9709 S
: constant Entity_Id
:= Current_Scope
;
9710 Inst_Par
: Entity_Id
;
9711 First_Par
: Entity_Id
;
9712 Inst_Node
: Node_Id
;
9713 Gen_Par
: Entity_Id
;
9714 First_Gen
: Entity_Id
;
9717 procedure Install_Noninstance_Specs
(Par
: Entity_Id
);
9718 -- Install the scopes of noninstance parent units ending with Par
9720 procedure Install_Spec
(Par
: Entity_Id
);
9721 -- The child unit is within the declarative part of the parent, so the
9722 -- declarations within the parent are immediately visible.
9724 -------------------------------
9725 -- Install_Noninstance_Specs --
9726 -------------------------------
9728 procedure Install_Noninstance_Specs
(Par
: Entity_Id
) is
9731 and then Par
/= Standard_Standard
9732 and then not In_Open_Scopes
(Par
)
9734 Install_Noninstance_Specs
(Scope
(Par
));
9737 end Install_Noninstance_Specs
;
9743 procedure Install_Spec
(Par
: Entity_Id
) is
9744 Spec
: constant Node_Id
:= Package_Specification
(Par
);
9747 -- If this parent of the child instance is a top-level unit,
9748 -- then record the unit and its visibility for later resetting in
9749 -- Remove_Parent. We exclude units that are generic instances, as we
9750 -- only want to record this information for the ultimate top-level
9751 -- noninstance parent (is that always correct???).
9753 if Scope
(Par
) = Standard_Standard
9754 and then not Is_Generic_Instance
(Par
)
9756 Parent_Unit_Visible
:= Is_Immediately_Visible
(Par
);
9757 Instance_Parent_Unit
:= Par
;
9760 -- Open the parent scope and make it and its declarations visible.
9761 -- If this point is not within a body, then only the visible
9762 -- declarations should be made visible, and installation of the
9763 -- private declarations is deferred until the appropriate point
9764 -- within analysis of the spec being instantiated (see the handling
9765 -- of parent visibility in Analyze_Package_Specification). This is
9766 -- relaxed in the case where the parent unit is Ada.Tags, to avoid
9767 -- private view problems that occur when compiling instantiations of
9768 -- a generic child of that package (Generic_Dispatching_Constructor).
9769 -- If the instance freezes a tagged type, inlinings of operations
9770 -- from Ada.Tags may need the full view of type Tag. If inlining took
9771 -- proper account of establishing visibility of inlined subprograms'
9772 -- parents then it should be possible to remove this
9773 -- special check. ???
9776 Set_Is_Immediately_Visible
(Par
);
9777 Install_Visible_Declarations
(Par
);
9778 Set_Use
(Visible_Declarations
(Spec
));
9780 if In_Body
or else Is_RTU
(Par
, Ada_Tags
) then
9781 Install_Private_Declarations
(Par
);
9782 Set_Use
(Private_Declarations
(Spec
));
9786 -- Start of processing for Install_Parent
9789 -- We need to install the parent instance to compile the instantiation
9790 -- of the child, but the child instance must appear in the current
9791 -- scope. Given that we cannot place the parent above the current scope
9792 -- in the scope stack, we duplicate the current scope and unstack both
9793 -- after the instantiation is complete.
9795 -- If the parent is itself the instantiation of a child unit, we must
9796 -- also stack the instantiation of its parent, and so on. Each such
9797 -- ancestor is the prefix of the name in a prior instantiation.
9799 -- If this is a nested instance, the parent unit itself resolves to
9800 -- a renaming of the parent instance, whose declaration we need.
9802 -- Finally, the parent may be a generic (not an instance) when the
9803 -- child unit appears as a formal package.
9807 if Present
(Renamed_Entity
(Inst_Par
)) then
9808 Inst_Par
:= Renamed_Entity
(Inst_Par
);
9811 First_Par
:= Inst_Par
;
9813 Gen_Par
:= Generic_Parent
(Package_Specification
(Inst_Par
));
9815 First_Gen
:= Gen_Par
;
9817 while Present
(Gen_Par
) and then Is_Child_Unit
(Gen_Par
) loop
9819 -- Load grandparent instance as well
9821 Inst_Node
:= Get_Unit_Instantiation_Node
(Inst_Par
);
9823 if Nkind
(Name
(Inst_Node
)) = N_Expanded_Name
then
9824 Inst_Par
:= Entity
(Prefix
(Name
(Inst_Node
)));
9826 if Present
(Renamed_Entity
(Inst_Par
)) then
9827 Inst_Par
:= Renamed_Entity
(Inst_Par
);
9830 Gen_Par
:= Generic_Parent
(Package_Specification
(Inst_Par
));
9832 if Present
(Gen_Par
) then
9833 Prepend_Elmt
(Inst_Par
, Ancestors
);
9836 -- Parent is not the name of an instantiation
9838 Install_Noninstance_Specs
(Inst_Par
);
9849 if Present
(First_Gen
) then
9850 Append_Elmt
(First_Par
, Ancestors
);
9852 Install_Noninstance_Specs
(First_Par
);
9855 if not Is_Empty_Elmt_List
(Ancestors
) then
9856 Elmt
:= First_Elmt
(Ancestors
);
9857 while Present
(Elmt
) loop
9858 Install_Spec
(Node
(Elmt
));
9859 Install_Formal_Packages
(Node
(Elmt
));
9869 -------------------------------
9870 -- Install_Hidden_Primitives --
9871 -------------------------------
9873 procedure Install_Hidden_Primitives
9874 (Prims_List
: in out Elist_Id
;
9879 List
: Elist_Id
:= No_Elist
;
9880 Prim_G_Elmt
: Elmt_Id
;
9881 Prim_A_Elmt
: Elmt_Id
;
9886 -- No action needed in case of serious errors because we cannot trust
9887 -- in the order of primitives
9889 if Serious_Errors_Detected
> 0 then
9892 -- No action possible if we don't have available the list of primitive
9896 or else not Is_Record_Type
(Gen_T
)
9897 or else not Is_Tagged_Type
(Gen_T
)
9898 or else not Is_Record_Type
(Act_T
)
9899 or else not Is_Tagged_Type
(Act_T
)
9903 -- There is no need to handle interface types since their primitives
9906 elsif Is_Interface
(Gen_T
) then
9910 Prim_G_Elmt
:= First_Elmt
(Primitive_Operations
(Gen_T
));
9912 if not Is_Class_Wide_Type
(Act_T
) then
9913 Prim_A_Elmt
:= First_Elmt
(Primitive_Operations
(Act_T
));
9915 Prim_A_Elmt
:= First_Elmt
(Primitive_Operations
(Root_Type
(Act_T
)));
9919 -- Skip predefined primitives in the generic formal
9921 while Present
(Prim_G_Elmt
)
9922 and then Is_Predefined_Dispatching_Operation
(Node
(Prim_G_Elmt
))
9924 Next_Elmt
(Prim_G_Elmt
);
9927 -- Skip predefined primitives in the generic actual
9929 while Present
(Prim_A_Elmt
)
9930 and then Is_Predefined_Dispatching_Operation
(Node
(Prim_A_Elmt
))
9932 Next_Elmt
(Prim_A_Elmt
);
9935 exit when No
(Prim_G_Elmt
) or else No
(Prim_A_Elmt
);
9937 Prim_G
:= Node
(Prim_G_Elmt
);
9938 Prim_A
:= Node
(Prim_A_Elmt
);
9940 -- There is no need to handle interface primitives because their
9941 -- primitives are not hidden
9943 exit when Present
(Interface_Alias
(Prim_G
));
9945 -- Here we install one hidden primitive
9947 if Chars
(Prim_G
) /= Chars
(Prim_A
)
9948 and then Has_Suffix
(Prim_A
, 'P')
9949 and then Remove_Suffix
(Prim_A
, 'P') = Chars
(Prim_G
)
9951 Set_Chars
(Prim_A
, Chars
(Prim_G
));
9952 Append_New_Elmt
(Prim_A
, To
=> List
);
9955 Next_Elmt
(Prim_A_Elmt
);
9956 Next_Elmt
(Prim_G_Elmt
);
9959 -- Append the elements to the list of temporarily visible primitives
9960 -- avoiding duplicates.
9962 if Present
(List
) then
9963 if No
(Prims_List
) then
9964 Prims_List
:= New_Elmt_List
;
9967 Elmt
:= First_Elmt
(List
);
9968 while Present
(Elmt
) loop
9969 Append_Unique_Elmt
(Node
(Elmt
), Prims_List
);
9973 end Install_Hidden_Primitives
;
9975 -------------------------------
9976 -- Restore_Hidden_Primitives --
9977 -------------------------------
9979 procedure Restore_Hidden_Primitives
(Prims_List
: in out Elist_Id
) is
9980 Prim_Elmt
: Elmt_Id
;
9984 if Prims_List
/= No_Elist
then
9985 Prim_Elmt
:= First_Elmt
(Prims_List
);
9986 while Present
(Prim_Elmt
) loop
9987 Prim
:= Node
(Prim_Elmt
);
9988 Set_Chars
(Prim
, Add_Suffix
(Prim
, 'P'));
9989 Next_Elmt
(Prim_Elmt
);
9992 Prims_List
:= No_Elist
;
9994 end Restore_Hidden_Primitives
;
9996 --------------------------------
9997 -- Instantiate_Formal_Package --
9998 --------------------------------
10000 function Instantiate_Formal_Package
10003 Analyzed_Formal
: Node_Id
) return List_Id
10005 Loc
: constant Source_Ptr
:= Sloc
(Actual
);
10006 Actual_Pack
: Entity_Id
;
10007 Formal_Pack
: Entity_Id
;
10008 Gen_Parent
: Entity_Id
;
10011 Parent_Spec
: Node_Id
;
10013 procedure Find_Matching_Actual
10015 Act
: in out Entity_Id
);
10016 -- We need to associate each formal entity in the formal package with
10017 -- the corresponding entity in the actual package. The actual package
10018 -- has been analyzed and possibly expanded, and as a result there is
10019 -- no one-to-one correspondence between the two lists (for example,
10020 -- the actual may include subtypes, itypes, and inherited primitive
10021 -- operations, interspersed among the renaming declarations for the
10022 -- actuals). We retrieve the corresponding actual by name because each
10023 -- actual has the same name as the formal, and they do appear in the
10026 function Get_Formal_Entity
(N
: Node_Id
) return Entity_Id
;
10027 -- Retrieve entity of defining entity of generic formal parameter.
10028 -- Only the declarations of formals need to be considered when
10029 -- linking them to actuals, but the declarative list may include
10030 -- internal entities generated during analysis, and those are ignored.
10032 procedure Match_Formal_Entity
10033 (Formal_Node
: Node_Id
;
10034 Formal_Ent
: Entity_Id
;
10035 Actual_Ent
: Entity_Id
);
10036 -- Associates the formal entity with the actual. In the case where
10037 -- Formal_Ent is a formal package, this procedure iterates through all
10038 -- of its formals and enters associations between the actuals occurring
10039 -- in the formal package's corresponding actual package (given by
10040 -- Actual_Ent) and the formal package's formal parameters. This
10041 -- procedure recurses if any of the parameters is itself a package.
10043 function Is_Instance_Of
10044 (Act_Spec
: Entity_Id
;
10045 Gen_Anc
: Entity_Id
) return Boolean;
10046 -- The actual can be an instantiation of a generic within another
10047 -- instance, in which case there is no direct link from it to the
10048 -- original generic ancestor. In that case, we recognize that the
10049 -- ultimate ancestor is the same by examining names and scopes.
10051 procedure Process_Nested_Formal
(Formal
: Entity_Id
);
10052 -- If the current formal is declared with a box, its own formals are
10053 -- visible in the instance, as they were in the generic, and their
10054 -- Hidden flag must be reset. If some of these formals are themselves
10055 -- packages declared with a box, the processing must be recursive.
10057 --------------------------
10058 -- Find_Matching_Actual --
10059 --------------------------
10061 procedure Find_Matching_Actual
10063 Act
: in out Entity_Id
)
10065 Formal_Ent
: Entity_Id
;
10068 case Nkind
(Original_Node
(F
)) is
10069 when N_Formal_Object_Declaration
10070 | N_Formal_Type_Declaration
10072 Formal_Ent
:= Defining_Identifier
(F
);
10074 while Chars
(Act
) /= Chars
(Formal_Ent
) loop
10078 when N_Formal_Package_Declaration
10079 | N_Formal_Subprogram_Declaration
10080 | N_Generic_Package_Declaration
10081 | N_Package_Declaration
10083 Formal_Ent
:= Defining_Entity
(F
);
10085 while Chars
(Act
) /= Chars
(Formal_Ent
) loop
10090 raise Program_Error
;
10092 end Find_Matching_Actual
;
10094 -------------------------
10095 -- Match_Formal_Entity --
10096 -------------------------
10098 procedure Match_Formal_Entity
10099 (Formal_Node
: Node_Id
;
10100 Formal_Ent
: Entity_Id
;
10101 Actual_Ent
: Entity_Id
)
10103 Act_Pkg
: Entity_Id
;
10106 Set_Instance_Of
(Formal_Ent
, Actual_Ent
);
10108 if Ekind
(Actual_Ent
) = E_Package
then
10110 -- Record associations for each parameter
10112 Act_Pkg
:= Actual_Ent
;
10115 A_Ent
: Entity_Id
:= First_Entity
(Act_Pkg
);
10119 Gen_Decl
: Node_Id
;
10121 Actual
: Entity_Id
;
10124 -- Retrieve the actual given in the formal package declaration
10126 Actual
:= Entity
(Name
(Original_Node
(Formal_Node
)));
10128 -- The actual in the formal package declaration may be a
10129 -- renamed generic package, in which case we want to retrieve
10130 -- the original generic in order to traverse its formal part.
10132 if Present
(Renamed_Entity
(Actual
)) then
10133 Gen_Decl
:= Unit_Declaration_Node
(Renamed_Entity
(Actual
));
10135 Gen_Decl
:= Unit_Declaration_Node
(Actual
);
10138 Formals
:= Generic_Formal_Declarations
(Gen_Decl
);
10140 if Present
(Formals
) then
10141 F_Node
:= First_Non_Pragma
(Formals
);
10146 while Present
(A_Ent
)
10147 and then Present
(F_Node
)
10148 and then A_Ent
/= First_Private_Entity
(Act_Pkg
)
10150 F_Ent
:= Get_Formal_Entity
(F_Node
);
10152 if Present
(F_Ent
) then
10154 -- This is a formal of the original package. Record
10155 -- association and recurse.
10157 Find_Matching_Actual
(F_Node
, A_Ent
);
10158 Match_Formal_Entity
(F_Node
, F_Ent
, A_Ent
);
10159 Next_Entity
(A_Ent
);
10162 Next_Non_Pragma
(F_Node
);
10166 end Match_Formal_Entity
;
10168 -----------------------
10169 -- Get_Formal_Entity --
10170 -----------------------
10172 function Get_Formal_Entity
(N
: Node_Id
) return Entity_Id
is
10173 Kind
: constant Node_Kind
:= Nkind
(Original_Node
(N
));
10176 when N_Formal_Object_Declaration
=>
10177 return Defining_Identifier
(N
);
10179 when N_Formal_Type_Declaration
=>
10180 return Defining_Identifier
(N
);
10182 when N_Formal_Subprogram_Declaration
=>
10183 return Defining_Unit_Name
(Specification
(N
));
10185 when N_Formal_Package_Declaration
=>
10186 return Defining_Identifier
(Original_Node
(N
));
10188 when N_Generic_Package_Declaration
=>
10189 return Defining_Identifier
(Original_Node
(N
));
10191 -- All other declarations are introduced by semantic analysis and
10192 -- have no match in the actual.
10197 end Get_Formal_Entity
;
10199 --------------------
10200 -- Is_Instance_Of --
10201 --------------------
10203 function Is_Instance_Of
10204 (Act_Spec
: Entity_Id
;
10205 Gen_Anc
: Entity_Id
) return Boolean
10207 Gen_Par
: constant Entity_Id
:= Generic_Parent
(Act_Spec
);
10210 if No
(Gen_Par
) then
10213 -- Simplest case: the generic parent of the actual is the formal
10215 elsif Gen_Par
= Gen_Anc
then
10218 elsif Chars
(Gen_Par
) /= Chars
(Gen_Anc
) then
10221 -- The actual may be obtained through several instantiations. Its
10222 -- scope must itself be an instance of a generic declared in the
10223 -- same scope as the formal. Any other case is detected above.
10225 elsif not Is_Generic_Instance
(Scope
(Gen_Par
)) then
10229 return Generic_Parent
(Parent
(Scope
(Gen_Par
))) = Scope
(Gen_Anc
);
10231 end Is_Instance_Of
;
10233 ---------------------------
10234 -- Process_Nested_Formal --
10235 ---------------------------
10237 procedure Process_Nested_Formal
(Formal
: Entity_Id
) is
10241 if Present
(Associated_Formal_Package
(Formal
))
10242 and then Box_Present
(Parent
(Associated_Formal_Package
(Formal
)))
10244 Ent
:= First_Entity
(Formal
);
10245 while Present
(Ent
) loop
10246 Set_Is_Hidden
(Ent
, False);
10247 Set_Is_Visible_Formal
(Ent
);
10248 Set_Is_Potentially_Use_Visible
10249 (Ent
, Is_Potentially_Use_Visible
(Formal
));
10251 if Ekind
(Ent
) = E_Package
then
10252 exit when Renamed_Entity
(Ent
) = Renamed_Entity
(Formal
);
10253 Process_Nested_Formal
(Ent
);
10259 end Process_Nested_Formal
;
10261 -- Start of processing for Instantiate_Formal_Package
10266 if not Is_Entity_Name
(Actual
)
10267 or else Ekind
(Entity
(Actual
)) /= E_Package
10270 ("expect package instance to instantiate formal", Actual
);
10271 Abandon_Instantiation
(Actual
);
10272 raise Program_Error
;
10275 Actual_Pack
:= Entity
(Actual
);
10276 Set_Is_Instantiated
(Actual_Pack
);
10278 -- The actual may be a renamed package, or an outer generic formal
10279 -- package whose instantiation is converted into a renaming.
10281 if Present
(Renamed_Object
(Actual_Pack
)) then
10282 Actual_Pack
:= Renamed_Object
(Actual_Pack
);
10285 if Nkind
(Analyzed_Formal
) = N_Formal_Package_Declaration
then
10286 Gen_Parent
:= Get_Instance_Of
(Entity
(Name
(Analyzed_Formal
)));
10287 Formal_Pack
:= Defining_Identifier
(Analyzed_Formal
);
10290 Generic_Parent
(Specification
(Analyzed_Formal
));
10292 Defining_Unit_Name
(Specification
(Analyzed_Formal
));
10295 if Nkind
(Parent
(Actual_Pack
)) = N_Defining_Program_Unit_Name
then
10296 Parent_Spec
:= Package_Specification
(Actual_Pack
);
10298 Parent_Spec
:= Parent
(Actual_Pack
);
10301 if Gen_Parent
= Any_Id
then
10303 ("previous error in declaration of formal package", Actual
);
10304 Abandon_Instantiation
(Actual
);
10307 Is_Instance_Of
(Parent_Spec
, Get_Instance_Of
(Gen_Parent
))
10313 ("actual parameter must be instance of&", Actual
, Gen_Parent
);
10314 Abandon_Instantiation
(Actual
);
10317 Set_Instance_Of
(Defining_Identifier
(Formal
), Actual_Pack
);
10318 Map_Formal_Package_Entities
(Formal_Pack
, Actual_Pack
);
10321 Make_Package_Renaming_Declaration
(Loc
,
10322 Defining_Unit_Name
=> New_Copy
(Defining_Identifier
(Formal
)),
10323 Name
=> New_Occurrence_Of
(Actual_Pack
, Loc
));
10325 Set_Associated_Formal_Package
10326 (Defining_Unit_Name
(Nod
), Defining_Identifier
(Formal
));
10327 Decls
:= New_List
(Nod
);
10329 -- If the formal F has a box, then the generic declarations are
10330 -- visible in the generic G. In an instance of G, the corresponding
10331 -- entities in the actual for F (which are the actuals for the
10332 -- instantiation of the generic that F denotes) must also be made
10333 -- visible for analysis of the current instance. On exit from the
10334 -- current instance, those entities are made private again. If the
10335 -- actual is currently in use, these entities are also use-visible.
10337 -- The loop through the actual entities also steps through the formal
10338 -- entities and enters associations from formals to actuals into the
10339 -- renaming map. This is necessary to properly handle checking of
10340 -- actual parameter associations for later formals that depend on
10341 -- actuals declared in the formal package.
10343 -- In Ada 2005, partial parameterization requires that we make
10344 -- visible the actuals corresponding to formals that were defaulted
10345 -- in the formal package. There formals are identified because they
10346 -- remain formal generics within the formal package, rather than
10347 -- being renamings of the actuals supplied.
10350 Gen_Decl
: constant Node_Id
:=
10351 Unit_Declaration_Node
(Gen_Parent
);
10352 Formals
: constant List_Id
:=
10353 Generic_Formal_Declarations
(Gen_Decl
);
10355 Actual_Ent
: Entity_Id
;
10356 Actual_Of_Formal
: Node_Id
;
10357 Formal_Node
: Node_Id
;
10358 Formal_Ent
: Entity_Id
;
10361 if Present
(Formals
) then
10362 Formal_Node
:= First_Non_Pragma
(Formals
);
10364 Formal_Node
:= Empty
;
10367 Actual_Ent
:= First_Entity
(Actual_Pack
);
10368 Actual_Of_Formal
:=
10369 First
(Visible_Declarations
(Specification
(Analyzed_Formal
)));
10370 while Present
(Actual_Ent
)
10371 and then Actual_Ent
/= First_Private_Entity
(Actual_Pack
)
10373 if Present
(Formal_Node
) then
10374 Formal_Ent
:= Get_Formal_Entity
(Formal_Node
);
10376 if Present
(Formal_Ent
) then
10377 Find_Matching_Actual
(Formal_Node
, Actual_Ent
);
10378 Match_Formal_Entity
(Formal_Node
, Formal_Ent
, Actual_Ent
);
10380 -- We iterate at the same time over the actuals of the
10381 -- local package created for the formal, to determine
10382 -- which one of the formals of the original generic were
10383 -- defaulted in the formal. The corresponding actual
10384 -- entities are visible in the enclosing instance.
10386 if Box_Present
(Formal
)
10388 (Present
(Actual_Of_Formal
)
10391 (Get_Formal_Entity
(Actual_Of_Formal
)))
10393 Set_Is_Hidden
(Actual_Ent
, False);
10394 Set_Is_Visible_Formal
(Actual_Ent
);
10395 Set_Is_Potentially_Use_Visible
10396 (Actual_Ent
, In_Use
(Actual_Pack
));
10398 if Ekind
(Actual_Ent
) = E_Package
then
10399 Process_Nested_Formal
(Actual_Ent
);
10403 Set_Is_Hidden
(Actual_Ent
);
10404 Set_Is_Potentially_Use_Visible
(Actual_Ent
, False);
10408 Next_Non_Pragma
(Formal_Node
);
10409 Next
(Actual_Of_Formal
);
10412 -- No further formals to match, but the generic part may
10413 -- contain inherited operation that are not hidden in the
10414 -- enclosing instance.
10416 Next_Entity
(Actual_Ent
);
10420 -- Inherited subprograms generated by formal derived types are
10421 -- also visible if the types are.
10423 Actual_Ent
:= First_Entity
(Actual_Pack
);
10424 while Present
(Actual_Ent
)
10425 and then Actual_Ent
/= First_Private_Entity
(Actual_Pack
)
10427 if Is_Overloadable
(Actual_Ent
)
10429 Nkind
(Parent
(Actual_Ent
)) = N_Subtype_Declaration
10431 not Is_Hidden
(Defining_Identifier
(Parent
(Actual_Ent
)))
10433 Set_Is_Hidden
(Actual_Ent
, False);
10434 Set_Is_Potentially_Use_Visible
10435 (Actual_Ent
, In_Use
(Actual_Pack
));
10438 Next_Entity
(Actual_Ent
);
10442 -- If the formal is not declared with a box, reanalyze it as an
10443 -- abbreviated instantiation, to verify the matching rules of 12.7.
10444 -- The actual checks are performed after the generic associations
10445 -- have been analyzed, to guarantee the same visibility for this
10446 -- instantiation and for the actuals.
10448 -- In Ada 2005, the generic associations for the formal can include
10449 -- defaulted parameters. These are ignored during check. This
10450 -- internal instantiation is removed from the tree after conformance
10451 -- checking, because it contains formal declarations for those
10452 -- defaulted parameters, and those should not reach the back-end.
10454 if not Box_Present
(Formal
) then
10456 I_Pack
: constant Entity_Id
:=
10457 Make_Temporary
(Sloc
(Actual
), 'P');
10460 Set_Is_Internal
(I_Pack
);
10463 Make_Package_Instantiation
(Sloc
(Actual
),
10464 Defining_Unit_Name
=> I_Pack
,
10467 (Get_Instance_Of
(Gen_Parent
), Sloc
(Actual
)),
10468 Generic_Associations
=> Generic_Associations
(Formal
)));
10474 end Instantiate_Formal_Package
;
10476 -----------------------------------
10477 -- Instantiate_Formal_Subprogram --
10478 -----------------------------------
10480 function Instantiate_Formal_Subprogram
10483 Analyzed_Formal
: Node_Id
) return Node_Id
10485 Analyzed_S
: constant Entity_Id
:=
10486 Defining_Unit_Name
(Specification
(Analyzed_Formal
));
10487 Formal_Sub
: constant Entity_Id
:=
10488 Defining_Unit_Name
(Specification
(Formal
));
10490 function From_Parent_Scope
(Subp
: Entity_Id
) return Boolean;
10491 -- If the generic is a child unit, the parent has been installed on the
10492 -- scope stack, but a default subprogram cannot resolve to something
10493 -- on the parent because that parent is not really part of the visible
10494 -- context (it is there to resolve explicit local entities). If the
10495 -- default has resolved in this way, we remove the entity from immediate
10496 -- visibility and analyze the node again to emit an error message or
10497 -- find another visible candidate.
10499 procedure Valid_Actual_Subprogram
(Act
: Node_Id
);
10500 -- Perform legality check and raise exception on failure
10502 -----------------------
10503 -- From_Parent_Scope --
10504 -----------------------
10506 function From_Parent_Scope
(Subp
: Entity_Id
) return Boolean is
10507 Gen_Scope
: Node_Id
;
10510 Gen_Scope
:= Scope
(Analyzed_S
);
10511 while Present
(Gen_Scope
) and then Is_Child_Unit
(Gen_Scope
) loop
10512 if Scope
(Subp
) = Scope
(Gen_Scope
) then
10516 Gen_Scope
:= Scope
(Gen_Scope
);
10520 end From_Parent_Scope
;
10522 -----------------------------
10523 -- Valid_Actual_Subprogram --
10524 -----------------------------
10526 procedure Valid_Actual_Subprogram
(Act
: Node_Id
) is
10530 if Is_Entity_Name
(Act
) then
10531 Act_E
:= Entity
(Act
);
10533 elsif Nkind
(Act
) = N_Selected_Component
10534 and then Is_Entity_Name
(Selector_Name
(Act
))
10536 Act_E
:= Entity
(Selector_Name
(Act
));
10542 if (Present
(Act_E
) and then Is_Overloadable
(Act_E
))
10543 or else Nkind_In
(Act
, N_Attribute_Reference
,
10544 N_Indexed_Component
,
10545 N_Character_Literal
,
10546 N_Explicit_Dereference
)
10552 ("expect subprogram or entry name in instantiation of &",
10553 Instantiation_Node
, Formal_Sub
);
10554 Abandon_Instantiation
(Instantiation_Node
);
10555 end Valid_Actual_Subprogram
;
10559 Decl_Node
: Node_Id
;
10562 New_Spec
: Node_Id
;
10563 New_Subp
: Entity_Id
;
10565 -- Start of processing for Instantiate_Formal_Subprogram
10568 New_Spec
:= New_Copy_Tree
(Specification
(Formal
));
10570 -- The tree copy has created the proper instantiation sloc for the
10571 -- new specification. Use this location for all other constructed
10574 Loc
:= Sloc
(Defining_Unit_Name
(New_Spec
));
10576 -- Create new entity for the actual (New_Copy_Tree does not), and
10577 -- indicate that it is an actual.
10579 New_Subp
:= Make_Defining_Identifier
(Loc
, Chars
(Formal_Sub
));
10580 Set_Ekind
(New_Subp
, Ekind
(Analyzed_S
));
10581 Set_Is_Generic_Actual_Subprogram
(New_Subp
);
10582 Set_Defining_Unit_Name
(New_Spec
, New_Subp
);
10584 -- Create new entities for the each of the formals in the specification
10585 -- of the renaming declaration built for the actual.
10587 if Present
(Parameter_Specifications
(New_Spec
)) then
10593 F
:= First
(Parameter_Specifications
(New_Spec
));
10594 while Present
(F
) loop
10595 F_Id
:= Defining_Identifier
(F
);
10597 Set_Defining_Identifier
(F
,
10598 Make_Defining_Identifier
(Sloc
(F_Id
), Chars
(F_Id
)));
10604 -- Find entity of actual. If the actual is an attribute reference, it
10605 -- cannot be resolved here (its formal is missing) but is handled
10606 -- instead in Attribute_Renaming. If the actual is overloaded, it is
10607 -- fully resolved subsequently, when the renaming declaration for the
10608 -- formal is analyzed. If it is an explicit dereference, resolve the
10609 -- prefix but not the actual itself, to prevent interpretation as call.
10611 if Present
(Actual
) then
10612 Loc
:= Sloc
(Actual
);
10613 Set_Sloc
(New_Spec
, Loc
);
10615 if Nkind
(Actual
) = N_Operator_Symbol
then
10616 Find_Direct_Name
(Actual
);
10618 elsif Nkind
(Actual
) = N_Explicit_Dereference
then
10619 Analyze
(Prefix
(Actual
));
10621 elsif Nkind
(Actual
) /= N_Attribute_Reference
then
10625 Valid_Actual_Subprogram
(Actual
);
10628 elsif Present
(Default_Name
(Formal
)) then
10629 if not Nkind_In
(Default_Name
(Formal
), N_Attribute_Reference
,
10630 N_Selected_Component
,
10631 N_Indexed_Component
,
10632 N_Character_Literal
)
10633 and then Present
(Entity
(Default_Name
(Formal
)))
10635 Nam
:= New_Occurrence_Of
(Entity
(Default_Name
(Formal
)), Loc
);
10637 Nam
:= New_Copy
(Default_Name
(Formal
));
10638 Set_Sloc
(Nam
, Loc
);
10641 elsif Box_Present
(Formal
) then
10643 -- Actual is resolved at the point of instantiation. Create an
10644 -- identifier or operator with the same name as the formal.
10646 if Nkind
(Formal_Sub
) = N_Defining_Operator_Symbol
then
10648 Make_Operator_Symbol
(Loc
,
10649 Chars
=> Chars
(Formal_Sub
),
10650 Strval
=> No_String
);
10652 Nam
:= Make_Identifier
(Loc
, Chars
(Formal_Sub
));
10655 elsif Nkind
(Specification
(Formal
)) = N_Procedure_Specification
10656 and then Null_Present
(Specification
(Formal
))
10658 -- Generate null body for procedure, for use in the instance
10661 Make_Subprogram_Body
(Loc
,
10662 Specification
=> New_Spec
,
10663 Declarations
=> New_List
,
10664 Handled_Statement_Sequence
=>
10665 Make_Handled_Sequence_Of_Statements
(Loc
,
10666 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
10668 Set_Is_Intrinsic_Subprogram
(Defining_Unit_Name
(New_Spec
));
10672 Error_Msg_Sloc
:= Sloc
(Scope
(Analyzed_S
));
10674 ("missing actual&", Instantiation_Node
, Formal_Sub
);
10676 ("\in instantiation of & declared#",
10677 Instantiation_Node
, Scope
(Analyzed_S
));
10678 Abandon_Instantiation
(Instantiation_Node
);
10682 Make_Subprogram_Renaming_Declaration
(Loc
,
10683 Specification
=> New_Spec
,
10686 -- If we do not have an actual and the formal specified <> then set to
10687 -- get proper default.
10689 if No
(Actual
) and then Box_Present
(Formal
) then
10690 Set_From_Default
(Decl_Node
);
10693 -- Gather possible interpretations for the actual before analyzing the
10694 -- instance. If overloaded, it will be resolved when analyzing the
10695 -- renaming declaration.
10697 if Box_Present
(Formal
) and then No
(Actual
) then
10700 if Is_Child_Unit
(Scope
(Analyzed_S
))
10701 and then Present
(Entity
(Nam
))
10703 if not Is_Overloaded
(Nam
) then
10704 if From_Parent_Scope
(Entity
(Nam
)) then
10705 Set_Is_Immediately_Visible
(Entity
(Nam
), False);
10706 Set_Entity
(Nam
, Empty
);
10707 Set_Etype
(Nam
, Empty
);
10710 Set_Is_Immediately_Visible
(Entity
(Nam
));
10719 Get_First_Interp
(Nam
, I
, It
);
10720 while Present
(It
.Nam
) loop
10721 if From_Parent_Scope
(It
.Nam
) then
10725 Get_Next_Interp
(I
, It
);
10732 -- The generic instantiation freezes the actual. This can only be done
10733 -- once the actual is resolved, in the analysis of the renaming
10734 -- declaration. To make the formal subprogram entity available, we set
10735 -- Corresponding_Formal_Spec to point to the formal subprogram entity.
10736 -- This is also needed in Analyze_Subprogram_Renaming for the processing
10737 -- of formal abstract subprograms.
10739 Set_Corresponding_Formal_Spec
(Decl_Node
, Analyzed_S
);
10741 -- We cannot analyze the renaming declaration, and thus find the actual,
10742 -- until all the actuals are assembled in the instance. For subsequent
10743 -- checks of other actuals, indicate the node that will hold the
10744 -- instance of this formal.
10746 Set_Instance_Of
(Analyzed_S
, Nam
);
10748 if Nkind
(Actual
) = N_Selected_Component
10749 and then Is_Task_Type
(Etype
(Prefix
(Actual
)))
10750 and then not Is_Frozen
(Etype
(Prefix
(Actual
)))
10752 -- The renaming declaration will create a body, which must appear
10753 -- outside of the instantiation, We move the renaming declaration
10754 -- out of the instance, and create an additional renaming inside,
10755 -- to prevent freezing anomalies.
10758 Anon_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E');
10761 Set_Defining_Unit_Name
(New_Spec
, Anon_Id
);
10762 Insert_Before
(Instantiation_Node
, Decl_Node
);
10763 Analyze
(Decl_Node
);
10765 -- Now create renaming within the instance
10768 Make_Subprogram_Renaming_Declaration
(Loc
,
10769 Specification
=> New_Copy_Tree
(New_Spec
),
10770 Name
=> New_Occurrence_Of
(Anon_Id
, Loc
));
10772 Set_Defining_Unit_Name
(Specification
(Decl_Node
),
10773 Make_Defining_Identifier
(Loc
, Chars
(Formal_Sub
)));
10778 end Instantiate_Formal_Subprogram
;
10780 ------------------------
10781 -- Instantiate_Object --
10782 ------------------------
10784 function Instantiate_Object
10787 Analyzed_Formal
: Node_Id
) return List_Id
10789 Gen_Obj
: constant Entity_Id
:= Defining_Identifier
(Formal
);
10790 A_Gen_Obj
: constant Entity_Id
:=
10791 Defining_Identifier
(Analyzed_Formal
);
10792 Acc_Def
: Node_Id
:= Empty
;
10793 Act_Assoc
: constant Node_Id
:= Parent
(Actual
);
10794 Actual_Decl
: Node_Id
:= Empty
;
10795 Decl_Node
: Node_Id
;
10798 List
: constant List_Id
:= New_List
;
10799 Loc
: constant Source_Ptr
:= Sloc
(Actual
);
10800 Orig_Ftyp
: constant Entity_Id
:= Etype
(A_Gen_Obj
);
10801 Subt_Decl
: Node_Id
:= Empty
;
10802 Subt_Mark
: Node_Id
:= Empty
;
10804 function Copy_Access_Def
return Node_Id
;
10805 -- If formal is an anonymous access, copy access definition of formal
10806 -- for generated object declaration.
10808 ---------------------
10809 -- Copy_Access_Def --
10810 ---------------------
10812 function Copy_Access_Def
return Node_Id
is
10814 Def
:= New_Copy_Tree
(Acc_Def
);
10816 -- In addition, if formal is an access to subprogram we need to
10817 -- generate new formals for the signature of the default, so that
10818 -- the tree is properly formatted for ASIS use.
10820 if Present
(Access_To_Subprogram_Definition
(Acc_Def
)) then
10822 Par_Spec
: Node_Id
;
10825 First
(Parameter_Specifications
10826 (Access_To_Subprogram_Definition
(Def
)));
10827 while Present
(Par_Spec
) loop
10828 Set_Defining_Identifier
(Par_Spec
,
10829 Make_Defining_Identifier
(Sloc
(Acc_Def
),
10830 Chars
=> Chars
(Defining_Identifier
(Par_Spec
))));
10837 end Copy_Access_Def
;
10839 -- Start of processing for Instantiate_Object
10842 -- Formal may be an anonymous access
10844 if Present
(Subtype_Mark
(Formal
)) then
10845 Subt_Mark
:= Subtype_Mark
(Formal
);
10847 Check_Access_Definition
(Formal
);
10848 Acc_Def
:= Access_Definition
(Formal
);
10851 -- Sloc for error message on missing actual
10853 Error_Msg_Sloc
:= Sloc
(Scope
(A_Gen_Obj
));
10855 if Get_Instance_Of
(Gen_Obj
) /= Gen_Obj
then
10856 Error_Msg_N
("duplicate instantiation of generic parameter", Actual
);
10859 Set_Parent
(List
, Parent
(Actual
));
10863 if Out_Present
(Formal
) then
10865 -- An IN OUT generic actual must be a name. The instantiation is a
10866 -- renaming declaration. The actual is the name being renamed. We
10867 -- use the actual directly, rather than a copy, because it is not
10868 -- used further in the list of actuals, and because a copy or a use
10869 -- of relocate_node is incorrect if the instance is nested within a
10870 -- generic. In order to simplify ASIS searches, the Generic_Parent
10871 -- field links the declaration to the generic association.
10873 if No
(Actual
) then
10875 ("missing actual &",
10876 Instantiation_Node
, Gen_Obj
);
10878 ("\in instantiation of & declared#",
10879 Instantiation_Node
, Scope
(A_Gen_Obj
));
10880 Abandon_Instantiation
(Instantiation_Node
);
10883 if Present
(Subt_Mark
) then
10885 Make_Object_Renaming_Declaration
(Loc
,
10886 Defining_Identifier
=> New_Copy
(Gen_Obj
),
10887 Subtype_Mark
=> New_Copy_Tree
(Subt_Mark
),
10890 else pragma Assert
(Present
(Acc_Def
));
10892 Make_Object_Renaming_Declaration
(Loc
,
10893 Defining_Identifier
=> New_Copy
(Gen_Obj
),
10894 Access_Definition
=> New_Copy_Tree
(Acc_Def
),
10898 Set_Corresponding_Generic_Association
(Decl_Node
, Act_Assoc
);
10900 -- The analysis of the actual may produce Insert_Action nodes, so
10901 -- the declaration must have a context in which to attach them.
10903 Append
(Decl_Node
, List
);
10906 -- Return if the analysis of the actual reported some error
10908 if Etype
(Actual
) = Any_Type
then
10912 -- This check is performed here because Analyze_Object_Renaming will
10913 -- not check it when Comes_From_Source is False. Note though that the
10914 -- check for the actual being the name of an object will be performed
10915 -- in Analyze_Object_Renaming.
10917 if Is_Object_Reference
(Actual
)
10918 and then Is_Dependent_Component_Of_Mutable_Object
(Actual
)
10921 ("illegal discriminant-dependent component for in out parameter",
10925 -- The actual has to be resolved in order to check that it is a
10926 -- variable (due to cases such as F (1), where F returns access to
10927 -- an array, and for overloaded prefixes).
10929 Ftyp
:= Get_Instance_Of
(Etype
(A_Gen_Obj
));
10931 -- If the type of the formal is not itself a formal, and the current
10932 -- unit is a child unit, the formal type must be declared in a
10933 -- parent, and must be retrieved by visibility.
10935 if Ftyp
= Orig_Ftyp
10936 and then Is_Generic_Unit
(Scope
(Ftyp
))
10937 and then Is_Child_Unit
(Scope
(A_Gen_Obj
))
10940 Temp
: constant Node_Id
:=
10941 New_Copy_Tree
(Subtype_Mark
(Analyzed_Formal
));
10943 Set_Entity
(Temp
, Empty
);
10945 Ftyp
:= Entity
(Temp
);
10949 if Is_Private_Type
(Ftyp
)
10950 and then not Is_Private_Type
(Etype
(Actual
))
10951 and then (Base_Type
(Full_View
(Ftyp
)) = Base_Type
(Etype
(Actual
))
10952 or else Base_Type
(Etype
(Actual
)) = Ftyp
)
10954 -- If the actual has the type of the full view of the formal, or
10955 -- else a non-private subtype of the formal, then the visibility
10956 -- of the formal type has changed. Add to the actuals a subtype
10957 -- declaration that will force the exchange of views in the body
10958 -- of the instance as well.
10961 Make_Subtype_Declaration
(Loc
,
10962 Defining_Identifier
=> Make_Temporary
(Loc
, 'P'),
10963 Subtype_Indication
=> New_Occurrence_Of
(Ftyp
, Loc
));
10965 Prepend
(Subt_Decl
, List
);
10967 Prepend_Elmt
(Full_View
(Ftyp
), Exchanged_Views
);
10968 Exchange_Declarations
(Ftyp
);
10971 Resolve
(Actual
, Ftyp
);
10973 if not Denotes_Variable
(Actual
) then
10974 Error_Msg_NE
("actual for& must be a variable", Actual
, Gen_Obj
);
10976 elsif Base_Type
(Ftyp
) /= Base_Type
(Etype
(Actual
)) then
10978 -- Ada 2005 (AI-423): For a generic formal object of mode in out,
10979 -- the type of the actual shall resolve to a specific anonymous
10982 if Ada_Version
< Ada_2005
10983 or else Ekind
(Base_Type
(Ftyp
)) /=
10984 E_Anonymous_Access_Type
10985 or else Ekind
(Base_Type
(Etype
(Actual
))) /=
10986 E_Anonymous_Access_Type
10989 ("type of actual does not match type of&", Actual
, Gen_Obj
);
10993 Note_Possible_Modification
(Actual
, Sure
=> True);
10995 -- Check for instantiation of atomic/volatile actual for
10996 -- non-atomic/volatile formal (RM C.6 (12)).
10998 if Is_Atomic_Object
(Actual
) and then not Is_Atomic
(Orig_Ftyp
) then
11000 ("cannot instantiate non-atomic formal object "
11001 & "with atomic actual", Actual
);
11003 elsif Is_Volatile_Object
(Actual
) and then not Is_Volatile
(Orig_Ftyp
)
11006 ("cannot instantiate non-volatile formal object "
11007 & "with volatile actual", Actual
);
11010 -- Formal in-parameter
11013 -- The instantiation of a generic formal in-parameter is constant
11014 -- declaration. The actual is the expression for that declaration.
11015 -- Its type is a full copy of the type of the formal. This may be
11016 -- an access to subprogram, for which we need to generate entities
11017 -- for the formals in the new signature.
11019 if Present
(Actual
) then
11020 if Present
(Subt_Mark
) then
11021 Def
:= New_Copy_Tree
(Subt_Mark
);
11022 else pragma Assert
(Present
(Acc_Def
));
11023 Def
:= Copy_Access_Def
;
11027 Make_Object_Declaration
(Loc
,
11028 Defining_Identifier
=> New_Copy
(Gen_Obj
),
11029 Constant_Present
=> True,
11030 Null_Exclusion_Present
=> Null_Exclusion_Present
(Formal
),
11031 Object_Definition
=> Def
,
11032 Expression
=> Actual
);
11034 Set_Corresponding_Generic_Association
(Decl_Node
, Act_Assoc
);
11036 -- A generic formal object of a tagged type is defined to be
11037 -- aliased so the new constant must also be treated as aliased.
11039 if Is_Tagged_Type
(Etype
(A_Gen_Obj
)) then
11040 Set_Aliased_Present
(Decl_Node
);
11043 Append
(Decl_Node
, List
);
11045 -- No need to repeat (pre-)analysis of some expression nodes
11046 -- already handled in Preanalyze_Actuals.
11048 if Nkind
(Actual
) /= N_Allocator
then
11051 -- Return if the analysis of the actual reported some error
11053 if Etype
(Actual
) = Any_Type
then
11059 Formal_Type
: constant Entity_Id
:= Etype
(A_Gen_Obj
);
11063 Typ
:= Get_Instance_Of
(Formal_Type
);
11065 -- If the actual appears in the current or an enclosing scope,
11066 -- use its type directly. This is relevant if it has an actual
11067 -- subtype that is distinct from its nominal one. This cannot
11068 -- be done in general because the type of the actual may
11069 -- depend on other actuals, and only be fully determined when
11070 -- the enclosing instance is analyzed.
11072 if Present
(Etype
(Actual
))
11073 and then Is_Constr_Subt_For_U_Nominal
(Etype
(Actual
))
11075 Freeze_Before
(Instantiation_Node
, Etype
(Actual
));
11077 Freeze_Before
(Instantiation_Node
, Typ
);
11080 -- If the actual is an aggregate, perform name resolution on
11081 -- its components (the analysis of an aggregate does not do it)
11082 -- to capture local names that may be hidden if the generic is
11085 if Nkind
(Actual
) = N_Aggregate
then
11086 Preanalyze_And_Resolve
(Actual
, Typ
);
11089 if Is_Limited_Type
(Typ
)
11090 and then not OK_For_Limited_Init
(Typ
, Actual
)
11093 ("initialization not allowed for limited types", Actual
);
11094 Explain_Limited_Type
(Typ
, Actual
);
11098 elsif Present
(Default_Expression
(Formal
)) then
11100 -- Use default to construct declaration
11102 if Present
(Subt_Mark
) then
11103 Def
:= New_Copy
(Subt_Mark
);
11104 else pragma Assert
(Present
(Acc_Def
));
11105 Def
:= Copy_Access_Def
;
11109 Make_Object_Declaration
(Sloc
(Formal
),
11110 Defining_Identifier
=> New_Copy
(Gen_Obj
),
11111 Constant_Present
=> True,
11112 Null_Exclusion_Present
=> Null_Exclusion_Present
(Formal
),
11113 Object_Definition
=> Def
,
11114 Expression
=> New_Copy_Tree
11115 (Default_Expression
(Formal
)));
11117 Append
(Decl_Node
, List
);
11118 Set_Analyzed
(Expression
(Decl_Node
), False);
11121 Error_Msg_NE
("missing actual&", Instantiation_Node
, Gen_Obj
);
11122 Error_Msg_NE
("\in instantiation of & declared#",
11123 Instantiation_Node
, Scope
(A_Gen_Obj
));
11125 if Is_Scalar_Type
(Etype
(A_Gen_Obj
)) then
11127 -- Create dummy constant declaration so that instance can be
11128 -- analyzed, to minimize cascaded visibility errors.
11130 if Present
(Subt_Mark
) then
11132 else pragma Assert
(Present
(Acc_Def
));
11137 Make_Object_Declaration
(Loc
,
11138 Defining_Identifier
=> New_Copy
(Gen_Obj
),
11139 Constant_Present
=> True,
11140 Null_Exclusion_Present
=> Null_Exclusion_Present
(Formal
),
11141 Object_Definition
=> New_Copy
(Def
),
11143 Make_Attribute_Reference
(Sloc
(Gen_Obj
),
11144 Attribute_Name
=> Name_First
,
11145 Prefix
=> New_Copy
(Def
)));
11147 Append
(Decl_Node
, List
);
11150 Abandon_Instantiation
(Instantiation_Node
);
11155 if Nkind
(Actual
) in N_Has_Entity
then
11156 Actual_Decl
:= Parent
(Entity
(Actual
));
11159 -- Ada 2005 (AI-423): For a formal object declaration with a null
11160 -- exclusion or an access definition that has a null exclusion: If the
11161 -- actual matching the formal object declaration denotes a generic
11162 -- formal object of another generic unit G, and the instantiation
11163 -- containing the actual occurs within the body of G or within the body
11164 -- of a generic unit declared within the declarative region of G, then
11165 -- the declaration of the formal object of G must have a null exclusion.
11166 -- Otherwise, the subtype of the actual matching the formal object
11167 -- declaration shall exclude null.
11169 if Ada_Version
>= Ada_2005
11170 and then Present
(Actual_Decl
)
11171 and then Nkind_In
(Actual_Decl
, N_Formal_Object_Declaration
,
11172 N_Object_Declaration
)
11173 and then Nkind
(Analyzed_Formal
) = N_Formal_Object_Declaration
11174 and then not Has_Null_Exclusion
(Actual_Decl
)
11175 and then Has_Null_Exclusion
(Analyzed_Formal
)
11177 Error_Msg_Sloc
:= Sloc
(Analyzed_Formal
);
11179 ("actual must exclude null to match generic formal#", Actual
);
11182 -- An effectively volatile object cannot be used as an actual in a
11183 -- generic instantiation (SPARK RM 7.1.3(7)). The following check is
11184 -- relevant only when SPARK_Mode is on as it is not a standard Ada
11185 -- legality rule, and also verifies that the actual is an object.
11188 and then Present
(Actual
)
11189 and then Is_Object_Reference
(Actual
)
11190 and then Is_Effectively_Volatile_Object
(Actual
)
11193 ("volatile object cannot act as actual in generic instantiation",
11198 end Instantiate_Object
;
11200 ------------------------------
11201 -- Instantiate_Package_Body --
11202 ------------------------------
11204 -- WARNING: This routine manages Ghost and SPARK regions. Return statements
11205 -- must be replaced by gotos which jump to the end of the routine in order
11206 -- to restore the Ghost and SPARK modes.
11208 procedure Instantiate_Package_Body
11209 (Body_Info
: Pending_Body_Info
;
11210 Inlined_Body
: Boolean := False;
11211 Body_Optional
: Boolean := False)
11213 Act_Decl
: constant Node_Id
:= Body_Info
.Act_Decl
;
11214 Act_Decl_Id
: constant Entity_Id
:= Defining_Entity
(Act_Decl
);
11215 Act_Spec
: constant Node_Id
:= Specification
(Act_Decl
);
11216 Inst_Node
: constant Node_Id
:= Body_Info
.Inst_Node
;
11217 Gen_Id
: constant Node_Id
:= Name
(Inst_Node
);
11218 Gen_Unit
: constant Entity_Id
:= Get_Generic_Entity
(Inst_Node
);
11219 Gen_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Gen_Unit
);
11220 Loc
: constant Source_Ptr
:= Sloc
(Inst_Node
);
11222 Saved_ISMP
: constant Boolean :=
11223 Ignore_SPARK_Mode_Pragmas_In_Instance
;
11224 Saved_Style_Check
: constant Boolean := Style_Check
;
11226 procedure Check_Initialized_Types
;
11227 -- In a generic package body, an entity of a generic private type may
11228 -- appear uninitialized. This is suspicious, unless the actual is a
11229 -- fully initialized type.
11231 -----------------------------
11232 -- Check_Initialized_Types --
11233 -----------------------------
11235 procedure Check_Initialized_Types
is
11237 Formal
: Entity_Id
;
11238 Actual
: Entity_Id
;
11239 Uninit_Var
: Entity_Id
;
11242 Decl
:= First
(Generic_Formal_Declarations
(Gen_Decl
));
11243 while Present
(Decl
) loop
11244 Uninit_Var
:= Empty
;
11246 if Nkind
(Decl
) = N_Private_Extension_Declaration
then
11247 Uninit_Var
:= Uninitialized_Variable
(Decl
);
11249 elsif Nkind
(Decl
) = N_Formal_Type_Declaration
11250 and then Nkind
(Formal_Type_Definition
(Decl
)) =
11251 N_Formal_Private_Type_Definition
11254 Uninitialized_Variable
(Formal_Type_Definition
(Decl
));
11257 if Present
(Uninit_Var
) then
11258 Formal
:= Defining_Identifier
(Decl
);
11259 Actual
:= First_Entity
(Act_Decl_Id
);
11261 -- For each formal there is a subtype declaration that renames
11262 -- the actual and has the same name as the formal. Locate the
11263 -- formal for warning message about uninitialized variables
11264 -- in the generic, for which the actual type should be a fully
11265 -- initialized type.
11267 while Present
(Actual
) loop
11268 exit when Ekind
(Actual
) = E_Package
11269 and then Present
(Renamed_Object
(Actual
));
11271 if Chars
(Actual
) = Chars
(Formal
)
11272 and then not Is_Scalar_Type
(Actual
)
11273 and then not Is_Fully_Initialized_Type
(Actual
)
11274 and then Warn_On_No_Value_Assigned
11276 Error_Msg_Node_2
:= Formal
;
11278 ("generic unit has uninitialized variable& of "
11279 & "formal private type &?v?", Actual
, Uninit_Var
);
11281 ("actual type for& should be fully initialized type?v?",
11286 Next_Entity
(Actual
);
11292 end Check_Initialized_Types
;
11296 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
11297 Saved_SM
: constant SPARK_Mode_Type
:= SPARK_Mode
;
11298 Saved_SMP
: constant Node_Id
:= SPARK_Mode_Pragma
;
11299 -- Save the Ghost and SPARK mode-related data to restore on exit
11301 Act_Body
: Node_Id
;
11302 Act_Body_Id
: Entity_Id
;
11303 Act_Body_Name
: Node_Id
;
11304 Gen_Body
: Node_Id
;
11305 Gen_Body_Id
: Node_Id
;
11306 Par_Ent
: Entity_Id
:= Empty
;
11307 Par_Vis
: Boolean := False;
11308 Parent_Installed
: Boolean := False;
11310 Vis_Prims_List
: Elist_Id
:= No_Elist
;
11311 -- List of primitives made temporarily visible in the instantiation
11312 -- to match the visibility of the formal type.
11314 -- Start of processing for Instantiate_Package_Body
11317 Gen_Body_Id
:= Corresponding_Body
(Gen_Decl
);
11319 -- The instance body may already have been processed, as the parent of
11320 -- another instance that is inlined (Load_Parent_Of_Generic).
11322 if Present
(Corresponding_Body
(Instance_Spec
(Inst_Node
))) then
11326 -- The package being instantiated may be subject to pragma Ghost. Set
11327 -- the mode now to ensure that any nodes generated during instantiation
11328 -- are properly marked as Ghost.
11330 Set_Ghost_Mode
(Act_Decl_Id
);
11332 Expander_Mode_Save_And_Set
(Body_Info
.Expander_Status
);
11334 -- Re-establish the state of information on which checks are suppressed.
11335 -- This information was set in Body_Info at the point of instantiation,
11336 -- and now we restore it so that the instance is compiled using the
11337 -- check status at the instantiation (RM 11.5(7.2/2), AI95-00224-01).
11339 Local_Suppress_Stack_Top
:= Body_Info
.Local_Suppress_Stack_Top
;
11340 Scope_Suppress
:= Body_Info
.Scope_Suppress
;
11341 Opt
.Ada_Version
:= Body_Info
.Version
;
11342 Opt
.Ada_Version_Pragma
:= Body_Info
.Version_Pragma
;
11343 Restore_Warnings
(Body_Info
.Warnings
);
11345 -- Install the SPARK mode which applies to the package body
11347 Install_SPARK_Mode
(Body_Info
.SPARK_Mode
, Body_Info
.SPARK_Mode_Pragma
);
11349 if No
(Gen_Body_Id
) then
11351 -- Do not look for parent of generic body if none is required.
11352 -- This may happen when the routine is called as part of the
11353 -- Pending_Instantiations processing, when nested instances
11354 -- may precede the one generated from the main unit.
11356 if not Unit_Requires_Body
(Defining_Entity
(Gen_Decl
))
11357 and then Body_Optional
11361 Load_Parent_Of_Generic
11362 (Inst_Node
, Specification
(Gen_Decl
), Body_Optional
);
11363 Gen_Body_Id
:= Corresponding_Body
(Gen_Decl
);
11367 -- Establish global variable for sloc adjustment and for error recovery
11368 -- In the case of an instance body for an instantiation with actuals
11369 -- from a limited view, the instance body is placed at the beginning
11370 -- of the enclosing package body: use the body entity as the source
11371 -- location for nodes of the instance body.
11373 if not Is_Empty_Elmt_List
(Incomplete_Actuals
(Act_Decl_Id
)) then
11375 Scop
: constant Entity_Id
:= Scope
(Act_Decl_Id
);
11376 Body_Id
: constant Node_Id
:=
11377 Corresponding_Body
(Unit_Declaration_Node
(Scop
));
11380 Instantiation_Node
:= Body_Id
;
11383 Instantiation_Node
:= Inst_Node
;
11386 if Present
(Gen_Body_Id
) then
11387 Save_Env
(Gen_Unit
, Act_Decl_Id
);
11388 Style_Check
:= False;
11390 -- If the context of the instance is subject to SPARK_Mode "off", the
11391 -- annotation is missing, or the body is instantiated at a later pass
11392 -- and its spec ignored SPARK_Mode pragma, set the global flag which
11393 -- signals Analyze_Pragma to ignore all SPARK_Mode pragmas within the
11396 if SPARK_Mode
/= On
11397 or else Ignore_SPARK_Mode_Pragmas
(Act_Decl_Id
)
11399 Ignore_SPARK_Mode_Pragmas_In_Instance
:= True;
11402 Current_Sem_Unit
:= Body_Info
.Current_Sem_Unit
;
11403 Gen_Body
:= Unit_Declaration_Node
(Gen_Body_Id
);
11405 Create_Instantiation_Source
11406 (Inst_Node
, Gen_Body_Id
, S_Adjustment
);
11410 (Original_Node
(Gen_Body
), Empty
, Instantiating
=> True);
11412 -- Create proper (possibly qualified) defining name for the body, to
11413 -- correspond to the one in the spec.
11416 Make_Defining_Identifier
(Sloc
(Act_Decl_Id
), Chars
(Act_Decl_Id
));
11417 Set_Comes_From_Source
(Act_Body_Id
, Comes_From_Source
(Act_Decl_Id
));
11419 -- Some attributes of spec entity are not inherited by body entity
11421 Set_Handler_Records
(Act_Body_Id
, No_List
);
11423 if Nkind
(Defining_Unit_Name
(Act_Spec
)) =
11424 N_Defining_Program_Unit_Name
11427 Make_Defining_Program_Unit_Name
(Loc
,
11429 New_Copy_Tree
(Name
(Defining_Unit_Name
(Act_Spec
))),
11430 Defining_Identifier
=> Act_Body_Id
);
11432 Act_Body_Name
:= Act_Body_Id
;
11435 Set_Defining_Unit_Name
(Act_Body
, Act_Body_Name
);
11437 Set_Corresponding_Spec
(Act_Body
, Act_Decl_Id
);
11438 Check_Generic_Actuals
(Act_Decl_Id
, False);
11439 Check_Initialized_Types
;
11441 -- Install primitives hidden at the point of the instantiation but
11442 -- visible when processing the generic formals
11448 E
:= First_Entity
(Act_Decl_Id
);
11449 while Present
(E
) loop
11451 and then not Is_Itype
(E
)
11452 and then Is_Generic_Actual_Type
(E
)
11453 and then Is_Tagged_Type
(E
)
11455 Install_Hidden_Primitives
11456 (Prims_List
=> Vis_Prims_List
,
11457 Gen_T
=> Generic_Parent_Type
(Parent
(E
)),
11465 -- If it is a child unit, make the parent instance (which is an
11466 -- instance of the parent of the generic) visible. The parent
11467 -- instance is the prefix of the name of the generic unit.
11469 if Ekind
(Scope
(Gen_Unit
)) = E_Generic_Package
11470 and then Nkind
(Gen_Id
) = N_Expanded_Name
11472 Par_Ent
:= Entity
(Prefix
(Gen_Id
));
11473 Par_Vis
:= Is_Immediately_Visible
(Par_Ent
);
11474 Install_Parent
(Par_Ent
, In_Body
=> True);
11475 Parent_Installed
:= True;
11477 elsif Is_Child_Unit
(Gen_Unit
) then
11478 Par_Ent
:= Scope
(Gen_Unit
);
11479 Par_Vis
:= Is_Immediately_Visible
(Par_Ent
);
11480 Install_Parent
(Par_Ent
, In_Body
=> True);
11481 Parent_Installed
:= True;
11484 -- If the instantiation is a library unit, and this is the main unit,
11485 -- then build the resulting compilation unit nodes for the instance.
11486 -- If this is a compilation unit but it is not the main unit, then it
11487 -- is the body of a unit in the context, that is being compiled
11488 -- because it is encloses some inlined unit or another generic unit
11489 -- being instantiated. In that case, this body is not part of the
11490 -- current compilation, and is not attached to the tree, but its
11491 -- parent must be set for analysis.
11493 if Nkind
(Parent
(Inst_Node
)) = N_Compilation_Unit
then
11495 -- Replace instance node with body of instance, and create new
11496 -- node for corresponding instance declaration.
11498 Build_Instance_Compilation_Unit_Nodes
11499 (Inst_Node
, Act_Body
, Act_Decl
);
11500 Analyze
(Inst_Node
);
11502 if Parent
(Inst_Node
) = Cunit
(Main_Unit
) then
11504 -- If the instance is a child unit itself, then set the scope
11505 -- of the expanded body to be the parent of the instantiation
11506 -- (ensuring that the fully qualified name will be generated
11507 -- for the elaboration subprogram).
11509 if Nkind
(Defining_Unit_Name
(Act_Spec
)) =
11510 N_Defining_Program_Unit_Name
11512 Set_Scope
(Defining_Entity
(Inst_Node
), Scope
(Act_Decl_Id
));
11516 -- Case where instantiation is not a library unit
11519 -- If this is an early instantiation, i.e. appears textually
11520 -- before the corresponding body and must be elaborated first,
11521 -- indicate that the body instance is to be delayed.
11523 Install_Body
(Act_Body
, Inst_Node
, Gen_Body
, Gen_Decl
);
11525 -- Now analyze the body. We turn off all checks if this is an
11526 -- internal unit, since there is no reason to have checks on for
11527 -- any predefined run-time library code. All such code is designed
11528 -- to be compiled with checks off.
11530 -- Note that we do NOT apply this criterion to children of GNAT
11531 -- The latter units must suppress checks explicitly if needed.
11533 -- We also do not suppress checks in CodePeer mode where we are
11534 -- interested in finding possible runtime errors.
11536 if not CodePeer_Mode
11537 and then In_Predefined_Unit
(Gen_Decl
)
11539 Analyze
(Act_Body
, Suppress
=> All_Checks
);
11541 Analyze
(Act_Body
);
11545 Inherit_Context
(Gen_Body
, Inst_Node
);
11547 -- Remove the parent instances if they have been placed on the scope
11548 -- stack to compile the body.
11550 if Parent_Installed
then
11551 Remove_Parent
(In_Body
=> True);
11553 -- Restore the previous visibility of the parent
11555 Set_Is_Immediately_Visible
(Par_Ent
, Par_Vis
);
11558 Restore_Hidden_Primitives
(Vis_Prims_List
);
11559 Restore_Private_Views
(Act_Decl_Id
);
11561 -- Remove the current unit from visibility if this is an instance
11562 -- that is not elaborated on the fly for inlining purposes.
11564 if not Inlined_Body
then
11565 Set_Is_Immediately_Visible
(Act_Decl_Id
, False);
11570 -- If we have no body, and the unit requires a body, then complain. This
11571 -- complaint is suppressed if we have detected other errors (since a
11572 -- common reason for missing the body is that it had errors).
11573 -- In CodePeer mode, a warning has been emitted already, no need for
11574 -- further messages.
11576 elsif Unit_Requires_Body
(Gen_Unit
)
11577 and then not Body_Optional
11579 if CodePeer_Mode
then
11582 elsif Serious_Errors_Detected
= 0 then
11584 ("cannot find body of generic package &", Inst_Node
, Gen_Unit
);
11586 -- Don't attempt to perform any cleanup actions if some other error
11587 -- was already detected, since this can cause blowups.
11593 -- Case of package that does not need a body
11596 -- If the instantiation of the declaration is a library unit, rewrite
11597 -- the original package instantiation as a package declaration in the
11598 -- compilation unit node.
11600 if Nkind
(Parent
(Inst_Node
)) = N_Compilation_Unit
then
11601 Set_Parent_Spec
(Act_Decl
, Parent_Spec
(Inst_Node
));
11602 Rewrite
(Inst_Node
, Act_Decl
);
11604 -- Generate elaboration entity, in case spec has elaboration code.
11605 -- This cannot be done when the instance is analyzed, because it
11606 -- is not known yet whether the body exists.
11608 Set_Elaboration_Entity_Required
(Act_Decl_Id
, False);
11609 Build_Elaboration_Entity
(Parent
(Inst_Node
), Act_Decl_Id
);
11611 -- If the instantiation is not a library unit, then append the
11612 -- declaration to the list of implicitly generated entities, unless
11613 -- it is already a list member which means that it was already
11616 elsif not Is_List_Member
(Act_Decl
) then
11617 Mark_Rewrite_Insertion
(Act_Decl
);
11618 Insert_Before
(Inst_Node
, Act_Decl
);
11622 Expander_Mode_Restore
;
11625 Ignore_SPARK_Mode_Pragmas_In_Instance
:= Saved_ISMP
;
11626 Restore_Ghost_Mode
(Saved_GM
);
11627 Restore_SPARK_Mode
(Saved_SM
, Saved_SMP
);
11628 Style_Check
:= Saved_Style_Check
;
11629 end Instantiate_Package_Body
;
11631 ---------------------------------
11632 -- Instantiate_Subprogram_Body --
11633 ---------------------------------
11635 -- WARNING: This routine manages Ghost and SPARK regions. Return statements
11636 -- must be replaced by gotos which jump to the end of the routine in order
11637 -- to restore the Ghost and SPARK modes.
11639 procedure Instantiate_Subprogram_Body
11640 (Body_Info
: Pending_Body_Info
;
11641 Body_Optional
: Boolean := False)
11643 Act_Decl
: constant Node_Id
:= Body_Info
.Act_Decl
;
11644 Act_Decl_Id
: constant Entity_Id
:= Defining_Entity
(Act_Decl
);
11645 Inst_Node
: constant Node_Id
:= Body_Info
.Inst_Node
;
11646 Gen_Id
: constant Node_Id
:= Name
(Inst_Node
);
11647 Gen_Unit
: constant Entity_Id
:= Get_Generic_Entity
(Inst_Node
);
11648 Gen_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Gen_Unit
);
11649 Loc
: constant Source_Ptr
:= Sloc
(Inst_Node
);
11650 Pack_Id
: constant Entity_Id
:=
11651 Defining_Unit_Name
(Parent
(Act_Decl
));
11653 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
11654 Saved_ISMP
: constant Boolean :=
11655 Ignore_SPARK_Mode_Pragmas_In_Instance
;
11656 Saved_SM
: constant SPARK_Mode_Type
:= SPARK_Mode
;
11657 Saved_SMP
: constant Node_Id
:= SPARK_Mode_Pragma
;
11658 -- Save the Ghost and SPARK mode-related data to restore on exit
11660 Saved_Style_Check
: constant Boolean := Style_Check
;
11661 Saved_Warnings
: constant Warning_Record
:= Save_Warnings
;
11663 Act_Body
: Node_Id
;
11664 Act_Body_Id
: Entity_Id
;
11665 Gen_Body
: Node_Id
;
11666 Gen_Body_Id
: Node_Id
;
11667 Pack_Body
: Node_Id
;
11668 Par_Ent
: Entity_Id
:= Empty
;
11669 Par_Vis
: Boolean := False;
11670 Ret_Expr
: Node_Id
;
11672 Parent_Installed
: Boolean := False;
11675 Gen_Body_Id
:= Corresponding_Body
(Gen_Decl
);
11677 -- Subprogram body may have been created already because of an inline
11678 -- pragma, or because of multiple elaborations of the enclosing package
11679 -- when several instances of the subprogram appear in the main unit.
11681 if Present
(Corresponding_Body
(Act_Decl
)) then
11685 -- The subprogram being instantiated may be subject to pragma Ghost. Set
11686 -- the mode now to ensure that any nodes generated during instantiation
11687 -- are properly marked as Ghost.
11689 Set_Ghost_Mode
(Act_Decl_Id
);
11691 Expander_Mode_Save_And_Set
(Body_Info
.Expander_Status
);
11693 -- Re-establish the state of information on which checks are suppressed.
11694 -- This information was set in Body_Info at the point of instantiation,
11695 -- and now we restore it so that the instance is compiled using the
11696 -- check status at the instantiation (RM 11.5(7.2/2), AI95-00224-01).
11698 Local_Suppress_Stack_Top
:= Body_Info
.Local_Suppress_Stack_Top
;
11699 Scope_Suppress
:= Body_Info
.Scope_Suppress
;
11700 Opt
.Ada_Version
:= Body_Info
.Version
;
11701 Opt
.Ada_Version_Pragma
:= Body_Info
.Version_Pragma
;
11702 Restore_Warnings
(Body_Info
.Warnings
);
11704 -- Install the SPARK mode which applies to the subprogram body from the
11705 -- instantiation context. This may be refined further if an explicit
11706 -- SPARK_Mode pragma applies to the generic body.
11708 Install_SPARK_Mode
(Body_Info
.SPARK_Mode
, Body_Info
.SPARK_Mode_Pragma
);
11710 if No
(Gen_Body_Id
) then
11712 -- For imported generic subprogram, no body to compile, complete
11713 -- the spec entity appropriately.
11715 if Is_Imported
(Gen_Unit
) then
11716 Set_Is_Imported
(Act_Decl_Id
);
11717 Set_First_Rep_Item
(Act_Decl_Id
, First_Rep_Item
(Gen_Unit
));
11718 Set_Interface_Name
(Act_Decl_Id
, Interface_Name
(Gen_Unit
));
11719 Set_Convention
(Act_Decl_Id
, Convention
(Gen_Unit
));
11720 Set_Has_Completion
(Act_Decl_Id
);
11723 -- For other cases, compile the body
11726 Load_Parent_Of_Generic
11727 (Inst_Node
, Specification
(Gen_Decl
), Body_Optional
);
11728 Gen_Body_Id
:= Corresponding_Body
(Gen_Decl
);
11732 Instantiation_Node
:= Inst_Node
;
11734 if Present
(Gen_Body_Id
) then
11735 Gen_Body
:= Unit_Declaration_Node
(Gen_Body_Id
);
11737 if Nkind
(Gen_Body
) = N_Subprogram_Body_Stub
then
11739 -- Either body is not present, or context is non-expanding, as
11740 -- when compiling a subunit. Mark the instance as completed, and
11741 -- diagnose a missing body when needed.
11744 and then Operating_Mode
= Generate_Code
11746 Error_Msg_N
("missing proper body for instantiation", Gen_Body
);
11749 Set_Has_Completion
(Act_Decl_Id
);
11753 Save_Env
(Gen_Unit
, Act_Decl_Id
);
11754 Style_Check
:= False;
11756 -- If the context of the instance is subject to SPARK_Mode "off", the
11757 -- annotation is missing, or the body is instantiated at a later pass
11758 -- and its spec ignored SPARK_Mode pragma, set the global flag which
11759 -- signals Analyze_Pragma to ignore all SPARK_Mode pragmas within the
11762 if SPARK_Mode
/= On
11763 or else Ignore_SPARK_Mode_Pragmas
(Act_Decl_Id
)
11765 Ignore_SPARK_Mode_Pragmas_In_Instance
:= True;
11768 -- If the context of an instance is not subject to SPARK_Mode "off",
11769 -- and the generic body is subject to an explicit SPARK_Mode pragma,
11770 -- the latter should be the one applicable to the instance.
11772 if not Ignore_SPARK_Mode_Pragmas_In_Instance
11773 and then SPARK_Mode
/= Off
11774 and then Present
(SPARK_Pragma
(Gen_Body_Id
))
11776 Set_SPARK_Mode
(Gen_Body_Id
);
11779 Current_Sem_Unit
:= Body_Info
.Current_Sem_Unit
;
11780 Create_Instantiation_Source
11787 (Original_Node
(Gen_Body
), Empty
, Instantiating
=> True);
11789 -- Create proper defining name for the body, to correspond to the one
11793 Make_Defining_Identifier
(Sloc
(Act_Decl_Id
), Chars
(Act_Decl_Id
));
11795 Set_Comes_From_Source
(Act_Body_Id
, Comes_From_Source
(Act_Decl_Id
));
11796 Set_Defining_Unit_Name
(Specification
(Act_Body
), Act_Body_Id
);
11798 Set_Corresponding_Spec
(Act_Body
, Act_Decl_Id
);
11799 Set_Has_Completion
(Act_Decl_Id
);
11800 Check_Generic_Actuals
(Pack_Id
, False);
11802 -- Generate a reference to link the visible subprogram instance to
11803 -- the generic body, which for navigation purposes is the only
11804 -- available source for the instance.
11807 (Related_Instance
(Pack_Id
),
11808 Gen_Body_Id
, 'b', Set_Ref
=> False, Force
=> True);
11810 -- If it is a child unit, make the parent instance (which is an
11811 -- instance of the parent of the generic) visible. The parent
11812 -- instance is the prefix of the name of the generic unit.
11814 if Ekind
(Scope
(Gen_Unit
)) = E_Generic_Package
11815 and then Nkind
(Gen_Id
) = N_Expanded_Name
11817 Par_Ent
:= Entity
(Prefix
(Gen_Id
));
11818 Par_Vis
:= Is_Immediately_Visible
(Par_Ent
);
11819 Install_Parent
(Par_Ent
, In_Body
=> True);
11820 Parent_Installed
:= True;
11822 elsif Is_Child_Unit
(Gen_Unit
) then
11823 Par_Ent
:= Scope
(Gen_Unit
);
11824 Par_Vis
:= Is_Immediately_Visible
(Par_Ent
);
11825 Install_Parent
(Par_Ent
, In_Body
=> True);
11826 Parent_Installed
:= True;
11829 -- Subprogram body is placed in the body of wrapper package,
11830 -- whose spec contains the subprogram declaration as well as
11831 -- the renaming declarations for the generic parameters.
11834 Make_Package_Body
(Loc
,
11835 Defining_Unit_Name
=> New_Copy
(Pack_Id
),
11836 Declarations
=> New_List
(Act_Body
));
11838 Set_Corresponding_Spec
(Pack_Body
, Pack_Id
);
11840 -- If the instantiation is a library unit, then build resulting
11841 -- compilation unit nodes for the instance. The declaration of
11842 -- the enclosing package is the grandparent of the subprogram
11843 -- declaration. First replace the instantiation node as the unit
11844 -- of the corresponding compilation.
11846 if Nkind
(Parent
(Inst_Node
)) = N_Compilation_Unit
then
11847 if Parent
(Inst_Node
) = Cunit
(Main_Unit
) then
11848 Set_Unit
(Parent
(Inst_Node
), Inst_Node
);
11849 Build_Instance_Compilation_Unit_Nodes
11850 (Inst_Node
, Pack_Body
, Parent
(Parent
(Act_Decl
)));
11851 Analyze
(Inst_Node
);
11853 Set_Parent
(Pack_Body
, Parent
(Inst_Node
));
11854 Analyze
(Pack_Body
);
11858 Insert_Before
(Inst_Node
, Pack_Body
);
11859 Mark_Rewrite_Insertion
(Pack_Body
);
11860 Analyze
(Pack_Body
);
11862 if Expander_Active
then
11863 Freeze_Subprogram_Body
(Inst_Node
, Gen_Body
, Pack_Id
);
11867 Inherit_Context
(Gen_Body
, Inst_Node
);
11869 Restore_Private_Views
(Pack_Id
, False);
11871 if Parent_Installed
then
11872 Remove_Parent
(In_Body
=> True);
11874 -- Restore the previous visibility of the parent
11876 Set_Is_Immediately_Visible
(Par_Ent
, Par_Vis
);
11880 Restore_Warnings
(Saved_Warnings
);
11882 -- Body not found. Error was emitted already. If there were no previous
11883 -- errors, this may be an instance whose scope is a premature instance.
11884 -- In that case we must insure that the (legal) program does raise
11885 -- program error if executed. We generate a subprogram body for this
11886 -- purpose. See DEC ac30vso.
11888 -- Should not reference proprietary DEC tests in comments ???
11890 elsif Serious_Errors_Detected
= 0
11891 and then Nkind
(Parent
(Inst_Node
)) /= N_Compilation_Unit
11893 if Body_Optional
then
11896 elsif Ekind
(Act_Decl_Id
) = E_Procedure
then
11898 Make_Subprogram_Body
(Loc
,
11900 Make_Procedure_Specification
(Loc
,
11901 Defining_Unit_Name
=>
11902 Make_Defining_Identifier
(Loc
, Chars
(Act_Decl_Id
)),
11903 Parameter_Specifications
=>
11905 (Parameter_Specifications
(Parent
(Act_Decl_Id
)))),
11907 Declarations
=> Empty_List
,
11908 Handled_Statement_Sequence
=>
11909 Make_Handled_Sequence_Of_Statements
(Loc
,
11910 Statements
=> New_List
(
11911 Make_Raise_Program_Error
(Loc
,
11912 Reason
=> PE_Access_Before_Elaboration
))));
11916 Make_Raise_Program_Error
(Loc
,
11917 Reason
=> PE_Access_Before_Elaboration
);
11919 Set_Etype
(Ret_Expr
, (Etype
(Act_Decl_Id
)));
11920 Set_Analyzed
(Ret_Expr
);
11923 Make_Subprogram_Body
(Loc
,
11925 Make_Function_Specification
(Loc
,
11926 Defining_Unit_Name
=>
11927 Make_Defining_Identifier
(Loc
, Chars
(Act_Decl_Id
)),
11928 Parameter_Specifications
=>
11930 (Parameter_Specifications
(Parent
(Act_Decl_Id
))),
11931 Result_Definition
=>
11932 New_Occurrence_Of
(Etype
(Act_Decl_Id
), Loc
)),
11934 Declarations
=> Empty_List
,
11935 Handled_Statement_Sequence
=>
11936 Make_Handled_Sequence_Of_Statements
(Loc
,
11937 Statements
=> New_List
(
11938 Make_Simple_Return_Statement
(Loc
, Ret_Expr
))));
11942 Make_Package_Body
(Loc
,
11943 Defining_Unit_Name
=> New_Copy
(Pack_Id
),
11944 Declarations
=> New_List
(Act_Body
));
11946 Insert_After
(Inst_Node
, Pack_Body
);
11947 Set_Corresponding_Spec
(Pack_Body
, Pack_Id
);
11948 Analyze
(Pack_Body
);
11951 Expander_Mode_Restore
;
11954 Ignore_SPARK_Mode_Pragmas_In_Instance
:= Saved_ISMP
;
11955 Restore_Ghost_Mode
(Saved_GM
);
11956 Restore_SPARK_Mode
(Saved_SM
, Saved_SMP
);
11957 Style_Check
:= Saved_Style_Check
;
11958 end Instantiate_Subprogram_Body
;
11960 ----------------------
11961 -- Instantiate_Type --
11962 ----------------------
11964 function Instantiate_Type
11967 Analyzed_Formal
: Node_Id
;
11968 Actual_Decls
: List_Id
) return List_Id
11970 A_Gen_T
: constant Entity_Id
:=
11971 Defining_Identifier
(Analyzed_Formal
);
11972 Def
: constant Node_Id
:= Formal_Type_Definition
(Formal
);
11973 Gen_T
: constant Entity_Id
:= Defining_Identifier
(Formal
);
11975 Ancestor
: Entity_Id
:= Empty
;
11976 Decl_Node
: Node_Id
;
11977 Decl_Nodes
: List_Id
;
11981 procedure Diagnose_Predicated_Actual
;
11982 -- There are a number of constructs in which a discrete type with
11983 -- predicates is illegal, e.g. as an index in an array type declaration.
11984 -- If a generic type is used is such a construct in a generic package
11985 -- declaration, it carries the flag No_Predicate_On_Actual. it is part
11986 -- of the generic contract that the actual cannot have predicates.
11988 procedure Validate_Array_Type_Instance
;
11989 procedure Validate_Access_Subprogram_Instance
;
11990 procedure Validate_Access_Type_Instance
;
11991 procedure Validate_Derived_Type_Instance
;
11992 procedure Validate_Derived_Interface_Type_Instance
;
11993 procedure Validate_Discriminated_Formal_Type
;
11994 procedure Validate_Interface_Type_Instance
;
11995 procedure Validate_Private_Type_Instance
;
11996 procedure Validate_Incomplete_Type_Instance
;
11997 -- These procedures perform validation tests for the named case.
11998 -- Validate_Discriminated_Formal_Type is shared by formal private
11999 -- types and Ada 2012 formal incomplete types.
12001 function Subtypes_Match
(Gen_T
, Act_T
: Entity_Id
) return Boolean;
12002 -- Check that base types are the same and that the subtypes match
12003 -- statically. Used in several of the above.
12005 ---------------------------------
12006 -- Diagnose_Predicated_Actual --
12007 ---------------------------------
12009 procedure Diagnose_Predicated_Actual
is
12011 if No_Predicate_On_Actual
(A_Gen_T
)
12012 and then Has_Predicates
(Act_T
)
12015 ("actual for& cannot be a type with predicate",
12016 Instantiation_Node
, A_Gen_T
);
12018 elsif No_Dynamic_Predicate_On_Actual
(A_Gen_T
)
12019 and then Has_Predicates
(Act_T
)
12020 and then not Has_Static_Predicate_Aspect
(Act_T
)
12023 ("actual for& cannot be a type with a dynamic predicate",
12024 Instantiation_Node
, A_Gen_T
);
12026 end Diagnose_Predicated_Actual
;
12028 --------------------
12029 -- Subtypes_Match --
12030 --------------------
12032 function Subtypes_Match
(Gen_T
, Act_T
: Entity_Id
) return Boolean is
12033 T
: constant Entity_Id
:= Get_Instance_Of
(Gen_T
);
12036 -- Some detailed comments would be useful here ???
12038 return ((Base_Type
(T
) = Act_T
12039 or else Base_Type
(T
) = Base_Type
(Act_T
))
12040 and then Subtypes_Statically_Match
(T
, Act_T
))
12042 or else (Is_Class_Wide_Type
(Gen_T
)
12043 and then Is_Class_Wide_Type
(Act_T
)
12044 and then Subtypes_Match
12045 (Get_Instance_Of
(Root_Type
(Gen_T
)),
12046 Root_Type
(Act_T
)))
12049 (Ekind_In
(Gen_T
, E_Anonymous_Access_Subprogram_Type
,
12050 E_Anonymous_Access_Type
)
12051 and then Ekind
(Act_T
) = Ekind
(Gen_T
)
12052 and then Subtypes_Statically_Match
12053 (Designated_Type
(Gen_T
), Designated_Type
(Act_T
)));
12054 end Subtypes_Match
;
12056 -----------------------------------------
12057 -- Validate_Access_Subprogram_Instance --
12058 -----------------------------------------
12060 procedure Validate_Access_Subprogram_Instance
is
12062 if not Is_Access_Type
(Act_T
)
12063 or else Ekind
(Designated_Type
(Act_T
)) /= E_Subprogram_Type
12066 ("expect access type in instantiation of &", Actual
, Gen_T
);
12067 Abandon_Instantiation
(Actual
);
12070 -- According to AI05-288, actuals for access_to_subprograms must be
12071 -- subtype conformant with the generic formal. Previous to AI05-288
12072 -- only mode conformance was required.
12074 -- This is a binding interpretation that applies to previous versions
12075 -- of the language, no need to maintain previous weaker checks.
12077 Check_Subtype_Conformant
12078 (Designated_Type
(Act_T
),
12079 Designated_Type
(A_Gen_T
),
12083 if Ekind
(Base_Type
(Act_T
)) = E_Access_Protected_Subprogram_Type
then
12084 if Ekind
(A_Gen_T
) = E_Access_Subprogram_Type
then
12086 ("protected access type not allowed for formal &",
12090 elsif Ekind
(A_Gen_T
) = E_Access_Protected_Subprogram_Type
then
12092 ("expect protected access type for formal &",
12096 -- If the formal has a specified convention (which in most cases
12097 -- will be StdCall) verify that the actual has the same convention.
12099 if Has_Convention_Pragma
(A_Gen_T
)
12100 and then Convention
(A_Gen_T
) /= Convention
(Act_T
)
12102 Error_Msg_Name_1
:= Get_Convention_Name
(Convention
(A_Gen_T
));
12104 ("actual for formal & must have convention %", Actual
, Gen_T
);
12106 end Validate_Access_Subprogram_Instance
;
12108 -----------------------------------
12109 -- Validate_Access_Type_Instance --
12110 -----------------------------------
12112 procedure Validate_Access_Type_Instance
is
12113 Desig_Type
: constant Entity_Id
:=
12114 Find_Actual_Type
(Designated_Type
(A_Gen_T
), A_Gen_T
);
12115 Desig_Act
: Entity_Id
;
12118 if not Is_Access_Type
(Act_T
) then
12120 ("expect access type in instantiation of &", Actual
, Gen_T
);
12121 Abandon_Instantiation
(Actual
);
12124 if Is_Access_Constant
(A_Gen_T
) then
12125 if not Is_Access_Constant
(Act_T
) then
12127 ("actual type must be access-to-constant type", Actual
);
12128 Abandon_Instantiation
(Actual
);
12131 if Is_Access_Constant
(Act_T
) then
12133 ("actual type must be access-to-variable type", Actual
);
12134 Abandon_Instantiation
(Actual
);
12136 elsif Ekind
(A_Gen_T
) = E_General_Access_Type
12137 and then Ekind
(Base_Type
(Act_T
)) /= E_General_Access_Type
12139 Error_Msg_N
-- CODEFIX
12140 ("actual must be general access type!", Actual
);
12141 Error_Msg_NE
-- CODEFIX
12142 ("add ALL to }!", Actual
, Act_T
);
12143 Abandon_Instantiation
(Actual
);
12147 -- The designated subtypes, that is to say the subtypes introduced
12148 -- by an access type declaration (and not by a subtype declaration)
12151 Desig_Act
:= Designated_Type
(Base_Type
(Act_T
));
12153 -- The designated type may have been introduced through a limited_
12154 -- with clause, in which case retrieve the non-limited view. This
12155 -- applies to incomplete types as well as to class-wide types.
12157 if From_Limited_With
(Desig_Act
) then
12158 Desig_Act
:= Available_View
(Desig_Act
);
12161 if not Subtypes_Match
(Desig_Type
, Desig_Act
) then
12163 ("designated type of actual does not match that of formal &",
12166 if not Predicates_Match
(Desig_Type
, Desig_Act
) then
12167 Error_Msg_N
("\predicates do not match", Actual
);
12170 Abandon_Instantiation
(Actual
);
12172 elsif Is_Access_Type
(Designated_Type
(Act_T
))
12173 and then Is_Constrained
(Designated_Type
(Designated_Type
(Act_T
)))
12175 Is_Constrained
(Designated_Type
(Desig_Type
))
12178 ("designated type of actual does not match that of formal &",
12181 if not Predicates_Match
(Desig_Type
, Desig_Act
) then
12182 Error_Msg_N
("\predicates do not match", Actual
);
12185 Abandon_Instantiation
(Actual
);
12188 -- Ada 2005: null-exclusion indicators of the two types must agree
12190 if Can_Never_Be_Null
(A_Gen_T
) /= Can_Never_Be_Null
(Act_T
) then
12192 ("non null exclusion of actual and formal & do not match",
12195 end Validate_Access_Type_Instance
;
12197 ----------------------------------
12198 -- Validate_Array_Type_Instance --
12199 ----------------------------------
12201 procedure Validate_Array_Type_Instance
is
12206 function Formal_Dimensions
return Nat
;
12207 -- Count number of dimensions in array type formal
12209 -----------------------
12210 -- Formal_Dimensions --
12211 -----------------------
12213 function Formal_Dimensions
return Nat
is
12218 if Nkind
(Def
) = N_Constrained_Array_Definition
then
12219 Index
:= First
(Discrete_Subtype_Definitions
(Def
));
12221 Index
:= First
(Subtype_Marks
(Def
));
12224 while Present
(Index
) loop
12226 Next_Index
(Index
);
12230 end Formal_Dimensions
;
12232 -- Start of processing for Validate_Array_Type_Instance
12235 if not Is_Array_Type
(Act_T
) then
12237 ("expect array type in instantiation of &", Actual
, Gen_T
);
12238 Abandon_Instantiation
(Actual
);
12240 elsif Nkind
(Def
) = N_Constrained_Array_Definition
then
12241 if not (Is_Constrained
(Act_T
)) then
12243 ("expect constrained array in instantiation of &",
12245 Abandon_Instantiation
(Actual
);
12249 if Is_Constrained
(Act_T
) then
12251 ("expect unconstrained array in instantiation of &",
12253 Abandon_Instantiation
(Actual
);
12257 if Formal_Dimensions
/= Number_Dimensions
(Act_T
) then
12259 ("dimensions of actual do not match formal &", Actual
, Gen_T
);
12260 Abandon_Instantiation
(Actual
);
12263 I1
:= First_Index
(A_Gen_T
);
12264 I2
:= First_Index
(Act_T
);
12265 for J
in 1 .. Formal_Dimensions
loop
12267 -- If the indexes of the actual were given by a subtype_mark,
12268 -- the index was transformed into a range attribute. Retrieve
12269 -- the original type mark for checking.
12271 if Is_Entity_Name
(Original_Node
(I2
)) then
12272 T2
:= Entity
(Original_Node
(I2
));
12277 if not Subtypes_Match
12278 (Find_Actual_Type
(Etype
(I1
), A_Gen_T
), T2
)
12281 ("index types of actual do not match those of formal &",
12283 Abandon_Instantiation
(Actual
);
12290 -- Check matching subtypes. Note that there are complex visibility
12291 -- issues when the generic is a child unit and some aspect of the
12292 -- generic type is declared in a parent unit of the generic. We do
12293 -- the test to handle this special case only after a direct check
12294 -- for static matching has failed. The case where both the component
12295 -- type and the array type are separate formals, and the component
12296 -- type is a private view may also require special checking in
12297 -- Subtypes_Match. Finally, we assume that a child instance where
12298 -- the component type comes from a formal of a parent instance is
12299 -- correct because the generic was correct. A more precise check
12300 -- seems too complex to install???
12303 (Component_Type
(A_Gen_T
), Component_Type
(Act_T
))
12306 (Find_Actual_Type
(Component_Type
(A_Gen_T
), A_Gen_T
),
12307 Component_Type
(Act_T
))
12309 (not Inside_A_Generic
12310 and then Is_Child_Unit
(Scope
(Component_Type
(A_Gen_T
))))
12315 ("component subtype of actual does not match that of formal &",
12317 Abandon_Instantiation
(Actual
);
12320 if Has_Aliased_Components
(A_Gen_T
)
12321 and then not Has_Aliased_Components
(Act_T
)
12324 ("actual must have aliased components to match formal type &",
12327 end Validate_Array_Type_Instance
;
12329 -----------------------------------------------
12330 -- Validate_Derived_Interface_Type_Instance --
12331 -----------------------------------------------
12333 procedure Validate_Derived_Interface_Type_Instance
is
12334 Par
: constant Entity_Id
:= Entity
(Subtype_Indication
(Def
));
12338 -- First apply interface instance checks
12340 Validate_Interface_Type_Instance
;
12342 -- Verify that immediate parent interface is an ancestor of
12346 and then not Interface_Present_In_Ancestor
(Act_T
, Par
)
12349 ("interface actual must include progenitor&", Actual
, Par
);
12352 -- Now verify that the actual includes all other ancestors of
12355 Elmt
:= First_Elmt
(Interfaces
(A_Gen_T
));
12356 while Present
(Elmt
) loop
12357 if not Interface_Present_In_Ancestor
12358 (Act_T
, Get_Instance_Of
(Node
(Elmt
)))
12361 ("interface actual must include progenitor&",
12362 Actual
, Node
(Elmt
));
12367 end Validate_Derived_Interface_Type_Instance
;
12369 ------------------------------------
12370 -- Validate_Derived_Type_Instance --
12371 ------------------------------------
12373 procedure Validate_Derived_Type_Instance
is
12374 Actual_Discr
: Entity_Id
;
12375 Ancestor_Discr
: Entity_Id
;
12378 -- If the parent type in the generic declaration is itself a previous
12379 -- formal type, then it is local to the generic and absent from the
12380 -- analyzed generic definition. In that case the ancestor is the
12381 -- instance of the formal (which must have been instantiated
12382 -- previously), unless the ancestor is itself a formal derived type.
12383 -- In this latter case (which is the subject of Corrigendum 8652/0038
12384 -- (AI-202) the ancestor of the formals is the ancestor of its
12385 -- parent. Otherwise, the analyzed generic carries the parent type.
12386 -- If the parent type is defined in a previous formal package, then
12387 -- the scope of that formal package is that of the generic type
12388 -- itself, and it has already been mapped into the corresponding type
12389 -- in the actual package.
12391 -- Common case: parent type defined outside of the generic
12393 if Is_Entity_Name
(Subtype_Mark
(Def
))
12394 and then Present
(Entity
(Subtype_Mark
(Def
)))
12396 Ancestor
:= Get_Instance_Of
(Entity
(Subtype_Mark
(Def
)));
12398 -- Check whether parent is defined in a previous formal package
12401 Scope
(Scope
(Base_Type
(Etype
(A_Gen_T
)))) = Scope
(A_Gen_T
)
12404 Get_Instance_Of
(Base_Type
(Etype
(A_Gen_T
)));
12406 -- The type may be a local derivation, or a type extension of a
12407 -- previous formal, or of a formal of a parent package.
12409 elsif Is_Derived_Type
(Get_Instance_Of
(A_Gen_T
))
12411 Ekind
(Get_Instance_Of
(A_Gen_T
)) = E_Record_Type_With_Private
12413 -- Check whether the parent is another derived formal type in the
12414 -- same generic unit.
12416 if Etype
(A_Gen_T
) /= A_Gen_T
12417 and then Is_Generic_Type
(Etype
(A_Gen_T
))
12418 and then Scope
(Etype
(A_Gen_T
)) = Scope
(A_Gen_T
)
12419 and then Etype
(Etype
(A_Gen_T
)) /= Etype
(A_Gen_T
)
12421 -- Locate ancestor of parent from the subtype declaration
12422 -- created for the actual.
12428 Decl
:= First
(Actual_Decls
);
12429 while Present
(Decl
) loop
12430 if Nkind
(Decl
) = N_Subtype_Declaration
12431 and then Chars
(Defining_Identifier
(Decl
)) =
12432 Chars
(Etype
(A_Gen_T
))
12434 Ancestor
:= Generic_Parent_Type
(Decl
);
12442 pragma Assert
(Present
(Ancestor
));
12444 -- The ancestor itself may be a previous formal that has been
12447 Ancestor
:= Get_Instance_Of
(Ancestor
);
12451 Get_Instance_Of
(Base_Type
(Get_Instance_Of
(A_Gen_T
)));
12454 -- Check whether parent is a previous formal of the current generic
12456 elsif Is_Derived_Type
(A_Gen_T
)
12457 and then Is_Generic_Type
(Etype
(A_Gen_T
))
12458 and then Scope
(A_Gen_T
) = Scope
(Etype
(A_Gen_T
))
12460 Ancestor
:= Get_Instance_Of
(First_Subtype
(Etype
(A_Gen_T
)));
12462 -- An unusual case: the actual is a type declared in a parent unit,
12463 -- but is not a formal type so there is no instance_of for it.
12464 -- Retrieve it by analyzing the record extension.
12466 elsif Is_Child_Unit
(Scope
(A_Gen_T
))
12467 and then In_Open_Scopes
(Scope
(Act_T
))
12468 and then Is_Generic_Instance
(Scope
(Act_T
))
12470 Analyze
(Subtype_Mark
(Def
));
12471 Ancestor
:= Entity
(Subtype_Mark
(Def
));
12474 Ancestor
:= Get_Instance_Of
(Etype
(Base_Type
(A_Gen_T
)));
12477 -- If the formal derived type has pragma Preelaborable_Initialization
12478 -- then the actual type must have preelaborable initialization.
12480 if Known_To_Have_Preelab_Init
(A_Gen_T
)
12481 and then not Has_Preelaborable_Initialization
(Act_T
)
12484 ("actual for & must have preelaborable initialization",
12488 -- Ada 2005 (AI-251)
12490 if Ada_Version
>= Ada_2005
and then Is_Interface
(Ancestor
) then
12491 if not Interface_Present_In_Ancestor
(Act_T
, Ancestor
) then
12493 ("(Ada 2005) expected type implementing & in instantiation",
12497 -- Finally verify that the (instance of) the ancestor is an ancestor
12500 elsif not Is_Ancestor
(Base_Type
(Ancestor
), Act_T
) then
12502 ("expect type derived from & in instantiation",
12503 Actual
, First_Subtype
(Ancestor
));
12504 Abandon_Instantiation
(Actual
);
12507 -- Ada 2005 (AI-443): Synchronized formal derived type checks. Note
12508 -- that the formal type declaration has been rewritten as a private
12511 if Ada_Version
>= Ada_2005
12512 and then Nkind
(Parent
(A_Gen_T
)) = N_Private_Extension_Declaration
12513 and then Synchronized_Present
(Parent
(A_Gen_T
))
12515 -- The actual must be a synchronized tagged type
12517 if not Is_Tagged_Type
(Act_T
) then
12519 ("actual of synchronized type must be tagged", Actual
);
12520 Abandon_Instantiation
(Actual
);
12522 elsif Nkind
(Parent
(Act_T
)) = N_Full_Type_Declaration
12523 and then Nkind
(Type_Definition
(Parent
(Act_T
))) =
12524 N_Derived_Type_Definition
12525 and then not Synchronized_Present
12526 (Type_Definition
(Parent
(Act_T
)))
12529 ("actual of synchronized type must be synchronized", Actual
);
12530 Abandon_Instantiation
(Actual
);
12534 -- Perform atomic/volatile checks (RM C.6(12)). Note that AI05-0218-1
12535 -- removes the second instance of the phrase "or allow pass by copy".
12537 if Is_Atomic
(Act_T
) and then not Is_Atomic
(Ancestor
) then
12539 ("cannot have atomic actual type for non-atomic formal type",
12542 elsif Is_Volatile
(Act_T
) and then not Is_Volatile
(Ancestor
) then
12544 ("cannot have volatile actual type for non-volatile formal type",
12548 -- It should not be necessary to check for unknown discriminants on
12549 -- Formal, but for some reason Has_Unknown_Discriminants is false for
12550 -- A_Gen_T, so Is_Definite_Subtype incorrectly returns True. This
12551 -- needs fixing. ???
12553 if Is_Definite_Subtype
(A_Gen_T
)
12554 and then not Unknown_Discriminants_Present
(Formal
)
12555 and then not Is_Definite_Subtype
(Act_T
)
12557 Error_Msg_N
("actual subtype must be constrained", Actual
);
12558 Abandon_Instantiation
(Actual
);
12561 if not Unknown_Discriminants_Present
(Formal
) then
12562 if Is_Constrained
(Ancestor
) then
12563 if not Is_Constrained
(Act_T
) then
12564 Error_Msg_N
("actual subtype must be constrained", Actual
);
12565 Abandon_Instantiation
(Actual
);
12568 -- Ancestor is unconstrained, Check if generic formal and actual
12569 -- agree on constrainedness. The check only applies to array types
12570 -- and discriminated types.
12572 elsif Is_Constrained
(Act_T
) then
12573 if Ekind
(Ancestor
) = E_Access_Type
12574 or else (not Is_Constrained
(A_Gen_T
)
12575 and then Is_Composite_Type
(A_Gen_T
))
12577 Error_Msg_N
("actual subtype must be unconstrained", Actual
);
12578 Abandon_Instantiation
(Actual
);
12581 -- A class-wide type is only allowed if the formal has unknown
12584 elsif Is_Class_Wide_Type
(Act_T
)
12585 and then not Has_Unknown_Discriminants
(Ancestor
)
12588 ("actual for & cannot be a class-wide type", Actual
, Gen_T
);
12589 Abandon_Instantiation
(Actual
);
12591 -- Otherwise, the formal and actual must have the same number
12592 -- of discriminants and each discriminant of the actual must
12593 -- correspond to a discriminant of the formal.
12595 elsif Has_Discriminants
(Act_T
)
12596 and then not Has_Unknown_Discriminants
(Act_T
)
12597 and then Has_Discriminants
(Ancestor
)
12599 Actual_Discr
:= First_Discriminant
(Act_T
);
12600 Ancestor_Discr
:= First_Discriminant
(Ancestor
);
12601 while Present
(Actual_Discr
)
12602 and then Present
(Ancestor_Discr
)
12604 if Base_Type
(Act_T
) /= Base_Type
(Ancestor
) and then
12605 No
(Corresponding_Discriminant
(Actual_Discr
))
12608 ("discriminant & does not correspond "
12609 & "to ancestor discriminant", Actual
, Actual_Discr
);
12610 Abandon_Instantiation
(Actual
);
12613 Next_Discriminant
(Actual_Discr
);
12614 Next_Discriminant
(Ancestor_Discr
);
12617 if Present
(Actual_Discr
) or else Present
(Ancestor_Discr
) then
12619 ("actual for & must have same number of discriminants",
12621 Abandon_Instantiation
(Actual
);
12624 -- This case should be caught by the earlier check for
12625 -- constrainedness, but the check here is added for completeness.
12627 elsif Has_Discriminants
(Act_T
)
12628 and then not Has_Unknown_Discriminants
(Act_T
)
12631 ("actual for & must not have discriminants", Actual
, Gen_T
);
12632 Abandon_Instantiation
(Actual
);
12634 elsif Has_Discriminants
(Ancestor
) then
12636 ("actual for & must have known discriminants", Actual
, Gen_T
);
12637 Abandon_Instantiation
(Actual
);
12640 if not Subtypes_Statically_Compatible
12641 (Act_T
, Ancestor
, Formal_Derived_Matching
=> True)
12644 ("constraint on actual is incompatible with formal", Actual
);
12645 Abandon_Instantiation
(Actual
);
12649 -- If the formal and actual types are abstract, check that there
12650 -- are no abstract primitives of the actual type that correspond to
12651 -- nonabstract primitives of the formal type (second sentence of
12654 if Is_Abstract_Type
(A_Gen_T
) and then Is_Abstract_Type
(Act_T
) then
12655 Check_Abstract_Primitives
: declare
12656 Gen_Prims
: constant Elist_Id
:=
12657 Primitive_Operations
(A_Gen_T
);
12658 Gen_Elmt
: Elmt_Id
;
12659 Gen_Subp
: Entity_Id
;
12660 Anc_Subp
: Entity_Id
;
12661 Anc_Formal
: Entity_Id
;
12662 Anc_F_Type
: Entity_Id
;
12664 Act_Prims
: constant Elist_Id
:= Primitive_Operations
(Act_T
);
12665 Act_Elmt
: Elmt_Id
;
12666 Act_Subp
: Entity_Id
;
12667 Act_Formal
: Entity_Id
;
12668 Act_F_Type
: Entity_Id
;
12670 Subprograms_Correspond
: Boolean;
12672 function Is_Tagged_Ancestor
(T1
, T2
: Entity_Id
) return Boolean;
12673 -- Returns true if T2 is derived directly or indirectly from
12674 -- T1, including derivations from interfaces. T1 and T2 are
12675 -- required to be specific tagged base types.
12677 ------------------------
12678 -- Is_Tagged_Ancestor --
12679 ------------------------
12681 function Is_Tagged_Ancestor
(T1
, T2
: Entity_Id
) return Boolean
12683 Intfc_Elmt
: Elmt_Id
;
12686 -- The predicate is satisfied if the types are the same
12691 -- If we've reached the top of the derivation chain then
12692 -- we know that T1 is not an ancestor of T2.
12694 elsif Etype
(T2
) = T2
then
12697 -- Proceed to check T2's immediate parent
12699 elsif Is_Ancestor
(T1
, Base_Type
(Etype
(T2
))) then
12702 -- Finally, check to see if T1 is an ancestor of any of T2's
12706 Intfc_Elmt
:= First_Elmt
(Interfaces
(T2
));
12707 while Present
(Intfc_Elmt
) loop
12708 if Is_Ancestor
(T1
, Node
(Intfc_Elmt
)) then
12712 Next_Elmt
(Intfc_Elmt
);
12717 end Is_Tagged_Ancestor
;
12719 -- Start of processing for Check_Abstract_Primitives
12722 -- Loop over all of the formal derived type's primitives
12724 Gen_Elmt
:= First_Elmt
(Gen_Prims
);
12725 while Present
(Gen_Elmt
) loop
12726 Gen_Subp
:= Node
(Gen_Elmt
);
12728 -- If the primitive of the formal is not abstract, then
12729 -- determine whether there is a corresponding primitive of
12730 -- the actual type that's abstract.
12732 if not Is_Abstract_Subprogram
(Gen_Subp
) then
12733 Act_Elmt
:= First_Elmt
(Act_Prims
);
12734 while Present
(Act_Elmt
) loop
12735 Act_Subp
:= Node
(Act_Elmt
);
12737 -- If we find an abstract primitive of the actual,
12738 -- then we need to test whether it corresponds to the
12739 -- subprogram from which the generic formal primitive
12742 if Is_Abstract_Subprogram
(Act_Subp
) then
12743 Anc_Subp
:= Alias
(Gen_Subp
);
12745 -- Test whether we have a corresponding primitive
12746 -- by comparing names, kinds, formal types, and
12749 if Chars
(Anc_Subp
) = Chars
(Act_Subp
)
12750 and then Ekind
(Anc_Subp
) = Ekind
(Act_Subp
)
12752 Anc_Formal
:= First_Formal
(Anc_Subp
);
12753 Act_Formal
:= First_Formal
(Act_Subp
);
12754 while Present
(Anc_Formal
)
12755 and then Present
(Act_Formal
)
12757 Anc_F_Type
:= Etype
(Anc_Formal
);
12758 Act_F_Type
:= Etype
(Act_Formal
);
12760 if Ekind
(Anc_F_Type
) =
12761 E_Anonymous_Access_Type
12763 Anc_F_Type
:= Designated_Type
(Anc_F_Type
);
12765 if Ekind
(Act_F_Type
) =
12766 E_Anonymous_Access_Type
12769 Designated_Type
(Act_F_Type
);
12775 Ekind
(Act_F_Type
) = E_Anonymous_Access_Type
12780 Anc_F_Type
:= Base_Type
(Anc_F_Type
);
12781 Act_F_Type
:= Base_Type
(Act_F_Type
);
12783 -- If the formal is controlling, then the
12784 -- the type of the actual primitive's formal
12785 -- must be derived directly or indirectly
12786 -- from the type of the ancestor primitive's
12789 if Is_Controlling_Formal
(Anc_Formal
) then
12790 if not Is_Tagged_Ancestor
12791 (Anc_F_Type
, Act_F_Type
)
12796 -- Otherwise the types of the formals must
12799 elsif Anc_F_Type
/= Act_F_Type
then
12803 Next_Entity
(Anc_Formal
);
12804 Next_Entity
(Act_Formal
);
12807 -- If we traversed through all of the formals
12808 -- then so far the subprograms correspond, so
12809 -- now check that any result types correspond.
12811 if No
(Anc_Formal
) and then No
(Act_Formal
) then
12812 Subprograms_Correspond
:= True;
12814 if Ekind
(Act_Subp
) = E_Function
then
12815 Anc_F_Type
:= Etype
(Anc_Subp
);
12816 Act_F_Type
:= Etype
(Act_Subp
);
12818 if Ekind
(Anc_F_Type
) =
12819 E_Anonymous_Access_Type
12822 Designated_Type
(Anc_F_Type
);
12824 if Ekind
(Act_F_Type
) =
12825 E_Anonymous_Access_Type
12828 Designated_Type
(Act_F_Type
);
12830 Subprograms_Correspond
:= False;
12835 = E_Anonymous_Access_Type
12837 Subprograms_Correspond
:= False;
12840 Anc_F_Type
:= Base_Type
(Anc_F_Type
);
12841 Act_F_Type
:= Base_Type
(Act_F_Type
);
12843 -- Now either the result types must be
12844 -- the same or, if the result type is
12845 -- controlling, the result type of the
12846 -- actual primitive must descend from the
12847 -- result type of the ancestor primitive.
12849 if Subprograms_Correspond
12850 and then Anc_F_Type
/= Act_F_Type
12852 Has_Controlling_Result
(Anc_Subp
)
12853 and then not Is_Tagged_Ancestor
12854 (Anc_F_Type
, Act_F_Type
)
12856 Subprograms_Correspond
:= False;
12860 -- Found a matching subprogram belonging to
12861 -- formal ancestor type, so actual subprogram
12862 -- corresponds and this violates 3.9.3(9).
12864 if Subprograms_Correspond
then
12866 ("abstract subprogram & overrides "
12867 & "nonabstract subprogram of ancestor",
12874 Next_Elmt
(Act_Elmt
);
12878 Next_Elmt
(Gen_Elmt
);
12880 end Check_Abstract_Primitives
;
12883 -- Verify that limitedness matches. If parent is a limited
12884 -- interface then the generic formal is not unless declared
12885 -- explicitly so. If not declared limited, the actual cannot be
12886 -- limited (see AI05-0087).
12888 -- Even though this AI is a binding interpretation, we enable the
12889 -- check only in Ada 2012 mode, because this improper construct
12890 -- shows up in user code and in existing B-tests.
12892 if Is_Limited_Type
(Act_T
)
12893 and then not Is_Limited_Type
(A_Gen_T
)
12894 and then Ada_Version
>= Ada_2012
12896 if In_Instance
then
12900 ("actual for non-limited & cannot be a limited type",
12902 Explain_Limited_Type
(Act_T
, Actual
);
12903 Abandon_Instantiation
(Actual
);
12906 end Validate_Derived_Type_Instance
;
12908 ----------------------------------------
12909 -- Validate_Discriminated_Formal_Type --
12910 ----------------------------------------
12912 procedure Validate_Discriminated_Formal_Type
is
12913 Formal_Discr
: Entity_Id
;
12914 Actual_Discr
: Entity_Id
;
12915 Formal_Subt
: Entity_Id
;
12918 if Has_Discriminants
(A_Gen_T
) then
12919 if not Has_Discriminants
(Act_T
) then
12921 ("actual for & must have discriminants", Actual
, Gen_T
);
12922 Abandon_Instantiation
(Actual
);
12924 elsif Is_Constrained
(Act_T
) then
12926 ("actual for & must be unconstrained", Actual
, Gen_T
);
12927 Abandon_Instantiation
(Actual
);
12930 Formal_Discr
:= First_Discriminant
(A_Gen_T
);
12931 Actual_Discr
:= First_Discriminant
(Act_T
);
12932 while Formal_Discr
/= Empty
loop
12933 if Actual_Discr
= Empty
then
12935 ("discriminants on actual do not match formal",
12937 Abandon_Instantiation
(Actual
);
12940 Formal_Subt
:= Get_Instance_Of
(Etype
(Formal_Discr
));
12942 -- Access discriminants match if designated types do
12944 if Ekind
(Base_Type
(Formal_Subt
)) = E_Anonymous_Access_Type
12945 and then (Ekind
(Base_Type
(Etype
(Actual_Discr
)))) =
12946 E_Anonymous_Access_Type
12949 (Designated_Type
(Base_Type
(Formal_Subt
))) =
12950 Designated_Type
(Base_Type
(Etype
(Actual_Discr
)))
12954 elsif Base_Type
(Formal_Subt
) /=
12955 Base_Type
(Etype
(Actual_Discr
))
12958 ("types of actual discriminants must match formal",
12960 Abandon_Instantiation
(Actual
);
12962 elsif not Subtypes_Statically_Match
12963 (Formal_Subt
, Etype
(Actual_Discr
))
12964 and then Ada_Version
>= Ada_95
12967 ("subtypes of actual discriminants must match formal",
12969 Abandon_Instantiation
(Actual
);
12972 Next_Discriminant
(Formal_Discr
);
12973 Next_Discriminant
(Actual_Discr
);
12976 if Actual_Discr
/= Empty
then
12978 ("discriminants on actual do not match formal",
12980 Abandon_Instantiation
(Actual
);
12984 end Validate_Discriminated_Formal_Type
;
12986 ---------------------------------------
12987 -- Validate_Incomplete_Type_Instance --
12988 ---------------------------------------
12990 procedure Validate_Incomplete_Type_Instance
is
12992 if not Is_Tagged_Type
(Act_T
)
12993 and then Is_Tagged_Type
(A_Gen_T
)
12996 ("actual for & must be a tagged type", Actual
, Gen_T
);
12999 Validate_Discriminated_Formal_Type
;
13000 end Validate_Incomplete_Type_Instance
;
13002 --------------------------------------
13003 -- Validate_Interface_Type_Instance --
13004 --------------------------------------
13006 procedure Validate_Interface_Type_Instance
is
13008 if not Is_Interface
(Act_T
) then
13010 ("actual for formal interface type must be an interface",
13013 elsif Is_Limited_Type
(Act_T
) /= Is_Limited_Type
(A_Gen_T
)
13014 or else Is_Task_Interface
(A_Gen_T
) /= Is_Task_Interface
(Act_T
)
13015 or else Is_Protected_Interface
(A_Gen_T
) /=
13016 Is_Protected_Interface
(Act_T
)
13017 or else Is_Synchronized_Interface
(A_Gen_T
) /=
13018 Is_Synchronized_Interface
(Act_T
)
13021 ("actual for interface& does not match (RM 12.5.5(4))",
13024 end Validate_Interface_Type_Instance
;
13026 ------------------------------------
13027 -- Validate_Private_Type_Instance --
13028 ------------------------------------
13030 procedure Validate_Private_Type_Instance
is
13032 if Is_Limited_Type
(Act_T
)
13033 and then not Is_Limited_Type
(A_Gen_T
)
13035 if In_Instance
then
13039 ("actual for non-limited & cannot be a limited type", Actual
,
13041 Explain_Limited_Type
(Act_T
, Actual
);
13042 Abandon_Instantiation
(Actual
);
13045 elsif Known_To_Have_Preelab_Init
(A_Gen_T
)
13046 and then not Has_Preelaborable_Initialization
(Act_T
)
13049 ("actual for & must have preelaborable initialization", Actual
,
13052 elsif not Is_Definite_Subtype
(Act_T
)
13053 and then Is_Definite_Subtype
(A_Gen_T
)
13054 and then Ada_Version
>= Ada_95
13057 ("actual for & must be a definite subtype", Actual
, Gen_T
);
13059 elsif not Is_Tagged_Type
(Act_T
)
13060 and then Is_Tagged_Type
(A_Gen_T
)
13063 ("actual for & must be a tagged type", Actual
, Gen_T
);
13066 Validate_Discriminated_Formal_Type
;
13068 end Validate_Private_Type_Instance
;
13070 -- Start of processing for Instantiate_Type
13073 if Get_Instance_Of
(A_Gen_T
) /= A_Gen_T
then
13074 Error_Msg_N
("duplicate instantiation of generic type", Actual
);
13075 return New_List
(Error
);
13077 elsif not Is_Entity_Name
(Actual
)
13078 or else not Is_Type
(Entity
(Actual
))
13081 ("expect valid subtype mark to instantiate &", Actual
, Gen_T
);
13082 Abandon_Instantiation
(Actual
);
13085 Act_T
:= Entity
(Actual
);
13087 -- Ada 2005 (AI-216): An Unchecked_Union subtype shall only be passed
13088 -- as a generic actual parameter if the corresponding formal type
13089 -- does not have a known_discriminant_part, or is a formal derived
13090 -- type that is an Unchecked_Union type.
13092 if Is_Unchecked_Union
(Base_Type
(Act_T
)) then
13093 if not Has_Discriminants
(A_Gen_T
)
13094 or else (Is_Derived_Type
(A_Gen_T
)
13095 and then Is_Unchecked_Union
(A_Gen_T
))
13099 Error_Msg_N
("unchecked union cannot be the actual for a "
13100 & "discriminated formal type", Act_T
);
13105 -- Deal with fixed/floating restrictions
13107 if Is_Floating_Point_Type
(Act_T
) then
13108 Check_Restriction
(No_Floating_Point
, Actual
);
13109 elsif Is_Fixed_Point_Type
(Act_T
) then
13110 Check_Restriction
(No_Fixed_Point
, Actual
);
13113 -- Deal with error of using incomplete type as generic actual.
13114 -- This includes limited views of a type, even if the non-limited
13115 -- view may be available.
13117 if Ekind
(Act_T
) = E_Incomplete_Type
13118 or else (Is_Class_Wide_Type
(Act_T
)
13119 and then Ekind
(Root_Type
(Act_T
)) = E_Incomplete_Type
)
13121 -- If the formal is an incomplete type, the actual can be
13122 -- incomplete as well.
13124 if Ekind
(A_Gen_T
) = E_Incomplete_Type
then
13127 elsif Is_Class_Wide_Type
(Act_T
)
13128 or else No
(Full_View
(Act_T
))
13130 Error_Msg_N
("premature use of incomplete type", Actual
);
13131 Abandon_Instantiation
(Actual
);
13133 Act_T
:= Full_View
(Act_T
);
13134 Set_Entity
(Actual
, Act_T
);
13136 if Has_Private_Component
(Act_T
) then
13138 ("premature use of type with private component", Actual
);
13142 -- Deal with error of premature use of private type as generic actual
13144 elsif Is_Private_Type
(Act_T
)
13145 and then Is_Private_Type
(Base_Type
(Act_T
))
13146 and then not Is_Generic_Type
(Act_T
)
13147 and then not Is_Derived_Type
(Act_T
)
13148 and then No
(Full_View
(Root_Type
(Act_T
)))
13150 -- If the formal is an incomplete type, the actual can be
13151 -- private or incomplete as well.
13153 if Ekind
(A_Gen_T
) = E_Incomplete_Type
then
13156 Error_Msg_N
("premature use of private type", Actual
);
13159 elsif Has_Private_Component
(Act_T
) then
13161 ("premature use of type with private component", Actual
);
13164 Set_Instance_Of
(A_Gen_T
, Act_T
);
13166 -- If the type is generic, the class-wide type may also be used
13168 if Is_Tagged_Type
(A_Gen_T
)
13169 and then Is_Tagged_Type
(Act_T
)
13170 and then not Is_Class_Wide_Type
(A_Gen_T
)
13172 Set_Instance_Of
(Class_Wide_Type
(A_Gen_T
),
13173 Class_Wide_Type
(Act_T
));
13176 if not Is_Abstract_Type
(A_Gen_T
)
13177 and then Is_Abstract_Type
(Act_T
)
13180 ("actual of non-abstract formal cannot be abstract", Actual
);
13183 -- A generic scalar type is a first subtype for which we generate
13184 -- an anonymous base type. Indicate that the instance of this base
13185 -- is the base type of the actual.
13187 if Is_Scalar_Type
(A_Gen_T
) then
13188 Set_Instance_Of
(Etype
(A_Gen_T
), Etype
(Act_T
));
13192 if Error_Posted
(Act_T
) then
13195 case Nkind
(Def
) is
13196 when N_Formal_Private_Type_Definition
=>
13197 Validate_Private_Type_Instance
;
13199 when N_Formal_Incomplete_Type_Definition
=>
13200 Validate_Incomplete_Type_Instance
;
13202 when N_Formal_Derived_Type_Definition
=>
13203 Validate_Derived_Type_Instance
;
13205 when N_Formal_Discrete_Type_Definition
=>
13206 if not Is_Discrete_Type
(Act_T
) then
13208 ("expect discrete type in instantiation of&",
13210 Abandon_Instantiation
(Actual
);
13213 Diagnose_Predicated_Actual
;
13215 when N_Formal_Signed_Integer_Type_Definition
=>
13216 if not Is_Signed_Integer_Type
(Act_T
) then
13218 ("expect signed integer type in instantiation of&",
13220 Abandon_Instantiation
(Actual
);
13223 Diagnose_Predicated_Actual
;
13225 when N_Formal_Modular_Type_Definition
=>
13226 if not Is_Modular_Integer_Type
(Act_T
) then
13228 ("expect modular type in instantiation of &",
13230 Abandon_Instantiation
(Actual
);
13233 Diagnose_Predicated_Actual
;
13235 when N_Formal_Floating_Point_Definition
=>
13236 if not Is_Floating_Point_Type
(Act_T
) then
13238 ("expect float type in instantiation of &", Actual
, Gen_T
);
13239 Abandon_Instantiation
(Actual
);
13242 when N_Formal_Ordinary_Fixed_Point_Definition
=>
13243 if not Is_Ordinary_Fixed_Point_Type
(Act_T
) then
13245 ("expect ordinary fixed point type in instantiation of &",
13247 Abandon_Instantiation
(Actual
);
13250 when N_Formal_Decimal_Fixed_Point_Definition
=>
13251 if not Is_Decimal_Fixed_Point_Type
(Act_T
) then
13253 ("expect decimal type in instantiation of &",
13255 Abandon_Instantiation
(Actual
);
13258 when N_Array_Type_Definition
=>
13259 Validate_Array_Type_Instance
;
13261 when N_Access_To_Object_Definition
=>
13262 Validate_Access_Type_Instance
;
13264 when N_Access_Function_Definition
13265 | N_Access_Procedure_Definition
13267 Validate_Access_Subprogram_Instance
;
13269 when N_Record_Definition
=>
13270 Validate_Interface_Type_Instance
;
13272 when N_Derived_Type_Definition
=>
13273 Validate_Derived_Interface_Type_Instance
;
13276 raise Program_Error
;
13280 Subt
:= New_Copy
(Gen_T
);
13282 -- Use adjusted sloc of subtype name as the location for other nodes in
13283 -- the subtype declaration.
13285 Loc
:= Sloc
(Subt
);
13288 Make_Subtype_Declaration
(Loc
,
13289 Defining_Identifier
=> Subt
,
13290 Subtype_Indication
=> New_Occurrence_Of
(Act_T
, Loc
));
13292 if Is_Private_Type
(Act_T
) then
13293 Set_Has_Private_View
(Subtype_Indication
(Decl_Node
));
13295 elsif Is_Access_Type
(Act_T
)
13296 and then Is_Private_Type
(Designated_Type
(Act_T
))
13298 Set_Has_Private_View
(Subtype_Indication
(Decl_Node
));
13301 -- In Ada 2012 the actual may be a limited view. Indicate that
13302 -- the local subtype must be treated as such.
13304 if From_Limited_With
(Act_T
) then
13305 Set_Ekind
(Subt
, E_Incomplete_Subtype
);
13306 Set_From_Limited_With
(Subt
);
13309 Decl_Nodes
:= New_List
(Decl_Node
);
13311 -- Flag actual derived types so their elaboration produces the
13312 -- appropriate renamings for the primitive operations of the ancestor.
13313 -- Flag actual for formal private types as well, to determine whether
13314 -- operations in the private part may override inherited operations.
13315 -- If the formal has an interface list, the ancestor is not the
13316 -- parent, but the analyzed formal that includes the interface
13317 -- operations of all its progenitors.
13319 -- Same treatment for formal private types, so we can check whether the
13320 -- type is tagged limited when validating derivations in the private
13321 -- part. (See AI05-096).
13323 if Nkind
(Def
) = N_Formal_Derived_Type_Definition
then
13324 if Present
(Interface_List
(Def
)) then
13325 Set_Generic_Parent_Type
(Decl_Node
, A_Gen_T
);
13327 Set_Generic_Parent_Type
(Decl_Node
, Ancestor
);
13330 elsif Nkind_In
(Def
, N_Formal_Private_Type_Definition
,
13331 N_Formal_Incomplete_Type_Definition
)
13333 Set_Generic_Parent_Type
(Decl_Node
, A_Gen_T
);
13336 -- If the actual is a synchronized type that implements an interface,
13337 -- the primitive operations are attached to the corresponding record,
13338 -- and we have to treat it as an additional generic actual, so that its
13339 -- primitive operations become visible in the instance. The task or
13340 -- protected type itself does not carry primitive operations.
13342 if Is_Concurrent_Type
(Act_T
)
13343 and then Is_Tagged_Type
(Act_T
)
13344 and then Present
(Corresponding_Record_Type
(Act_T
))
13345 and then Present
(Ancestor
)
13346 and then Is_Interface
(Ancestor
)
13349 Corr_Rec
: constant Entity_Id
:=
13350 Corresponding_Record_Type
(Act_T
);
13351 New_Corr
: Entity_Id
;
13352 Corr_Decl
: Node_Id
;
13355 New_Corr
:= Make_Temporary
(Loc
, 'S');
13357 Make_Subtype_Declaration
(Loc
,
13358 Defining_Identifier
=> New_Corr
,
13359 Subtype_Indication
=>
13360 New_Occurrence_Of
(Corr_Rec
, Loc
));
13361 Append_To
(Decl_Nodes
, Corr_Decl
);
13363 if Ekind
(Act_T
) = E_Task_Type
then
13364 Set_Ekind
(Subt
, E_Task_Subtype
);
13366 Set_Ekind
(Subt
, E_Protected_Subtype
);
13369 Set_Corresponding_Record_Type
(Subt
, Corr_Rec
);
13370 Set_Generic_Parent_Type
(Corr_Decl
, Ancestor
);
13371 Set_Generic_Parent_Type
(Decl_Node
, Empty
);
13375 -- For a floating-point type, capture dimension info if any, because
13376 -- the generated subtype declaration does not come from source and
13377 -- will not process dimensions.
13379 if Is_Floating_Point_Type
(Act_T
) then
13380 Copy_Dimensions
(Act_T
, Subt
);
13384 end Instantiate_Type
;
13386 ---------------------
13387 -- Is_In_Main_Unit --
13388 ---------------------
13390 function Is_In_Main_Unit
(N
: Node_Id
) return Boolean is
13391 Unum
: constant Unit_Number_Type
:= Get_Source_Unit
(N
);
13392 Current_Unit
: Node_Id
;
13395 if Unum
= Main_Unit
then
13398 -- If the current unit is a subunit then it is either the main unit or
13399 -- is being compiled as part of the main unit.
13401 elsif Nkind
(N
) = N_Compilation_Unit
then
13402 return Nkind
(Unit
(N
)) = N_Subunit
;
13405 Current_Unit
:= Parent
(N
);
13406 while Present
(Current_Unit
)
13407 and then Nkind
(Current_Unit
) /= N_Compilation_Unit
13409 Current_Unit
:= Parent
(Current_Unit
);
13412 -- The instantiation node is in the main unit, or else the current node
13413 -- (perhaps as the result of nested instantiations) is in the main unit,
13414 -- or in the declaration of the main unit, which in this last case must
13418 Current_Unit
= Cunit
(Main_Unit
)
13419 or else Current_Unit
= Library_Unit
(Cunit
(Main_Unit
))
13420 or else (Present
(Current_Unit
)
13421 and then Present
(Library_Unit
(Current_Unit
))
13422 and then Is_In_Main_Unit
(Library_Unit
(Current_Unit
)));
13423 end Is_In_Main_Unit
;
13425 ----------------------------
13426 -- Load_Parent_Of_Generic --
13427 ----------------------------
13429 procedure Load_Parent_Of_Generic
13432 Body_Optional
: Boolean := False)
13434 Comp_Unit
: constant Node_Id
:= Cunit
(Get_Source_Unit
(Spec
));
13435 Saved_Style_Check
: constant Boolean := Style_Check
;
13436 Saved_Warnings
: constant Warning_Record
:= Save_Warnings
;
13437 True_Parent
: Node_Id
;
13438 Inst_Node
: Node_Id
;
13440 Previous_Instances
: constant Elist_Id
:= New_Elmt_List
;
13442 procedure Collect_Previous_Instances
(Decls
: List_Id
);
13443 -- Collect all instantiations in the given list of declarations, that
13444 -- precede the generic that we need to load. If the bodies of these
13445 -- instantiations are available, we must analyze them, to ensure that
13446 -- the public symbols generated are the same when the unit is compiled
13447 -- to generate code, and when it is compiled in the context of a unit
13448 -- that needs a particular nested instance. This process is applied to
13449 -- both package and subprogram instances.
13451 --------------------------------
13452 -- Collect_Previous_Instances --
13453 --------------------------------
13455 procedure Collect_Previous_Instances
(Decls
: List_Id
) is
13459 Decl
:= First
(Decls
);
13460 while Present
(Decl
) loop
13461 if Sloc
(Decl
) >= Sloc
(Inst_Node
) then
13464 -- If Decl is an instantiation, then record it as requiring
13465 -- instantiation of the corresponding body, except if it is an
13466 -- abbreviated instantiation generated internally for conformance
13467 -- checking purposes only for the case of a formal package
13468 -- declared without a box (see Instantiate_Formal_Package). Such
13469 -- an instantiation does not generate any code (the actual code
13470 -- comes from actual) and thus does not need to be analyzed here.
13471 -- If the instantiation appears with a generic package body it is
13472 -- not analyzed here either.
13474 elsif Nkind
(Decl
) = N_Package_Instantiation
13475 and then not Is_Internal
(Defining_Entity
(Decl
))
13477 Append_Elmt
(Decl
, Previous_Instances
);
13479 -- For a subprogram instantiation, omit instantiations intrinsic
13480 -- operations (Unchecked_Conversions, etc.) that have no bodies.
13482 elsif Nkind_In
(Decl
, N_Function_Instantiation
,
13483 N_Procedure_Instantiation
)
13484 and then not Is_Intrinsic_Subprogram
(Entity
(Name
(Decl
)))
13486 Append_Elmt
(Decl
, Previous_Instances
);
13488 elsif Nkind
(Decl
) = N_Package_Declaration
then
13489 Collect_Previous_Instances
13490 (Visible_Declarations
(Specification
(Decl
)));
13491 Collect_Previous_Instances
13492 (Private_Declarations
(Specification
(Decl
)));
13494 -- Previous non-generic bodies may contain instances as well
13496 elsif Nkind
(Decl
) = N_Package_Body
13497 and then Ekind
(Corresponding_Spec
(Decl
)) /= E_Generic_Package
13499 Collect_Previous_Instances
(Declarations
(Decl
));
13501 elsif Nkind
(Decl
) = N_Subprogram_Body
13502 and then not Acts_As_Spec
(Decl
)
13503 and then not Is_Generic_Subprogram
(Corresponding_Spec
(Decl
))
13505 Collect_Previous_Instances
(Declarations
(Decl
));
13510 end Collect_Previous_Instances
;
13512 -- Start of processing for Load_Parent_Of_Generic
13515 if not In_Same_Source_Unit
(N
, Spec
)
13516 or else Nkind
(Unit
(Comp_Unit
)) = N_Package_Declaration
13517 or else (Nkind
(Unit
(Comp_Unit
)) = N_Package_Body
13518 and then not Is_In_Main_Unit
(Spec
))
13520 -- Find body of parent of spec, and analyze it. A special case arises
13521 -- when the parent is an instantiation, that is to say when we are
13522 -- currently instantiating a nested generic. In that case, there is
13523 -- no separate file for the body of the enclosing instance. Instead,
13524 -- the enclosing body must be instantiated as if it were a pending
13525 -- instantiation, in order to produce the body for the nested generic
13526 -- we require now. Note that in that case the generic may be defined
13527 -- in a package body, the instance defined in the same package body,
13528 -- and the original enclosing body may not be in the main unit.
13530 Inst_Node
:= Empty
;
13532 True_Parent
:= Parent
(Spec
);
13533 while Present
(True_Parent
)
13534 and then Nkind
(True_Parent
) /= N_Compilation_Unit
13536 if Nkind
(True_Parent
) = N_Package_Declaration
13538 Nkind
(Original_Node
(True_Parent
)) = N_Package_Instantiation
13540 -- Parent is a compilation unit that is an instantiation.
13541 -- Instantiation node has been replaced with package decl.
13543 Inst_Node
:= Original_Node
(True_Parent
);
13546 elsif Nkind
(True_Parent
) = N_Package_Declaration
13547 and then Present
(Generic_Parent
(Specification
(True_Parent
)))
13548 and then Nkind
(Parent
(True_Parent
)) /= N_Compilation_Unit
13550 -- Parent is an instantiation within another specification.
13551 -- Declaration for instance has been inserted before original
13552 -- instantiation node. A direct link would be preferable?
13554 Inst_Node
:= Next
(True_Parent
);
13555 while Present
(Inst_Node
)
13556 and then Nkind
(Inst_Node
) /= N_Package_Instantiation
13561 -- If the instance appears within a generic, and the generic
13562 -- unit is defined within a formal package of the enclosing
13563 -- generic, there is no generic body available, and none
13564 -- needed. A more precise test should be used ???
13566 if No
(Inst_Node
) then
13573 True_Parent
:= Parent
(True_Parent
);
13577 -- Case where we are currently instantiating a nested generic
13579 if Present
(Inst_Node
) then
13580 if Nkind
(Parent
(True_Parent
)) = N_Compilation_Unit
then
13582 -- Instantiation node and declaration of instantiated package
13583 -- were exchanged when only the declaration was needed.
13584 -- Restore instantiation node before proceeding with body.
13586 Set_Unit
(Parent
(True_Parent
), Inst_Node
);
13589 -- Now complete instantiation of enclosing body, if it appears in
13590 -- some other unit. If it appears in the current unit, the body
13591 -- will have been instantiated already.
13593 if No
(Corresponding_Body
(Instance_Spec
(Inst_Node
))) then
13595 -- We need to determine the expander mode to instantiate the
13596 -- enclosing body. Because the generic body we need may use
13597 -- global entities declared in the enclosing package (including
13598 -- aggregates) it is in general necessary to compile this body
13599 -- with expansion enabled, except if we are within a generic
13600 -- package, in which case the usual generic rule applies.
13603 Exp_Status
: Boolean := True;
13607 -- Loop through scopes looking for generic package
13609 Scop
:= Scope
(Defining_Entity
(Instance_Spec
(Inst_Node
)));
13610 while Present
(Scop
)
13611 and then Scop
/= Standard_Standard
13613 if Ekind
(Scop
) = E_Generic_Package
then
13614 Exp_Status
:= False;
13618 Scop
:= Scope
(Scop
);
13621 -- Collect previous instantiations in the unit that contains
13622 -- the desired generic.
13624 if Nkind
(Parent
(True_Parent
)) /= N_Compilation_Unit
13625 and then not Body_Optional
13629 Info
: Pending_Body_Info
;
13633 Par
:= Parent
(Inst_Node
);
13634 while Present
(Par
) loop
13635 exit when Nkind
(Parent
(Par
)) = N_Compilation_Unit
;
13636 Par
:= Parent
(Par
);
13639 pragma Assert
(Present
(Par
));
13641 if Nkind
(Par
) = N_Package_Body
then
13642 Collect_Previous_Instances
(Declarations
(Par
));
13644 elsif Nkind
(Par
) = N_Package_Declaration
then
13645 Collect_Previous_Instances
13646 (Visible_Declarations
(Specification
(Par
)));
13647 Collect_Previous_Instances
13648 (Private_Declarations
(Specification
(Par
)));
13651 -- Enclosing unit is a subprogram body. In this
13652 -- case all instance bodies are processed in order
13653 -- and there is no need to collect them separately.
13658 Decl
:= First_Elmt
(Previous_Instances
);
13659 while Present
(Decl
) loop
13661 (Inst_Node
=> Node
(Decl
),
13663 Instance_Spec
(Node
(Decl
)),
13664 Expander_Status
=> Exp_Status
,
13665 Current_Sem_Unit
=>
13666 Get_Code_Unit
(Sloc
(Node
(Decl
))),
13667 Scope_Suppress
=> Scope_Suppress
,
13668 Local_Suppress_Stack_Top
=>
13669 Local_Suppress_Stack_Top
,
13670 Version
=> Ada_Version
,
13671 Version_Pragma
=> Ada_Version_Pragma
,
13672 Warnings
=> Save_Warnings
,
13673 SPARK_Mode
=> SPARK_Mode
,
13674 SPARK_Mode_Pragma
=> SPARK_Mode_Pragma
);
13676 -- Package instance
13678 if Nkind
(Node
(Decl
)) = N_Package_Instantiation
13680 Instantiate_Package_Body
13681 (Info
, Body_Optional
=> True);
13683 -- Subprogram instance
13686 -- The instance_spec is in the wrapper package,
13687 -- usually followed by its local renaming
13688 -- declaration. See Build_Subprogram_Renaming
13689 -- for details. If the instance carries aspects,
13690 -- these result in the corresponding pragmas,
13691 -- inserted after the subprogram declaration.
13692 -- They must be skipped as well when retrieving
13693 -- the desired spec. Some of them may have been
13694 -- rewritten as null statements.
13695 -- A direct link would be more robust ???
13699 (Last
(Visible_Declarations
13700 (Specification
(Info
.Act_Decl
))));
13702 while Nkind_In
(Decl
,
13705 N_Subprogram_Renaming_Declaration
)
13707 Decl
:= Prev
(Decl
);
13710 Info
.Act_Decl
:= Decl
;
13713 Instantiate_Subprogram_Body
13714 (Info
, Body_Optional
=> True);
13722 Instantiate_Package_Body
13724 ((Inst_Node
=> Inst_Node
,
13725 Act_Decl
=> True_Parent
,
13726 Expander_Status
=> Exp_Status
,
13727 Current_Sem_Unit
=> Get_Code_Unit
13728 (Sloc
(Inst_Node
)),
13729 Scope_Suppress
=> Scope_Suppress
,
13730 Local_Suppress_Stack_Top
=> Local_Suppress_Stack_Top
,
13731 Version
=> Ada_Version
,
13732 Version_Pragma
=> Ada_Version_Pragma
,
13733 Warnings
=> Save_Warnings
,
13734 SPARK_Mode
=> SPARK_Mode
,
13735 SPARK_Mode_Pragma
=> SPARK_Mode_Pragma
)),
13736 Body_Optional
=> Body_Optional
);
13740 -- Case where we are not instantiating a nested generic
13743 Opt
.Style_Check
:= False;
13744 Expander_Mode_Save_And_Set
(True);
13745 Load_Needed_Body
(Comp_Unit
, OK
);
13746 Opt
.Style_Check
:= Saved_Style_Check
;
13747 Restore_Warnings
(Saved_Warnings
);
13748 Expander_Mode_Restore
;
13751 and then Unit_Requires_Body
(Defining_Entity
(Spec
))
13752 and then not Body_Optional
13755 Bname
: constant Unit_Name_Type
:=
13756 Get_Body_Name
(Get_Unit_Name
(Unit
(Comp_Unit
)));
13759 -- In CodePeer mode, the missing body may make the analysis
13760 -- incomplete, but we do not treat it as fatal.
13762 if CodePeer_Mode
then
13766 Error_Msg_Unit_1
:= Bname
;
13767 Error_Msg_N
("this instantiation requires$!", N
);
13768 Error_Msg_File_1
:=
13769 Get_File_Name
(Bname
, Subunit
=> False);
13770 Error_Msg_N
("\but file{ was not found!", N
);
13771 raise Unrecoverable_Error
;
13778 -- If loading parent of the generic caused an instantiation circularity,
13779 -- we abandon compilation at this point, because otherwise in some cases
13780 -- we get into trouble with infinite recursions after this point.
13782 if Circularity_Detected
then
13783 raise Unrecoverable_Error
;
13785 end Load_Parent_Of_Generic
;
13787 ---------------------------------
13788 -- Map_Formal_Package_Entities --
13789 ---------------------------------
13791 procedure Map_Formal_Package_Entities
(Form
: Entity_Id
; Act
: Entity_Id
) is
13796 Set_Instance_Of
(Form
, Act
);
13798 -- Traverse formal and actual package to map the corresponding entities.
13799 -- We skip over internal entities that may be generated during semantic
13800 -- analysis, and find the matching entities by name, given that they
13801 -- must appear in the same order.
13803 E1
:= First_Entity
(Form
);
13804 E2
:= First_Entity
(Act
);
13805 while Present
(E1
) and then E1
/= First_Private_Entity
(Form
) loop
13806 -- Could this test be a single condition??? Seems like it could, and
13807 -- isn't FPE (Form) a constant anyway???
13809 if not Is_Internal
(E1
)
13810 and then Present
(Parent
(E1
))
13811 and then not Is_Class_Wide_Type
(E1
)
13812 and then not Is_Internal_Name
(Chars
(E1
))
13814 while Present
(E2
) and then Chars
(E2
) /= Chars
(E1
) loop
13821 Set_Instance_Of
(E1
, E2
);
13823 if Is_Type
(E1
) and then Is_Tagged_Type
(E2
) then
13824 Set_Instance_Of
(Class_Wide_Type
(E1
), Class_Wide_Type
(E2
));
13827 if Is_Constrained
(E1
) then
13828 Set_Instance_Of
(Base_Type
(E1
), Base_Type
(E2
));
13831 if Ekind
(E1
) = E_Package
and then No
(Renamed_Object
(E1
)) then
13832 Map_Formal_Package_Entities
(E1
, E2
);
13839 end Map_Formal_Package_Entities
;
13841 -----------------------
13842 -- Move_Freeze_Nodes --
13843 -----------------------
13845 procedure Move_Freeze_Nodes
13846 (Out_Of
: Entity_Id
;
13851 Next_Decl
: Node_Id
;
13852 Next_Node
: Node_Id
:= After
;
13855 function Is_Outer_Type
(T
: Entity_Id
) return Boolean;
13856 -- Check whether entity is declared in a scope external to that of the
13859 -------------------
13860 -- Is_Outer_Type --
13861 -------------------
13863 function Is_Outer_Type
(T
: Entity_Id
) return Boolean is
13864 Scop
: Entity_Id
:= Scope
(T
);
13867 if Scope_Depth
(Scop
) < Scope_Depth
(Out_Of
) then
13871 while Scop
/= Standard_Standard
loop
13872 if Scop
= Out_Of
then
13875 Scop
:= Scope
(Scop
);
13883 -- Start of processing for Move_Freeze_Nodes
13890 -- First remove the freeze nodes that may appear before all other
13894 while Present
(Decl
)
13895 and then Nkind
(Decl
) = N_Freeze_Entity
13896 and then Is_Outer_Type
(Entity
(Decl
))
13898 Decl
:= Remove_Head
(L
);
13899 Insert_After
(Next_Node
, Decl
);
13900 Set_Analyzed
(Decl
, False);
13905 -- Next scan the list of declarations and remove each freeze node that
13906 -- appears ahead of the current node.
13908 while Present
(Decl
) loop
13909 while Present
(Next
(Decl
))
13910 and then Nkind
(Next
(Decl
)) = N_Freeze_Entity
13911 and then Is_Outer_Type
(Entity
(Next
(Decl
)))
13913 Next_Decl
:= Remove_Next
(Decl
);
13914 Insert_After
(Next_Node
, Next_Decl
);
13915 Set_Analyzed
(Next_Decl
, False);
13916 Next_Node
:= Next_Decl
;
13919 -- If the declaration is a nested package or concurrent type, then
13920 -- recurse. Nested generic packages will have been processed from the
13923 case Nkind
(Decl
) is
13924 when N_Package_Declaration
=>
13925 Spec
:= Specification
(Decl
);
13927 when N_Task_Type_Declaration
=>
13928 Spec
:= Task_Definition
(Decl
);
13930 when N_Protected_Type_Declaration
=>
13931 Spec
:= Protected_Definition
(Decl
);
13937 if Present
(Spec
) then
13938 Move_Freeze_Nodes
(Out_Of
, Next_Node
, Visible_Declarations
(Spec
));
13939 Move_Freeze_Nodes
(Out_Of
, Next_Node
, Private_Declarations
(Spec
));
13944 end Move_Freeze_Nodes
;
13950 function Next_Assoc
(E
: Assoc_Ptr
) return Assoc_Ptr
is
13952 return Generic_Renamings
.Table
(E
).Next_In_HTable
;
13955 ------------------------
13956 -- Preanalyze_Actuals --
13957 ------------------------
13959 procedure Preanalyze_Actuals
(N
: Node_Id
; Inst
: Entity_Id
:= Empty
) is
13962 Errs
: constant Nat
:= Serious_Errors_Detected
;
13964 Cur
: Entity_Id
:= Empty
;
13965 -- Current homograph of the instance name
13967 Vis
: Boolean := False;
13968 -- Saved visibility status of the current homograph
13971 Assoc
:= First
(Generic_Associations
(N
));
13973 -- If the instance is a child unit, its name may hide an outer homonym,
13974 -- so make it invisible to perform name resolution on the actuals.
13976 if Nkind
(Defining_Unit_Name
(N
)) = N_Defining_Program_Unit_Name
13978 (Current_Entity
(Defining_Identifier
(Defining_Unit_Name
(N
))))
13980 Cur
:= Current_Entity
(Defining_Identifier
(Defining_Unit_Name
(N
)));
13982 if Is_Compilation_Unit
(Cur
) then
13983 Vis
:= Is_Immediately_Visible
(Cur
);
13984 Set_Is_Immediately_Visible
(Cur
, False);
13990 while Present
(Assoc
) loop
13991 if Nkind
(Assoc
) /= N_Others_Choice
then
13992 Act
:= Explicit_Generic_Actual_Parameter
(Assoc
);
13994 -- Within a nested instantiation, a defaulted actual is an empty
13995 -- association, so nothing to analyze. If the subprogram actual
13996 -- is an attribute, analyze prefix only, because actual is not a
13997 -- complete attribute reference.
13999 -- If actual is an allocator, analyze expression only. The full
14000 -- analysis can generate code, and if instance is a compilation
14001 -- unit we have to wait until the package instance is installed
14002 -- to have a proper place to insert this code.
14004 -- String literals may be operators, but at this point we do not
14005 -- know whether the actual is a formal subprogram or a string.
14010 elsif Nkind
(Act
) = N_Attribute_Reference
then
14011 Analyze
(Prefix
(Act
));
14013 elsif Nkind
(Act
) = N_Explicit_Dereference
then
14014 Analyze
(Prefix
(Act
));
14016 elsif Nkind
(Act
) = N_Allocator
then
14018 Expr
: constant Node_Id
:= Expression
(Act
);
14021 if Nkind
(Expr
) = N_Subtype_Indication
then
14022 Analyze
(Subtype_Mark
(Expr
));
14024 -- Analyze separately each discriminant constraint, when
14025 -- given with a named association.
14031 Constr
:= First
(Constraints
(Constraint
(Expr
)));
14032 while Present
(Constr
) loop
14033 if Nkind
(Constr
) = N_Discriminant_Association
then
14034 Analyze
(Expression
(Constr
));
14048 elsif Nkind
(Act
) /= N_Operator_Symbol
then
14051 -- Within a package instance, mark actuals that are limited
14052 -- views, so their use can be moved to the body of the
14055 if Is_Entity_Name
(Act
)
14056 and then Is_Type
(Entity
(Act
))
14057 and then From_Limited_With
(Entity
(Act
))
14058 and then Present
(Inst
)
14060 Append_Elmt
(Entity
(Act
), Incomplete_Actuals
(Inst
));
14064 if Errs
/= Serious_Errors_Detected
then
14066 -- Do a minimal analysis of the generic, to prevent spurious
14067 -- warnings complaining about the generic being unreferenced,
14068 -- before abandoning the instantiation.
14070 Analyze
(Name
(N
));
14072 if Is_Entity_Name
(Name
(N
))
14073 and then Etype
(Name
(N
)) /= Any_Type
14075 Generate_Reference
(Entity
(Name
(N
)), Name
(N
));
14076 Set_Is_Instantiated
(Entity
(Name
(N
)));
14079 if Present
(Cur
) then
14081 -- For the case of a child instance hiding an outer homonym,
14082 -- provide additional warning which might explain the error.
14084 Set_Is_Immediately_Visible
(Cur
, Vis
);
14086 ("& hides outer unit with the same name??",
14087 N
, Defining_Unit_Name
(N
));
14090 Abandon_Instantiation
(Act
);
14097 if Present
(Cur
) then
14098 Set_Is_Immediately_Visible
(Cur
, Vis
);
14100 end Preanalyze_Actuals
;
14102 -------------------------------
14103 -- Provide_Completing_Bodies --
14104 -------------------------------
14106 procedure Provide_Completing_Bodies
(N
: Node_Id
) is
14107 procedure Build_Completing_Body
(Subp_Decl
: Node_Id
);
14108 -- Generate the completing body for subprogram declaration Subp_Decl
14110 procedure Provide_Completing_Bodies_In
(Decls
: List_Id
);
14111 -- Generating completing bodies for all subprograms found in declarative
14114 ---------------------------
14115 -- Build_Completing_Body --
14116 ---------------------------
14118 procedure Build_Completing_Body
(Subp_Decl
: Node_Id
) is
14119 Loc
: constant Source_Ptr
:= Sloc
(Subp_Decl
);
14120 Subp_Id
: constant Entity_Id
:= Defining_Entity
(Subp_Decl
);
14124 -- Nothing to do if the subprogram already has a completing body
14126 if Present
(Corresponding_Body
(Subp_Decl
)) then
14129 -- Mark the function as having a valid return statement even though
14130 -- the body contains a single raise statement.
14132 elsif Ekind
(Subp_Id
) = E_Function
then
14133 Set_Return_Present
(Subp_Id
);
14136 -- Clone the specification to obtain new entities and reset the only
14139 Spec
:= Copy_Subprogram_Spec
(Specification
(Subp_Decl
));
14140 Set_Generic_Parent
(Spec
, Empty
);
14143 -- function Func ... return ... is
14145 -- procedure Proc ... is
14147 -- raise Program_Error with "access before elaboration";
14150 Insert_After_And_Analyze
(Subp_Decl
,
14151 Make_Subprogram_Body
(Loc
,
14152 Specification
=> Spec
,
14153 Declarations
=> New_List
,
14154 Handled_Statement_Sequence
=>
14155 Make_Handled_Sequence_Of_Statements
(Loc
,
14156 Statements
=> New_List
(
14157 Make_Raise_Program_Error
(Loc
,
14158 Reason
=> PE_Access_Before_Elaboration
)))));
14159 end Build_Completing_Body
;
14161 ----------------------------------
14162 -- Provide_Completing_Bodies_In --
14163 ----------------------------------
14165 procedure Provide_Completing_Bodies_In
(Decls
: List_Id
) is
14169 if Present
(Decls
) then
14170 Decl
:= First
(Decls
);
14171 while Present
(Decl
) loop
14172 Provide_Completing_Bodies
(Decl
);
14176 end Provide_Completing_Bodies_In
;
14182 -- Start of processing for Provide_Completing_Bodies
14185 if Nkind
(N
) = N_Package_Declaration
then
14186 Spec
:= Specification
(N
);
14188 Push_Scope
(Defining_Entity
(N
));
14189 Provide_Completing_Bodies_In
(Visible_Declarations
(Spec
));
14190 Provide_Completing_Bodies_In
(Private_Declarations
(Spec
));
14193 elsif Nkind
(N
) = N_Subprogram_Declaration
then
14194 Build_Completing_Body
(N
);
14196 end Provide_Completing_Bodies
;
14198 -------------------
14199 -- Remove_Parent --
14200 -------------------
14202 procedure Remove_Parent
(In_Body
: Boolean := False) is
14203 S
: Entity_Id
:= Current_Scope
;
14204 -- S is the scope containing the instantiation just completed. The scope
14205 -- stack contains the parent instances of the instantiation, followed by
14214 -- After child instantiation is complete, remove from scope stack the
14215 -- extra copy of the current scope, and then remove parent instances.
14217 if not In_Body
then
14220 while Current_Scope
/= S
loop
14221 P
:= Current_Scope
;
14222 End_Package_Scope
(Current_Scope
);
14224 if In_Open_Scopes
(P
) then
14225 E
:= First_Entity
(P
);
14226 while Present
(E
) loop
14227 Set_Is_Immediately_Visible
(E
, True);
14231 -- If instantiation is declared in a block, it is the enclosing
14232 -- scope that might be a parent instance. Note that only one
14233 -- block can be involved, because the parent instances have
14234 -- been installed within it.
14236 if Ekind
(P
) = E_Block
then
14237 Cur_P
:= Scope
(P
);
14242 if Is_Generic_Instance
(Cur_P
) and then P
/= Current_Scope
then
14243 -- We are within an instance of some sibling. Retain
14244 -- visibility of parent, for proper subsequent cleanup, and
14245 -- reinstall private declarations as well.
14247 Set_In_Private_Part
(P
);
14248 Install_Private_Declarations
(P
);
14251 -- If the ultimate parent is a top-level unit recorded in
14252 -- Instance_Parent_Unit, then reset its visibility to what it was
14253 -- before instantiation. (It's not clear what the purpose is of
14254 -- testing whether Scope (P) is In_Open_Scopes, but that test was
14255 -- present before the ultimate parent test was added.???)
14257 elsif not In_Open_Scopes
(Scope
(P
))
14258 or else (P
= Instance_Parent_Unit
14259 and then not Parent_Unit_Visible
)
14261 Set_Is_Immediately_Visible
(P
, False);
14263 -- If the current scope is itself an instantiation of a generic
14264 -- nested within P, and we are in the private part of body of this
14265 -- instantiation, restore the full views of P, that were removed
14266 -- in End_Package_Scope above. This obscure case can occur when a
14267 -- subunit of a generic contains an instance of a child unit of
14268 -- its generic parent unit.
14270 elsif S
= Current_Scope
and then Is_Generic_Instance
(S
) then
14272 Par
: constant Entity_Id
:=
14273 Generic_Parent
(Package_Specification
(S
));
14276 and then P
= Scope
(Par
)
14277 and then (In_Package_Body
(S
) or else In_Private_Part
(S
))
14279 Set_In_Private_Part
(P
);
14280 Install_Private_Declarations
(P
);
14286 -- Reset visibility of entities in the enclosing scope
14288 Set_Is_Hidden_Open_Scope
(Current_Scope
, False);
14290 Hidden
:= First_Elmt
(Hidden_Entities
);
14291 while Present
(Hidden
) loop
14292 Set_Is_Immediately_Visible
(Node
(Hidden
), True);
14293 Next_Elmt
(Hidden
);
14297 -- Each body is analyzed separately, and there is no context that
14298 -- needs preserving from one body instance to the next, so remove all
14299 -- parent scopes that have been installed.
14301 while Present
(S
) loop
14302 End_Package_Scope
(S
);
14303 Set_Is_Immediately_Visible
(S
, False);
14304 S
:= Current_Scope
;
14305 exit when S
= Standard_Standard
;
14314 procedure Restore_Env
is
14315 Saved
: Instance_Env
renames Instance_Envs
.Table
(Instance_Envs
.Last
);
14318 if No
(Current_Instantiated_Parent
.Act_Id
) then
14319 -- Restore environment after subprogram inlining
14321 Restore_Private_Views
(Empty
);
14324 Current_Instantiated_Parent
:= Saved
.Instantiated_Parent
;
14325 Exchanged_Views
:= Saved
.Exchanged_Views
;
14326 Hidden_Entities
:= Saved
.Hidden_Entities
;
14327 Current_Sem_Unit
:= Saved
.Current_Sem_Unit
;
14328 Parent_Unit_Visible
:= Saved
.Parent_Unit_Visible
;
14329 Instance_Parent_Unit
:= Saved
.Instance_Parent_Unit
;
14331 Restore_Opt_Config_Switches
(Saved
.Switches
);
14333 Instance_Envs
.Decrement_Last
;
14336 ---------------------------
14337 -- Restore_Private_Views --
14338 ---------------------------
14340 procedure Restore_Private_Views
14341 (Pack_Id
: Entity_Id
;
14342 Is_Package
: Boolean := True)
14347 Dep_Elmt
: Elmt_Id
;
14350 procedure Restore_Nested_Formal
(Formal
: Entity_Id
);
14351 -- Hide the generic formals of formal packages declared with box which
14352 -- were reachable in the current instantiation.
14354 ---------------------------
14355 -- Restore_Nested_Formal --
14356 ---------------------------
14358 procedure Restore_Nested_Formal
(Formal
: Entity_Id
) is
14362 if Present
(Renamed_Object
(Formal
))
14363 and then Denotes_Formal_Package
(Renamed_Object
(Formal
), True)
14367 elsif Present
(Associated_Formal_Package
(Formal
)) then
14368 Ent
:= First_Entity
(Formal
);
14369 while Present
(Ent
) loop
14370 exit when Ekind
(Ent
) = E_Package
14371 and then Renamed_Entity
(Ent
) = Renamed_Entity
(Formal
);
14373 Set_Is_Hidden
(Ent
);
14374 Set_Is_Potentially_Use_Visible
(Ent
, False);
14376 -- If package, then recurse
14378 if Ekind
(Ent
) = E_Package
then
14379 Restore_Nested_Formal
(Ent
);
14385 end Restore_Nested_Formal
;
14387 -- Start of processing for Restore_Private_Views
14390 M
:= First_Elmt
(Exchanged_Views
);
14391 while Present
(M
) loop
14394 -- Subtypes of types whose views have been exchanged, and that are
14395 -- defined within the instance, were not on the Private_Dependents
14396 -- list on entry to the instance, so they have to be exchanged
14397 -- explicitly now, in order to remain consistent with the view of the
14400 if Ekind_In
(Typ
, E_Private_Type
,
14401 E_Limited_Private_Type
,
14402 E_Record_Type_With_Private
)
14404 Dep_Elmt
:= First_Elmt
(Private_Dependents
(Typ
));
14405 while Present
(Dep_Elmt
) loop
14406 Dep_Typ
:= Node
(Dep_Elmt
);
14408 if Scope
(Dep_Typ
) = Pack_Id
14409 and then Present
(Full_View
(Dep_Typ
))
14411 Replace_Elmt
(Dep_Elmt
, Full_View
(Dep_Typ
));
14412 Exchange_Declarations
(Dep_Typ
);
14415 Next_Elmt
(Dep_Elmt
);
14419 Exchange_Declarations
(Node
(M
));
14423 if No
(Pack_Id
) then
14427 -- Make the generic formal parameters private, and make the formal types
14428 -- into subtypes of the actuals again.
14430 E
:= First_Entity
(Pack_Id
);
14431 while Present
(E
) loop
14432 Set_Is_Hidden
(E
, True);
14435 and then Nkind
(Parent
(E
)) = N_Subtype_Declaration
14437 -- If the actual for E is itself a generic actual type from
14438 -- an enclosing instance, E is still a generic actual type
14439 -- outside of the current instance. This matter when resolving
14440 -- an overloaded call that may be ambiguous in the enclosing
14441 -- instance, when two of its actuals coincide.
14443 if Is_Entity_Name
(Subtype_Indication
(Parent
(E
)))
14444 and then Is_Generic_Actual_Type
14445 (Entity
(Subtype_Indication
(Parent
(E
))))
14449 Set_Is_Generic_Actual_Type
(E
, False);
14452 -- An unusual case of aliasing: the actual may also be directly
14453 -- visible in the generic, and be private there, while it is fully
14454 -- visible in the context of the instance. The internal subtype
14455 -- is private in the instance but has full visibility like its
14456 -- parent in the enclosing scope. This enforces the invariant that
14457 -- the privacy status of all private dependents of a type coincide
14458 -- with that of the parent type. This can only happen when a
14459 -- generic child unit is instantiated within a sibling.
14461 if Is_Private_Type
(E
)
14462 and then not Is_Private_Type
(Etype
(E
))
14464 Exchange_Declarations
(E
);
14467 elsif Ekind
(E
) = E_Package
then
14469 -- The end of the renaming list is the renaming of the generic
14470 -- package itself. If the instance is a subprogram, all entities
14471 -- in the corresponding package are renamings. If this entity is
14472 -- a formal package, make its own formals private as well. The
14473 -- actual in this case is itself the renaming of an instantiation.
14474 -- If the entity is not a package renaming, it is the entity
14475 -- created to validate formal package actuals: ignore it.
14477 -- If the actual is itself a formal package for the enclosing
14478 -- generic, or the actual for such a formal package, it remains
14479 -- visible on exit from the instance, and therefore nothing needs
14480 -- to be done either, except to keep it accessible.
14482 if Is_Package
and then Renamed_Object
(E
) = Pack_Id
then
14485 elsif Nkind
(Parent
(E
)) /= N_Package_Renaming_Declaration
then
14489 Denotes_Formal_Package
(Renamed_Object
(E
), True, Pack_Id
)
14491 Set_Is_Hidden
(E
, False);
14495 Act_P
: constant Entity_Id
:= Renamed_Object
(E
);
14499 Id
:= First_Entity
(Act_P
);
14501 and then Id
/= First_Private_Entity
(Act_P
)
14503 exit when Ekind
(Id
) = E_Package
14504 and then Renamed_Object
(Id
) = Act_P
;
14506 Set_Is_Hidden
(Id
, True);
14507 Set_Is_Potentially_Use_Visible
(Id
, In_Use
(Act_P
));
14509 if Ekind
(Id
) = E_Package
then
14510 Restore_Nested_Formal
(Id
);
14521 end Restore_Private_Views
;
14528 (Gen_Unit
: Entity_Id
;
14529 Act_Unit
: Entity_Id
)
14533 Set_Instance_Env
(Gen_Unit
, Act_Unit
);
14536 ----------------------------
14537 -- Save_Global_References --
14538 ----------------------------
14540 procedure Save_Global_References
(Templ
: Node_Id
) is
14542 -- ??? it is horrible to use global variables in highly recursive code
14545 -- The entity of the current associated node
14547 Gen_Scope
: Entity_Id
;
14548 -- The scope of the generic for which references are being saved
14551 -- The current associated node
14553 function Is_Global
(E
: Entity_Id
) return Boolean;
14554 -- Check whether entity is defined outside of generic unit. Examine the
14555 -- scope of an entity, and the scope of the scope, etc, until we find
14556 -- either Standard, in which case the entity is global, or the generic
14557 -- unit itself, which indicates that the entity is local. If the entity
14558 -- is the generic unit itself, as in the case of a recursive call, or
14559 -- the enclosing generic unit, if different from the current scope, then
14560 -- it is local as well, because it will be replaced at the point of
14561 -- instantiation. On the other hand, if it is a reference to a child
14562 -- unit of a common ancestor, which appears in an instantiation, it is
14563 -- global because it is used to denote a specific compilation unit at
14564 -- the time the instantiations will be analyzed.
14566 procedure Qualify_Universal_Operands
14568 Func_Call
: Node_Id
);
14569 -- Op denotes a binary or unary operator in generic template Templ. Node
14570 -- Func_Call is the function call alternative of the operator within the
14571 -- the analyzed copy of the template. Change each operand which yields a
14572 -- universal type by wrapping it into a qualified expression
14574 -- Actual_Typ'(Operand)
14576 -- where Actual_Typ is the type of corresponding actual parameter of
14577 -- Operand in Func_Call.
14579 procedure Reset_Entity
(N
: Node_Id
);
14580 -- Save semantic information on global entity so that it is not resolved
14581 -- again at instantiation time.
14583 procedure Save_Entity_Descendants
(N
: Node_Id
);
14584 -- Apply Save_Global_References to the two syntactic descendants of
14585 -- non-terminal nodes that carry an Associated_Node and are processed
14586 -- through Reset_Entity. Once the global entity (if any) has been
14587 -- captured together with its type, only two syntactic descendants need
14588 -- to be traversed to complete the processing of the tree rooted at N.
14589 -- This applies to Selected_Components, Expanded_Names, and to Operator
14590 -- nodes. N can also be a character literal, identifier, or operator
14591 -- symbol node, but the call has no effect in these cases.
14593 procedure Save_Global_Defaults
(N1
: Node_Id
; N2
: Node_Id
);
14594 -- Default actuals in nested instances must be handled specially
14595 -- because there is no link to them from the original tree. When an
14596 -- actual subprogram is given by a default, we add an explicit generic
14597 -- association for it in the instantiation node. When we save the
14598 -- global references on the name of the instance, we recover the list
14599 -- of generic associations, and add an explicit one to the original
14600 -- generic tree, through which a global actual can be preserved.
14601 -- Similarly, if a child unit is instantiated within a sibling, in the
14602 -- context of the parent, we must preserve the identifier of the parent
14603 -- so that it can be properly resolved in a subsequent instantiation.
14605 procedure Save_Global_Descendant
(D
: Union_Id
);
14606 -- Apply Save_References recursively to the descendants of node D
14608 procedure Save_References
(N
: Node_Id
);
14609 -- This is the recursive procedure that does the work, once the
14610 -- enclosing generic scope has been established.
14616 function Is_Global
(E
: Entity_Id
) return Boolean is
14619 function Is_Instance_Node
(Decl
: Node_Id
) return Boolean;
14620 -- Determine whether the parent node of a reference to a child unit
14621 -- denotes an instantiation or a formal package, in which case the
14622 -- reference to the child unit is global, even if it appears within
14623 -- the current scope (e.g. when the instance appears within the body
14624 -- of an ancestor).
14626 ----------------------
14627 -- Is_Instance_Node --
14628 ----------------------
14630 function Is_Instance_Node
(Decl
: Node_Id
) return Boolean is
14632 return Nkind
(Decl
) in N_Generic_Instantiation
14634 Nkind
(Original_Node
(Decl
)) = N_Formal_Package_Declaration
;
14635 end Is_Instance_Node
;
14637 -- Start of processing for Is_Global
14640 if E
= Gen_Scope
then
14643 elsif E
= Standard_Standard
then
14646 elsif Is_Child_Unit
(E
)
14647 and then (Is_Instance_Node
(Parent
(N2
))
14648 or else (Nkind
(Parent
(N2
)) = N_Expanded_Name
14649 and then N2
= Selector_Name
(Parent
(N2
))
14651 Is_Instance_Node
(Parent
(Parent
(N2
)))))
14657 while Se
/= Gen_Scope
loop
14658 if Se
= Standard_Standard
then
14669 --------------------------------
14670 -- Qualify_Universal_Operands --
14671 --------------------------------
14673 procedure Qualify_Universal_Operands
14675 Func_Call
: Node_Id
)
14677 procedure Qualify_Operand
(Opnd
: Node_Id
; Actual
: Node_Id
);
14678 -- Rewrite operand Opnd as a qualified expression of the form
14680 -- Actual_Typ'(Opnd)
14682 -- where Actual is the corresponding actual parameter of Opnd in
14683 -- function call Func_Call.
14685 function Qualify_Type
14687 Typ
: Entity_Id
) return Node_Id
;
14688 -- Qualify type Typ by creating a selected component of the form
14690 -- Scope_Of_Typ.Typ
14692 ---------------------
14693 -- Qualify_Operand --
14694 ---------------------
14696 procedure Qualify_Operand
(Opnd
: Node_Id
; Actual
: Node_Id
) is
14697 Loc
: constant Source_Ptr
:= Sloc
(Opnd
);
14698 Typ
: constant Entity_Id
:= Etype
(Actual
);
14703 -- Qualify the operand when it is of a universal type. Note that
14704 -- the template is unanalyzed and it is not possible to directly
14705 -- query the type. This transformation is not done when the type
14706 -- of the actual is internally generated because the type will be
14707 -- regenerated in the instance.
14709 if Yields_Universal_Type
(Opnd
)
14710 and then Comes_From_Source
(Typ
)
14711 and then not Is_Hidden
(Typ
)
14713 -- The type of the actual may be a global reference. Save this
14714 -- information by creating a reference to it.
14716 if Is_Global
(Typ
) then
14717 Mark
:= New_Occurrence_Of
(Typ
, Loc
);
14719 -- Otherwise rely on resolution to find the proper type within
14723 Mark
:= Qualify_Type
(Loc
, Typ
);
14727 Make_Qualified_Expression
(Loc
,
14728 Subtype_Mark
=> Mark
,
14729 Expression
=> Relocate_Node
(Opnd
));
14731 -- Mark the qualification to distinguish it from other source
14732 -- constructs and signal the instantiation mechanism that this
14733 -- node requires special processing. See Copy_Generic_Node for
14736 Set_Is_Qualified_Universal_Literal
(Qual
);
14738 Rewrite
(Opnd
, Qual
);
14740 end Qualify_Operand
;
14746 function Qualify_Type
14748 Typ
: Entity_Id
) return Node_Id
14750 Scop
: constant Entity_Id
:= Scope
(Typ
);
14754 Result
:= Make_Identifier
(Loc
, Chars
(Typ
));
14756 if Present
(Scop
) and then not Is_Generic_Unit
(Scop
) then
14758 Make_Selected_Component
(Loc
,
14759 Prefix
=> Make_Identifier
(Loc
, Chars
(Scop
)),
14760 Selector_Name
=> Result
);
14768 Actuals
: constant List_Id
:= Parameter_Associations
(Func_Call
);
14770 -- Start of processing for Qualify_Universal_Operands
14773 if Nkind
(Op
) in N_Binary_Op
then
14774 Qualify_Operand
(Left_Opnd
(Op
), First
(Actuals
));
14775 Qualify_Operand
(Right_Opnd
(Op
), Next
(First
(Actuals
)));
14777 elsif Nkind
(Op
) in N_Unary_Op
then
14778 Qualify_Operand
(Right_Opnd
(Op
), First
(Actuals
));
14780 end Qualify_Universal_Operands
;
14786 procedure Reset_Entity
(N
: Node_Id
) is
14787 procedure Set_Global_Type
(N
: Node_Id
; N2
: Node_Id
);
14788 -- If the type of N2 is global to the generic unit, save the type in
14789 -- the generic node. Just as we perform name capture for explicit
14790 -- references within the generic, we must capture the global types
14791 -- of local entities because they may participate in resolution in
14794 function Top_Ancestor
(E
: Entity_Id
) return Entity_Id
;
14795 -- Find the ultimate ancestor of the current unit. If it is not a
14796 -- generic unit, then the name of the current unit in the prefix of
14797 -- an expanded name must be replaced with its generic homonym to
14798 -- ensure that it will be properly resolved in an instance.
14800 ---------------------
14801 -- Set_Global_Type --
14802 ---------------------
14804 procedure Set_Global_Type
(N
: Node_Id
; N2
: Node_Id
) is
14805 Typ
: constant Entity_Id
:= Etype
(N2
);
14808 Set_Etype
(N
, Typ
);
14810 -- If the entity of N is not the associated node, this is a
14811 -- nested generic and it has an associated node as well, whose
14812 -- type is already the full view (see below). Indicate that the
14813 -- original node has a private view.
14815 if Entity
(N
) /= N2
and then Has_Private_View
(Entity
(N
)) then
14816 Set_Has_Private_View
(N
);
14819 -- If not a private type, nothing else to do
14821 if not Is_Private_Type
(Typ
) then
14822 if Is_Array_Type
(Typ
)
14823 and then Is_Private_Type
(Component_Type
(Typ
))
14825 Set_Has_Private_View
(N
);
14828 -- If it is a derivation of a private type in a context where no
14829 -- full view is needed, nothing to do either.
14831 elsif No
(Full_View
(Typ
)) and then Typ
/= Etype
(Typ
) then
14834 -- Otherwise mark the type for flipping and use the full view when
14838 Set_Has_Private_View
(N
);
14840 if Present
(Full_View
(Typ
)) then
14841 Set_Etype
(N2
, Full_View
(Typ
));
14845 if Is_Floating_Point_Type
(Typ
)
14846 and then Has_Dimension_System
(Typ
)
14848 Copy_Dimensions
(N2
, N
);
14850 end Set_Global_Type
;
14856 function Top_Ancestor
(E
: Entity_Id
) return Entity_Id
is
14861 while Is_Child_Unit
(Par
) loop
14862 Par
:= Scope
(Par
);
14868 -- Start of processing for Reset_Entity
14871 N2
:= Get_Associated_Node
(N
);
14874 if Present
(E
) then
14876 -- If the node is an entry call to an entry in an enclosing task,
14877 -- it is rewritten as a selected component. No global entity to
14878 -- preserve in this case, since the expansion will be redone in
14881 if not Nkind_In
(E
, N_Defining_Character_Literal
,
14882 N_Defining_Identifier
,
14883 N_Defining_Operator_Symbol
)
14885 Set_Associated_Node
(N
, Empty
);
14886 Set_Etype
(N
, Empty
);
14890 -- If the entity is an itype created as a subtype of an access
14891 -- type with a null exclusion restore source entity for proper
14892 -- visibility. The itype will be created anew in the instance.
14895 and then Ekind
(E
) = E_Access_Subtype
14896 and then Is_Entity_Name
(N
)
14897 and then Chars
(Etype
(E
)) = Chars
(N
)
14900 Set_Entity
(N2
, E
);
14904 if Is_Global
(E
) then
14906 -- If the entity is a package renaming that is the prefix of
14907 -- an expanded name, it has been rewritten as the renamed
14908 -- package, which is necessary semantically but complicates
14909 -- ASIS tree traversal, so we recover the original entity to
14910 -- expose the renaming. Take into account that the context may
14911 -- be a nested generic, that the original node may itself have
14912 -- an associated node that had better be an entity, and that
14913 -- the current node is still a selected component.
14915 if Ekind
(E
) = E_Package
14916 and then Nkind
(N
) = N_Selected_Component
14917 and then Nkind
(Parent
(N
)) = N_Expanded_Name
14918 and then Present
(Original_Node
(N2
))
14919 and then Is_Entity_Name
(Original_Node
(N2
))
14920 and then Present
(Entity
(Original_Node
(N2
)))
14922 if Is_Global
(Entity
(Original_Node
(N2
))) then
14923 N2
:= Original_Node
(N2
);
14924 Set_Associated_Node
(N
, N2
);
14925 Set_Global_Type
(N
, N2
);
14927 -- Renaming is local, and will be resolved in instance
14930 Set_Associated_Node
(N
, Empty
);
14931 Set_Etype
(N
, Empty
);
14935 Set_Global_Type
(N
, N2
);
14938 elsif Nkind
(N
) = N_Op_Concat
14939 and then Is_Generic_Type
(Etype
(N2
))
14940 and then (Base_Type
(Etype
(Right_Opnd
(N2
))) = Etype
(N2
)
14942 Base_Type
(Etype
(Left_Opnd
(N2
))) = Etype
(N2
))
14943 and then Is_Intrinsic_Subprogram
(E
)
14947 -- Entity is local. Mark generic node as unresolved. Note that now
14948 -- it does not have an entity.
14951 Set_Associated_Node
(N
, Empty
);
14952 Set_Etype
(N
, Empty
);
14955 if Nkind
(Parent
(N
)) in N_Generic_Instantiation
14956 and then N
= Name
(Parent
(N
))
14958 Save_Global_Defaults
(Parent
(N
), Parent
(N2
));
14961 elsif Nkind
(Parent
(N
)) = N_Selected_Component
14962 and then Nkind
(Parent
(N2
)) = N_Expanded_Name
14964 if Is_Global
(Entity
(Parent
(N2
))) then
14965 Change_Selected_Component_To_Expanded_Name
(Parent
(N
));
14966 Set_Associated_Node
(Parent
(N
), Parent
(N2
));
14967 Set_Global_Type
(Parent
(N
), Parent
(N2
));
14968 Save_Entity_Descendants
(N
);
14970 -- If this is a reference to the current generic entity, replace
14971 -- by the name of the generic homonym of the current package. This
14972 -- is because in an instantiation Par.P.Q will not resolve to the
14973 -- name of the instance, whose enclosing scope is not necessarily
14974 -- Par. We use the generic homonym rather that the name of the
14975 -- generic itself because it may be hidden by a local declaration.
14977 elsif In_Open_Scopes
(Entity
(Parent
(N2
)))
14979 Is_Generic_Unit
(Top_Ancestor
(Entity
(Prefix
(Parent
(N2
)))))
14981 if Ekind
(Entity
(Parent
(N2
))) = E_Generic_Package
then
14982 Rewrite
(Parent
(N
),
14983 Make_Identifier
(Sloc
(N
),
14985 Chars
(Generic_Homonym
(Entity
(Parent
(N2
))))));
14987 Rewrite
(Parent
(N
),
14988 Make_Identifier
(Sloc
(N
),
14989 Chars
=> Chars
(Selector_Name
(Parent
(N2
)))));
14993 if Nkind
(Parent
(Parent
(N
))) in N_Generic_Instantiation
14994 and then Parent
(N
) = Name
(Parent
(Parent
(N
)))
14996 Save_Global_Defaults
14997 (Parent
(Parent
(N
)), Parent
(Parent
(N2
)));
15000 -- A selected component may denote a static constant that has been
15001 -- folded. If the static constant is global to the generic, capture
15002 -- its value. Otherwise the folding will happen in any instantiation.
15004 elsif Nkind
(Parent
(N
)) = N_Selected_Component
15005 and then Nkind_In
(Parent
(N2
), N_Integer_Literal
, N_Real_Literal
)
15007 if Present
(Entity
(Original_Node
(Parent
(N2
))))
15008 and then Is_Global
(Entity
(Original_Node
(Parent
(N2
))))
15010 Rewrite
(Parent
(N
), New_Copy
(Parent
(N2
)));
15011 Set_Analyzed
(Parent
(N
), False);
15014 -- A selected component may be transformed into a parameterless
15015 -- function call. If the called entity is global, rewrite the node
15016 -- appropriately, i.e. as an extended name for the global entity.
15018 elsif Nkind
(Parent
(N
)) = N_Selected_Component
15019 and then Nkind
(Parent
(N2
)) = N_Function_Call
15020 and then N
= Selector_Name
(Parent
(N
))
15022 if No
(Parameter_Associations
(Parent
(N2
))) then
15023 if Is_Global
(Entity
(Name
(Parent
(N2
)))) then
15024 Change_Selected_Component_To_Expanded_Name
(Parent
(N
));
15025 Set_Associated_Node
(Parent
(N
), Name
(Parent
(N2
)));
15026 Set_Global_Type
(Parent
(N
), Name
(Parent
(N2
)));
15027 Save_Entity_Descendants
(N
);
15030 Set_Is_Prefixed_Call
(Parent
(N
));
15031 Set_Associated_Node
(N
, Empty
);
15032 Set_Etype
(N
, Empty
);
15035 -- In Ada 2005, X.F may be a call to a primitive operation,
15036 -- rewritten as F (X). This rewriting will be done again in an
15037 -- instance, so keep the original node. Global entities will be
15038 -- captured as for other constructs. Indicate that this must
15039 -- resolve as a call, to prevent accidental overloading in the
15040 -- instance, if both a component and a primitive operation appear
15044 Set_Is_Prefixed_Call
(Parent
(N
));
15047 -- Entity is local. Reset in generic unit, so that node is resolved
15048 -- anew at the point of instantiation.
15051 Set_Associated_Node
(N
, Empty
);
15052 Set_Etype
(N
, Empty
);
15056 -----------------------------
15057 -- Save_Entity_Descendants --
15058 -----------------------------
15060 procedure Save_Entity_Descendants
(N
: Node_Id
) is
15063 when N_Binary_Op
=>
15064 Save_Global_Descendant
(Union_Id
(Left_Opnd
(N
)));
15065 Save_Global_Descendant
(Union_Id
(Right_Opnd
(N
)));
15068 Save_Global_Descendant
(Union_Id
(Right_Opnd
(N
)));
15070 when N_Expanded_Name
15071 | N_Selected_Component
15073 Save_Global_Descendant
(Union_Id
(Prefix
(N
)));
15074 Save_Global_Descendant
(Union_Id
(Selector_Name
(N
)));
15076 when N_Character_Literal
15078 | N_Operator_Symbol
15083 raise Program_Error
;
15085 end Save_Entity_Descendants
;
15087 --------------------------
15088 -- Save_Global_Defaults --
15089 --------------------------
15091 procedure Save_Global_Defaults
(N1
: Node_Id
; N2
: Node_Id
) is
15092 Loc
: constant Source_Ptr
:= Sloc
(N1
);
15093 Assoc2
: constant List_Id
:= Generic_Associations
(N2
);
15094 Gen_Id
: constant Entity_Id
:= Get_Generic_Entity
(N2
);
15101 Actual
: Entity_Id
;
15104 Assoc1
:= Generic_Associations
(N1
);
15106 if Present
(Assoc1
) then
15107 Act1
:= First
(Assoc1
);
15110 Set_Generic_Associations
(N1
, New_List
);
15111 Assoc1
:= Generic_Associations
(N1
);
15114 if Present
(Assoc2
) then
15115 Act2
:= First
(Assoc2
);
15120 while Present
(Act1
) and then Present
(Act2
) loop
15125 -- Find the associations added for default subprograms
15127 if Present
(Act2
) then
15128 while Nkind
(Act2
) /= N_Generic_Association
15129 or else No
(Entity
(Selector_Name
(Act2
)))
15130 or else not Is_Overloadable
(Entity
(Selector_Name
(Act2
)))
15135 -- Add a similar association if the default is global. The
15136 -- renaming declaration for the actual has been analyzed, and
15137 -- its alias is the program it renames. Link the actual in the
15138 -- original generic tree with the node in the analyzed tree.
15140 while Present
(Act2
) loop
15141 Subp
:= Entity
(Selector_Name
(Act2
));
15142 Def
:= Explicit_Generic_Actual_Parameter
(Act2
);
15144 -- Following test is defence against rubbish errors
15146 if No
(Alias
(Subp
)) then
15150 -- Retrieve the resolved actual from the renaming declaration
15151 -- created for the instantiated formal.
15153 Actual
:= Entity
(Name
(Parent
(Parent
(Subp
))));
15154 Set_Entity
(Def
, Actual
);
15155 Set_Etype
(Def
, Etype
(Actual
));
15157 if Is_Global
(Actual
) then
15159 Make_Generic_Association
(Loc
,
15161 New_Occurrence_Of
(Subp
, Loc
),
15162 Explicit_Generic_Actual_Parameter
=>
15163 New_Occurrence_Of
(Actual
, Loc
));
15165 Set_Associated_Node
15166 (Explicit_Generic_Actual_Parameter
(Ndec
), Def
);
15168 Append
(Ndec
, Assoc1
);
15170 -- If there are other defaults, add a dummy association in case
15171 -- there are other defaulted formals with the same name.
15173 elsif Present
(Next
(Act2
)) then
15175 Make_Generic_Association
(Loc
,
15177 New_Occurrence_Of
(Subp
, Loc
),
15178 Explicit_Generic_Actual_Parameter
=> Empty
);
15180 Append
(Ndec
, Assoc1
);
15187 if Nkind
(Name
(N1
)) = N_Identifier
15188 and then Is_Child_Unit
(Gen_Id
)
15189 and then Is_Global
(Gen_Id
)
15190 and then Is_Generic_Unit
(Scope
(Gen_Id
))
15191 and then In_Open_Scopes
(Scope
(Gen_Id
))
15193 -- This is an instantiation of a child unit within a sibling, so
15194 -- that the generic parent is in scope. An eventual instance must
15195 -- occur within the scope of an instance of the parent. Make name
15196 -- in instance into an expanded name, to preserve the identifier
15197 -- of the parent, so it can be resolved subsequently.
15199 Rewrite
(Name
(N2
),
15200 Make_Expanded_Name
(Loc
,
15201 Chars
=> Chars
(Gen_Id
),
15202 Prefix
=> New_Occurrence_Of
(Scope
(Gen_Id
), Loc
),
15203 Selector_Name
=> New_Occurrence_Of
(Gen_Id
, Loc
)));
15204 Set_Entity
(Name
(N2
), Gen_Id
);
15206 Rewrite
(Name
(N1
),
15207 Make_Expanded_Name
(Loc
,
15208 Chars
=> Chars
(Gen_Id
),
15209 Prefix
=> New_Occurrence_Of
(Scope
(Gen_Id
), Loc
),
15210 Selector_Name
=> New_Occurrence_Of
(Gen_Id
, Loc
)));
15212 Set_Associated_Node
(Name
(N1
), Name
(N2
));
15213 Set_Associated_Node
(Prefix
(Name
(N1
)), Empty
);
15214 Set_Associated_Node
15215 (Selector_Name
(Name
(N1
)), Selector_Name
(Name
(N2
)));
15216 Set_Etype
(Name
(N1
), Etype
(Gen_Id
));
15218 end Save_Global_Defaults
;
15220 ----------------------------
15221 -- Save_Global_Descendant --
15222 ----------------------------
15224 procedure Save_Global_Descendant
(D
: Union_Id
) is
15228 if D
in Node_Range
then
15229 if D
= Union_Id
(Empty
) then
15232 elsif Nkind
(Node_Id
(D
)) /= N_Compilation_Unit
then
15233 Save_References
(Node_Id
(D
));
15236 elsif D
in List_Range
then
15237 pragma Assert
(D
/= Union_Id
(No_List
));
15238 -- Because No_List = Empty, which is in Node_Range above
15240 if Is_Empty_List
(List_Id
(D
)) then
15244 N1
:= First
(List_Id
(D
));
15245 while Present
(N1
) loop
15246 Save_References
(N1
);
15251 -- Element list or other non-node field, nothing to do
15256 end Save_Global_Descendant
;
15258 ---------------------
15259 -- Save_References --
15260 ---------------------
15262 -- This is the recursive procedure that does the work once the enclosing
15263 -- generic scope has been established. We have to treat specially a
15264 -- number of node rewritings that are required by semantic processing
15265 -- and which change the kind of nodes in the generic copy: typically
15266 -- constant-folding, replacing an operator node by a string literal, or
15267 -- a selected component by an expanded name. In each of those cases, the
15268 -- transformation is propagated to the generic unit.
15270 procedure Save_References
(N
: Node_Id
) is
15271 Loc
: constant Source_Ptr
:= Sloc
(N
);
15273 function Requires_Delayed_Save
(Nod
: Node_Id
) return Boolean;
15274 -- Determine whether arbitrary node Nod requires delayed capture of
15275 -- global references within its aspect specifications.
15277 procedure Save_References_In_Aggregate
(N
: Node_Id
);
15278 -- Save all global references in [extension] aggregate node N
15280 procedure Save_References_In_Char_Lit_Or_Op_Symbol
(N
: Node_Id
);
15281 -- Save all global references in a character literal or operator
15282 -- symbol denoted by N.
15284 procedure Save_References_In_Descendants
(N
: Node_Id
);
15285 -- Save all global references in all descendants of node N
15287 procedure Save_References_In_Identifier
(N
: Node_Id
);
15288 -- Save all global references in identifier node N
15290 procedure Save_References_In_Operator
(N
: Node_Id
);
15291 -- Save all global references in operator node N
15293 procedure Save_References_In_Pragma
(Prag
: Node_Id
);
15294 -- Save all global references found within the expression of pragma
15297 ---------------------------
15298 -- Requires_Delayed_Save --
15299 ---------------------------
15301 function Requires_Delayed_Save
(Nod
: Node_Id
) return Boolean is
15303 -- Generic packages and subprograms require delayed capture of
15304 -- global references within their aspects due to the timing of
15305 -- annotation analysis.
15307 if Nkind_In
(Nod
, N_Generic_Package_Declaration
,
15308 N_Generic_Subprogram_Declaration
,
15310 N_Package_Body_Stub
,
15312 N_Subprogram_Body_Stub
)
15314 -- Since the capture of global references is done on the
15315 -- unanalyzed generic template, there is no information around
15316 -- to infer the context. Use the Associated_Entity linkages to
15317 -- peek into the analyzed generic copy and determine what the
15318 -- template corresponds to.
15320 if Nod
= Templ
then
15322 Is_Generic_Declaration_Or_Body
15323 (Unit_Declaration_Node
15324 (Associated_Entity
(Defining_Entity
(Nod
))));
15326 -- Otherwise the generic unit being processed is not the top
15327 -- level template. It is safe to capture of global references
15328 -- within the generic unit because at this point the top level
15329 -- copy is fully analyzed.
15335 -- Otherwise capture the global references without interference
15340 end Requires_Delayed_Save
;
15342 ----------------------------------
15343 -- Save_References_In_Aggregate --
15344 ----------------------------------
15346 procedure Save_References_In_Aggregate
(N
: Node_Id
) is
15348 Qual
: Node_Id
:= Empty
;
15349 Typ
: Entity_Id
:= Empty
;
15351 use Atree
.Unchecked_Access
;
15352 -- This code section is part of implementing an untyped tree
15353 -- traversal, so it needs direct access to node fields.
15356 N2
:= Get_Associated_Node
(N
);
15358 if Present
(N2
) then
15361 -- In an instance within a generic, use the name of the actual
15362 -- and not the original generic parameter. If the actual is
15363 -- global in the current generic it must be preserved for its
15366 if Nkind
(Parent
(Typ
)) = N_Subtype_Declaration
15367 and then Present
(Generic_Parent_Type
(Parent
(Typ
)))
15369 Typ
:= Base_Type
(Typ
);
15370 Set_Etype
(N2
, Typ
);
15374 if No
(N2
) or else No
(Typ
) or else not Is_Global
(Typ
) then
15375 Set_Associated_Node
(N
, Empty
);
15377 -- If the aggregate is an actual in a call, it has been
15378 -- resolved in the current context, to some local type. The
15379 -- enclosing call may have been disambiguated by the aggregate,
15380 -- and this disambiguation might fail at instantiation time
15381 -- because the type to which the aggregate did resolve is not
15382 -- preserved. In order to preserve some of this information,
15383 -- wrap the aggregate in a qualified expression, using the id
15384 -- of its type. For further disambiguation we qualify the type
15385 -- name with its scope (if visible and not hidden by a local
15386 -- homograph) because both id's will have corresponding
15387 -- entities in an instance. This resolves most of the problems
15388 -- with missing type information on aggregates in instances.
15391 and then Nkind
(N2
) = Nkind
(N
)
15392 and then Nkind
(Parent
(N2
)) in N_Subprogram_Call
15393 and then Present
(Typ
)
15394 and then Comes_From_Source
(Typ
)
15396 Nam
:= Make_Identifier
(Loc
, Chars
(Typ
));
15398 if Is_Immediately_Visible
(Scope
(Typ
))
15400 (not In_Open_Scopes
(Scope
(Typ
))
15401 or else Current_Entity
(Scope
(Typ
)) = Scope
(Typ
))
15404 Make_Selected_Component
(Loc
,
15406 Make_Identifier
(Loc
, Chars
(Scope
(Typ
))),
15407 Selector_Name
=> Nam
);
15411 Make_Qualified_Expression
(Loc
,
15412 Subtype_Mark
=> Nam
,
15413 Expression
=> Relocate_Node
(N
));
15417 Save_Global_Descendant
(Field1
(N
));
15418 Save_Global_Descendant
(Field2
(N
));
15419 Save_Global_Descendant
(Field3
(N
));
15420 Save_Global_Descendant
(Field5
(N
));
15422 if Present
(Qual
) then
15425 end Save_References_In_Aggregate
;
15427 ----------------------------------------------
15428 -- Save_References_In_Char_Lit_Or_Op_Symbol --
15429 ----------------------------------------------
15431 procedure Save_References_In_Char_Lit_Or_Op_Symbol
(N
: Node_Id
) is
15433 if Nkind
(N
) = Nkind
(Get_Associated_Node
(N
)) then
15436 elsif Nkind
(N
) = N_Operator_Symbol
15437 and then Nkind
(Get_Associated_Node
(N
)) = N_String_Literal
15439 Change_Operator_Symbol_To_String_Literal
(N
);
15441 end Save_References_In_Char_Lit_Or_Op_Symbol
;
15443 ------------------------------------
15444 -- Save_References_In_Descendants --
15445 ------------------------------------
15447 procedure Save_References_In_Descendants
(N
: Node_Id
) is
15448 use Atree
.Unchecked_Access
;
15449 -- This code section is part of implementing an untyped tree
15450 -- traversal, so it needs direct access to node fields.
15453 Save_Global_Descendant
(Field1
(N
));
15454 Save_Global_Descendant
(Field2
(N
));
15455 Save_Global_Descendant
(Field3
(N
));
15456 Save_Global_Descendant
(Field4
(N
));
15457 Save_Global_Descendant
(Field5
(N
));
15458 end Save_References_In_Descendants
;
15460 -----------------------------------
15461 -- Save_References_In_Identifier --
15462 -----------------------------------
15464 procedure Save_References_In_Identifier
(N
: Node_Id
) is
15466 -- The node did not undergo a transformation
15468 if Nkind
(N
) = Nkind
(Get_Associated_Node
(N
)) then
15470 Aux_N2
: constant Node_Id
:= Get_Associated_Node
(N
);
15471 Orig_N2_Parent
: constant Node_Id
:=
15472 Original_Node
(Parent
(Aux_N2
));
15474 -- The parent of this identifier is a selected component
15475 -- which denotes a named number that was constant folded.
15476 -- Preserve the original name for ASIS and link the parent
15477 -- with its expanded name. The constant folding will be
15478 -- repeated in the instance.
15480 if Nkind
(Parent
(N
)) = N_Selected_Component
15481 and then Nkind_In
(Parent
(Aux_N2
), N_Integer_Literal
,
15483 and then Is_Entity_Name
(Orig_N2_Parent
)
15484 and then Ekind
(Entity
(Orig_N2_Parent
)) in Named_Kind
15485 and then Is_Global
(Entity
(Orig_N2_Parent
))
15488 Set_Associated_Node
15489 (Parent
(N
), Original_Node
(Parent
(N2
)));
15494 -- If this is a discriminant reference, always save it.
15495 -- It is used in the instance to find the corresponding
15496 -- discriminant positionally rather than by name.
15498 Set_Original_Discriminant
15499 (N
, Original_Discriminant
(Get_Associated_Node
(N
)));
15505 -- The analysis of the generic copy transformed the identifier
15506 -- into another construct. Propagate the changes to the template.
15509 N2
:= Get_Associated_Node
(N
);
15511 -- The identifier denotes a call to a parameterless function.
15512 -- Mark the node as resolved when the function is external.
15514 if Nkind
(N2
) = N_Function_Call
then
15515 E
:= Entity
(Name
(N2
));
15517 if Present
(E
) and then Is_Global
(E
) then
15518 Set_Etype
(N
, Etype
(N2
));
15520 Set_Associated_Node
(N
, Empty
);
15521 Set_Etype
(N
, Empty
);
15524 -- The identifier denotes a named number that was constant
15525 -- folded. Preserve the original name for ASIS and undo the
15526 -- constant folding which will be repeated in the instance.
15528 elsif Nkind_In
(N2
, N_Integer_Literal
, N_Real_Literal
)
15529 and then Is_Entity_Name
(Original_Node
(N2
))
15531 Set_Associated_Node
(N
, Original_Node
(N2
));
15534 -- The identifier resolved to a string literal. Propagate this
15535 -- information to the generic template.
15537 elsif Nkind
(N2
) = N_String_Literal
then
15538 Rewrite
(N
, New_Copy
(N2
));
15540 -- The identifier is rewritten as a dereference if it is the
15541 -- prefix of an implicit dereference. Preserve the original
15542 -- tree as the analysis of the instance will expand the node
15543 -- again, but preserve the resolved entity if it is global.
15545 elsif Nkind
(N2
) = N_Explicit_Dereference
then
15546 if Is_Entity_Name
(Prefix
(N2
))
15547 and then Present
(Entity
(Prefix
(N2
)))
15548 and then Is_Global
(Entity
(Prefix
(N2
)))
15550 Set_Associated_Node
(N
, Prefix
(N2
));
15552 elsif Nkind
(Prefix
(N2
)) = N_Function_Call
15553 and then Present
(Entity
(Name
(Prefix
(N2
))))
15554 and then Is_Global
(Entity
(Name
(Prefix
(N2
))))
15557 Make_Explicit_Dereference
(Loc
,
15559 Make_Function_Call
(Loc
,
15562 (Entity
(Name
(Prefix
(N2
))), Loc
))));
15565 Set_Associated_Node
(N
, Empty
);
15566 Set_Etype
(N
, Empty
);
15569 -- The subtype mark of a nominally unconstrained object is
15570 -- rewritten as a subtype indication using the bounds of the
15571 -- expression. Recover the original subtype mark.
15573 elsif Nkind
(N2
) = N_Subtype_Indication
15574 and then Is_Entity_Name
(Original_Node
(N2
))
15576 Set_Associated_Node
(N
, Original_Node
(N2
));
15580 end Save_References_In_Identifier
;
15582 ---------------------------------
15583 -- Save_References_In_Operator --
15584 ---------------------------------
15586 procedure Save_References_In_Operator
(N
: Node_Id
) is
15588 -- The node did not undergo a transformation
15590 if Nkind
(N
) = Nkind
(Get_Associated_Node
(N
)) then
15591 if Nkind
(N
) = N_Op_Concat
then
15592 Set_Is_Component_Left_Opnd
(N
,
15593 Is_Component_Left_Opnd
(Get_Associated_Node
(N
)));
15595 Set_Is_Component_Right_Opnd
(N
,
15596 Is_Component_Right_Opnd
(Get_Associated_Node
(N
)));
15601 -- The analysis of the generic copy transformed the operator into
15602 -- some other construct. Propagate the changes to the template if
15606 N2
:= Get_Associated_Node
(N
);
15608 -- The operator resoved to a function call
15610 if Nkind
(N2
) = N_Function_Call
then
15612 -- Add explicit qualifications in the generic template for
15613 -- all operands of universal type. This aids resolution by
15614 -- preserving the actual type of a literal or an attribute
15615 -- that yields a universal result.
15617 Qualify_Universal_Operands
(N
, N2
);
15619 E
:= Entity
(Name
(N2
));
15621 if Present
(E
) and then Is_Global
(E
) then
15622 Set_Etype
(N
, Etype
(N2
));
15624 Set_Associated_Node
(N
, Empty
);
15625 Set_Etype
(N
, Empty
);
15628 -- The operator was folded into a literal
15630 elsif Nkind_In
(N2
, N_Integer_Literal
,
15634 if Present
(Original_Node
(N2
))
15635 and then Nkind
(Original_Node
(N2
)) = Nkind
(N
)
15637 -- Operation was constant-folded. Whenever possible,
15638 -- recover semantic information from unfolded node,
15641 Set_Associated_Node
(N
, Original_Node
(N2
));
15643 if Nkind
(N
) = N_Op_Concat
then
15644 Set_Is_Component_Left_Opnd
(N
,
15645 Is_Component_Left_Opnd
(Get_Associated_Node
(N
)));
15646 Set_Is_Component_Right_Opnd
(N
,
15647 Is_Component_Right_Opnd
(Get_Associated_Node
(N
)));
15652 -- Propagate the constant folding back to the template
15655 Rewrite
(N
, New_Copy
(N2
));
15656 Set_Analyzed
(N
, False);
15659 -- The operator was folded into an enumeration literal. Retain
15660 -- the entity to avoid spurious ambiguities if it is overloaded
15661 -- at the point of instantiation or inlining.
15663 elsif Nkind
(N2
) = N_Identifier
15664 and then Ekind
(Entity
(N2
)) = E_Enumeration_Literal
15666 Rewrite
(N
, New_Copy
(N2
));
15667 Set_Analyzed
(N
, False);
15671 -- Complete the operands check if node has not been constant
15674 if Nkind
(N
) in N_Op
then
15675 Save_Entity_Descendants
(N
);
15677 end Save_References_In_Operator
;
15679 -------------------------------
15680 -- Save_References_In_Pragma --
15681 -------------------------------
15683 procedure Save_References_In_Pragma
(Prag
: Node_Id
) is
15685 Do_Save
: Boolean := True;
15687 use Atree
.Unchecked_Access
;
15688 -- This code section is part of implementing an untyped tree
15689 -- traversal, so it needs direct access to node fields.
15692 -- Do not save global references in pragmas generated from aspects
15693 -- because the pragmas will be regenerated at instantiation time.
15695 if From_Aspect_Specification
(Prag
) then
15698 -- The capture of global references within contract-related source
15699 -- pragmas associated with generic packages, subprograms or their
15700 -- respective bodies must be delayed due to timing of annotation
15701 -- analysis. Global references are still captured in routine
15702 -- Save_Global_References_In_Contract.
15704 elsif Is_Generic_Contract_Pragma
(Prag
) and then Prag
/= Templ
then
15705 if Is_Package_Contract_Annotation
(Prag
) then
15706 Context
:= Find_Related_Package_Or_Body
(Prag
);
15708 pragma Assert
(Is_Subprogram_Contract_Annotation
(Prag
));
15709 Context
:= Find_Related_Declaration_Or_Body
(Prag
);
15712 -- The use of Original_Node accounts for the case when the
15713 -- related context is generic template.
15715 if Requires_Delayed_Save
(Original_Node
(Context
)) then
15720 -- For all other cases, save all global references within the
15721 -- descendants, but skip the following semantic fields:
15723 -- Field1 - Next_Pragma
15724 -- Field3 - Corresponding_Aspect
15725 -- Field5 - Next_Rep_Item
15728 Save_Global_Descendant
(Field2
(Prag
));
15729 Save_Global_Descendant
(Field4
(Prag
));
15731 end Save_References_In_Pragma
;
15733 -- Start of processing for Save_References
15741 elsif Nkind_In
(N
, N_Aggregate
, N_Extension_Aggregate
) then
15742 Save_References_In_Aggregate
(N
);
15744 -- Character literals, operator symbols
15746 elsif Nkind_In
(N
, N_Character_Literal
, N_Operator_Symbol
) then
15747 Save_References_In_Char_Lit_Or_Op_Symbol
(N
);
15749 -- Defining identifiers
15751 elsif Nkind
(N
) in N_Entity
then
15756 elsif Nkind
(N
) = N_Identifier
then
15757 Save_References_In_Identifier
(N
);
15761 elsif Nkind
(N
) in N_Op
then
15762 Save_References_In_Operator
(N
);
15766 elsif Nkind
(N
) = N_Pragma
then
15767 Save_References_In_Pragma
(N
);
15770 Save_References_In_Descendants
(N
);
15773 -- Save all global references found within the aspect specifications
15774 -- of the related node.
15776 if Permits_Aspect_Specifications
(N
) and then Has_Aspects
(N
) then
15778 -- The capture of global references within aspects associated with
15779 -- generic packages, subprograms or their bodies must be delayed
15780 -- due to timing of annotation analysis. Global references are
15781 -- still captured in routine Save_Global_References_In_Contract.
15783 if Requires_Delayed_Save
(N
) then
15786 -- Otherwise save all global references within the aspects
15789 Save_Global_References_In_Aspects
(N
);
15792 end Save_References
;
15794 -- Start of processing for Save_Global_References
15797 Gen_Scope
:= Current_Scope
;
15799 -- If the generic unit is a child unit, references to entities in the
15800 -- parent are treated as local, because they will be resolved anew in
15801 -- the context of the instance of the parent.
15803 while Is_Child_Unit
(Gen_Scope
)
15804 and then Ekind
(Scope
(Gen_Scope
)) = E_Generic_Package
15806 Gen_Scope
:= Scope
(Gen_Scope
);
15809 Save_References
(Templ
);
15810 end Save_Global_References
;
15812 ---------------------------------------
15813 -- Save_Global_References_In_Aspects --
15814 ---------------------------------------
15816 procedure Save_Global_References_In_Aspects
(N
: Node_Id
) is
15821 Asp
:= First
(Aspect_Specifications
(N
));
15822 while Present
(Asp
) loop
15823 Expr
:= Expression
(Asp
);
15825 if Present
(Expr
) then
15826 Save_Global_References
(Expr
);
15831 end Save_Global_References_In_Aspects
;
15833 ------------------------------------------
15834 -- Set_Copied_Sloc_For_Inherited_Pragma --
15835 ------------------------------------------
15837 procedure Set_Copied_Sloc_For_Inherited_Pragma
15842 Create_Instantiation_Source
(N
, E
,
15843 Inlined_Body
=> False,
15844 Inherited_Pragma
=> True,
15845 Factor
=> S_Adjustment
);
15846 end Set_Copied_Sloc_For_Inherited_Pragma
;
15848 --------------------------------------
15849 -- Set_Copied_Sloc_For_Inlined_Body --
15850 --------------------------------------
15852 procedure Set_Copied_Sloc_For_Inlined_Body
(N
: Node_Id
; E
: Entity_Id
) is
15854 Create_Instantiation_Source
(N
, E
,
15855 Inlined_Body
=> True,
15856 Inherited_Pragma
=> False,
15857 Factor
=> S_Adjustment
);
15858 end Set_Copied_Sloc_For_Inlined_Body
;
15860 ---------------------
15861 -- Set_Instance_Of --
15862 ---------------------
15864 procedure Set_Instance_Of
(A
: Entity_Id
; B
: Entity_Id
) is
15866 Generic_Renamings
.Table
(Generic_Renamings
.Last
) := (A
, B
, Assoc_Null
);
15867 Generic_Renamings_HTable
.Set
(Generic_Renamings
.Last
);
15868 Generic_Renamings
.Increment_Last
;
15869 end Set_Instance_Of
;
15871 --------------------
15872 -- Set_Next_Assoc --
15873 --------------------
15875 procedure Set_Next_Assoc
(E
: Assoc_Ptr
; Next
: Assoc_Ptr
) is
15877 Generic_Renamings
.Table
(E
).Next_In_HTable
:= Next
;
15878 end Set_Next_Assoc
;
15880 -------------------
15881 -- Start_Generic --
15882 -------------------
15884 procedure Start_Generic
is
15886 -- ??? More things could be factored out in this routine.
15887 -- Should probably be done at a later stage.
15889 Generic_Flags
.Append
(Inside_A_Generic
);
15890 Inside_A_Generic
:= True;
15892 Expander_Mode_Save_And_Set
(False);
15895 ----------------------
15896 -- Set_Instance_Env --
15897 ----------------------
15899 -- WARNING: This routine manages SPARK regions
15901 procedure Set_Instance_Env
15902 (Gen_Unit
: Entity_Id
;
15903 Act_Unit
: Entity_Id
)
15905 Saved_AE
: constant Boolean := Assertions_Enabled
;
15906 Saved_SM
: constant SPARK_Mode_Type
:= SPARK_Mode
;
15907 Saved_SMP
: constant Node_Id
:= SPARK_Mode_Pragma
;
15908 -- Save the SPARK mode-related data because utilizing the configuration
15909 -- values of pragmas and switches will eliminate any previously set
15913 -- Regardless of the current mode, predefined units are analyzed in the
15914 -- most current Ada mode, and earlier version Ada checks do not apply
15915 -- to predefined units. Nothing needs to be done for non-internal units.
15916 -- These are always analyzed in the current mode.
15918 if In_Internal_Unit
(Gen_Unit
) then
15919 Set_Opt_Config_Switches
(True, Current_Sem_Unit
= Main_Unit
);
15921 -- In Ada2012 we may want to enable assertions in an instance of a
15922 -- predefined unit, in which case we need to preserve the current
15923 -- setting for the Assertions_Enabled flag. This will become more
15924 -- critical when pre/postconditions are added to predefined units,
15925 -- as is already the case for some numeric libraries.
15927 if Ada_Version
>= Ada_2012
then
15928 Assertions_Enabled
:= Saved_AE
;
15931 -- Reinstall the SPARK_Mode which was in effect at the point of
15934 Install_SPARK_Mode
(Saved_SM
, Saved_SMP
);
15937 Current_Instantiated_Parent
:=
15938 (Gen_Id
=> Gen_Unit
,
15939 Act_Id
=> Act_Unit
,
15940 Next_In_HTable
=> Assoc_Null
);
15941 end Set_Instance_Env
;
15947 procedure Switch_View
(T
: Entity_Id
) is
15948 BT
: constant Entity_Id
:= Base_Type
(T
);
15949 Priv_Elmt
: Elmt_Id
:= No_Elmt
;
15950 Priv_Sub
: Entity_Id
;
15953 -- T may be private but its base type may have been exchanged through
15954 -- some other occurrence, in which case there is nothing to switch
15955 -- besides T itself. Note that a private dependent subtype of a private
15956 -- type might not have been switched even if the base type has been,
15957 -- because of the last branch of Check_Private_View (see comment there).
15959 if not Is_Private_Type
(BT
) then
15960 Prepend_Elmt
(Full_View
(T
), Exchanged_Views
);
15961 Exchange_Declarations
(T
);
15965 Priv_Elmt
:= First_Elmt
(Private_Dependents
(BT
));
15967 if Present
(Full_View
(BT
)) then
15968 Prepend_Elmt
(Full_View
(BT
), Exchanged_Views
);
15969 Exchange_Declarations
(BT
);
15972 while Present
(Priv_Elmt
) loop
15973 Priv_Sub
:= (Node
(Priv_Elmt
));
15975 -- We avoid flipping the subtype if the Etype of its full view is
15976 -- private because this would result in a malformed subtype. This
15977 -- occurs when the Etype of the subtype full view is the full view of
15978 -- the base type (and since the base types were just switched, the
15979 -- subtype is pointing to the wrong view). This is currently the case
15980 -- for tagged record types, access types (maybe more?) and needs to
15981 -- be resolved. ???
15983 if Present
(Full_View
(Priv_Sub
))
15984 and then not Is_Private_Type
(Etype
(Full_View
(Priv_Sub
)))
15986 Prepend_Elmt
(Full_View
(Priv_Sub
), Exchanged_Views
);
15987 Exchange_Declarations
(Priv_Sub
);
15990 Next_Elmt
(Priv_Elmt
);
15998 function True_Parent
(N
: Node_Id
) return Node_Id
is
16000 if Nkind
(Parent
(N
)) = N_Subunit
then
16001 return Parent
(Corresponding_Stub
(Parent
(N
)));
16007 -----------------------------
16008 -- Valid_Default_Attribute --
16009 -----------------------------
16011 procedure Valid_Default_Attribute
(Nam
: Entity_Id
; Def
: Node_Id
) is
16012 Attr_Id
: constant Attribute_Id
:=
16013 Get_Attribute_Id
(Attribute_Name
(Def
));
16014 T
: constant Entity_Id
:= Entity
(Prefix
(Def
));
16015 Is_Fun
: constant Boolean := (Ekind
(Nam
) = E_Function
);
16021 if No
(T
) or else T
= Any_Id
then
16026 F
:= First_Formal
(Nam
);
16027 while Present
(F
) loop
16028 Num_F
:= Num_F
+ 1;
16033 when Attribute_Adjacent
16034 | Attribute_Ceiling
16035 | Attribute_Copy_Sign
16037 | Attribute_Fraction
16038 | Attribute_Machine
16040 | Attribute_Remainder
16041 | Attribute_Rounding
16042 | Attribute_Unbiased_Rounding
16046 and then Is_Floating_Point_Type
(T
);
16048 when Attribute_Image
16052 | Attribute_Wide_Image
16053 | Attribute_Wide_Value
16055 OK
:= Is_Fun
and then Num_F
= 1 and then Is_Scalar_Type
(T
);
16060 OK
:= Is_Fun
and then Num_F
= 2 and then Is_Scalar_Type
(T
);
16062 when Attribute_Input
=>
16063 OK
:= (Is_Fun
and then Num_F
= 1);
16065 when Attribute_Output
16069 OK
:= not Is_Fun
and then Num_F
= 2;
16077 ("attribute reference has wrong profile for subprogram", Def
);
16079 end Valid_Default_Attribute
;