1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2017, 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 Exp_Disp
; use Exp_Disp
;
34 with Fname
; use Fname
;
35 with Fname
.UF
; use Fname
.UF
;
36 with Freeze
; use Freeze
;
37 with Ghost
; use Ghost
;
38 with Itypes
; use Itypes
;
40 with Lib
.Load
; use Lib
.Load
;
41 with Lib
.Xref
; use Lib
.Xref
;
42 with Nlists
; use Nlists
;
43 with Namet
; use Namet
;
44 with Nmake
; use Nmake
;
46 with Rident
; use Rident
;
47 with Restrict
; use Restrict
;
48 with Rtsfind
; use Rtsfind
;
50 with Sem_Aux
; use Sem_Aux
;
51 with Sem_Cat
; use Sem_Cat
;
52 with Sem_Ch3
; use Sem_Ch3
;
53 with Sem_Ch6
; use Sem_Ch6
;
54 with Sem_Ch7
; use Sem_Ch7
;
55 with Sem_Ch8
; use Sem_Ch8
;
56 with Sem_Ch10
; use Sem_Ch10
;
57 with Sem_Ch13
; use Sem_Ch13
;
58 with Sem_Dim
; use Sem_Dim
;
59 with Sem_Disp
; use Sem_Disp
;
60 with Sem_Elab
; use Sem_Elab
;
61 with Sem_Elim
; use Sem_Elim
;
62 with Sem_Eval
; use Sem_Eval
;
63 with Sem_Prag
; use Sem_Prag
;
64 with Sem_Res
; use Sem_Res
;
65 with Sem_Type
; use Sem_Type
;
66 with Sem_Util
; use Sem_Util
;
67 with Sem_Warn
; use Sem_Warn
;
68 with Stand
; use Stand
;
69 with Sinfo
; use Sinfo
;
70 with Sinfo
.CN
; use Sinfo
.CN
;
71 with Sinput
; use Sinput
;
72 with Sinput
.L
; use Sinput
.L
;
73 with Snames
; use Snames
;
74 with Stringt
; use Stringt
;
75 with Uname
; use Uname
;
77 with Tbuild
; use Tbuild
;
78 with Uintp
; use Uintp
;
79 with Urealp
; use Urealp
;
80 with Warnsw
; use Warnsw
;
84 package body Sem_Ch12
is
86 ----------------------------------------------------------
87 -- Implementation of Generic Analysis and Instantiation --
88 ----------------------------------------------------------
90 -- GNAT implements generics by macro expansion. No attempt is made to share
91 -- generic instantiations (for now). Analysis of a generic definition does
92 -- not perform any expansion action, but the expander must be called on the
93 -- tree for each instantiation, because the expansion may of course depend
94 -- on the generic actuals. All of this is best achieved as follows:
96 -- a) Semantic analysis of a generic unit is performed on a copy of the
97 -- tree for the generic unit. All tree modifications that follow analysis
98 -- do not affect the original tree. Links are kept between the original
99 -- tree and the copy, in order to recognize non-local references within
100 -- the generic, and propagate them to each instance (recall that name
101 -- resolution is done on the generic declaration: generics are not really
102 -- macros). This is summarized in the following diagram:
104 -- .-----------. .----------.
105 -- | semantic |<--------------| generic |
107 -- | |==============>| |
108 -- |___________| global |__________|
119 -- b) Each instantiation copies the original tree, and inserts into it a
120 -- series of declarations that describe the mapping between generic formals
121 -- and actuals. For example, a generic In OUT parameter is an object
122 -- renaming of the corresponding actual, etc. Generic IN parameters are
123 -- constant declarations.
125 -- c) In order to give the right visibility for these renamings, we use
126 -- a different scheme for package and subprogram instantiations. For
127 -- packages, the list of renamings is inserted into the package
128 -- specification, before the visible declarations of the package. The
129 -- renamings are analyzed before any of the text of the instance, and are
130 -- thus visible at the right place. Furthermore, outside of the instance,
131 -- the generic parameters are visible and denote their corresponding
134 -- For subprograms, we create a container package to hold the renamings
135 -- and the subprogram instance itself. Analysis of the package makes the
136 -- renaming declarations visible to the subprogram. After analyzing the
137 -- package, the defining entity for the subprogram is touched-up so that
138 -- it appears declared in the current scope, and not inside the container
141 -- If the instantiation is a compilation unit, the container package is
142 -- given the same name as the subprogram instance. This ensures that
143 -- the elaboration procedure called by the binder, using the compilation
144 -- unit name, calls in fact the elaboration procedure for the package.
146 -- Not surprisingly, private types complicate this approach. By saving in
147 -- the original generic object the non-local references, we guarantee that
148 -- the proper entities are referenced at the point of instantiation.
149 -- However, for private types, this by itself does not insure that the
150 -- proper VIEW of the entity is used (the full type may be visible at the
151 -- point of generic definition, but not at instantiation, or vice-versa).
152 -- In order to reference the proper view, we special-case any reference
153 -- to private types in the generic object, by saving both views, one in
154 -- the generic and one in the semantic copy. At time of instantiation, we
155 -- check whether the two views are consistent, and exchange declarations if
156 -- necessary, in order to restore the correct visibility. Similarly, if
157 -- the instance view is private when the generic view was not, we perform
158 -- the exchange. After completing the instantiation, we restore the
159 -- current visibility. The flag Has_Private_View marks identifiers in the
160 -- the generic unit that require checking.
162 -- Visibility within nested generic units requires special handling.
163 -- Consider the following scheme:
165 -- type Global is ... -- outside of generic unit.
169 -- type Semi_Global is ... -- global to inner.
172 -- procedure inner (X1 : Global; X2 : Semi_Global);
174 -- procedure in2 is new inner (...); -- 4
177 -- package New_Outer is new Outer (...); -- 2
178 -- procedure New_Inner is new New_Outer.Inner (...); -- 3
180 -- The semantic analysis of Outer captures all occurrences of Global.
181 -- The semantic analysis of Inner (at 1) captures both occurrences of
182 -- Global and Semi_Global.
184 -- At point 2 (instantiation of Outer), we also produce a generic copy
185 -- of Inner, even though Inner is, at that point, not being instantiated.
186 -- (This is just part of the semantic analysis of New_Outer).
188 -- Critically, references to Global within Inner must be preserved, while
189 -- references to Semi_Global should not preserved, because they must now
190 -- resolve to an entity within New_Outer. To distinguish between these, we
191 -- use a global variable, Current_Instantiated_Parent, which is set when
192 -- performing a generic copy during instantiation (at 2). This variable is
193 -- used when performing a generic copy that is not an instantiation, but
194 -- that is nested within one, as the occurrence of 1 within 2. The analysis
195 -- of a nested generic only preserves references that are global to the
196 -- enclosing Current_Instantiated_Parent. We use the Scope_Depth value to
197 -- determine whether a reference is external to the given parent.
199 -- The instantiation at point 3 requires no special treatment. The method
200 -- works as well for further nestings of generic units, but of course the
201 -- variable Current_Instantiated_Parent must be stacked because nested
202 -- instantiations can occur, e.g. the occurrence of 4 within 2.
204 -- The instantiation of package and subprogram bodies is handled in a
205 -- similar manner, except that it is delayed until after semantic
206 -- analysis is complete. In this fashion complex cross-dependencies
207 -- between several package declarations and bodies containing generics
208 -- can be compiled which otherwise would diagnose spurious circularities.
210 -- For example, it is possible to compile two packages A and B that
211 -- have the following structure:
213 -- package A is package B is
214 -- generic ... generic ...
215 -- package G_A is package G_B is
218 -- package body A is package body B is
219 -- package N_B is new G_B (..) package N_A is new G_A (..)
221 -- The table Pending_Instantiations in package Inline is used to keep
222 -- track of body instantiations that are delayed in this manner. Inline
223 -- handles the actual calls to do the body instantiations. This activity
224 -- is part of Inline, since the processing occurs at the same point, and
225 -- for essentially the same reason, as the handling of inlined routines.
227 ----------------------------------------------
228 -- Detection of Instantiation Circularities --
229 ----------------------------------------------
231 -- If we have a chain of instantiations that is circular, this is static
232 -- error which must be detected at compile time. The detection of these
233 -- circularities is carried out at the point that we insert a generic
234 -- instance spec or body. If there is a circularity, then the analysis of
235 -- the offending spec or body will eventually result in trying to load the
236 -- same unit again, and we detect this problem as we analyze the package
237 -- instantiation for the second time.
239 -- At least in some cases after we have detected the circularity, we get
240 -- into trouble if we try to keep going. The following flag is set if a
241 -- circularity is detected, and used to abandon compilation after the
242 -- messages have been posted.
244 -----------------------------------------
245 -- Implementation of Generic Contracts --
246 -----------------------------------------
248 -- A "contract" is a collection of aspects and pragmas that either verify a
249 -- property of a construct at runtime or classify the data flow to and from
250 -- the construct in some fashion.
252 -- Generic packages, subprograms and their respective bodies may be subject
253 -- to the following contract-related aspects or pragmas collectively known
256 -- package subprogram [body]
257 -- Abstract_State Contract_Cases
258 -- Initial_Condition Depends
259 -- Initializes Extensions_Visible
262 -- Refined_State Post_Class
272 -- Most package contract annotations utilize forward references to classify
273 -- data declared within the package [body]. Subprogram annotations then use
274 -- the classifications to further refine them. These inter dependencies are
275 -- problematic with respect to the implementation of generics because their
276 -- analysis, capture of global references and instantiation does not mesh
277 -- well with the existing mechanism.
279 -- 1) Analysis of generic contracts is carried out the same way non-generic
280 -- contracts are analyzed:
282 -- 1.1) General rule - a contract is analyzed after all related aspects
283 -- and pragmas are analyzed. This is done by routines
285 -- Analyze_Package_Body_Contract
286 -- Analyze_Package_Contract
287 -- Analyze_Subprogram_Body_Contract
288 -- Analyze_Subprogram_Contract
290 -- 1.2) Compilation unit - the contract is analyzed after Pragmas_After
293 -- 1.3) Compilation unit body - the contract is analyzed at the end of
294 -- the body declaration list.
296 -- 1.4) Package - the contract is analyzed at the end of the private or
297 -- visible declarations, prior to analyzing the contracts of any nested
298 -- packages or subprograms.
300 -- 1.5) Package body - the contract is analyzed at the end of the body
301 -- declaration list, prior to analyzing the contracts of any nested
302 -- packages or subprograms.
304 -- 1.6) Subprogram - if the subprogram is declared inside a block, a
305 -- package or a subprogram, then its contract is analyzed at the end of
306 -- the enclosing declarations, otherwise the subprogram is a compilation
309 -- 1.7) Subprogram body - if the subprogram body is declared inside a
310 -- block, a package body or a subprogram body, then its contract is
311 -- analyzed at the end of the enclosing declarations, otherwise the
312 -- subprogram is a compilation unit 1.3).
314 -- 2) Capture of global references within contracts is done after capturing
315 -- global references within the generic template. There are two reasons for
316 -- this delay - pragma annotations are not part of the generic template in
317 -- the case of a generic subprogram declaration, and analysis of contracts
320 -- Contract-related source pragmas within generic templates are prepared
321 -- for delayed capture of global references by routine
323 -- Create_Generic_Contract
325 -- The routine associates these pragmas with the contract of the template.
326 -- In the case of a generic subprogram declaration, the routine creates
327 -- generic templates for the pragmas declared after the subprogram because
328 -- they are not part of the template.
330 -- generic -- template starts
331 -- procedure Gen_Proc (Input : Integer); -- template ends
332 -- pragma Precondition (Input > 0); -- requires own template
334 -- 2.1) The capture of global references with aspect specifications and
335 -- source pragmas that apply to a generic unit must be suppressed when
336 -- the generic template is being processed because the contracts have not
337 -- been analyzed yet. Any attempts to capture global references at that
338 -- point will destroy the Associated_Node linkages and leave the template
339 -- undecorated. This delay is controlled by routine
341 -- Requires_Delayed_Save
343 -- 2.2) The real capture of global references within a contract is done
344 -- after the contract has been analyzed, by routine
346 -- Save_Global_References_In_Contract
348 -- 3) The instantiation of a generic contract occurs as part of the
349 -- instantiation of the contract owner. Generic subprogram declarations
350 -- require additional processing when the contract is specified by pragmas
351 -- because the pragmas are not part of the generic template. This is done
354 -- Instantiate_Subprogram_Contract
356 Circularity_Detected
: Boolean := False;
357 -- This should really be reset on encountering a new main unit, but in
358 -- practice we are not using multiple main units so it is not critical.
360 --------------------------------------------------
361 -- Formal packages and partial parameterization --
362 --------------------------------------------------
364 -- When compiling a generic, a formal package is a local instantiation. If
365 -- declared with a box, its generic formals are visible in the enclosing
366 -- generic. If declared with a partial list of actuals, those actuals that
367 -- are defaulted (covered by an Others clause, or given an explicit box
368 -- initialization) are also visible in the enclosing generic, while those
369 -- that have a corresponding actual are not.
371 -- In our source model of instantiation, the same visibility must be
372 -- present in the spec and body of an instance: the names of the formals
373 -- that are defaulted must be made visible within the instance, and made
374 -- invisible (hidden) after the instantiation is complete, so that they
375 -- are not accessible outside of the instance.
377 -- In a generic, a formal package is treated like a special instantiation.
378 -- Our Ada 95 compiler handled formals with and without box in different
379 -- ways. With partial parameterization, we use a single model for both.
380 -- We create a package declaration that consists of the specification of
381 -- the generic package, and a set of declarations that map the actuals
382 -- into local renamings, just as we do for bona fide instantiations. For
383 -- defaulted parameters and formals with a box, we copy directly the
384 -- declarations of the formal into this local package. The result is a
385 -- a package whose visible declarations may include generic formals. This
386 -- package is only used for type checking and visibility analysis, and
387 -- never reaches the back-end, so it can freely violate the placement
388 -- rules for generic formal declarations.
390 -- The list of declarations (renamings and copies of formals) is built
391 -- by Analyze_Associations, just as for regular instantiations.
393 -- At the point of instantiation, conformance checking must be applied only
394 -- to those parameters that were specified in the formal. We perform this
395 -- checking by creating another internal instantiation, this one including
396 -- only the renamings and the formals (the rest of the package spec is not
397 -- relevant to conformance checking). We can then traverse two lists: the
398 -- list of actuals in the instance that corresponds to the formal package,
399 -- and the list of actuals produced for this bogus instantiation. We apply
400 -- the conformance rules to those actuals that are not defaulted (i.e.
401 -- which still appear as generic formals.
403 -- When we compile an instance body we must make the right parameters
404 -- visible again. The predicate Is_Generic_Formal indicates which of the
405 -- formals should have its Is_Hidden flag reset.
407 -----------------------
408 -- Local subprograms --
409 -----------------------
411 procedure Abandon_Instantiation
(N
: Node_Id
);
412 pragma No_Return
(Abandon_Instantiation
);
413 -- Posts an error message "instantiation abandoned" at the indicated node
414 -- and then raises the exception Instantiation_Error to do it.
416 procedure Analyze_Formal_Array_Type
417 (T
: in out Entity_Id
;
419 -- A formal array type is treated like an array type declaration, and
420 -- invokes Array_Type_Declaration (sem_ch3) whose first parameter is
421 -- in-out, because in the case of an anonymous type the entity is
422 -- actually created in the procedure.
424 -- The following procedures treat other kinds of formal parameters
426 procedure Analyze_Formal_Derived_Interface_Type
431 procedure Analyze_Formal_Derived_Type
436 procedure Analyze_Formal_Interface_Type
441 -- The following subprograms create abbreviated declarations for formal
442 -- scalar types. We introduce an anonymous base of the proper class for
443 -- each of them, and define the formals as constrained first subtypes of
444 -- their bases. The bounds are expressions that are non-static in the
447 procedure Analyze_Formal_Decimal_Fixed_Point_Type
448 (T
: Entity_Id
; Def
: Node_Id
);
449 procedure Analyze_Formal_Discrete_Type
(T
: Entity_Id
; Def
: Node_Id
);
450 procedure Analyze_Formal_Floating_Type
(T
: Entity_Id
; Def
: Node_Id
);
451 procedure Analyze_Formal_Signed_Integer_Type
(T
: Entity_Id
; Def
: Node_Id
);
452 procedure Analyze_Formal_Modular_Type
(T
: Entity_Id
; Def
: Node_Id
);
453 procedure Analyze_Formal_Ordinary_Fixed_Point_Type
454 (T
: Entity_Id
; Def
: Node_Id
);
456 procedure Analyze_Formal_Private_Type
460 -- Creates a new private type, which does not require completion
462 procedure Analyze_Formal_Incomplete_Type
(T
: Entity_Id
; Def
: Node_Id
);
463 -- Ada 2012: Creates a new incomplete type whose actual does not freeze
465 procedure Analyze_Generic_Formal_Part
(N
: Node_Id
);
466 -- Analyze generic formal part
468 procedure Analyze_Generic_Access_Type
(T
: Entity_Id
; Def
: Node_Id
);
469 -- Create a new access type with the given designated type
471 function Analyze_Associations
474 F_Copy
: List_Id
) return List_Id
;
475 -- At instantiation time, build the list of associations between formals
476 -- and actuals. Each association becomes a renaming declaration for the
477 -- formal entity. F_Copy is the analyzed list of formals in the generic
478 -- copy. It is used to apply legality checks to the actuals. I_Node is the
479 -- instantiation node itself.
481 procedure Analyze_Subprogram_Instantiation
485 procedure Build_Instance_Compilation_Unit_Nodes
489 -- This procedure is used in the case where the generic instance of a
490 -- subprogram body or package body is a library unit. In this case, the
491 -- original library unit node for the generic instantiation must be
492 -- replaced by the resulting generic body, and a link made to a new
493 -- compilation unit node for the generic declaration. The argument N is
494 -- the original generic instantiation. Act_Body and Act_Decl are the body
495 -- and declaration of the instance (either package body and declaration
496 -- nodes or subprogram body and declaration nodes depending on the case).
497 -- On return, the node N has been rewritten with the actual body.
499 procedure Check_Access_Definition
(N
: Node_Id
);
500 -- Subsidiary routine to null exclusion processing. Perform an assertion
501 -- check on Ada version and the presence of an access definition in N.
503 procedure Check_Formal_Packages
(P_Id
: Entity_Id
);
504 -- Apply the following to all formal packages in generic associations
506 procedure Check_Formal_Package_Instance
507 (Formal_Pack
: Entity_Id
;
508 Actual_Pack
: Entity_Id
);
509 -- Verify that the actuals of the actual instance match the actuals of
510 -- the template for a formal package that is not declared with a box.
512 procedure Check_Forward_Instantiation
(Decl
: Node_Id
);
513 -- If the generic is a local entity and the corresponding body has not
514 -- been seen yet, flag enclosing packages to indicate that it will be
515 -- elaborated after the generic body. Subprograms declared in the same
516 -- package cannot be inlined by the front end because front-end inlining
517 -- requires a strict linear order of elaboration.
519 function Check_Hidden_Primitives
(Assoc_List
: List_Id
) return Elist_Id
;
520 -- Check if some association between formals and actuals requires to make
521 -- visible primitives of a tagged type, and make those primitives visible.
522 -- Return the list of primitives whose visibility is modified (to restore
523 -- their visibility later through Restore_Hidden_Primitives). If no
524 -- candidate is found then return No_Elist.
526 procedure Check_Hidden_Child_Unit
528 Gen_Unit
: Entity_Id
;
529 Act_Decl_Id
: Entity_Id
);
530 -- If the generic unit is an implicit child instance within a parent
531 -- instance, we need to make an explicit test that it is not hidden by
532 -- a child instance of the same name and parent.
534 procedure Check_Generic_Actuals
535 (Instance
: Entity_Id
;
536 Is_Formal_Box
: Boolean);
537 -- Similar to previous one. Check the actuals in the instantiation,
538 -- whose views can change between the point of instantiation and the point
539 -- of instantiation of the body. In addition, mark the generic renamings
540 -- as generic actuals, so that they are not compatible with other actuals.
541 -- Recurse on an actual that is a formal package whose declaration has
544 function Contains_Instance_Of
547 N
: Node_Id
) return Boolean;
548 -- Inner is instantiated within the generic Outer. Check whether Inner
549 -- directly or indirectly contains an instance of Outer or of one of its
550 -- parents, in the case of a subunit. Each generic unit holds a list of
551 -- the entities instantiated within (at any depth). This procedure
552 -- determines whether the set of such lists contains a cycle, i.e. an
553 -- illegal circular instantiation.
555 function Denotes_Formal_Package
557 On_Exit
: Boolean := False;
558 Instance
: Entity_Id
:= Empty
) return Boolean;
559 -- Returns True if E is a formal package of an enclosing generic, or
560 -- the actual for such a formal in an enclosing instantiation. If such
561 -- a package is used as a formal in an nested generic, or as an actual
562 -- in a nested instantiation, the visibility of ITS formals should not
563 -- be modified. When called from within Restore_Private_Views, the flag
564 -- On_Exit is true, to indicate that the search for a possible enclosing
565 -- instance should ignore the current one. In that case Instance denotes
566 -- the declaration for which this is an actual. This declaration may be
567 -- an instantiation in the source, or the internal instantiation that
568 -- corresponds to the actual for a formal package.
570 function Earlier
(N1
, N2
: Node_Id
) return Boolean;
571 -- Yields True if N1 and N2 appear in the same compilation unit,
572 -- ignoring subunits, and if N1 is to the left of N2 in a left-to-right
573 -- traversal of the tree for the unit. Used to determine the placement
574 -- of freeze nodes for instance bodies that may depend on other instances.
576 function Find_Actual_Type
578 Gen_Type
: Entity_Id
) return Entity_Id
;
579 -- When validating the actual types of a child instance, check whether
580 -- the formal is a formal type of the parent unit, and retrieve the current
581 -- actual for it. Typ is the entity in the analyzed formal type declaration
582 -- (component or index type of an array type, or designated type of an
583 -- access formal) and Gen_Type is the enclosing analyzed formal array
584 -- or access type. The desired actual may be a formal of a parent, or may
585 -- be declared in a formal package of a parent. In both cases it is a
586 -- generic actual type because it appears within a visible instance.
587 -- Finally, it may be declared in a parent unit without being a formal
588 -- of that unit, in which case it must be retrieved by visibility.
589 -- Ambiguities may still arise if two homonyms are declared in two formal
590 -- packages, and the prefix of the formal type may be needed to resolve
591 -- the ambiguity in the instance ???
593 procedure Freeze_Subprogram_Body
594 (Inst_Node
: Node_Id
;
596 Pack_Id
: Entity_Id
);
597 -- The generic body may appear textually after the instance, including
598 -- in the proper body of a stub, or within a different package instance.
599 -- Given that the instance can only be elaborated after the generic, we
600 -- place freeze_nodes for the instance and/or for packages that may enclose
601 -- the instance and the generic, so that the back-end can establish the
602 -- proper order of elaboration.
604 function Get_Associated_Node
(N
: Node_Id
) return Node_Id
;
605 -- In order to propagate semantic information back from the analyzed copy
606 -- to the original generic, we maintain links between selected nodes in the
607 -- generic and their corresponding copies. At the end of generic analysis,
608 -- the routine Save_Global_References traverses the generic tree, examines
609 -- the semantic information, and preserves the links to those nodes that
610 -- contain global information. At instantiation, the information from the
611 -- associated node is placed on the new copy, so that name resolution is
614 -- Three kinds of source nodes have associated nodes:
616 -- a) those that can reference (denote) entities, that is identifiers,
617 -- character literals, expanded_names, operator symbols, operators,
618 -- and attribute reference nodes. These nodes have an Entity field
619 -- and are the set of nodes that are in N_Has_Entity.
621 -- b) aggregates (N_Aggregate and N_Extension_Aggregate)
623 -- c) selected components (N_Selected_Component)
625 -- For the first class, the associated node preserves the entity if it is
626 -- global. If the generic contains nested instantiations, the associated
627 -- node itself has been recopied, and a chain of them must be followed.
629 -- For aggregates, the associated node allows retrieval of the type, which
630 -- may otherwise not appear in the generic. The view of this type may be
631 -- different between generic and instantiation, and the full view can be
632 -- installed before the instantiation is analyzed. For aggregates of type
633 -- extensions, the same view exchange may have to be performed for some of
634 -- the ancestor types, if their view is private at the point of
637 -- Nodes that are selected components in the parse tree may be rewritten
638 -- as expanded names after resolution, and must be treated as potential
639 -- entity holders, which is why they also have an Associated_Node.
641 -- Nodes that do not come from source, such as freeze nodes, do not appear
642 -- in the generic tree, and need not have an associated node.
644 -- The associated node is stored in the Associated_Node field. Note that
645 -- this field overlaps Entity, which is fine, because the whole point is
646 -- that we don't need or want the normal Entity field in this situation.
648 function Has_Been_Exchanged
(E
: Entity_Id
) return Boolean;
649 -- Traverse the Exchanged_Views list to see if a type was private
650 -- and has already been flipped during this phase of instantiation.
652 procedure Hide_Current_Scope
;
653 -- When instantiating a generic child unit, the parent context must be
654 -- present, but the instance and all entities that may be generated
655 -- must be inserted in the current scope. We leave the current scope
656 -- on the stack, but make its entities invisible to avoid visibility
657 -- problems. This is reversed at the end of the instantiation. This is
658 -- not done for the instantiation of the bodies, which only require the
659 -- instances of the generic parents to be in scope.
661 function In_Same_Declarative_Part
663 Inst
: Node_Id
) return Boolean;
664 -- True if the instantiation Inst and the given freeze_node F_Node appear
665 -- within the same declarative part, ignoring subunits, but with no inter-
666 -- vening subprograms or concurrent units. Used to find the proper plave
667 -- for the freeze node of an instance, when the generic is declared in a
668 -- previous instance. If predicate is true, the freeze node of the instance
669 -- can be placed after the freeze node of the previous instance, Otherwise
670 -- it has to be placed at the end of the current declarative part.
672 function In_Main_Context
(E
: Entity_Id
) return Boolean;
673 -- Check whether an instantiation is in the context of the main unit.
674 -- Used to determine whether its body should be elaborated to allow
675 -- front-end inlining.
677 procedure Inherit_Context
(Gen_Decl
: Node_Id
; Inst
: Node_Id
);
678 -- Add the context clause of the unit containing a generic unit to a
679 -- compilation unit that is, or contains, an instantiation.
682 -- Establish environment for subsequent instantiation. Separated from
683 -- Save_Env because data-structures for visibility handling must be
684 -- initialized before call to Check_Generic_Child_Unit.
686 procedure Inline_Instance_Body
688 Gen_Unit
: Entity_Id
;
690 -- If front-end inlining is requested, instantiate the package body,
691 -- and preserve the visibility of its compilation unit, to insure
692 -- that successive instantiations succeed.
694 procedure Insert_Freeze_Node_For_Instance
697 -- N denotes a package or a subprogram instantiation and F_Node is the
698 -- associated freeze node. Insert the freeze node before the first source
699 -- body which follows immediately after N. If no such body is found, the
700 -- freeze node is inserted at the end of the declarative region which
703 procedure Install_Body
708 -- If the instantiation happens textually before the body of the generic,
709 -- the instantiation of the body must be analyzed after the generic body,
710 -- and not at the point of instantiation. Such early instantiations can
711 -- happen if the generic and the instance appear in a package declaration
712 -- because the generic body can only appear in the corresponding package
713 -- body. Early instantiations can also appear if generic, instance and
714 -- body are all in the declarative part of a subprogram or entry. Entities
715 -- of packages that are early instantiations are delayed, and their freeze
716 -- node appears after the generic body. This rather complex machinery is
717 -- needed when nested instantiations are present, because the source does
718 -- not carry any indication of where the corresponding instance bodies must
719 -- be installed and frozen.
721 procedure Install_Formal_Packages
(Par
: Entity_Id
);
722 -- Install the visible part of any formal of the parent that is a formal
723 -- package. Note that for the case of a formal package with a box, this
724 -- includes the formal part of the formal package (12.7(10/2)).
726 procedure Install_Hidden_Primitives
727 (Prims_List
: in out Elist_Id
;
730 -- Remove suffix 'P' from hidden primitives of Act_T to match the
731 -- visibility of primitives of Gen_T. The list of primitives to which
732 -- the suffix is removed is added to Prims_List to restore them later.
734 procedure Install_Parent
(P
: Entity_Id
; In_Body
: Boolean := False);
735 -- When compiling an instance of a child unit the parent (which is
736 -- itself an instance) is an enclosing scope that must be made
737 -- immediately visible. This procedure is also used to install the non-
738 -- generic parent of a generic child unit when compiling its body, so
739 -- that full views of types in the parent are made visible.
741 -- The functions Instantiate_XXX perform various legality checks and build
742 -- the declarations for instantiated generic parameters. In all of these
743 -- Formal is the entity in the generic unit, Actual is the entity of
744 -- expression in the generic associations, and Analyzed_Formal is the
745 -- formal in the generic copy, which contains the semantic information to
746 -- be used to validate the actual.
748 function Instantiate_Object
751 Analyzed_Formal
: Node_Id
) return List_Id
;
753 function Instantiate_Type
756 Analyzed_Formal
: Node_Id
;
757 Actual_Decls
: List_Id
) return List_Id
;
759 function Instantiate_Formal_Subprogram
762 Analyzed_Formal
: Node_Id
) return Node_Id
;
764 function Instantiate_Formal_Package
767 Analyzed_Formal
: Node_Id
) return List_Id
;
768 -- If the formal package is declared with a box, special visibility rules
769 -- apply to its formals: they are in the visible part of the package. This
770 -- is true in the declarative region of the formal package, that is to say
771 -- in the enclosing generic or instantiation. For an instantiation, the
772 -- parameters of the formal package are made visible in an explicit step.
773 -- Furthermore, if the actual has a visible USE clause, these formals must
774 -- be made potentially use-visible as well. On exit from the enclosing
775 -- instantiation, the reverse must be done.
777 -- For a formal package declared without a box, there are conformance rules
778 -- that apply to the actuals in the generic declaration and the actuals of
779 -- the actual package in the enclosing instantiation. The simplest way to
780 -- apply these rules is to repeat the instantiation of the formal package
781 -- in the context of the enclosing instance, and compare the generic
782 -- associations of this instantiation with those of the actual package.
783 -- This internal instantiation only needs to contain the renamings of the
784 -- formals: the visible and private declarations themselves need not be
787 -- In Ada 2005, the formal package may be only partially parameterized.
788 -- In that case the visibility step must make visible those actuals whose
789 -- corresponding formals were given with a box. A final complication
790 -- involves inherited operations from formal derived types, which must
791 -- be visible if the type is.
793 function Is_In_Main_Unit
(N
: Node_Id
) return Boolean;
794 -- Test if given node is in the main unit
796 procedure Load_Parent_Of_Generic
799 Body_Optional
: Boolean := False);
800 -- If the generic appears in a separate non-generic library unit, load the
801 -- corresponding body to retrieve the body of the generic. N is the node
802 -- for the generic instantiation, Spec is the generic package declaration.
804 -- Body_Optional is a flag that indicates that the body is being loaded to
805 -- ensure that temporaries are generated consistently when there are other
806 -- instances in the current declarative part that precede the one being
807 -- loaded. In that case a missing body is acceptable.
809 procedure Map_Formal_Package_Entities
(Form
: Entity_Id
; Act
: Entity_Id
);
810 -- Within the generic part, entities in the formal package are
811 -- visible. To validate subsequent type declarations, indicate
812 -- the correspondence between the entities in the analyzed formal,
813 -- and the entities in the actual package. There are three packages
814 -- involved in the instantiation of a formal package: the parent
815 -- generic P1 which appears in the generic declaration, the fake
816 -- instantiation P2 which appears in the analyzed generic, and whose
817 -- visible entities may be used in subsequent formals, and the actual
818 -- P3 in the instance. To validate subsequent formals, me indicate
819 -- that the entities in P2 are mapped into those of P3. The mapping of
820 -- entities has to be done recursively for nested packages.
822 procedure Move_Freeze_Nodes
826 -- Freeze nodes can be generated in the analysis of a generic unit, but
827 -- will not be seen by the back-end. It is necessary to move those nodes
828 -- to the enclosing scope if they freeze an outer entity. We place them
829 -- at the end of the enclosing generic package, which is semantically
832 procedure Preanalyze_Actuals
(N
: Node_Id
; Inst
: Entity_Id
:= Empty
);
833 -- Analyze actuals to perform name resolution. Full resolution is done
834 -- later, when the expected types are known, but names have to be captured
835 -- before installing parents of generics, that are not visible for the
836 -- actuals themselves.
838 -- If Inst is present, it is the entity of the package instance. This
839 -- entity is marked as having a limited_view actual when some actual is
840 -- a limited view. This is used to place the instance body properly.
842 procedure Provide_Completing_Bodies
(N
: Node_Id
);
843 -- Generate completing bodies for all subprograms found within package or
844 -- subprogram declaration N.
846 procedure Remove_Parent
(In_Body
: Boolean := False);
847 -- Reverse effect after instantiation of child is complete
849 procedure Restore_Hidden_Primitives
(Prims_List
: in out Elist_Id
);
850 -- Restore suffix 'P' to primitives of Prims_List and leave Prims_List
853 procedure Set_Instance_Env
854 (Gen_Unit
: Entity_Id
;
855 Act_Unit
: Entity_Id
);
856 -- Save current instance on saved environment, to be used to determine
857 -- the global status of entities in nested instances. Part of Save_Env.
858 -- called after verifying that the generic unit is legal for the instance,
859 -- The procedure also examines whether the generic unit is a predefined
860 -- unit, in order to set configuration switches accordingly. As a result
861 -- the procedure must be called after analyzing and freezing the actuals.
863 procedure Set_Instance_Of
(A
: Entity_Id
; B
: Entity_Id
);
864 -- Associate analyzed generic parameter with corresponding instance. Used
865 -- for semantic checks at instantiation time.
867 function True_Parent
(N
: Node_Id
) return Node_Id
;
868 -- For a subunit, return parent of corresponding stub, else return
871 procedure Valid_Default_Attribute
(Nam
: Entity_Id
; Def
: Node_Id
);
872 -- Verify that an attribute that appears as the default for a formal
873 -- subprogram is a function or procedure with the correct profile.
875 -------------------------------------------
876 -- Data Structures for Generic Renamings --
877 -------------------------------------------
879 -- The map Generic_Renamings associates generic entities with their
880 -- corresponding actuals. Currently used to validate type instances. It
881 -- will eventually be used for all generic parameters to eliminate the
882 -- need for overload resolution in the instance.
884 type Assoc_Ptr
is new Int
;
886 Assoc_Null
: constant Assoc_Ptr
:= -1;
891 Next_In_HTable
: Assoc_Ptr
;
894 package Generic_Renamings
is new Table
.Table
895 (Table_Component_Type
=> Assoc
,
896 Table_Index_Type
=> Assoc_Ptr
,
897 Table_Low_Bound
=> 0,
899 Table_Increment
=> 100,
900 Table_Name
=> "Generic_Renamings");
902 -- Variable to hold enclosing instantiation. When the environment is
903 -- saved for a subprogram inlining, the corresponding Act_Id is empty.
905 Current_Instantiated_Parent
: Assoc
:= (Empty
, Empty
, Assoc_Null
);
907 -- Hash table for associations
909 HTable_Size
: constant := 37;
910 type HTable_Range
is range 0 .. HTable_Size
- 1;
912 procedure Set_Next_Assoc
(E
: Assoc_Ptr
; Next
: Assoc_Ptr
);
913 function Next_Assoc
(E
: Assoc_Ptr
) return Assoc_Ptr
;
914 function Get_Gen_Id
(E
: Assoc_Ptr
) return Entity_Id
;
915 function Hash
(F
: Entity_Id
) return HTable_Range
;
917 package Generic_Renamings_HTable
is new GNAT
.HTable
.Static_HTable
(
918 Header_Num
=> HTable_Range
,
920 Elmt_Ptr
=> Assoc_Ptr
,
921 Null_Ptr
=> Assoc_Null
,
922 Set_Next
=> Set_Next_Assoc
,
925 Get_Key
=> Get_Gen_Id
,
929 Exchanged_Views
: Elist_Id
;
930 -- This list holds the private views that have been exchanged during
931 -- instantiation to restore the visibility of the generic declaration.
932 -- (see comments above). After instantiation, the current visibility is
933 -- reestablished by means of a traversal of this list.
935 Hidden_Entities
: Elist_Id
;
936 -- This list holds the entities of the current scope that are removed
937 -- from immediate visibility when instantiating a child unit. Their
938 -- visibility is restored in Remove_Parent.
940 -- Because instantiations can be recursive, the following must be saved
941 -- on entry and restored on exit from an instantiation (spec or body).
942 -- This is done by the two procedures Save_Env and Restore_Env. For
943 -- package and subprogram instantiations (but not for the body instances)
944 -- the action of Save_Env is done in two steps: Init_Env is called before
945 -- Check_Generic_Child_Unit, because setting the parent instances requires
946 -- that the visibility data structures be properly initialized. Once the
947 -- generic is unit is validated, Set_Instance_Env completes Save_Env.
949 Parent_Unit_Visible
: Boolean := False;
950 -- Parent_Unit_Visible is used when the generic is a child unit, and
951 -- indicates whether the ultimate parent of the generic is visible in the
952 -- instantiation environment. It is used to reset the visibility of the
953 -- parent at the end of the instantiation (see Remove_Parent).
955 Instance_Parent_Unit
: Entity_Id
:= Empty
;
956 -- This records the ultimate parent unit of an instance of a generic
957 -- child unit and is used in conjunction with Parent_Unit_Visible to
958 -- indicate the unit to which the Parent_Unit_Visible flag corresponds.
960 type Instance_Env
is record
961 Instantiated_Parent
: Assoc
;
962 Exchanged_Views
: Elist_Id
;
963 Hidden_Entities
: Elist_Id
;
964 Current_Sem_Unit
: Unit_Number_Type
;
965 Parent_Unit_Visible
: Boolean := False;
966 Instance_Parent_Unit
: Entity_Id
:= Empty
;
967 Switches
: Config_Switches_Type
;
970 package Instance_Envs
is new Table
.Table
(
971 Table_Component_Type
=> Instance_Env
,
972 Table_Index_Type
=> Int
,
973 Table_Low_Bound
=> 0,
975 Table_Increment
=> 100,
976 Table_Name
=> "Instance_Envs");
978 procedure Restore_Private_Views
979 (Pack_Id
: Entity_Id
;
980 Is_Package
: Boolean := True);
981 -- Restore the private views of external types, and unmark the generic
982 -- renamings of actuals, so that they become compatible subtypes again.
983 -- For subprograms, Pack_Id is the package constructed to hold the
986 procedure Switch_View
(T
: Entity_Id
);
987 -- Switch the partial and full views of a type and its private
988 -- dependents (i.e. its subtypes and derived types).
990 ------------------------------------
991 -- Structures for Error Reporting --
992 ------------------------------------
994 Instantiation_Node
: Node_Id
;
995 -- Used by subprograms that validate instantiation of formal parameters
996 -- where there might be no actual on which to place the error message.
997 -- Also used to locate the instantiation node for generic subunits.
999 Instantiation_Error
: exception;
1000 -- When there is a semantic error in the generic parameter matching,
1001 -- there is no point in continuing the instantiation, because the
1002 -- number of cascaded errors is unpredictable. This exception aborts
1003 -- the instantiation process altogether.
1005 S_Adjustment
: Sloc_Adjustment
;
1006 -- Offset created for each node in an instantiation, in order to keep
1007 -- track of the source position of the instantiation in each of its nodes.
1008 -- A subsequent semantic error or warning on a construct of the instance
1009 -- points to both places: the original generic node, and the point of
1010 -- instantiation. See Sinput and Sinput.L for additional details.
1012 ------------------------------------------------------------
1013 -- Data structure for keeping track when inside a Generic --
1014 ------------------------------------------------------------
1016 -- The following table is used to save values of the Inside_A_Generic
1017 -- flag (see spec of Sem) when they are saved by Start_Generic.
1019 package Generic_Flags
is new Table
.Table
(
1020 Table_Component_Type
=> Boolean,
1021 Table_Index_Type
=> Int
,
1022 Table_Low_Bound
=> 0,
1023 Table_Initial
=> 32,
1024 Table_Increment
=> 200,
1025 Table_Name
=> "Generic_Flags");
1027 ---------------------------
1028 -- Abandon_Instantiation --
1029 ---------------------------
1031 procedure Abandon_Instantiation
(N
: Node_Id
) is
1033 Error_Msg_N
("\instantiation abandoned!", N
);
1034 raise Instantiation_Error
;
1035 end Abandon_Instantiation
;
1037 --------------------------------
1038 -- Add_Pending_Instantiation --
1039 --------------------------------
1041 procedure Add_Pending_Instantiation
(Inst
: Node_Id
; Act_Decl
: Node_Id
) is
1044 -- Add to the instantiation node and the corresponding unit declaration
1045 -- the current values of global flags to be used when analyzing the
1048 Pending_Instantiations
.Append
1049 ((Inst_Node
=> Inst
,
1050 Act_Decl
=> Act_Decl
,
1051 Expander_Status
=> Expander_Active
,
1052 Current_Sem_Unit
=> Current_Sem_Unit
,
1053 Scope_Suppress
=> Scope_Suppress
,
1054 Local_Suppress_Stack_Top
=> Local_Suppress_Stack_Top
,
1055 Version
=> Ada_Version
,
1056 Version_Pragma
=> Ada_Version_Pragma
,
1057 Warnings
=> Save_Warnings
,
1058 SPARK_Mode
=> SPARK_Mode
,
1059 SPARK_Mode_Pragma
=> SPARK_Mode_Pragma
));
1060 end Add_Pending_Instantiation
;
1062 ----------------------------------
1063 -- Adjust_Inherited_Pragma_Sloc --
1064 ----------------------------------
1066 procedure Adjust_Inherited_Pragma_Sloc
(N
: Node_Id
) is
1068 Adjust_Instantiation_Sloc
(N
, S_Adjustment
);
1069 end Adjust_Inherited_Pragma_Sloc
;
1071 --------------------------
1072 -- Analyze_Associations --
1073 --------------------------
1075 function Analyze_Associations
1078 F_Copy
: List_Id
) return List_Id
1080 Actuals_To_Freeze
: constant Elist_Id
:= New_Elmt_List
;
1081 Assoc_List
: constant List_Id
:= New_List
;
1082 Default_Actuals
: constant List_Id
:= New_List
;
1083 Gen_Unit
: constant Entity_Id
:=
1084 Defining_Entity
(Parent
(F_Copy
));
1088 Analyzed_Formal
: Node_Id
;
1089 First_Named
: Node_Id
:= Empty
;
1093 Saved_Formal
: Node_Id
;
1095 Default_Formals
: constant List_Id
:= New_List
;
1096 -- If an Others_Choice is present, some of the formals may be defaulted.
1097 -- To simplify the treatment of visibility in an instance, we introduce
1098 -- individual defaults for each such formal. These defaults are
1099 -- appended to the list of associations and replace the Others_Choice.
1101 Found_Assoc
: Node_Id
;
1102 -- Association for the current formal being match. Empty if there are
1103 -- no remaining actuals, or if there is no named association with the
1104 -- name of the formal.
1106 Is_Named_Assoc
: Boolean;
1107 Num_Matched
: Nat
:= 0;
1108 Num_Actuals
: Nat
:= 0;
1110 Others_Present
: Boolean := False;
1111 Others_Choice
: Node_Id
:= Empty
;
1112 -- In Ada 2005, indicates partial parameterization of a formal
1113 -- package. As usual an other association must be last in the list.
1115 procedure Check_Fixed_Point_Actual
(Actual
: Node_Id
);
1116 -- Warn if an actual fixed-point type has user-defined arithmetic
1117 -- operations, but there is no corresponding formal in the generic,
1118 -- in which case the predefined operations will be used. This merits
1119 -- a warning because of the special semantics of fixed point ops.
1121 procedure Check_Overloaded_Formal_Subprogram
(Formal
: Entity_Id
);
1122 -- Apply RM 12.3(9): if a formal subprogram is overloaded, the instance
1123 -- cannot have a named association for it. AI05-0025 extends this rule
1124 -- to formals of formal packages by AI05-0025, and it also applies to
1125 -- box-initialized formals.
1127 function Has_Fully_Defined_Profile
(Subp
: Entity_Id
) return Boolean;
1128 -- Determine whether the parameter types and the return type of Subp
1129 -- are fully defined at the point of instantiation.
1131 function Matching_Actual
1133 A_F
: Entity_Id
) return Node_Id
;
1134 -- Find actual that corresponds to a given a formal parameter. If the
1135 -- actuals are positional, return the next one, if any. If the actuals
1136 -- are named, scan the parameter associations to find the right one.
1137 -- A_F is the corresponding entity in the analyzed generic, which is
1138 -- placed on the selector name for ASIS use.
1140 -- In Ada 2005, a named association may be given with a box, in which
1141 -- case Matching_Actual sets Found_Assoc to the generic association,
1142 -- but return Empty for the actual itself. In this case the code below
1143 -- creates a corresponding declaration for the formal.
1145 function Partial_Parameterization
return Boolean;
1146 -- Ada 2005: if no match is found for a given formal, check if the
1147 -- association for it includes a box, or whether the associations
1148 -- include an Others clause.
1150 procedure Process_Default
(F
: Entity_Id
);
1151 -- Add a copy of the declaration of generic formal F to the list of
1152 -- associations, and add an explicit box association for F if there
1153 -- is none yet, and the default comes from an Others_Choice.
1155 function Renames_Standard_Subprogram
(Subp
: Entity_Id
) return Boolean;
1156 -- Determine whether Subp renames one of the subprograms defined in the
1157 -- generated package Standard.
1159 procedure Set_Analyzed_Formal
;
1160 -- Find the node in the generic copy that corresponds to a given formal.
1161 -- The semantic information on this node is used to perform legality
1162 -- checks on the actuals. Because semantic analysis can introduce some
1163 -- anonymous entities or modify the declaration node itself, the
1164 -- correspondence between the two lists is not one-one. In addition to
1165 -- anonymous types, the presence a formal equality will introduce an
1166 -- implicit declaration for the corresponding inequality.
1168 ----------------------------------------
1169 -- Check_Overloaded_Formal_Subprogram --
1170 ----------------------------------------
1172 procedure Check_Overloaded_Formal_Subprogram
(Formal
: Entity_Id
) is
1173 Temp_Formal
: Entity_Id
;
1176 Temp_Formal
:= First
(Formals
);
1177 while Present
(Temp_Formal
) loop
1178 if Nkind
(Temp_Formal
) in N_Formal_Subprogram_Declaration
1179 and then Temp_Formal
/= Formal
1181 Chars
(Defining_Unit_Name
(Specification
(Formal
))) =
1182 Chars
(Defining_Unit_Name
(Specification
(Temp_Formal
)))
1184 if Present
(Found_Assoc
) then
1186 ("named association not allowed for overloaded formal",
1191 ("named association not allowed for overloaded formal",
1195 Abandon_Instantiation
(Instantiation_Node
);
1200 end Check_Overloaded_Formal_Subprogram
;
1202 -------------------------------
1203 -- Check_Fixed_Point_Actual --
1204 -------------------------------
1206 procedure Check_Fixed_Point_Actual
(Actual
: Node_Id
) is
1207 Typ
: constant Entity_Id
:= Entity
(Actual
);
1208 Prims
: constant Elist_Id
:= Collect_Primitive_Operations
(Typ
);
1214 -- Locate primitive operations of the type that are arithmetic
1217 Elem
:= First_Elmt
(Prims
);
1218 while Present
(Elem
) loop
1219 if Nkind
(Node
(Elem
)) = N_Defining_Operator_Symbol
then
1221 -- Check whether the generic unit has a formal subprogram of
1222 -- the same name. This does not check types but is good enough
1223 -- to justify a warning.
1225 Formal
:= First_Non_Pragma
(Formals
);
1226 Op
:= Alias
(Node
(Elem
));
1228 while Present
(Formal
) loop
1229 if Nkind
(Formal
) = N_Formal_Concrete_Subprogram_Declaration
1230 and then Chars
(Defining_Entity
(Formal
)) =
1235 elsif Nkind
(Formal
) = N_Formal_Package_Declaration
then
1241 -- Locate corresponding actual, and check whether it
1242 -- includes a fixed-point type.
1244 Assoc
:= First
(Assoc_List
);
1245 while Present
(Assoc
) loop
1247 Nkind
(Assoc
) = N_Package_Renaming_Declaration
1248 and then Chars
(Defining_Unit_Name
(Assoc
)) =
1249 Chars
(Defining_Identifier
(Formal
));
1254 if Present
(Assoc
) then
1256 -- If formal package declares a fixed-point type,
1257 -- and the user-defined operator is derived from
1258 -- a generic instance package, the fixed-point type
1259 -- does not use the corresponding predefined op.
1261 Ent
:= First_Entity
(Entity
(Name
(Assoc
)));
1262 while Present
(Ent
) loop
1263 if Is_Fixed_Point_Type
(Ent
)
1264 and then Present
(Op
)
1265 and then Is_Generic_Instance
(Scope
(Op
))
1280 Error_Msg_Sloc
:= Sloc
(Node
(Elem
));
1282 ("?instance does not use primitive operation&#",
1283 Actual
, Node
(Elem
));
1289 end Check_Fixed_Point_Actual
;
1291 -------------------------------
1292 -- Has_Fully_Defined_Profile --
1293 -------------------------------
1295 function Has_Fully_Defined_Profile
(Subp
: Entity_Id
) return Boolean is
1296 function Is_Fully_Defined_Type
(Typ
: Entity_Id
) return Boolean;
1297 -- Determine whethet type Typ is fully defined
1299 ---------------------------
1300 -- Is_Fully_Defined_Type --
1301 ---------------------------
1303 function Is_Fully_Defined_Type
(Typ
: Entity_Id
) return Boolean is
1305 -- A private type without a full view is not fully defined
1307 if Is_Private_Type
(Typ
)
1308 and then No
(Full_View
(Typ
))
1312 -- An incomplete type is never fully defined
1314 elsif Is_Incomplete_Type
(Typ
) then
1317 -- All other types are fully defined
1322 end Is_Fully_Defined_Type
;
1324 -- Local declarations
1328 -- Start of processing for Has_Fully_Defined_Profile
1331 -- Check the parameters
1333 Param
:= First_Formal
(Subp
);
1334 while Present
(Param
) loop
1335 if not Is_Fully_Defined_Type
(Etype
(Param
)) then
1339 Next_Formal
(Param
);
1342 -- Check the return type
1344 return Is_Fully_Defined_Type
(Etype
(Subp
));
1345 end Has_Fully_Defined_Profile
;
1347 ---------------------
1348 -- Matching_Actual --
1349 ---------------------
1351 function Matching_Actual
1353 A_F
: Entity_Id
) return Node_Id
1359 Is_Named_Assoc
:= False;
1361 -- End of list of purely positional parameters
1363 if No
(Actual
) or else Nkind
(Actual
) = N_Others_Choice
then
1364 Found_Assoc
:= Empty
;
1367 -- Case of positional parameter corresponding to current formal
1369 elsif No
(Selector_Name
(Actual
)) then
1370 Found_Assoc
:= Actual
;
1371 Act
:= Explicit_Generic_Actual_Parameter
(Actual
);
1372 Num_Matched
:= Num_Matched
+ 1;
1375 -- Otherwise scan list of named actuals to find the one with the
1376 -- desired name. All remaining actuals have explicit names.
1379 Is_Named_Assoc
:= True;
1380 Found_Assoc
:= Empty
;
1384 while Present
(Actual
) loop
1385 if Nkind
(Actual
) = N_Others_Choice
then
1386 Found_Assoc
:= Empty
;
1389 elsif Chars
(Selector_Name
(Actual
)) = Chars
(F
) then
1390 Set_Entity
(Selector_Name
(Actual
), A_F
);
1391 Set_Etype
(Selector_Name
(Actual
), Etype
(A_F
));
1392 Generate_Reference
(A_F
, Selector_Name
(Actual
));
1394 Found_Assoc
:= Actual
;
1395 Act
:= Explicit_Generic_Actual_Parameter
(Actual
);
1396 Num_Matched
:= Num_Matched
+ 1;
1404 -- Reset for subsequent searches. In most cases the named
1405 -- associations are in order. If they are not, we reorder them
1406 -- to avoid scanning twice the same actual. This is not just a
1407 -- question of efficiency: there may be multiple defaults with
1408 -- boxes that have the same name. In a nested instantiation we
1409 -- insert actuals for those defaults, and cannot rely on their
1410 -- names to disambiguate them.
1412 if Actual
= First_Named
then
1415 elsif Present
(Actual
) then
1416 Insert_Before
(First_Named
, Remove_Next
(Prev
));
1419 Actual
:= First_Named
;
1422 if Is_Entity_Name
(Act
) and then Present
(Entity
(Act
)) then
1423 Set_Used_As_Generic_Actual
(Entity
(Act
));
1427 end Matching_Actual
;
1429 ------------------------------
1430 -- Partial_Parameterization --
1431 ------------------------------
1433 function Partial_Parameterization
return Boolean is
1435 return Others_Present
1436 or else (Present
(Found_Assoc
) and then Box_Present
(Found_Assoc
));
1437 end Partial_Parameterization
;
1439 ---------------------
1440 -- Process_Default --
1441 ---------------------
1443 procedure Process_Default
(F
: Entity_Id
) is
1444 Loc
: constant Source_Ptr
:= Sloc
(I_Node
);
1445 F_Id
: constant Entity_Id
:= Defining_Entity
(F
);
1451 -- Append copy of formal declaration to associations, and create new
1452 -- defining identifier for it.
1454 Decl
:= New_Copy_Tree
(F
);
1455 Id
:= Make_Defining_Identifier
(Sloc
(F_Id
), Chars
(F_Id
));
1457 if Nkind
(F
) in N_Formal_Subprogram_Declaration
then
1458 Set_Defining_Unit_Name
(Specification
(Decl
), Id
);
1461 Set_Defining_Identifier
(Decl
, Id
);
1464 Append
(Decl
, Assoc_List
);
1466 if No
(Found_Assoc
) then
1468 Make_Generic_Association
(Loc
,
1470 New_Occurrence_Of
(Id
, Loc
),
1471 Explicit_Generic_Actual_Parameter
=> Empty
);
1472 Set_Box_Present
(Default
);
1473 Append
(Default
, Default_Formals
);
1475 end Process_Default
;
1477 ---------------------------------
1478 -- Renames_Standard_Subprogram --
1479 ---------------------------------
1481 function Renames_Standard_Subprogram
(Subp
: Entity_Id
) return Boolean is
1486 while Present
(Id
) loop
1487 if Scope
(Id
) = Standard_Standard
then
1495 end Renames_Standard_Subprogram
;
1497 -------------------------
1498 -- Set_Analyzed_Formal --
1499 -------------------------
1501 procedure Set_Analyzed_Formal
is
1505 while Present
(Analyzed_Formal
) loop
1506 Kind
:= Nkind
(Analyzed_Formal
);
1508 case Nkind
(Formal
) is
1509 when N_Formal_Subprogram_Declaration
=>
1510 exit when Kind
in N_Formal_Subprogram_Declaration
1513 (Defining_Unit_Name
(Specification
(Formal
))) =
1515 (Defining_Unit_Name
(Specification
(Analyzed_Formal
)));
1517 when N_Formal_Package_Declaration
=>
1518 exit when Nkind_In
(Kind
, N_Formal_Package_Declaration
,
1519 N_Generic_Package_Declaration
,
1520 N_Package_Declaration
);
1522 when N_Use_Package_Clause
1529 -- Skip freeze nodes, and nodes inserted to replace
1530 -- unrecognized pragmas.
1533 Kind
not in N_Formal_Subprogram_Declaration
1534 and then not Nkind_In
(Kind
, N_Subprogram_Declaration
,
1538 and then Chars
(Defining_Identifier
(Formal
)) =
1539 Chars
(Defining_Identifier
(Analyzed_Formal
));
1542 Next
(Analyzed_Formal
);
1544 end Set_Analyzed_Formal
;
1546 -- Start of processing for Analyze_Associations
1549 Actuals
:= Generic_Associations
(I_Node
);
1551 if Present
(Actuals
) then
1553 -- Check for an Others choice, indicating a partial parameterization
1554 -- for a formal package.
1556 Actual
:= First
(Actuals
);
1557 while Present
(Actual
) loop
1558 if Nkind
(Actual
) = N_Others_Choice
then
1559 Others_Present
:= True;
1560 Others_Choice
:= Actual
;
1562 if Present
(Next
(Actual
)) then
1563 Error_Msg_N
("others must be last association", Actual
);
1566 -- This subprogram is used both for formal packages and for
1567 -- instantiations. For the latter, associations must all be
1570 if Nkind
(I_Node
) /= N_Formal_Package_Declaration
1571 and then Comes_From_Source
(I_Node
)
1574 ("others association not allowed in an instance",
1578 -- In any case, nothing to do after the others association
1582 elsif Box_Present
(Actual
)
1583 and then Comes_From_Source
(I_Node
)
1584 and then Nkind
(I_Node
) /= N_Formal_Package_Declaration
1587 ("box association not allowed in an instance", Actual
);
1593 -- If named associations are present, save first named association
1594 -- (it may of course be Empty) to facilitate subsequent name search.
1596 First_Named
:= First
(Actuals
);
1597 while Present
(First_Named
)
1598 and then Nkind
(First_Named
) /= N_Others_Choice
1599 and then No
(Selector_Name
(First_Named
))
1601 Num_Actuals
:= Num_Actuals
+ 1;
1606 Named
:= First_Named
;
1607 while Present
(Named
) loop
1608 if Nkind
(Named
) /= N_Others_Choice
1609 and then No
(Selector_Name
(Named
))
1611 Error_Msg_N
("invalid positional actual after named one", Named
);
1612 Abandon_Instantiation
(Named
);
1615 -- A named association may lack an actual parameter, if it was
1616 -- introduced for a default subprogram that turns out to be local
1617 -- to the outer instantiation. If it has a box association it must
1618 -- correspond to some formal in the generic.
1620 if Nkind
(Named
) /= N_Others_Choice
1621 and then (Present
(Explicit_Generic_Actual_Parameter
(Named
))
1622 or else Box_Present
(Named
))
1624 Num_Actuals
:= Num_Actuals
+ 1;
1630 if Present
(Formals
) then
1631 Formal
:= First_Non_Pragma
(Formals
);
1632 Analyzed_Formal
:= First_Non_Pragma
(F_Copy
);
1634 if Present
(Actuals
) then
1635 Actual
:= First
(Actuals
);
1637 -- All formals should have default values
1643 while Present
(Formal
) loop
1644 Set_Analyzed_Formal
;
1645 Saved_Formal
:= Next_Non_Pragma
(Formal
);
1647 case Nkind
(Formal
) is
1648 when N_Formal_Object_Declaration
=>
1651 (Defining_Identifier
(Formal
),
1652 Defining_Identifier
(Analyzed_Formal
));
1654 if No
(Match
) and then Partial_Parameterization
then
1655 Process_Default
(Formal
);
1659 (Instantiate_Object
(Formal
, Match
, Analyzed_Formal
),
1662 -- For a defaulted in_parameter, create an entry in the
1663 -- the list of defaulted actuals, for GNATProve use. Do
1664 -- not included these defaults for an instance nested
1665 -- within a generic, because the defaults are also used
1666 -- in the analysis of the enclosing generic, and only
1667 -- defaulted subprograms are relevant there.
1669 if No
(Match
) and then not Inside_A_Generic
then
1670 Append_To
(Default_Actuals
,
1671 Make_Generic_Association
(Sloc
(I_Node
),
1674 (Defining_Identifier
(Formal
), Sloc
(I_Node
)),
1675 Explicit_Generic_Actual_Parameter
=>
1676 New_Copy_Tree
(Default_Expression
(Formal
))));
1680 -- If the object is a call to an expression function, this
1681 -- is a freezing point for it.
1683 if Is_Entity_Name
(Match
)
1684 and then Present
(Entity
(Match
))
1686 (Original_Node
(Unit_Declaration_Node
(Entity
(Match
))))
1687 = N_Expression_Function
1689 Append_Elmt
(Entity
(Match
), Actuals_To_Freeze
);
1692 when N_Formal_Type_Declaration
=>
1695 (Defining_Identifier
(Formal
),
1696 Defining_Identifier
(Analyzed_Formal
));
1699 if Partial_Parameterization
then
1700 Process_Default
(Formal
);
1703 Error_Msg_Sloc
:= Sloc
(Gen_Unit
);
1706 Instantiation_Node
, Defining_Identifier
(Formal
));
1708 ("\in instantiation of & declared#",
1709 Instantiation_Node
, Gen_Unit
);
1710 Abandon_Instantiation
(Instantiation_Node
);
1717 (Formal
, Match
, Analyzed_Formal
, Assoc_List
),
1720 if Is_Fixed_Point_Type
(Entity
(Match
)) then
1721 Check_Fixed_Point_Actual
(Match
);
1724 -- An instantiation is a freeze point for the actuals,
1725 -- unless this is a rewritten formal package, or the
1726 -- formal is an Ada 2012 formal incomplete type.
1728 if Nkind
(I_Node
) = N_Formal_Package_Declaration
1730 (Ada_Version
>= Ada_2012
1732 Ekind
(Defining_Identifier
(Analyzed_Formal
)) =
1738 Append_Elmt
(Entity
(Match
), Actuals_To_Freeze
);
1742 -- A remote access-to-class-wide type is not a legal actual
1743 -- for a generic formal of an access type (E.2.2(17/2)).
1744 -- In GNAT an exception to this rule is introduced when
1745 -- the formal is marked as remote using implementation
1746 -- defined aspect/pragma Remote_Access_Type. In that case
1747 -- the actual must be remote as well.
1749 -- If the current instantiation is the construction of a
1750 -- local copy for a formal package the actuals may be
1751 -- defaulted, and there is no matching actual to check.
1753 if Nkind
(Analyzed_Formal
) = N_Formal_Type_Declaration
1755 Nkind
(Formal_Type_Definition
(Analyzed_Formal
)) =
1756 N_Access_To_Object_Definition
1757 and then Present
(Match
)
1760 Formal_Ent
: constant Entity_Id
:=
1761 Defining_Identifier
(Analyzed_Formal
);
1763 if Is_Remote_Access_To_Class_Wide_Type
(Entity
(Match
))
1764 = Is_Remote_Types
(Formal_Ent
)
1766 -- Remoteness of formal and actual match
1770 elsif Is_Remote_Types
(Formal_Ent
) then
1772 -- Remote formal, non-remote actual
1775 ("actual for& must be remote", Match
, Formal_Ent
);
1778 -- Non-remote formal, remote actual
1781 ("actual for& may not be remote",
1787 when N_Formal_Subprogram_Declaration
=>
1790 (Defining_Unit_Name
(Specification
(Formal
)),
1791 Defining_Unit_Name
(Specification
(Analyzed_Formal
)));
1793 -- If the formal subprogram has the same name as another
1794 -- formal subprogram of the generic, then a named
1795 -- association is illegal (12.3(9)). Exclude named
1796 -- associations that are generated for a nested instance.
1799 and then Is_Named_Assoc
1800 and then Comes_From_Source
(Found_Assoc
)
1802 Check_Overloaded_Formal_Subprogram
(Formal
);
1805 -- If there is no corresponding actual, this may be case
1806 -- of partial parameterization, or else the formal has a
1807 -- default or a box.
1809 if No
(Match
) and then Partial_Parameterization
then
1810 Process_Default
(Formal
);
1812 if Nkind
(I_Node
) = N_Formal_Package_Declaration
then
1813 Check_Overloaded_Formal_Subprogram
(Formal
);
1817 Append_To
(Assoc_List
,
1818 Instantiate_Formal_Subprogram
1819 (Formal
, Match
, Analyzed_Formal
));
1821 -- An instantiation is a freeze point for the actuals,
1822 -- unless this is a rewritten formal package.
1824 if Nkind
(I_Node
) /= N_Formal_Package_Declaration
1825 and then Nkind
(Match
) = N_Identifier
1826 and then Is_Subprogram
(Entity
(Match
))
1828 -- The actual subprogram may rename a routine defined
1829 -- in Standard. Avoid freezing such renamings because
1830 -- subprograms coming from Standard cannot be frozen.
1833 not Renames_Standard_Subprogram
(Entity
(Match
))
1835 -- If the actual subprogram comes from a different
1836 -- unit, it is already frozen, either by a body in
1837 -- that unit or by the end of the declarative part
1838 -- of the unit. This check avoids the freezing of
1839 -- subprograms defined in Standard which are used
1840 -- as generic actuals.
1842 and then In_Same_Code_Unit
(Entity
(Match
), I_Node
)
1843 and then Has_Fully_Defined_Profile
(Entity
(Match
))
1845 -- Mark the subprogram as having a delayed freeze
1846 -- since this may be an out-of-order action.
1848 Set_Has_Delayed_Freeze
(Entity
(Match
));
1849 Append_Elmt
(Entity
(Match
), Actuals_To_Freeze
);
1853 -- If this is a nested generic, preserve default for later
1854 -- instantiations. We do this as well for GNATProve use,
1855 -- so that the list of generic associations is complete.
1857 if No
(Match
) and then Box_Present
(Formal
) then
1859 Subp
: constant Entity_Id
:=
1861 (Specification
(Last
(Assoc_List
)));
1864 Append_To
(Default_Actuals
,
1865 Make_Generic_Association
(Sloc
(I_Node
),
1867 New_Occurrence_Of
(Subp
, Sloc
(I_Node
)),
1868 Explicit_Generic_Actual_Parameter
=>
1869 New_Occurrence_Of
(Subp
, Sloc
(I_Node
))));
1873 when N_Formal_Package_Declaration
=>
1876 (Defining_Identifier
(Formal
),
1877 Defining_Identifier
(Original_Node
(Analyzed_Formal
)));
1880 if Partial_Parameterization
then
1881 Process_Default
(Formal
);
1884 Error_Msg_Sloc
:= Sloc
(Gen_Unit
);
1887 Instantiation_Node
, Defining_Identifier
(Formal
));
1889 ("\in instantiation of & declared#",
1890 Instantiation_Node
, Gen_Unit
);
1892 Abandon_Instantiation
(Instantiation_Node
);
1898 (Instantiate_Formal_Package
1899 (Formal
, Match
, Analyzed_Formal
),
1902 -- Determine whether the actual package needs an explicit
1903 -- freeze node. This is only the case if the actual is
1904 -- declared in the same unit and has a body. Normally
1905 -- packages do not have explicit freeze nodes, and gigi
1906 -- only uses them to elaborate entities in a package
1909 Explicit_Freeze_Check
: declare
1910 Actual
: constant Entity_Id
:= Entity
(Match
);
1911 Gen_Par
: Entity_Id
;
1913 Needs_Freezing
: Boolean;
1916 procedure Check_Generic_Parent
;
1917 -- The actual may be an instantiation of a unit
1918 -- declared in a previous instantiation. If that
1919 -- one is also in the current compilation, it must
1920 -- itself be frozen before the actual. The actual
1921 -- may be an instantiation of a generic child unit,
1922 -- in which case the same applies to the instance
1923 -- of the parent which must be frozen before the
1925 -- Should this itself be recursive ???
1927 --------------------------
1928 -- Check_Generic_Parent --
1929 --------------------------
1931 procedure Check_Generic_Parent
is
1932 Inst
: constant Node_Id
:=
1933 Next
(Unit_Declaration_Node
(Actual
));
1939 if Nkind
(Parent
(Actual
)) = N_Package_Specification
1941 Par
:= Scope
(Generic_Parent
(Parent
(Actual
)));
1943 if Is_Generic_Instance
(Par
) then
1946 -- If the actual is a child generic unit, check
1947 -- whether the instantiation of the parent is
1948 -- also local and must also be frozen now. We
1949 -- must retrieve the instance node to locate the
1950 -- parent instance if any.
1952 elsif Ekind
(Par
) = E_Generic_Package
1953 and then Is_Child_Unit
(Gen_Par
)
1954 and then Ekind
(Scope
(Gen_Par
)) =
1957 if Nkind
(Inst
) = N_Package_Instantiation
1958 and then Nkind
(Name
(Inst
)) =
1961 -- Retrieve entity of parent instance
1963 Par
:= Entity
(Prefix
(Name
(Inst
)));
1972 and then Is_Generic_Instance
(Par
)
1973 and then Scope
(Par
) = Current_Scope
1975 (No
(Freeze_Node
(Par
))
1977 not Is_List_Member
(Freeze_Node
(Par
)))
1979 Set_Has_Delayed_Freeze
(Par
);
1980 Append_Elmt
(Par
, Actuals_To_Freeze
);
1982 end Check_Generic_Parent
;
1984 -- Start of processing for Explicit_Freeze_Check
1987 if Present
(Renamed_Entity
(Actual
)) then
1989 Generic_Parent
(Specification
1990 (Unit_Declaration_Node
1991 (Renamed_Entity
(Actual
))));
1994 Generic_Parent
(Specification
1995 (Unit_Declaration_Node
(Actual
)));
1998 if not Expander_Active
1999 or else not Has_Completion
(Actual
)
2000 or else not In_Same_Source_Unit
(I_Node
, Actual
)
2001 or else Is_Frozen
(Actual
)
2003 (Present
(Renamed_Entity
(Actual
))
2005 not In_Same_Source_Unit
2006 (I_Node
, (Renamed_Entity
(Actual
))))
2011 -- Finally we want to exclude such freeze nodes
2012 -- from statement sequences, which freeze
2013 -- everything before them.
2014 -- Is this strictly necessary ???
2016 Needs_Freezing
:= True;
2019 while Present
(S
) loop
2020 if Ekind_In
(S
, E_Block
,
2025 Needs_Freezing
:= False;
2032 if Needs_Freezing
then
2033 Check_Generic_Parent
;
2035 -- If the actual is a renaming of a proper
2036 -- instance of the formal package, indicate
2037 -- that it is the instance that must be frozen.
2039 if Nkind
(Parent
(Actual
)) =
2040 N_Package_Renaming_Declaration
2042 Set_Has_Delayed_Freeze
2043 (Renamed_Entity
(Actual
));
2045 (Renamed_Entity
(Actual
),
2048 Set_Has_Delayed_Freeze
(Actual
);
2049 Append_Elmt
(Actual
, Actuals_To_Freeze
);
2053 end Explicit_Freeze_Check
;
2056 -- For use type and use package appearing in the generic part,
2057 -- we have already copied them, so we can just move them where
2058 -- they belong (we mustn't recopy them since this would mess up
2059 -- the Sloc values).
2061 when N_Use_Package_Clause
2064 if Nkind
(Original_Node
(I_Node
)) =
2065 N_Formal_Package_Declaration
2067 Append
(New_Copy_Tree
(Formal
), Assoc_List
);
2070 Append
(Formal
, Assoc_List
);
2074 raise Program_Error
;
2077 Formal
:= Saved_Formal
;
2078 Next_Non_Pragma
(Analyzed_Formal
);
2081 if Num_Actuals
> Num_Matched
then
2082 Error_Msg_Sloc
:= Sloc
(Gen_Unit
);
2084 if Present
(Selector_Name
(Actual
)) then
2086 ("unmatched actual &", Actual
, Selector_Name
(Actual
));
2088 ("\in instantiation of & declared#", Actual
, Gen_Unit
);
2091 ("unmatched actual in instantiation of & declared#",
2096 elsif Present
(Actuals
) then
2098 ("too many actuals in generic instantiation", Instantiation_Node
);
2101 -- An instantiation freezes all generic actuals. The only exceptions
2102 -- to this are incomplete types and subprograms which are not fully
2103 -- defined at the point of instantiation.
2106 Elmt
: Elmt_Id
:= First_Elmt
(Actuals_To_Freeze
);
2108 while Present
(Elmt
) loop
2109 Freeze_Before
(I_Node
, Node
(Elmt
));
2114 -- If there are default subprograms, normalize the tree by adding
2115 -- explicit associations for them. This is required if the instance
2116 -- appears within a generic.
2118 if not Is_Empty_List
(Default_Actuals
) then
2123 Default
:= First
(Default_Actuals
);
2124 while Present
(Default
) loop
2125 Mark_Rewrite_Insertion
(Default
);
2129 if No
(Actuals
) then
2130 Set_Generic_Associations
(I_Node
, Default_Actuals
);
2132 Append_List_To
(Actuals
, Default_Actuals
);
2137 -- If this is a formal package, normalize the parameter list by adding
2138 -- explicit box associations for the formals that are covered by an
2141 if not Is_Empty_List
(Default_Formals
) then
2142 Append_List
(Default_Formals
, Formals
);
2146 end Analyze_Associations
;
2148 -------------------------------
2149 -- Analyze_Formal_Array_Type --
2150 -------------------------------
2152 procedure Analyze_Formal_Array_Type
2153 (T
: in out Entity_Id
;
2159 -- Treated like a non-generic array declaration, with additional
2164 if Nkind
(Def
) = N_Constrained_Array_Definition
then
2165 DSS
:= First
(Discrete_Subtype_Definitions
(Def
));
2166 while Present
(DSS
) loop
2167 if Nkind_In
(DSS
, N_Subtype_Indication
,
2169 N_Attribute_Reference
)
2171 Error_Msg_N
("only a subtype mark is allowed in a formal", DSS
);
2178 Array_Type_Declaration
(T
, Def
);
2179 Set_Is_Generic_Type
(Base_Type
(T
));
2181 if Ekind
(Component_Type
(T
)) = E_Incomplete_Type
2182 and then No
(Full_View
(Component_Type
(T
)))
2184 Error_Msg_N
("premature usage of incomplete type", Def
);
2186 -- Check that range constraint is not allowed on the component type
2187 -- of a generic formal array type (AARM 12.5.3(3))
2189 elsif Is_Internal
(Component_Type
(T
))
2190 and then Present
(Subtype_Indication
(Component_Definition
(Def
)))
2191 and then Nkind
(Original_Node
2192 (Subtype_Indication
(Component_Definition
(Def
)))) =
2193 N_Subtype_Indication
2196 ("in a formal, a subtype indication can only be "
2197 & "a subtype mark (RM 12.5.3(3))",
2198 Subtype_Indication
(Component_Definition
(Def
)));
2201 end Analyze_Formal_Array_Type
;
2203 ---------------------------------------------
2204 -- Analyze_Formal_Decimal_Fixed_Point_Type --
2205 ---------------------------------------------
2207 -- As for other generic types, we create a valid type representation with
2208 -- legal but arbitrary attributes, whose values are never considered
2209 -- static. For all scalar types we introduce an anonymous base type, with
2210 -- the same attributes. We choose the corresponding integer type to be
2211 -- Standard_Integer.
2212 -- Here and in other similar routines, the Sloc of the generated internal
2213 -- type must be the same as the sloc of the defining identifier of the
2214 -- formal type declaration, to provide proper source navigation.
2216 procedure Analyze_Formal_Decimal_Fixed_Point_Type
2220 Loc
: constant Source_Ptr
:= Sloc
(Def
);
2222 Base
: constant Entity_Id
:=
2224 (E_Decimal_Fixed_Point_Type
,
2226 Sloc
(Defining_Identifier
(Parent
(Def
))), 'G');
2228 Int_Base
: constant Entity_Id
:= Standard_Integer
;
2229 Delta_Val
: constant Ureal
:= Ureal_1
;
2230 Digs_Val
: constant Uint
:= Uint_6
;
2232 function Make_Dummy_Bound
return Node_Id
;
2233 -- Return a properly typed universal real literal to use as a bound
2235 ----------------------
2236 -- Make_Dummy_Bound --
2237 ----------------------
2239 function Make_Dummy_Bound
return Node_Id
is
2240 Bound
: constant Node_Id
:= Make_Real_Literal
(Loc
, Ureal_1
);
2242 Set_Etype
(Bound
, Universal_Real
);
2244 end Make_Dummy_Bound
;
2246 -- Start of processing for Analyze_Formal_Decimal_Fixed_Point_Type
2251 Set_Etype
(Base
, Base
);
2252 Set_Size_Info
(Base
, Int_Base
);
2253 Set_RM_Size
(Base
, RM_Size
(Int_Base
));
2254 Set_First_Rep_Item
(Base
, First_Rep_Item
(Int_Base
));
2255 Set_Digits_Value
(Base
, Digs_Val
);
2256 Set_Delta_Value
(Base
, Delta_Val
);
2257 Set_Small_Value
(Base
, Delta_Val
);
2258 Set_Scalar_Range
(Base
,
2260 Low_Bound
=> Make_Dummy_Bound
,
2261 High_Bound
=> Make_Dummy_Bound
));
2263 Set_Is_Generic_Type
(Base
);
2264 Set_Parent
(Base
, Parent
(Def
));
2266 Set_Ekind
(T
, E_Decimal_Fixed_Point_Subtype
);
2267 Set_Etype
(T
, Base
);
2268 Set_Size_Info
(T
, Int_Base
);
2269 Set_RM_Size
(T
, RM_Size
(Int_Base
));
2270 Set_First_Rep_Item
(T
, First_Rep_Item
(Int_Base
));
2271 Set_Digits_Value
(T
, Digs_Val
);
2272 Set_Delta_Value
(T
, Delta_Val
);
2273 Set_Small_Value
(T
, Delta_Val
);
2274 Set_Scalar_Range
(T
, Scalar_Range
(Base
));
2275 Set_Is_Constrained
(T
);
2277 Check_Restriction
(No_Fixed_Point
, Def
);
2278 end Analyze_Formal_Decimal_Fixed_Point_Type
;
2280 -------------------------------------------
2281 -- Analyze_Formal_Derived_Interface_Type --
2282 -------------------------------------------
2284 procedure Analyze_Formal_Derived_Interface_Type
2289 Loc
: constant Source_Ptr
:= Sloc
(Def
);
2292 -- Rewrite as a type declaration of a derived type. This ensures that
2293 -- the interface list and primitive operations are properly captured.
2296 Make_Full_Type_Declaration
(Loc
,
2297 Defining_Identifier
=> T
,
2298 Type_Definition
=> Def
));
2300 Set_Is_Generic_Type
(T
);
2301 end Analyze_Formal_Derived_Interface_Type
;
2303 ---------------------------------
2304 -- Analyze_Formal_Derived_Type --
2305 ---------------------------------
2307 procedure Analyze_Formal_Derived_Type
2312 Loc
: constant Source_Ptr
:= Sloc
(Def
);
2313 Unk_Disc
: constant Boolean := Unknown_Discriminants_Present
(N
);
2317 Set_Is_Generic_Type
(T
);
2319 if Private_Present
(Def
) then
2321 Make_Private_Extension_Declaration
(Loc
,
2322 Defining_Identifier
=> T
,
2323 Discriminant_Specifications
=> Discriminant_Specifications
(N
),
2324 Unknown_Discriminants_Present
=> Unk_Disc
,
2325 Subtype_Indication
=> Subtype_Mark
(Def
),
2326 Interface_List
=> Interface_List
(Def
));
2328 Set_Abstract_Present
(New_N
, Abstract_Present
(Def
));
2329 Set_Limited_Present
(New_N
, Limited_Present
(Def
));
2330 Set_Synchronized_Present
(New_N
, Synchronized_Present
(Def
));
2334 Make_Full_Type_Declaration
(Loc
,
2335 Defining_Identifier
=> T
,
2336 Discriminant_Specifications
=>
2337 Discriminant_Specifications
(Parent
(T
)),
2339 Make_Derived_Type_Definition
(Loc
,
2340 Subtype_Indication
=> Subtype_Mark
(Def
)));
2342 Set_Abstract_Present
2343 (Type_Definition
(New_N
), Abstract_Present
(Def
));
2345 (Type_Definition
(New_N
), Limited_Present
(Def
));
2352 if not Is_Composite_Type
(T
) then
2354 ("unknown discriminants not allowed for elementary types", N
);
2356 Set_Has_Unknown_Discriminants
(T
);
2357 Set_Is_Constrained
(T
, False);
2361 -- If the parent type has a known size, so does the formal, which makes
2362 -- legal representation clauses that involve the formal.
2364 Set_Size_Known_At_Compile_Time
2365 (T
, Size_Known_At_Compile_Time
(Entity
(Subtype_Mark
(Def
))));
2366 end Analyze_Formal_Derived_Type
;
2368 ----------------------------------
2369 -- Analyze_Formal_Discrete_Type --
2370 ----------------------------------
2372 -- The operations defined for a discrete types are those of an enumeration
2373 -- type. The size is set to an arbitrary value, for use in analyzing the
2376 procedure Analyze_Formal_Discrete_Type
(T
: Entity_Id
; Def
: Node_Id
) is
2377 Loc
: constant Source_Ptr
:= Sloc
(Def
);
2381 Base
: constant Entity_Id
:=
2383 (E_Floating_Point_Type
, Current_Scope
,
2384 Sloc
(Defining_Identifier
(Parent
(Def
))), 'G');
2388 Set_Ekind
(T
, E_Enumeration_Subtype
);
2389 Set_Etype
(T
, Base
);
2392 Set_Is_Generic_Type
(T
);
2393 Set_Is_Constrained
(T
);
2395 -- For semantic analysis, the bounds of the type must be set to some
2396 -- non-static value. The simplest is to create attribute nodes for those
2397 -- bounds, that refer to the type itself. These bounds are never
2398 -- analyzed but serve as place-holders.
2401 Make_Attribute_Reference
(Loc
,
2402 Attribute_Name
=> Name_First
,
2403 Prefix
=> New_Occurrence_Of
(T
, Loc
));
2407 Make_Attribute_Reference
(Loc
,
2408 Attribute_Name
=> Name_Last
,
2409 Prefix
=> New_Occurrence_Of
(T
, Loc
));
2412 Set_Scalar_Range
(T
,
2417 Set_Ekind
(Base
, E_Enumeration_Type
);
2418 Set_Etype
(Base
, Base
);
2419 Init_Size
(Base
, 8);
2420 Init_Alignment
(Base
);
2421 Set_Is_Generic_Type
(Base
);
2422 Set_Scalar_Range
(Base
, Scalar_Range
(T
));
2423 Set_Parent
(Base
, Parent
(Def
));
2424 end Analyze_Formal_Discrete_Type
;
2426 ----------------------------------
2427 -- Analyze_Formal_Floating_Type --
2428 ---------------------------------
2430 procedure Analyze_Formal_Floating_Type
(T
: Entity_Id
; Def
: Node_Id
) is
2431 Base
: constant Entity_Id
:=
2433 (E_Floating_Point_Type
, Current_Scope
,
2434 Sloc
(Defining_Identifier
(Parent
(Def
))), 'G');
2437 -- The various semantic attributes are taken from the predefined type
2438 -- Float, just so that all of them are initialized. Their values are
2439 -- never used because no constant folding or expansion takes place in
2440 -- the generic itself.
2443 Set_Ekind
(T
, E_Floating_Point_Subtype
);
2444 Set_Etype
(T
, Base
);
2445 Set_Size_Info
(T
, (Standard_Float
));
2446 Set_RM_Size
(T
, RM_Size
(Standard_Float
));
2447 Set_Digits_Value
(T
, Digits_Value
(Standard_Float
));
2448 Set_Scalar_Range
(T
, Scalar_Range
(Standard_Float
));
2449 Set_Is_Constrained
(T
);
2451 Set_Is_Generic_Type
(Base
);
2452 Set_Etype
(Base
, Base
);
2453 Set_Size_Info
(Base
, (Standard_Float
));
2454 Set_RM_Size
(Base
, RM_Size
(Standard_Float
));
2455 Set_Digits_Value
(Base
, Digits_Value
(Standard_Float
));
2456 Set_Scalar_Range
(Base
, Scalar_Range
(Standard_Float
));
2457 Set_Parent
(Base
, Parent
(Def
));
2459 Check_Restriction
(No_Floating_Point
, Def
);
2460 end Analyze_Formal_Floating_Type
;
2462 -----------------------------------
2463 -- Analyze_Formal_Interface_Type;--
2464 -----------------------------------
2466 procedure Analyze_Formal_Interface_Type
2471 Loc
: constant Source_Ptr
:= Sloc
(N
);
2476 Make_Full_Type_Declaration
(Loc
,
2477 Defining_Identifier
=> T
,
2478 Type_Definition
=> Def
);
2482 Set_Is_Generic_Type
(T
);
2483 end Analyze_Formal_Interface_Type
;
2485 ---------------------------------
2486 -- Analyze_Formal_Modular_Type --
2487 ---------------------------------
2489 procedure Analyze_Formal_Modular_Type
(T
: Entity_Id
; Def
: Node_Id
) is
2491 -- Apart from their entity kind, generic modular types are treated like
2492 -- signed integer types, and have the same attributes.
2494 Analyze_Formal_Signed_Integer_Type
(T
, Def
);
2495 Set_Ekind
(T
, E_Modular_Integer_Subtype
);
2496 Set_Ekind
(Etype
(T
), E_Modular_Integer_Type
);
2498 end Analyze_Formal_Modular_Type
;
2500 ---------------------------------------
2501 -- Analyze_Formal_Object_Declaration --
2502 ---------------------------------------
2504 procedure Analyze_Formal_Object_Declaration
(N
: Node_Id
) is
2505 E
: constant Node_Id
:= Default_Expression
(N
);
2506 Id
: constant Node_Id
:= Defining_Identifier
(N
);
2513 -- Determine the mode of the formal object
2515 if Out_Present
(N
) then
2516 K
:= E_Generic_In_Out_Parameter
;
2518 if not In_Present
(N
) then
2519 Error_Msg_N
("formal generic objects cannot have mode OUT", N
);
2523 K
:= E_Generic_In_Parameter
;
2526 if Present
(Subtype_Mark
(N
)) then
2527 Find_Type
(Subtype_Mark
(N
));
2528 T
:= Entity
(Subtype_Mark
(N
));
2530 -- Verify that there is no redundant null exclusion
2532 if Null_Exclusion_Present
(N
) then
2533 if not Is_Access_Type
(T
) then
2535 ("null exclusion can only apply to an access type", N
);
2537 elsif Can_Never_Be_Null
(T
) then
2539 ("`NOT NULL` not allowed (& already excludes null)", N
, T
);
2543 -- Ada 2005 (AI-423): Formal object with an access definition
2546 Check_Access_Definition
(N
);
2547 T
:= Access_Definition
2549 N
=> Access_Definition
(N
));
2552 if Ekind
(T
) = E_Incomplete_Type
then
2554 Error_Node
: Node_Id
;
2557 if Present
(Subtype_Mark
(N
)) then
2558 Error_Node
:= Subtype_Mark
(N
);
2560 Check_Access_Definition
(N
);
2561 Error_Node
:= Access_Definition
(N
);
2564 Error_Msg_N
("premature usage of incomplete type", Error_Node
);
2568 if K
= E_Generic_In_Parameter
then
2570 -- Ada 2005 (AI-287): Limited aggregates allowed in generic formals
2572 if Ada_Version
< Ada_2005
and then Is_Limited_Type
(T
) then
2574 ("generic formal of mode IN must not be of limited type", N
);
2575 Explain_Limited_Type
(T
, N
);
2578 if Is_Abstract_Type
(T
) then
2580 ("generic formal of mode IN must not be of abstract type", N
);
2584 Preanalyze_Spec_Expression
(E
, T
);
2586 if Is_Limited_Type
(T
) and then not OK_For_Limited_Init
(T
, E
) then
2588 ("initialization not allowed for limited types", E
);
2589 Explain_Limited_Type
(T
, E
);
2596 -- Case of generic IN OUT parameter
2599 -- If the formal has an unconstrained type, construct its actual
2600 -- subtype, as is done for subprogram formals. In this fashion, all
2601 -- its uses can refer to specific bounds.
2606 if (Is_Array_Type
(T
) and then not Is_Constrained
(T
))
2607 or else (Ekind
(T
) = E_Record_Type
and then Has_Discriminants
(T
))
2610 Non_Freezing_Ref
: constant Node_Id
:=
2611 New_Occurrence_Of
(Id
, Sloc
(Id
));
2615 -- Make sure the actual subtype doesn't generate bogus freezing
2617 Set_Must_Not_Freeze
(Non_Freezing_Ref
);
2618 Decl
:= Build_Actual_Subtype
(T
, Non_Freezing_Ref
);
2619 Insert_Before_And_Analyze
(N
, Decl
);
2620 Set_Actual_Subtype
(Id
, Defining_Identifier
(Decl
));
2623 Set_Actual_Subtype
(Id
, T
);
2628 ("initialization not allowed for `IN OUT` formals", N
);
2632 if Has_Aspects
(N
) then
2633 Analyze_Aspect_Specifications
(N
, Id
);
2635 end Analyze_Formal_Object_Declaration
;
2637 ----------------------------------------------
2638 -- Analyze_Formal_Ordinary_Fixed_Point_Type --
2639 ----------------------------------------------
2641 procedure Analyze_Formal_Ordinary_Fixed_Point_Type
2645 Loc
: constant Source_Ptr
:= Sloc
(Def
);
2646 Base
: constant Entity_Id
:=
2648 (E_Ordinary_Fixed_Point_Type
, Current_Scope
,
2649 Sloc
(Defining_Identifier
(Parent
(Def
))), 'G');
2652 -- The semantic attributes are set for completeness only, their values
2653 -- will never be used, since all properties of the type are non-static.
2656 Set_Ekind
(T
, E_Ordinary_Fixed_Point_Subtype
);
2657 Set_Etype
(T
, Base
);
2658 Set_Size_Info
(T
, Standard_Integer
);
2659 Set_RM_Size
(T
, RM_Size
(Standard_Integer
));
2660 Set_Small_Value
(T
, Ureal_1
);
2661 Set_Delta_Value
(T
, Ureal_1
);
2662 Set_Scalar_Range
(T
,
2664 Low_Bound
=> Make_Real_Literal
(Loc
, Ureal_1
),
2665 High_Bound
=> Make_Real_Literal
(Loc
, Ureal_1
)));
2666 Set_Is_Constrained
(T
);
2668 Set_Is_Generic_Type
(Base
);
2669 Set_Etype
(Base
, Base
);
2670 Set_Size_Info
(Base
, Standard_Integer
);
2671 Set_RM_Size
(Base
, RM_Size
(Standard_Integer
));
2672 Set_Small_Value
(Base
, Ureal_1
);
2673 Set_Delta_Value
(Base
, Ureal_1
);
2674 Set_Scalar_Range
(Base
, Scalar_Range
(T
));
2675 Set_Parent
(Base
, Parent
(Def
));
2677 Check_Restriction
(No_Fixed_Point
, Def
);
2678 end Analyze_Formal_Ordinary_Fixed_Point_Type
;
2680 ----------------------------------------
2681 -- Analyze_Formal_Package_Declaration --
2682 ----------------------------------------
2684 procedure Analyze_Formal_Package_Declaration
(N
: Node_Id
) is
2685 Gen_Id
: constant Node_Id
:= Name
(N
);
2686 Loc
: constant Source_Ptr
:= Sloc
(N
);
2687 Pack_Id
: constant Entity_Id
:= Defining_Identifier
(N
);
2690 Gen_Unit
: Entity_Id
;
2693 Vis_Prims_List
: Elist_Id
:= No_Elist
;
2694 -- List of primitives made temporarily visible in the instantiation
2695 -- to match the visibility of the formal type.
2697 function Build_Local_Package
return Node_Id
;
2698 -- The formal package is rewritten so that its parameters are replaced
2699 -- with corresponding declarations. For parameters with bona fide
2700 -- associations these declarations are created by Analyze_Associations
2701 -- as for a regular instantiation. For boxed parameters, we preserve
2702 -- the formal declarations and analyze them, in order to introduce
2703 -- entities of the right kind in the environment of the formal.
2705 -------------------------
2706 -- Build_Local_Package --
2707 -------------------------
2709 function Build_Local_Package
return Node_Id
is
2711 Pack_Decl
: Node_Id
;
2714 -- Within the formal, the name of the generic package is a renaming
2715 -- of the formal (as for a regular instantiation).
2718 Make_Package_Declaration
(Loc
,
2721 (Specification
(Original_Node
(Gen_Decl
)),
2722 Empty
, Instantiating
=> True));
2725 Make_Package_Renaming_Declaration
(Loc
,
2726 Defining_Unit_Name
=>
2727 Make_Defining_Identifier
(Loc
, Chars
(Gen_Unit
)),
2728 Name
=> New_Occurrence_Of
(Formal
, Loc
));
2730 if Nkind
(Gen_Id
) = N_Identifier
2731 and then Chars
(Gen_Id
) = Chars
(Pack_Id
)
2734 ("& is hidden within declaration of instance", Gen_Id
, Gen_Unit
);
2737 -- If the formal is declared with a box, or with an others choice,
2738 -- create corresponding declarations for all entities in the formal
2739 -- part, so that names with the proper types are available in the
2740 -- specification of the formal package.
2742 -- On the other hand, if there are no associations, then all the
2743 -- formals must have defaults, and this will be checked by the
2744 -- call to Analyze_Associations.
2747 or else Nkind
(First
(Generic_Associations
(N
))) = N_Others_Choice
2750 Formal_Decl
: Node_Id
;
2753 -- TBA : for a formal package, need to recurse ???
2758 (Generic_Formal_Declarations
(Original_Node
(Gen_Decl
)));
2759 while Present
(Formal_Decl
) loop
2763 (Formal_Decl
, Empty
, Instantiating
=> True));
2768 -- If generic associations are present, use Analyze_Associations to
2769 -- create the proper renaming declarations.
2773 Act_Tree
: constant Node_Id
:=
2775 (Original_Node
(Gen_Decl
), Empty
,
2776 Instantiating
=> True);
2779 Generic_Renamings
.Set_Last
(0);
2780 Generic_Renamings_HTable
.Reset
;
2781 Instantiation_Node
:= N
;
2784 Analyze_Associations
2785 (I_Node
=> Original_Node
(N
),
2786 Formals
=> Generic_Formal_Declarations
(Act_Tree
),
2787 F_Copy
=> Generic_Formal_Declarations
(Gen_Decl
));
2789 Vis_Prims_List
:= Check_Hidden_Primitives
(Decls
);
2793 Append
(Renaming
, To
=> Decls
);
2795 -- Add generated declarations ahead of local declarations in
2798 if No
(Visible_Declarations
(Specification
(Pack_Decl
))) then
2799 Set_Visible_Declarations
(Specification
(Pack_Decl
), Decls
);
2802 (First
(Visible_Declarations
(Specification
(Pack_Decl
))),
2807 end Build_Local_Package
;
2811 Save_ISMP
: constant Boolean := Ignore_SPARK_Mode_Pragmas_In_Instance
;
2812 -- Save flag Ignore_SPARK_Mode_Pragmas_In_Instance for restore on exit
2814 Associations
: Boolean := True;
2816 Parent_Installed
: Boolean := False;
2817 Parent_Instance
: Entity_Id
;
2818 Renaming_In_Par
: Entity_Id
;
2820 -- Start of processing for Analyze_Formal_Package_Declaration
2823 Check_Text_IO_Special_Unit
(Gen_Id
);
2826 Check_Generic_Child_Unit
(Gen_Id
, Parent_Installed
);
2827 Gen_Unit
:= Entity
(Gen_Id
);
2829 -- Check for a formal package that is a package renaming
2831 if Present
(Renamed_Object
(Gen_Unit
)) then
2833 -- Indicate that unit is used, before replacing it with renamed
2834 -- entity for use below.
2836 if In_Extended_Main_Source_Unit
(N
) then
2837 Set_Is_Instantiated
(Gen_Unit
);
2838 Generate_Reference
(Gen_Unit
, N
);
2841 Gen_Unit
:= Renamed_Object
(Gen_Unit
);
2844 if Ekind
(Gen_Unit
) /= E_Generic_Package
then
2845 Error_Msg_N
("expect generic package name", Gen_Id
);
2849 elsif Gen_Unit
= Current_Scope
then
2851 ("generic package cannot be used as a formal package of itself",
2856 elsif In_Open_Scopes
(Gen_Unit
) then
2857 if Is_Compilation_Unit
(Gen_Unit
)
2858 and then Is_Child_Unit
(Current_Scope
)
2860 -- Special-case the error when the formal is a parent, and
2861 -- continue analysis to minimize cascaded errors.
2864 ("generic parent cannot be used as formal package of a child "
2869 ("generic package cannot be used as a formal package within "
2870 & "itself", Gen_Id
);
2876 -- Check that name of formal package does not hide name of generic,
2877 -- or its leading prefix. This check must be done separately because
2878 -- the name of the generic has already been analyzed.
2881 Gen_Name
: Entity_Id
;
2885 while Nkind
(Gen_Name
) = N_Expanded_Name
loop
2886 Gen_Name
:= Prefix
(Gen_Name
);
2889 if Chars
(Gen_Name
) = Chars
(Pack_Id
) then
2891 ("& is hidden within declaration of formal package",
2897 or else No
(Generic_Associations
(N
))
2898 or else Nkind
(First
(Generic_Associations
(N
))) = N_Others_Choice
2900 Associations
:= False;
2903 -- If there are no generic associations, the generic parameters appear
2904 -- as local entities and are instantiated like them. We copy the generic
2905 -- package declaration as if it were an instantiation, and analyze it
2906 -- like a regular package, except that we treat the formals as
2907 -- additional visible components.
2909 Gen_Decl
:= Unit_Declaration_Node
(Gen_Unit
);
2911 if In_Extended_Main_Source_Unit
(N
) then
2912 Set_Is_Instantiated
(Gen_Unit
);
2913 Generate_Reference
(Gen_Unit
, N
);
2916 Formal
:= New_Copy
(Pack_Id
);
2917 Create_Instantiation_Source
(N
, Gen_Unit
, S_Adjustment
);
2919 -- Make local generic without formals. The formals will be replaced with
2920 -- internal declarations.
2923 New_N
:= Build_Local_Package
;
2925 -- If there are errors in the parameter list, Analyze_Associations
2926 -- raises Instantiation_Error. Patch the declaration to prevent further
2927 -- exception propagation.
2930 when Instantiation_Error
=>
2931 Enter_Name
(Formal
);
2932 Set_Ekind
(Formal
, E_Variable
);
2933 Set_Etype
(Formal
, Any_Type
);
2934 Restore_Hidden_Primitives
(Vis_Prims_List
);
2936 if Parent_Installed
then
2944 Set_Defining_Unit_Name
(Specification
(New_N
), Formal
);
2945 Set_Generic_Parent
(Specification
(N
), Gen_Unit
);
2946 Set_Instance_Env
(Gen_Unit
, Formal
);
2947 Set_Is_Generic_Instance
(Formal
);
2949 Enter_Name
(Formal
);
2950 Set_Ekind
(Formal
, E_Package
);
2951 Set_Etype
(Formal
, Standard_Void_Type
);
2952 Set_Inner_Instances
(Formal
, New_Elmt_List
);
2953 Push_Scope
(Formal
);
2955 -- Manually set the SPARK_Mode from the context because the package
2956 -- declaration is never analyzed.
2958 Set_SPARK_Pragma
(Formal
, SPARK_Mode_Pragma
);
2959 Set_SPARK_Aux_Pragma
(Formal
, SPARK_Mode_Pragma
);
2960 Set_SPARK_Pragma_Inherited
(Formal
);
2961 Set_SPARK_Aux_Pragma_Inherited
(Formal
);
2963 if Is_Child_Unit
(Gen_Unit
) and then Parent_Installed
then
2965 -- Similarly, we have to make the name of the formal visible in the
2966 -- parent instance, to resolve properly fully qualified names that
2967 -- may appear in the generic unit. The parent instance has been
2968 -- placed on the scope stack ahead of the current scope.
2970 Parent_Instance
:= Scope_Stack
.Table
(Scope_Stack
.Last
- 1).Entity
;
2973 Make_Defining_Identifier
(Loc
, Chars
(Gen_Unit
));
2974 Set_Ekind
(Renaming_In_Par
, E_Package
);
2975 Set_Etype
(Renaming_In_Par
, Standard_Void_Type
);
2976 Set_Scope
(Renaming_In_Par
, Parent_Instance
);
2977 Set_Parent
(Renaming_In_Par
, Parent
(Formal
));
2978 Set_Renamed_Object
(Renaming_In_Par
, Formal
);
2979 Append_Entity
(Renaming_In_Par
, Parent_Instance
);
2982 -- A formal package declaration behaves as a package instantiation with
2983 -- respect to SPARK_Mode "off". If the annotation is "off" or altogether
2984 -- missing, set the global flag which signals Analyze_Pragma to ingnore
2985 -- all SPARK_Mode pragmas within the generic_package_name.
2987 if SPARK_Mode
/= On
then
2988 Ignore_SPARK_Mode_Pragmas_In_Instance
:= True;
2990 -- Mark the formal spec in case the body is instantiated at a later
2991 -- pass. This preserves the original context in effect for the body.
2993 Set_Ignore_SPARK_Mode_Pragmas
(Formal
);
2996 Analyze
(Specification
(N
));
2998 -- The formals for which associations are provided are not visible
2999 -- outside of the formal package. The others are still declared by a
3000 -- formal parameter declaration.
3002 -- If there are no associations, the only local entity to hide is the
3003 -- generated package renaming itself.
3009 E
:= First_Entity
(Formal
);
3010 while Present
(E
) loop
3011 if Associations
and then not Is_Generic_Formal
(E
) then
3015 if Ekind
(E
) = E_Package
and then Renamed_Entity
(E
) = Formal
then
3024 End_Package_Scope
(Formal
);
3025 Restore_Hidden_Primitives
(Vis_Prims_List
);
3027 if Parent_Installed
then
3033 -- Inside the generic unit, the formal package is a regular package, but
3034 -- no body is needed for it. Note that after instantiation, the defining
3035 -- unit name we need is in the new tree and not in the original (see
3036 -- Package_Instantiation). A generic formal package is an instance, and
3037 -- can be used as an actual for an inner instance.
3039 Set_Has_Completion
(Formal
, True);
3041 -- Add semantic information to the original defining identifier for ASIS
3044 Set_Ekind
(Pack_Id
, E_Package
);
3045 Set_Etype
(Pack_Id
, Standard_Void_Type
);
3046 Set_Scope
(Pack_Id
, Scope
(Formal
));
3047 Set_Has_Completion
(Pack_Id
, True);
3050 if Has_Aspects
(N
) then
3051 Analyze_Aspect_Specifications
(N
, Pack_Id
);
3054 Ignore_SPARK_Mode_Pragmas_In_Instance
:= Save_ISMP
;
3055 end Analyze_Formal_Package_Declaration
;
3057 ---------------------------------
3058 -- Analyze_Formal_Private_Type --
3059 ---------------------------------
3061 procedure Analyze_Formal_Private_Type
3067 New_Private_Type
(N
, T
, Def
);
3069 -- Set the size to an arbitrary but legal value
3071 Set_Size_Info
(T
, Standard_Integer
);
3072 Set_RM_Size
(T
, RM_Size
(Standard_Integer
));
3073 end Analyze_Formal_Private_Type
;
3075 ------------------------------------
3076 -- Analyze_Formal_Incomplete_Type --
3077 ------------------------------------
3079 procedure Analyze_Formal_Incomplete_Type
3085 Set_Ekind
(T
, E_Incomplete_Type
);
3087 Set_Private_Dependents
(T
, New_Elmt_List
);
3089 if Tagged_Present
(Def
) then
3090 Set_Is_Tagged_Type
(T
);
3091 Make_Class_Wide_Type
(T
);
3092 Set_Direct_Primitive_Operations
(T
, New_Elmt_List
);
3094 end Analyze_Formal_Incomplete_Type
;
3096 ----------------------------------------
3097 -- Analyze_Formal_Signed_Integer_Type --
3098 ----------------------------------------
3100 procedure Analyze_Formal_Signed_Integer_Type
3104 Base
: constant Entity_Id
:=
3106 (E_Signed_Integer_Type
,
3108 Sloc
(Defining_Identifier
(Parent
(Def
))), 'G');
3113 Set_Ekind
(T
, E_Signed_Integer_Subtype
);
3114 Set_Etype
(T
, Base
);
3115 Set_Size_Info
(T
, Standard_Integer
);
3116 Set_RM_Size
(T
, RM_Size
(Standard_Integer
));
3117 Set_Scalar_Range
(T
, Scalar_Range
(Standard_Integer
));
3118 Set_Is_Constrained
(T
);
3120 Set_Is_Generic_Type
(Base
);
3121 Set_Size_Info
(Base
, Standard_Integer
);
3122 Set_RM_Size
(Base
, RM_Size
(Standard_Integer
));
3123 Set_Etype
(Base
, Base
);
3124 Set_Scalar_Range
(Base
, Scalar_Range
(Standard_Integer
));
3125 Set_Parent
(Base
, Parent
(Def
));
3126 end Analyze_Formal_Signed_Integer_Type
;
3128 -------------------------------------------
3129 -- Analyze_Formal_Subprogram_Declaration --
3130 -------------------------------------------
3132 procedure Analyze_Formal_Subprogram_Declaration
(N
: Node_Id
) is
3133 Spec
: constant Node_Id
:= Specification
(N
);
3134 Def
: constant Node_Id
:= Default_Name
(N
);
3135 Nam
: constant Entity_Id
:= Defining_Unit_Name
(Spec
);
3143 if Nkind
(Nam
) = N_Defining_Program_Unit_Name
then
3144 Error_Msg_N
("name of formal subprogram must be a direct name", Nam
);
3148 Analyze_Subprogram_Declaration
(N
);
3149 Set_Is_Formal_Subprogram
(Nam
);
3150 Set_Has_Completion
(Nam
);
3152 if Nkind
(N
) = N_Formal_Abstract_Subprogram_Declaration
then
3153 Set_Is_Abstract_Subprogram
(Nam
);
3155 Set_Is_Dispatching_Operation
(Nam
);
3157 -- A formal abstract procedure cannot have a null default
3158 -- (RM 12.6(4.1/2)).
3160 if Nkind
(Spec
) = N_Procedure_Specification
3161 and then Null_Present
(Spec
)
3164 ("a formal abstract subprogram cannot default to null", Spec
);
3168 Ctrl_Type
: constant Entity_Id
:= Find_Dispatching_Type
(Nam
);
3170 if No
(Ctrl_Type
) then
3172 ("abstract formal subprogram must have a controlling type",
3175 elsif Ada_Version
>= Ada_2012
3176 and then Is_Incomplete_Type
(Ctrl_Type
)
3179 ("controlling type of abstract formal subprogram cannot "
3180 & "be incomplete type", N
, Ctrl_Type
);
3183 Check_Controlling_Formals
(Ctrl_Type
, Nam
);
3188 -- Default name is resolved at the point of instantiation
3190 if Box_Present
(N
) then
3193 -- Else default is bound at the point of generic declaration
3195 elsif Present
(Def
) then
3196 if Nkind
(Def
) = N_Operator_Symbol
then
3197 Find_Direct_Name
(Def
);
3199 elsif Nkind
(Def
) /= N_Attribute_Reference
then
3203 -- For an attribute reference, analyze the prefix and verify
3204 -- that it has the proper profile for the subprogram.
3206 Analyze
(Prefix
(Def
));
3207 Valid_Default_Attribute
(Nam
, Def
);
3211 -- Default name may be overloaded, in which case the interpretation
3212 -- with the correct profile must be selected, as for a renaming.
3213 -- If the definition is an indexed component, it must denote a
3214 -- member of an entry family. If it is a selected component, it
3215 -- can be a protected operation.
3217 if Etype
(Def
) = Any_Type
then
3220 elsif Nkind
(Def
) = N_Selected_Component
then
3221 if not Is_Overloadable
(Entity
(Selector_Name
(Def
))) then
3222 Error_Msg_N
("expect valid subprogram name as default", Def
);
3225 elsif Nkind
(Def
) = N_Indexed_Component
then
3226 if Is_Entity_Name
(Prefix
(Def
)) then
3227 if Ekind
(Entity
(Prefix
(Def
))) /= E_Entry_Family
then
3228 Error_Msg_N
("expect valid subprogram name as default", Def
);
3231 elsif Nkind
(Prefix
(Def
)) = N_Selected_Component
then
3232 if Ekind
(Entity
(Selector_Name
(Prefix
(Def
)))) /=
3235 Error_Msg_N
("expect valid subprogram name as default", Def
);
3239 Error_Msg_N
("expect valid subprogram name as default", Def
);
3243 elsif Nkind
(Def
) = N_Character_Literal
then
3245 -- Needs some type checks: subprogram should be parameterless???
3247 Resolve
(Def
, (Etype
(Nam
)));
3249 elsif not Is_Entity_Name
(Def
)
3250 or else not Is_Overloadable
(Entity
(Def
))
3252 Error_Msg_N
("expect valid subprogram name as default", Def
);
3255 elsif not Is_Overloaded
(Def
) then
3256 Subp
:= Entity
(Def
);
3259 Error_Msg_N
("premature usage of formal subprogram", Def
);
3261 elsif not Entity_Matches_Spec
(Subp
, Nam
) then
3262 Error_Msg_N
("no visible entity matches specification", Def
);
3265 -- More than one interpretation, so disambiguate as for a renaming
3270 I1
: Interp_Index
:= 0;
3276 Get_First_Interp
(Def
, I
, It
);
3277 while Present
(It
.Nam
) loop
3278 if Entity_Matches_Spec
(It
.Nam
, Nam
) then
3279 if Subp
/= Any_Id
then
3280 It1
:= Disambiguate
(Def
, I1
, I
, Etype
(Subp
));
3282 if It1
= No_Interp
then
3283 Error_Msg_N
("ambiguous default subprogram", Def
);
3296 Get_Next_Interp
(I
, It
);
3300 if Subp
/= Any_Id
then
3302 -- Subprogram found, generate reference to it
3304 Set_Entity
(Def
, Subp
);
3305 Generate_Reference
(Subp
, Def
);
3308 Error_Msg_N
("premature usage of formal subprogram", Def
);
3310 elsif Ekind
(Subp
) /= E_Operator
then
3311 Check_Mode_Conformant
(Subp
, Nam
);
3315 Error_Msg_N
("no visible subprogram matches specification", N
);
3321 if Has_Aspects
(N
) then
3322 Analyze_Aspect_Specifications
(N
, Nam
);
3325 end Analyze_Formal_Subprogram_Declaration
;
3327 -------------------------------------
3328 -- Analyze_Formal_Type_Declaration --
3329 -------------------------------------
3331 procedure Analyze_Formal_Type_Declaration
(N
: Node_Id
) is
3332 Def
: constant Node_Id
:= Formal_Type_Definition
(N
);
3336 T
:= Defining_Identifier
(N
);
3338 if Present
(Discriminant_Specifications
(N
))
3339 and then Nkind
(Def
) /= N_Formal_Private_Type_Definition
3342 ("discriminants not allowed for this formal type", T
);
3345 -- Enter the new name, and branch to specific routine
3348 when N_Formal_Private_Type_Definition
=>
3349 Analyze_Formal_Private_Type
(N
, T
, Def
);
3351 when N_Formal_Derived_Type_Definition
=>
3352 Analyze_Formal_Derived_Type
(N
, T
, Def
);
3354 when N_Formal_Incomplete_Type_Definition
=>
3355 Analyze_Formal_Incomplete_Type
(T
, Def
);
3357 when N_Formal_Discrete_Type_Definition
=>
3358 Analyze_Formal_Discrete_Type
(T
, Def
);
3360 when N_Formal_Signed_Integer_Type_Definition
=>
3361 Analyze_Formal_Signed_Integer_Type
(T
, Def
);
3363 when N_Formal_Modular_Type_Definition
=>
3364 Analyze_Formal_Modular_Type
(T
, Def
);
3366 when N_Formal_Floating_Point_Definition
=>
3367 Analyze_Formal_Floating_Type
(T
, Def
);
3369 when N_Formal_Ordinary_Fixed_Point_Definition
=>
3370 Analyze_Formal_Ordinary_Fixed_Point_Type
(T
, Def
);
3372 when N_Formal_Decimal_Fixed_Point_Definition
=>
3373 Analyze_Formal_Decimal_Fixed_Point_Type
(T
, Def
);
3375 when N_Array_Type_Definition
=>
3376 Analyze_Formal_Array_Type
(T
, Def
);
3378 when N_Access_Function_Definition
3379 | N_Access_Procedure_Definition
3380 | N_Access_To_Object_Definition
3382 Analyze_Generic_Access_Type
(T
, Def
);
3384 -- Ada 2005: a interface declaration is encoded as an abstract
3385 -- record declaration or a abstract type derivation.
3387 when N_Record_Definition
=>
3388 Analyze_Formal_Interface_Type
(N
, T
, Def
);
3390 when N_Derived_Type_Definition
=>
3391 Analyze_Formal_Derived_Interface_Type
(N
, T
, Def
);
3397 raise Program_Error
;
3400 Set_Is_Generic_Type
(T
);
3402 if Has_Aspects
(N
) then
3403 Analyze_Aspect_Specifications
(N
, T
);
3405 end Analyze_Formal_Type_Declaration
;
3407 ------------------------------------
3408 -- Analyze_Function_Instantiation --
3409 ------------------------------------
3411 procedure Analyze_Function_Instantiation
(N
: Node_Id
) is
3413 Analyze_Subprogram_Instantiation
(N
, E_Function
);
3414 end Analyze_Function_Instantiation
;
3416 ---------------------------------
3417 -- Analyze_Generic_Access_Type --
3418 ---------------------------------
3420 procedure Analyze_Generic_Access_Type
(T
: Entity_Id
; Def
: Node_Id
) is
3424 if Nkind
(Def
) = N_Access_To_Object_Definition
then
3425 Access_Type_Declaration
(T
, Def
);
3427 if Is_Incomplete_Or_Private_Type
(Designated_Type
(T
))
3428 and then No
(Full_View
(Designated_Type
(T
)))
3429 and then not Is_Generic_Type
(Designated_Type
(T
))
3431 Error_Msg_N
("premature usage of incomplete type", Def
);
3433 elsif not Is_Entity_Name
(Subtype_Indication
(Def
)) then
3435 ("only a subtype mark is allowed in a formal", Def
);
3439 Access_Subprogram_Declaration
(T
, Def
);
3441 end Analyze_Generic_Access_Type
;
3443 ---------------------------------
3444 -- Analyze_Generic_Formal_Part --
3445 ---------------------------------
3447 procedure Analyze_Generic_Formal_Part
(N
: Node_Id
) is
3448 Gen_Parm_Decl
: Node_Id
;
3451 -- The generic formals are processed in the scope of the generic unit,
3452 -- where they are immediately visible. The scope is installed by the
3455 Gen_Parm_Decl
:= First
(Generic_Formal_Declarations
(N
));
3456 while Present
(Gen_Parm_Decl
) loop
3457 Analyze
(Gen_Parm_Decl
);
3458 Next
(Gen_Parm_Decl
);
3461 Generate_Reference_To_Generic_Formals
(Current_Scope
);
3462 end Analyze_Generic_Formal_Part
;
3464 ------------------------------------------
3465 -- Analyze_Generic_Package_Declaration --
3466 ------------------------------------------
3468 procedure Analyze_Generic_Package_Declaration
(N
: Node_Id
) is
3469 Decls
: constant List_Id
:= Visible_Declarations
(Specification
(N
));
3470 Loc
: constant Source_Ptr
:= Sloc
(N
);
3476 Save_Parent
: Node_Id
;
3479 Check_SPARK_05_Restriction
("generic is not allowed", N
);
3481 -- We introduce a renaming of the enclosing package, to have a usable
3482 -- entity as the prefix of an expanded name for a local entity of the
3483 -- form Par.P.Q, where P is the generic package. This is because a local
3484 -- entity named P may hide it, so that the usual visibility rules in
3485 -- the instance will not resolve properly.
3488 Make_Package_Renaming_Declaration
(Loc
,
3489 Defining_Unit_Name
=>
3490 Make_Defining_Identifier
(Loc
,
3491 Chars
=> New_External_Name
(Chars
(Defining_Entity
(N
)), "GH")),
3493 Make_Identifier
(Loc
, Chars
(Defining_Entity
(N
))));
3495 -- The declaration is inserted before other declarations, but before
3496 -- pragmas that may be library-unit pragmas and must appear before other
3497 -- declarations. The pragma Compile_Time_Error is not in this class, and
3498 -- may contain an expression that includes such a qualified name, so the
3499 -- renaming declaration must appear before it.
3501 -- Are there other pragmas that require this special handling ???
3503 if Present
(Decls
) then
3504 Decl
:= First
(Decls
);
3505 while Present
(Decl
)
3506 and then Nkind
(Decl
) = N_Pragma
3507 and then Get_Pragma_Id
(Decl
) /= Pragma_Compile_Time_Error
3512 if Present
(Decl
) then
3513 Insert_Before
(Decl
, Renaming
);
3515 Append
(Renaming
, Visible_Declarations
(Specification
(N
)));
3519 Set_Visible_Declarations
(Specification
(N
), New_List
(Renaming
));
3522 -- Create copy of generic unit, and save for instantiation. If the unit
3523 -- is a child unit, do not copy the specifications for the parent, which
3524 -- are not part of the generic tree.
3526 Save_Parent
:= Parent_Spec
(N
);
3527 Set_Parent_Spec
(N
, Empty
);
3529 New_N
:= Copy_Generic_Node
(N
, Empty
, Instantiating
=> False);
3530 Set_Parent_Spec
(New_N
, Save_Parent
);
3533 -- Once the contents of the generic copy and the template are swapped,
3534 -- do the same for their respective aspect specifications.
3536 Exchange_Aspects
(N
, New_N
);
3538 -- Collect all contract-related source pragmas found within the template
3539 -- and attach them to the contract of the package spec. This contract is
3540 -- used in the capture of global references within annotations.
3542 Create_Generic_Contract
(N
);
3544 Id
:= Defining_Entity
(N
);
3545 Generate_Definition
(Id
);
3547 -- Expansion is not applied to generic units
3552 Set_Ekind
(Id
, E_Generic_Package
);
3553 Set_Etype
(Id
, Standard_Void_Type
);
3555 -- Set SPARK_Mode from context
3557 Set_SPARK_Pragma
(Id
, SPARK_Mode_Pragma
);
3558 Set_SPARK_Aux_Pragma
(Id
, SPARK_Mode_Pragma
);
3559 Set_SPARK_Pragma_Inherited
(Id
);
3560 Set_SPARK_Aux_Pragma_Inherited
(Id
);
3562 -- Preserve relevant elaboration-related attributes of the context which
3563 -- are no longer available or very expensive to recompute once analysis,
3564 -- resolution, and expansion are over.
3566 Mark_Elaboration_Attributes
3570 -- Analyze aspects now, so that generated pragmas appear in the
3571 -- declarations before building and analyzing the generic copy.
3573 if Has_Aspects
(N
) then
3574 Analyze_Aspect_Specifications
(N
, Id
);
3578 Enter_Generic_Scope
(Id
);
3579 Set_Inner_Instances
(Id
, New_Elmt_List
);
3581 Set_Categorization_From_Pragmas
(N
);
3582 Set_Is_Pure
(Id
, Is_Pure
(Current_Scope
));
3584 -- Link the declaration of the generic homonym in the generic copy to
3585 -- the package it renames, so that it is always resolved properly.
3587 Set_Generic_Homonym
(Id
, Defining_Unit_Name
(Renaming
));
3588 Set_Entity
(Associated_Node
(Name
(Renaming
)), Id
);
3590 -- For a library unit, we have reconstructed the entity for the unit,
3591 -- and must reset it in the library tables.
3593 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
3594 Set_Cunit_Entity
(Current_Sem_Unit
, Id
);
3597 Analyze_Generic_Formal_Part
(N
);
3599 -- After processing the generic formals, analysis proceeds as for a
3600 -- non-generic package.
3602 Analyze
(Specification
(N
));
3604 Validate_Categorization_Dependency
(N
, Id
);
3608 End_Package_Scope
(Id
);
3609 Exit_Generic_Scope
(Id
);
3611 -- If the generic appears within a package unit, the body of that unit
3612 -- has to be present for instantiation and inlining.
3614 if Nkind
(Unit
(Cunit
(Current_Sem_Unit
))) = N_Package_Declaration
then
3615 Set_Body_Needed_For_Inlining
3616 (Defining_Entity
(Unit
(Cunit
(Current_Sem_Unit
))));
3619 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
3620 Move_Freeze_Nodes
(Id
, N
, Visible_Declarations
(Specification
(N
)));
3621 Move_Freeze_Nodes
(Id
, N
, Private_Declarations
(Specification
(N
)));
3622 Move_Freeze_Nodes
(Id
, N
, Generic_Formal_Declarations
(N
));
3625 Set_Body_Required
(Parent
(N
), Unit_Requires_Body
(Id
));
3626 Validate_RT_RAT_Component
(N
);
3628 -- If this is a spec without a body, check that generic parameters
3631 if not Body_Required
(Parent
(N
)) then
3632 Check_References
(Id
);
3636 -- If there is a specified storage pool in the context, create an
3637 -- aspect on the package declaration, so that it is used in any
3638 -- instance that does not override it.
3640 if Present
(Default_Pool
) then
3646 Make_Aspect_Specification
(Loc
,
3647 Identifier
=> Make_Identifier
(Loc
, Name_Default_Storage_Pool
),
3648 Expression
=> New_Copy
(Default_Pool
));
3650 if No
(Aspect_Specifications
(Specification
(N
))) then
3651 Set_Aspect_Specifications
(Specification
(N
), New_List
(ASN
));
3653 Append
(ASN
, Aspect_Specifications
(Specification
(N
)));
3657 end Analyze_Generic_Package_Declaration
;
3659 --------------------------------------------
3660 -- Analyze_Generic_Subprogram_Declaration --
3661 --------------------------------------------
3663 procedure Analyze_Generic_Subprogram_Declaration
(N
: Node_Id
) is
3667 Result_Type
: Entity_Id
;
3668 Save_Parent
: Node_Id
;
3673 Check_SPARK_05_Restriction
("generic is not allowed", N
);
3675 -- Create copy of generic unit, and save for instantiation. If the unit
3676 -- is a child unit, do not copy the specifications for the parent, which
3677 -- are not part of the generic tree.
3679 Save_Parent
:= Parent_Spec
(N
);
3680 Set_Parent_Spec
(N
, Empty
);
3682 New_N
:= Copy_Generic_Node
(N
, Empty
, Instantiating
=> False);
3683 Set_Parent_Spec
(New_N
, Save_Parent
);
3686 -- Once the contents of the generic copy and the template are swapped,
3687 -- do the same for their respective aspect specifications.
3689 Exchange_Aspects
(N
, New_N
);
3691 -- Collect all contract-related source pragmas found within the template
3692 -- and attach them to the contract of the subprogram spec. This contract
3693 -- is used in the capture of global references within annotations.
3695 Create_Generic_Contract
(N
);
3697 Spec
:= Specification
(N
);
3698 Id
:= Defining_Entity
(Spec
);
3699 Generate_Definition
(Id
);
3701 if Nkind
(Id
) = N_Defining_Operator_Symbol
then
3703 ("operator symbol not allowed for generic subprogram", Id
);
3709 Set_Scope_Depth_Value
(Id
, Scope_Depth
(Current_Scope
) + 1);
3711 -- Analyze the aspects of the generic copy to ensure that all generated
3712 -- pragmas (if any) perform their semantic effects.
3714 if Has_Aspects
(N
) then
3715 Analyze_Aspect_Specifications
(N
, Id
);
3719 Enter_Generic_Scope
(Id
);
3720 Set_Inner_Instances
(Id
, New_Elmt_List
);
3721 Set_Is_Pure
(Id
, Is_Pure
(Current_Scope
));
3723 Analyze_Generic_Formal_Part
(N
);
3725 if Nkind
(Spec
) = N_Function_Specification
then
3726 Set_Ekind
(Id
, E_Generic_Function
);
3728 Set_Ekind
(Id
, E_Generic_Procedure
);
3731 -- Set SPARK_Mode from context
3733 Set_SPARK_Pragma
(Id
, SPARK_Mode_Pragma
);
3734 Set_SPARK_Pragma_Inherited
(Id
);
3736 -- Preserve relevant elaboration-related attributes of the context which
3737 -- are no longer available or very expensive to recompute once analysis,
3738 -- resolution, and expansion are over.
3740 Mark_Elaboration_Attributes
3744 Formals
:= Parameter_Specifications
(Spec
);
3746 if Present
(Formals
) then
3747 Process_Formals
(Formals
, Spec
);
3750 if Nkind
(Spec
) = N_Function_Specification
then
3751 if Nkind
(Result_Definition
(Spec
)) = N_Access_Definition
then
3752 Result_Type
:= Access_Definition
(Spec
, Result_Definition
(Spec
));
3753 Set_Etype
(Id
, Result_Type
);
3755 -- Check restriction imposed by AI05-073: a generic function
3756 -- cannot return an abstract type or an access to such.
3758 -- This is a binding interpretation should it apply to earlier
3759 -- versions of Ada as well as Ada 2012???
3761 if Is_Abstract_Type
(Designated_Type
(Result_Type
))
3762 and then Ada_Version
>= Ada_2012
3765 ("generic function cannot have an access result "
3766 & "that designates an abstract type", Spec
);
3770 Find_Type
(Result_Definition
(Spec
));
3771 Typ
:= Entity
(Result_Definition
(Spec
));
3773 if Is_Abstract_Type
(Typ
)
3774 and then Ada_Version
>= Ada_2012
3777 ("generic function cannot have abstract result type", Spec
);
3780 -- If a null exclusion is imposed on the result type, then create
3781 -- a null-excluding itype (an access subtype) and use it as the
3782 -- function's Etype.
3784 if Is_Access_Type
(Typ
)
3785 and then Null_Exclusion_Present
(Spec
)
3788 Create_Null_Excluding_Itype
3790 Related_Nod
=> Spec
,
3791 Scope_Id
=> Defining_Unit_Name
(Spec
)));
3793 Set_Etype
(Id
, Typ
);
3798 Set_Etype
(Id
, Standard_Void_Type
);
3801 -- For a library unit, we have reconstructed the entity for the unit,
3802 -- and must reset it in the library tables. We also make sure that
3803 -- Body_Required is set properly in the original compilation unit node.
3805 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
3806 Set_Cunit_Entity
(Current_Sem_Unit
, Id
);
3807 Set_Body_Required
(Parent
(N
), Unit_Requires_Body
(Id
));
3810 -- If the generic appears within a package unit, the body of that unit
3811 -- has to be present for instantiation and inlining.
3813 if Nkind
(Unit
(Cunit
(Current_Sem_Unit
))) = N_Package_Declaration
3814 and then Unit_Requires_Body
(Id
)
3816 Set_Body_Needed_For_Inlining
3817 (Defining_Entity
(Unit
(Cunit
(Current_Sem_Unit
))));
3820 Set_Categorization_From_Pragmas
(N
);
3821 Validate_Categorization_Dependency
(N
, Id
);
3823 -- Capture all global references that occur within the profile of the
3824 -- generic subprogram. Aspects are not part of this processing because
3825 -- they must be delayed. If processed now, Save_Global_References will
3826 -- destroy the Associated_Node links and prevent the capture of global
3827 -- references when the contract of the generic subprogram is analyzed.
3829 Save_Global_References
(Original_Node
(N
));
3833 Exit_Generic_Scope
(Id
);
3834 Generate_Reference_To_Formals
(Id
);
3836 List_Inherited_Pre_Post_Aspects
(Id
);
3837 end Analyze_Generic_Subprogram_Declaration
;
3839 -----------------------------------
3840 -- Analyze_Package_Instantiation --
3841 -----------------------------------
3843 -- WARNING: This routine manages Ghost and SPARK regions. Return statements
3844 -- must be replaced by gotos which jump to the end of the routine in order
3845 -- to restore the Ghost and SPARK modes.
3847 procedure Analyze_Package_Instantiation
(N
: Node_Id
) is
3848 Has_Inline_Always
: Boolean := False;
3850 procedure Delay_Descriptors
(E
: Entity_Id
);
3851 -- Delay generation of subprogram descriptors for given entity
3853 function Might_Inline_Subp
(Gen_Unit
: Entity_Id
) return Boolean;
3854 -- If inlining is active and the generic contains inlined subprograms,
3855 -- we instantiate the body. This may cause superfluous instantiations,
3856 -- but it is simpler than detecting the need for the body at the point
3857 -- of inlining, when the context of the instance is not available.
3859 -----------------------
3860 -- Delay_Descriptors --
3861 -----------------------
3863 procedure Delay_Descriptors
(E
: Entity_Id
) is
3865 if not Delay_Subprogram_Descriptors
(E
) then
3866 Set_Delay_Subprogram_Descriptors
(E
);
3867 Pending_Descriptor
.Append
(E
);
3869 end Delay_Descriptors
;
3871 -----------------------
3872 -- Might_Inline_Subp --
3873 -----------------------
3875 function Might_Inline_Subp
(Gen_Unit
: Entity_Id
) return Boolean is
3879 if not Inline_Processing_Required
then
3883 E
:= First_Entity
(Gen_Unit
);
3884 while Present
(E
) loop
3885 if Is_Subprogram
(E
) and then Is_Inlined
(E
) then
3886 -- Remember if there are any subprograms with Inline_Always
3888 if Has_Pragma_Inline_Always
(E
) then
3889 Has_Inline_Always
:= True;
3900 end Might_Inline_Subp
;
3902 -- Local declarations
3904 Gen_Id
: constant Node_Id
:= Name
(N
);
3905 Is_Actual_Pack
: constant Boolean :=
3906 Is_Internal
(Defining_Entity
(N
));
3907 Loc
: constant Source_Ptr
:= Sloc
(N
);
3909 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
3910 Saved_ISMP
: constant Boolean :=
3911 Ignore_SPARK_Mode_Pragmas_In_Instance
;
3912 Saved_SM
: constant SPARK_Mode_Type
:= SPARK_Mode
;
3913 Saved_SMP
: constant Node_Id
:= SPARK_Mode_Pragma
;
3914 -- Save the Ghost and SPARK mode-related data to restore on exit
3916 Saved_Style_Check
: constant Boolean := Style_Check
;
3917 -- Save style check mode for restore on exit
3920 Act_Decl_Name
: Node_Id
;
3921 Act_Decl_Id
: Entity_Id
;
3924 Env_Installed
: Boolean := False;
3927 Gen_Unit
: Entity_Id
;
3928 Inline_Now
: Boolean := False;
3929 Needs_Body
: Boolean;
3930 Parent_Installed
: Boolean := False;
3931 Renaming_List
: List_Id
;
3932 Unit_Renaming
: Node_Id
;
3934 Vis_Prims_List
: Elist_Id
:= No_Elist
;
3935 -- List of primitives made temporarily visible in the instantiation
3936 -- to match the visibility of the formal type
3938 -- Start of processing for Analyze_Package_Instantiation
3941 -- Preserve relevant elaboration-related attributes of the context which
3942 -- are no longer available or very expensive to recompute once analysis,
3943 -- resolution, and expansion are over.
3945 Mark_Elaboration_Attributes
3952 Check_SPARK_05_Restriction
("generic is not allowed", N
);
3954 -- Very first thing: check for Text_IO special unit in case we are
3955 -- instantiating one of the children of [[Wide_]Wide_]Text_IO.
3957 Check_Text_IO_Special_Unit
(Name
(N
));
3959 -- Make node global for error reporting
3961 Instantiation_Node
:= N
;
3963 -- Case of instantiation of a generic package
3965 if Nkind
(N
) = N_Package_Instantiation
then
3966 Act_Decl_Id
:= New_Copy
(Defining_Entity
(N
));
3967 Set_Comes_From_Source
(Act_Decl_Id
, True);
3969 if Nkind
(Defining_Unit_Name
(N
)) = N_Defining_Program_Unit_Name
then
3971 Make_Defining_Program_Unit_Name
(Loc
,
3973 New_Copy_Tree
(Name
(Defining_Unit_Name
(N
))),
3974 Defining_Identifier
=> Act_Decl_Id
);
3976 Act_Decl_Name
:= Act_Decl_Id
;
3979 -- Case of instantiation of a formal package
3982 Act_Decl_Id
:= Defining_Identifier
(N
);
3983 Act_Decl_Name
:= Act_Decl_Id
;
3986 Generate_Definition
(Act_Decl_Id
);
3987 Set_Ekind
(Act_Decl_Id
, E_Package
);
3989 -- Initialize list of incomplete actuals before analysis
3991 Set_Incomplete_Actuals
(Act_Decl_Id
, New_Elmt_List
);
3993 Preanalyze_Actuals
(N
, Act_Decl_Id
);
3995 -- Turn off style checking in instances. If the check is enabled on the
3996 -- generic unit, a warning in an instance would just be noise. If not
3997 -- enabled on the generic, then a warning in an instance is just wrong.
3998 -- This must be done after analyzing the actuals, which do come from
3999 -- source and are subject to style checking.
4001 Style_Check
:= False;
4004 Env_Installed
:= True;
4006 -- Reset renaming map for formal types. The mapping is established
4007 -- when analyzing the generic associations, but some mappings are
4008 -- inherited from formal packages of parent units, and these are
4009 -- constructed when the parents are installed.
4011 Generic_Renamings
.Set_Last
(0);
4012 Generic_Renamings_HTable
.Reset
;
4014 Check_Generic_Child_Unit
(Gen_Id
, Parent_Installed
);
4015 Gen_Unit
:= Entity
(Gen_Id
);
4017 -- A package instantiation is Ghost when it is subject to pragma Ghost
4018 -- or the generic template is Ghost. Set the mode now to ensure that
4019 -- any nodes generated during analysis and expansion are marked as
4022 Mark_And_Set_Ghost_Instantiation
(N
, Gen_Unit
);
4024 -- Verify that it is the name of a generic package
4026 -- A visibility glitch: if the instance is a child unit and the generic
4027 -- is the generic unit of a parent instance (i.e. both the parent and
4028 -- the child units are instances of the same package) the name now
4029 -- denotes the renaming within the parent, not the intended generic
4030 -- unit. See if there is a homonym that is the desired generic. The
4031 -- renaming declaration must be visible inside the instance of the
4032 -- child, but not when analyzing the name in the instantiation itself.
4034 if Ekind
(Gen_Unit
) = E_Package
4035 and then Present
(Renamed_Entity
(Gen_Unit
))
4036 and then In_Open_Scopes
(Renamed_Entity
(Gen_Unit
))
4037 and then Is_Generic_Instance
(Renamed_Entity
(Gen_Unit
))
4038 and then Present
(Homonym
(Gen_Unit
))
4040 Gen_Unit
:= Homonym
(Gen_Unit
);
4043 if Etype
(Gen_Unit
) = Any_Type
then
4047 elsif Ekind
(Gen_Unit
) /= E_Generic_Package
then
4049 -- Ada 2005 (AI-50217): Cannot use instance in limited with_clause
4051 if From_Limited_With
(Gen_Unit
) then
4053 ("cannot instantiate a limited withed package", Gen_Id
);
4056 ("& is not the name of a generic package", Gen_Id
, Gen_Unit
);
4063 if In_Extended_Main_Source_Unit
(N
) then
4064 Set_Is_Instantiated
(Gen_Unit
);
4065 Generate_Reference
(Gen_Unit
, N
);
4067 if Present
(Renamed_Object
(Gen_Unit
)) then
4068 Set_Is_Instantiated
(Renamed_Object
(Gen_Unit
));
4069 Generate_Reference
(Renamed_Object
(Gen_Unit
), N
);
4073 if Nkind
(Gen_Id
) = N_Identifier
4074 and then Chars
(Gen_Unit
) = Chars
(Defining_Entity
(N
))
4077 ("& is hidden within declaration of instance", Gen_Id
, Gen_Unit
);
4079 elsif Nkind
(Gen_Id
) = N_Expanded_Name
4080 and then Is_Child_Unit
(Gen_Unit
)
4081 and then Nkind
(Prefix
(Gen_Id
)) = N_Identifier
4082 and then Chars
(Act_Decl_Id
) = Chars
(Prefix
(Gen_Id
))
4085 ("& is hidden within declaration of instance ", Prefix
(Gen_Id
));
4088 Set_Entity
(Gen_Id
, Gen_Unit
);
4090 -- If generic is a renaming, get original generic unit
4092 if Present
(Renamed_Object
(Gen_Unit
))
4093 and then Ekind
(Renamed_Object
(Gen_Unit
)) = E_Generic_Package
4095 Gen_Unit
:= Renamed_Object
(Gen_Unit
);
4098 -- Verify that there are no circular instantiations
4100 if In_Open_Scopes
(Gen_Unit
) then
4101 Error_Msg_NE
("instantiation of & within itself", N
, Gen_Unit
);
4105 elsif Contains_Instance_Of
(Gen_Unit
, Current_Scope
, Gen_Id
) then
4106 Error_Msg_Node_2
:= Current_Scope
;
4108 ("circular Instantiation: & instantiated in &!", N
, Gen_Unit
);
4109 Circularity_Detected
:= True;
4114 -- If the context of the instance is subject to SPARK_Mode "off" or
4115 -- the annotation is altogether missing, set the global flag which
4116 -- signals Analyze_Pragma to ignore all SPARK_Mode pragmas within
4119 if SPARK_Mode
/= On
then
4120 Ignore_SPARK_Mode_Pragmas_In_Instance
:= True;
4122 -- Mark the instance spec in case the body is instantiated at a
4123 -- later pass. This preserves the original context in effect for
4126 Set_Ignore_SPARK_Mode_Pragmas
(Act_Decl_Id
);
4129 Gen_Decl
:= Unit_Declaration_Node
(Gen_Unit
);
4130 Gen_Spec
:= Specification
(Gen_Decl
);
4132 -- Initialize renamings map, for error checking, and the list that
4133 -- holds private entities whose views have changed between generic
4134 -- definition and instantiation. If this is the instance created to
4135 -- validate an actual package, the instantiation environment is that
4136 -- of the enclosing instance.
4138 Create_Instantiation_Source
(N
, Gen_Unit
, S_Adjustment
);
4140 -- Copy original generic tree, to produce text for instantiation
4144 (Original_Node
(Gen_Decl
), Empty
, Instantiating
=> True);
4146 Act_Spec
:= Specification
(Act_Tree
);
4148 -- If this is the instance created to validate an actual package,
4149 -- only the formals matter, do not examine the package spec itself.
4151 if Is_Actual_Pack
then
4152 Set_Visible_Declarations
(Act_Spec
, New_List
);
4153 Set_Private_Declarations
(Act_Spec
, New_List
);
4157 Analyze_Associations
4159 Formals
=> Generic_Formal_Declarations
(Act_Tree
),
4160 F_Copy
=> Generic_Formal_Declarations
(Gen_Decl
));
4162 Vis_Prims_List
:= Check_Hidden_Primitives
(Renaming_List
);
4164 Set_Instance_Env
(Gen_Unit
, Act_Decl_Id
);
4165 Set_Defining_Unit_Name
(Act_Spec
, Act_Decl_Name
);
4166 Set_Is_Generic_Instance
(Act_Decl_Id
);
4167 Set_Generic_Parent
(Act_Spec
, Gen_Unit
);
4169 -- References to the generic in its own declaration or its body are
4170 -- references to the instance. Add a renaming declaration for the
4171 -- generic unit itself. This declaration, as well as the renaming
4172 -- declarations for the generic formals, must remain private to the
4173 -- unit: the formals, because this is the language semantics, and
4174 -- the unit because its use is an artifact of the implementation.
4177 Make_Package_Renaming_Declaration
(Loc
,
4178 Defining_Unit_Name
=>
4179 Make_Defining_Identifier
(Loc
, Chars
(Gen_Unit
)),
4180 Name
=> New_Occurrence_Of
(Act_Decl_Id
, Loc
));
4182 Append
(Unit_Renaming
, Renaming_List
);
4184 -- The renaming declarations are the first local declarations of the
4187 if Is_Non_Empty_List
(Visible_Declarations
(Act_Spec
)) then
4189 (First
(Visible_Declarations
(Act_Spec
)), Renaming_List
);
4191 Set_Visible_Declarations
(Act_Spec
, Renaming_List
);
4194 Act_Decl
:= Make_Package_Declaration
(Loc
, Specification
=> Act_Spec
);
4196 -- Propagate the aspect specifications from the package declaration
4197 -- template to the instantiated version of the package declaration.
4199 if Has_Aspects
(Act_Tree
) then
4200 Set_Aspect_Specifications
(Act_Decl
,
4201 New_Copy_List_Tree
(Aspect_Specifications
(Act_Tree
)));
4204 -- The generic may have a generated Default_Storage_Pool aspect,
4205 -- set at the point of generic declaration. If the instance has
4206 -- that aspect, it overrides the one inherited from the generic.
4208 if Has_Aspects
(Gen_Spec
) then
4209 if No
(Aspect_Specifications
(N
)) then
4210 Set_Aspect_Specifications
(N
,
4212 (Aspect_Specifications
(Gen_Spec
))));
4216 ASN1
, ASN2
: Node_Id
;
4219 ASN1
:= First
(Aspect_Specifications
(N
));
4220 while Present
(ASN1
) loop
4221 if Chars
(Identifier
(ASN1
)) = Name_Default_Storage_Pool
4223 -- If generic carries a default storage pool, remove
4224 -- it in favor of the instance one.
4226 ASN2
:= First
(Aspect_Specifications
(Gen_Spec
));
4227 while Present
(ASN2
) loop
4228 if Chars
(Identifier
(ASN2
)) =
4229 Name_Default_Storage_Pool
4242 Prepend_List_To
(Aspect_Specifications
(N
),
4244 (Aspect_Specifications
(Gen_Spec
))));
4249 -- Save the instantiation node, for subsequent instantiation of the
4250 -- body, if there is one and we are generating code for the current
4251 -- unit. Mark unit as having a body (avoids premature error message).
4253 -- We instantiate the body if we are generating code, if we are
4254 -- generating cross-reference information, or if we are building
4255 -- trees for ASIS use or GNATprove use.
4258 Enclosing_Body_Present
: Boolean := False;
4259 -- If the generic unit is not a compilation unit, then a body may
4260 -- be present in its parent even if none is required. We create a
4261 -- tentative pending instantiation for the body, which will be
4262 -- discarded if none is actually present.
4267 if Scope
(Gen_Unit
) /= Standard_Standard
4268 and then not Is_Child_Unit
(Gen_Unit
)
4270 Scop
:= Scope
(Gen_Unit
);
4271 while Present
(Scop
) and then Scop
/= Standard_Standard
loop
4272 if Unit_Requires_Body
(Scop
) then
4273 Enclosing_Body_Present
:= True;
4276 elsif In_Open_Scopes
(Scop
)
4277 and then In_Package_Body
(Scop
)
4279 Enclosing_Body_Present
:= True;
4283 exit when Is_Compilation_Unit
(Scop
);
4284 Scop
:= Scope
(Scop
);
4288 -- If front-end inlining is enabled or there are any subprograms
4289 -- marked with Inline_Always, and this is a unit for which code
4290 -- will be generated, we instantiate the body at once.
4292 -- This is done if the instance is not the main unit, and if the
4293 -- generic is not a child unit of another generic, to avoid scope
4294 -- problems and the reinstallation of parent instances.
4297 and then (not Is_Child_Unit
(Gen_Unit
)
4298 or else not Is_Generic_Unit
(Scope
(Gen_Unit
)))
4299 and then Might_Inline_Subp
(Gen_Unit
)
4300 and then not Is_Actual_Pack
4302 if not Back_End_Inlining
4303 and then (Front_End_Inlining
or else Has_Inline_Always
)
4304 and then (Is_In_Main_Unit
(N
)
4305 or else In_Main_Context
(Current_Scope
))
4306 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit
4310 -- In configurable_run_time mode we force the inlining of
4311 -- predefined subprograms marked Inline_Always, to minimize
4312 -- the use of the run-time library.
4314 elsif In_Predefined_Unit
(Gen_Decl
)
4315 and then Configurable_Run_Time_Mode
4316 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit
4321 -- If the current scope is itself an instance within a child
4322 -- unit, there will be duplications in the scope stack, and the
4323 -- unstacking mechanism in Inline_Instance_Body will fail.
4324 -- This loses some rare cases of optimization, and might be
4325 -- improved some day, if we can find a proper abstraction for
4326 -- "the complete compilation context" that can be saved and
4329 if Is_Generic_Instance
(Current_Scope
) then
4331 Curr_Unit
: constant Entity_Id
:=
4332 Cunit_Entity
(Current_Sem_Unit
);
4334 if Curr_Unit
/= Current_Scope
4335 and then Is_Child_Unit
(Curr_Unit
)
4337 Inline_Now
:= False;
4344 (Unit_Requires_Body
(Gen_Unit
)
4345 or else Enclosing_Body_Present
4346 or else Present
(Corresponding_Body
(Gen_Decl
)))
4347 and then (Is_In_Main_Unit
(N
)
4348 or else Might_Inline_Subp
(Gen_Unit
))
4349 and then not Is_Actual_Pack
4350 and then not Inline_Now
4351 and then (Operating_Mode
= Generate_Code
4353 -- Need comment for this check ???
4355 or else (Operating_Mode
= Check_Semantics
4356 and then (ASIS_Mode
or GNATprove_Mode
)));
4358 -- If front-end inlining is enabled or there are any subprograms
4359 -- marked with Inline_Always, do not instantiate body when within
4360 -- a generic context.
4362 if ((Front_End_Inlining
or else Has_Inline_Always
)
4363 and then not Expander_Active
)
4364 or else Is_Generic_Unit
(Cunit_Entity
(Main_Unit
))
4366 Needs_Body
:= False;
4369 -- If the current context is generic, and the package being
4370 -- instantiated is declared within a formal package, there is no
4371 -- body to instantiate until the enclosing generic is instantiated
4372 -- and there is an actual for the formal package. If the formal
4373 -- package has parameters, we build a regular package instance for
4374 -- it, that precedes the original formal package declaration.
4376 if In_Open_Scopes
(Scope
(Scope
(Gen_Unit
))) then
4378 Decl
: constant Node_Id
:=
4380 (Unit_Declaration_Node
(Scope
(Gen_Unit
)));
4382 if Nkind
(Decl
) = N_Formal_Package_Declaration
4383 or else (Nkind
(Decl
) = N_Package_Declaration
4384 and then Is_List_Member
(Decl
)
4385 and then Present
(Next
(Decl
))
4387 Nkind
(Next
(Decl
)) =
4388 N_Formal_Package_Declaration
)
4390 Needs_Body
:= False;
4396 -- For RCI unit calling stubs, we omit the instance body if the
4397 -- instance is the RCI library unit itself.
4399 -- However there is a special case for nested instances: in this case
4400 -- we do generate the instance body, as it might be required, e.g.
4401 -- because it provides stream attributes for some type used in the
4402 -- profile of a remote subprogram. This is consistent with 12.3(12),
4403 -- which indicates that the instance body occurs at the place of the
4404 -- instantiation, and thus is part of the RCI declaration, which is
4405 -- present on all client partitions (this is E.2.3(18)).
4407 -- Note that AI12-0002 may make it illegal at some point to have
4408 -- stream attributes defined in an RCI unit, in which case this
4409 -- special case will become unnecessary. In the meantime, there
4410 -- is known application code in production that depends on this
4411 -- being possible, so we definitely cannot eliminate the body in
4412 -- the case of nested instances for the time being.
4414 -- When we generate a nested instance body, calling stubs for any
4415 -- relevant subprogram will be be inserted immediately after the
4416 -- subprogram declarations, and will take precedence over the
4417 -- subsequent (original) body. (The stub and original body will be
4418 -- complete homographs, but this is permitted in an instance).
4419 -- (Could we do better and remove the original body???)
4421 if Distribution_Stub_Mode
= Generate_Caller_Stub_Body
4422 and then Comes_From_Source
(N
)
4423 and then Nkind
(Parent
(N
)) = N_Compilation_Unit
4425 Needs_Body
:= False;
4430 -- Here is a defence against a ludicrous number of instantiations
4431 -- caused by a circular set of instantiation attempts.
4433 if Pending_Instantiations
.Last
> Maximum_Instantiations
then
4434 Error_Msg_Uint_1
:= UI_From_Int
(Maximum_Instantiations
);
4435 Error_Msg_N
("too many instantiations, exceeds max of^", N
);
4436 Error_Msg_N
("\limit can be changed using -gnateinn switch", N
);
4437 raise Unrecoverable_Error
;
4440 -- Indicate that the enclosing scopes contain an instantiation,
4441 -- and that cleanup actions should be delayed until after the
4442 -- instance body is expanded.
4444 Check_Forward_Instantiation
(Gen_Decl
);
4445 if Nkind
(N
) = N_Package_Instantiation
then
4447 Enclosing_Master
: Entity_Id
;
4450 -- Loop to search enclosing masters
4452 Enclosing_Master
:= Current_Scope
;
4453 Scope_Loop
: while Enclosing_Master
/= Standard_Standard
loop
4454 if Ekind
(Enclosing_Master
) = E_Package
then
4455 if Is_Compilation_Unit
(Enclosing_Master
) then
4456 if In_Package_Body
(Enclosing_Master
) then
4458 (Body_Entity
(Enclosing_Master
));
4467 Enclosing_Master
:= Scope
(Enclosing_Master
);
4470 elsif Is_Generic_Unit
(Enclosing_Master
)
4471 or else Ekind
(Enclosing_Master
) = E_Void
4473 -- Cleanup actions will eventually be performed on the
4474 -- enclosing subprogram or package instance, if any.
4475 -- Enclosing scope is void in the formal part of a
4476 -- generic subprogram.
4481 if Ekind
(Enclosing_Master
) = E_Entry
4483 Ekind
(Scope
(Enclosing_Master
)) = E_Protected_Type
4485 if not Expander_Active
then
4489 Protected_Body_Subprogram
(Enclosing_Master
);
4493 Set_Delay_Cleanups
(Enclosing_Master
);
4495 while Ekind
(Enclosing_Master
) = E_Block
loop
4496 Enclosing_Master
:= Scope
(Enclosing_Master
);
4499 if Is_Subprogram
(Enclosing_Master
) then
4500 Delay_Descriptors
(Enclosing_Master
);
4502 elsif Is_Task_Type
(Enclosing_Master
) then
4504 TBP
: constant Node_Id
:=
4505 Get_Task_Body_Procedure
4508 if Present
(TBP
) then
4509 Delay_Descriptors
(TBP
);
4510 Set_Delay_Cleanups
(TBP
);
4517 end loop Scope_Loop
;
4520 -- Make entry in table
4522 Add_Pending_Instantiation
(N
, Act_Decl
);
4526 Set_Categorization_From_Pragmas
(Act_Decl
);
4528 if Parent_Installed
then
4532 Set_Instance_Spec
(N
, Act_Decl
);
4534 -- If not a compilation unit, insert the package declaration before
4535 -- the original instantiation node.
4537 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
4538 Mark_Rewrite_Insertion
(Act_Decl
);
4539 Insert_Before
(N
, Act_Decl
);
4541 if Has_Aspects
(N
) then
4542 Analyze_Aspect_Specifications
(N
, Act_Decl_Id
);
4544 -- The pragma created for a Default_Storage_Pool aspect must
4545 -- appear ahead of the declarations in the instance spec.
4546 -- Analysis has placed it after the instance node, so remove
4547 -- it and reinsert it properly now.
4550 ASN
: constant Node_Id
:= First
(Aspect_Specifications
(N
));
4551 A_Name
: constant Name_Id
:= Chars
(Identifier
(ASN
));
4555 if A_Name
= Name_Default_Storage_Pool
then
4556 if No
(Visible_Declarations
(Act_Spec
)) then
4557 Set_Visible_Declarations
(Act_Spec
, New_List
);
4561 while Present
(Decl
) loop
4562 if Nkind
(Decl
) = N_Pragma
then
4564 Prepend
(Decl
, Visible_Declarations
(Act_Spec
));
4576 -- For an instantiation that is a compilation unit, place
4577 -- declaration on current node so context is complete for analysis
4578 -- (including nested instantiations). If this is the main unit,
4579 -- the declaration eventually replaces the instantiation node.
4580 -- If the instance body is created later, it replaces the
4581 -- instance node, and the declaration is attached to it
4582 -- (see Build_Instance_Compilation_Unit_Nodes).
4585 if Cunit_Entity
(Current_Sem_Unit
) = Defining_Entity
(N
) then
4587 -- The entity for the current unit is the newly created one,
4588 -- and all semantic information is attached to it.
4590 Set_Cunit_Entity
(Current_Sem_Unit
, Act_Decl_Id
);
4592 -- If this is the main unit, replace the main entity as well
4594 if Current_Sem_Unit
= Main_Unit
then
4595 Main_Unit_Entity
:= Act_Decl_Id
;
4599 Set_Unit
(Parent
(N
), Act_Decl
);
4600 Set_Parent_Spec
(Act_Decl
, Parent_Spec
(N
));
4601 Set_Package_Instantiation
(Act_Decl_Id
, N
);
4603 -- Process aspect specifications of the instance node, if any, to
4604 -- take into account categorization pragmas before analyzing the
4607 if Has_Aspects
(N
) then
4608 Analyze_Aspect_Specifications
(N
, Act_Decl_Id
);
4612 Set_Unit
(Parent
(N
), N
);
4613 Set_Body_Required
(Parent
(N
), False);
4615 -- We never need elaboration checks on instantiations, since by
4616 -- definition, the body instantiation is elaborated at the same
4617 -- time as the spec instantiation.
4619 if Legacy_Elaboration_Checks
then
4620 Set_Kill_Elaboration_Checks
(Act_Decl_Id
);
4621 Set_Suppress_Elaboration_Warnings
(Act_Decl_Id
);
4625 if Legacy_Elaboration_Checks
then
4626 Check_Elab_Instantiation
(N
);
4629 -- Save the scenario for later examination by the ABE Processing
4632 Record_Elaboration_Scenario
(N
);
4634 -- The instantiation results in a guaranteed ABE
4636 if Is_Known_Guaranteed_ABE
(N
) and then Needs_Body
then
4638 -- Do not instantiate the corresponding body because gigi cannot
4639 -- handle certain types of premature instantiations.
4641 Pending_Instantiations
.Decrement_Last
;
4643 -- Create completing bodies for all subprogram declarations since
4644 -- their real bodies will not be instantiated.
4646 Provide_Completing_Bodies
(Instance_Spec
(N
));
4649 Check_Hidden_Child_Unit
(N
, Gen_Unit
, Act_Decl_Id
);
4651 Set_First_Private_Entity
(Defining_Unit_Name
(Unit_Renaming
),
4652 First_Private_Entity
(Act_Decl_Id
));
4654 -- If the instantiation will receive a body, the unit will be
4655 -- transformed into a package body, and receive its own elaboration
4656 -- entity. Otherwise, the nature of the unit is now a package
4659 if Nkind
(Parent
(N
)) = N_Compilation_Unit
4660 and then not Needs_Body
4662 Rewrite
(N
, Act_Decl
);
4665 if Present
(Corresponding_Body
(Gen_Decl
))
4666 or else Unit_Requires_Body
(Gen_Unit
)
4668 Set_Has_Completion
(Act_Decl_Id
);
4671 Check_Formal_Packages
(Act_Decl_Id
);
4673 Restore_Hidden_Primitives
(Vis_Prims_List
);
4674 Restore_Private_Views
(Act_Decl_Id
);
4676 Inherit_Context
(Gen_Decl
, N
);
4678 if Parent_Installed
then
4683 Env_Installed
:= False;
4686 Validate_Categorization_Dependency
(N
, Act_Decl_Id
);
4688 -- There used to be a check here to prevent instantiations in local
4689 -- contexts if the No_Local_Allocators restriction was active. This
4690 -- check was removed by a binding interpretation in AI-95-00130/07,
4691 -- but we retain the code for documentation purposes.
4693 -- if Ekind (Act_Decl_Id) /= E_Void
4694 -- and then not Is_Library_Level_Entity (Act_Decl_Id)
4696 -- Check_Restriction (No_Local_Allocators, N);
4700 Inline_Instance_Body
(N
, Gen_Unit
, Act_Decl
);
4703 -- The following is a tree patch for ASIS: ASIS needs separate nodes to
4704 -- be used as defining identifiers for a formal package and for the
4705 -- corresponding expanded package.
4707 if Nkind
(N
) = N_Formal_Package_Declaration
then
4708 Act_Decl_Id
:= New_Copy
(Defining_Entity
(N
));
4709 Set_Comes_From_Source
(Act_Decl_Id
, True);
4710 Set_Is_Generic_Instance
(Act_Decl_Id
, False);
4711 Set_Defining_Identifier
(N
, Act_Decl_Id
);
4714 -- Check that if N is an instantiation of System.Dim_Float_IO or
4715 -- System.Dim_Integer_IO, the formal type has a dimension system.
4717 if Nkind
(N
) = N_Package_Instantiation
4718 and then Is_Dim_IO_Package_Instantiation
(N
)
4721 Assoc
: constant Node_Id
:= First
(Generic_Associations
(N
));
4723 if not Has_Dimension_System
4724 (Etype
(Explicit_Generic_Actual_Parameter
(Assoc
)))
4726 Error_Msg_N
("type with a dimension system expected", Assoc
);
4732 if Has_Aspects
(N
) and then Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
4733 Analyze_Aspect_Specifications
(N
, Act_Decl_Id
);
4736 Ignore_SPARK_Mode_Pragmas_In_Instance
:= Saved_ISMP
;
4737 Restore_Ghost_Mode
(Saved_GM
);
4738 Restore_SPARK_Mode
(Saved_SM
, Saved_SMP
);
4739 Style_Check
:= Saved_Style_Check
;
4742 when Instantiation_Error
=>
4743 if Parent_Installed
then
4747 if Env_Installed
then
4751 Ignore_SPARK_Mode_Pragmas_In_Instance
:= Saved_ISMP
;
4752 Restore_Ghost_Mode
(Saved_GM
);
4753 Restore_SPARK_Mode
(Saved_SM
, Saved_SMP
);
4754 Style_Check
:= Saved_Style_Check
;
4755 end Analyze_Package_Instantiation
;
4757 --------------------------
4758 -- Inline_Instance_Body --
4759 --------------------------
4761 -- WARNING: This routine manages SPARK regions. Return statements must be
4762 -- replaced by gotos which jump to the end of the routine and restore the
4765 procedure Inline_Instance_Body
4767 Gen_Unit
: Entity_Id
;
4770 Curr_Comp
: constant Node_Id
:= Cunit
(Current_Sem_Unit
);
4771 Curr_Unit
: constant Entity_Id
:= Cunit_Entity
(Current_Sem_Unit
);
4772 Gen_Comp
: constant Entity_Id
:=
4773 Cunit_Entity
(Get_Source_Unit
(Gen_Unit
));
4775 Saved_SM
: constant SPARK_Mode_Type
:= SPARK_Mode
;
4776 Saved_SMP
: constant Node_Id
:= SPARK_Mode_Pragma
;
4777 -- Save the SPARK mode-related data to restore on exit. Removing
4778 -- enclosing scopes to provide a clean environment for analysis of
4779 -- the inlined body will eliminate any previously set SPARK_Mode.
4781 Scope_Stack_Depth
: constant Pos
:=
4782 Scope_Stack
.Last
- Scope_Stack
.First
+ 1;
4784 Inner_Scopes
: array (1 .. Scope_Stack_Depth
) of Entity_Id
;
4785 Instances
: array (1 .. Scope_Stack_Depth
) of Entity_Id
;
4786 Use_Clauses
: array (1 .. Scope_Stack_Depth
) of Node_Id
;
4788 Curr_Scope
: Entity_Id
:= Empty
;
4789 List
: Elist_Id
:= No_Elist
; -- init to avoid warning
4790 N_Instances
: Nat
:= 0;
4791 Num_Inner
: Nat
:= 0;
4792 Num_Scopes
: Nat
:= 0;
4793 Removed
: Boolean := False;
4798 -- Case of generic unit defined in another unit. We must remove the
4799 -- complete context of the current unit to install that of the generic.
4801 if Gen_Comp
/= Cunit_Entity
(Current_Sem_Unit
) then
4803 -- Add some comments for the following two loops ???
4806 while Present
(S
) and then S
/= Standard_Standard
loop
4808 Num_Scopes
:= Num_Scopes
+ 1;
4810 Use_Clauses
(Num_Scopes
) :=
4812 (Scope_Stack
.Last
- Num_Scopes
+ 1).
4814 End_Use_Clauses
(Use_Clauses
(Num_Scopes
));
4816 exit when Scope_Stack
.Last
- Num_Scopes
+ 1 = Scope_Stack
.First
4817 or else Scope_Stack
.Table
4818 (Scope_Stack
.Last
- Num_Scopes
).Entity
= Scope
(S
);
4821 exit when Is_Generic_Instance
(S
)
4822 and then (In_Package_Body
(S
)
4823 or else Ekind
(S
) = E_Procedure
4824 or else Ekind
(S
) = E_Function
);
4828 Vis
:= Is_Immediately_Visible
(Gen_Comp
);
4830 -- Find and save all enclosing instances
4835 and then S
/= Standard_Standard
4837 if Is_Generic_Instance
(S
) then
4838 N_Instances
:= N_Instances
+ 1;
4839 Instances
(N_Instances
) := S
;
4841 exit when In_Package_Body
(S
);
4847 -- Remove context of current compilation unit, unless we are within a
4848 -- nested package instantiation, in which case the context has been
4849 -- removed previously.
4851 -- If current scope is the body of a child unit, remove context of
4852 -- spec as well. If an enclosing scope is an instance body, the
4853 -- context has already been removed, but the entities in the body
4854 -- must be made invisible as well.
4857 while Present
(S
) and then S
/= Standard_Standard
loop
4858 if Is_Generic_Instance
(S
)
4859 and then (In_Package_Body
(S
)
4860 or else Ekind_In
(S
, E_Procedure
, E_Function
))
4862 -- We still have to remove the entities of the enclosing
4863 -- instance from direct visibility.
4868 E
:= First_Entity
(S
);
4869 while Present
(E
) loop
4870 Set_Is_Immediately_Visible
(E
, False);
4879 or else (Ekind
(Curr_Unit
) = E_Package_Body
4880 and then S
= Spec_Entity
(Curr_Unit
))
4881 or else (Ekind
(Curr_Unit
) = E_Subprogram_Body
4882 and then S
= Corresponding_Spec
4883 (Unit_Declaration_Node
(Curr_Unit
)))
4887 -- Remove entities in current scopes from visibility, so that
4888 -- instance body is compiled in a clean environment.
4890 List
:= Save_Scope_Stack
(Handle_Use
=> False);
4892 if Is_Child_Unit
(S
) then
4894 -- Remove child unit from stack, as well as inner scopes.
4895 -- Removing the context of a child unit removes parent units
4898 while Current_Scope
/= S
loop
4899 Num_Inner
:= Num_Inner
+ 1;
4900 Inner_Scopes
(Num_Inner
) := Current_Scope
;
4905 Remove_Context
(Curr_Comp
);
4909 Remove_Context
(Curr_Comp
);
4912 if Ekind
(Curr_Unit
) = E_Package_Body
then
4913 Remove_Context
(Library_Unit
(Curr_Comp
));
4920 pragma Assert
(Num_Inner
< Num_Scopes
);
4922 -- The inlined package body must be analyzed with the SPARK_Mode of
4923 -- the enclosing context, otherwise the body may cause bogus errors
4924 -- if a configuration SPARK_Mode pragma in in effect.
4926 Push_Scope
(Standard_Standard
);
4927 Scope_Stack
.Table
(Scope_Stack
.Last
).Is_Active_Stack_Base
:= True;
4928 Instantiate_Package_Body
4931 Act_Decl
=> Act_Decl
,
4932 Expander_Status
=> Expander_Active
,
4933 Current_Sem_Unit
=> Current_Sem_Unit
,
4934 Scope_Suppress
=> Scope_Suppress
,
4935 Local_Suppress_Stack_Top
=> Local_Suppress_Stack_Top
,
4936 Version
=> Ada_Version
,
4937 Version_Pragma
=> Ada_Version_Pragma
,
4938 Warnings
=> Save_Warnings
,
4939 SPARK_Mode
=> Saved_SM
,
4940 SPARK_Mode_Pragma
=> Saved_SMP
)),
4941 Inlined_Body
=> True);
4947 Set_Is_Immediately_Visible
(Gen_Comp
, Vis
);
4949 -- Reset Generic_Instance flag so that use clauses can be installed
4950 -- in the proper order. (See Use_One_Package for effect of enclosing
4951 -- instances on processing of use clauses).
4953 for J
in 1 .. N_Instances
loop
4954 Set_Is_Generic_Instance
(Instances
(J
), False);
4958 Install_Context
(Curr_Comp
, Chain
=> False);
4960 if Present
(Curr_Scope
)
4961 and then Is_Child_Unit
(Curr_Scope
)
4963 Push_Scope
(Curr_Scope
);
4964 Set_Is_Immediately_Visible
(Curr_Scope
);
4966 -- Finally, restore inner scopes as well
4968 for J
in reverse 1 .. Num_Inner
loop
4969 Push_Scope
(Inner_Scopes
(J
));
4973 Restore_Scope_Stack
(List
, Handle_Use
=> False);
4975 if Present
(Curr_Scope
)
4977 (In_Private_Part
(Curr_Scope
)
4978 or else In_Package_Body
(Curr_Scope
))
4980 -- Install private declaration of ancestor units, which are
4981 -- currently available. Restore_Scope_Stack and Install_Context
4982 -- only install the visible part of parents.
4987 Par
:= Scope
(Curr_Scope
);
4988 while (Present
(Par
)) and then Par
/= Standard_Standard
loop
4989 Install_Private_Declarations
(Par
);
4996 -- Restore use clauses. For a child unit, use clauses in the parents
4997 -- are restored when installing the context, so only those in inner
4998 -- scopes (and those local to the child unit itself) need to be
4999 -- installed explicitly.
5001 if Is_Child_Unit
(Curr_Unit
) and then Removed
then
5002 for J
in reverse 1 .. Num_Inner
+ 1 loop
5003 Scope_Stack
.Table
(Scope_Stack
.Last
- J
+ 1).First_Use_Clause
:=
5005 Install_Use_Clauses
(Use_Clauses
(J
));
5009 for J
in reverse 1 .. Num_Scopes
loop
5010 Scope_Stack
.Table
(Scope_Stack
.Last
- J
+ 1).First_Use_Clause
:=
5012 Install_Use_Clauses
(Use_Clauses
(J
));
5016 -- Restore status of instances. If one of them is a body, make its
5017 -- local entities visible again.
5024 for J
in 1 .. N_Instances
loop
5025 Inst
:= Instances
(J
);
5026 Set_Is_Generic_Instance
(Inst
, True);
5028 if In_Package_Body
(Inst
)
5029 or else Ekind_In
(S
, E_Procedure
, E_Function
)
5031 E
:= First_Entity
(Instances
(J
));
5032 while Present
(E
) loop
5033 Set_Is_Immediately_Visible
(E
);
5040 -- If generic unit is in current unit, current context is correct. Note
5041 -- that the context is guaranteed to carry the correct SPARK_Mode as no
5042 -- enclosing scopes were removed.
5045 Instantiate_Package_Body
5048 Act_Decl
=> Act_Decl
,
5049 Expander_Status
=> Expander_Active
,
5050 Current_Sem_Unit
=> Current_Sem_Unit
,
5051 Scope_Suppress
=> Scope_Suppress
,
5052 Local_Suppress_Stack_Top
=> Local_Suppress_Stack_Top
,
5053 Version
=> Ada_Version
,
5054 Version_Pragma
=> Ada_Version_Pragma
,
5055 Warnings
=> Save_Warnings
,
5056 SPARK_Mode
=> SPARK_Mode
,
5057 SPARK_Mode_Pragma
=> SPARK_Mode_Pragma
)),
5058 Inlined_Body
=> True);
5060 end Inline_Instance_Body
;
5062 -------------------------------------
5063 -- Analyze_Procedure_Instantiation --
5064 -------------------------------------
5066 procedure Analyze_Procedure_Instantiation
(N
: Node_Id
) is
5068 Analyze_Subprogram_Instantiation
(N
, E_Procedure
);
5069 end Analyze_Procedure_Instantiation
;
5071 -----------------------------------
5072 -- Need_Subprogram_Instance_Body --
5073 -----------------------------------
5075 function Need_Subprogram_Instance_Body
5077 Subp
: Entity_Id
) return Boolean
5079 function Is_Inlined_Or_Child_Of_Inlined
(E
: Entity_Id
) return Boolean;
5080 -- Return True if E is an inlined subprogram, an inlined renaming or a
5081 -- subprogram nested in an inlined subprogram. The inlining machinery
5082 -- totally disregards nested subprograms since it considers that they
5083 -- will always be compiled if the parent is (see Inline.Is_Nested).
5085 ------------------------------------
5086 -- Is_Inlined_Or_Child_Of_Inlined --
5087 ------------------------------------
5089 function Is_Inlined_Or_Child_Of_Inlined
(E
: Entity_Id
) return Boolean is
5093 if Is_Inlined
(E
) or else Is_Inlined
(Alias
(E
)) then
5098 while Scop
/= Standard_Standard
loop
5099 if Ekind
(Scop
) in Subprogram_Kind
and then Is_Inlined
(Scop
) then
5103 Scop
:= Scope
(Scop
);
5107 end Is_Inlined_Or_Child_Of_Inlined
;
5110 -- Must be in the main unit or inlined (or child of inlined)
5112 if (Is_In_Main_Unit
(N
) or else Is_Inlined_Or_Child_Of_Inlined
(Subp
))
5114 -- Must be generating code or analyzing code in ASIS/GNATprove mode
5116 and then (Operating_Mode
= Generate_Code
5117 or else (Operating_Mode
= Check_Semantics
5118 and then (ASIS_Mode
or GNATprove_Mode
)))
5120 -- The body is needed when generating code (full expansion), in ASIS
5121 -- mode for other tools, and in GNATprove mode (special expansion) for
5122 -- formal verification of the body itself.
5124 and then (Expander_Active
or ASIS_Mode
or GNATprove_Mode
)
5126 -- No point in inlining if ABE is inevitable
5128 and then not Is_Known_Guaranteed_ABE
(N
)
5130 -- Or if subprogram is eliminated
5132 and then not Is_Eliminated
(Subp
)
5134 Add_Pending_Instantiation
(N
, Unit_Declaration_Node
(Subp
));
5137 -- Here if not inlined, or we ignore the inlining
5142 end Need_Subprogram_Instance_Body
;
5144 --------------------------------------
5145 -- Analyze_Subprogram_Instantiation --
5146 --------------------------------------
5148 -- WARNING: This routine manages Ghost and SPARK regions. Return statements
5149 -- must be replaced by gotos which jump to the end of the routine in order
5150 -- to restore the Ghost and SPARK modes.
5152 procedure Analyze_Subprogram_Instantiation
5156 Loc
: constant Source_Ptr
:= Sloc
(N
);
5157 Gen_Id
: constant Node_Id
:= Name
(N
);
5158 Errs
: constant Nat
:= Serious_Errors_Detected
;
5160 Anon_Id
: constant Entity_Id
:=
5161 Make_Defining_Identifier
(Sloc
(Defining_Entity
(N
)),
5162 Chars
=> New_External_Name
5163 (Chars
(Defining_Entity
(N
)), 'R'));
5165 Act_Decl_Id
: Entity_Id
:= Empty
; -- init to avoid warning
5170 Env_Installed
: Boolean := False;
5171 Gen_Unit
: Entity_Id
;
5173 Pack_Id
: Entity_Id
;
5174 Parent_Installed
: Boolean := False;
5176 Renaming_List
: List_Id
;
5177 -- The list of declarations that link formals and actuals of the
5178 -- instance. These are subtype declarations for formal types, and
5179 -- renaming declarations for other formals. The subprogram declaration
5180 -- for the instance is then appended to the list, and the last item on
5181 -- the list is the renaming declaration for the instance.
5183 procedure Analyze_Instance_And_Renamings
;
5184 -- The instance must be analyzed in a context that includes the mappings
5185 -- of generic parameters into actuals. We create a package declaration
5186 -- for this purpose, and a subprogram with an internal name within the
5187 -- package. The subprogram instance is simply an alias for the internal
5188 -- subprogram, declared in the current scope.
5190 procedure Build_Subprogram_Renaming
;
5191 -- If the subprogram is recursive, there are occurrences of the name of
5192 -- the generic within the body, which must resolve to the current
5193 -- instance. We add a renaming declaration after the declaration, which
5194 -- is available in the instance body, as well as in the analysis of
5195 -- aspects that appear in the generic. This renaming declaration is
5196 -- inserted after the instance declaration which it renames.
5198 ------------------------------------
5199 -- Analyze_Instance_And_Renamings --
5200 ------------------------------------
5202 procedure Analyze_Instance_And_Renamings
is
5203 Def_Ent
: constant Entity_Id
:= Defining_Entity
(N
);
5204 Pack_Decl
: Node_Id
;
5207 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
5209 -- For the case of a compilation unit, the container package has
5210 -- the same name as the instantiation, to insure that the binder
5211 -- calls the elaboration procedure with the right name. Copy the
5212 -- entity of the instance, which may have compilation level flags
5213 -- (e.g. Is_Child_Unit) set.
5215 Pack_Id
:= New_Copy
(Def_Ent
);
5218 -- Otherwise we use the name of the instantiation concatenated
5219 -- with its source position to ensure uniqueness if there are
5220 -- several instantiations with the same name.
5223 Make_Defining_Identifier
(Loc
,
5224 Chars
=> New_External_Name
5225 (Related_Id
=> Chars
(Def_Ent
),
5227 Suffix_Index
=> Source_Offset
(Sloc
(Def_Ent
))));
5231 Make_Package_Declaration
(Loc
,
5232 Specification
=> Make_Package_Specification
(Loc
,
5233 Defining_Unit_Name
=> Pack_Id
,
5234 Visible_Declarations
=> Renaming_List
,
5235 End_Label
=> Empty
));
5237 Set_Instance_Spec
(N
, Pack_Decl
);
5238 Set_Is_Generic_Instance
(Pack_Id
);
5239 Set_Debug_Info_Needed
(Pack_Id
);
5241 -- Case of not a compilation unit
5243 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
5244 Mark_Rewrite_Insertion
(Pack_Decl
);
5245 Insert_Before
(N
, Pack_Decl
);
5246 Set_Has_Completion
(Pack_Id
);
5248 -- Case of an instantiation that is a compilation unit
5250 -- Place declaration on current node so context is complete for
5251 -- analysis (including nested instantiations), and for use in a
5252 -- context_clause (see Analyze_With_Clause).
5255 Set_Unit
(Parent
(N
), Pack_Decl
);
5256 Set_Parent_Spec
(Pack_Decl
, Parent_Spec
(N
));
5259 Analyze
(Pack_Decl
);
5260 Check_Formal_Packages
(Pack_Id
);
5261 Set_Is_Generic_Instance
(Pack_Id
, False);
5263 -- Why do we clear Is_Generic_Instance??? We set it 20 lines
5266 -- Body of the enclosing package is supplied when instantiating the
5267 -- subprogram body, after semantic analysis is completed.
5269 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
5271 -- Remove package itself from visibility, so it does not
5272 -- conflict with subprogram.
5274 Set_Name_Entity_Id
(Chars
(Pack_Id
), Homonym
(Pack_Id
));
5276 -- Set name and scope of internal subprogram so that the proper
5277 -- external name will be generated. The proper scope is the scope
5278 -- of the wrapper package. We need to generate debugging info for
5279 -- the internal subprogram, so set flag accordingly.
5281 Set_Chars
(Anon_Id
, Chars
(Defining_Entity
(N
)));
5282 Set_Scope
(Anon_Id
, Scope
(Pack_Id
));
5284 -- Mark wrapper package as referenced, to avoid spurious warnings
5285 -- if the instantiation appears in various with_ clauses of
5286 -- subunits of the main unit.
5288 Set_Referenced
(Pack_Id
);
5291 Set_Is_Generic_Instance
(Anon_Id
);
5292 Set_Debug_Info_Needed
(Anon_Id
);
5293 Act_Decl_Id
:= New_Copy
(Anon_Id
);
5295 Set_Parent
(Act_Decl_Id
, Parent
(Anon_Id
));
5296 Set_Chars
(Act_Decl_Id
, Chars
(Defining_Entity
(N
)));
5297 Set_Sloc
(Act_Decl_Id
, Sloc
(Defining_Entity
(N
)));
5299 -- Subprogram instance comes from source only if generic does
5301 Set_Comes_From_Source
(Act_Decl_Id
, Comes_From_Source
(Gen_Unit
));
5303 -- If the instance is a child unit, mark the Id accordingly. Mark
5304 -- the anonymous entity as well, which is the real subprogram and
5305 -- which is used when the instance appears in a context clause.
5306 -- Similarly, propagate the Is_Eliminated flag to handle properly
5307 -- nested eliminated subprograms.
5309 Set_Is_Child_Unit
(Act_Decl_Id
, Is_Child_Unit
(Defining_Entity
(N
)));
5310 Set_Is_Child_Unit
(Anon_Id
, Is_Child_Unit
(Defining_Entity
(N
)));
5311 New_Overloaded_Entity
(Act_Decl_Id
);
5312 Check_Eliminated
(Act_Decl_Id
);
5313 Set_Is_Eliminated
(Anon_Id
, Is_Eliminated
(Act_Decl_Id
));
5315 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
5317 -- In compilation unit case, kill elaboration checks on the
5318 -- instantiation, since they are never needed - the body is
5319 -- instantiated at the same point as the spec.
5321 if Legacy_Elaboration_Checks
then
5322 Set_Kill_Elaboration_Checks
(Act_Decl_Id
);
5323 Set_Suppress_Elaboration_Warnings
(Act_Decl_Id
);
5326 Set_Is_Compilation_Unit
(Anon_Id
);
5327 Set_Cunit_Entity
(Current_Sem_Unit
, Pack_Id
);
5330 -- The instance is not a freezing point for the new subprogram.
5331 -- The anonymous subprogram may have a freeze node, created for
5332 -- some delayed aspects. This freeze node must not be inherited
5333 -- by the visible subprogram entity.
5335 Set_Is_Frozen
(Act_Decl_Id
, False);
5336 Set_Freeze_Node
(Act_Decl_Id
, Empty
);
5338 if Nkind
(Defining_Entity
(N
)) = N_Defining_Operator_Symbol
then
5339 Valid_Operator_Definition
(Act_Decl_Id
);
5342 Set_Alias
(Act_Decl_Id
, Anon_Id
);
5343 Set_Has_Completion
(Act_Decl_Id
);
5344 Set_Related_Instance
(Pack_Id
, Act_Decl_Id
);
5346 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
5347 Set_Body_Required
(Parent
(N
), False);
5349 end Analyze_Instance_And_Renamings
;
5351 -------------------------------
5352 -- Build_Subprogram_Renaming --
5353 -------------------------------
5355 procedure Build_Subprogram_Renaming
is
5356 Renaming_Decl
: Node_Id
;
5357 Unit_Renaming
: Node_Id
;
5361 Make_Subprogram_Renaming_Declaration
(Loc
,
5364 (Specification
(Original_Node
(Gen_Decl
)),
5366 Instantiating
=> True),
5367 Name
=> New_Occurrence_Of
(Anon_Id
, Loc
));
5369 -- The generic may be a a child unit. The renaming needs an
5370 -- identifier with the proper name.
5372 Set_Defining_Unit_Name
(Specification
(Unit_Renaming
),
5373 Make_Defining_Identifier
(Loc
, Chars
(Gen_Unit
)));
5375 -- If there is a formal subprogram with the same name as the unit
5376 -- itself, do not add this renaming declaration, to prevent
5377 -- ambiguities when there is a call with that name in the body.
5378 -- This is a partial and ugly fix for one ACATS test. ???
5380 Renaming_Decl
:= First
(Renaming_List
);
5381 while Present
(Renaming_Decl
) loop
5382 if Nkind
(Renaming_Decl
) = N_Subprogram_Renaming_Declaration
5384 Chars
(Defining_Entity
(Renaming_Decl
)) = Chars
(Gen_Unit
)
5389 Next
(Renaming_Decl
);
5392 if No
(Renaming_Decl
) then
5393 Append
(Unit_Renaming
, Renaming_List
);
5395 end Build_Subprogram_Renaming
;
5399 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
5400 Saved_ISMP
: constant Boolean :=
5401 Ignore_SPARK_Mode_Pragmas_In_Instance
;
5402 Saved_SM
: constant SPARK_Mode_Type
:= SPARK_Mode
;
5403 Saved_SMP
: constant Node_Id
:= SPARK_Mode_Pragma
;
5404 -- Save the Ghost and SPARK mode-related data to restore on exit
5406 Vis_Prims_List
: Elist_Id
:= No_Elist
;
5407 -- List of primitives made temporarily visible in the instantiation
5408 -- to match the visibility of the formal type
5410 -- Start of processing for Analyze_Subprogram_Instantiation
5413 -- Preserve relevant elaboration-related attributes of the context which
5414 -- are no longer available or very expensive to recompute once analysis,
5415 -- resolution, and expansion are over.
5417 Mark_Elaboration_Attributes
5424 Check_SPARK_05_Restriction
("generic is not allowed", N
);
5426 -- Very first thing: check for special Text_IO unit in case we are
5427 -- instantiating one of the children of [[Wide_]Wide_]Text_IO. Of course
5428 -- such an instantiation is bogus (these are packages, not subprograms),
5429 -- but we get a better error message if we do this.
5431 Check_Text_IO_Special_Unit
(Gen_Id
);
5433 -- Make node global for error reporting
5435 Instantiation_Node
:= N
;
5437 -- For package instantiations we turn off style checks, because they
5438 -- will have been emitted in the generic. For subprogram instantiations
5439 -- we want to apply at least the check on overriding indicators so we
5440 -- do not modify the style check status.
5442 -- The renaming declarations for the actuals do not come from source and
5443 -- will not generate spurious warnings.
5445 Preanalyze_Actuals
(N
);
5448 Env_Installed
:= True;
5449 Check_Generic_Child_Unit
(Gen_Id
, Parent_Installed
);
5450 Gen_Unit
:= Entity
(Gen_Id
);
5452 -- A subprogram instantiation is Ghost when it is subject to pragma
5453 -- Ghost or the generic template is Ghost. Set the mode now to ensure
5454 -- that any nodes generated during analysis and expansion are marked as
5457 Mark_And_Set_Ghost_Instantiation
(N
, Gen_Unit
);
5459 Generate_Reference
(Gen_Unit
, Gen_Id
);
5461 if Nkind
(Gen_Id
) = N_Identifier
5462 and then Chars
(Gen_Unit
) = Chars
(Defining_Entity
(N
))
5465 ("& is hidden within declaration of instance", Gen_Id
, Gen_Unit
);
5468 if Etype
(Gen_Unit
) = Any_Type
then
5473 -- Verify that it is a generic subprogram of the right kind, and that
5474 -- it does not lead to a circular instantiation.
5476 if K
= E_Procedure
and then Ekind
(Gen_Unit
) /= E_Generic_Procedure
then
5478 ("& is not the name of a generic procedure", Gen_Id
, Gen_Unit
);
5480 elsif K
= E_Function
and then Ekind
(Gen_Unit
) /= E_Generic_Function
then
5482 ("& is not the name of a generic function", Gen_Id
, Gen_Unit
);
5484 elsif In_Open_Scopes
(Gen_Unit
) then
5485 Error_Msg_NE
("instantiation of & within itself", N
, Gen_Unit
);
5488 Set_Entity
(Gen_Id
, Gen_Unit
);
5489 Set_Is_Instantiated
(Gen_Unit
);
5491 if In_Extended_Main_Source_Unit
(N
) then
5492 Generate_Reference
(Gen_Unit
, N
);
5495 -- If renaming, get original unit
5497 if Present
(Renamed_Object
(Gen_Unit
))
5498 and then Ekind_In
(Renamed_Object
(Gen_Unit
), E_Generic_Procedure
,
5501 Gen_Unit
:= Renamed_Object
(Gen_Unit
);
5502 Set_Is_Instantiated
(Gen_Unit
);
5503 Generate_Reference
(Gen_Unit
, N
);
5506 if Contains_Instance_Of
(Gen_Unit
, Current_Scope
, Gen_Id
) then
5507 Error_Msg_Node_2
:= Current_Scope
;
5509 ("circular Instantiation: & instantiated in &!", N
, Gen_Unit
);
5510 Circularity_Detected
:= True;
5511 Restore_Hidden_Primitives
(Vis_Prims_List
);
5515 Gen_Decl
:= Unit_Declaration_Node
(Gen_Unit
);
5517 -- Initialize renamings map, for error checking
5519 Generic_Renamings
.Set_Last
(0);
5520 Generic_Renamings_HTable
.Reset
;
5522 Create_Instantiation_Source
(N
, Gen_Unit
, S_Adjustment
);
5524 -- Copy original generic tree, to produce text for instantiation
5528 (Original_Node
(Gen_Decl
), Empty
, Instantiating
=> True);
5530 -- Inherit overriding indicator from instance node
5532 Act_Spec
:= Specification
(Act_Tree
);
5533 Set_Must_Override
(Act_Spec
, Must_Override
(N
));
5534 Set_Must_Not_Override
(Act_Spec
, Must_Not_Override
(N
));
5537 Analyze_Associations
5539 Formals
=> Generic_Formal_Declarations
(Act_Tree
),
5540 F_Copy
=> Generic_Formal_Declarations
(Gen_Decl
));
5542 Vis_Prims_List
:= Check_Hidden_Primitives
(Renaming_List
);
5544 -- The subprogram itself cannot contain a nested instance, so the
5545 -- current parent is left empty.
5547 Set_Instance_Env
(Gen_Unit
, Empty
);
5549 -- Build the subprogram declaration, which does not appear in the
5550 -- generic template, and give it a sloc consistent with that of the
5553 Set_Defining_Unit_Name
(Act_Spec
, Anon_Id
);
5554 Set_Generic_Parent
(Act_Spec
, Gen_Unit
);
5556 Make_Subprogram_Declaration
(Sloc
(Act_Spec
),
5557 Specification
=> Act_Spec
);
5559 -- The aspects have been copied previously, but they have to be
5560 -- linked explicitly to the new subprogram declaration. Explicit
5561 -- pre/postconditions on the instance are analyzed below, in a
5564 Move_Aspects
(Act_Tree
, To
=> Act_Decl
);
5565 Set_Categorization_From_Pragmas
(Act_Decl
);
5567 if Parent_Installed
then
5571 Append
(Act_Decl
, Renaming_List
);
5573 -- Contract-related source pragmas that follow a generic subprogram
5574 -- must be instantiated explicitly because they are not part of the
5575 -- subprogram template.
5577 Instantiate_Subprogram_Contract
5578 (Original_Node
(Gen_Decl
), Renaming_List
);
5580 Build_Subprogram_Renaming
;
5582 -- If the context of the instance is subject to SPARK_Mode "off" or
5583 -- the annotation is altogether missing, set the global flag which
5584 -- signals Analyze_Pragma to ignore all SPARK_Mode pragmas within
5585 -- the instance. This should be done prior to analyzing the instance.
5587 if SPARK_Mode
/= On
then
5588 Ignore_SPARK_Mode_Pragmas_In_Instance
:= True;
5591 -- If the context of an instance is not subject to SPARK_Mode "off",
5592 -- and the generic spec is subject to an explicit SPARK_Mode pragma,
5593 -- the latter should be the one applicable to the instance.
5595 if not Ignore_SPARK_Mode_Pragmas_In_Instance
5596 and then Saved_SM
/= Off
5597 and then Present
(SPARK_Pragma
(Gen_Unit
))
5599 Set_SPARK_Mode
(Gen_Unit
);
5602 Analyze_Instance_And_Renamings
;
5604 -- Restore SPARK_Mode from the context after analysis of the package
5605 -- declaration, so that the SPARK_Mode on the generic spec does not
5606 -- apply to the pending instance for the instance body.
5608 if not Ignore_SPARK_Mode_Pragmas_In_Instance
5609 and then Saved_SM
/= Off
5610 and then Present
(SPARK_Pragma
(Gen_Unit
))
5612 Restore_SPARK_Mode
(Saved_SM
, Saved_SMP
);
5615 -- If the generic is marked Import (Intrinsic), then so is the
5616 -- instance. This indicates that there is no body to instantiate. If
5617 -- generic is marked inline, so it the instance, and the anonymous
5618 -- subprogram it renames. If inlined, or else if inlining is enabled
5619 -- for the compilation, we generate the instance body even if it is
5620 -- not within the main unit.
5622 if Is_Intrinsic_Subprogram
(Gen_Unit
) then
5623 Set_Is_Intrinsic_Subprogram
(Anon_Id
);
5624 Set_Is_Intrinsic_Subprogram
(Act_Decl_Id
);
5626 if Chars
(Gen_Unit
) = Name_Unchecked_Conversion
then
5627 Validate_Unchecked_Conversion
(N
, Act_Decl_Id
);
5631 -- Inherit convention from generic unit. Intrinsic convention, as for
5632 -- an instance of unchecked conversion, is not inherited because an
5633 -- explicit Ada instance has been created.
5635 if Has_Convention_Pragma
(Gen_Unit
)
5636 and then Convention
(Gen_Unit
) /= Convention_Intrinsic
5638 Set_Convention
(Act_Decl_Id
, Convention
(Gen_Unit
));
5639 Set_Is_Exported
(Act_Decl_Id
, Is_Exported
(Gen_Unit
));
5642 Generate_Definition
(Act_Decl_Id
);
5644 -- Inherit all inlining-related flags which apply to the generic in
5645 -- the subprogram and its declaration.
5647 Set_Is_Inlined
(Act_Decl_Id
, Is_Inlined
(Gen_Unit
));
5648 Set_Is_Inlined
(Anon_Id
, Is_Inlined
(Gen_Unit
));
5650 Set_Has_Pragma_Inline
(Act_Decl_Id
, Has_Pragma_Inline
(Gen_Unit
));
5651 Set_Has_Pragma_Inline
(Anon_Id
, Has_Pragma_Inline
(Gen_Unit
));
5653 -- Propagate No_Return if pragma applied to generic unit. This must
5654 -- be done explicitly because pragma does not appear in generic
5655 -- declaration (unlike the aspect case).
5657 if No_Return
(Gen_Unit
) then
5658 Set_No_Return
(Act_Decl_Id
);
5659 Set_No_Return
(Anon_Id
);
5662 Set_Has_Pragma_Inline_Always
5663 (Act_Decl_Id
, Has_Pragma_Inline_Always
(Gen_Unit
));
5664 Set_Has_Pragma_Inline_Always
5665 (Anon_Id
, Has_Pragma_Inline_Always
(Gen_Unit
));
5667 -- Mark both the instance spec and the anonymous package in case the
5668 -- body is instantiated at a later pass. This preserves the original
5669 -- context in effect for the body.
5671 if SPARK_Mode
/= On
then
5672 Set_Ignore_SPARK_Mode_Pragmas
(Act_Decl_Id
);
5673 Set_Ignore_SPARK_Mode_Pragmas
(Anon_Id
);
5676 if Legacy_Elaboration_Checks
5677 and then not Is_Intrinsic_Subprogram
(Gen_Unit
)
5679 Check_Elab_Instantiation
(N
);
5682 -- Save the scenario for later examination by the ABE Processing
5685 Record_Elaboration_Scenario
(N
);
5687 -- The instantiation results in a guaranteed ABE. Create a completing
5688 -- body for the subprogram declaration because the real body will not
5691 if Is_Known_Guaranteed_ABE
(N
) then
5692 Provide_Completing_Bodies
(Instance_Spec
(N
));
5695 if Is_Dispatching_Operation
(Act_Decl_Id
)
5696 and then Ada_Version
>= Ada_2005
5702 Formal
:= First_Formal
(Act_Decl_Id
);
5703 while Present
(Formal
) loop
5704 if Ekind
(Etype
(Formal
)) = E_Anonymous_Access_Type
5705 and then Is_Controlling_Formal
(Formal
)
5706 and then not Can_Never_Be_Null
(Formal
)
5709 ("access parameter& is controlling,", N
, Formal
);
5711 ("\corresponding parameter of & must be explicitly "
5712 & "null-excluding", N
, Gen_Id
);
5715 Next_Formal
(Formal
);
5720 Check_Hidden_Child_Unit
(N
, Gen_Unit
, Act_Decl_Id
);
5722 Validate_Categorization_Dependency
(N
, Act_Decl_Id
);
5724 if not Is_Intrinsic_Subprogram
(Act_Decl_Id
) then
5725 Inherit_Context
(Gen_Decl
, N
);
5727 Restore_Private_Views
(Pack_Id
, False);
5729 -- If the context requires a full instantiation, mark node for
5730 -- subsequent construction of the body.
5732 if Need_Subprogram_Instance_Body
(N
, Act_Decl_Id
) then
5733 Check_Forward_Instantiation
(Gen_Decl
);
5735 -- The wrapper package is always delayed, because it does not
5736 -- constitute a freeze point, but to insure that the freeze node
5737 -- is placed properly, it is created directly when instantiating
5738 -- the body (otherwise the freeze node might appear to early for
5739 -- nested instantiations). For ASIS purposes, indicate that the
5740 -- wrapper package has replaced the instantiation node.
5742 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
then
5743 Rewrite
(N
, Unit
(Parent
(N
)));
5744 Set_Unit
(Parent
(N
), N
);
5747 -- Replace instance node for library-level instantiations of
5748 -- intrinsic subprograms, for ASIS use.
5750 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
then
5751 Rewrite
(N
, Unit
(Parent
(N
)));
5752 Set_Unit
(Parent
(N
), N
);
5755 if Parent_Installed
then
5759 Restore_Hidden_Primitives
(Vis_Prims_List
);
5761 Env_Installed
:= False;
5762 Generic_Renamings
.Set_Last
(0);
5763 Generic_Renamings_HTable
.Reset
;
5767 -- Analyze aspects in declaration if no errors appear in the instance.
5769 if Has_Aspects
(N
) and then Serious_Errors_Detected
= Errs
then
5770 Analyze_Aspect_Specifications
(N
, Act_Decl_Id
);
5773 Ignore_SPARK_Mode_Pragmas_In_Instance
:= Saved_ISMP
;
5774 Restore_Ghost_Mode
(Saved_GM
);
5775 Restore_SPARK_Mode
(Saved_SM
, Saved_SMP
);
5778 when Instantiation_Error
=>
5779 if Parent_Installed
then
5783 if Env_Installed
then
5787 Ignore_SPARK_Mode_Pragmas_In_Instance
:= Saved_ISMP
;
5788 Restore_Ghost_Mode
(Saved_GM
);
5789 Restore_SPARK_Mode
(Saved_SM
, Saved_SMP
);
5790 end Analyze_Subprogram_Instantiation
;
5792 -------------------------
5793 -- Get_Associated_Node --
5794 -------------------------
5796 function Get_Associated_Node
(N
: Node_Id
) return Node_Id
is
5800 Assoc
:= Associated_Node
(N
);
5802 if Nkind
(Assoc
) /= Nkind
(N
) then
5805 elsif Nkind_In
(Assoc
, N_Aggregate
, N_Extension_Aggregate
) then
5809 -- If the node is part of an inner generic, it may itself have been
5810 -- remapped into a further generic copy. Associated_Node is otherwise
5811 -- used for the entity of the node, and will be of a different node
5812 -- kind, or else N has been rewritten as a literal or function call.
5814 while Present
(Associated_Node
(Assoc
))
5815 and then Nkind
(Associated_Node
(Assoc
)) = Nkind
(Assoc
)
5817 Assoc
:= Associated_Node
(Assoc
);
5820 -- Follow an additional link in case the final node was rewritten.
5821 -- This can only happen with nested generic units.
5823 if (Nkind
(Assoc
) = N_Identifier
or else Nkind
(Assoc
) in N_Op
)
5824 and then Present
(Associated_Node
(Assoc
))
5825 and then (Nkind_In
(Associated_Node
(Assoc
), N_Function_Call
,
5826 N_Explicit_Dereference
,
5831 Assoc
:= Associated_Node
(Assoc
);
5834 -- An additional special case: an unconstrained type in an object
5835 -- declaration may have been rewritten as a local subtype constrained
5836 -- by the expression in the declaration. We need to recover the
5837 -- original entity, which may be global.
5839 if Present
(Original_Node
(Assoc
))
5840 and then Nkind
(Parent
(N
)) = N_Object_Declaration
5842 Assoc
:= Original_Node
(Assoc
);
5847 end Get_Associated_Node
;
5849 ----------------------------
5850 -- Build_Function_Wrapper --
5851 ----------------------------
5853 function Build_Function_Wrapper
5854 (Formal_Subp
: Entity_Id
;
5855 Actual_Subp
: Entity_Id
) return Node_Id
5857 Loc
: constant Source_Ptr
:= Sloc
(Current_Scope
);
5858 Ret_Type
: constant Entity_Id
:= Get_Instance_Of
(Etype
(Formal_Subp
));
5861 Func_Name
: Node_Id
;
5863 Parm_Type
: Node_Id
;
5864 Profile
: List_Id
:= New_List
;
5871 Func_Name
:= New_Occurrence_Of
(Actual_Subp
, Loc
);
5873 Func
:= Make_Defining_Identifier
(Loc
, Chars
(Formal_Subp
));
5874 Set_Ekind
(Func
, E_Function
);
5875 Set_Is_Generic_Actual_Subprogram
(Func
);
5877 Actuals
:= New_List
;
5878 Profile
:= New_List
;
5880 Act_F
:= First_Formal
(Actual_Subp
);
5881 Form_F
:= First_Formal
(Formal_Subp
);
5882 while Present
(Form_F
) loop
5884 -- Create new formal for profile of wrapper, and add a reference
5885 -- to it in the list of actuals for the enclosing call. The name
5886 -- must be that of the formal in the formal subprogram, because
5887 -- calls to it in the generic body may use named associations.
5889 New_F
:= Make_Defining_Identifier
(Loc
, Chars
(Form_F
));
5892 New_Occurrence_Of
(Get_Instance_Of
(Etype
(Form_F
)), Loc
);
5895 Make_Parameter_Specification
(Loc
,
5896 Defining_Identifier
=> New_F
,
5897 Parameter_Type
=> Parm_Type
));
5899 Append_To
(Actuals
, New_Occurrence_Of
(New_F
, Loc
));
5900 Next_Formal
(Form_F
);
5902 if Present
(Act_F
) then
5903 Next_Formal
(Act_F
);
5908 Make_Function_Specification
(Loc
,
5909 Defining_Unit_Name
=> Func
,
5910 Parameter_Specifications
=> Profile
,
5911 Result_Definition
=> New_Occurrence_Of
(Ret_Type
, Loc
));
5914 Make_Expression_Function
(Loc
,
5915 Specification
=> Spec
,
5917 Make_Function_Call
(Loc
,
5919 Parameter_Associations
=> Actuals
));
5922 end Build_Function_Wrapper
;
5924 ----------------------------
5925 -- Build_Operator_Wrapper --
5926 ----------------------------
5928 function Build_Operator_Wrapper
5929 (Formal_Subp
: Entity_Id
;
5930 Actual_Subp
: Entity_Id
) return Node_Id
5932 Loc
: constant Source_Ptr
:= Sloc
(Current_Scope
);
5933 Ret_Type
: constant Entity_Id
:=
5934 Get_Instance_Of
(Etype
(Formal_Subp
));
5935 Op_Type
: constant Entity_Id
:=
5936 Get_Instance_Of
(Etype
(First_Formal
(Formal_Subp
)));
5937 Is_Binary
: constant Boolean :=
5938 Present
(Next_Formal
(First_Formal
(Formal_Subp
)));
5941 Expr
: Node_Id
:= Empty
;
5949 Op_Name
:= Chars
(Actual_Subp
);
5951 -- Create entities for wrapper function and its formals
5953 F1
:= Make_Temporary
(Loc
, 'A');
5954 F2
:= Make_Temporary
(Loc
, 'B');
5955 L
:= New_Occurrence_Of
(F1
, Loc
);
5956 R
:= New_Occurrence_Of
(F2
, Loc
);
5958 Func
:= Make_Defining_Identifier
(Loc
, Chars
(Formal_Subp
));
5959 Set_Ekind
(Func
, E_Function
);
5960 Set_Is_Generic_Actual_Subprogram
(Func
);
5963 Make_Function_Specification
(Loc
,
5964 Defining_Unit_Name
=> Func
,
5965 Parameter_Specifications
=> New_List
(
5966 Make_Parameter_Specification
(Loc
,
5967 Defining_Identifier
=> F1
,
5968 Parameter_Type
=> New_Occurrence_Of
(Op_Type
, Loc
))),
5969 Result_Definition
=> New_Occurrence_Of
(Ret_Type
, Loc
));
5972 Append_To
(Parameter_Specifications
(Spec
),
5973 Make_Parameter_Specification
(Loc
,
5974 Defining_Identifier
=> F2
,
5975 Parameter_Type
=> New_Occurrence_Of
(Op_Type
, Loc
)));
5978 -- Build expression as a function call, or as an operator node
5979 -- that corresponds to the name of the actual, starting with
5980 -- binary operators.
5982 if Op_Name
not in Any_Operator_Name
then
5984 Make_Function_Call
(Loc
,
5986 New_Occurrence_Of
(Actual_Subp
, Loc
),
5987 Parameter_Associations
=> New_List
(L
));
5990 Append_To
(Parameter_Associations
(Expr
), R
);
5995 elsif Is_Binary
then
5996 if Op_Name
= Name_Op_And
then
5997 Expr
:= Make_Op_And
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
5998 elsif Op_Name
= Name_Op_Or
then
5999 Expr
:= Make_Op_Or
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
6000 elsif Op_Name
= Name_Op_Xor
then
6001 Expr
:= Make_Op_Xor
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
6002 elsif Op_Name
= Name_Op_Eq
then
6003 Expr
:= Make_Op_Eq
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
6004 elsif Op_Name
= Name_Op_Ne
then
6005 Expr
:= Make_Op_Ne
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
6006 elsif Op_Name
= Name_Op_Le
then
6007 Expr
:= Make_Op_Le
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
6008 elsif Op_Name
= Name_Op_Gt
then
6009 Expr
:= Make_Op_Gt
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
6010 elsif Op_Name
= Name_Op_Ge
then
6011 Expr
:= Make_Op_Ge
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
6012 elsif Op_Name
= Name_Op_Lt
then
6013 Expr
:= Make_Op_Lt
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
6014 elsif Op_Name
= Name_Op_Add
then
6015 Expr
:= Make_Op_Add
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
6016 elsif Op_Name
= Name_Op_Subtract
then
6017 Expr
:= Make_Op_Subtract
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
6018 elsif Op_Name
= Name_Op_Concat
then
6019 Expr
:= Make_Op_Concat
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
6020 elsif Op_Name
= Name_Op_Multiply
then
6021 Expr
:= Make_Op_Multiply
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
6022 elsif Op_Name
= Name_Op_Divide
then
6023 Expr
:= Make_Op_Divide
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
6024 elsif Op_Name
= Name_Op_Mod
then
6025 Expr
:= Make_Op_Mod
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
6026 elsif Op_Name
= Name_Op_Rem
then
6027 Expr
:= Make_Op_Rem
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
6028 elsif Op_Name
= Name_Op_Expon
then
6029 Expr
:= Make_Op_Expon
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
6035 if Op_Name
= Name_Op_Add
then
6036 Expr
:= Make_Op_Plus
(Loc
, Right_Opnd
=> L
);
6037 elsif Op_Name
= Name_Op_Subtract
then
6038 Expr
:= Make_Op_Minus
(Loc
, Right_Opnd
=> L
);
6039 elsif Op_Name
= Name_Op_Abs
then
6040 Expr
:= Make_Op_Abs
(Loc
, Right_Opnd
=> L
);
6041 elsif Op_Name
= Name_Op_Not
then
6042 Expr
:= Make_Op_Not
(Loc
, Right_Opnd
=> L
);
6047 Make_Expression_Function
(Loc
,
6048 Specification
=> Spec
,
6049 Expression
=> Expr
);
6052 end Build_Operator_Wrapper
;
6054 -------------------------------------------
6055 -- Build_Instance_Compilation_Unit_Nodes --
6056 -------------------------------------------
6058 procedure Build_Instance_Compilation_Unit_Nodes
6063 Decl_Cunit
: Node_Id
;
6064 Body_Cunit
: Node_Id
;
6066 New_Main
: constant Entity_Id
:= Defining_Entity
(Act_Decl
);
6067 Old_Main
: constant Entity_Id
:= Cunit_Entity
(Main_Unit
);
6070 -- A new compilation unit node is built for the instance declaration
6073 Make_Compilation_Unit
(Sloc
(N
),
6074 Context_Items
=> Empty_List
,
6076 Aux_Decls_Node
=> Make_Compilation_Unit_Aux
(Sloc
(N
)));
6078 Set_Parent_Spec
(Act_Decl
, Parent_Spec
(N
));
6080 -- The new compilation unit is linked to its body, but both share the
6081 -- same file, so we do not set Body_Required on the new unit so as not
6082 -- to create a spurious dependency on a non-existent body in the ali.
6083 -- This simplifies CodePeer unit traversal.
6085 -- We use the original instantiation compilation unit as the resulting
6086 -- compilation unit of the instance, since this is the main unit.
6088 Rewrite
(N
, Act_Body
);
6090 -- Propagate the aspect specifications from the package body template to
6091 -- the instantiated version of the package body.
6093 if Has_Aspects
(Act_Body
) then
6094 Set_Aspect_Specifications
6095 (N
, New_Copy_List_Tree
(Aspect_Specifications
(Act_Body
)));
6098 Body_Cunit
:= Parent
(N
);
6100 -- The two compilation unit nodes are linked by the Library_Unit field
6102 Set_Library_Unit
(Decl_Cunit
, Body_Cunit
);
6103 Set_Library_Unit
(Body_Cunit
, Decl_Cunit
);
6105 -- Preserve the private nature of the package if needed
6107 Set_Private_Present
(Decl_Cunit
, Private_Present
(Body_Cunit
));
6109 -- If the instance is not the main unit, its context, categorization
6110 -- and elaboration entity are not relevant to the compilation.
6112 if Body_Cunit
/= Cunit
(Main_Unit
) then
6113 Make_Instance_Unit
(Body_Cunit
, In_Main
=> False);
6117 -- The context clause items on the instantiation, which are now attached
6118 -- to the body compilation unit (since the body overwrote the original
6119 -- instantiation node), semantically belong on the spec, so copy them
6120 -- there. It's harmless to leave them on the body as well. In fact one
6121 -- could argue that they belong in both places.
6123 Citem
:= First
(Context_Items
(Body_Cunit
));
6124 while Present
(Citem
) loop
6125 Append
(New_Copy
(Citem
), Context_Items
(Decl_Cunit
));
6129 -- Propagate categorization flags on packages, so that they appear in
6130 -- the ali file for the spec of the unit.
6132 if Ekind
(New_Main
) = E_Package
then
6133 Set_Is_Pure
(Old_Main
, Is_Pure
(New_Main
));
6134 Set_Is_Preelaborated
(Old_Main
, Is_Preelaborated
(New_Main
));
6135 Set_Is_Remote_Types
(Old_Main
, Is_Remote_Types
(New_Main
));
6136 Set_Is_Shared_Passive
(Old_Main
, Is_Shared_Passive
(New_Main
));
6137 Set_Is_Remote_Call_Interface
6138 (Old_Main
, Is_Remote_Call_Interface
(New_Main
));
6141 -- Make entry in Units table, so that binder can generate call to
6142 -- elaboration procedure for body, if any.
6144 Make_Instance_Unit
(Body_Cunit
, In_Main
=> True);
6145 Main_Unit_Entity
:= New_Main
;
6146 Set_Cunit_Entity
(Main_Unit
, Main_Unit_Entity
);
6148 -- Build elaboration entity, since the instance may certainly generate
6149 -- elaboration code requiring a flag for protection.
6151 Build_Elaboration_Entity
(Decl_Cunit
, New_Main
);
6152 end Build_Instance_Compilation_Unit_Nodes
;
6154 -----------------------------
6155 -- Check_Access_Definition --
6156 -----------------------------
6158 procedure Check_Access_Definition
(N
: Node_Id
) is
6161 (Ada_Version
>= Ada_2005
and then Present
(Access_Definition
(N
)));
6163 end Check_Access_Definition
;
6165 -----------------------------------
6166 -- Check_Formal_Package_Instance --
6167 -----------------------------------
6169 -- If the formal has specific parameters, they must match those of the
6170 -- actual. Both of them are instances, and the renaming declarations for
6171 -- their formal parameters appear in the same order in both. The analyzed
6172 -- formal has been analyzed in the context of the current instance.
6174 procedure Check_Formal_Package_Instance
6175 (Formal_Pack
: Entity_Id
;
6176 Actual_Pack
: Entity_Id
)
6178 E1
: Entity_Id
:= First_Entity
(Actual_Pack
);
6179 E2
: Entity_Id
:= First_Entity
(Formal_Pack
);
6180 Prev_E1
: Entity_Id
;
6185 procedure Check_Mismatch
(B
: Boolean);
6186 -- Common error routine for mismatch between the parameters of the
6187 -- actual instance and those of the formal package.
6189 function Same_Instantiated_Constant
(E1
, E2
: Entity_Id
) return Boolean;
6190 -- The formal may come from a nested formal package, and the actual may
6191 -- have been constant-folded. To determine whether the two denote the
6192 -- same entity we may have to traverse several definitions to recover
6193 -- the ultimate entity that they refer to.
6195 function Same_Instantiated_Function
(E1
, E2
: Entity_Id
) return Boolean;
6196 -- The formal and the actual must be identical, but if both are
6197 -- given by attributes they end up renaming different generated bodies,
6198 -- and we must verify that the attributes themselves match.
6200 function Same_Instantiated_Variable
(E1
, E2
: Entity_Id
) return Boolean;
6201 -- Similarly, if the formal comes from a nested formal package, the
6202 -- actual may designate the formal through multiple renamings, which
6203 -- have to be followed to determine the original variable in question.
6205 --------------------
6206 -- Check_Mismatch --
6207 --------------------
6209 procedure Check_Mismatch
(B
: Boolean) is
6210 -- A Formal_Type_Declaration for a derived private type is rewritten
6211 -- as a private extension decl. (see Analyze_Formal_Derived_Type),
6212 -- which is why we examine the original node.
6214 Kind
: constant Node_Kind
:= Nkind
(Original_Node
(Parent
(E2
)));
6217 if Kind
= N_Formal_Type_Declaration
then
6220 elsif Nkind_In
(Kind
, N_Formal_Object_Declaration
,
6221 N_Formal_Package_Declaration
)
6222 or else Kind
in N_Formal_Subprogram_Declaration
6226 -- Ada 2012: If both formal and actual are incomplete types they
6229 elsif Is_Incomplete_Type
(E1
) and then Is_Incomplete_Type
(E2
) then
6234 ("actual for & in actual instance does not match formal",
6235 Parent
(Actual_Pack
), E1
);
6239 --------------------------------
6240 -- Same_Instantiated_Constant --
6241 --------------------------------
6243 function Same_Instantiated_Constant
6244 (E1
, E2
: Entity_Id
) return Boolean
6250 while Present
(Ent
) loop
6254 elsif Ekind
(Ent
) /= E_Constant
then
6257 elsif Is_Entity_Name
(Constant_Value
(Ent
)) then
6258 if Entity
(Constant_Value
(Ent
)) = E1
then
6261 Ent
:= Entity
(Constant_Value
(Ent
));
6264 -- The actual may be a constant that has been folded. Recover
6267 elsif Is_Entity_Name
(Original_Node
(Constant_Value
(Ent
))) then
6268 Ent
:= Entity
(Original_Node
(Constant_Value
(Ent
)));
6276 end Same_Instantiated_Constant
;
6278 --------------------------------
6279 -- Same_Instantiated_Function --
6280 --------------------------------
6282 function Same_Instantiated_Function
6283 (E1
, E2
: Entity_Id
) return Boolean
6287 if Alias
(E1
) = Alias
(E2
) then
6290 elsif Present
(Alias
(E2
)) then
6291 U1
:= Original_Node
(Unit_Declaration_Node
(E1
));
6292 U2
:= Original_Node
(Unit_Declaration_Node
(Alias
(E2
)));
6294 return Nkind
(U1
) = N_Subprogram_Renaming_Declaration
6295 and then Nkind
(Name
(U1
)) = N_Attribute_Reference
6297 and then Nkind
(U2
) = N_Subprogram_Renaming_Declaration
6298 and then Nkind
(Name
(U2
)) = N_Attribute_Reference
6301 Attribute_Name
(Name
(U1
)) = Attribute_Name
(Name
(U2
));
6305 end Same_Instantiated_Function
;
6307 --------------------------------
6308 -- Same_Instantiated_Variable --
6309 --------------------------------
6311 function Same_Instantiated_Variable
6312 (E1
, E2
: Entity_Id
) return Boolean
6314 function Original_Entity
(E
: Entity_Id
) return Entity_Id
;
6315 -- Follow chain of renamings to the ultimate ancestor
6317 ---------------------
6318 -- Original_Entity --
6319 ---------------------
6321 function Original_Entity
(E
: Entity_Id
) return Entity_Id
is
6326 while Nkind
(Parent
(Orig
)) = N_Object_Renaming_Declaration
6327 and then Present
(Renamed_Object
(Orig
))
6328 and then Is_Entity_Name
(Renamed_Object
(Orig
))
6330 Orig
:= Entity
(Renamed_Object
(Orig
));
6334 end Original_Entity
;
6336 -- Start of processing for Same_Instantiated_Variable
6339 return Ekind
(E1
) = Ekind
(E2
)
6340 and then Original_Entity
(E1
) = Original_Entity
(E2
);
6341 end Same_Instantiated_Variable
;
6343 -- Start of processing for Check_Formal_Package_Instance
6347 while Present
(E1
) and then Present
(E2
) loop
6348 exit when Ekind
(E1
) = E_Package
6349 and then Renamed_Entity
(E1
) = Renamed_Entity
(Actual_Pack
);
6351 -- If the formal is the renaming of the formal package, this
6352 -- is the end of its formal part, which may occur before the
6353 -- end of the formal part in the actual in the presence of
6354 -- defaulted parameters in the formal package.
6356 exit when Nkind
(Parent
(E2
)) = N_Package_Renaming_Declaration
6357 and then Renamed_Entity
(E2
) = Scope
(E2
);
6359 -- The analysis of the actual may generate additional internal
6360 -- entities. If the formal is defaulted, there is no corresponding
6361 -- analysis and the internal entities must be skipped, until we
6362 -- find corresponding entities again.
6364 if Comes_From_Source
(E2
)
6365 and then not Comes_From_Source
(E1
)
6366 and then Chars
(E1
) /= Chars
(E2
)
6368 while Present
(E1
) and then Chars
(E1
) /= Chars
(E2
) loop
6376 -- Entities may be declared without full declaration, such as
6377 -- itypes and predefined operators (concatenation for arrays, eg).
6378 -- Skip it and keep the formal entity to find a later match for it.
6380 elsif No
(Parent
(E2
)) and then Ekind
(E1
) /= Ekind
(E2
) then
6384 -- If the formal entity comes from a formal declaration, it was
6385 -- defaulted in the formal package, and no check is needed on it.
6387 elsif Nkind_In
(Original_Node
(Parent
(E2
)),
6388 N_Formal_Object_Declaration
,
6389 N_Formal_Type_Declaration
)
6391 -- If the formal is a tagged type the corresponding class-wide
6392 -- type has been generated as well, and it must be skipped.
6394 if Is_Type
(E2
) and then Is_Tagged_Type
(E2
) then
6400 -- Ditto for defaulted formal subprograms.
6402 elsif Is_Overloadable
(E1
)
6403 and then Nkind
(Unit_Declaration_Node
(E2
)) in
6404 N_Formal_Subprogram_Declaration
6408 elsif Is_Type
(E1
) then
6410 -- Subtypes must statically match. E1, E2 are the local entities
6411 -- that are subtypes of the actuals. Itypes generated for other
6412 -- parameters need not be checked, the check will be performed
6413 -- on the parameters themselves.
6415 -- If E2 is a formal type declaration, it is a defaulted parameter
6416 -- and needs no checking.
6418 if not Is_Itype
(E1
) and then not Is_Itype
(E2
) then
6421 or else Etype
(E1
) /= Etype
(E2
)
6422 or else not Subtypes_Statically_Match
(E1
, E2
));
6425 elsif Ekind
(E1
) = E_Constant
then
6427 -- IN parameters must denote the same static value, or the same
6428 -- constant, or the literal null.
6430 Expr1
:= Expression
(Parent
(E1
));
6432 if Ekind
(E2
) /= E_Constant
then
6433 Check_Mismatch
(True);
6436 Expr2
:= Expression
(Parent
(E2
));
6439 if Is_OK_Static_Expression
(Expr1
) then
6440 if not Is_OK_Static_Expression
(Expr2
) then
6441 Check_Mismatch
(True);
6443 elsif Is_Discrete_Type
(Etype
(E1
)) then
6445 V1
: constant Uint
:= Expr_Value
(Expr1
);
6446 V2
: constant Uint
:= Expr_Value
(Expr2
);
6448 Check_Mismatch
(V1
/= V2
);
6451 elsif Is_Real_Type
(Etype
(E1
)) then
6453 V1
: constant Ureal
:= Expr_Value_R
(Expr1
);
6454 V2
: constant Ureal
:= Expr_Value_R
(Expr2
);
6456 Check_Mismatch
(V1
/= V2
);
6459 elsif Is_String_Type
(Etype
(E1
))
6460 and then Nkind
(Expr1
) = N_String_Literal
6462 if Nkind
(Expr2
) /= N_String_Literal
then
6463 Check_Mismatch
(True);
6466 (not String_Equal
(Strval
(Expr1
), Strval
(Expr2
)));
6470 elsif Is_Entity_Name
(Expr1
) then
6471 if Is_Entity_Name
(Expr2
) then
6472 if Entity
(Expr1
) = Entity
(Expr2
) then
6476 (not Same_Instantiated_Constant
6477 (Entity
(Expr1
), Entity
(Expr2
)));
6481 Check_Mismatch
(True);
6484 elsif Is_Entity_Name
(Original_Node
(Expr1
))
6485 and then Is_Entity_Name
(Expr2
)
6486 and then Same_Instantiated_Constant
6487 (Entity
(Original_Node
(Expr1
)), Entity
(Expr2
))
6491 elsif Nkind
(Expr1
) = N_Null
then
6492 Check_Mismatch
(Nkind
(Expr1
) /= N_Null
);
6495 Check_Mismatch
(True);
6498 elsif Ekind
(E1
) = E_Variable
then
6499 Check_Mismatch
(not Same_Instantiated_Variable
(E1
, E2
));
6501 elsif Ekind
(E1
) = E_Package
then
6503 (Ekind
(E1
) /= Ekind
(E2
)
6504 or else (Present
(Renamed_Object
(E2
))
6505 and then Renamed_Object
(E1
) /=
6506 Renamed_Object
(E2
)));
6508 elsif Is_Overloadable
(E1
) then
6509 -- Verify that the actual subprograms match. Note that actuals
6510 -- that are attributes are rewritten as subprograms. If the
6511 -- subprogram in the formal package is defaulted, no check is
6512 -- needed. Note that this can only happen in Ada 2005 when the
6513 -- formal package can be partially parameterized.
6515 if Nkind
(Unit_Declaration_Node
(E1
)) =
6516 N_Subprogram_Renaming_Declaration
6517 and then From_Default
(Unit_Declaration_Node
(E1
))
6521 -- If the formal package has an "others" box association that
6522 -- covers this formal, there is no need for a check either.
6524 elsif Nkind
(Unit_Declaration_Node
(E2
)) in
6525 N_Formal_Subprogram_Declaration
6526 and then Box_Present
(Unit_Declaration_Node
(E2
))
6530 -- No check needed if subprogram is a defaulted null procedure
6532 elsif No
(Alias
(E2
))
6533 and then Ekind
(E2
) = E_Procedure
6535 Null_Present
(Specification
(Unit_Declaration_Node
(E2
)))
6539 -- Otherwise the actual in the formal and the actual in the
6540 -- instantiation of the formal must match, up to renamings.
6544 (Ekind
(E2
) /= Ekind
(E1
)
6545 or else not Same_Instantiated_Function
(E1
, E2
));
6549 raise Program_Error
;
6557 end Check_Formal_Package_Instance
;
6559 ---------------------------
6560 -- Check_Formal_Packages --
6561 ---------------------------
6563 procedure Check_Formal_Packages
(P_Id
: Entity_Id
) is
6565 Formal_P
: Entity_Id
;
6566 Formal_Decl
: Node_Id
;
6569 -- Iterate through the declarations in the instance, looking for package
6570 -- renaming declarations that denote instances of formal packages. Stop
6571 -- when we find the renaming of the current package itself. The
6572 -- declaration for a formal package without a box is followed by an
6573 -- internal entity that repeats the instantiation.
6575 E
:= First_Entity
(P_Id
);
6576 while Present
(E
) loop
6577 if Ekind
(E
) = E_Package
then
6578 if Renamed_Object
(E
) = P_Id
then
6581 elsif Nkind
(Parent
(E
)) /= N_Package_Renaming_Declaration
then
6585 Formal_Decl
:= Parent
(Associated_Formal_Package
(E
));
6587 -- Nothing to check if the formal has a box or an others_clause
6588 -- (necessarily with a box).
6590 if Box_Present
(Formal_Decl
) then
6593 elsif Nkind
(First
(Generic_Associations
(Formal_Decl
))) =
6596 -- The internal validating package was generated but formal
6597 -- and instance are known to be compatible.
6599 Formal_P
:= Next_Entity
(E
);
6600 Remove
(Unit_Declaration_Node
(Formal_P
));
6603 Formal_P
:= Next_Entity
(E
);
6605 -- If the instance is within an enclosing instance body
6606 -- there is no need to verify the legality of current formal
6607 -- packages because they were legal in the generic body.
6608 -- This optimization may be applicable elsewhere, and it
6609 -- also removes spurious errors that may arise with
6610 -- on-the-fly inlining and confusion between private and
6613 if not In_Instance_Body
then
6614 Check_Formal_Package_Instance
(Formal_P
, E
);
6617 -- After checking, remove the internal validating package.
6618 -- It is only needed for semantic checks, and as it may
6619 -- contain generic formal declarations it should not reach
6622 Remove
(Unit_Declaration_Node
(Formal_P
));
6629 end Check_Formal_Packages
;
6631 ---------------------------------
6632 -- Check_Forward_Instantiation --
6633 ---------------------------------
6635 procedure Check_Forward_Instantiation
(Decl
: Node_Id
) is
6637 Gen_Comp
: Entity_Id
:= Cunit_Entity
(Get_Source_Unit
(Decl
));
6640 -- The instantiation appears before the generic body if we are in the
6641 -- scope of the unit containing the generic, either in its spec or in
6642 -- the package body, and before the generic body.
6644 if Ekind
(Gen_Comp
) = E_Package_Body
then
6645 Gen_Comp
:= Spec_Entity
(Gen_Comp
);
6648 if In_Open_Scopes
(Gen_Comp
)
6649 and then No
(Corresponding_Body
(Decl
))
6654 and then not Is_Compilation_Unit
(S
)
6655 and then not Is_Child_Unit
(S
)
6657 if Ekind
(S
) = E_Package
then
6658 Set_Has_Forward_Instantiation
(S
);
6664 end Check_Forward_Instantiation
;
6666 ---------------------------
6667 -- Check_Generic_Actuals --
6668 ---------------------------
6670 -- The visibility of the actuals may be different between the point of
6671 -- generic instantiation and the instantiation of the body.
6673 procedure Check_Generic_Actuals
6674 (Instance
: Entity_Id
;
6675 Is_Formal_Box
: Boolean)
6680 function Denotes_Previous_Actual
(Typ
: Entity_Id
) return Boolean;
6681 -- For a formal that is an array type, the component type is often a
6682 -- previous formal in the same unit. The privacy status of the component
6683 -- type will have been examined earlier in the traversal of the
6684 -- corresponding actuals, and this status should not be modified for
6685 -- the array (sub)type itself. However, if the base type of the array
6686 -- (sub)type is private, its full view must be restored in the body to
6687 -- be consistent with subsequent index subtypes, etc.
6689 -- To detect this case we have to rescan the list of formals, which is
6690 -- usually short enough to ignore the resulting inefficiency.
6692 -----------------------------
6693 -- Denotes_Previous_Actual --
6694 -----------------------------
6696 function Denotes_Previous_Actual
(Typ
: Entity_Id
) return Boolean is
6700 Prev
:= First_Entity
(Instance
);
6701 while Present
(Prev
) loop
6703 and then Nkind
(Parent
(Prev
)) = N_Subtype_Declaration
6704 and then Is_Entity_Name
(Subtype_Indication
(Parent
(Prev
)))
6705 and then Entity
(Subtype_Indication
(Parent
(Prev
))) = Typ
6718 end Denotes_Previous_Actual
;
6720 -- Start of processing for Check_Generic_Actuals
6723 E
:= First_Entity
(Instance
);
6724 while Present
(E
) loop
6726 and then Nkind
(Parent
(E
)) = N_Subtype_Declaration
6727 and then Scope
(Etype
(E
)) /= Instance
6728 and then Is_Entity_Name
(Subtype_Indication
(Parent
(E
)))
6730 if Is_Array_Type
(E
)
6731 and then not Is_Private_Type
(Etype
(E
))
6732 and then Denotes_Previous_Actual
(Component_Type
(E
))
6736 Check_Private_View
(Subtype_Indication
(Parent
(E
)));
6739 Set_Is_Generic_Actual_Type
(E
, True);
6740 Set_Is_Hidden
(E
, False);
6741 Set_Is_Potentially_Use_Visible
(E
, In_Use
(Instance
));
6743 -- We constructed the generic actual type as a subtype of the
6744 -- supplied type. This means that it normally would not inherit
6745 -- subtype specific attributes of the actual, which is wrong for
6746 -- the generic case.
6748 Astype
:= Ancestor_Subtype
(E
);
6752 -- This can happen when E is an itype that is the full view of
6753 -- a private type completed, e.g. with a constrained array. In
6754 -- that case, use the first subtype, which will carry size
6755 -- information. The base type itself is unconstrained and will
6758 Astype
:= First_Subtype
(E
);
6761 Set_Size_Info
(E
, (Astype
));
6762 Set_RM_Size
(E
, RM_Size
(Astype
));
6763 Set_First_Rep_Item
(E
, First_Rep_Item
(Astype
));
6765 if Is_Discrete_Or_Fixed_Point_Type
(E
) then
6766 Set_RM_Size
(E
, RM_Size
(Astype
));
6768 -- In nested instances, the base type of an access actual may
6769 -- itself be private, and need to be exchanged.
6771 elsif Is_Access_Type
(E
)
6772 and then Is_Private_Type
(Etype
(E
))
6775 (New_Occurrence_Of
(Etype
(E
), Sloc
(Instance
)));
6778 elsif Ekind
(E
) = E_Package
then
6780 -- If this is the renaming for the current instance, we're done.
6781 -- Otherwise it is a formal package. If the corresponding formal
6782 -- was declared with a box, the (instantiations of the) generic
6783 -- formal part are also visible. Otherwise, ignore the entity
6784 -- created to validate the actuals.
6786 if Renamed_Object
(E
) = Instance
then
6789 elsif Nkind
(Parent
(E
)) /= N_Package_Renaming_Declaration
then
6792 -- The visibility of a formal of an enclosing generic is already
6795 elsif Denotes_Formal_Package
(E
) then
6798 elsif Present
(Associated_Formal_Package
(E
))
6799 and then not Is_Generic_Formal
(E
)
6801 if Box_Present
(Parent
(Associated_Formal_Package
(E
))) then
6802 Check_Generic_Actuals
(Renamed_Object
(E
), True);
6805 Check_Generic_Actuals
(Renamed_Object
(E
), False);
6808 Set_Is_Hidden
(E
, False);
6811 -- If this is a subprogram instance (in a wrapper package) the
6812 -- actual is fully visible.
6814 elsif Is_Wrapper_Package
(Instance
) then
6815 Set_Is_Hidden
(E
, False);
6817 -- If the formal package is declared with a box, or if the formal
6818 -- parameter is defaulted, it is visible in the body.
6820 elsif Is_Formal_Box
or else Is_Visible_Formal
(E
) then
6821 Set_Is_Hidden
(E
, False);
6824 if Ekind
(E
) = E_Constant
then
6826 -- If the type of the actual is a private type declared in the
6827 -- enclosing scope of the generic unit, the body of the generic
6828 -- sees the full view of the type (because it has to appear in
6829 -- the corresponding package body). If the type is private now,
6830 -- exchange views to restore the proper visiblity in the instance.
6833 Typ
: constant Entity_Id
:= Base_Type
(Etype
(E
));
6834 -- The type of the actual
6839 Parent_Scope
: Entity_Id
;
6840 -- The enclosing scope of the generic unit
6843 if Is_Wrapper_Package
(Instance
) then
6847 (Unit_Declaration_Node
6848 (Related_Instance
(Instance
))));
6851 Generic_Parent
(Package_Specification
(Instance
));
6854 Parent_Scope
:= Scope
(Gen_Id
);
6856 -- The exchange is only needed if the generic is defined
6857 -- within a package which is not a common ancestor of the
6858 -- scope of the instance, and is not already in scope.
6860 if Is_Private_Type
(Typ
)
6861 and then Scope
(Typ
) = Parent_Scope
6862 and then Scope
(Instance
) /= Parent_Scope
6863 and then Ekind
(Parent_Scope
) = E_Package
6864 and then not Is_Child_Unit
(Gen_Id
)
6868 -- If the type of the entity is a subtype, it may also have
6869 -- to be made visible, together with the base type of its
6870 -- full view, after exchange.
6872 if Is_Private_Type
(Etype
(E
)) then
6873 Switch_View
(Etype
(E
));
6874 Switch_View
(Base_Type
(Etype
(E
)));
6882 end Check_Generic_Actuals
;
6884 ------------------------------
6885 -- Check_Generic_Child_Unit --
6886 ------------------------------
6888 procedure Check_Generic_Child_Unit
6890 Parent_Installed
: in out Boolean)
6892 Loc
: constant Source_Ptr
:= Sloc
(Gen_Id
);
6893 Gen_Par
: Entity_Id
:= Empty
;
6895 Inst_Par
: Entity_Id
;
6898 function Find_Generic_Child
6900 Id
: Node_Id
) return Entity_Id
;
6901 -- Search generic parent for possible child unit with the given name
6903 function In_Enclosing_Instance
return Boolean;
6904 -- Within an instance of the parent, the child unit may be denoted by
6905 -- a simple name, or an abbreviated expanded name. Examine enclosing
6906 -- scopes to locate a possible parent instantiation.
6908 ------------------------
6909 -- Find_Generic_Child --
6910 ------------------------
6912 function Find_Generic_Child
6914 Id
: Node_Id
) return Entity_Id
6919 -- If entity of name is already set, instance has already been
6920 -- resolved, e.g. in an enclosing instantiation.
6922 if Present
(Entity
(Id
)) then
6923 if Scope
(Entity
(Id
)) = Scop
then
6930 E
:= First_Entity
(Scop
);
6931 while Present
(E
) loop
6932 if Chars
(E
) = Chars
(Id
)
6933 and then Is_Child_Unit
(E
)
6935 if Is_Child_Unit
(E
)
6936 and then not Is_Visible_Lib_Unit
(E
)
6939 ("generic child unit& is not visible", Gen_Id
, E
);
6951 end Find_Generic_Child
;
6953 ---------------------------
6954 -- In_Enclosing_Instance --
6955 ---------------------------
6957 function In_Enclosing_Instance
return Boolean is
6958 Enclosing_Instance
: Node_Id
;
6959 Instance_Decl
: Node_Id
;
6962 -- We do not inline any call that contains instantiations, except
6963 -- for instantiations of Unchecked_Conversion, so if we are within
6964 -- an inlined body the current instance does not require parents.
6966 if In_Inlined_Body
then
6967 pragma Assert
(Chars
(Gen_Id
) = Name_Unchecked_Conversion
);
6971 -- Loop to check enclosing scopes
6973 Enclosing_Instance
:= Current_Scope
;
6974 while Present
(Enclosing_Instance
) loop
6975 Instance_Decl
:= Unit_Declaration_Node
(Enclosing_Instance
);
6977 if Ekind
(Enclosing_Instance
) = E_Package
6978 and then Is_Generic_Instance
(Enclosing_Instance
)
6980 (Generic_Parent
(Specification
(Instance_Decl
)))
6982 -- Check whether the generic we are looking for is a child of
6985 E
:= Find_Generic_Child
6986 (Generic_Parent
(Specification
(Instance_Decl
)), Gen_Id
);
6987 exit when Present
(E
);
6993 Enclosing_Instance
:= Scope
(Enclosing_Instance
);
7005 Make_Expanded_Name
(Loc
,
7007 Prefix
=> New_Occurrence_Of
(Enclosing_Instance
, Loc
),
7008 Selector_Name
=> New_Occurrence_Of
(E
, Loc
)));
7010 Set_Entity
(Gen_Id
, E
);
7011 Set_Etype
(Gen_Id
, Etype
(E
));
7012 Parent_Installed
:= False; -- Already in scope.
7015 end In_Enclosing_Instance
;
7017 -- Start of processing for Check_Generic_Child_Unit
7020 -- If the name of the generic is given by a selected component, it may
7021 -- be the name of a generic child unit, and the prefix is the name of an
7022 -- instance of the parent, in which case the child unit must be visible.
7023 -- If this instance is not in scope, it must be placed there and removed
7024 -- after instantiation, because what is being instantiated is not the
7025 -- original child, but the corresponding child present in the instance
7028 -- If the child is instantiated within the parent, it can be given by
7029 -- a simple name. In this case the instance is already in scope, but
7030 -- the child generic must be recovered from the generic parent as well.
7032 if Nkind
(Gen_Id
) = N_Selected_Component
then
7033 S
:= Selector_Name
(Gen_Id
);
7034 Analyze
(Prefix
(Gen_Id
));
7035 Inst_Par
:= Entity
(Prefix
(Gen_Id
));
7037 if Ekind
(Inst_Par
) = E_Package
7038 and then Present
(Renamed_Object
(Inst_Par
))
7040 Inst_Par
:= Renamed_Object
(Inst_Par
);
7043 if Ekind
(Inst_Par
) = E_Package
then
7044 if Nkind
(Parent
(Inst_Par
)) = N_Package_Specification
then
7045 Gen_Par
:= Generic_Parent
(Parent
(Inst_Par
));
7047 elsif Nkind
(Parent
(Inst_Par
)) = N_Defining_Program_Unit_Name
7049 Nkind
(Parent
(Parent
(Inst_Par
))) = N_Package_Specification
7051 Gen_Par
:= Generic_Parent
(Parent
(Parent
(Inst_Par
)));
7054 elsif Ekind
(Inst_Par
) = E_Generic_Package
7055 and then Nkind
(Parent
(Gen_Id
)) = N_Formal_Package_Declaration
7057 -- A formal package may be a real child package, and not the
7058 -- implicit instance within a parent. In this case the child is
7059 -- not visible and has to be retrieved explicitly as well.
7061 Gen_Par
:= Inst_Par
;
7064 if Present
(Gen_Par
) then
7066 -- The prefix denotes an instantiation. The entity itself may be a
7067 -- nested generic, or a child unit.
7069 E
:= Find_Generic_Child
(Gen_Par
, S
);
7072 Change_Selected_Component_To_Expanded_Name
(Gen_Id
);
7073 Set_Entity
(Gen_Id
, E
);
7074 Set_Etype
(Gen_Id
, Etype
(E
));
7076 Set_Etype
(S
, Etype
(E
));
7078 -- Indicate that this is a reference to the parent
7080 if In_Extended_Main_Source_Unit
(Gen_Id
) then
7081 Set_Is_Instantiated
(Inst_Par
);
7084 -- A common mistake is to replicate the naming scheme of a
7085 -- hierarchy by instantiating a generic child directly, rather
7086 -- than the implicit child in a parent instance:
7088 -- generic .. package Gpar is ..
7089 -- generic .. package Gpar.Child is ..
7090 -- package Par is new Gpar ();
7093 -- package Par.Child is new Gpar.Child ();
7094 -- rather than Par.Child
7096 -- In this case the instantiation is within Par, which is an
7097 -- instance, but Gpar does not denote Par because we are not IN
7098 -- the instance of Gpar, so this is illegal. The test below
7099 -- recognizes this particular case.
7101 if Is_Child_Unit
(E
)
7102 and then not Comes_From_Source
(Entity
(Prefix
(Gen_Id
)))
7103 and then (not In_Instance
7104 or else Nkind
(Parent
(Parent
(Gen_Id
))) =
7108 ("prefix of generic child unit must be instance of parent",
7112 if not In_Open_Scopes
(Inst_Par
)
7113 and then Nkind
(Parent
(Gen_Id
)) not in
7114 N_Generic_Renaming_Declaration
7116 Install_Parent
(Inst_Par
);
7117 Parent_Installed
:= True;
7119 elsif In_Open_Scopes
(Inst_Par
) then
7121 -- If the parent is already installed, install the actuals
7122 -- for its formal packages. This is necessary when the child
7123 -- instance is a child of the parent instance: in this case,
7124 -- the parent is placed on the scope stack but the formal
7125 -- packages are not made visible.
7127 Install_Formal_Packages
(Inst_Par
);
7131 -- If the generic parent does not contain an entity that
7132 -- corresponds to the selector, the instance doesn't either.
7133 -- Analyzing the node will yield the appropriate error message.
7134 -- If the entity is not a child unit, then it is an inner
7135 -- generic in the parent.
7143 if Is_Child_Unit
(Entity
(Gen_Id
))
7145 Nkind
(Parent
(Gen_Id
)) not in N_Generic_Renaming_Declaration
7146 and then not In_Open_Scopes
(Inst_Par
)
7148 Install_Parent
(Inst_Par
);
7149 Parent_Installed
:= True;
7151 -- The generic unit may be the renaming of the implicit child
7152 -- present in an instance. In that case the parent instance is
7153 -- obtained from the name of the renamed entity.
7155 elsif Ekind
(Entity
(Gen_Id
)) = E_Generic_Package
7156 and then Present
(Renamed_Entity
(Entity
(Gen_Id
)))
7157 and then Is_Child_Unit
(Renamed_Entity
(Entity
(Gen_Id
)))
7160 Renamed_Package
: constant Node_Id
:=
7161 Name
(Parent
(Entity
(Gen_Id
)));
7163 if Nkind
(Renamed_Package
) = N_Expanded_Name
then
7164 Inst_Par
:= Entity
(Prefix
(Renamed_Package
));
7165 Install_Parent
(Inst_Par
);
7166 Parent_Installed
:= True;
7172 elsif Nkind
(Gen_Id
) = N_Expanded_Name
then
7174 -- Entity already present, analyze prefix, whose meaning may be an
7175 -- instance in the current context. If it is an instance of a
7176 -- relative within another, the proper parent may still have to be
7177 -- installed, if they are not of the same generation.
7179 Analyze
(Prefix
(Gen_Id
));
7181 -- Prevent cascaded errors
7183 if Etype
(Prefix
(Gen_Id
)) = Any_Type
then
7187 -- In the unlikely case that a local declaration hides the name of
7188 -- the parent package, locate it on the homonym chain. If the context
7189 -- is an instance of the parent, the renaming entity is flagged as
7192 Inst_Par
:= Entity
(Prefix
(Gen_Id
));
7193 while Present
(Inst_Par
)
7194 and then not Is_Package_Or_Generic_Package
(Inst_Par
)
7196 Inst_Par
:= Homonym
(Inst_Par
);
7199 pragma Assert
(Present
(Inst_Par
));
7200 Set_Entity
(Prefix
(Gen_Id
), Inst_Par
);
7202 if In_Enclosing_Instance
then
7205 elsif Present
(Entity
(Gen_Id
))
7206 and then Is_Child_Unit
(Entity
(Gen_Id
))
7207 and then not In_Open_Scopes
(Inst_Par
)
7209 Install_Parent
(Inst_Par
);
7210 Parent_Installed
:= True;
7213 elsif In_Enclosing_Instance
then
7215 -- The child unit is found in some enclosing scope
7222 -- If this is the renaming of the implicit child in a parent
7223 -- instance, recover the parent name and install it.
7225 if Is_Entity_Name
(Gen_Id
) then
7226 E
:= Entity
(Gen_Id
);
7228 if Is_Generic_Unit
(E
)
7229 and then Nkind
(Parent
(E
)) in N_Generic_Renaming_Declaration
7230 and then Is_Child_Unit
(Renamed_Object
(E
))
7231 and then Is_Generic_Unit
(Scope
(Renamed_Object
(E
)))
7232 and then Nkind
(Name
(Parent
(E
))) = N_Expanded_Name
7234 Rewrite
(Gen_Id
, New_Copy_Tree
(Name
(Parent
(E
))));
7235 Inst_Par
:= Entity
(Prefix
(Gen_Id
));
7237 if not In_Open_Scopes
(Inst_Par
) then
7238 Install_Parent
(Inst_Par
);
7239 Parent_Installed
:= True;
7242 -- If it is a child unit of a non-generic parent, it may be
7243 -- use-visible and given by a direct name. Install parent as
7246 elsif Is_Generic_Unit
(E
)
7247 and then Is_Child_Unit
(E
)
7249 Nkind
(Parent
(Gen_Id
)) not in N_Generic_Renaming_Declaration
7250 and then not Is_Generic_Unit
(Scope
(E
))
7252 if not In_Open_Scopes
(Scope
(E
)) then
7253 Install_Parent
(Scope
(E
));
7254 Parent_Installed
:= True;
7259 end Check_Generic_Child_Unit
;
7261 -----------------------------
7262 -- Check_Hidden_Child_Unit --
7263 -----------------------------
7265 procedure Check_Hidden_Child_Unit
7267 Gen_Unit
: Entity_Id
;
7268 Act_Decl_Id
: Entity_Id
)
7270 Gen_Id
: constant Node_Id
:= Name
(N
);
7273 if Is_Child_Unit
(Gen_Unit
)
7274 and then Is_Child_Unit
(Act_Decl_Id
)
7275 and then Nkind
(Gen_Id
) = N_Expanded_Name
7276 and then Entity
(Prefix
(Gen_Id
)) = Scope
(Act_Decl_Id
)
7277 and then Chars
(Gen_Unit
) = Chars
(Act_Decl_Id
)
7279 Error_Msg_Node_2
:= Scope
(Act_Decl_Id
);
7281 ("generic unit & is implicitly declared in &",
7282 Defining_Unit_Name
(N
), Gen_Unit
);
7283 Error_Msg_N
("\instance must have different name",
7284 Defining_Unit_Name
(N
));
7286 end Check_Hidden_Child_Unit
;
7288 ------------------------
7289 -- Check_Private_View --
7290 ------------------------
7292 procedure Check_Private_View
(N
: Node_Id
) is
7293 T
: constant Entity_Id
:= Etype
(N
);
7297 -- Exchange views if the type was not private in the generic but is
7298 -- private at the point of instantiation. Do not exchange views if
7299 -- the scope of the type is in scope. This can happen if both generic
7300 -- and instance are sibling units, or if type is defined in a parent.
7301 -- In this case the visibility of the type will be correct for all
7305 BT
:= Base_Type
(T
);
7307 if Is_Private_Type
(T
)
7308 and then not Has_Private_View
(N
)
7309 and then Present
(Full_View
(T
))
7310 and then not In_Open_Scopes
(Scope
(T
))
7312 -- In the generic, the full type was visible. Save the private
7313 -- entity, for subsequent exchange.
7317 elsif Has_Private_View
(N
)
7318 and then not Is_Private_Type
(T
)
7319 and then not Has_Been_Exchanged
(T
)
7320 and then Etype
(Get_Associated_Node
(N
)) /= T
7322 -- Only the private declaration was visible in the generic. If
7323 -- the type appears in a subtype declaration, the subtype in the
7324 -- instance must have a view compatible with that of its parent,
7325 -- which must be exchanged (see corresponding code in Restore_
7326 -- Private_Views). Otherwise, if the type is defined in a parent
7327 -- unit, leave full visibility within instance, which is safe.
7329 if In_Open_Scopes
(Scope
(Base_Type
(T
)))
7330 and then not Is_Private_Type
(Base_Type
(T
))
7331 and then Comes_From_Source
(Base_Type
(T
))
7335 elsif Nkind
(Parent
(N
)) = N_Subtype_Declaration
7336 or else not In_Private_Part
(Scope
(Base_Type
(T
)))
7338 Prepend_Elmt
(T
, Exchanged_Views
);
7339 Exchange_Declarations
(Etype
(Get_Associated_Node
(N
)));
7342 -- For composite types with inconsistent representation exchange
7343 -- component types accordingly.
7345 elsif Is_Access_Type
(T
)
7346 and then Is_Private_Type
(Designated_Type
(T
))
7347 and then not Has_Private_View
(N
)
7348 and then Present
(Full_View
(Designated_Type
(T
)))
7350 Switch_View
(Designated_Type
(T
));
7352 elsif Is_Array_Type
(T
) then
7353 if Is_Private_Type
(Component_Type
(T
))
7354 and then not Has_Private_View
(N
)
7355 and then Present
(Full_View
(Component_Type
(T
)))
7357 Switch_View
(Component_Type
(T
));
7360 -- The normal exchange mechanism relies on the setting of a
7361 -- flag on the reference in the generic. However, an additional
7362 -- mechanism is needed for types that are not explicitly
7363 -- mentioned in the generic, but may be needed in expanded code
7364 -- in the instance. This includes component types of arrays and
7365 -- designated types of access types. This processing must also
7366 -- include the index types of arrays which we take care of here.
7373 Indx
:= First_Index
(T
);
7374 while Present
(Indx
) loop
7375 Typ
:= Base_Type
(Etype
(Indx
));
7377 if Is_Private_Type
(Typ
)
7378 and then Present
(Full_View
(Typ
))
7387 elsif Is_Private_Type
(T
)
7388 and then Present
(Full_View
(T
))
7389 and then Is_Array_Type
(Full_View
(T
))
7390 and then Is_Private_Type
(Component_Type
(Full_View
(T
)))
7394 -- Finally, a non-private subtype may have a private base type, which
7395 -- must be exchanged for consistency. This can happen when a package
7396 -- body is instantiated, when the scope stack is empty but in fact
7397 -- the subtype and the base type are declared in an enclosing scope.
7399 -- Note that in this case we introduce an inconsistency in the view
7400 -- set, because we switch the base type BT, but there could be some
7401 -- private dependent subtypes of BT which remain unswitched. Such
7402 -- subtypes might need to be switched at a later point (see specific
7403 -- provision for that case in Switch_View).
7405 elsif not Is_Private_Type
(T
)
7406 and then not Has_Private_View
(N
)
7407 and then Is_Private_Type
(BT
)
7408 and then Present
(Full_View
(BT
))
7409 and then not Is_Generic_Type
(BT
)
7410 and then not In_Open_Scopes
(BT
)
7412 Prepend_Elmt
(Full_View
(BT
), Exchanged_Views
);
7413 Exchange_Declarations
(BT
);
7416 end Check_Private_View
;
7418 -----------------------------
7419 -- Check_Hidden_Primitives --
7420 -----------------------------
7422 function Check_Hidden_Primitives
(Assoc_List
: List_Id
) return Elist_Id
is
7425 Result
: Elist_Id
:= No_Elist
;
7428 if No
(Assoc_List
) then
7432 -- Traverse the list of associations between formals and actuals
7433 -- searching for renamings of tagged types
7435 Actual
:= First
(Assoc_List
);
7436 while Present
(Actual
) loop
7437 if Nkind
(Actual
) = N_Subtype_Declaration
then
7438 Gen_T
:= Generic_Parent_Type
(Actual
);
7440 if Present
(Gen_T
) and then Is_Tagged_Type
(Gen_T
) then
7442 -- Traverse the list of primitives of the actual types
7443 -- searching for hidden primitives that are visible in the
7444 -- corresponding generic formal; leave them visible and
7445 -- append them to Result to restore their decoration later.
7447 Install_Hidden_Primitives
7448 (Prims_List
=> Result
,
7450 Act_T
=> Entity
(Subtype_Indication
(Actual
)));
7458 end Check_Hidden_Primitives
;
7460 --------------------------
7461 -- Contains_Instance_Of --
7462 --------------------------
7464 function Contains_Instance_Of
7467 N
: Node_Id
) return Boolean
7475 -- Verify that there are no circular instantiations. We check whether
7476 -- the unit contains an instance of the current scope or some enclosing
7477 -- scope (in case one of the instances appears in a subunit). Longer
7478 -- circularities involving subunits might seem too pathological to
7479 -- consider, but they were not too pathological for the authors of
7480 -- DEC bc30vsq, so we loop over all enclosing scopes, and mark all
7481 -- enclosing generic scopes as containing an instance.
7484 -- Within a generic subprogram body, the scope is not generic, to
7485 -- allow for recursive subprograms. Use the declaration to determine
7486 -- whether this is a generic unit.
7488 if Ekind
(Scop
) = E_Generic_Package
7489 or else (Is_Subprogram
(Scop
)
7490 and then Nkind
(Unit_Declaration_Node
(Scop
)) =
7491 N_Generic_Subprogram_Declaration
)
7493 Elmt
:= First_Elmt
(Inner_Instances
(Inner
));
7495 while Present
(Elmt
) loop
7496 if Node
(Elmt
) = Scop
then
7497 Error_Msg_Node_2
:= Inner
;
7499 ("circular Instantiation: & instantiated within &!",
7503 elsif Node
(Elmt
) = Inner
then
7506 elsif Contains_Instance_Of
(Node
(Elmt
), Scop
, N
) then
7507 Error_Msg_Node_2
:= Inner
;
7509 ("circular Instantiation: & instantiated within &!",
7517 -- Indicate that Inner is being instantiated within Scop
7519 Append_Elmt
(Inner
, Inner_Instances
(Scop
));
7522 if Scop
= Standard_Standard
then
7525 Scop
:= Scope
(Scop
);
7530 end Contains_Instance_Of
;
7532 -----------------------
7533 -- Copy_Generic_Node --
7534 -----------------------
7536 function Copy_Generic_Node
7538 Parent_Id
: Node_Id
;
7539 Instantiating
: Boolean) return Node_Id
7544 function Copy_Generic_Descendant
(D
: Union_Id
) return Union_Id
;
7545 -- Check the given value of one of the Fields referenced by the current
7546 -- node to determine whether to copy it recursively. The field may hold
7547 -- a Node_Id, a List_Id, or an Elist_Id, or a plain value (Sloc, Uint,
7548 -- Char) in which case it need not be copied.
7550 procedure Copy_Descendants
;
7551 -- Common utility for various nodes
7553 function Copy_Generic_Elist
(E
: Elist_Id
) return Elist_Id
;
7554 -- Make copy of element list
7556 function Copy_Generic_List
7558 Parent_Id
: Node_Id
) return List_Id
;
7559 -- Apply Copy_Node recursively to the members of a node list
7561 function In_Defining_Unit_Name
(Nam
: Node_Id
) return Boolean;
7562 -- True if an identifier is part of the defining program unit name of
7563 -- a child unit. The entity of such an identifier must be kept (for
7564 -- ASIS use) even though as the name of an enclosing generic it would
7565 -- otherwise not be preserved in the generic tree.
7567 ----------------------
7568 -- Copy_Descendants --
7569 ----------------------
7571 procedure Copy_Descendants
is
7572 use Atree
.Unchecked_Access
;
7573 -- This code section is part of the implementation of an untyped
7574 -- tree traversal, so it needs direct access to node fields.
7577 Set_Field1
(New_N
, Copy_Generic_Descendant
(Field1
(N
)));
7578 Set_Field2
(New_N
, Copy_Generic_Descendant
(Field2
(N
)));
7579 Set_Field3
(New_N
, Copy_Generic_Descendant
(Field3
(N
)));
7580 Set_Field4
(New_N
, Copy_Generic_Descendant
(Field4
(N
)));
7581 Set_Field5
(New_N
, Copy_Generic_Descendant
(Field5
(N
)));
7582 end Copy_Descendants
;
7584 -----------------------------
7585 -- Copy_Generic_Descendant --
7586 -----------------------------
7588 function Copy_Generic_Descendant
(D
: Union_Id
) return Union_Id
is
7590 if D
= Union_Id
(Empty
) then
7593 elsif D
in Node_Range
then
7595 (Copy_Generic_Node
(Node_Id
(D
), New_N
, Instantiating
));
7597 elsif D
in List_Range
then
7598 return Union_Id
(Copy_Generic_List
(List_Id
(D
), New_N
));
7600 elsif D
in Elist_Range
then
7601 return Union_Id
(Copy_Generic_Elist
(Elist_Id
(D
)));
7603 -- Nothing else is copyable (e.g. Uint values), return as is
7608 end Copy_Generic_Descendant
;
7610 ------------------------
7611 -- Copy_Generic_Elist --
7612 ------------------------
7614 function Copy_Generic_Elist
(E
: Elist_Id
) return Elist_Id
is
7621 M
:= First_Elmt
(E
);
7622 while Present
(M
) loop
7624 (Copy_Generic_Node
(Node
(M
), Empty
, Instantiating
), L
);
7633 end Copy_Generic_Elist
;
7635 -----------------------
7636 -- Copy_Generic_List --
7637 -----------------------
7639 function Copy_Generic_List
7641 Parent_Id
: Node_Id
) return List_Id
7649 Set_Parent
(New_L
, Parent_Id
);
7652 while Present
(N
) loop
7653 Append
(Copy_Generic_Node
(N
, Empty
, Instantiating
), New_L
);
7662 end Copy_Generic_List
;
7664 ---------------------------
7665 -- In_Defining_Unit_Name --
7666 ---------------------------
7668 function In_Defining_Unit_Name
(Nam
: Node_Id
) return Boolean is
7671 Present
(Parent
(Nam
))
7672 and then (Nkind
(Parent
(Nam
)) = N_Defining_Program_Unit_Name
7674 (Nkind
(Parent
(Nam
)) = N_Expanded_Name
7675 and then In_Defining_Unit_Name
(Parent
(Nam
))));
7676 end In_Defining_Unit_Name
;
7678 -- Start of processing for Copy_Generic_Node
7685 New_N
:= New_Copy
(N
);
7687 -- Copy aspects if present
7689 if Has_Aspects
(N
) then
7690 Set_Has_Aspects
(New_N
, False);
7691 Set_Aspect_Specifications
7692 (New_N
, Copy_Generic_List
(Aspect_Specifications
(N
), Parent_Id
));
7695 -- If we are instantiating, we want to adjust the sloc based on the
7696 -- current S_Adjustment. However, if this is the root node of a subunit,
7697 -- we need to defer that adjustment to below (see "elsif Instantiating
7698 -- and Was_Stub"), so it comes after Create_Instantiation_Source has
7699 -- computed the adjustment.
7702 and then not (Nkind
(N
) in N_Proper_Body
7703 and then Was_Originally_Stub
(N
))
7705 Adjust_Instantiation_Sloc
(New_N
, S_Adjustment
);
7708 if not Is_List_Member
(N
) then
7709 Set_Parent
(New_N
, Parent_Id
);
7712 -- Special casing for identifiers and other entity names and operators
7714 if Nkind_In
(New_N
, N_Character_Literal
,
7718 or else Nkind
(New_N
) in N_Op
7720 if not Instantiating
then
7722 -- Link both nodes in order to assign subsequently the entity of
7723 -- the copy to the original node, in case this is a global
7726 Set_Associated_Node
(N
, New_N
);
7728 -- If we are within an instantiation, this is a nested generic
7729 -- that has already been analyzed at the point of definition.
7730 -- We must preserve references that were global to the enclosing
7731 -- parent at that point. Other occurrences, whether global or
7732 -- local to the current generic, must be resolved anew, so we
7733 -- reset the entity in the generic copy. A global reference has a
7734 -- smaller depth than the parent, or else the same depth in case
7735 -- both are distinct compilation units.
7737 -- A child unit is implicitly declared within the enclosing parent
7738 -- but is in fact global to it, and must be preserved.
7740 -- It is also possible for Current_Instantiated_Parent to be
7741 -- defined, and for this not to be a nested generic, namely if
7742 -- the unit is loaded through Rtsfind. In that case, the entity of
7743 -- New_N is only a link to the associated node, and not a defining
7746 -- The entities for parent units in the defining_program_unit of a
7747 -- generic child unit are established when the context of the unit
7748 -- is first analyzed, before the generic copy is made. They are
7749 -- preserved in the copy for use in ASIS queries.
7751 Ent
:= Entity
(New_N
);
7753 if No
(Current_Instantiated_Parent
.Gen_Id
) then
7755 or else Nkind
(Ent
) /= N_Defining_Identifier
7756 or else not In_Defining_Unit_Name
(N
)
7758 Set_Associated_Node
(New_N
, Empty
);
7763 not Nkind_In
(Ent
, N_Defining_Identifier
,
7764 N_Defining_Character_Literal
,
7765 N_Defining_Operator_Symbol
)
7766 or else No
(Scope
(Ent
))
7768 (Scope
(Ent
) = Current_Instantiated_Parent
.Gen_Id
7769 and then not Is_Child_Unit
(Ent
))
7771 (Scope_Depth
(Scope
(Ent
)) >
7772 Scope_Depth
(Current_Instantiated_Parent
.Gen_Id
)
7774 Get_Source_Unit
(Ent
) =
7775 Get_Source_Unit
(Current_Instantiated_Parent
.Gen_Id
))
7777 Set_Associated_Node
(New_N
, Empty
);
7780 -- Case of instantiating identifier or some other name or operator
7783 -- If the associated node is still defined, the entity in it
7784 -- is global, and must be copied to the instance. If this copy
7785 -- is being made for a body to inline, it is applied to an
7786 -- instantiated tree, and the entity is already present and
7787 -- must be also preserved.
7790 Assoc
: constant Node_Id
:= Get_Associated_Node
(N
);
7793 if Present
(Assoc
) then
7794 if Nkind
(Assoc
) = Nkind
(N
) then
7795 Set_Entity
(New_N
, Entity
(Assoc
));
7796 Check_Private_View
(N
);
7798 -- The node is a reference to a global type and acts as the
7799 -- subtype mark of a qualified expression created in order
7800 -- to aid resolution of accidental overloading in instances.
7801 -- Since N is a reference to a type, the Associated_Node of
7802 -- N denotes an entity rather than another identifier. See
7803 -- Qualify_Universal_Operands for details.
7805 elsif Nkind
(N
) = N_Identifier
7806 and then Nkind
(Parent
(N
)) = N_Qualified_Expression
7807 and then Subtype_Mark
(Parent
(N
)) = N
7808 and then Is_Qualified_Universal_Literal
(Parent
(N
))
7810 Set_Entity
(New_N
, Assoc
);
7812 -- The name in the call may be a selected component if the
7813 -- call has not been analyzed yet, as may be the case for
7814 -- pre/post conditions in a generic unit.
7816 elsif Nkind
(Assoc
) = N_Function_Call
7817 and then Is_Entity_Name
(Name
(Assoc
))
7819 Set_Entity
(New_N
, Entity
(Name
(Assoc
)));
7821 elsif Nkind_In
(Assoc
, N_Defining_Identifier
,
7822 N_Defining_Character_Literal
,
7823 N_Defining_Operator_Symbol
)
7824 and then Expander_Active
7826 -- Inlining case: we are copying a tree that contains
7827 -- global entities, which are preserved in the copy to be
7828 -- used for subsequent inlining.
7833 Set_Entity
(New_N
, Empty
);
7839 -- For expanded name, we must copy the Prefix and Selector_Name
7841 if Nkind
(N
) = N_Expanded_Name
then
7843 (New_N
, Copy_Generic_Node
(Prefix
(N
), New_N
, Instantiating
));
7845 Set_Selector_Name
(New_N
,
7846 Copy_Generic_Node
(Selector_Name
(N
), New_N
, Instantiating
));
7848 -- For operators, copy the operands
7850 elsif Nkind
(N
) in N_Op
then
7851 if Nkind
(N
) in N_Binary_Op
then
7852 Set_Left_Opnd
(New_N
,
7853 Copy_Generic_Node
(Left_Opnd
(N
), New_N
, Instantiating
));
7856 Set_Right_Opnd
(New_N
,
7857 Copy_Generic_Node
(Right_Opnd
(N
), New_N
, Instantiating
));
7860 -- Establish a link between an entity from the generic template and the
7861 -- corresponding entity in the generic copy to be analyzed.
7863 elsif Nkind
(N
) in N_Entity
then
7864 if not Instantiating
then
7865 Set_Associated_Entity
(N
, New_N
);
7868 -- Clear any existing link the copy may inherit from the replicated
7869 -- generic template entity.
7871 Set_Associated_Entity
(New_N
, Empty
);
7873 -- Special casing for stubs
7875 elsif Nkind
(N
) in N_Body_Stub
then
7877 -- In any case, we must copy the specification or defining
7878 -- identifier as appropriate.
7880 if Nkind
(N
) = N_Subprogram_Body_Stub
then
7881 Set_Specification
(New_N
,
7882 Copy_Generic_Node
(Specification
(N
), New_N
, Instantiating
));
7885 Set_Defining_Identifier
(New_N
,
7887 (Defining_Identifier
(N
), New_N
, Instantiating
));
7890 -- If we are not instantiating, then this is where we load and
7891 -- analyze subunits, i.e. at the point where the stub occurs. A
7892 -- more permissive system might defer this analysis to the point
7893 -- of instantiation, but this seems too complicated for now.
7895 if not Instantiating
then
7897 Subunit_Name
: constant Unit_Name_Type
:= Get_Unit_Name
(N
);
7899 Unum
: Unit_Number_Type
;
7903 -- Make sure that, if it is a subunit of the main unit that is
7904 -- preprocessed and if -gnateG is specified, the preprocessed
7905 -- file will be written.
7907 Lib
.Analysing_Subunit_Of_Main
:=
7908 Lib
.In_Extended_Main_Source_Unit
(N
);
7911 (Load_Name
=> Subunit_Name
,
7915 Lib
.Analysing_Subunit_Of_Main
:= False;
7917 -- If the proper body is not found, a warning message will be
7918 -- emitted when analyzing the stub, or later at the point of
7919 -- instantiation. Here we just leave the stub as is.
7921 if Unum
= No_Unit
then
7922 Subunits_Missing
:= True;
7923 goto Subunit_Not_Found
;
7926 Subunit
:= Cunit
(Unum
);
7928 if Nkind
(Unit
(Subunit
)) /= N_Subunit
then
7930 ("found child unit instead of expected SEPARATE subunit",
7932 Error_Msg_Sloc
:= Sloc
(N
);
7933 Error_Msg_N
("\to complete stub #", Subunit
);
7934 goto Subunit_Not_Found
;
7937 -- We must create a generic copy of the subunit, in order to
7938 -- perform semantic analysis on it, and we must replace the
7939 -- stub in the original generic unit with the subunit, in order
7940 -- to preserve non-local references within.
7942 -- Only the proper body needs to be copied. Library_Unit and
7943 -- context clause are simply inherited by the generic copy.
7944 -- Note that the copy (which may be recursive if there are
7945 -- nested subunits) must be done first, before attaching it to
7946 -- the enclosing generic.
7950 (Proper_Body
(Unit
(Subunit
)),
7951 Empty
, Instantiating
=> False);
7953 -- Now place the original proper body in the original generic
7954 -- unit. This is a body, not a compilation unit.
7956 Rewrite
(N
, Proper_Body
(Unit
(Subunit
)));
7957 Set_Is_Compilation_Unit
(Defining_Entity
(N
), False);
7958 Set_Was_Originally_Stub
(N
);
7960 -- Finally replace the body of the subunit with its copy, and
7961 -- make this new subunit into the library unit of the generic
7962 -- copy, which does not have stubs any longer.
7964 Set_Proper_Body
(Unit
(Subunit
), New_Body
);
7965 Set_Library_Unit
(New_N
, Subunit
);
7966 Inherit_Context
(Unit
(Subunit
), N
);
7969 -- If we are instantiating, this must be an error case, since
7970 -- otherwise we would have replaced the stub node by the proper body
7971 -- that corresponds. So just ignore it in the copy (i.e. we have
7972 -- copied it, and that is good enough).
7978 <<Subunit_Not_Found
>> null;
7980 -- If the node is a compilation unit, it is the subunit of a stub, which
7981 -- has been loaded already (see code below). In this case, the library
7982 -- unit field of N points to the parent unit (which is a compilation
7983 -- unit) and need not (and cannot) be copied.
7985 -- When the proper body of the stub is analyzed, the library_unit link
7986 -- is used to establish the proper context (see sem_ch10).
7988 -- The other fields of a compilation unit are copied as usual
7990 elsif Nkind
(N
) = N_Compilation_Unit
then
7992 -- This code can only be executed when not instantiating, because in
7993 -- the copy made for an instantiation, the compilation unit node has
7994 -- disappeared at the point that a stub is replaced by its proper
7997 pragma Assert
(not Instantiating
);
7999 Set_Context_Items
(New_N
,
8000 Copy_Generic_List
(Context_Items
(N
), New_N
));
8003 Copy_Generic_Node
(Unit
(N
), New_N
, Instantiating
=> False));
8005 Set_First_Inlined_Subprogram
(New_N
,
8007 (First_Inlined_Subprogram
(N
), New_N
, Instantiating
=> False));
8012 (Aux_Decls_Node
(N
), New_N
, Instantiating
=> False));
8014 -- For an assignment node, the assignment is known to be semantically
8015 -- legal if we are instantiating the template. This avoids incorrect
8016 -- diagnostics in generated code.
8018 elsif Nkind
(N
) = N_Assignment_Statement
then
8020 -- Copy name and expression fields in usual manner
8023 Copy_Generic_Node
(Name
(N
), New_N
, Instantiating
));
8025 Set_Expression
(New_N
,
8026 Copy_Generic_Node
(Expression
(N
), New_N
, Instantiating
));
8028 if Instantiating
then
8029 Set_Assignment_OK
(Name
(New_N
), True);
8032 elsif Nkind_In
(N
, N_Aggregate
, N_Extension_Aggregate
) then
8033 if not Instantiating
then
8034 Set_Associated_Node
(N
, New_N
);
8037 if Present
(Get_Associated_Node
(N
))
8038 and then Nkind
(Get_Associated_Node
(N
)) = Nkind
(N
)
8040 -- In the generic the aggregate has some composite type. If at
8041 -- the point of instantiation the type has a private view,
8042 -- install the full view (and that of its ancestors, if any).
8045 T
: Entity_Id
:= (Etype
(Get_Associated_Node
(New_N
)));
8049 if Present
(T
) and then Is_Private_Type
(T
) then
8054 and then Is_Tagged_Type
(T
)
8055 and then Is_Derived_Type
(T
)
8057 Rt
:= Root_Type
(T
);
8062 if Is_Private_Type
(T
) then
8073 -- Do not copy the associated node, which points to the generic copy
8074 -- of the aggregate.
8077 use Atree
.Unchecked_Access
;
8078 -- This code section is part of the implementation of an untyped
8079 -- tree traversal, so it needs direct access to node fields.
8082 Set_Field1
(New_N
, Copy_Generic_Descendant
(Field1
(N
)));
8083 Set_Field2
(New_N
, Copy_Generic_Descendant
(Field2
(N
)));
8084 Set_Field3
(New_N
, Copy_Generic_Descendant
(Field3
(N
)));
8085 Set_Field5
(New_N
, Copy_Generic_Descendant
(Field5
(N
)));
8088 -- Allocators do not have an identifier denoting the access type, so we
8089 -- must locate it through the expression to check whether the views are
8092 elsif Nkind
(N
) = N_Allocator
8093 and then Nkind
(Expression
(N
)) = N_Qualified_Expression
8094 and then Is_Entity_Name
(Subtype_Mark
(Expression
(N
)))
8095 and then Instantiating
8098 T
: constant Node_Id
:=
8099 Get_Associated_Node
(Subtype_Mark
(Expression
(N
)));
8105 -- Retrieve the allocator node in the generic copy
8107 Acc_T
:= Etype
(Parent
(Parent
(T
)));
8109 if Present
(Acc_T
) and then Is_Private_Type
(Acc_T
) then
8110 Switch_View
(Acc_T
);
8117 -- For a proper body, we must catch the case of a proper body that
8118 -- replaces a stub. This represents the point at which a separate
8119 -- compilation unit, and hence template file, may be referenced, so we
8120 -- must make a new source instantiation entry for the template of the
8121 -- subunit, and ensure that all nodes in the subunit are adjusted using
8122 -- this new source instantiation entry.
8124 elsif Nkind
(N
) in N_Proper_Body
then
8126 Save_Adjustment
: constant Sloc_Adjustment
:= S_Adjustment
;
8128 if Instantiating
and then Was_Originally_Stub
(N
) then
8129 Create_Instantiation_Source
8130 (Instantiation_Node
,
8131 Defining_Entity
(N
),
8134 Adjust_Instantiation_Sloc
(New_N
, S_Adjustment
);
8137 -- Now copy the fields of the proper body, using the new
8138 -- adjustment factor if one was needed as per test above.
8142 -- Restore the original adjustment factor
8144 S_Adjustment
:= Save_Adjustment
;
8147 elsif Nkind
(N
) = N_Pragma
and then Instantiating
then
8149 -- Do not copy Comment or Ident pragmas their content is relevant to
8150 -- the generic unit, not to the instantiating unit.
8152 if Nam_In
(Pragma_Name_Unmapped
(N
), Name_Comment
, Name_Ident
) then
8153 New_N
:= Make_Null_Statement
(Sloc
(N
));
8155 -- Do not copy pragmas generated from aspects because the pragmas do
8156 -- not carry any semantic information, plus they will be regenerated
8159 -- However, generating C we need to copy them since postconditions
8160 -- are inlined by the front end, and the front-end inlining machinery
8161 -- relies on this routine to perform inlining.
8163 elsif From_Aspect_Specification
(N
)
8164 and then not Modify_Tree_For_C
8166 New_N
:= Make_Null_Statement
(Sloc
(N
));
8172 elsif Nkind_In
(N
, N_Integer_Literal
, N_Real_Literal
) then
8174 -- No descendant fields need traversing
8178 elsif Nkind
(N
) = N_String_Literal
8179 and then Present
(Etype
(N
))
8180 and then Instantiating
8182 -- If the string is declared in an outer scope, the string_literal
8183 -- subtype created for it may have the wrong scope. Force reanalysis
8184 -- of the constant to generate a new itype in the proper context.
8186 Set_Etype
(New_N
, Empty
);
8187 Set_Analyzed
(New_N
, False);
8189 -- For the remaining nodes, copy their descendants recursively
8194 if Instantiating
and then Nkind
(N
) = N_Subprogram_Body
then
8195 Set_Generic_Parent
(Specification
(New_N
), N
);
8197 -- Should preserve Corresponding_Spec??? (12.3(14))
8201 -- Propagate dimensions if present, so that they are reflected in the
8204 if Nkind
(N
) in N_Has_Etype
8205 and then (Nkind
(N
) in N_Op
or else Is_Entity_Name
(N
))
8206 and then Present
(Etype
(N
))
8207 and then Is_Floating_Point_Type
(Etype
(N
))
8208 and then Has_Dimension_System
(Etype
(N
))
8210 Copy_Dimensions
(N
, New_N
);
8214 end Copy_Generic_Node
;
8216 ----------------------------
8217 -- Denotes_Formal_Package --
8218 ----------------------------
8220 function Denotes_Formal_Package
8222 On_Exit
: Boolean := False;
8223 Instance
: Entity_Id
:= Empty
) return Boolean
8226 Scop
: constant Entity_Id
:= Scope
(Pack
);
8229 function Is_Actual_Of_Previous_Formal
(P
: Entity_Id
) return Boolean;
8230 -- The package in question may be an actual for a previous formal
8231 -- package P of the current instance, so examine its actuals as well.
8232 -- This must be recursive over other formal packages.
8234 ----------------------------------
8235 -- Is_Actual_Of_Previous_Formal --
8236 ----------------------------------
8238 function Is_Actual_Of_Previous_Formal
(P
: Entity_Id
) return Boolean is
8242 E1
:= First_Entity
(P
);
8243 while Present
(E1
) and then E1
/= Instance
loop
8244 if Ekind
(E1
) = E_Package
8245 and then Nkind
(Parent
(E1
)) = N_Package_Renaming_Declaration
8247 if Renamed_Object
(E1
) = Pack
then
8250 elsif E1
= P
or else Renamed_Object
(E1
) = P
then
8253 elsif Is_Actual_Of_Previous_Formal
(E1
) then
8262 end Is_Actual_Of_Previous_Formal
;
8264 -- Start of processing for Denotes_Formal_Package
8270 (Instance_Envs
.Last
).Instantiated_Parent
.Act_Id
;
8272 Par
:= Current_Instantiated_Parent
.Act_Id
;
8275 if Ekind
(Scop
) = E_Generic_Package
8276 or else Nkind
(Unit_Declaration_Node
(Scop
)) =
8277 N_Generic_Subprogram_Declaration
8281 elsif Nkind
(Original_Node
(Unit_Declaration_Node
(Pack
))) =
8282 N_Formal_Package_Declaration
8290 -- Check whether this package is associated with a formal package of
8291 -- the enclosing instantiation. Iterate over the list of renamings.
8293 E
:= First_Entity
(Par
);
8294 while Present
(E
) loop
8295 if Ekind
(E
) /= E_Package
8296 or else Nkind
(Parent
(E
)) /= N_Package_Renaming_Declaration
8300 elsif Renamed_Object
(E
) = Par
then
8303 elsif Renamed_Object
(E
) = Pack
then
8306 elsif Is_Actual_Of_Previous_Formal
(E
) then
8316 end Denotes_Formal_Package
;
8322 procedure End_Generic
is
8324 -- ??? More things could be factored out in this routine. Should
8325 -- probably be done at a later stage.
8327 Inside_A_Generic
:= Generic_Flags
.Table
(Generic_Flags
.Last
);
8328 Generic_Flags
.Decrement_Last
;
8330 Expander_Mode_Restore
;
8337 function Earlier
(N1
, N2
: Node_Id
) return Boolean is
8338 procedure Find_Depth
(P
: in out Node_Id
; D
: in out Integer);
8339 -- Find distance from given node to enclosing compilation unit
8345 procedure Find_Depth
(P
: in out Node_Id
; D
: in out Integer) is
8348 and then Nkind
(P
) /= N_Compilation_Unit
8350 P
:= True_Parent
(P
);
8355 -- Local declarations
8364 -- Start of processing for Earlier
8367 Find_Depth
(P1
, D1
);
8368 Find_Depth
(P2
, D2
);
8378 P1
:= True_Parent
(P1
);
8383 P2
:= True_Parent
(P2
);
8387 -- At this point P1 and P2 are at the same distance from the root.
8388 -- We examine their parents until we find a common declarative list.
8389 -- If we reach the root, N1 and N2 do not descend from the same
8390 -- declarative list (e.g. one is nested in the declarative part and
8391 -- the other is in a block in the statement part) and the earlier
8392 -- one is already frozen.
8394 while not Is_List_Member
(P1
)
8395 or else not Is_List_Member
(P2
)
8396 or else List_Containing
(P1
) /= List_Containing
(P2
)
8398 P1
:= True_Parent
(P1
);
8399 P2
:= True_Parent
(P2
);
8401 if Nkind
(Parent
(P1
)) = N_Subunit
then
8402 P1
:= Corresponding_Stub
(Parent
(P1
));
8405 if Nkind
(Parent
(P2
)) = N_Subunit
then
8406 P2
:= Corresponding_Stub
(Parent
(P2
));
8414 -- Expanded code usually shares the source location of the original
8415 -- construct it was generated for. This however may not necessarily
8416 -- reflect the true location of the code within the tree.
8418 -- Before comparing the slocs of the two nodes, make sure that we are
8419 -- working with correct source locations. Assume that P1 is to the left
8420 -- of P2. If either one does not come from source, traverse the common
8421 -- list heading towards the other node and locate the first source
8425 -- ----+===+===+--------------+===+===+----
8426 -- expanded code expanded code
8428 if not Comes_From_Source
(P1
) then
8429 while Present
(P1
) loop
8431 -- Neither P2 nor a source statement were located during the
8432 -- search. If we reach the end of the list, then P1 does not
8433 -- occur earlier than P2.
8436 -- start --- P2 ----- P1 --- end
8438 if No
(Next
(P1
)) then
8441 -- We encounter P2 while going to the right of the list. This
8442 -- means that P1 does indeed appear earlier.
8445 -- start --- P1 ===== P2 --- end
8446 -- expanded code in between
8451 -- No need to look any further since we have located a source
8454 elsif Comes_From_Source
(P1
) then
8464 if not Comes_From_Source
(P2
) then
8465 while Present
(P2
) loop
8467 -- Neither P1 nor a source statement were located during the
8468 -- search. If we reach the start of the list, then P1 does not
8469 -- occur earlier than P2.
8472 -- start --- P2 --- P1 --- end
8474 if No
(Prev
(P2
)) then
8477 -- We encounter P1 while going to the left of the list. This
8478 -- means that P1 does indeed appear earlier.
8481 -- start --- P1 ===== P2 --- end
8482 -- expanded code in between
8487 -- No need to look any further since we have located a source
8490 elsif Comes_From_Source
(P2
) then
8500 -- At this point either both nodes came from source or we approximated
8501 -- their source locations through neighboring source statements.
8503 T1
:= Top_Level_Location
(Sloc
(P1
));
8504 T2
:= Top_Level_Location
(Sloc
(P2
));
8506 -- When two nodes come from the same instance, they have identical top
8507 -- level locations. To determine proper relation within the tree, check
8508 -- their locations within the template.
8511 return Sloc
(P1
) < Sloc
(P2
);
8513 -- The two nodes either come from unrelated instances or do not come
8514 -- from instantiated code at all.
8521 ----------------------
8522 -- Find_Actual_Type --
8523 ----------------------
8525 function Find_Actual_Type
8527 Gen_Type
: Entity_Id
) return Entity_Id
8529 Gen_Scope
: constant Entity_Id
:= Scope
(Gen_Type
);
8533 -- Special processing only applies to child units
8535 if not Is_Child_Unit
(Gen_Scope
) then
8536 return Get_Instance_Of
(Typ
);
8538 -- If designated or component type is itself a formal of the child unit,
8539 -- its instance is available.
8541 elsif Scope
(Typ
) = Gen_Scope
then
8542 return Get_Instance_Of
(Typ
);
8544 -- If the array or access type is not declared in the parent unit,
8545 -- no special processing needed.
8547 elsif not Is_Generic_Type
(Typ
)
8548 and then Scope
(Gen_Scope
) /= Scope
(Typ
)
8550 return Get_Instance_Of
(Typ
);
8552 -- Otherwise, retrieve designated or component type by visibility
8555 T
:= Current_Entity
(Typ
);
8556 while Present
(T
) loop
8557 if In_Open_Scopes
(Scope
(T
)) then
8559 elsif Is_Generic_Actual_Type
(T
) then
8568 end Find_Actual_Type
;
8570 ----------------------------
8571 -- Freeze_Subprogram_Body --
8572 ----------------------------
8574 procedure Freeze_Subprogram_Body
8575 (Inst_Node
: Node_Id
;
8577 Pack_Id
: Entity_Id
)
8579 Gen_Unit
: constant Entity_Id
:= Get_Generic_Entity
(Inst_Node
);
8580 Par
: constant Entity_Id
:= Scope
(Gen_Unit
);
8586 function Enclosing_Package_Body
(N
: Node_Id
) return Node_Id
;
8587 -- Find innermost package body that encloses the given node, and which
8588 -- is not a compilation unit. Freeze nodes for the instance, or for its
8589 -- enclosing body, may be inserted after the enclosing_body of the
8590 -- generic unit. Used to determine proper placement of freeze node for
8591 -- both package and subprogram instances.
8593 function Package_Freeze_Node
(B
: Node_Id
) return Node_Id
;
8594 -- Find entity for given package body, and locate or create a freeze
8597 ----------------------------
8598 -- Enclosing_Package_Body --
8599 ----------------------------
8601 function Enclosing_Package_Body
(N
: Node_Id
) return Node_Id
is
8607 and then Nkind
(Parent
(P
)) /= N_Compilation_Unit
8609 if Nkind
(P
) = N_Package_Body
then
8610 if Nkind
(Parent
(P
)) = N_Subunit
then
8611 return Corresponding_Stub
(Parent
(P
));
8617 P
:= True_Parent
(P
);
8621 end Enclosing_Package_Body
;
8623 -------------------------
8624 -- Package_Freeze_Node --
8625 -------------------------
8627 function Package_Freeze_Node
(B
: Node_Id
) return Node_Id
is
8631 if Nkind
(B
) = N_Package_Body
then
8632 Id
:= Corresponding_Spec
(B
);
8633 else pragma Assert
(Nkind
(B
) = N_Package_Body_Stub
);
8634 Id
:= Corresponding_Spec
(Proper_Body
(Unit
(Library_Unit
(B
))));
8637 Ensure_Freeze_Node
(Id
);
8638 return Freeze_Node
(Id
);
8639 end Package_Freeze_Node
;
8641 -- Start of processing for Freeze_Subprogram_Body
8644 -- If the instance and the generic body appear within the same unit, and
8645 -- the instance precedes the generic, the freeze node for the instance
8646 -- must appear after that of the generic. If the generic is nested
8647 -- within another instance I2, then current instance must be frozen
8648 -- after I2. In both cases, the freeze nodes are those of enclosing
8649 -- packages. Otherwise, the freeze node is placed at the end of the
8650 -- current declarative part.
8652 Enc_G
:= Enclosing_Package_Body
(Gen_Body
);
8653 Enc_I
:= Enclosing_Package_Body
(Inst_Node
);
8654 Ensure_Freeze_Node
(Pack_Id
);
8655 F_Node
:= Freeze_Node
(Pack_Id
);
8657 if Is_Generic_Instance
(Par
)
8658 and then Present
(Freeze_Node
(Par
))
8659 and then In_Same_Declarative_Part
(Freeze_Node
(Par
), Inst_Node
)
8661 -- The parent was a premature instantiation. Insert freeze node at
8662 -- the end the current declarative part.
8664 if Is_Known_Guaranteed_ABE
(Get_Unit_Instantiation_Node
(Par
)) then
8665 Insert_Freeze_Node_For_Instance
(Inst_Node
, F_Node
);
8667 -- Handle the following case:
8669 -- package Parent_Inst is new ...
8672 -- procedure P ... -- this body freezes Parent_Inst
8674 -- package Inst is new ...
8676 -- In this particular scenario, the freeze node for Inst must be
8677 -- inserted in the same manner as that of Parent_Inst - before the
8678 -- next source body or at the end of the declarative list (body not
8679 -- available). If body P did not exist and Parent_Inst was frozen
8680 -- after Inst, either by a body following Inst or at the end of the
8681 -- declarative region, the freeze node for Inst must be inserted
8682 -- after that of Parent_Inst. This relation is established by
8683 -- comparing the Slocs of Parent_Inst freeze node and Inst.
8685 elsif List_Containing
(Get_Unit_Instantiation_Node
(Par
)) =
8686 List_Containing
(Inst_Node
)
8687 and then Sloc
(Freeze_Node
(Par
)) < Sloc
(Inst_Node
)
8689 Insert_Freeze_Node_For_Instance
(Inst_Node
, F_Node
);
8692 Insert_After
(Freeze_Node
(Par
), F_Node
);
8695 -- The body enclosing the instance should be frozen after the body that
8696 -- includes the generic, because the body of the instance may make
8697 -- references to entities therein. If the two are not in the same
8698 -- declarative part, or if the one enclosing the instance is frozen
8699 -- already, freeze the instance at the end of the current declarative
8702 elsif Is_Generic_Instance
(Par
)
8703 and then Present
(Freeze_Node
(Par
))
8704 and then Present
(Enc_I
)
8706 if In_Same_Declarative_Part
(Freeze_Node
(Par
), Enc_I
)
8708 (Nkind
(Enc_I
) = N_Package_Body
8710 In_Same_Declarative_Part
(Freeze_Node
(Par
), Parent
(Enc_I
)))
8712 -- The enclosing package may contain several instances. Rather
8713 -- than computing the earliest point at which to insert its freeze
8714 -- node, we place it at the end of the declarative part of the
8715 -- parent of the generic.
8717 Insert_Freeze_Node_For_Instance
8718 (Freeze_Node
(Par
), Package_Freeze_Node
(Enc_I
));
8721 Insert_Freeze_Node_For_Instance
(Inst_Node
, F_Node
);
8723 elsif Present
(Enc_G
)
8724 and then Present
(Enc_I
)
8725 and then Enc_G
/= Enc_I
8726 and then Earlier
(Inst_Node
, Gen_Body
)
8728 if Nkind
(Enc_G
) = N_Package_Body
then
8730 Corresponding_Spec
(Enc_G
);
8731 else pragma Assert
(Nkind
(Enc_G
) = N_Package_Body_Stub
);
8733 Corresponding_Spec
(Proper_Body
(Unit
(Library_Unit
(Enc_G
))));
8736 -- Freeze package that encloses instance, and place node after the
8737 -- package that encloses generic. If enclosing package is already
8738 -- frozen we have to assume it is at the proper place. This may be a
8739 -- potential ABE that requires dynamic checking. Do not add a freeze
8740 -- node if the package that encloses the generic is inside the body
8741 -- that encloses the instance, because the freeze node would be in
8742 -- the wrong scope. Additional contortions needed if the bodies are
8743 -- within a subunit.
8746 Enclosing_Body
: Node_Id
;
8749 if Nkind
(Enc_I
) = N_Package_Body_Stub
then
8750 Enclosing_Body
:= Proper_Body
(Unit
(Library_Unit
(Enc_I
)));
8752 Enclosing_Body
:= Enc_I
;
8755 if Parent
(List_Containing
(Enc_G
)) /= Enclosing_Body
then
8756 Insert_Freeze_Node_For_Instance
8757 (Enc_G
, Package_Freeze_Node
(Enc_I
));
8761 -- Freeze enclosing subunit before instance
8763 Ensure_Freeze_Node
(E_G_Id
);
8765 if not Is_List_Member
(Freeze_Node
(E_G_Id
)) then
8766 Insert_After
(Enc_G
, Freeze_Node
(E_G_Id
));
8769 Insert_Freeze_Node_For_Instance
(Inst_Node
, F_Node
);
8772 -- If none of the above, insert freeze node at the end of the current
8773 -- declarative part.
8775 Insert_Freeze_Node_For_Instance
(Inst_Node
, F_Node
);
8777 end Freeze_Subprogram_Body
;
8783 function Get_Gen_Id
(E
: Assoc_Ptr
) return Entity_Id
is
8785 return Generic_Renamings
.Table
(E
).Gen_Id
;
8788 ---------------------
8789 -- Get_Instance_Of --
8790 ---------------------
8792 function Get_Instance_Of
(A
: Entity_Id
) return Entity_Id
is
8793 Res
: constant Assoc_Ptr
:= Generic_Renamings_HTable
.Get
(A
);
8796 if Res
/= Assoc_Null
then
8797 return Generic_Renamings
.Table
(Res
).Act_Id
;
8800 -- On exit, entity is not instantiated: not a generic parameter, or
8801 -- else parameter of an inner generic unit.
8805 end Get_Instance_Of
;
8807 ---------------------------------
8808 -- Get_Unit_Instantiation_Node --
8809 ---------------------------------
8811 function Get_Unit_Instantiation_Node
(A
: Entity_Id
) return Node_Id
is
8812 Decl
: Node_Id
:= Unit_Declaration_Node
(A
);
8816 -- If the Package_Instantiation attribute has been set on the package
8817 -- entity, then use it directly when it (or its Original_Node) refers
8818 -- to an N_Package_Instantiation node. In principle it should be
8819 -- possible to have this field set in all cases, which should be
8820 -- investigated, and would allow this function to be significantly
8823 Inst
:= Package_Instantiation
(A
);
8825 if Present
(Inst
) then
8826 if Nkind
(Inst
) = N_Package_Instantiation
then
8829 elsif Nkind
(Original_Node
(Inst
)) = N_Package_Instantiation
then
8830 return Original_Node
(Inst
);
8834 -- If the instantiation is a compilation unit that does not need body
8835 -- then the instantiation node has been rewritten as a package
8836 -- declaration for the instance, and we return the original node.
8838 -- If it is a compilation unit and the instance node has not been
8839 -- rewritten, then it is still the unit of the compilation. Finally, if
8840 -- a body is present, this is a parent of the main unit whose body has
8841 -- been compiled for inlining purposes, and the instantiation node has
8842 -- been rewritten with the instance body.
8844 -- Otherwise the instantiation node appears after the declaration. If
8845 -- the entity is a formal package, the declaration may have been
8846 -- rewritten as a generic declaration (in the case of a formal with box)
8847 -- or left as a formal package declaration if it has actuals, and is
8848 -- found with a forward search.
8850 if Nkind
(Parent
(Decl
)) = N_Compilation_Unit
then
8851 if Nkind
(Decl
) = N_Package_Declaration
8852 and then Present
(Corresponding_Body
(Decl
))
8854 Decl
:= Unit_Declaration_Node
(Corresponding_Body
(Decl
));
8857 if Nkind_In
(Original_Node
(Decl
), N_Function_Instantiation
,
8858 N_Package_Instantiation
,
8859 N_Procedure_Instantiation
)
8861 return Original_Node
(Decl
);
8863 return Unit
(Parent
(Decl
));
8866 elsif Nkind
(Decl
) = N_Package_Declaration
8867 and then Nkind
(Original_Node
(Decl
)) = N_Formal_Package_Declaration
8869 return Original_Node
(Decl
);
8872 Inst
:= Next
(Decl
);
8873 while not Nkind_In
(Inst
, N_Formal_Package_Declaration
,
8874 N_Function_Instantiation
,
8875 N_Package_Instantiation
,
8876 N_Procedure_Instantiation
)
8883 end Get_Unit_Instantiation_Node
;
8885 ------------------------
8886 -- Has_Been_Exchanged --
8887 ------------------------
8889 function Has_Been_Exchanged
(E
: Entity_Id
) return Boolean is
8893 Next
:= First_Elmt
(Exchanged_Views
);
8894 while Present
(Next
) loop
8895 if Full_View
(Node
(Next
)) = E
then
8903 end Has_Been_Exchanged
;
8909 function Hash
(F
: Entity_Id
) return HTable_Range
is
8911 return HTable_Range
(F
mod HTable_Size
);
8914 ------------------------
8915 -- Hide_Current_Scope --
8916 ------------------------
8918 procedure Hide_Current_Scope
is
8919 C
: constant Entity_Id
:= Current_Scope
;
8923 Set_Is_Hidden_Open_Scope
(C
);
8925 E
:= First_Entity
(C
);
8926 while Present
(E
) loop
8927 if Is_Immediately_Visible
(E
) then
8928 Set_Is_Immediately_Visible
(E
, False);
8929 Append_Elmt
(E
, Hidden_Entities
);
8935 -- Make the scope name invisible as well. This is necessary, but might
8936 -- conflict with calls to Rtsfind later on, in case the scope is a
8937 -- predefined one. There is no clean solution to this problem, so for
8938 -- now we depend on the user not redefining Standard itself in one of
8939 -- the parent units.
8941 if Is_Immediately_Visible
(C
) and then C
/= Standard_Standard
then
8942 Set_Is_Immediately_Visible
(C
, False);
8943 Append_Elmt
(C
, Hidden_Entities
);
8946 end Hide_Current_Scope
;
8952 procedure Init_Env
is
8953 Saved
: Instance_Env
;
8956 Saved
.Instantiated_Parent
:= Current_Instantiated_Parent
;
8957 Saved
.Exchanged_Views
:= Exchanged_Views
;
8958 Saved
.Hidden_Entities
:= Hidden_Entities
;
8959 Saved
.Current_Sem_Unit
:= Current_Sem_Unit
;
8960 Saved
.Parent_Unit_Visible
:= Parent_Unit_Visible
;
8961 Saved
.Instance_Parent_Unit
:= Instance_Parent_Unit
;
8963 -- Save configuration switches. These may be reset if the unit is a
8964 -- predefined unit, and the current mode is not Ada 2005.
8966 Save_Opt_Config_Switches
(Saved
.Switches
);
8968 Instance_Envs
.Append
(Saved
);
8970 Exchanged_Views
:= New_Elmt_List
;
8971 Hidden_Entities
:= New_Elmt_List
;
8973 -- Make dummy entry for Instantiated parent. If generic unit is legal,
8974 -- this is set properly in Set_Instance_Env.
8976 Current_Instantiated_Parent
:=
8977 (Current_Scope
, Current_Scope
, Assoc_Null
);
8980 ------------------------------
8981 -- In_Same_Declarative_Part --
8982 ------------------------------
8984 function In_Same_Declarative_Part
8986 Inst
: Node_Id
) return Boolean
8988 Decls
: constant Node_Id
:= Parent
(F_Node
);
8992 Nod
:= Parent
(Inst
);
8993 while Present
(Nod
) loop
8997 elsif Nkind_In
(Nod
, N_Subprogram_Body
,
8999 N_Package_Declaration
,
9006 elsif Nkind
(Nod
) = N_Subunit
then
9007 Nod
:= Corresponding_Stub
(Nod
);
9009 elsif Nkind
(Nod
) = N_Compilation_Unit
then
9013 Nod
:= Parent
(Nod
);
9018 end In_Same_Declarative_Part
;
9020 ---------------------
9021 -- In_Main_Context --
9022 ---------------------
9024 function In_Main_Context
(E
: Entity_Id
) return Boolean is
9030 if not Is_Compilation_Unit
(E
)
9031 or else Ekind
(E
) /= E_Package
9032 or else In_Private_Part
(E
)
9037 Context
:= Context_Items
(Cunit
(Main_Unit
));
9039 Clause
:= First
(Context
);
9040 while Present
(Clause
) loop
9041 if Nkind
(Clause
) = N_With_Clause
then
9042 Nam
:= Name
(Clause
);
9044 -- If the current scope is part of the context of the main unit,
9045 -- analysis of the corresponding with_clause is not complete, and
9046 -- the entity is not set. We use the Chars field directly, which
9047 -- might produce false positives in rare cases, but guarantees
9048 -- that we produce all the instance bodies we will need.
9050 if (Is_Entity_Name
(Nam
) and then Chars
(Nam
) = Chars
(E
))
9051 or else (Nkind
(Nam
) = N_Selected_Component
9052 and then Chars
(Selector_Name
(Nam
)) = Chars
(E
))
9062 end In_Main_Context
;
9064 ---------------------
9065 -- Inherit_Context --
9066 ---------------------
9068 procedure Inherit_Context
(Gen_Decl
: Node_Id
; Inst
: Node_Id
) is
9069 Current_Context
: List_Id
;
9070 Current_Unit
: Node_Id
;
9079 if Nkind
(Parent
(Gen_Decl
)) = N_Compilation_Unit
then
9081 -- The inherited context is attached to the enclosing compilation
9082 -- unit. This is either the main unit, or the declaration for the
9083 -- main unit (in case the instantiation appears within the package
9084 -- declaration and the main unit is its body).
9086 Current_Unit
:= Parent
(Inst
);
9087 while Present
(Current_Unit
)
9088 and then Nkind
(Current_Unit
) /= N_Compilation_Unit
9090 Current_Unit
:= Parent
(Current_Unit
);
9093 Current_Context
:= Context_Items
(Current_Unit
);
9095 Item
:= First
(Context_Items
(Parent
(Gen_Decl
)));
9096 while Present
(Item
) loop
9097 if Nkind
(Item
) = N_With_Clause
then
9098 Lib_Unit
:= Library_Unit
(Item
);
9100 -- Take care to prevent direct cyclic with's
9102 if Lib_Unit
/= Current_Unit
then
9104 -- Do not add a unit if it is already in the context
9106 Clause
:= First
(Current_Context
);
9108 while Present
(Clause
) loop
9109 if Nkind
(Clause
) = N_With_Clause
and then
9110 Library_Unit
(Clause
) = Lib_Unit
9120 New_I
:= New_Copy
(Item
);
9121 Set_Implicit_With
(New_I
, True);
9122 Set_Implicit_With_From_Instantiation
(New_I
, True);
9123 Append
(New_I
, Current_Context
);
9131 end Inherit_Context
;
9137 procedure Initialize
is
9139 Generic_Renamings
.Init
;
9142 Generic_Renamings_HTable
.Reset
;
9143 Circularity_Detected
:= False;
9144 Exchanged_Views
:= No_Elist
;
9145 Hidden_Entities
:= No_Elist
;
9148 -------------------------------------
9149 -- Insert_Freeze_Node_For_Instance --
9150 -------------------------------------
9152 procedure Insert_Freeze_Node_For_Instance
9161 function Enclosing_Body
(N
: Node_Id
) return Node_Id
;
9162 -- Find enclosing package or subprogram body, if any. Freeze node may
9163 -- be placed at end of current declarative list if previous instance
9164 -- and current one have different enclosing bodies.
9166 function Previous_Instance
(Gen
: Entity_Id
) return Entity_Id
;
9167 -- Find the local instance, if any, that declares the generic that is
9168 -- being instantiated. If present, the freeze node for this instance
9169 -- must follow the freeze node for the previous instance.
9171 --------------------
9172 -- Enclosing_Body --
9173 --------------------
9175 function Enclosing_Body
(N
: Node_Id
) return Node_Id
is
9181 and then Nkind
(Parent
(P
)) /= N_Compilation_Unit
9183 if Nkind_In
(P
, N_Package_Body
, N_Subprogram_Body
) then
9184 if Nkind
(Parent
(P
)) = N_Subunit
then
9185 return Corresponding_Stub
(Parent
(P
));
9191 P
:= True_Parent
(P
);
9197 -----------------------
9198 -- Previous_Instance --
9199 -----------------------
9201 function Previous_Instance
(Gen
: Entity_Id
) return Entity_Id
is
9206 while Present
(S
) and then S
/= Standard_Standard
loop
9207 if Is_Generic_Instance
(S
)
9208 and then In_Same_Source_Unit
(S
, N
)
9217 end Previous_Instance
;
9219 -- Start of processing for Insert_Freeze_Node_For_Instance
9222 if not Is_List_Member
(F_Node
) then
9224 Decls
:= List_Containing
(N
);
9225 Inst
:= Entity
(F_Node
);
9226 Par_N
:= Parent
(Decls
);
9228 -- When processing a subprogram instantiation, utilize the actual
9229 -- subprogram instantiation rather than its package wrapper as it
9230 -- carries all the context information.
9232 if Is_Wrapper_Package
(Inst
) then
9233 Inst
:= Related_Instance
(Inst
);
9236 -- If this is a package instance, check whether the generic is
9237 -- declared in a previous instance and the current instance is
9238 -- not within the previous one.
9240 if Present
(Generic_Parent
(Parent
(Inst
)))
9241 and then Is_In_Main_Unit
(N
)
9244 Enclosing_N
: constant Node_Id
:= Enclosing_Body
(N
);
9245 Par_I
: constant Entity_Id
:=
9247 (Generic_Parent
(Parent
(Inst
)));
9252 and then Earlier
(N
, Freeze_Node
(Par_I
))
9254 Scop
:= Scope
(Inst
);
9256 -- If the current instance is within the one that contains
9257 -- the generic, the freeze node for the current one must
9258 -- appear in the current declarative part. Ditto, if the
9259 -- current instance is within another package instance or
9260 -- within a body that does not enclose the current instance.
9261 -- In these three cases the freeze node of the previous
9262 -- instance is not relevant.
9264 while Present
(Scop
) and then Scop
/= Standard_Standard
loop
9265 exit when Scop
= Par_I
9267 (Is_Generic_Instance
(Scop
)
9268 and then Scope_Depth
(Scop
) > Scope_Depth
(Par_I
));
9269 Scop
:= Scope
(Scop
);
9272 -- Previous instance encloses current instance
9274 if Scop
= Par_I
then
9277 -- If the next node is a source body we must freeze in
9278 -- the current scope as well.
9280 elsif Present
(Next
(N
))
9281 and then Nkind_In
(Next
(N
), N_Subprogram_Body
,
9283 and then Comes_From_Source
(Next
(N
))
9287 -- Current instance is within an unrelated instance
9289 elsif Is_Generic_Instance
(Scop
) then
9292 -- Current instance is within an unrelated body
9294 elsif Present
(Enclosing_N
)
9295 and then Enclosing_N
/= Enclosing_Body
(Par_I
)
9300 Insert_After
(Freeze_Node
(Par_I
), F_Node
);
9307 -- When the instantiation occurs in a package declaration, append the
9308 -- freeze node to the private declarations (if any).
9310 if Nkind
(Par_N
) = N_Package_Specification
9311 and then Decls
= Visible_Declarations
(Par_N
)
9312 and then Present
(Private_Declarations
(Par_N
))
9313 and then not Is_Empty_List
(Private_Declarations
(Par_N
))
9315 Decls
:= Private_Declarations
(Par_N
);
9316 Decl
:= First
(Decls
);
9319 -- Determine the proper freeze point of a package instantiation. We
9320 -- adhere to the general rule of a package or subprogram body causing
9321 -- freezing of anything before it in the same declarative region. In
9322 -- this case, the proper freeze point of a package instantiation is
9323 -- before the first source body which follows, or before a stub. This
9324 -- ensures that entities coming from the instance are already frozen
9325 -- and usable in source bodies.
9327 if Nkind
(Par_N
) /= N_Package_Declaration
9328 and then Ekind
(Inst
) = E_Package
9329 and then Is_Generic_Instance
(Inst
)
9331 not In_Same_Source_Unit
(Generic_Parent
(Parent
(Inst
)), Inst
)
9333 while Present
(Decl
) loop
9334 if (Nkind
(Decl
) in N_Unit_Body
9336 Nkind
(Decl
) in N_Body_Stub
)
9337 and then Comes_From_Source
(Decl
)
9339 Insert_Before
(Decl
, F_Node
);
9347 -- In a package declaration, or if no previous body, insert at end
9350 Set_Sloc
(F_Node
, Sloc
(Last
(Decls
)));
9351 Insert_After
(Last
(Decls
), F_Node
);
9353 end Insert_Freeze_Node_For_Instance
;
9359 procedure Install_Body
9360 (Act_Body
: Node_Id
;
9365 function In_Same_Scope
(Gen_Id
, Act_Id
: Node_Id
) return Boolean;
9366 -- Check if the generic definition and the instantiation come from
9367 -- a common scope, in which case the instance must be frozen after
9368 -- the generic body.
9370 function True_Sloc
(N
, Act_Unit
: Node_Id
) return Source_Ptr
;
9371 -- If the instance is nested inside a generic unit, the Sloc of the
9372 -- instance indicates the place of the original definition, not the
9373 -- point of the current enclosing instance. Pending a better usage of
9374 -- Slocs to indicate instantiation places, we determine the place of
9375 -- origin of a node by finding the maximum sloc of any ancestor node.
9376 -- Why is this not equivalent to Top_Level_Location ???
9382 function In_Same_Scope
(Gen_Id
, Act_Id
: Node_Id
) return Boolean is
9383 Act_Scop
: Entity_Id
:= Scope
(Act_Id
);
9384 Gen_Scop
: Entity_Id
:= Scope
(Gen_Id
);
9387 while Act_Scop
/= Standard_Standard
9388 and then Gen_Scop
/= Standard_Standard
9390 if Act_Scop
= Gen_Scop
then
9394 Act_Scop
:= Scope
(Act_Scop
);
9395 Gen_Scop
:= Scope
(Gen_Scop
);
9405 function True_Sloc
(N
, Act_Unit
: Node_Id
) return Source_Ptr
is
9412 while Present
(N1
) and then N1
/= Act_Unit
loop
9413 if Sloc
(N1
) > Res
then
9423 Act_Id
: constant Entity_Id
:= Corresponding_Spec
(Act_Body
);
9424 Act_Unit
: constant Node_Id
:= Unit
(Cunit
(Get_Source_Unit
(N
)));
9425 Gen_Id
: constant Entity_Id
:= Corresponding_Spec
(Gen_Body
);
9426 Par
: constant Entity_Id
:= Scope
(Gen_Id
);
9427 Gen_Unit
: constant Node_Id
:=
9428 Unit
(Cunit
(Get_Source_Unit
(Gen_Decl
)));
9430 Body_Unit
: Node_Id
;
9432 Must_Delay
: Boolean;
9433 Orig_Body
: Node_Id
:= Gen_Body
;
9435 -- Start of processing for Install_Body
9438 -- Handle first the case of an instance with incomplete actual types.
9439 -- The instance body cannot be placed after the declaration because
9440 -- full views have not been seen yet. Any use of the non-limited views
9441 -- in the instance body requires the presence of a regular with_clause
9442 -- in the enclosing unit, and will fail if this with_clause is missing.
9443 -- We place the instance body at the beginning of the enclosing body,
9444 -- which is the unit being compiled. The freeze node for the instance
9445 -- is then placed after the instance body.
9447 if not Is_Empty_Elmt_List
(Incomplete_Actuals
(Act_Id
))
9448 and then Expander_Active
9449 and then Ekind
(Scope
(Act_Id
)) = E_Package
9452 Scop
: constant Entity_Id
:= Scope
(Act_Id
);
9453 Body_Id
: constant Node_Id
:=
9454 Corresponding_Body
(Unit_Declaration_Node
(Scop
));
9457 Ensure_Freeze_Node
(Act_Id
);
9458 F_Node
:= Freeze_Node
(Act_Id
);
9459 if Present
(Body_Id
) then
9460 Set_Is_Frozen
(Act_Id
, False);
9461 Prepend
(Act_Body
, Declarations
(Parent
(Body_Id
)));
9462 if Is_List_Member
(F_Node
) then
9466 Insert_After
(Act_Body
, F_Node
);
9472 -- If the body is a subunit, the freeze point is the corresponding stub
9473 -- in the current compilation, not the subunit itself.
9475 if Nkind
(Parent
(Gen_Body
)) = N_Subunit
then
9476 Orig_Body
:= Corresponding_Stub
(Parent
(Gen_Body
));
9478 Orig_Body
:= Gen_Body
;
9481 Body_Unit
:= Unit
(Cunit
(Get_Source_Unit
(Orig_Body
)));
9483 -- If the instantiation and the generic definition appear in the same
9484 -- package declaration, this is an early instantiation. If they appear
9485 -- in the same declarative part, it is an early instantiation only if
9486 -- the generic body appears textually later, and the generic body is
9487 -- also in the main unit.
9489 -- If instance is nested within a subprogram, and the generic body
9490 -- is not, the instance is delayed because the enclosing body is. If
9491 -- instance and body are within the same scope, or the same subprogram
9492 -- body, indicate explicitly that the instance is delayed.
9495 (Gen_Unit
= Act_Unit
9496 and then (Nkind_In
(Gen_Unit
, N_Generic_Package_Declaration
,
9497 N_Package_Declaration
)
9498 or else (Gen_Unit
= Body_Unit
9499 and then True_Sloc
(N
, Act_Unit
) <
9501 and then Is_In_Main_Unit
(Original_Node
(Gen_Unit
))
9502 and then In_Same_Scope
(Gen_Id
, Act_Id
));
9504 -- If this is an early instantiation, the freeze node is placed after
9505 -- the generic body. Otherwise, if the generic appears in an instance,
9506 -- we cannot freeze the current instance until the outer one is frozen.
9507 -- This is only relevant if the current instance is nested within some
9508 -- inner scope not itself within the outer instance. If this scope is
9509 -- a package body in the same declarative part as the outer instance,
9510 -- then that body needs to be frozen after the outer instance. Finally,
9511 -- if no delay is needed, we place the freeze node at the end of the
9512 -- current declarative part.
9515 and then (No
(Freeze_Node
(Act_Id
))
9516 or else not Is_List_Member
(Freeze_Node
(Act_Id
)))
9518 Ensure_Freeze_Node
(Act_Id
);
9519 F_Node
:= Freeze_Node
(Act_Id
);
9522 Insert_After
(Orig_Body
, F_Node
);
9524 elsif Is_Generic_Instance
(Par
)
9525 and then Present
(Freeze_Node
(Par
))
9526 and then Scope
(Act_Id
) /= Par
9528 -- Freeze instance of inner generic after instance of enclosing
9531 if In_Same_Declarative_Part
(Freeze_Node
(Par
), N
) then
9533 -- Handle the following case:
9535 -- package Parent_Inst is new ...
9538 -- procedure P ... -- this body freezes Parent_Inst
9540 -- package Inst is new ...
9542 -- In this particular scenario, the freeze node for Inst must
9543 -- be inserted in the same manner as that of Parent_Inst,
9544 -- before the next source body or at the end of the declarative
9545 -- list (body not available). If body P did not exist and
9546 -- Parent_Inst was frozen after Inst, either by a body
9547 -- following Inst or at the end of the declarative region,
9548 -- the freeze node for Inst must be inserted after that of
9549 -- Parent_Inst. This relation is established by comparing
9550 -- the Slocs of Parent_Inst freeze node and Inst.
9552 if List_Containing
(Get_Unit_Instantiation_Node
(Par
)) =
9554 and then Sloc
(Freeze_Node
(Par
)) < Sloc
(N
)
9556 Insert_Freeze_Node_For_Instance
(N
, F_Node
);
9558 Insert_After
(Freeze_Node
(Par
), F_Node
);
9561 -- Freeze package enclosing instance of inner generic after
9562 -- instance of enclosing generic.
9564 elsif Nkind_In
(Parent
(N
), N_Package_Body
, N_Subprogram_Body
)
9565 and then In_Same_Declarative_Part
(Freeze_Node
(Par
), Parent
(N
))
9568 Enclosing
: Entity_Id
;
9571 Enclosing
:= Corresponding_Spec
(Parent
(N
));
9573 if No
(Enclosing
) then
9574 Enclosing
:= Defining_Entity
(Parent
(N
));
9577 Insert_Freeze_Node_For_Instance
(N
, F_Node
);
9578 Ensure_Freeze_Node
(Enclosing
);
9580 if not Is_List_Member
(Freeze_Node
(Enclosing
)) then
9582 -- The enclosing context is a subunit, insert the freeze
9583 -- node after the stub.
9585 if Nkind
(Parent
(Parent
(N
))) = N_Subunit
then
9586 Insert_Freeze_Node_For_Instance
9587 (Corresponding_Stub
(Parent
(Parent
(N
))),
9588 Freeze_Node
(Enclosing
));
9590 -- The enclosing context is a package with a stub body
9591 -- which has already been replaced by the real body.
9592 -- Insert the freeze node after the actual body.
9594 elsif Ekind
(Enclosing
) = E_Package
9595 and then Present
(Body_Entity
(Enclosing
))
9596 and then Was_Originally_Stub
9597 (Parent
(Body_Entity
(Enclosing
)))
9599 Insert_Freeze_Node_For_Instance
9600 (Parent
(Body_Entity
(Enclosing
)),
9601 Freeze_Node
(Enclosing
));
9603 -- The parent instance has been frozen before the body of
9604 -- the enclosing package, insert the freeze node after
9607 elsif List_Containing
(Freeze_Node
(Par
)) =
9608 List_Containing
(Parent
(N
))
9609 and then Sloc
(Freeze_Node
(Par
)) < Sloc
(Parent
(N
))
9611 Insert_Freeze_Node_For_Instance
9612 (Parent
(N
), Freeze_Node
(Enclosing
));
9616 (Freeze_Node
(Par
), Freeze_Node
(Enclosing
));
9622 Insert_Freeze_Node_For_Instance
(N
, F_Node
);
9626 Insert_Freeze_Node_For_Instance
(N
, F_Node
);
9630 Set_Is_Frozen
(Act_Id
);
9631 Insert_Before
(N
, Act_Body
);
9632 Mark_Rewrite_Insertion
(Act_Body
);
9635 -----------------------------
9636 -- Install_Formal_Packages --
9637 -----------------------------
9639 procedure Install_Formal_Packages
(Par
: Entity_Id
) is
9642 Gen_E
: Entity_Id
:= Empty
;
9645 E
:= First_Entity
(Par
);
9647 -- If we are installing an instance parent, locate the formal packages
9648 -- of its generic parent.
9650 if Is_Generic_Instance
(Par
) then
9651 Gen
:= Generic_Parent
(Package_Specification
(Par
));
9652 Gen_E
:= First_Entity
(Gen
);
9655 while Present
(E
) loop
9656 if Ekind
(E
) = E_Package
9657 and then Nkind
(Parent
(E
)) = N_Package_Renaming_Declaration
9659 -- If this is the renaming for the parent instance, done
9661 if Renamed_Object
(E
) = Par
then
9664 -- The visibility of a formal of an enclosing generic is already
9667 elsif Denotes_Formal_Package
(E
) then
9670 elsif Present
(Associated_Formal_Package
(E
)) then
9671 Check_Generic_Actuals
(Renamed_Object
(E
), True);
9672 Set_Is_Hidden
(E
, False);
9674 -- Find formal package in generic unit that corresponds to
9675 -- (instance of) formal package in instance.
9677 while Present
(Gen_E
) and then Chars
(Gen_E
) /= Chars
(E
) loop
9678 Next_Entity
(Gen_E
);
9681 if Present
(Gen_E
) then
9682 Map_Formal_Package_Entities
(Gen_E
, E
);
9689 if Present
(Gen_E
) then
9690 Next_Entity
(Gen_E
);
9693 end Install_Formal_Packages
;
9695 --------------------
9696 -- Install_Parent --
9697 --------------------
9699 procedure Install_Parent
(P
: Entity_Id
; In_Body
: Boolean := False) is
9700 Ancestors
: constant Elist_Id
:= New_Elmt_List
;
9701 S
: constant Entity_Id
:= Current_Scope
;
9702 Inst_Par
: Entity_Id
;
9703 First_Par
: Entity_Id
;
9704 Inst_Node
: Node_Id
;
9705 Gen_Par
: Entity_Id
;
9706 First_Gen
: Entity_Id
;
9709 procedure Install_Noninstance_Specs
(Par
: Entity_Id
);
9710 -- Install the scopes of noninstance parent units ending with Par
9712 procedure Install_Spec
(Par
: Entity_Id
);
9713 -- The child unit is within the declarative part of the parent, so the
9714 -- declarations within the parent are immediately visible.
9716 -------------------------------
9717 -- Install_Noninstance_Specs --
9718 -------------------------------
9720 procedure Install_Noninstance_Specs
(Par
: Entity_Id
) is
9723 and then Par
/= Standard_Standard
9724 and then not In_Open_Scopes
(Par
)
9726 Install_Noninstance_Specs
(Scope
(Par
));
9729 end Install_Noninstance_Specs
;
9735 procedure Install_Spec
(Par
: Entity_Id
) is
9736 Spec
: constant Node_Id
:= Package_Specification
(Par
);
9739 -- If this parent of the child instance is a top-level unit,
9740 -- then record the unit and its visibility for later resetting in
9741 -- Remove_Parent. We exclude units that are generic instances, as we
9742 -- only want to record this information for the ultimate top-level
9743 -- noninstance parent (is that always correct???).
9745 if Scope
(Par
) = Standard_Standard
9746 and then not Is_Generic_Instance
(Par
)
9748 Parent_Unit_Visible
:= Is_Immediately_Visible
(Par
);
9749 Instance_Parent_Unit
:= Par
;
9752 -- Open the parent scope and make it and its declarations visible.
9753 -- If this point is not within a body, then only the visible
9754 -- declarations should be made visible, and installation of the
9755 -- private declarations is deferred until the appropriate point
9756 -- within analysis of the spec being instantiated (see the handling
9757 -- of parent visibility in Analyze_Package_Specification). This is
9758 -- relaxed in the case where the parent unit is Ada.Tags, to avoid
9759 -- private view problems that occur when compiling instantiations of
9760 -- a generic child of that package (Generic_Dispatching_Constructor).
9761 -- If the instance freezes a tagged type, inlinings of operations
9762 -- from Ada.Tags may need the full view of type Tag. If inlining took
9763 -- proper account of establishing visibility of inlined subprograms'
9764 -- parents then it should be possible to remove this
9765 -- special check. ???
9768 Set_Is_Immediately_Visible
(Par
);
9769 Install_Visible_Declarations
(Par
);
9770 Set_Use
(Visible_Declarations
(Spec
));
9772 if In_Body
or else Is_RTU
(Par
, Ada_Tags
) then
9773 Install_Private_Declarations
(Par
);
9774 Set_Use
(Private_Declarations
(Spec
));
9778 -- Start of processing for Install_Parent
9781 -- We need to install the parent instance to compile the instantiation
9782 -- of the child, but the child instance must appear in the current
9783 -- scope. Given that we cannot place the parent above the current scope
9784 -- in the scope stack, we duplicate the current scope and unstack both
9785 -- after the instantiation is complete.
9787 -- If the parent is itself the instantiation of a child unit, we must
9788 -- also stack the instantiation of its parent, and so on. Each such
9789 -- ancestor is the prefix of the name in a prior instantiation.
9791 -- If this is a nested instance, the parent unit itself resolves to
9792 -- a renaming of the parent instance, whose declaration we need.
9794 -- Finally, the parent may be a generic (not an instance) when the
9795 -- child unit appears as a formal package.
9799 if Present
(Renamed_Entity
(Inst_Par
)) then
9800 Inst_Par
:= Renamed_Entity
(Inst_Par
);
9803 First_Par
:= Inst_Par
;
9805 Gen_Par
:= Generic_Parent
(Package_Specification
(Inst_Par
));
9807 First_Gen
:= Gen_Par
;
9809 while Present
(Gen_Par
) and then Is_Child_Unit
(Gen_Par
) loop
9811 -- Load grandparent instance as well
9813 Inst_Node
:= Get_Unit_Instantiation_Node
(Inst_Par
);
9815 if Nkind
(Name
(Inst_Node
)) = N_Expanded_Name
then
9816 Inst_Par
:= Entity
(Prefix
(Name
(Inst_Node
)));
9818 if Present
(Renamed_Entity
(Inst_Par
)) then
9819 Inst_Par
:= Renamed_Entity
(Inst_Par
);
9822 Gen_Par
:= Generic_Parent
(Package_Specification
(Inst_Par
));
9824 if Present
(Gen_Par
) then
9825 Prepend_Elmt
(Inst_Par
, Ancestors
);
9828 -- Parent is not the name of an instantiation
9830 Install_Noninstance_Specs
(Inst_Par
);
9841 if Present
(First_Gen
) then
9842 Append_Elmt
(First_Par
, Ancestors
);
9844 Install_Noninstance_Specs
(First_Par
);
9847 if not Is_Empty_Elmt_List
(Ancestors
) then
9848 Elmt
:= First_Elmt
(Ancestors
);
9849 while Present
(Elmt
) loop
9850 Install_Spec
(Node
(Elmt
));
9851 Install_Formal_Packages
(Node
(Elmt
));
9861 -------------------------------
9862 -- Install_Hidden_Primitives --
9863 -------------------------------
9865 procedure Install_Hidden_Primitives
9866 (Prims_List
: in out Elist_Id
;
9871 List
: Elist_Id
:= No_Elist
;
9872 Prim_G_Elmt
: Elmt_Id
;
9873 Prim_A_Elmt
: Elmt_Id
;
9878 -- No action needed in case of serious errors because we cannot trust
9879 -- in the order of primitives
9881 if Serious_Errors_Detected
> 0 then
9884 -- No action possible if we don't have available the list of primitive
9888 or else not Is_Record_Type
(Gen_T
)
9889 or else not Is_Tagged_Type
(Gen_T
)
9890 or else not Is_Record_Type
(Act_T
)
9891 or else not Is_Tagged_Type
(Act_T
)
9895 -- There is no need to handle interface types since their primitives
9898 elsif Is_Interface
(Gen_T
) then
9902 Prim_G_Elmt
:= First_Elmt
(Primitive_Operations
(Gen_T
));
9904 if not Is_Class_Wide_Type
(Act_T
) then
9905 Prim_A_Elmt
:= First_Elmt
(Primitive_Operations
(Act_T
));
9907 Prim_A_Elmt
:= First_Elmt
(Primitive_Operations
(Root_Type
(Act_T
)));
9911 -- Skip predefined primitives in the generic formal
9913 while Present
(Prim_G_Elmt
)
9914 and then Is_Predefined_Dispatching_Operation
(Node
(Prim_G_Elmt
))
9916 Next_Elmt
(Prim_G_Elmt
);
9919 -- Skip predefined primitives in the generic actual
9921 while Present
(Prim_A_Elmt
)
9922 and then Is_Predefined_Dispatching_Operation
(Node
(Prim_A_Elmt
))
9924 Next_Elmt
(Prim_A_Elmt
);
9927 exit when No
(Prim_G_Elmt
) or else No
(Prim_A_Elmt
);
9929 Prim_G
:= Node
(Prim_G_Elmt
);
9930 Prim_A
:= Node
(Prim_A_Elmt
);
9932 -- There is no need to handle interface primitives because their
9933 -- primitives are not hidden
9935 exit when Present
(Interface_Alias
(Prim_G
));
9937 -- Here we install one hidden primitive
9939 if Chars
(Prim_G
) /= Chars
(Prim_A
)
9940 and then Has_Suffix
(Prim_A
, 'P')
9941 and then Remove_Suffix
(Prim_A
, 'P') = Chars
(Prim_G
)
9943 Set_Chars
(Prim_A
, Chars
(Prim_G
));
9944 Append_New_Elmt
(Prim_A
, To
=> List
);
9947 Next_Elmt
(Prim_A_Elmt
);
9948 Next_Elmt
(Prim_G_Elmt
);
9951 -- Append the elements to the list of temporarily visible primitives
9952 -- avoiding duplicates.
9954 if Present
(List
) then
9955 if No
(Prims_List
) then
9956 Prims_List
:= New_Elmt_List
;
9959 Elmt
:= First_Elmt
(List
);
9960 while Present
(Elmt
) loop
9961 Append_Unique_Elmt
(Node
(Elmt
), Prims_List
);
9965 end Install_Hidden_Primitives
;
9967 -------------------------------
9968 -- Restore_Hidden_Primitives --
9969 -------------------------------
9971 procedure Restore_Hidden_Primitives
(Prims_List
: in out Elist_Id
) is
9972 Prim_Elmt
: Elmt_Id
;
9976 if Prims_List
/= No_Elist
then
9977 Prim_Elmt
:= First_Elmt
(Prims_List
);
9978 while Present
(Prim_Elmt
) loop
9979 Prim
:= Node
(Prim_Elmt
);
9980 Set_Chars
(Prim
, Add_Suffix
(Prim
, 'P'));
9981 Next_Elmt
(Prim_Elmt
);
9984 Prims_List
:= No_Elist
;
9986 end Restore_Hidden_Primitives
;
9988 --------------------------------
9989 -- Instantiate_Formal_Package --
9990 --------------------------------
9992 function Instantiate_Formal_Package
9995 Analyzed_Formal
: Node_Id
) return List_Id
9997 Loc
: constant Source_Ptr
:= Sloc
(Actual
);
9998 Actual_Pack
: Entity_Id
;
9999 Formal_Pack
: Entity_Id
;
10000 Gen_Parent
: Entity_Id
;
10003 Parent_Spec
: Node_Id
;
10005 procedure Find_Matching_Actual
10007 Act
: in out Entity_Id
);
10008 -- We need to associate each formal entity in the formal package with
10009 -- the corresponding entity in the actual package. The actual package
10010 -- has been analyzed and possibly expanded, and as a result there is
10011 -- no one-to-one correspondence between the two lists (for example,
10012 -- the actual may include subtypes, itypes, and inherited primitive
10013 -- operations, interspersed among the renaming declarations for the
10014 -- actuals). We retrieve the corresponding actual by name because each
10015 -- actual has the same name as the formal, and they do appear in the
10018 function Get_Formal_Entity
(N
: Node_Id
) return Entity_Id
;
10019 -- Retrieve entity of defining entity of generic formal parameter.
10020 -- Only the declarations of formals need to be considered when
10021 -- linking them to actuals, but the declarative list may include
10022 -- internal entities generated during analysis, and those are ignored.
10024 procedure Match_Formal_Entity
10025 (Formal_Node
: Node_Id
;
10026 Formal_Ent
: Entity_Id
;
10027 Actual_Ent
: Entity_Id
);
10028 -- Associates the formal entity with the actual. In the case where
10029 -- Formal_Ent is a formal package, this procedure iterates through all
10030 -- of its formals and enters associations between the actuals occurring
10031 -- in the formal package's corresponding actual package (given by
10032 -- Actual_Ent) and the formal package's formal parameters. This
10033 -- procedure recurses if any of the parameters is itself a package.
10035 function Is_Instance_Of
10036 (Act_Spec
: Entity_Id
;
10037 Gen_Anc
: Entity_Id
) return Boolean;
10038 -- The actual can be an instantiation of a generic within another
10039 -- instance, in which case there is no direct link from it to the
10040 -- original generic ancestor. In that case, we recognize that the
10041 -- ultimate ancestor is the same by examining names and scopes.
10043 procedure Process_Nested_Formal
(Formal
: Entity_Id
);
10044 -- If the current formal is declared with a box, its own formals are
10045 -- visible in the instance, as they were in the generic, and their
10046 -- Hidden flag must be reset. If some of these formals are themselves
10047 -- packages declared with a box, the processing must be recursive.
10049 --------------------------
10050 -- Find_Matching_Actual --
10051 --------------------------
10053 procedure Find_Matching_Actual
10055 Act
: in out Entity_Id
)
10057 Formal_Ent
: Entity_Id
;
10060 case Nkind
(Original_Node
(F
)) is
10061 when N_Formal_Object_Declaration
10062 | N_Formal_Type_Declaration
10064 Formal_Ent
:= Defining_Identifier
(F
);
10066 while Chars
(Act
) /= Chars
(Formal_Ent
) loop
10070 when N_Formal_Package_Declaration
10071 | N_Formal_Subprogram_Declaration
10072 | N_Generic_Package_Declaration
10073 | N_Package_Declaration
10075 Formal_Ent
:= Defining_Entity
(F
);
10077 while Chars
(Act
) /= Chars
(Formal_Ent
) loop
10082 raise Program_Error
;
10084 end Find_Matching_Actual
;
10086 -------------------------
10087 -- Match_Formal_Entity --
10088 -------------------------
10090 procedure Match_Formal_Entity
10091 (Formal_Node
: Node_Id
;
10092 Formal_Ent
: Entity_Id
;
10093 Actual_Ent
: Entity_Id
)
10095 Act_Pkg
: Entity_Id
;
10098 Set_Instance_Of
(Formal_Ent
, Actual_Ent
);
10100 if Ekind
(Actual_Ent
) = E_Package
then
10102 -- Record associations for each parameter
10104 Act_Pkg
:= Actual_Ent
;
10107 A_Ent
: Entity_Id
:= First_Entity
(Act_Pkg
);
10111 Gen_Decl
: Node_Id
;
10113 Actual
: Entity_Id
;
10116 -- Retrieve the actual given in the formal package declaration
10118 Actual
:= Entity
(Name
(Original_Node
(Formal_Node
)));
10120 -- The actual in the formal package declaration may be a
10121 -- renamed generic package, in which case we want to retrieve
10122 -- the original generic in order to traverse its formal part.
10124 if Present
(Renamed_Entity
(Actual
)) then
10125 Gen_Decl
:= Unit_Declaration_Node
(Renamed_Entity
(Actual
));
10127 Gen_Decl
:= Unit_Declaration_Node
(Actual
);
10130 Formals
:= Generic_Formal_Declarations
(Gen_Decl
);
10132 if Present
(Formals
) then
10133 F_Node
:= First_Non_Pragma
(Formals
);
10138 while Present
(A_Ent
)
10139 and then Present
(F_Node
)
10140 and then A_Ent
/= First_Private_Entity
(Act_Pkg
)
10142 F_Ent
:= Get_Formal_Entity
(F_Node
);
10144 if Present
(F_Ent
) then
10146 -- This is a formal of the original package. Record
10147 -- association and recurse.
10149 Find_Matching_Actual
(F_Node
, A_Ent
);
10150 Match_Formal_Entity
(F_Node
, F_Ent
, A_Ent
);
10151 Next_Entity
(A_Ent
);
10154 Next_Non_Pragma
(F_Node
);
10158 end Match_Formal_Entity
;
10160 -----------------------
10161 -- Get_Formal_Entity --
10162 -----------------------
10164 function Get_Formal_Entity
(N
: Node_Id
) return Entity_Id
is
10165 Kind
: constant Node_Kind
:= Nkind
(Original_Node
(N
));
10168 when N_Formal_Object_Declaration
=>
10169 return Defining_Identifier
(N
);
10171 when N_Formal_Type_Declaration
=>
10172 return Defining_Identifier
(N
);
10174 when N_Formal_Subprogram_Declaration
=>
10175 return Defining_Unit_Name
(Specification
(N
));
10177 when N_Formal_Package_Declaration
=>
10178 return Defining_Identifier
(Original_Node
(N
));
10180 when N_Generic_Package_Declaration
=>
10181 return Defining_Identifier
(Original_Node
(N
));
10183 -- All other declarations are introduced by semantic analysis and
10184 -- have no match in the actual.
10189 end Get_Formal_Entity
;
10191 --------------------
10192 -- Is_Instance_Of --
10193 --------------------
10195 function Is_Instance_Of
10196 (Act_Spec
: Entity_Id
;
10197 Gen_Anc
: Entity_Id
) return Boolean
10199 Gen_Par
: constant Entity_Id
:= Generic_Parent
(Act_Spec
);
10202 if No
(Gen_Par
) then
10205 -- Simplest case: the generic parent of the actual is the formal
10207 elsif Gen_Par
= Gen_Anc
then
10210 elsif Chars
(Gen_Par
) /= Chars
(Gen_Anc
) then
10213 -- The actual may be obtained through several instantiations. Its
10214 -- scope must itself be an instance of a generic declared in the
10215 -- same scope as the formal. Any other case is detected above.
10217 elsif not Is_Generic_Instance
(Scope
(Gen_Par
)) then
10221 return Generic_Parent
(Parent
(Scope
(Gen_Par
))) = Scope
(Gen_Anc
);
10223 end Is_Instance_Of
;
10225 ---------------------------
10226 -- Process_Nested_Formal --
10227 ---------------------------
10229 procedure Process_Nested_Formal
(Formal
: Entity_Id
) is
10233 if Present
(Associated_Formal_Package
(Formal
))
10234 and then Box_Present
(Parent
(Associated_Formal_Package
(Formal
)))
10236 Ent
:= First_Entity
(Formal
);
10237 while Present
(Ent
) loop
10238 Set_Is_Hidden
(Ent
, False);
10239 Set_Is_Visible_Formal
(Ent
);
10240 Set_Is_Potentially_Use_Visible
10241 (Ent
, Is_Potentially_Use_Visible
(Formal
));
10243 if Ekind
(Ent
) = E_Package
then
10244 exit when Renamed_Entity
(Ent
) = Renamed_Entity
(Formal
);
10245 Process_Nested_Formal
(Ent
);
10251 end Process_Nested_Formal
;
10253 -- Start of processing for Instantiate_Formal_Package
10258 if not Is_Entity_Name
(Actual
)
10259 or else Ekind
(Entity
(Actual
)) /= E_Package
10262 ("expect package instance to instantiate formal", Actual
);
10263 Abandon_Instantiation
(Actual
);
10264 raise Program_Error
;
10267 Actual_Pack
:= Entity
(Actual
);
10268 Set_Is_Instantiated
(Actual_Pack
);
10270 -- The actual may be a renamed package, or an outer generic formal
10271 -- package whose instantiation is converted into a renaming.
10273 if Present
(Renamed_Object
(Actual_Pack
)) then
10274 Actual_Pack
:= Renamed_Object
(Actual_Pack
);
10277 if Nkind
(Analyzed_Formal
) = N_Formal_Package_Declaration
then
10278 Gen_Parent
:= Get_Instance_Of
(Entity
(Name
(Analyzed_Formal
)));
10279 Formal_Pack
:= Defining_Identifier
(Analyzed_Formal
);
10282 Generic_Parent
(Specification
(Analyzed_Formal
));
10284 Defining_Unit_Name
(Specification
(Analyzed_Formal
));
10287 if Nkind
(Parent
(Actual_Pack
)) = N_Defining_Program_Unit_Name
then
10288 Parent_Spec
:= Package_Specification
(Actual_Pack
);
10290 Parent_Spec
:= Parent
(Actual_Pack
);
10293 if Gen_Parent
= Any_Id
then
10295 ("previous error in declaration of formal package", Actual
);
10296 Abandon_Instantiation
(Actual
);
10299 Is_Instance_Of
(Parent_Spec
, Get_Instance_Of
(Gen_Parent
))
10305 ("actual parameter must be instance of&", Actual
, Gen_Parent
);
10306 Abandon_Instantiation
(Actual
);
10309 Set_Instance_Of
(Defining_Identifier
(Formal
), Actual_Pack
);
10310 Map_Formal_Package_Entities
(Formal_Pack
, Actual_Pack
);
10313 Make_Package_Renaming_Declaration
(Loc
,
10314 Defining_Unit_Name
=> New_Copy
(Defining_Identifier
(Formal
)),
10315 Name
=> New_Occurrence_Of
(Actual_Pack
, Loc
));
10317 Set_Associated_Formal_Package
10318 (Defining_Unit_Name
(Nod
), Defining_Identifier
(Formal
));
10319 Decls
:= New_List
(Nod
);
10321 -- If the formal F has a box, then the generic declarations are
10322 -- visible in the generic G. In an instance of G, the corresponding
10323 -- entities in the actual for F (which are the actuals for the
10324 -- instantiation of the generic that F denotes) must also be made
10325 -- visible for analysis of the current instance. On exit from the
10326 -- current instance, those entities are made private again. If the
10327 -- actual is currently in use, these entities are also use-visible.
10329 -- The loop through the actual entities also steps through the formal
10330 -- entities and enters associations from formals to actuals into the
10331 -- renaming map. This is necessary to properly handle checking of
10332 -- actual parameter associations for later formals that depend on
10333 -- actuals declared in the formal package.
10335 -- In Ada 2005, partial parameterization requires that we make
10336 -- visible the actuals corresponding to formals that were defaulted
10337 -- in the formal package. There formals are identified because they
10338 -- remain formal generics within the formal package, rather than
10339 -- being renamings of the actuals supplied.
10342 Gen_Decl
: constant Node_Id
:=
10343 Unit_Declaration_Node
(Gen_Parent
);
10344 Formals
: constant List_Id
:=
10345 Generic_Formal_Declarations
(Gen_Decl
);
10347 Actual_Ent
: Entity_Id
;
10348 Actual_Of_Formal
: Node_Id
;
10349 Formal_Node
: Node_Id
;
10350 Formal_Ent
: Entity_Id
;
10353 if Present
(Formals
) then
10354 Formal_Node
:= First_Non_Pragma
(Formals
);
10356 Formal_Node
:= Empty
;
10359 Actual_Ent
:= First_Entity
(Actual_Pack
);
10360 Actual_Of_Formal
:=
10361 First
(Visible_Declarations
(Specification
(Analyzed_Formal
)));
10362 while Present
(Actual_Ent
)
10363 and then Actual_Ent
/= First_Private_Entity
(Actual_Pack
)
10365 if Present
(Formal_Node
) then
10366 Formal_Ent
:= Get_Formal_Entity
(Formal_Node
);
10368 if Present
(Formal_Ent
) then
10369 Find_Matching_Actual
(Formal_Node
, Actual_Ent
);
10370 Match_Formal_Entity
(Formal_Node
, Formal_Ent
, Actual_Ent
);
10372 -- We iterate at the same time over the actuals of the
10373 -- local package created for the formal, to determine
10374 -- which one of the formals of the original generic were
10375 -- defaulted in the formal. The corresponding actual
10376 -- entities are visible in the enclosing instance.
10378 if Box_Present
(Formal
)
10380 (Present
(Actual_Of_Formal
)
10383 (Get_Formal_Entity
(Actual_Of_Formal
)))
10385 Set_Is_Hidden
(Actual_Ent
, False);
10386 Set_Is_Visible_Formal
(Actual_Ent
);
10387 Set_Is_Potentially_Use_Visible
10388 (Actual_Ent
, In_Use
(Actual_Pack
));
10390 if Ekind
(Actual_Ent
) = E_Package
then
10391 Process_Nested_Formal
(Actual_Ent
);
10395 Set_Is_Hidden
(Actual_Ent
);
10396 Set_Is_Potentially_Use_Visible
(Actual_Ent
, False);
10400 Next_Non_Pragma
(Formal_Node
);
10401 Next
(Actual_Of_Formal
);
10404 -- No further formals to match, but the generic part may
10405 -- contain inherited operation that are not hidden in the
10406 -- enclosing instance.
10408 Next_Entity
(Actual_Ent
);
10412 -- Inherited subprograms generated by formal derived types are
10413 -- also visible if the types are.
10415 Actual_Ent
:= First_Entity
(Actual_Pack
);
10416 while Present
(Actual_Ent
)
10417 and then Actual_Ent
/= First_Private_Entity
(Actual_Pack
)
10419 if Is_Overloadable
(Actual_Ent
)
10421 Nkind
(Parent
(Actual_Ent
)) = N_Subtype_Declaration
10423 not Is_Hidden
(Defining_Identifier
(Parent
(Actual_Ent
)))
10425 Set_Is_Hidden
(Actual_Ent
, False);
10426 Set_Is_Potentially_Use_Visible
10427 (Actual_Ent
, In_Use
(Actual_Pack
));
10430 Next_Entity
(Actual_Ent
);
10434 -- If the formal is not declared with a box, reanalyze it as an
10435 -- abbreviated instantiation, to verify the matching rules of 12.7.
10436 -- The actual checks are performed after the generic associations
10437 -- have been analyzed, to guarantee the same visibility for this
10438 -- instantiation and for the actuals.
10440 -- In Ada 2005, the generic associations for the formal can include
10441 -- defaulted parameters. These are ignored during check. This
10442 -- internal instantiation is removed from the tree after conformance
10443 -- checking, because it contains formal declarations for those
10444 -- defaulted parameters, and those should not reach the back-end.
10446 if not Box_Present
(Formal
) then
10448 I_Pack
: constant Entity_Id
:=
10449 Make_Temporary
(Sloc
(Actual
), 'P');
10452 Set_Is_Internal
(I_Pack
);
10455 Make_Package_Instantiation
(Sloc
(Actual
),
10456 Defining_Unit_Name
=> I_Pack
,
10459 (Get_Instance_Of
(Gen_Parent
), Sloc
(Actual
)),
10460 Generic_Associations
=> Generic_Associations
(Formal
)));
10466 end Instantiate_Formal_Package
;
10468 -----------------------------------
10469 -- Instantiate_Formal_Subprogram --
10470 -----------------------------------
10472 function Instantiate_Formal_Subprogram
10475 Analyzed_Formal
: Node_Id
) return Node_Id
10477 Analyzed_S
: constant Entity_Id
:=
10478 Defining_Unit_Name
(Specification
(Analyzed_Formal
));
10479 Formal_Sub
: constant Entity_Id
:=
10480 Defining_Unit_Name
(Specification
(Formal
));
10482 function From_Parent_Scope
(Subp
: Entity_Id
) return Boolean;
10483 -- If the generic is a child unit, the parent has been installed on the
10484 -- scope stack, but a default subprogram cannot resolve to something
10485 -- on the parent because that parent is not really part of the visible
10486 -- context (it is there to resolve explicit local entities). If the
10487 -- default has resolved in this way, we remove the entity from immediate
10488 -- visibility and analyze the node again to emit an error message or
10489 -- find another visible candidate.
10491 procedure Valid_Actual_Subprogram
(Act
: Node_Id
);
10492 -- Perform legality check and raise exception on failure
10494 -----------------------
10495 -- From_Parent_Scope --
10496 -----------------------
10498 function From_Parent_Scope
(Subp
: Entity_Id
) return Boolean is
10499 Gen_Scope
: Node_Id
;
10502 Gen_Scope
:= Scope
(Analyzed_S
);
10503 while Present
(Gen_Scope
) and then Is_Child_Unit
(Gen_Scope
) loop
10504 if Scope
(Subp
) = Scope
(Gen_Scope
) then
10508 Gen_Scope
:= Scope
(Gen_Scope
);
10512 end From_Parent_Scope
;
10514 -----------------------------
10515 -- Valid_Actual_Subprogram --
10516 -----------------------------
10518 procedure Valid_Actual_Subprogram
(Act
: Node_Id
) is
10522 if Is_Entity_Name
(Act
) then
10523 Act_E
:= Entity
(Act
);
10525 elsif Nkind
(Act
) = N_Selected_Component
10526 and then Is_Entity_Name
(Selector_Name
(Act
))
10528 Act_E
:= Entity
(Selector_Name
(Act
));
10534 if (Present
(Act_E
) and then Is_Overloadable
(Act_E
))
10535 or else Nkind_In
(Act
, N_Attribute_Reference
,
10536 N_Indexed_Component
,
10537 N_Character_Literal
,
10538 N_Explicit_Dereference
)
10544 ("expect subprogram or entry name in instantiation of &",
10545 Instantiation_Node
, Formal_Sub
);
10546 Abandon_Instantiation
(Instantiation_Node
);
10547 end Valid_Actual_Subprogram
;
10551 Decl_Node
: Node_Id
;
10554 New_Spec
: Node_Id
;
10555 New_Subp
: Entity_Id
;
10557 -- Start of processing for Instantiate_Formal_Subprogram
10560 New_Spec
:= New_Copy_Tree
(Specification
(Formal
));
10562 -- The tree copy has created the proper instantiation sloc for the
10563 -- new specification. Use this location for all other constructed
10566 Loc
:= Sloc
(Defining_Unit_Name
(New_Spec
));
10568 -- Create new entity for the actual (New_Copy_Tree does not), and
10569 -- indicate that it is an actual.
10571 New_Subp
:= Make_Defining_Identifier
(Loc
, Chars
(Formal_Sub
));
10572 Set_Ekind
(New_Subp
, Ekind
(Analyzed_S
));
10573 Set_Is_Generic_Actual_Subprogram
(New_Subp
);
10574 Set_Defining_Unit_Name
(New_Spec
, New_Subp
);
10576 -- Create new entities for the each of the formals in the specification
10577 -- of the renaming declaration built for the actual.
10579 if Present
(Parameter_Specifications
(New_Spec
)) then
10585 F
:= First
(Parameter_Specifications
(New_Spec
));
10586 while Present
(F
) loop
10587 F_Id
:= Defining_Identifier
(F
);
10589 Set_Defining_Identifier
(F
,
10590 Make_Defining_Identifier
(Sloc
(F_Id
), Chars
(F_Id
)));
10596 -- Find entity of actual. If the actual is an attribute reference, it
10597 -- cannot be resolved here (its formal is missing) but is handled
10598 -- instead in Attribute_Renaming. If the actual is overloaded, it is
10599 -- fully resolved subsequently, when the renaming declaration for the
10600 -- formal is analyzed. If it is an explicit dereference, resolve the
10601 -- prefix but not the actual itself, to prevent interpretation as call.
10603 if Present
(Actual
) then
10604 Loc
:= Sloc
(Actual
);
10605 Set_Sloc
(New_Spec
, Loc
);
10607 if Nkind
(Actual
) = N_Operator_Symbol
then
10608 Find_Direct_Name
(Actual
);
10610 elsif Nkind
(Actual
) = N_Explicit_Dereference
then
10611 Analyze
(Prefix
(Actual
));
10613 elsif Nkind
(Actual
) /= N_Attribute_Reference
then
10617 Valid_Actual_Subprogram
(Actual
);
10620 elsif Present
(Default_Name
(Formal
)) then
10621 if not Nkind_In
(Default_Name
(Formal
), N_Attribute_Reference
,
10622 N_Selected_Component
,
10623 N_Indexed_Component
,
10624 N_Character_Literal
)
10625 and then Present
(Entity
(Default_Name
(Formal
)))
10627 Nam
:= New_Occurrence_Of
(Entity
(Default_Name
(Formal
)), Loc
);
10629 Nam
:= New_Copy
(Default_Name
(Formal
));
10630 Set_Sloc
(Nam
, Loc
);
10633 elsif Box_Present
(Formal
) then
10635 -- Actual is resolved at the point of instantiation. Create an
10636 -- identifier or operator with the same name as the formal.
10638 if Nkind
(Formal_Sub
) = N_Defining_Operator_Symbol
then
10640 Make_Operator_Symbol
(Loc
,
10641 Chars
=> Chars
(Formal_Sub
),
10642 Strval
=> No_String
);
10644 Nam
:= Make_Identifier
(Loc
, Chars
(Formal_Sub
));
10647 elsif Nkind
(Specification
(Formal
)) = N_Procedure_Specification
10648 and then Null_Present
(Specification
(Formal
))
10650 -- Generate null body for procedure, for use in the instance
10653 Make_Subprogram_Body
(Loc
,
10654 Specification
=> New_Spec
,
10655 Declarations
=> New_List
,
10656 Handled_Statement_Sequence
=>
10657 Make_Handled_Sequence_Of_Statements
(Loc
,
10658 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
10660 Set_Is_Intrinsic_Subprogram
(Defining_Unit_Name
(New_Spec
));
10664 Error_Msg_Sloc
:= Sloc
(Scope
(Analyzed_S
));
10666 ("missing actual&", Instantiation_Node
, Formal_Sub
);
10668 ("\in instantiation of & declared#",
10669 Instantiation_Node
, Scope
(Analyzed_S
));
10670 Abandon_Instantiation
(Instantiation_Node
);
10674 Make_Subprogram_Renaming_Declaration
(Loc
,
10675 Specification
=> New_Spec
,
10678 -- If we do not have an actual and the formal specified <> then set to
10679 -- get proper default.
10681 if No
(Actual
) and then Box_Present
(Formal
) then
10682 Set_From_Default
(Decl_Node
);
10685 -- Gather possible interpretations for the actual before analyzing the
10686 -- instance. If overloaded, it will be resolved when analyzing the
10687 -- renaming declaration.
10689 if Box_Present
(Formal
) and then No
(Actual
) then
10692 if Is_Child_Unit
(Scope
(Analyzed_S
))
10693 and then Present
(Entity
(Nam
))
10695 if not Is_Overloaded
(Nam
) then
10696 if From_Parent_Scope
(Entity
(Nam
)) then
10697 Set_Is_Immediately_Visible
(Entity
(Nam
), False);
10698 Set_Entity
(Nam
, Empty
);
10699 Set_Etype
(Nam
, Empty
);
10702 Set_Is_Immediately_Visible
(Entity
(Nam
));
10711 Get_First_Interp
(Nam
, I
, It
);
10712 while Present
(It
.Nam
) loop
10713 if From_Parent_Scope
(It
.Nam
) then
10717 Get_Next_Interp
(I
, It
);
10724 -- The generic instantiation freezes the actual. This can only be done
10725 -- once the actual is resolved, in the analysis of the renaming
10726 -- declaration. To make the formal subprogram entity available, we set
10727 -- Corresponding_Formal_Spec to point to the formal subprogram entity.
10728 -- This is also needed in Analyze_Subprogram_Renaming for the processing
10729 -- of formal abstract subprograms.
10731 Set_Corresponding_Formal_Spec
(Decl_Node
, Analyzed_S
);
10733 -- We cannot analyze the renaming declaration, and thus find the actual,
10734 -- until all the actuals are assembled in the instance. For subsequent
10735 -- checks of other actuals, indicate the node that will hold the
10736 -- instance of this formal.
10738 Set_Instance_Of
(Analyzed_S
, Nam
);
10740 if Nkind
(Actual
) = N_Selected_Component
10741 and then Is_Task_Type
(Etype
(Prefix
(Actual
)))
10742 and then not Is_Frozen
(Etype
(Prefix
(Actual
)))
10744 -- The renaming declaration will create a body, which must appear
10745 -- outside of the instantiation, We move the renaming declaration
10746 -- out of the instance, and create an additional renaming inside,
10747 -- to prevent freezing anomalies.
10750 Anon_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E');
10753 Set_Defining_Unit_Name
(New_Spec
, Anon_Id
);
10754 Insert_Before
(Instantiation_Node
, Decl_Node
);
10755 Analyze
(Decl_Node
);
10757 -- Now create renaming within the instance
10760 Make_Subprogram_Renaming_Declaration
(Loc
,
10761 Specification
=> New_Copy_Tree
(New_Spec
),
10762 Name
=> New_Occurrence_Of
(Anon_Id
, Loc
));
10764 Set_Defining_Unit_Name
(Specification
(Decl_Node
),
10765 Make_Defining_Identifier
(Loc
, Chars
(Formal_Sub
)));
10770 end Instantiate_Formal_Subprogram
;
10772 ------------------------
10773 -- Instantiate_Object --
10774 ------------------------
10776 function Instantiate_Object
10779 Analyzed_Formal
: Node_Id
) return List_Id
10781 Gen_Obj
: constant Entity_Id
:= Defining_Identifier
(Formal
);
10782 A_Gen_Obj
: constant Entity_Id
:=
10783 Defining_Identifier
(Analyzed_Formal
);
10784 Acc_Def
: Node_Id
:= Empty
;
10785 Act_Assoc
: constant Node_Id
:= Parent
(Actual
);
10786 Actual_Decl
: Node_Id
:= Empty
;
10787 Decl_Node
: Node_Id
;
10790 List
: constant List_Id
:= New_List
;
10791 Loc
: constant Source_Ptr
:= Sloc
(Actual
);
10792 Orig_Ftyp
: constant Entity_Id
:= Etype
(A_Gen_Obj
);
10793 Subt_Decl
: Node_Id
:= Empty
;
10794 Subt_Mark
: Node_Id
:= Empty
;
10796 function Copy_Access_Def
return Node_Id
;
10797 -- If formal is an anonymous access, copy access definition of formal
10798 -- for generated object declaration.
10800 ---------------------
10801 -- Copy_Access_Def --
10802 ---------------------
10804 function Copy_Access_Def
return Node_Id
is
10806 Def
:= New_Copy_Tree
(Acc_Def
);
10808 -- In addition, if formal is an access to subprogram we need to
10809 -- generate new formals for the signature of the default, so that
10810 -- the tree is properly formatted for ASIS use.
10812 if Present
(Access_To_Subprogram_Definition
(Acc_Def
)) then
10814 Par_Spec
: Node_Id
;
10817 First
(Parameter_Specifications
10818 (Access_To_Subprogram_Definition
(Def
)));
10819 while Present
(Par_Spec
) loop
10820 Set_Defining_Identifier
(Par_Spec
,
10821 Make_Defining_Identifier
(Sloc
(Acc_Def
),
10822 Chars
=> Chars
(Defining_Identifier
(Par_Spec
))));
10829 end Copy_Access_Def
;
10831 -- Start of processing for Instantiate_Object
10834 -- Formal may be an anonymous access
10836 if Present
(Subtype_Mark
(Formal
)) then
10837 Subt_Mark
:= Subtype_Mark
(Formal
);
10839 Check_Access_Definition
(Formal
);
10840 Acc_Def
:= Access_Definition
(Formal
);
10843 -- Sloc for error message on missing actual
10845 Error_Msg_Sloc
:= Sloc
(Scope
(A_Gen_Obj
));
10847 if Get_Instance_Of
(Gen_Obj
) /= Gen_Obj
then
10848 Error_Msg_N
("duplicate instantiation of generic parameter", Actual
);
10851 Set_Parent
(List
, Parent
(Actual
));
10855 if Out_Present
(Formal
) then
10857 -- An IN OUT generic actual must be a name. The instantiation is a
10858 -- renaming declaration. The actual is the name being renamed. We
10859 -- use the actual directly, rather than a copy, because it is not
10860 -- used further in the list of actuals, and because a copy or a use
10861 -- of relocate_node is incorrect if the instance is nested within a
10862 -- generic. In order to simplify ASIS searches, the Generic_Parent
10863 -- field links the declaration to the generic association.
10865 if No
(Actual
) then
10867 ("missing actual &",
10868 Instantiation_Node
, Gen_Obj
);
10870 ("\in instantiation of & declared#",
10871 Instantiation_Node
, Scope
(A_Gen_Obj
));
10872 Abandon_Instantiation
(Instantiation_Node
);
10875 if Present
(Subt_Mark
) then
10877 Make_Object_Renaming_Declaration
(Loc
,
10878 Defining_Identifier
=> New_Copy
(Gen_Obj
),
10879 Subtype_Mark
=> New_Copy_Tree
(Subt_Mark
),
10882 else pragma Assert
(Present
(Acc_Def
));
10884 Make_Object_Renaming_Declaration
(Loc
,
10885 Defining_Identifier
=> New_Copy
(Gen_Obj
),
10886 Access_Definition
=> New_Copy_Tree
(Acc_Def
),
10890 Set_Corresponding_Generic_Association
(Decl_Node
, Act_Assoc
);
10892 -- The analysis of the actual may produce Insert_Action nodes, so
10893 -- the declaration must have a context in which to attach them.
10895 Append
(Decl_Node
, List
);
10898 -- Return if the analysis of the actual reported some error
10900 if Etype
(Actual
) = Any_Type
then
10904 -- This check is performed here because Analyze_Object_Renaming will
10905 -- not check it when Comes_From_Source is False. Note though that the
10906 -- check for the actual being the name of an object will be performed
10907 -- in Analyze_Object_Renaming.
10909 if Is_Object_Reference
(Actual
)
10910 and then Is_Dependent_Component_Of_Mutable_Object
(Actual
)
10913 ("illegal discriminant-dependent component for in out parameter",
10917 -- The actual has to be resolved in order to check that it is a
10918 -- variable (due to cases such as F (1), where F returns access to
10919 -- an array, and for overloaded prefixes).
10921 Ftyp
:= Get_Instance_Of
(Etype
(A_Gen_Obj
));
10923 -- If the type of the formal is not itself a formal, and the current
10924 -- unit is a child unit, the formal type must be declared in a
10925 -- parent, and must be retrieved by visibility.
10927 if Ftyp
= Orig_Ftyp
10928 and then Is_Generic_Unit
(Scope
(Ftyp
))
10929 and then Is_Child_Unit
(Scope
(A_Gen_Obj
))
10932 Temp
: constant Node_Id
:=
10933 New_Copy_Tree
(Subtype_Mark
(Analyzed_Formal
));
10935 Set_Entity
(Temp
, Empty
);
10937 Ftyp
:= Entity
(Temp
);
10941 if Is_Private_Type
(Ftyp
)
10942 and then not Is_Private_Type
(Etype
(Actual
))
10943 and then (Base_Type
(Full_View
(Ftyp
)) = Base_Type
(Etype
(Actual
))
10944 or else Base_Type
(Etype
(Actual
)) = Ftyp
)
10946 -- If the actual has the type of the full view of the formal, or
10947 -- else a non-private subtype of the formal, then the visibility
10948 -- of the formal type has changed. Add to the actuals a subtype
10949 -- declaration that will force the exchange of views in the body
10950 -- of the instance as well.
10953 Make_Subtype_Declaration
(Loc
,
10954 Defining_Identifier
=> Make_Temporary
(Loc
, 'P'),
10955 Subtype_Indication
=> New_Occurrence_Of
(Ftyp
, Loc
));
10957 Prepend
(Subt_Decl
, List
);
10959 Prepend_Elmt
(Full_View
(Ftyp
), Exchanged_Views
);
10960 Exchange_Declarations
(Ftyp
);
10963 Resolve
(Actual
, Ftyp
);
10965 if not Denotes_Variable
(Actual
) then
10966 Error_Msg_NE
("actual for& must be a variable", Actual
, Gen_Obj
);
10968 elsif Base_Type
(Ftyp
) /= Base_Type
(Etype
(Actual
)) then
10970 -- Ada 2005 (AI-423): For a generic formal object of mode in out,
10971 -- the type of the actual shall resolve to a specific anonymous
10974 if Ada_Version
< Ada_2005
10975 or else Ekind
(Base_Type
(Ftyp
)) /=
10976 E_Anonymous_Access_Type
10977 or else Ekind
(Base_Type
(Etype
(Actual
))) /=
10978 E_Anonymous_Access_Type
10981 ("type of actual does not match type of&", Actual
, Gen_Obj
);
10985 Note_Possible_Modification
(Actual
, Sure
=> True);
10987 -- Check for instantiation of atomic/volatile actual for
10988 -- non-atomic/volatile formal (RM C.6 (12)).
10990 if Is_Atomic_Object
(Actual
) and then not Is_Atomic
(Orig_Ftyp
) then
10992 ("cannot instantiate non-atomic formal object "
10993 & "with atomic actual", Actual
);
10995 elsif Is_Volatile_Object
(Actual
) and then not Is_Volatile
(Orig_Ftyp
)
10998 ("cannot instantiate non-volatile formal object "
10999 & "with volatile actual", Actual
);
11002 -- Formal in-parameter
11005 -- The instantiation of a generic formal in-parameter is constant
11006 -- declaration. The actual is the expression for that declaration.
11007 -- Its type is a full copy of the type of the formal. This may be
11008 -- an access to subprogram, for which we need to generate entities
11009 -- for the formals in the new signature.
11011 if Present
(Actual
) then
11012 if Present
(Subt_Mark
) then
11013 Def
:= New_Copy_Tree
(Subt_Mark
);
11014 else pragma Assert
(Present
(Acc_Def
));
11015 Def
:= Copy_Access_Def
;
11019 Make_Object_Declaration
(Loc
,
11020 Defining_Identifier
=> New_Copy
(Gen_Obj
),
11021 Constant_Present
=> True,
11022 Null_Exclusion_Present
=> Null_Exclusion_Present
(Formal
),
11023 Object_Definition
=> Def
,
11024 Expression
=> Actual
);
11026 Set_Corresponding_Generic_Association
(Decl_Node
, Act_Assoc
);
11028 -- A generic formal object of a tagged type is defined to be
11029 -- aliased so the new constant must also be treated as aliased.
11031 if Is_Tagged_Type
(Etype
(A_Gen_Obj
)) then
11032 Set_Aliased_Present
(Decl_Node
);
11035 Append
(Decl_Node
, List
);
11037 -- No need to repeat (pre-)analysis of some expression nodes
11038 -- already handled in Preanalyze_Actuals.
11040 if Nkind
(Actual
) /= N_Allocator
then
11043 -- Return if the analysis of the actual reported some error
11045 if Etype
(Actual
) = Any_Type
then
11051 Formal_Type
: constant Entity_Id
:= Etype
(A_Gen_Obj
);
11055 Typ
:= Get_Instance_Of
(Formal_Type
);
11057 -- If the actual appears in the current or an enclosing scope,
11058 -- use its type directly. This is relevant if it has an actual
11059 -- subtype that is distinct from its nominal one. This cannot
11060 -- be done in general because the type of the actual may
11061 -- depend on other actuals, and only be fully determined when
11062 -- the enclosing instance is analyzed.
11064 if Present
(Etype
(Actual
))
11065 and then Is_Constr_Subt_For_U_Nominal
(Etype
(Actual
))
11067 Freeze_Before
(Instantiation_Node
, Etype
(Actual
));
11069 Freeze_Before
(Instantiation_Node
, Typ
);
11072 -- If the actual is an aggregate, perform name resolution on
11073 -- its components (the analysis of an aggregate does not do it)
11074 -- to capture local names that may be hidden if the generic is
11077 if Nkind
(Actual
) = N_Aggregate
then
11078 Preanalyze_And_Resolve
(Actual
, Typ
);
11081 if Is_Limited_Type
(Typ
)
11082 and then not OK_For_Limited_Init
(Typ
, Actual
)
11085 ("initialization not allowed for limited types", Actual
);
11086 Explain_Limited_Type
(Typ
, Actual
);
11090 elsif Present
(Default_Expression
(Formal
)) then
11092 -- Use default to construct declaration
11094 if Present
(Subt_Mark
) then
11095 Def
:= New_Copy
(Subt_Mark
);
11096 else pragma Assert
(Present
(Acc_Def
));
11097 Def
:= Copy_Access_Def
;
11101 Make_Object_Declaration
(Sloc
(Formal
),
11102 Defining_Identifier
=> New_Copy
(Gen_Obj
),
11103 Constant_Present
=> True,
11104 Null_Exclusion_Present
=> Null_Exclusion_Present
(Formal
),
11105 Object_Definition
=> Def
,
11106 Expression
=> New_Copy_Tree
11107 (Default_Expression
(Formal
)));
11109 Append
(Decl_Node
, List
);
11110 Set_Analyzed
(Expression
(Decl_Node
), False);
11113 Error_Msg_NE
("missing actual&", Instantiation_Node
, Gen_Obj
);
11114 Error_Msg_NE
("\in instantiation of & declared#",
11115 Instantiation_Node
, Scope
(A_Gen_Obj
));
11117 if Is_Scalar_Type
(Etype
(A_Gen_Obj
)) then
11119 -- Create dummy constant declaration so that instance can be
11120 -- analyzed, to minimize cascaded visibility errors.
11122 if Present
(Subt_Mark
) then
11124 else pragma Assert
(Present
(Acc_Def
));
11129 Make_Object_Declaration
(Loc
,
11130 Defining_Identifier
=> New_Copy
(Gen_Obj
),
11131 Constant_Present
=> True,
11132 Null_Exclusion_Present
=> Null_Exclusion_Present
(Formal
),
11133 Object_Definition
=> New_Copy
(Def
),
11135 Make_Attribute_Reference
(Sloc
(Gen_Obj
),
11136 Attribute_Name
=> Name_First
,
11137 Prefix
=> New_Copy
(Def
)));
11139 Append
(Decl_Node
, List
);
11142 Abandon_Instantiation
(Instantiation_Node
);
11147 if Nkind
(Actual
) in N_Has_Entity
then
11148 Actual_Decl
:= Parent
(Entity
(Actual
));
11151 -- Ada 2005 (AI-423): For a formal object declaration with a null
11152 -- exclusion or an access definition that has a null exclusion: If the
11153 -- actual matching the formal object declaration denotes a generic
11154 -- formal object of another generic unit G, and the instantiation
11155 -- containing the actual occurs within the body of G or within the body
11156 -- of a generic unit declared within the declarative region of G, then
11157 -- the declaration of the formal object of G must have a null exclusion.
11158 -- Otherwise, the subtype of the actual matching the formal object
11159 -- declaration shall exclude null.
11161 if Ada_Version
>= Ada_2005
11162 and then Present
(Actual_Decl
)
11163 and then Nkind_In
(Actual_Decl
, N_Formal_Object_Declaration
,
11164 N_Object_Declaration
)
11165 and then Nkind
(Analyzed_Formal
) = N_Formal_Object_Declaration
11166 and then not Has_Null_Exclusion
(Actual_Decl
)
11167 and then Has_Null_Exclusion
(Analyzed_Formal
)
11169 Error_Msg_Sloc
:= Sloc
(Analyzed_Formal
);
11171 ("actual must exclude null to match generic formal#", Actual
);
11174 -- An effectively volatile object cannot be used as an actual in a
11175 -- generic instantiation (SPARK RM 7.1.3(7)). The following check is
11176 -- relevant only when SPARK_Mode is on as it is not a standard Ada
11177 -- legality rule, and also verifies that the actual is an object.
11180 and then Present
(Actual
)
11181 and then Is_Object_Reference
(Actual
)
11182 and then Is_Effectively_Volatile_Object
(Actual
)
11185 ("volatile object cannot act as actual in generic instantiation",
11190 end Instantiate_Object
;
11192 ------------------------------
11193 -- Instantiate_Package_Body --
11194 ------------------------------
11196 -- WARNING: This routine manages Ghost and SPARK regions. Return statements
11197 -- must be replaced by gotos which jump to the end of the routine in order
11198 -- to restore the Ghost and SPARK modes.
11200 procedure Instantiate_Package_Body
11201 (Body_Info
: Pending_Body_Info
;
11202 Inlined_Body
: Boolean := False;
11203 Body_Optional
: Boolean := False)
11205 Act_Decl
: constant Node_Id
:= Body_Info
.Act_Decl
;
11206 Act_Decl_Id
: constant Entity_Id
:= Defining_Entity
(Act_Decl
);
11207 Act_Spec
: constant Node_Id
:= Specification
(Act_Decl
);
11208 Inst_Node
: constant Node_Id
:= Body_Info
.Inst_Node
;
11209 Gen_Id
: constant Node_Id
:= Name
(Inst_Node
);
11210 Gen_Unit
: constant Entity_Id
:= Get_Generic_Entity
(Inst_Node
);
11211 Gen_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Gen_Unit
);
11212 Loc
: constant Source_Ptr
:= Sloc
(Inst_Node
);
11214 Saved_ISMP
: constant Boolean :=
11215 Ignore_SPARK_Mode_Pragmas_In_Instance
;
11216 Saved_Style_Check
: constant Boolean := Style_Check
;
11218 procedure Check_Initialized_Types
;
11219 -- In a generic package body, an entity of a generic private type may
11220 -- appear uninitialized. This is suspicious, unless the actual is a
11221 -- fully initialized type.
11223 -----------------------------
11224 -- Check_Initialized_Types --
11225 -----------------------------
11227 procedure Check_Initialized_Types
is
11229 Formal
: Entity_Id
;
11230 Actual
: Entity_Id
;
11231 Uninit_Var
: Entity_Id
;
11234 Decl
:= First
(Generic_Formal_Declarations
(Gen_Decl
));
11235 while Present
(Decl
) loop
11236 Uninit_Var
:= Empty
;
11238 if Nkind
(Decl
) = N_Private_Extension_Declaration
then
11239 Uninit_Var
:= Uninitialized_Variable
(Decl
);
11241 elsif Nkind
(Decl
) = N_Formal_Type_Declaration
11242 and then Nkind
(Formal_Type_Definition
(Decl
)) =
11243 N_Formal_Private_Type_Definition
11246 Uninitialized_Variable
(Formal_Type_Definition
(Decl
));
11249 if Present
(Uninit_Var
) then
11250 Formal
:= Defining_Identifier
(Decl
);
11251 Actual
:= First_Entity
(Act_Decl_Id
);
11253 -- For each formal there is a subtype declaration that renames
11254 -- the actual and has the same name as the formal. Locate the
11255 -- formal for warning message about uninitialized variables
11256 -- in the generic, for which the actual type should be a fully
11257 -- initialized type.
11259 while Present
(Actual
) loop
11260 exit when Ekind
(Actual
) = E_Package
11261 and then Present
(Renamed_Object
(Actual
));
11263 if Chars
(Actual
) = Chars
(Formal
)
11264 and then not Is_Scalar_Type
(Actual
)
11265 and then not Is_Fully_Initialized_Type
(Actual
)
11266 and then Warn_On_No_Value_Assigned
11268 Error_Msg_Node_2
:= Formal
;
11270 ("generic unit has uninitialized variable& of "
11271 & "formal private type &?v?", Actual
, Uninit_Var
);
11273 ("actual type for& should be fully initialized type?v?",
11278 Next_Entity
(Actual
);
11284 end Check_Initialized_Types
;
11288 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
11289 Saved_SM
: constant SPARK_Mode_Type
:= SPARK_Mode
;
11290 Saved_SMP
: constant Node_Id
:= SPARK_Mode_Pragma
;
11291 -- Save the Ghost and SPARK mode-related data to restore on exit
11293 Act_Body
: Node_Id
;
11294 Act_Body_Id
: Entity_Id
;
11295 Act_Body_Name
: Node_Id
;
11296 Gen_Body
: Node_Id
;
11297 Gen_Body_Id
: Node_Id
;
11298 Par_Ent
: Entity_Id
:= Empty
;
11299 Par_Vis
: Boolean := False;
11300 Parent_Installed
: Boolean := False;
11302 Vis_Prims_List
: Elist_Id
:= No_Elist
;
11303 -- List of primitives made temporarily visible in the instantiation
11304 -- to match the visibility of the formal type.
11306 -- Start of processing for Instantiate_Package_Body
11309 Gen_Body_Id
:= Corresponding_Body
(Gen_Decl
);
11311 -- The instance body may already have been processed, as the parent of
11312 -- another instance that is inlined (Load_Parent_Of_Generic).
11314 if Present
(Corresponding_Body
(Instance_Spec
(Inst_Node
))) then
11318 -- The package being instantiated may be subject to pragma Ghost. Set
11319 -- the mode now to ensure that any nodes generated during instantiation
11320 -- are properly marked as Ghost.
11322 Set_Ghost_Mode
(Act_Decl_Id
);
11324 Expander_Mode_Save_And_Set
(Body_Info
.Expander_Status
);
11326 -- Re-establish the state of information on which checks are suppressed.
11327 -- This information was set in Body_Info at the point of instantiation,
11328 -- and now we restore it so that the instance is compiled using the
11329 -- check status at the instantiation (RM 11.5(7.2/2), AI95-00224-01).
11331 Local_Suppress_Stack_Top
:= Body_Info
.Local_Suppress_Stack_Top
;
11332 Scope_Suppress
:= Body_Info
.Scope_Suppress
;
11333 Opt
.Ada_Version
:= Body_Info
.Version
;
11334 Opt
.Ada_Version_Pragma
:= Body_Info
.Version_Pragma
;
11335 Restore_Warnings
(Body_Info
.Warnings
);
11337 -- Install the SPARK mode which applies to the package body
11339 Install_SPARK_Mode
(Body_Info
.SPARK_Mode
, Body_Info
.SPARK_Mode_Pragma
);
11341 if No
(Gen_Body_Id
) then
11343 -- Do not look for parent of generic body if none is required.
11344 -- This may happen when the routine is called as part of the
11345 -- Pending_Instantiations processing, when nested instances
11346 -- may precede the one generated from the main unit.
11348 if not Unit_Requires_Body
(Defining_Entity
(Gen_Decl
))
11349 and then Body_Optional
11353 Load_Parent_Of_Generic
11354 (Inst_Node
, Specification
(Gen_Decl
), Body_Optional
);
11355 Gen_Body_Id
:= Corresponding_Body
(Gen_Decl
);
11359 -- Establish global variable for sloc adjustment and for error recovery
11360 -- In the case of an instance body for an instantiation with actuals
11361 -- from a limited view, the instance body is placed at the beginning
11362 -- of the enclosing package body: use the body entity as the source
11363 -- location for nodes of the instance body.
11365 if not Is_Empty_Elmt_List
(Incomplete_Actuals
(Act_Decl_Id
)) then
11367 Scop
: constant Entity_Id
:= Scope
(Act_Decl_Id
);
11368 Body_Id
: constant Node_Id
:=
11369 Corresponding_Body
(Unit_Declaration_Node
(Scop
));
11372 Instantiation_Node
:= Body_Id
;
11375 Instantiation_Node
:= Inst_Node
;
11378 if Present
(Gen_Body_Id
) then
11379 Save_Env
(Gen_Unit
, Act_Decl_Id
);
11380 Style_Check
:= False;
11382 -- If the context of the instance is subject to SPARK_Mode "off", the
11383 -- annotation is missing, or the body is instantiated at a later pass
11384 -- and its spec ignored SPARK_Mode pragma, set the global flag which
11385 -- signals Analyze_Pragma to ignore all SPARK_Mode pragmas within the
11388 if SPARK_Mode
/= On
11389 or else Ignore_SPARK_Mode_Pragmas
(Act_Decl_Id
)
11391 Ignore_SPARK_Mode_Pragmas_In_Instance
:= True;
11394 Current_Sem_Unit
:= Body_Info
.Current_Sem_Unit
;
11395 Gen_Body
:= Unit_Declaration_Node
(Gen_Body_Id
);
11397 Create_Instantiation_Source
11398 (Inst_Node
, Gen_Body_Id
, S_Adjustment
);
11402 (Original_Node
(Gen_Body
), Empty
, Instantiating
=> True);
11404 -- Create proper (possibly qualified) defining name for the body, to
11405 -- correspond to the one in the spec.
11408 Make_Defining_Identifier
(Sloc
(Act_Decl_Id
), Chars
(Act_Decl_Id
));
11409 Set_Comes_From_Source
(Act_Body_Id
, Comes_From_Source
(Act_Decl_Id
));
11411 -- Some attributes of spec entity are not inherited by body entity
11413 Set_Handler_Records
(Act_Body_Id
, No_List
);
11415 if Nkind
(Defining_Unit_Name
(Act_Spec
)) =
11416 N_Defining_Program_Unit_Name
11419 Make_Defining_Program_Unit_Name
(Loc
,
11421 New_Copy_Tree
(Name
(Defining_Unit_Name
(Act_Spec
))),
11422 Defining_Identifier
=> Act_Body_Id
);
11424 Act_Body_Name
:= Act_Body_Id
;
11427 Set_Defining_Unit_Name
(Act_Body
, Act_Body_Name
);
11429 Set_Corresponding_Spec
(Act_Body
, Act_Decl_Id
);
11430 Check_Generic_Actuals
(Act_Decl_Id
, False);
11431 Check_Initialized_Types
;
11433 -- Install primitives hidden at the point of the instantiation but
11434 -- visible when processing the generic formals
11440 E
:= First_Entity
(Act_Decl_Id
);
11441 while Present
(E
) loop
11443 and then not Is_Itype
(E
)
11444 and then Is_Generic_Actual_Type
(E
)
11445 and then Is_Tagged_Type
(E
)
11447 Install_Hidden_Primitives
11448 (Prims_List
=> Vis_Prims_List
,
11449 Gen_T
=> Generic_Parent_Type
(Parent
(E
)),
11457 -- If it is a child unit, make the parent instance (which is an
11458 -- instance of the parent of the generic) visible. The parent
11459 -- instance is the prefix of the name of the generic unit.
11461 if Ekind
(Scope
(Gen_Unit
)) = E_Generic_Package
11462 and then Nkind
(Gen_Id
) = N_Expanded_Name
11464 Par_Ent
:= Entity
(Prefix
(Gen_Id
));
11465 Par_Vis
:= Is_Immediately_Visible
(Par_Ent
);
11466 Install_Parent
(Par_Ent
, In_Body
=> True);
11467 Parent_Installed
:= True;
11469 elsif Is_Child_Unit
(Gen_Unit
) then
11470 Par_Ent
:= Scope
(Gen_Unit
);
11471 Par_Vis
:= Is_Immediately_Visible
(Par_Ent
);
11472 Install_Parent
(Par_Ent
, In_Body
=> True);
11473 Parent_Installed
:= True;
11476 -- If the instantiation is a library unit, and this is the main unit,
11477 -- then build the resulting compilation unit nodes for the instance.
11478 -- If this is a compilation unit but it is not the main unit, then it
11479 -- is the body of a unit in the context, that is being compiled
11480 -- because it is encloses some inlined unit or another generic unit
11481 -- being instantiated. In that case, this body is not part of the
11482 -- current compilation, and is not attached to the tree, but its
11483 -- parent must be set for analysis.
11485 if Nkind
(Parent
(Inst_Node
)) = N_Compilation_Unit
then
11487 -- Replace instance node with body of instance, and create new
11488 -- node for corresponding instance declaration.
11490 Build_Instance_Compilation_Unit_Nodes
11491 (Inst_Node
, Act_Body
, Act_Decl
);
11492 Analyze
(Inst_Node
);
11494 if Parent
(Inst_Node
) = Cunit
(Main_Unit
) then
11496 -- If the instance is a child unit itself, then set the scope
11497 -- of the expanded body to be the parent of the instantiation
11498 -- (ensuring that the fully qualified name will be generated
11499 -- for the elaboration subprogram).
11501 if Nkind
(Defining_Unit_Name
(Act_Spec
)) =
11502 N_Defining_Program_Unit_Name
11504 Set_Scope
(Defining_Entity
(Inst_Node
), Scope
(Act_Decl_Id
));
11508 -- Case where instantiation is not a library unit
11511 -- If this is an early instantiation, i.e. appears textually
11512 -- before the corresponding body and must be elaborated first,
11513 -- indicate that the body instance is to be delayed.
11515 Install_Body
(Act_Body
, Inst_Node
, Gen_Body
, Gen_Decl
);
11517 -- Now analyze the body. We turn off all checks if this is an
11518 -- internal unit, since there is no reason to have checks on for
11519 -- any predefined run-time library code. All such code is designed
11520 -- to be compiled with checks off.
11522 -- Note that we do NOT apply this criterion to children of GNAT
11523 -- The latter units must suppress checks explicitly if needed.
11525 -- We also do not suppress checks in CodePeer mode where we are
11526 -- interested in finding possible runtime errors.
11528 if not CodePeer_Mode
11529 and then In_Predefined_Unit
(Gen_Decl
)
11531 Analyze
(Act_Body
, Suppress
=> All_Checks
);
11533 Analyze
(Act_Body
);
11537 Inherit_Context
(Gen_Body
, Inst_Node
);
11539 -- Remove the parent instances if they have been placed on the scope
11540 -- stack to compile the body.
11542 if Parent_Installed
then
11543 Remove_Parent
(In_Body
=> True);
11545 -- Restore the previous visibility of the parent
11547 Set_Is_Immediately_Visible
(Par_Ent
, Par_Vis
);
11550 Restore_Hidden_Primitives
(Vis_Prims_List
);
11551 Restore_Private_Views
(Act_Decl_Id
);
11553 -- Remove the current unit from visibility if this is an instance
11554 -- that is not elaborated on the fly for inlining purposes.
11556 if not Inlined_Body
then
11557 Set_Is_Immediately_Visible
(Act_Decl_Id
, False);
11562 -- If we have no body, and the unit requires a body, then complain. This
11563 -- complaint is suppressed if we have detected other errors (since a
11564 -- common reason for missing the body is that it had errors).
11565 -- In CodePeer mode, a warning has been emitted already, no need for
11566 -- further messages.
11568 elsif Unit_Requires_Body
(Gen_Unit
)
11569 and then not Body_Optional
11571 if CodePeer_Mode
then
11574 elsif Serious_Errors_Detected
= 0 then
11576 ("cannot find body of generic package &", Inst_Node
, Gen_Unit
);
11578 -- Don't attempt to perform any cleanup actions if some other error
11579 -- was already detected, since this can cause blowups.
11585 -- Case of package that does not need a body
11588 -- If the instantiation of the declaration is a library unit, rewrite
11589 -- the original package instantiation as a package declaration in the
11590 -- compilation unit node.
11592 if Nkind
(Parent
(Inst_Node
)) = N_Compilation_Unit
then
11593 Set_Parent_Spec
(Act_Decl
, Parent_Spec
(Inst_Node
));
11594 Rewrite
(Inst_Node
, Act_Decl
);
11596 -- Generate elaboration entity, in case spec has elaboration code.
11597 -- This cannot be done when the instance is analyzed, because it
11598 -- is not known yet whether the body exists.
11600 Set_Elaboration_Entity_Required
(Act_Decl_Id
, False);
11601 Build_Elaboration_Entity
(Parent
(Inst_Node
), Act_Decl_Id
);
11603 -- If the instantiation is not a library unit, then append the
11604 -- declaration to the list of implicitly generated entities, unless
11605 -- it is already a list member which means that it was already
11608 elsif not Is_List_Member
(Act_Decl
) then
11609 Mark_Rewrite_Insertion
(Act_Decl
);
11610 Insert_Before
(Inst_Node
, Act_Decl
);
11614 Expander_Mode_Restore
;
11617 Ignore_SPARK_Mode_Pragmas_In_Instance
:= Saved_ISMP
;
11618 Restore_Ghost_Mode
(Saved_GM
);
11619 Restore_SPARK_Mode
(Saved_SM
, Saved_SMP
);
11620 Style_Check
:= Saved_Style_Check
;
11621 end Instantiate_Package_Body
;
11623 ---------------------------------
11624 -- Instantiate_Subprogram_Body --
11625 ---------------------------------
11627 -- WARNING: This routine manages Ghost and SPARK regions. Return statements
11628 -- must be replaced by gotos which jump to the end of the routine in order
11629 -- to restore the Ghost and SPARK modes.
11631 procedure Instantiate_Subprogram_Body
11632 (Body_Info
: Pending_Body_Info
;
11633 Body_Optional
: Boolean := False)
11635 Act_Decl
: constant Node_Id
:= Body_Info
.Act_Decl
;
11636 Act_Decl_Id
: constant Entity_Id
:= Defining_Entity
(Act_Decl
);
11637 Inst_Node
: constant Node_Id
:= Body_Info
.Inst_Node
;
11638 Gen_Id
: constant Node_Id
:= Name
(Inst_Node
);
11639 Gen_Unit
: constant Entity_Id
:= Get_Generic_Entity
(Inst_Node
);
11640 Gen_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Gen_Unit
);
11641 Loc
: constant Source_Ptr
:= Sloc
(Inst_Node
);
11642 Pack_Id
: constant Entity_Id
:=
11643 Defining_Unit_Name
(Parent
(Act_Decl
));
11645 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
11646 Saved_ISMP
: constant Boolean :=
11647 Ignore_SPARK_Mode_Pragmas_In_Instance
;
11648 Saved_SM
: constant SPARK_Mode_Type
:= SPARK_Mode
;
11649 Saved_SMP
: constant Node_Id
:= SPARK_Mode_Pragma
;
11650 -- Save the Ghost and SPARK mode-related data to restore on exit
11652 Saved_Style_Check
: constant Boolean := Style_Check
;
11653 Saved_Warnings
: constant Warning_Record
:= Save_Warnings
;
11655 Act_Body
: Node_Id
;
11656 Act_Body_Id
: Entity_Id
;
11657 Gen_Body
: Node_Id
;
11658 Gen_Body_Id
: Node_Id
;
11659 Pack_Body
: Node_Id
;
11660 Par_Ent
: Entity_Id
:= Empty
;
11661 Par_Vis
: Boolean := False;
11662 Ret_Expr
: Node_Id
;
11664 Parent_Installed
: Boolean := False;
11667 Gen_Body_Id
:= Corresponding_Body
(Gen_Decl
);
11669 -- Subprogram body may have been created already because of an inline
11670 -- pragma, or because of multiple elaborations of the enclosing package
11671 -- when several instances of the subprogram appear in the main unit.
11673 if Present
(Corresponding_Body
(Act_Decl
)) then
11677 -- The subprogram being instantiated may be subject to pragma Ghost. Set
11678 -- the mode now to ensure that any nodes generated during instantiation
11679 -- are properly marked as Ghost.
11681 Set_Ghost_Mode
(Act_Decl_Id
);
11683 Expander_Mode_Save_And_Set
(Body_Info
.Expander_Status
);
11685 -- Re-establish the state of information on which checks are suppressed.
11686 -- This information was set in Body_Info at the point of instantiation,
11687 -- and now we restore it so that the instance is compiled using the
11688 -- check status at the instantiation (RM 11.5(7.2/2), AI95-00224-01).
11690 Local_Suppress_Stack_Top
:= Body_Info
.Local_Suppress_Stack_Top
;
11691 Scope_Suppress
:= Body_Info
.Scope_Suppress
;
11692 Opt
.Ada_Version
:= Body_Info
.Version
;
11693 Opt
.Ada_Version_Pragma
:= Body_Info
.Version_Pragma
;
11694 Restore_Warnings
(Body_Info
.Warnings
);
11696 -- Install the SPARK mode which applies to the subprogram body from the
11697 -- instantiation context. This may be refined further if an explicit
11698 -- SPARK_Mode pragma applies to the generic body.
11700 Install_SPARK_Mode
(Body_Info
.SPARK_Mode
, Body_Info
.SPARK_Mode_Pragma
);
11702 if No
(Gen_Body_Id
) then
11704 -- For imported generic subprogram, no body to compile, complete
11705 -- the spec entity appropriately.
11707 if Is_Imported
(Gen_Unit
) then
11708 Set_Is_Imported
(Act_Decl_Id
);
11709 Set_First_Rep_Item
(Act_Decl_Id
, First_Rep_Item
(Gen_Unit
));
11710 Set_Interface_Name
(Act_Decl_Id
, Interface_Name
(Gen_Unit
));
11711 Set_Convention
(Act_Decl_Id
, Convention
(Gen_Unit
));
11712 Set_Has_Completion
(Act_Decl_Id
);
11715 -- For other cases, compile the body
11718 Load_Parent_Of_Generic
11719 (Inst_Node
, Specification
(Gen_Decl
), Body_Optional
);
11720 Gen_Body_Id
:= Corresponding_Body
(Gen_Decl
);
11724 Instantiation_Node
:= Inst_Node
;
11726 if Present
(Gen_Body_Id
) then
11727 Gen_Body
:= Unit_Declaration_Node
(Gen_Body_Id
);
11729 if Nkind
(Gen_Body
) = N_Subprogram_Body_Stub
then
11731 -- Either body is not present, or context is non-expanding, as
11732 -- when compiling a subunit. Mark the instance as completed, and
11733 -- diagnose a missing body when needed.
11736 and then Operating_Mode
= Generate_Code
11738 Error_Msg_N
("missing proper body for instantiation", Gen_Body
);
11741 Set_Has_Completion
(Act_Decl_Id
);
11745 Save_Env
(Gen_Unit
, Act_Decl_Id
);
11746 Style_Check
:= False;
11748 -- If the context of the instance is subject to SPARK_Mode "off", the
11749 -- annotation is missing, or the body is instantiated at a later pass
11750 -- and its spec ignored SPARK_Mode pragma, set the global flag which
11751 -- signals Analyze_Pragma to ignore all SPARK_Mode pragmas within the
11754 if SPARK_Mode
/= On
11755 or else Ignore_SPARK_Mode_Pragmas
(Act_Decl_Id
)
11757 Ignore_SPARK_Mode_Pragmas_In_Instance
:= True;
11760 -- If the context of an instance is not subject to SPARK_Mode "off",
11761 -- and the generic body is subject to an explicit SPARK_Mode pragma,
11762 -- the latter should be the one applicable to the instance.
11764 if not Ignore_SPARK_Mode_Pragmas_In_Instance
11765 and then SPARK_Mode
/= Off
11766 and then Present
(SPARK_Pragma
(Gen_Body_Id
))
11768 Set_SPARK_Mode
(Gen_Body_Id
);
11771 Current_Sem_Unit
:= Body_Info
.Current_Sem_Unit
;
11772 Create_Instantiation_Source
11779 (Original_Node
(Gen_Body
), Empty
, Instantiating
=> True);
11781 -- Create proper defining name for the body, to correspond to the one
11785 Make_Defining_Identifier
(Sloc
(Act_Decl_Id
), Chars
(Act_Decl_Id
));
11787 Set_Comes_From_Source
(Act_Body_Id
, Comes_From_Source
(Act_Decl_Id
));
11788 Set_Defining_Unit_Name
(Specification
(Act_Body
), Act_Body_Id
);
11790 Set_Corresponding_Spec
(Act_Body
, Act_Decl_Id
);
11791 Set_Has_Completion
(Act_Decl_Id
);
11792 Check_Generic_Actuals
(Pack_Id
, False);
11794 -- Generate a reference to link the visible subprogram instance to
11795 -- the generic body, which for navigation purposes is the only
11796 -- available source for the instance.
11799 (Related_Instance
(Pack_Id
),
11800 Gen_Body_Id
, 'b', Set_Ref
=> False, Force
=> True);
11802 -- If it is a child unit, make the parent instance (which is an
11803 -- instance of the parent of the generic) visible. The parent
11804 -- instance is the prefix of the name of the generic unit.
11806 if Ekind
(Scope
(Gen_Unit
)) = E_Generic_Package
11807 and then Nkind
(Gen_Id
) = N_Expanded_Name
11809 Par_Ent
:= Entity
(Prefix
(Gen_Id
));
11810 Par_Vis
:= Is_Immediately_Visible
(Par_Ent
);
11811 Install_Parent
(Par_Ent
, In_Body
=> True);
11812 Parent_Installed
:= True;
11814 elsif Is_Child_Unit
(Gen_Unit
) then
11815 Par_Ent
:= Scope
(Gen_Unit
);
11816 Par_Vis
:= Is_Immediately_Visible
(Par_Ent
);
11817 Install_Parent
(Par_Ent
, In_Body
=> True);
11818 Parent_Installed
:= True;
11821 -- Subprogram body is placed in the body of wrapper package,
11822 -- whose spec contains the subprogram declaration as well as
11823 -- the renaming declarations for the generic parameters.
11826 Make_Package_Body
(Loc
,
11827 Defining_Unit_Name
=> New_Copy
(Pack_Id
),
11828 Declarations
=> New_List
(Act_Body
));
11830 Set_Corresponding_Spec
(Pack_Body
, Pack_Id
);
11832 -- If the instantiation is a library unit, then build resulting
11833 -- compilation unit nodes for the instance. The declaration of
11834 -- the enclosing package is the grandparent of the subprogram
11835 -- declaration. First replace the instantiation node as the unit
11836 -- of the corresponding compilation.
11838 if Nkind
(Parent
(Inst_Node
)) = N_Compilation_Unit
then
11839 if Parent
(Inst_Node
) = Cunit
(Main_Unit
) then
11840 Set_Unit
(Parent
(Inst_Node
), Inst_Node
);
11841 Build_Instance_Compilation_Unit_Nodes
11842 (Inst_Node
, Pack_Body
, Parent
(Parent
(Act_Decl
)));
11843 Analyze
(Inst_Node
);
11845 Set_Parent
(Pack_Body
, Parent
(Inst_Node
));
11846 Analyze
(Pack_Body
);
11850 Insert_Before
(Inst_Node
, Pack_Body
);
11851 Mark_Rewrite_Insertion
(Pack_Body
);
11852 Analyze
(Pack_Body
);
11854 if Expander_Active
then
11855 Freeze_Subprogram_Body
(Inst_Node
, Gen_Body
, Pack_Id
);
11859 Inherit_Context
(Gen_Body
, Inst_Node
);
11861 Restore_Private_Views
(Pack_Id
, False);
11863 if Parent_Installed
then
11864 Remove_Parent
(In_Body
=> True);
11866 -- Restore the previous visibility of the parent
11868 Set_Is_Immediately_Visible
(Par_Ent
, Par_Vis
);
11872 Restore_Warnings
(Saved_Warnings
);
11874 -- Body not found. Error was emitted already. If there were no previous
11875 -- errors, this may be an instance whose scope is a premature instance.
11876 -- In that case we must insure that the (legal) program does raise
11877 -- program error if executed. We generate a subprogram body for this
11878 -- purpose. See DEC ac30vso.
11880 -- Should not reference proprietary DEC tests in comments ???
11882 elsif Serious_Errors_Detected
= 0
11883 and then Nkind
(Parent
(Inst_Node
)) /= N_Compilation_Unit
11885 if Body_Optional
then
11888 elsif Ekind
(Act_Decl_Id
) = E_Procedure
then
11890 Make_Subprogram_Body
(Loc
,
11892 Make_Procedure_Specification
(Loc
,
11893 Defining_Unit_Name
=>
11894 Make_Defining_Identifier
(Loc
, Chars
(Act_Decl_Id
)),
11895 Parameter_Specifications
=>
11897 (Parameter_Specifications
(Parent
(Act_Decl_Id
)))),
11899 Declarations
=> Empty_List
,
11900 Handled_Statement_Sequence
=>
11901 Make_Handled_Sequence_Of_Statements
(Loc
,
11902 Statements
=> New_List
(
11903 Make_Raise_Program_Error
(Loc
,
11904 Reason
=> PE_Access_Before_Elaboration
))));
11908 Make_Raise_Program_Error
(Loc
,
11909 Reason
=> PE_Access_Before_Elaboration
);
11911 Set_Etype
(Ret_Expr
, (Etype
(Act_Decl_Id
)));
11912 Set_Analyzed
(Ret_Expr
);
11915 Make_Subprogram_Body
(Loc
,
11917 Make_Function_Specification
(Loc
,
11918 Defining_Unit_Name
=>
11919 Make_Defining_Identifier
(Loc
, Chars
(Act_Decl_Id
)),
11920 Parameter_Specifications
=>
11922 (Parameter_Specifications
(Parent
(Act_Decl_Id
))),
11923 Result_Definition
=>
11924 New_Occurrence_Of
(Etype
(Act_Decl_Id
), Loc
)),
11926 Declarations
=> Empty_List
,
11927 Handled_Statement_Sequence
=>
11928 Make_Handled_Sequence_Of_Statements
(Loc
,
11929 Statements
=> New_List
(
11930 Make_Simple_Return_Statement
(Loc
, Ret_Expr
))));
11934 Make_Package_Body
(Loc
,
11935 Defining_Unit_Name
=> New_Copy
(Pack_Id
),
11936 Declarations
=> New_List
(Act_Body
));
11938 Insert_After
(Inst_Node
, Pack_Body
);
11939 Set_Corresponding_Spec
(Pack_Body
, Pack_Id
);
11940 Analyze
(Pack_Body
);
11943 Expander_Mode_Restore
;
11946 Ignore_SPARK_Mode_Pragmas_In_Instance
:= Saved_ISMP
;
11947 Restore_Ghost_Mode
(Saved_GM
);
11948 Restore_SPARK_Mode
(Saved_SM
, Saved_SMP
);
11949 Style_Check
:= Saved_Style_Check
;
11950 end Instantiate_Subprogram_Body
;
11952 ----------------------
11953 -- Instantiate_Type --
11954 ----------------------
11956 function Instantiate_Type
11959 Analyzed_Formal
: Node_Id
;
11960 Actual_Decls
: List_Id
) return List_Id
11962 A_Gen_T
: constant Entity_Id
:=
11963 Defining_Identifier
(Analyzed_Formal
);
11964 Def
: constant Node_Id
:= Formal_Type_Definition
(Formal
);
11965 Gen_T
: constant Entity_Id
:= Defining_Identifier
(Formal
);
11967 Ancestor
: Entity_Id
:= Empty
;
11968 Decl_Node
: Node_Id
;
11969 Decl_Nodes
: List_Id
;
11973 procedure Diagnose_Predicated_Actual
;
11974 -- There are a number of constructs in which a discrete type with
11975 -- predicates is illegal, e.g. as an index in an array type declaration.
11976 -- If a generic type is used is such a construct in a generic package
11977 -- declaration, it carries the flag No_Predicate_On_Actual. it is part
11978 -- of the generic contract that the actual cannot have predicates.
11980 procedure Validate_Array_Type_Instance
;
11981 procedure Validate_Access_Subprogram_Instance
;
11982 procedure Validate_Access_Type_Instance
;
11983 procedure Validate_Derived_Type_Instance
;
11984 procedure Validate_Derived_Interface_Type_Instance
;
11985 procedure Validate_Discriminated_Formal_Type
;
11986 procedure Validate_Interface_Type_Instance
;
11987 procedure Validate_Private_Type_Instance
;
11988 procedure Validate_Incomplete_Type_Instance
;
11989 -- These procedures perform validation tests for the named case.
11990 -- Validate_Discriminated_Formal_Type is shared by formal private
11991 -- types and Ada 2012 formal incomplete types.
11993 function Subtypes_Match
(Gen_T
, Act_T
: Entity_Id
) return Boolean;
11994 -- Check that base types are the same and that the subtypes match
11995 -- statically. Used in several of the above.
11997 ---------------------------------
11998 -- Diagnose_Predicated_Actual --
11999 ---------------------------------
12001 procedure Diagnose_Predicated_Actual
is
12003 if No_Predicate_On_Actual
(A_Gen_T
)
12004 and then Has_Predicates
(Act_T
)
12007 ("actual for& cannot be a type with predicate",
12008 Instantiation_Node
, A_Gen_T
);
12010 elsif No_Dynamic_Predicate_On_Actual
(A_Gen_T
)
12011 and then Has_Predicates
(Act_T
)
12012 and then not Has_Static_Predicate_Aspect
(Act_T
)
12015 ("actual for& cannot be a type with a dynamic predicate",
12016 Instantiation_Node
, A_Gen_T
);
12018 end Diagnose_Predicated_Actual
;
12020 --------------------
12021 -- Subtypes_Match --
12022 --------------------
12024 function Subtypes_Match
(Gen_T
, Act_T
: Entity_Id
) return Boolean is
12025 T
: constant Entity_Id
:= Get_Instance_Of
(Gen_T
);
12028 -- Some detailed comments would be useful here ???
12030 return ((Base_Type
(T
) = Act_T
12031 or else Base_Type
(T
) = Base_Type
(Act_T
))
12032 and then Subtypes_Statically_Match
(T
, Act_T
))
12034 or else (Is_Class_Wide_Type
(Gen_T
)
12035 and then Is_Class_Wide_Type
(Act_T
)
12036 and then Subtypes_Match
12037 (Get_Instance_Of
(Root_Type
(Gen_T
)),
12038 Root_Type
(Act_T
)))
12041 (Ekind_In
(Gen_T
, E_Anonymous_Access_Subprogram_Type
,
12042 E_Anonymous_Access_Type
)
12043 and then Ekind
(Act_T
) = Ekind
(Gen_T
)
12044 and then Subtypes_Statically_Match
12045 (Designated_Type
(Gen_T
), Designated_Type
(Act_T
)));
12046 end Subtypes_Match
;
12048 -----------------------------------------
12049 -- Validate_Access_Subprogram_Instance --
12050 -----------------------------------------
12052 procedure Validate_Access_Subprogram_Instance
is
12054 if not Is_Access_Type
(Act_T
)
12055 or else Ekind
(Designated_Type
(Act_T
)) /= E_Subprogram_Type
12058 ("expect access type in instantiation of &", Actual
, Gen_T
);
12059 Abandon_Instantiation
(Actual
);
12062 -- According to AI05-288, actuals for access_to_subprograms must be
12063 -- subtype conformant with the generic formal. Previous to AI05-288
12064 -- only mode conformance was required.
12066 -- This is a binding interpretation that applies to previous versions
12067 -- of the language, no need to maintain previous weaker checks.
12069 Check_Subtype_Conformant
12070 (Designated_Type
(Act_T
),
12071 Designated_Type
(A_Gen_T
),
12075 if Ekind
(Base_Type
(Act_T
)) = E_Access_Protected_Subprogram_Type
then
12076 if Ekind
(A_Gen_T
) = E_Access_Subprogram_Type
then
12078 ("protected access type not allowed for formal &",
12082 elsif Ekind
(A_Gen_T
) = E_Access_Protected_Subprogram_Type
then
12084 ("expect protected access type for formal &",
12088 -- If the formal has a specified convention (which in most cases
12089 -- will be StdCall) verify that the actual has the same convention.
12091 if Has_Convention_Pragma
(A_Gen_T
)
12092 and then Convention
(A_Gen_T
) /= Convention
(Act_T
)
12094 Error_Msg_Name_1
:= Get_Convention_Name
(Convention
(A_Gen_T
));
12096 ("actual for formal & must have convention %", Actual
, Gen_T
);
12098 end Validate_Access_Subprogram_Instance
;
12100 -----------------------------------
12101 -- Validate_Access_Type_Instance --
12102 -----------------------------------
12104 procedure Validate_Access_Type_Instance
is
12105 Desig_Type
: constant Entity_Id
:=
12106 Find_Actual_Type
(Designated_Type
(A_Gen_T
), A_Gen_T
);
12107 Desig_Act
: Entity_Id
;
12110 if not Is_Access_Type
(Act_T
) then
12112 ("expect access type in instantiation of &", Actual
, Gen_T
);
12113 Abandon_Instantiation
(Actual
);
12116 if Is_Access_Constant
(A_Gen_T
) then
12117 if not Is_Access_Constant
(Act_T
) then
12119 ("actual type must be access-to-constant type", Actual
);
12120 Abandon_Instantiation
(Actual
);
12123 if Is_Access_Constant
(Act_T
) then
12125 ("actual type must be access-to-variable type", Actual
);
12126 Abandon_Instantiation
(Actual
);
12128 elsif Ekind
(A_Gen_T
) = E_General_Access_Type
12129 and then Ekind
(Base_Type
(Act_T
)) /= E_General_Access_Type
12131 Error_Msg_N
-- CODEFIX
12132 ("actual must be general access type!", Actual
);
12133 Error_Msg_NE
-- CODEFIX
12134 ("add ALL to }!", Actual
, Act_T
);
12135 Abandon_Instantiation
(Actual
);
12139 -- The designated subtypes, that is to say the subtypes introduced
12140 -- by an access type declaration (and not by a subtype declaration)
12143 Desig_Act
:= Designated_Type
(Base_Type
(Act_T
));
12145 -- The designated type may have been introduced through a limited_
12146 -- with clause, in which case retrieve the non-limited view. This
12147 -- applies to incomplete types as well as to class-wide types.
12149 if From_Limited_With
(Desig_Act
) then
12150 Desig_Act
:= Available_View
(Desig_Act
);
12153 if not Subtypes_Match
(Desig_Type
, Desig_Act
) then
12155 ("designated type of actual does not match that of formal &",
12158 if not Predicates_Match
(Desig_Type
, Desig_Act
) then
12159 Error_Msg_N
("\predicates do not match", Actual
);
12162 Abandon_Instantiation
(Actual
);
12164 elsif Is_Access_Type
(Designated_Type
(Act_T
))
12165 and then Is_Constrained
(Designated_Type
(Designated_Type
(Act_T
)))
12167 Is_Constrained
(Designated_Type
(Desig_Type
))
12170 ("designated type of actual does not match that of formal &",
12173 if not Predicates_Match
(Desig_Type
, Desig_Act
) then
12174 Error_Msg_N
("\predicates do not match", Actual
);
12177 Abandon_Instantiation
(Actual
);
12180 -- Ada 2005: null-exclusion indicators of the two types must agree
12182 if Can_Never_Be_Null
(A_Gen_T
) /= Can_Never_Be_Null
(Act_T
) then
12184 ("non null exclusion of actual and formal & do not match",
12187 end Validate_Access_Type_Instance
;
12189 ----------------------------------
12190 -- Validate_Array_Type_Instance --
12191 ----------------------------------
12193 procedure Validate_Array_Type_Instance
is
12198 function Formal_Dimensions
return Nat
;
12199 -- Count number of dimensions in array type formal
12201 -----------------------
12202 -- Formal_Dimensions --
12203 -----------------------
12205 function Formal_Dimensions
return Nat
is
12210 if Nkind
(Def
) = N_Constrained_Array_Definition
then
12211 Index
:= First
(Discrete_Subtype_Definitions
(Def
));
12213 Index
:= First
(Subtype_Marks
(Def
));
12216 while Present
(Index
) loop
12218 Next_Index
(Index
);
12222 end Formal_Dimensions
;
12224 -- Start of processing for Validate_Array_Type_Instance
12227 if not Is_Array_Type
(Act_T
) then
12229 ("expect array type in instantiation of &", Actual
, Gen_T
);
12230 Abandon_Instantiation
(Actual
);
12232 elsif Nkind
(Def
) = N_Constrained_Array_Definition
then
12233 if not (Is_Constrained
(Act_T
)) then
12235 ("expect constrained array in instantiation of &",
12237 Abandon_Instantiation
(Actual
);
12241 if Is_Constrained
(Act_T
) then
12243 ("expect unconstrained array in instantiation of &",
12245 Abandon_Instantiation
(Actual
);
12249 if Formal_Dimensions
/= Number_Dimensions
(Act_T
) then
12251 ("dimensions of actual do not match formal &", Actual
, Gen_T
);
12252 Abandon_Instantiation
(Actual
);
12255 I1
:= First_Index
(A_Gen_T
);
12256 I2
:= First_Index
(Act_T
);
12257 for J
in 1 .. Formal_Dimensions
loop
12259 -- If the indexes of the actual were given by a subtype_mark,
12260 -- the index was transformed into a range attribute. Retrieve
12261 -- the original type mark for checking.
12263 if Is_Entity_Name
(Original_Node
(I2
)) then
12264 T2
:= Entity
(Original_Node
(I2
));
12269 if not Subtypes_Match
12270 (Find_Actual_Type
(Etype
(I1
), A_Gen_T
), T2
)
12273 ("index types of actual do not match those of formal &",
12275 Abandon_Instantiation
(Actual
);
12282 -- Check matching subtypes. Note that there are complex visibility
12283 -- issues when the generic is a child unit and some aspect of the
12284 -- generic type is declared in a parent unit of the generic. We do
12285 -- the test to handle this special case only after a direct check
12286 -- for static matching has failed. The case where both the component
12287 -- type and the array type are separate formals, and the component
12288 -- type is a private view may also require special checking in
12289 -- Subtypes_Match. Finally, we assume that a child instance where
12290 -- the component type comes from a formal of a parent instance is
12291 -- correct because the generic was correct. A more precise check
12292 -- seems too complex to install???
12295 (Component_Type
(A_Gen_T
), Component_Type
(Act_T
))
12298 (Find_Actual_Type
(Component_Type
(A_Gen_T
), A_Gen_T
),
12299 Component_Type
(Act_T
))
12301 (not Inside_A_Generic
12302 and then Is_Child_Unit
(Scope
(Component_Type
(A_Gen_T
))))
12307 ("component subtype of actual does not match that of formal &",
12309 Abandon_Instantiation
(Actual
);
12312 if Has_Aliased_Components
(A_Gen_T
)
12313 and then not Has_Aliased_Components
(Act_T
)
12316 ("actual must have aliased components to match formal type &",
12319 end Validate_Array_Type_Instance
;
12321 -----------------------------------------------
12322 -- Validate_Derived_Interface_Type_Instance --
12323 -----------------------------------------------
12325 procedure Validate_Derived_Interface_Type_Instance
is
12326 Par
: constant Entity_Id
:= Entity
(Subtype_Indication
(Def
));
12330 -- First apply interface instance checks
12332 Validate_Interface_Type_Instance
;
12334 -- Verify that immediate parent interface is an ancestor of
12338 and then not Interface_Present_In_Ancestor
(Act_T
, Par
)
12341 ("interface actual must include progenitor&", Actual
, Par
);
12344 -- Now verify that the actual includes all other ancestors of
12347 Elmt
:= First_Elmt
(Interfaces
(A_Gen_T
));
12348 while Present
(Elmt
) loop
12349 if not Interface_Present_In_Ancestor
12350 (Act_T
, Get_Instance_Of
(Node
(Elmt
)))
12353 ("interface actual must include progenitor&",
12354 Actual
, Node
(Elmt
));
12359 end Validate_Derived_Interface_Type_Instance
;
12361 ------------------------------------
12362 -- Validate_Derived_Type_Instance --
12363 ------------------------------------
12365 procedure Validate_Derived_Type_Instance
is
12366 Actual_Discr
: Entity_Id
;
12367 Ancestor_Discr
: Entity_Id
;
12370 -- If the parent type in the generic declaration is itself a previous
12371 -- formal type, then it is local to the generic and absent from the
12372 -- analyzed generic definition. In that case the ancestor is the
12373 -- instance of the formal (which must have been instantiated
12374 -- previously), unless the ancestor is itself a formal derived type.
12375 -- In this latter case (which is the subject of Corrigendum 8652/0038
12376 -- (AI-202) the ancestor of the formals is the ancestor of its
12377 -- parent. Otherwise, the analyzed generic carries the parent type.
12378 -- If the parent type is defined in a previous formal package, then
12379 -- the scope of that formal package is that of the generic type
12380 -- itself, and it has already been mapped into the corresponding type
12381 -- in the actual package.
12383 -- Common case: parent type defined outside of the generic
12385 if Is_Entity_Name
(Subtype_Mark
(Def
))
12386 and then Present
(Entity
(Subtype_Mark
(Def
)))
12388 Ancestor
:= Get_Instance_Of
(Entity
(Subtype_Mark
(Def
)));
12390 -- Check whether parent is defined in a previous formal package
12393 Scope
(Scope
(Base_Type
(Etype
(A_Gen_T
)))) = Scope
(A_Gen_T
)
12396 Get_Instance_Of
(Base_Type
(Etype
(A_Gen_T
)));
12398 -- The type may be a local derivation, or a type extension of a
12399 -- previous formal, or of a formal of a parent package.
12401 elsif Is_Derived_Type
(Get_Instance_Of
(A_Gen_T
))
12403 Ekind
(Get_Instance_Of
(A_Gen_T
)) = E_Record_Type_With_Private
12405 -- Check whether the parent is another derived formal type in the
12406 -- same generic unit.
12408 if Etype
(A_Gen_T
) /= A_Gen_T
12409 and then Is_Generic_Type
(Etype
(A_Gen_T
))
12410 and then Scope
(Etype
(A_Gen_T
)) = Scope
(A_Gen_T
)
12411 and then Etype
(Etype
(A_Gen_T
)) /= Etype
(A_Gen_T
)
12413 -- Locate ancestor of parent from the subtype declaration
12414 -- created for the actual.
12420 Decl
:= First
(Actual_Decls
);
12421 while Present
(Decl
) loop
12422 if Nkind
(Decl
) = N_Subtype_Declaration
12423 and then Chars
(Defining_Identifier
(Decl
)) =
12424 Chars
(Etype
(A_Gen_T
))
12426 Ancestor
:= Generic_Parent_Type
(Decl
);
12434 pragma Assert
(Present
(Ancestor
));
12436 -- The ancestor itself may be a previous formal that has been
12439 Ancestor
:= Get_Instance_Of
(Ancestor
);
12443 Get_Instance_Of
(Base_Type
(Get_Instance_Of
(A_Gen_T
)));
12446 -- Check whether parent is a previous formal of the current generic
12448 elsif Is_Derived_Type
(A_Gen_T
)
12449 and then Is_Generic_Type
(Etype
(A_Gen_T
))
12450 and then Scope
(A_Gen_T
) = Scope
(Etype
(A_Gen_T
))
12452 Ancestor
:= Get_Instance_Of
(First_Subtype
(Etype
(A_Gen_T
)));
12454 -- An unusual case: the actual is a type declared in a parent unit,
12455 -- but is not a formal type so there is no instance_of for it.
12456 -- Retrieve it by analyzing the record extension.
12458 elsif Is_Child_Unit
(Scope
(A_Gen_T
))
12459 and then In_Open_Scopes
(Scope
(Act_T
))
12460 and then Is_Generic_Instance
(Scope
(Act_T
))
12462 Analyze
(Subtype_Mark
(Def
));
12463 Ancestor
:= Entity
(Subtype_Mark
(Def
));
12466 Ancestor
:= Get_Instance_Of
(Etype
(Base_Type
(A_Gen_T
)));
12469 -- If the formal derived type has pragma Preelaborable_Initialization
12470 -- then the actual type must have preelaborable initialization.
12472 if Known_To_Have_Preelab_Init
(A_Gen_T
)
12473 and then not Has_Preelaborable_Initialization
(Act_T
)
12476 ("actual for & must have preelaborable initialization",
12480 -- Ada 2005 (AI-251)
12482 if Ada_Version
>= Ada_2005
and then Is_Interface
(Ancestor
) then
12483 if not Interface_Present_In_Ancestor
(Act_T
, Ancestor
) then
12485 ("(Ada 2005) expected type implementing & in instantiation",
12489 -- Finally verify that the (instance of) the ancestor is an ancestor
12492 elsif not Is_Ancestor
(Base_Type
(Ancestor
), Act_T
) then
12494 ("expect type derived from & in instantiation",
12495 Actual
, First_Subtype
(Ancestor
));
12496 Abandon_Instantiation
(Actual
);
12499 -- Ada 2005 (AI-443): Synchronized formal derived type checks. Note
12500 -- that the formal type declaration has been rewritten as a private
12503 if Ada_Version
>= Ada_2005
12504 and then Nkind
(Parent
(A_Gen_T
)) = N_Private_Extension_Declaration
12505 and then Synchronized_Present
(Parent
(A_Gen_T
))
12507 -- The actual must be a synchronized tagged type
12509 if not Is_Tagged_Type
(Act_T
) then
12511 ("actual of synchronized type must be tagged", Actual
);
12512 Abandon_Instantiation
(Actual
);
12514 elsif Nkind
(Parent
(Act_T
)) = N_Full_Type_Declaration
12515 and then Nkind
(Type_Definition
(Parent
(Act_T
))) =
12516 N_Derived_Type_Definition
12517 and then not Synchronized_Present
12518 (Type_Definition
(Parent
(Act_T
)))
12521 ("actual of synchronized type must be synchronized", Actual
);
12522 Abandon_Instantiation
(Actual
);
12526 -- Perform atomic/volatile checks (RM C.6(12)). Note that AI05-0218-1
12527 -- removes the second instance of the phrase "or allow pass by copy".
12529 if Is_Atomic
(Act_T
) and then not Is_Atomic
(Ancestor
) then
12531 ("cannot have atomic actual type for non-atomic formal type",
12534 elsif Is_Volatile
(Act_T
) and then not Is_Volatile
(Ancestor
) then
12536 ("cannot have volatile actual type for non-volatile formal type",
12540 -- It should not be necessary to check for unknown discriminants on
12541 -- Formal, but for some reason Has_Unknown_Discriminants is false for
12542 -- A_Gen_T, so Is_Definite_Subtype incorrectly returns True. This
12543 -- needs fixing. ???
12545 if Is_Definite_Subtype
(A_Gen_T
)
12546 and then not Unknown_Discriminants_Present
(Formal
)
12547 and then not Is_Definite_Subtype
(Act_T
)
12549 Error_Msg_N
("actual subtype must be constrained", Actual
);
12550 Abandon_Instantiation
(Actual
);
12553 if not Unknown_Discriminants_Present
(Formal
) then
12554 if Is_Constrained
(Ancestor
) then
12555 if not Is_Constrained
(Act_T
) then
12556 Error_Msg_N
("actual subtype must be constrained", Actual
);
12557 Abandon_Instantiation
(Actual
);
12560 -- Ancestor is unconstrained, Check if generic formal and actual
12561 -- agree on constrainedness. The check only applies to array types
12562 -- and discriminated types.
12564 elsif Is_Constrained
(Act_T
) then
12565 if Ekind
(Ancestor
) = E_Access_Type
12566 or else (not Is_Constrained
(A_Gen_T
)
12567 and then Is_Composite_Type
(A_Gen_T
))
12569 Error_Msg_N
("actual subtype must be unconstrained", Actual
);
12570 Abandon_Instantiation
(Actual
);
12573 -- A class-wide type is only allowed if the formal has unknown
12576 elsif Is_Class_Wide_Type
(Act_T
)
12577 and then not Has_Unknown_Discriminants
(Ancestor
)
12580 ("actual for & cannot be a class-wide type", Actual
, Gen_T
);
12581 Abandon_Instantiation
(Actual
);
12583 -- Otherwise, the formal and actual must have the same number
12584 -- of discriminants and each discriminant of the actual must
12585 -- correspond to a discriminant of the formal.
12587 elsif Has_Discriminants
(Act_T
)
12588 and then not Has_Unknown_Discriminants
(Act_T
)
12589 and then Has_Discriminants
(Ancestor
)
12591 Actual_Discr
:= First_Discriminant
(Act_T
);
12592 Ancestor_Discr
:= First_Discriminant
(Ancestor
);
12593 while Present
(Actual_Discr
)
12594 and then Present
(Ancestor_Discr
)
12596 if Base_Type
(Act_T
) /= Base_Type
(Ancestor
) and then
12597 No
(Corresponding_Discriminant
(Actual_Discr
))
12600 ("discriminant & does not correspond "
12601 & "to ancestor discriminant", Actual
, Actual_Discr
);
12602 Abandon_Instantiation
(Actual
);
12605 Next_Discriminant
(Actual_Discr
);
12606 Next_Discriminant
(Ancestor_Discr
);
12609 if Present
(Actual_Discr
) or else Present
(Ancestor_Discr
) then
12611 ("actual for & must have same number of discriminants",
12613 Abandon_Instantiation
(Actual
);
12616 -- This case should be caught by the earlier check for
12617 -- constrainedness, but the check here is added for completeness.
12619 elsif Has_Discriminants
(Act_T
)
12620 and then not Has_Unknown_Discriminants
(Act_T
)
12623 ("actual for & must not have discriminants", Actual
, Gen_T
);
12624 Abandon_Instantiation
(Actual
);
12626 elsif Has_Discriminants
(Ancestor
) then
12628 ("actual for & must have known discriminants", Actual
, Gen_T
);
12629 Abandon_Instantiation
(Actual
);
12632 if not Subtypes_Statically_Compatible
12633 (Act_T
, Ancestor
, Formal_Derived_Matching
=> True)
12636 ("constraint on actual is incompatible with formal", Actual
);
12637 Abandon_Instantiation
(Actual
);
12641 -- If the formal and actual types are abstract, check that there
12642 -- are no abstract primitives of the actual type that correspond to
12643 -- nonabstract primitives of the formal type (second sentence of
12646 if Is_Abstract_Type
(A_Gen_T
) and then Is_Abstract_Type
(Act_T
) then
12647 Check_Abstract_Primitives
: declare
12648 Gen_Prims
: constant Elist_Id
:=
12649 Primitive_Operations
(A_Gen_T
);
12650 Gen_Elmt
: Elmt_Id
;
12651 Gen_Subp
: Entity_Id
;
12652 Anc_Subp
: Entity_Id
;
12653 Anc_Formal
: Entity_Id
;
12654 Anc_F_Type
: Entity_Id
;
12656 Act_Prims
: constant Elist_Id
:= Primitive_Operations
(Act_T
);
12657 Act_Elmt
: Elmt_Id
;
12658 Act_Subp
: Entity_Id
;
12659 Act_Formal
: Entity_Id
;
12660 Act_F_Type
: Entity_Id
;
12662 Subprograms_Correspond
: Boolean;
12664 function Is_Tagged_Ancestor
(T1
, T2
: Entity_Id
) return Boolean;
12665 -- Returns true if T2 is derived directly or indirectly from
12666 -- T1, including derivations from interfaces. T1 and T2 are
12667 -- required to be specific tagged base types.
12669 ------------------------
12670 -- Is_Tagged_Ancestor --
12671 ------------------------
12673 function Is_Tagged_Ancestor
(T1
, T2
: Entity_Id
) return Boolean
12675 Intfc_Elmt
: Elmt_Id
;
12678 -- The predicate is satisfied if the types are the same
12683 -- If we've reached the top of the derivation chain then
12684 -- we know that T1 is not an ancestor of T2.
12686 elsif Etype
(T2
) = T2
then
12689 -- Proceed to check T2's immediate parent
12691 elsif Is_Ancestor
(T1
, Base_Type
(Etype
(T2
))) then
12694 -- Finally, check to see if T1 is an ancestor of any of T2's
12698 Intfc_Elmt
:= First_Elmt
(Interfaces
(T2
));
12699 while Present
(Intfc_Elmt
) loop
12700 if Is_Ancestor
(T1
, Node
(Intfc_Elmt
)) then
12704 Next_Elmt
(Intfc_Elmt
);
12709 end Is_Tagged_Ancestor
;
12711 -- Start of processing for Check_Abstract_Primitives
12714 -- Loop over all of the formal derived type's primitives
12716 Gen_Elmt
:= First_Elmt
(Gen_Prims
);
12717 while Present
(Gen_Elmt
) loop
12718 Gen_Subp
:= Node
(Gen_Elmt
);
12720 -- If the primitive of the formal is not abstract, then
12721 -- determine whether there is a corresponding primitive of
12722 -- the actual type that's abstract.
12724 if not Is_Abstract_Subprogram
(Gen_Subp
) then
12725 Act_Elmt
:= First_Elmt
(Act_Prims
);
12726 while Present
(Act_Elmt
) loop
12727 Act_Subp
:= Node
(Act_Elmt
);
12729 -- If we find an abstract primitive of the actual,
12730 -- then we need to test whether it corresponds to the
12731 -- subprogram from which the generic formal primitive
12734 if Is_Abstract_Subprogram
(Act_Subp
) then
12735 Anc_Subp
:= Alias
(Gen_Subp
);
12737 -- Test whether we have a corresponding primitive
12738 -- by comparing names, kinds, formal types, and
12741 if Chars
(Anc_Subp
) = Chars
(Act_Subp
)
12742 and then Ekind
(Anc_Subp
) = Ekind
(Act_Subp
)
12744 Anc_Formal
:= First_Formal
(Anc_Subp
);
12745 Act_Formal
:= First_Formal
(Act_Subp
);
12746 while Present
(Anc_Formal
)
12747 and then Present
(Act_Formal
)
12749 Anc_F_Type
:= Etype
(Anc_Formal
);
12750 Act_F_Type
:= Etype
(Act_Formal
);
12752 if Ekind
(Anc_F_Type
) =
12753 E_Anonymous_Access_Type
12755 Anc_F_Type
:= Designated_Type
(Anc_F_Type
);
12757 if Ekind
(Act_F_Type
) =
12758 E_Anonymous_Access_Type
12761 Designated_Type
(Act_F_Type
);
12767 Ekind
(Act_F_Type
) = E_Anonymous_Access_Type
12772 Anc_F_Type
:= Base_Type
(Anc_F_Type
);
12773 Act_F_Type
:= Base_Type
(Act_F_Type
);
12775 -- If the formal is controlling, then the
12776 -- the type of the actual primitive's formal
12777 -- must be derived directly or indirectly
12778 -- from the type of the ancestor primitive's
12781 if Is_Controlling_Formal
(Anc_Formal
) then
12782 if not Is_Tagged_Ancestor
12783 (Anc_F_Type
, Act_F_Type
)
12788 -- Otherwise the types of the formals must
12791 elsif Anc_F_Type
/= Act_F_Type
then
12795 Next_Entity
(Anc_Formal
);
12796 Next_Entity
(Act_Formal
);
12799 -- If we traversed through all of the formals
12800 -- then so far the subprograms correspond, so
12801 -- now check that any result types correspond.
12803 if No
(Anc_Formal
) and then No
(Act_Formal
) then
12804 Subprograms_Correspond
:= True;
12806 if Ekind
(Act_Subp
) = E_Function
then
12807 Anc_F_Type
:= Etype
(Anc_Subp
);
12808 Act_F_Type
:= Etype
(Act_Subp
);
12810 if Ekind
(Anc_F_Type
) =
12811 E_Anonymous_Access_Type
12814 Designated_Type
(Anc_F_Type
);
12816 if Ekind
(Act_F_Type
) =
12817 E_Anonymous_Access_Type
12820 Designated_Type
(Act_F_Type
);
12822 Subprograms_Correspond
:= False;
12827 = E_Anonymous_Access_Type
12829 Subprograms_Correspond
:= False;
12832 Anc_F_Type
:= Base_Type
(Anc_F_Type
);
12833 Act_F_Type
:= Base_Type
(Act_F_Type
);
12835 -- Now either the result types must be
12836 -- the same or, if the result type is
12837 -- controlling, the result type of the
12838 -- actual primitive must descend from the
12839 -- result type of the ancestor primitive.
12841 if Subprograms_Correspond
12842 and then Anc_F_Type
/= Act_F_Type
12844 Has_Controlling_Result
(Anc_Subp
)
12845 and then not Is_Tagged_Ancestor
12846 (Anc_F_Type
, Act_F_Type
)
12848 Subprograms_Correspond
:= False;
12852 -- Found a matching subprogram belonging to
12853 -- formal ancestor type, so actual subprogram
12854 -- corresponds and this violates 3.9.3(9).
12856 if Subprograms_Correspond
then
12858 ("abstract subprogram & overrides "
12859 & "nonabstract subprogram of ancestor",
12866 Next_Elmt
(Act_Elmt
);
12870 Next_Elmt
(Gen_Elmt
);
12872 end Check_Abstract_Primitives
;
12875 -- Verify that limitedness matches. If parent is a limited
12876 -- interface then the generic formal is not unless declared
12877 -- explicitly so. If not declared limited, the actual cannot be
12878 -- limited (see AI05-0087).
12880 -- Even though this AI is a binding interpretation, we enable the
12881 -- check only in Ada 2012 mode, because this improper construct
12882 -- shows up in user code and in existing B-tests.
12884 if Is_Limited_Type
(Act_T
)
12885 and then not Is_Limited_Type
(A_Gen_T
)
12886 and then Ada_Version
>= Ada_2012
12888 if In_Instance
then
12892 ("actual for non-limited & cannot be a limited type",
12894 Explain_Limited_Type
(Act_T
, Actual
);
12895 Abandon_Instantiation
(Actual
);
12898 end Validate_Derived_Type_Instance
;
12900 ----------------------------------------
12901 -- Validate_Discriminated_Formal_Type --
12902 ----------------------------------------
12904 procedure Validate_Discriminated_Formal_Type
is
12905 Formal_Discr
: Entity_Id
;
12906 Actual_Discr
: Entity_Id
;
12907 Formal_Subt
: Entity_Id
;
12910 if Has_Discriminants
(A_Gen_T
) then
12911 if not Has_Discriminants
(Act_T
) then
12913 ("actual for & must have discriminants", Actual
, Gen_T
);
12914 Abandon_Instantiation
(Actual
);
12916 elsif Is_Constrained
(Act_T
) then
12918 ("actual for & must be unconstrained", Actual
, Gen_T
);
12919 Abandon_Instantiation
(Actual
);
12922 Formal_Discr
:= First_Discriminant
(A_Gen_T
);
12923 Actual_Discr
:= First_Discriminant
(Act_T
);
12924 while Formal_Discr
/= Empty
loop
12925 if Actual_Discr
= Empty
then
12927 ("discriminants on actual do not match formal",
12929 Abandon_Instantiation
(Actual
);
12932 Formal_Subt
:= Get_Instance_Of
(Etype
(Formal_Discr
));
12934 -- Access discriminants match if designated types do
12936 if Ekind
(Base_Type
(Formal_Subt
)) = E_Anonymous_Access_Type
12937 and then (Ekind
(Base_Type
(Etype
(Actual_Discr
)))) =
12938 E_Anonymous_Access_Type
12941 (Designated_Type
(Base_Type
(Formal_Subt
))) =
12942 Designated_Type
(Base_Type
(Etype
(Actual_Discr
)))
12946 elsif Base_Type
(Formal_Subt
) /=
12947 Base_Type
(Etype
(Actual_Discr
))
12950 ("types of actual discriminants must match formal",
12952 Abandon_Instantiation
(Actual
);
12954 elsif not Subtypes_Statically_Match
12955 (Formal_Subt
, Etype
(Actual_Discr
))
12956 and then Ada_Version
>= Ada_95
12959 ("subtypes of actual discriminants must match formal",
12961 Abandon_Instantiation
(Actual
);
12964 Next_Discriminant
(Formal_Discr
);
12965 Next_Discriminant
(Actual_Discr
);
12968 if Actual_Discr
/= Empty
then
12970 ("discriminants on actual do not match formal",
12972 Abandon_Instantiation
(Actual
);
12976 end Validate_Discriminated_Formal_Type
;
12978 ---------------------------------------
12979 -- Validate_Incomplete_Type_Instance --
12980 ---------------------------------------
12982 procedure Validate_Incomplete_Type_Instance
is
12984 if not Is_Tagged_Type
(Act_T
)
12985 and then Is_Tagged_Type
(A_Gen_T
)
12988 ("actual for & must be a tagged type", Actual
, Gen_T
);
12991 Validate_Discriminated_Formal_Type
;
12992 end Validate_Incomplete_Type_Instance
;
12994 --------------------------------------
12995 -- Validate_Interface_Type_Instance --
12996 --------------------------------------
12998 procedure Validate_Interface_Type_Instance
is
13000 if not Is_Interface
(Act_T
) then
13002 ("actual for formal interface type must be an interface",
13005 elsif Is_Limited_Type
(Act_T
) /= Is_Limited_Type
(A_Gen_T
)
13006 or else Is_Task_Interface
(A_Gen_T
) /= Is_Task_Interface
(Act_T
)
13007 or else Is_Protected_Interface
(A_Gen_T
) /=
13008 Is_Protected_Interface
(Act_T
)
13009 or else Is_Synchronized_Interface
(A_Gen_T
) /=
13010 Is_Synchronized_Interface
(Act_T
)
13013 ("actual for interface& does not match (RM 12.5.5(4))",
13016 end Validate_Interface_Type_Instance
;
13018 ------------------------------------
13019 -- Validate_Private_Type_Instance --
13020 ------------------------------------
13022 procedure Validate_Private_Type_Instance
is
13024 if Is_Limited_Type
(Act_T
)
13025 and then not Is_Limited_Type
(A_Gen_T
)
13027 if In_Instance
then
13031 ("actual for non-limited & cannot be a limited type", Actual
,
13033 Explain_Limited_Type
(Act_T
, Actual
);
13034 Abandon_Instantiation
(Actual
);
13037 elsif Known_To_Have_Preelab_Init
(A_Gen_T
)
13038 and then not Has_Preelaborable_Initialization
(Act_T
)
13041 ("actual for & must have preelaborable initialization", Actual
,
13044 elsif not Is_Definite_Subtype
(Act_T
)
13045 and then Is_Definite_Subtype
(A_Gen_T
)
13046 and then Ada_Version
>= Ada_95
13049 ("actual for & must be a definite subtype", Actual
, Gen_T
);
13051 elsif not Is_Tagged_Type
(Act_T
)
13052 and then Is_Tagged_Type
(A_Gen_T
)
13055 ("actual for & must be a tagged type", Actual
, Gen_T
);
13058 Validate_Discriminated_Formal_Type
;
13060 end Validate_Private_Type_Instance
;
13062 -- Start of processing for Instantiate_Type
13065 if Get_Instance_Of
(A_Gen_T
) /= A_Gen_T
then
13066 Error_Msg_N
("duplicate instantiation of generic type", Actual
);
13067 return New_List
(Error
);
13069 elsif not Is_Entity_Name
(Actual
)
13070 or else not Is_Type
(Entity
(Actual
))
13073 ("expect valid subtype mark to instantiate &", Actual
, Gen_T
);
13074 Abandon_Instantiation
(Actual
);
13077 Act_T
:= Entity
(Actual
);
13079 -- Ada 2005 (AI-216): An Unchecked_Union subtype shall only be passed
13080 -- as a generic actual parameter if the corresponding formal type
13081 -- does not have a known_discriminant_part, or is a formal derived
13082 -- type that is an Unchecked_Union type.
13084 if Is_Unchecked_Union
(Base_Type
(Act_T
)) then
13085 if not Has_Discriminants
(A_Gen_T
)
13086 or else (Is_Derived_Type
(A_Gen_T
)
13087 and then Is_Unchecked_Union
(A_Gen_T
))
13091 Error_Msg_N
("unchecked union cannot be the actual for a "
13092 & "discriminated formal type", Act_T
);
13097 -- Deal with fixed/floating restrictions
13099 if Is_Floating_Point_Type
(Act_T
) then
13100 Check_Restriction
(No_Floating_Point
, Actual
);
13101 elsif Is_Fixed_Point_Type
(Act_T
) then
13102 Check_Restriction
(No_Fixed_Point
, Actual
);
13105 -- Deal with error of using incomplete type as generic actual.
13106 -- This includes limited views of a type, even if the non-limited
13107 -- view may be available.
13109 if Ekind
(Act_T
) = E_Incomplete_Type
13110 or else (Is_Class_Wide_Type
(Act_T
)
13111 and then Ekind
(Root_Type
(Act_T
)) = E_Incomplete_Type
)
13113 -- If the formal is an incomplete type, the actual can be
13114 -- incomplete as well.
13116 if Ekind
(A_Gen_T
) = E_Incomplete_Type
then
13119 elsif Is_Class_Wide_Type
(Act_T
)
13120 or else No
(Full_View
(Act_T
))
13122 Error_Msg_N
("premature use of incomplete type", Actual
);
13123 Abandon_Instantiation
(Actual
);
13125 Act_T
:= Full_View
(Act_T
);
13126 Set_Entity
(Actual
, Act_T
);
13128 if Has_Private_Component
(Act_T
) then
13130 ("premature use of type with private component", Actual
);
13134 -- Deal with error of premature use of private type as generic actual
13136 elsif Is_Private_Type
(Act_T
)
13137 and then Is_Private_Type
(Base_Type
(Act_T
))
13138 and then not Is_Generic_Type
(Act_T
)
13139 and then not Is_Derived_Type
(Act_T
)
13140 and then No
(Full_View
(Root_Type
(Act_T
)))
13142 -- If the formal is an incomplete type, the actual can be
13143 -- private or incomplete as well.
13145 if Ekind
(A_Gen_T
) = E_Incomplete_Type
then
13148 Error_Msg_N
("premature use of private type", Actual
);
13151 elsif Has_Private_Component
(Act_T
) then
13153 ("premature use of type with private component", Actual
);
13156 Set_Instance_Of
(A_Gen_T
, Act_T
);
13158 -- If the type is generic, the class-wide type may also be used
13160 if Is_Tagged_Type
(A_Gen_T
)
13161 and then Is_Tagged_Type
(Act_T
)
13162 and then not Is_Class_Wide_Type
(A_Gen_T
)
13164 Set_Instance_Of
(Class_Wide_Type
(A_Gen_T
),
13165 Class_Wide_Type
(Act_T
));
13168 if not Is_Abstract_Type
(A_Gen_T
)
13169 and then Is_Abstract_Type
(Act_T
)
13172 ("actual of non-abstract formal cannot be abstract", Actual
);
13175 -- A generic scalar type is a first subtype for which we generate
13176 -- an anonymous base type. Indicate that the instance of this base
13177 -- is the base type of the actual.
13179 if Is_Scalar_Type
(A_Gen_T
) then
13180 Set_Instance_Of
(Etype
(A_Gen_T
), Etype
(Act_T
));
13184 if Error_Posted
(Act_T
) then
13187 case Nkind
(Def
) is
13188 when N_Formal_Private_Type_Definition
=>
13189 Validate_Private_Type_Instance
;
13191 when N_Formal_Incomplete_Type_Definition
=>
13192 Validate_Incomplete_Type_Instance
;
13194 when N_Formal_Derived_Type_Definition
=>
13195 Validate_Derived_Type_Instance
;
13197 when N_Formal_Discrete_Type_Definition
=>
13198 if not Is_Discrete_Type
(Act_T
) then
13200 ("expect discrete type in instantiation of&",
13202 Abandon_Instantiation
(Actual
);
13205 Diagnose_Predicated_Actual
;
13207 when N_Formal_Signed_Integer_Type_Definition
=>
13208 if not Is_Signed_Integer_Type
(Act_T
) then
13210 ("expect signed integer type in instantiation of&",
13212 Abandon_Instantiation
(Actual
);
13215 Diagnose_Predicated_Actual
;
13217 when N_Formal_Modular_Type_Definition
=>
13218 if not Is_Modular_Integer_Type
(Act_T
) then
13220 ("expect modular type in instantiation of &",
13222 Abandon_Instantiation
(Actual
);
13225 Diagnose_Predicated_Actual
;
13227 when N_Formal_Floating_Point_Definition
=>
13228 if not Is_Floating_Point_Type
(Act_T
) then
13230 ("expect float type in instantiation of &", Actual
, Gen_T
);
13231 Abandon_Instantiation
(Actual
);
13234 when N_Formal_Ordinary_Fixed_Point_Definition
=>
13235 if not Is_Ordinary_Fixed_Point_Type
(Act_T
) then
13237 ("expect ordinary fixed point type in instantiation of &",
13239 Abandon_Instantiation
(Actual
);
13242 when N_Formal_Decimal_Fixed_Point_Definition
=>
13243 if not Is_Decimal_Fixed_Point_Type
(Act_T
) then
13245 ("expect decimal type in instantiation of &",
13247 Abandon_Instantiation
(Actual
);
13250 when N_Array_Type_Definition
=>
13251 Validate_Array_Type_Instance
;
13253 when N_Access_To_Object_Definition
=>
13254 Validate_Access_Type_Instance
;
13256 when N_Access_Function_Definition
13257 | N_Access_Procedure_Definition
13259 Validate_Access_Subprogram_Instance
;
13261 when N_Record_Definition
=>
13262 Validate_Interface_Type_Instance
;
13264 when N_Derived_Type_Definition
=>
13265 Validate_Derived_Interface_Type_Instance
;
13268 raise Program_Error
;
13272 Subt
:= New_Copy
(Gen_T
);
13274 -- Use adjusted sloc of subtype name as the location for other nodes in
13275 -- the subtype declaration.
13277 Loc
:= Sloc
(Subt
);
13280 Make_Subtype_Declaration
(Loc
,
13281 Defining_Identifier
=> Subt
,
13282 Subtype_Indication
=> New_Occurrence_Of
(Act_T
, Loc
));
13284 if Is_Private_Type
(Act_T
) then
13285 Set_Has_Private_View
(Subtype_Indication
(Decl_Node
));
13287 elsif Is_Access_Type
(Act_T
)
13288 and then Is_Private_Type
(Designated_Type
(Act_T
))
13290 Set_Has_Private_View
(Subtype_Indication
(Decl_Node
));
13293 -- In Ada 2012 the actual may be a limited view. Indicate that
13294 -- the local subtype must be treated as such.
13296 if From_Limited_With
(Act_T
) then
13297 Set_Ekind
(Subt
, E_Incomplete_Subtype
);
13298 Set_From_Limited_With
(Subt
);
13301 Decl_Nodes
:= New_List
(Decl_Node
);
13303 -- Flag actual derived types so their elaboration produces the
13304 -- appropriate renamings for the primitive operations of the ancestor.
13305 -- Flag actual for formal private types as well, to determine whether
13306 -- operations in the private part may override inherited operations.
13307 -- If the formal has an interface list, the ancestor is not the
13308 -- parent, but the analyzed formal that includes the interface
13309 -- operations of all its progenitors.
13311 -- Same treatment for formal private types, so we can check whether the
13312 -- type is tagged limited when validating derivations in the private
13313 -- part. (See AI05-096).
13315 if Nkind
(Def
) = N_Formal_Derived_Type_Definition
then
13316 if Present
(Interface_List
(Def
)) then
13317 Set_Generic_Parent_Type
(Decl_Node
, A_Gen_T
);
13319 Set_Generic_Parent_Type
(Decl_Node
, Ancestor
);
13322 elsif Nkind_In
(Def
, N_Formal_Private_Type_Definition
,
13323 N_Formal_Incomplete_Type_Definition
)
13325 Set_Generic_Parent_Type
(Decl_Node
, A_Gen_T
);
13328 -- If the actual is a synchronized type that implements an interface,
13329 -- the primitive operations are attached to the corresponding record,
13330 -- and we have to treat it as an additional generic actual, so that its
13331 -- primitive operations become visible in the instance. The task or
13332 -- protected type itself does not carry primitive operations.
13334 if Is_Concurrent_Type
(Act_T
)
13335 and then Is_Tagged_Type
(Act_T
)
13336 and then Present
(Corresponding_Record_Type
(Act_T
))
13337 and then Present
(Ancestor
)
13338 and then Is_Interface
(Ancestor
)
13341 Corr_Rec
: constant Entity_Id
:=
13342 Corresponding_Record_Type
(Act_T
);
13343 New_Corr
: Entity_Id
;
13344 Corr_Decl
: Node_Id
;
13347 New_Corr
:= Make_Temporary
(Loc
, 'S');
13349 Make_Subtype_Declaration
(Loc
,
13350 Defining_Identifier
=> New_Corr
,
13351 Subtype_Indication
=>
13352 New_Occurrence_Of
(Corr_Rec
, Loc
));
13353 Append_To
(Decl_Nodes
, Corr_Decl
);
13355 if Ekind
(Act_T
) = E_Task_Type
then
13356 Set_Ekind
(Subt
, E_Task_Subtype
);
13358 Set_Ekind
(Subt
, E_Protected_Subtype
);
13361 Set_Corresponding_Record_Type
(Subt
, Corr_Rec
);
13362 Set_Generic_Parent_Type
(Corr_Decl
, Ancestor
);
13363 Set_Generic_Parent_Type
(Decl_Node
, Empty
);
13367 -- For a floating-point type, capture dimension info if any, because
13368 -- the generated subtype declaration does not come from source and
13369 -- will not process dimensions.
13371 if Is_Floating_Point_Type
(Act_T
) then
13372 Copy_Dimensions
(Act_T
, Subt
);
13376 end Instantiate_Type
;
13378 ---------------------
13379 -- Is_In_Main_Unit --
13380 ---------------------
13382 function Is_In_Main_Unit
(N
: Node_Id
) return Boolean is
13383 Unum
: constant Unit_Number_Type
:= Get_Source_Unit
(N
);
13384 Current_Unit
: Node_Id
;
13387 if Unum
= Main_Unit
then
13390 -- If the current unit is a subunit then it is either the main unit or
13391 -- is being compiled as part of the main unit.
13393 elsif Nkind
(N
) = N_Compilation_Unit
then
13394 return Nkind
(Unit
(N
)) = N_Subunit
;
13397 Current_Unit
:= Parent
(N
);
13398 while Present
(Current_Unit
)
13399 and then Nkind
(Current_Unit
) /= N_Compilation_Unit
13401 Current_Unit
:= Parent
(Current_Unit
);
13404 -- The instantiation node is in the main unit, or else the current node
13405 -- (perhaps as the result of nested instantiations) is in the main unit,
13406 -- or in the declaration of the main unit, which in this last case must
13410 Current_Unit
= Cunit
(Main_Unit
)
13411 or else Current_Unit
= Library_Unit
(Cunit
(Main_Unit
))
13412 or else (Present
(Current_Unit
)
13413 and then Present
(Library_Unit
(Current_Unit
))
13414 and then Is_In_Main_Unit
(Library_Unit
(Current_Unit
)));
13415 end Is_In_Main_Unit
;
13417 ----------------------------
13418 -- Load_Parent_Of_Generic --
13419 ----------------------------
13421 procedure Load_Parent_Of_Generic
13424 Body_Optional
: Boolean := False)
13426 Comp_Unit
: constant Node_Id
:= Cunit
(Get_Source_Unit
(Spec
));
13427 Saved_Style_Check
: constant Boolean := Style_Check
;
13428 Saved_Warnings
: constant Warning_Record
:= Save_Warnings
;
13429 True_Parent
: Node_Id
;
13430 Inst_Node
: Node_Id
;
13432 Previous_Instances
: constant Elist_Id
:= New_Elmt_List
;
13434 procedure Collect_Previous_Instances
(Decls
: List_Id
);
13435 -- Collect all instantiations in the given list of declarations, that
13436 -- precede the generic that we need to load. If the bodies of these
13437 -- instantiations are available, we must analyze them, to ensure that
13438 -- the public symbols generated are the same when the unit is compiled
13439 -- to generate code, and when it is compiled in the context of a unit
13440 -- that needs a particular nested instance. This process is applied to
13441 -- both package and subprogram instances.
13443 --------------------------------
13444 -- Collect_Previous_Instances --
13445 --------------------------------
13447 procedure Collect_Previous_Instances
(Decls
: List_Id
) is
13451 Decl
:= First
(Decls
);
13452 while Present
(Decl
) loop
13453 if Sloc
(Decl
) >= Sloc
(Inst_Node
) then
13456 -- If Decl is an instantiation, then record it as requiring
13457 -- instantiation of the corresponding body, except if it is an
13458 -- abbreviated instantiation generated internally for conformance
13459 -- checking purposes only for the case of a formal package
13460 -- declared without a box (see Instantiate_Formal_Package). Such
13461 -- an instantiation does not generate any code (the actual code
13462 -- comes from actual) and thus does not need to be analyzed here.
13463 -- If the instantiation appears with a generic package body it is
13464 -- not analyzed here either.
13466 elsif Nkind
(Decl
) = N_Package_Instantiation
13467 and then not Is_Internal
(Defining_Entity
(Decl
))
13469 Append_Elmt
(Decl
, Previous_Instances
);
13471 -- For a subprogram instantiation, omit instantiations intrinsic
13472 -- operations (Unchecked_Conversions, etc.) that have no bodies.
13474 elsif Nkind_In
(Decl
, N_Function_Instantiation
,
13475 N_Procedure_Instantiation
)
13476 and then not Is_Intrinsic_Subprogram
(Entity
(Name
(Decl
)))
13478 Append_Elmt
(Decl
, Previous_Instances
);
13480 elsif Nkind
(Decl
) = N_Package_Declaration
then
13481 Collect_Previous_Instances
13482 (Visible_Declarations
(Specification
(Decl
)));
13483 Collect_Previous_Instances
13484 (Private_Declarations
(Specification
(Decl
)));
13486 -- Previous non-generic bodies may contain instances as well
13488 elsif Nkind
(Decl
) = N_Package_Body
13489 and then Ekind
(Corresponding_Spec
(Decl
)) /= E_Generic_Package
13491 Collect_Previous_Instances
(Declarations
(Decl
));
13493 elsif Nkind
(Decl
) = N_Subprogram_Body
13494 and then not Acts_As_Spec
(Decl
)
13495 and then not Is_Generic_Subprogram
(Corresponding_Spec
(Decl
))
13497 Collect_Previous_Instances
(Declarations
(Decl
));
13502 end Collect_Previous_Instances
;
13504 -- Start of processing for Load_Parent_Of_Generic
13507 if not In_Same_Source_Unit
(N
, Spec
)
13508 or else Nkind
(Unit
(Comp_Unit
)) = N_Package_Declaration
13509 or else (Nkind
(Unit
(Comp_Unit
)) = N_Package_Body
13510 and then not Is_In_Main_Unit
(Spec
))
13512 -- Find body of parent of spec, and analyze it. A special case arises
13513 -- when the parent is an instantiation, that is to say when we are
13514 -- currently instantiating a nested generic. In that case, there is
13515 -- no separate file for the body of the enclosing instance. Instead,
13516 -- the enclosing body must be instantiated as if it were a pending
13517 -- instantiation, in order to produce the body for the nested generic
13518 -- we require now. Note that in that case the generic may be defined
13519 -- in a package body, the instance defined in the same package body,
13520 -- and the original enclosing body may not be in the main unit.
13522 Inst_Node
:= Empty
;
13524 True_Parent
:= Parent
(Spec
);
13525 while Present
(True_Parent
)
13526 and then Nkind
(True_Parent
) /= N_Compilation_Unit
13528 if Nkind
(True_Parent
) = N_Package_Declaration
13530 Nkind
(Original_Node
(True_Parent
)) = N_Package_Instantiation
13532 -- Parent is a compilation unit that is an instantiation.
13533 -- Instantiation node has been replaced with package decl.
13535 Inst_Node
:= Original_Node
(True_Parent
);
13538 elsif Nkind
(True_Parent
) = N_Package_Declaration
13539 and then Present
(Generic_Parent
(Specification
(True_Parent
)))
13540 and then Nkind
(Parent
(True_Parent
)) /= N_Compilation_Unit
13542 -- Parent is an instantiation within another specification.
13543 -- Declaration for instance has been inserted before original
13544 -- instantiation node. A direct link would be preferable?
13546 Inst_Node
:= Next
(True_Parent
);
13547 while Present
(Inst_Node
)
13548 and then Nkind
(Inst_Node
) /= N_Package_Instantiation
13553 -- If the instance appears within a generic, and the generic
13554 -- unit is defined within a formal package of the enclosing
13555 -- generic, there is no generic body available, and none
13556 -- needed. A more precise test should be used ???
13558 if No
(Inst_Node
) then
13565 True_Parent
:= Parent
(True_Parent
);
13569 -- Case where we are currently instantiating a nested generic
13571 if Present
(Inst_Node
) then
13572 if Nkind
(Parent
(True_Parent
)) = N_Compilation_Unit
then
13574 -- Instantiation node and declaration of instantiated package
13575 -- were exchanged when only the declaration was needed.
13576 -- Restore instantiation node before proceeding with body.
13578 Set_Unit
(Parent
(True_Parent
), Inst_Node
);
13581 -- Now complete instantiation of enclosing body, if it appears in
13582 -- some other unit. If it appears in the current unit, the body
13583 -- will have been instantiated already.
13585 if No
(Corresponding_Body
(Instance_Spec
(Inst_Node
))) then
13587 -- We need to determine the expander mode to instantiate the
13588 -- enclosing body. Because the generic body we need may use
13589 -- global entities declared in the enclosing package (including
13590 -- aggregates) it is in general necessary to compile this body
13591 -- with expansion enabled, except if we are within a generic
13592 -- package, in which case the usual generic rule applies.
13595 Exp_Status
: Boolean := True;
13599 -- Loop through scopes looking for generic package
13601 Scop
:= Scope
(Defining_Entity
(Instance_Spec
(Inst_Node
)));
13602 while Present
(Scop
)
13603 and then Scop
/= Standard_Standard
13605 if Ekind
(Scop
) = E_Generic_Package
then
13606 Exp_Status
:= False;
13610 Scop
:= Scope
(Scop
);
13613 -- Collect previous instantiations in the unit that contains
13614 -- the desired generic.
13616 if Nkind
(Parent
(True_Parent
)) /= N_Compilation_Unit
13617 and then not Body_Optional
13621 Info
: Pending_Body_Info
;
13625 Par
:= Parent
(Inst_Node
);
13626 while Present
(Par
) loop
13627 exit when Nkind
(Parent
(Par
)) = N_Compilation_Unit
;
13628 Par
:= Parent
(Par
);
13631 pragma Assert
(Present
(Par
));
13633 if Nkind
(Par
) = N_Package_Body
then
13634 Collect_Previous_Instances
(Declarations
(Par
));
13636 elsif Nkind
(Par
) = N_Package_Declaration
then
13637 Collect_Previous_Instances
13638 (Visible_Declarations
(Specification
(Par
)));
13639 Collect_Previous_Instances
13640 (Private_Declarations
(Specification
(Par
)));
13643 -- Enclosing unit is a subprogram body. In this
13644 -- case all instance bodies are processed in order
13645 -- and there is no need to collect them separately.
13650 Decl
:= First_Elmt
(Previous_Instances
);
13651 while Present
(Decl
) loop
13653 (Inst_Node
=> Node
(Decl
),
13655 Instance_Spec
(Node
(Decl
)),
13656 Expander_Status
=> Exp_Status
,
13657 Current_Sem_Unit
=>
13658 Get_Code_Unit
(Sloc
(Node
(Decl
))),
13659 Scope_Suppress
=> Scope_Suppress
,
13660 Local_Suppress_Stack_Top
=>
13661 Local_Suppress_Stack_Top
,
13662 Version
=> Ada_Version
,
13663 Version_Pragma
=> Ada_Version_Pragma
,
13664 Warnings
=> Save_Warnings
,
13665 SPARK_Mode
=> SPARK_Mode
,
13666 SPARK_Mode_Pragma
=> SPARK_Mode_Pragma
);
13668 -- Package instance
13670 if Nkind
(Node
(Decl
)) = N_Package_Instantiation
13672 Instantiate_Package_Body
13673 (Info
, Body_Optional
=> True);
13675 -- Subprogram instance
13678 -- The instance_spec is in the wrapper package,
13679 -- usually followed by its local renaming
13680 -- declaration. See Build_Subprogram_Renaming
13681 -- for details. If the instance carries aspects,
13682 -- these result in the corresponding pragmas,
13683 -- inserted after the subprogram declaration.
13684 -- They must be skipped as well when retrieving
13685 -- the desired spec. Some of them may have been
13686 -- rewritten as null statements.
13687 -- A direct link would be more robust ???
13691 (Last
(Visible_Declarations
13692 (Specification
(Info
.Act_Decl
))));
13694 while Nkind_In
(Decl
,
13697 N_Subprogram_Renaming_Declaration
)
13699 Decl
:= Prev
(Decl
);
13702 Info
.Act_Decl
:= Decl
;
13705 Instantiate_Subprogram_Body
13706 (Info
, Body_Optional
=> True);
13714 Instantiate_Package_Body
13716 ((Inst_Node
=> Inst_Node
,
13717 Act_Decl
=> True_Parent
,
13718 Expander_Status
=> Exp_Status
,
13719 Current_Sem_Unit
=> Get_Code_Unit
13720 (Sloc
(Inst_Node
)),
13721 Scope_Suppress
=> Scope_Suppress
,
13722 Local_Suppress_Stack_Top
=> Local_Suppress_Stack_Top
,
13723 Version
=> Ada_Version
,
13724 Version_Pragma
=> Ada_Version_Pragma
,
13725 Warnings
=> Save_Warnings
,
13726 SPARK_Mode
=> SPARK_Mode
,
13727 SPARK_Mode_Pragma
=> SPARK_Mode_Pragma
)),
13728 Body_Optional
=> Body_Optional
);
13732 -- Case where we are not instantiating a nested generic
13735 Opt
.Style_Check
:= False;
13736 Expander_Mode_Save_And_Set
(True);
13737 Load_Needed_Body
(Comp_Unit
, OK
);
13738 Opt
.Style_Check
:= Saved_Style_Check
;
13739 Restore_Warnings
(Saved_Warnings
);
13740 Expander_Mode_Restore
;
13743 and then Unit_Requires_Body
(Defining_Entity
(Spec
))
13744 and then not Body_Optional
13747 Bname
: constant Unit_Name_Type
:=
13748 Get_Body_Name
(Get_Unit_Name
(Unit
(Comp_Unit
)));
13751 -- In CodePeer mode, the missing body may make the analysis
13752 -- incomplete, but we do not treat it as fatal.
13754 if CodePeer_Mode
then
13758 Error_Msg_Unit_1
:= Bname
;
13759 Error_Msg_N
("this instantiation requires$!", N
);
13760 Error_Msg_File_1
:=
13761 Get_File_Name
(Bname
, Subunit
=> False);
13762 Error_Msg_N
("\but file{ was not found!", N
);
13763 raise Unrecoverable_Error
;
13770 -- If loading parent of the generic caused an instantiation circularity,
13771 -- we abandon compilation at this point, because otherwise in some cases
13772 -- we get into trouble with infinite recursions after this point.
13774 if Circularity_Detected
then
13775 raise Unrecoverable_Error
;
13777 end Load_Parent_Of_Generic
;
13779 ---------------------------------
13780 -- Map_Formal_Package_Entities --
13781 ---------------------------------
13783 procedure Map_Formal_Package_Entities
(Form
: Entity_Id
; Act
: Entity_Id
) is
13788 Set_Instance_Of
(Form
, Act
);
13790 -- Traverse formal and actual package to map the corresponding entities.
13791 -- We skip over internal entities that may be generated during semantic
13792 -- analysis, and find the matching entities by name, given that they
13793 -- must appear in the same order.
13795 E1
:= First_Entity
(Form
);
13796 E2
:= First_Entity
(Act
);
13797 while Present
(E1
) and then E1
/= First_Private_Entity
(Form
) loop
13798 -- Could this test be a single condition??? Seems like it could, and
13799 -- isn't FPE (Form) a constant anyway???
13801 if not Is_Internal
(E1
)
13802 and then Present
(Parent
(E1
))
13803 and then not Is_Class_Wide_Type
(E1
)
13804 and then not Is_Internal_Name
(Chars
(E1
))
13806 while Present
(E2
) and then Chars
(E2
) /= Chars
(E1
) loop
13813 Set_Instance_Of
(E1
, E2
);
13815 if Is_Type
(E1
) and then Is_Tagged_Type
(E2
) then
13816 Set_Instance_Of
(Class_Wide_Type
(E1
), Class_Wide_Type
(E2
));
13819 if Is_Constrained
(E1
) then
13820 Set_Instance_Of
(Base_Type
(E1
), Base_Type
(E2
));
13823 if Ekind
(E1
) = E_Package
and then No
(Renamed_Object
(E1
)) then
13824 Map_Formal_Package_Entities
(E1
, E2
);
13831 end Map_Formal_Package_Entities
;
13833 -----------------------
13834 -- Move_Freeze_Nodes --
13835 -----------------------
13837 procedure Move_Freeze_Nodes
13838 (Out_Of
: Entity_Id
;
13843 Next_Decl
: Node_Id
;
13844 Next_Node
: Node_Id
:= After
;
13847 function Is_Outer_Type
(T
: Entity_Id
) return Boolean;
13848 -- Check whether entity is declared in a scope external to that of the
13851 -------------------
13852 -- Is_Outer_Type --
13853 -------------------
13855 function Is_Outer_Type
(T
: Entity_Id
) return Boolean is
13856 Scop
: Entity_Id
:= Scope
(T
);
13859 if Scope_Depth
(Scop
) < Scope_Depth
(Out_Of
) then
13863 while Scop
/= Standard_Standard
loop
13864 if Scop
= Out_Of
then
13867 Scop
:= Scope
(Scop
);
13875 -- Start of processing for Move_Freeze_Nodes
13882 -- First remove the freeze nodes that may appear before all other
13886 while Present
(Decl
)
13887 and then Nkind
(Decl
) = N_Freeze_Entity
13888 and then Is_Outer_Type
(Entity
(Decl
))
13890 Decl
:= Remove_Head
(L
);
13891 Insert_After
(Next_Node
, Decl
);
13892 Set_Analyzed
(Decl
, False);
13897 -- Next scan the list of declarations and remove each freeze node that
13898 -- appears ahead of the current node.
13900 while Present
(Decl
) loop
13901 while Present
(Next
(Decl
))
13902 and then Nkind
(Next
(Decl
)) = N_Freeze_Entity
13903 and then Is_Outer_Type
(Entity
(Next
(Decl
)))
13905 Next_Decl
:= Remove_Next
(Decl
);
13906 Insert_After
(Next_Node
, Next_Decl
);
13907 Set_Analyzed
(Next_Decl
, False);
13908 Next_Node
:= Next_Decl
;
13911 -- If the declaration is a nested package or concurrent type, then
13912 -- recurse. Nested generic packages will have been processed from the
13915 case Nkind
(Decl
) is
13916 when N_Package_Declaration
=>
13917 Spec
:= Specification
(Decl
);
13919 when N_Task_Type_Declaration
=>
13920 Spec
:= Task_Definition
(Decl
);
13922 when N_Protected_Type_Declaration
=>
13923 Spec
:= Protected_Definition
(Decl
);
13929 if Present
(Spec
) then
13930 Move_Freeze_Nodes
(Out_Of
, Next_Node
, Visible_Declarations
(Spec
));
13931 Move_Freeze_Nodes
(Out_Of
, Next_Node
, Private_Declarations
(Spec
));
13936 end Move_Freeze_Nodes
;
13942 function Next_Assoc
(E
: Assoc_Ptr
) return Assoc_Ptr
is
13944 return Generic_Renamings
.Table
(E
).Next_In_HTable
;
13947 ------------------------
13948 -- Preanalyze_Actuals --
13949 ------------------------
13951 procedure Preanalyze_Actuals
(N
: Node_Id
; Inst
: Entity_Id
:= Empty
) is
13954 Errs
: constant Nat
:= Serious_Errors_Detected
;
13956 Cur
: Entity_Id
:= Empty
;
13957 -- Current homograph of the instance name
13959 Vis
: Boolean := False;
13960 -- Saved visibility status of the current homograph
13963 Assoc
:= First
(Generic_Associations
(N
));
13965 -- If the instance is a child unit, its name may hide an outer homonym,
13966 -- so make it invisible to perform name resolution on the actuals.
13968 if Nkind
(Defining_Unit_Name
(N
)) = N_Defining_Program_Unit_Name
13970 (Current_Entity
(Defining_Identifier
(Defining_Unit_Name
(N
))))
13972 Cur
:= Current_Entity
(Defining_Identifier
(Defining_Unit_Name
(N
)));
13974 if Is_Compilation_Unit
(Cur
) then
13975 Vis
:= Is_Immediately_Visible
(Cur
);
13976 Set_Is_Immediately_Visible
(Cur
, False);
13982 while Present
(Assoc
) loop
13983 if Nkind
(Assoc
) /= N_Others_Choice
then
13984 Act
:= Explicit_Generic_Actual_Parameter
(Assoc
);
13986 -- Within a nested instantiation, a defaulted actual is an empty
13987 -- association, so nothing to analyze. If the subprogram actual
13988 -- is an attribute, analyze prefix only, because actual is not a
13989 -- complete attribute reference.
13991 -- If actual is an allocator, analyze expression only. The full
13992 -- analysis can generate code, and if instance is a compilation
13993 -- unit we have to wait until the package instance is installed
13994 -- to have a proper place to insert this code.
13996 -- String literals may be operators, but at this point we do not
13997 -- know whether the actual is a formal subprogram or a string.
14002 elsif Nkind
(Act
) = N_Attribute_Reference
then
14003 Analyze
(Prefix
(Act
));
14005 elsif Nkind
(Act
) = N_Explicit_Dereference
then
14006 Analyze
(Prefix
(Act
));
14008 elsif Nkind
(Act
) = N_Allocator
then
14010 Expr
: constant Node_Id
:= Expression
(Act
);
14013 if Nkind
(Expr
) = N_Subtype_Indication
then
14014 Analyze
(Subtype_Mark
(Expr
));
14016 -- Analyze separately each discriminant constraint, when
14017 -- given with a named association.
14023 Constr
:= First
(Constraints
(Constraint
(Expr
)));
14024 while Present
(Constr
) loop
14025 if Nkind
(Constr
) = N_Discriminant_Association
then
14026 Analyze
(Expression
(Constr
));
14040 elsif Nkind
(Act
) /= N_Operator_Symbol
then
14043 -- Within a package instance, mark actuals that are limited
14044 -- views, so their use can be moved to the body of the
14047 if Is_Entity_Name
(Act
)
14048 and then Is_Type
(Entity
(Act
))
14049 and then From_Limited_With
(Entity
(Act
))
14050 and then Present
(Inst
)
14052 Append_Elmt
(Entity
(Act
), Incomplete_Actuals
(Inst
));
14056 if Errs
/= Serious_Errors_Detected
then
14058 -- Do a minimal analysis of the generic, to prevent spurious
14059 -- warnings complaining about the generic being unreferenced,
14060 -- before abandoning the instantiation.
14062 Analyze
(Name
(N
));
14064 if Is_Entity_Name
(Name
(N
))
14065 and then Etype
(Name
(N
)) /= Any_Type
14067 Generate_Reference
(Entity
(Name
(N
)), Name
(N
));
14068 Set_Is_Instantiated
(Entity
(Name
(N
)));
14071 if Present
(Cur
) then
14073 -- For the case of a child instance hiding an outer homonym,
14074 -- provide additional warning which might explain the error.
14076 Set_Is_Immediately_Visible
(Cur
, Vis
);
14078 ("& hides outer unit with the same name??",
14079 N
, Defining_Unit_Name
(N
));
14082 Abandon_Instantiation
(Act
);
14089 if Present
(Cur
) then
14090 Set_Is_Immediately_Visible
(Cur
, Vis
);
14092 end Preanalyze_Actuals
;
14094 -------------------------------
14095 -- Provide_Completing_Bodies --
14096 -------------------------------
14098 procedure Provide_Completing_Bodies
(N
: Node_Id
) is
14099 procedure Build_Completing_Body
(Subp_Decl
: Node_Id
);
14100 -- Generate the completing body for subprogram declaration Subp_Decl
14102 procedure Provide_Completing_Bodies_In
(Decls
: List_Id
);
14103 -- Generating completing bodies for all subprograms found in declarative
14106 ---------------------------
14107 -- Build_Completing_Body --
14108 ---------------------------
14110 procedure Build_Completing_Body
(Subp_Decl
: Node_Id
) is
14111 Loc
: constant Source_Ptr
:= Sloc
(Subp_Decl
);
14112 Subp_Id
: constant Entity_Id
:= Defining_Entity
(Subp_Decl
);
14116 -- Nothing to do if the subprogram already has a completing body
14118 if Present
(Corresponding_Body
(Subp_Decl
)) then
14121 -- Mark the function as having a valid return statement even though
14122 -- the body contains a single raise statement.
14124 elsif Ekind
(Subp_Id
) = E_Function
then
14125 Set_Return_Present
(Subp_Id
);
14128 -- Clone the specification to obtain new entities and reset the only
14131 Spec
:= Copy_Subprogram_Spec
(Specification
(Subp_Decl
));
14132 Set_Generic_Parent
(Spec
, Empty
);
14135 -- function Func ... return ... is
14137 -- procedure Proc ... is
14139 -- raise Program_Error with "access before elaboration";
14142 Insert_After_And_Analyze
(Subp_Decl
,
14143 Make_Subprogram_Body
(Loc
,
14144 Specification
=> Spec
,
14145 Declarations
=> New_List
,
14146 Handled_Statement_Sequence
=>
14147 Make_Handled_Sequence_Of_Statements
(Loc
,
14148 Statements
=> New_List
(
14149 Make_Raise_Program_Error
(Loc
,
14150 Reason
=> PE_Access_Before_Elaboration
)))));
14151 end Build_Completing_Body
;
14153 ----------------------------------
14154 -- Provide_Completing_Bodies_In --
14155 ----------------------------------
14157 procedure Provide_Completing_Bodies_In
(Decls
: List_Id
) is
14161 if Present
(Decls
) then
14162 Decl
:= First
(Decls
);
14163 while Present
(Decl
) loop
14164 Provide_Completing_Bodies
(Decl
);
14168 end Provide_Completing_Bodies_In
;
14174 -- Start of processing for Provide_Completing_Bodies
14177 if Nkind
(N
) = N_Package_Declaration
then
14178 Spec
:= Specification
(N
);
14180 Push_Scope
(Defining_Entity
(N
));
14181 Provide_Completing_Bodies_In
(Visible_Declarations
(Spec
));
14182 Provide_Completing_Bodies_In
(Private_Declarations
(Spec
));
14185 elsif Nkind
(N
) = N_Subprogram_Declaration
then
14186 Build_Completing_Body
(N
);
14188 end Provide_Completing_Bodies
;
14190 -------------------
14191 -- Remove_Parent --
14192 -------------------
14194 procedure Remove_Parent
(In_Body
: Boolean := False) is
14195 S
: Entity_Id
:= Current_Scope
;
14196 -- S is the scope containing the instantiation just completed. The scope
14197 -- stack contains the parent instances of the instantiation, followed by
14206 -- After child instantiation is complete, remove from scope stack the
14207 -- extra copy of the current scope, and then remove parent instances.
14209 if not In_Body
then
14212 while Current_Scope
/= S
loop
14213 P
:= Current_Scope
;
14214 End_Package_Scope
(Current_Scope
);
14216 if In_Open_Scopes
(P
) then
14217 E
:= First_Entity
(P
);
14218 while Present
(E
) loop
14219 Set_Is_Immediately_Visible
(E
, True);
14223 -- If instantiation is declared in a block, it is the enclosing
14224 -- scope that might be a parent instance. Note that only one
14225 -- block can be involved, because the parent instances have
14226 -- been installed within it.
14228 if Ekind
(P
) = E_Block
then
14229 Cur_P
:= Scope
(P
);
14234 if Is_Generic_Instance
(Cur_P
) and then P
/= Current_Scope
then
14235 -- We are within an instance of some sibling. Retain
14236 -- visibility of parent, for proper subsequent cleanup, and
14237 -- reinstall private declarations as well.
14239 Set_In_Private_Part
(P
);
14240 Install_Private_Declarations
(P
);
14243 -- If the ultimate parent is a top-level unit recorded in
14244 -- Instance_Parent_Unit, then reset its visibility to what it was
14245 -- before instantiation. (It's not clear what the purpose is of
14246 -- testing whether Scope (P) is In_Open_Scopes, but that test was
14247 -- present before the ultimate parent test was added.???)
14249 elsif not In_Open_Scopes
(Scope
(P
))
14250 or else (P
= Instance_Parent_Unit
14251 and then not Parent_Unit_Visible
)
14253 Set_Is_Immediately_Visible
(P
, False);
14255 -- If the current scope is itself an instantiation of a generic
14256 -- nested within P, and we are in the private part of body of this
14257 -- instantiation, restore the full views of P, that were removed
14258 -- in End_Package_Scope above. This obscure case can occur when a
14259 -- subunit of a generic contains an instance of a child unit of
14260 -- its generic parent unit.
14262 elsif S
= Current_Scope
and then Is_Generic_Instance
(S
) then
14264 Par
: constant Entity_Id
:=
14265 Generic_Parent
(Package_Specification
(S
));
14268 and then P
= Scope
(Par
)
14269 and then (In_Package_Body
(S
) or else In_Private_Part
(S
))
14271 Set_In_Private_Part
(P
);
14272 Install_Private_Declarations
(P
);
14278 -- Reset visibility of entities in the enclosing scope
14280 Set_Is_Hidden_Open_Scope
(Current_Scope
, False);
14282 Hidden
:= First_Elmt
(Hidden_Entities
);
14283 while Present
(Hidden
) loop
14284 Set_Is_Immediately_Visible
(Node
(Hidden
), True);
14285 Next_Elmt
(Hidden
);
14289 -- Each body is analyzed separately, and there is no context that
14290 -- needs preserving from one body instance to the next, so remove all
14291 -- parent scopes that have been installed.
14293 while Present
(S
) loop
14294 End_Package_Scope
(S
);
14295 Set_Is_Immediately_Visible
(S
, False);
14296 S
:= Current_Scope
;
14297 exit when S
= Standard_Standard
;
14306 procedure Restore_Env
is
14307 Saved
: Instance_Env
renames Instance_Envs
.Table
(Instance_Envs
.Last
);
14310 if No
(Current_Instantiated_Parent
.Act_Id
) then
14311 -- Restore environment after subprogram inlining
14313 Restore_Private_Views
(Empty
);
14316 Current_Instantiated_Parent
:= Saved
.Instantiated_Parent
;
14317 Exchanged_Views
:= Saved
.Exchanged_Views
;
14318 Hidden_Entities
:= Saved
.Hidden_Entities
;
14319 Current_Sem_Unit
:= Saved
.Current_Sem_Unit
;
14320 Parent_Unit_Visible
:= Saved
.Parent_Unit_Visible
;
14321 Instance_Parent_Unit
:= Saved
.Instance_Parent_Unit
;
14323 Restore_Opt_Config_Switches
(Saved
.Switches
);
14325 Instance_Envs
.Decrement_Last
;
14328 ---------------------------
14329 -- Restore_Private_Views --
14330 ---------------------------
14332 procedure Restore_Private_Views
14333 (Pack_Id
: Entity_Id
;
14334 Is_Package
: Boolean := True)
14339 Dep_Elmt
: Elmt_Id
;
14342 procedure Restore_Nested_Formal
(Formal
: Entity_Id
);
14343 -- Hide the generic formals of formal packages declared with box which
14344 -- were reachable in the current instantiation.
14346 ---------------------------
14347 -- Restore_Nested_Formal --
14348 ---------------------------
14350 procedure Restore_Nested_Formal
(Formal
: Entity_Id
) is
14354 if Present
(Renamed_Object
(Formal
))
14355 and then Denotes_Formal_Package
(Renamed_Object
(Formal
), True)
14359 elsif Present
(Associated_Formal_Package
(Formal
)) then
14360 Ent
:= First_Entity
(Formal
);
14361 while Present
(Ent
) loop
14362 exit when Ekind
(Ent
) = E_Package
14363 and then Renamed_Entity
(Ent
) = Renamed_Entity
(Formal
);
14365 Set_Is_Hidden
(Ent
);
14366 Set_Is_Potentially_Use_Visible
(Ent
, False);
14368 -- If package, then recurse
14370 if Ekind
(Ent
) = E_Package
then
14371 Restore_Nested_Formal
(Ent
);
14377 end Restore_Nested_Formal
;
14379 -- Start of processing for Restore_Private_Views
14382 M
:= First_Elmt
(Exchanged_Views
);
14383 while Present
(M
) loop
14386 -- Subtypes of types whose views have been exchanged, and that are
14387 -- defined within the instance, were not on the Private_Dependents
14388 -- list on entry to the instance, so they have to be exchanged
14389 -- explicitly now, in order to remain consistent with the view of the
14392 if Ekind_In
(Typ
, E_Private_Type
,
14393 E_Limited_Private_Type
,
14394 E_Record_Type_With_Private
)
14396 Dep_Elmt
:= First_Elmt
(Private_Dependents
(Typ
));
14397 while Present
(Dep_Elmt
) loop
14398 Dep_Typ
:= Node
(Dep_Elmt
);
14400 if Scope
(Dep_Typ
) = Pack_Id
14401 and then Present
(Full_View
(Dep_Typ
))
14403 Replace_Elmt
(Dep_Elmt
, Full_View
(Dep_Typ
));
14404 Exchange_Declarations
(Dep_Typ
);
14407 Next_Elmt
(Dep_Elmt
);
14411 Exchange_Declarations
(Node
(M
));
14415 if No
(Pack_Id
) then
14419 -- Make the generic formal parameters private, and make the formal types
14420 -- into subtypes of the actuals again.
14422 E
:= First_Entity
(Pack_Id
);
14423 while Present
(E
) loop
14424 Set_Is_Hidden
(E
, True);
14427 and then Nkind
(Parent
(E
)) = N_Subtype_Declaration
14429 -- If the actual for E is itself a generic actual type from
14430 -- an enclosing instance, E is still a generic actual type
14431 -- outside of the current instance. This matter when resolving
14432 -- an overloaded call that may be ambiguous in the enclosing
14433 -- instance, when two of its actuals coincide.
14435 if Is_Entity_Name
(Subtype_Indication
(Parent
(E
)))
14436 and then Is_Generic_Actual_Type
14437 (Entity
(Subtype_Indication
(Parent
(E
))))
14441 Set_Is_Generic_Actual_Type
(E
, False);
14444 -- An unusual case of aliasing: the actual may also be directly
14445 -- visible in the generic, and be private there, while it is fully
14446 -- visible in the context of the instance. The internal subtype
14447 -- is private in the instance but has full visibility like its
14448 -- parent in the enclosing scope. This enforces the invariant that
14449 -- the privacy status of all private dependents of a type coincide
14450 -- with that of the parent type. This can only happen when a
14451 -- generic child unit is instantiated within a sibling.
14453 if Is_Private_Type
(E
)
14454 and then not Is_Private_Type
(Etype
(E
))
14456 Exchange_Declarations
(E
);
14459 elsif Ekind
(E
) = E_Package
then
14461 -- The end of the renaming list is the renaming of the generic
14462 -- package itself. If the instance is a subprogram, all entities
14463 -- in the corresponding package are renamings. If this entity is
14464 -- a formal package, make its own formals private as well. The
14465 -- actual in this case is itself the renaming of an instantiation.
14466 -- If the entity is not a package renaming, it is the entity
14467 -- created to validate formal package actuals: ignore it.
14469 -- If the actual is itself a formal package for the enclosing
14470 -- generic, or the actual for such a formal package, it remains
14471 -- visible on exit from the instance, and therefore nothing needs
14472 -- to be done either, except to keep it accessible.
14474 if Is_Package
and then Renamed_Object
(E
) = Pack_Id
then
14477 elsif Nkind
(Parent
(E
)) /= N_Package_Renaming_Declaration
then
14481 Denotes_Formal_Package
(Renamed_Object
(E
), True, Pack_Id
)
14483 Set_Is_Hidden
(E
, False);
14487 Act_P
: constant Entity_Id
:= Renamed_Object
(E
);
14491 Id
:= First_Entity
(Act_P
);
14493 and then Id
/= First_Private_Entity
(Act_P
)
14495 exit when Ekind
(Id
) = E_Package
14496 and then Renamed_Object
(Id
) = Act_P
;
14498 Set_Is_Hidden
(Id
, True);
14499 Set_Is_Potentially_Use_Visible
(Id
, In_Use
(Act_P
));
14501 if Ekind
(Id
) = E_Package
then
14502 Restore_Nested_Formal
(Id
);
14513 end Restore_Private_Views
;
14520 (Gen_Unit
: Entity_Id
;
14521 Act_Unit
: Entity_Id
)
14525 Set_Instance_Env
(Gen_Unit
, Act_Unit
);
14528 ----------------------------
14529 -- Save_Global_References --
14530 ----------------------------
14532 procedure Save_Global_References
(Templ
: Node_Id
) is
14534 -- ??? it is horrible to use global variables in highly recursive code
14537 -- The entity of the current associated node
14539 Gen_Scope
: Entity_Id
;
14540 -- The scope of the generic for which references are being saved
14543 -- The current associated node
14545 function Is_Global
(E
: Entity_Id
) return Boolean;
14546 -- Check whether entity is defined outside of generic unit. Examine the
14547 -- scope of an entity, and the scope of the scope, etc, until we find
14548 -- either Standard, in which case the entity is global, or the generic
14549 -- unit itself, which indicates that the entity is local. If the entity
14550 -- is the generic unit itself, as in the case of a recursive call, or
14551 -- the enclosing generic unit, if different from the current scope, then
14552 -- it is local as well, because it will be replaced at the point of
14553 -- instantiation. On the other hand, if it is a reference to a child
14554 -- unit of a common ancestor, which appears in an instantiation, it is
14555 -- global because it is used to denote a specific compilation unit at
14556 -- the time the instantiations will be analyzed.
14558 procedure Qualify_Universal_Operands
14560 Func_Call
: Node_Id
);
14561 -- Op denotes a binary or unary operator in generic template Templ. Node
14562 -- Func_Call is the function call alternative of the operator within the
14563 -- the analyzed copy of the template. Change each operand which yields a
14564 -- universal type by wrapping it into a qualified expression
14566 -- Actual_Typ'(Operand)
14568 -- where Actual_Typ is the type of corresponding actual parameter of
14569 -- Operand in Func_Call.
14571 procedure Reset_Entity
(N
: Node_Id
);
14572 -- Save semantic information on global entity so that it is not resolved
14573 -- again at instantiation time.
14575 procedure Save_Entity_Descendants
(N
: Node_Id
);
14576 -- Apply Save_Global_References to the two syntactic descendants of
14577 -- non-terminal nodes that carry an Associated_Node and are processed
14578 -- through Reset_Entity. Once the global entity (if any) has been
14579 -- captured together with its type, only two syntactic descendants need
14580 -- to be traversed to complete the processing of the tree rooted at N.
14581 -- This applies to Selected_Components, Expanded_Names, and to Operator
14582 -- nodes. N can also be a character literal, identifier, or operator
14583 -- symbol node, but the call has no effect in these cases.
14585 procedure Save_Global_Defaults
(N1
: Node_Id
; N2
: Node_Id
);
14586 -- Default actuals in nested instances must be handled specially
14587 -- because there is no link to them from the original tree. When an
14588 -- actual subprogram is given by a default, we add an explicit generic
14589 -- association for it in the instantiation node. When we save the
14590 -- global references on the name of the instance, we recover the list
14591 -- of generic associations, and add an explicit one to the original
14592 -- generic tree, through which a global actual can be preserved.
14593 -- Similarly, if a child unit is instantiated within a sibling, in the
14594 -- context of the parent, we must preserve the identifier of the parent
14595 -- so that it can be properly resolved in a subsequent instantiation.
14597 procedure Save_Global_Descendant
(D
: Union_Id
);
14598 -- Apply Save_References recursively to the descendants of node D
14600 procedure Save_References
(N
: Node_Id
);
14601 -- This is the recursive procedure that does the work, once the
14602 -- enclosing generic scope has been established.
14608 function Is_Global
(E
: Entity_Id
) return Boolean is
14611 function Is_Instance_Node
(Decl
: Node_Id
) return Boolean;
14612 -- Determine whether the parent node of a reference to a child unit
14613 -- denotes an instantiation or a formal package, in which case the
14614 -- reference to the child unit is global, even if it appears within
14615 -- the current scope (e.g. when the instance appears within the body
14616 -- of an ancestor).
14618 ----------------------
14619 -- Is_Instance_Node --
14620 ----------------------
14622 function Is_Instance_Node
(Decl
: Node_Id
) return Boolean is
14624 return Nkind
(Decl
) in N_Generic_Instantiation
14626 Nkind
(Original_Node
(Decl
)) = N_Formal_Package_Declaration
;
14627 end Is_Instance_Node
;
14629 -- Start of processing for Is_Global
14632 if E
= Gen_Scope
then
14635 elsif E
= Standard_Standard
then
14638 elsif Is_Child_Unit
(E
)
14639 and then (Is_Instance_Node
(Parent
(N2
))
14640 or else (Nkind
(Parent
(N2
)) = N_Expanded_Name
14641 and then N2
= Selector_Name
(Parent
(N2
))
14643 Is_Instance_Node
(Parent
(Parent
(N2
)))))
14649 while Se
/= Gen_Scope
loop
14650 if Se
= Standard_Standard
then
14661 --------------------------------
14662 -- Qualify_Universal_Operands --
14663 --------------------------------
14665 procedure Qualify_Universal_Operands
14667 Func_Call
: Node_Id
)
14669 procedure Qualify_Operand
(Opnd
: Node_Id
; Actual
: Node_Id
);
14670 -- Rewrite operand Opnd as a qualified expression of the form
14672 -- Actual_Typ'(Opnd)
14674 -- where Actual is the corresponding actual parameter of Opnd in
14675 -- function call Func_Call.
14677 function Qualify_Type
14679 Typ
: Entity_Id
) return Node_Id
;
14680 -- Qualify type Typ by creating a selected component of the form
14682 -- Scope_Of_Typ.Typ
14684 ---------------------
14685 -- Qualify_Operand --
14686 ---------------------
14688 procedure Qualify_Operand
(Opnd
: Node_Id
; Actual
: Node_Id
) is
14689 Loc
: constant Source_Ptr
:= Sloc
(Opnd
);
14690 Typ
: constant Entity_Id
:= Etype
(Actual
);
14695 -- Qualify the operand when it is of a universal type. Note that
14696 -- the template is unanalyzed and it is not possible to directly
14697 -- query the type. This transformation is not done when the type
14698 -- of the actual is internally generated because the type will be
14699 -- regenerated in the instance.
14701 if Yields_Universal_Type
(Opnd
)
14702 and then Comes_From_Source
(Typ
)
14703 and then not Is_Hidden
(Typ
)
14705 -- The type of the actual may be a global reference. Save this
14706 -- information by creating a reference to it.
14708 if Is_Global
(Typ
) then
14709 Mark
:= New_Occurrence_Of
(Typ
, Loc
);
14711 -- Otherwise rely on resolution to find the proper type within
14715 Mark
:= Qualify_Type
(Loc
, Typ
);
14719 Make_Qualified_Expression
(Loc
,
14720 Subtype_Mark
=> Mark
,
14721 Expression
=> Relocate_Node
(Opnd
));
14723 -- Mark the qualification to distinguish it from other source
14724 -- constructs and signal the instantiation mechanism that this
14725 -- node requires special processing. See Copy_Generic_Node for
14728 Set_Is_Qualified_Universal_Literal
(Qual
);
14730 Rewrite
(Opnd
, Qual
);
14732 end Qualify_Operand
;
14738 function Qualify_Type
14740 Typ
: Entity_Id
) return Node_Id
14742 Scop
: constant Entity_Id
:= Scope
(Typ
);
14746 Result
:= Make_Identifier
(Loc
, Chars
(Typ
));
14748 if Present
(Scop
) and then not Is_Generic_Unit
(Scop
) then
14750 Make_Selected_Component
(Loc
,
14751 Prefix
=> Make_Identifier
(Loc
, Chars
(Scop
)),
14752 Selector_Name
=> Result
);
14760 Actuals
: constant List_Id
:= Parameter_Associations
(Func_Call
);
14762 -- Start of processing for Qualify_Universal_Operands
14765 if Nkind
(Op
) in N_Binary_Op
then
14766 Qualify_Operand
(Left_Opnd
(Op
), First
(Actuals
));
14767 Qualify_Operand
(Right_Opnd
(Op
), Next
(First
(Actuals
)));
14769 elsif Nkind
(Op
) in N_Unary_Op
then
14770 Qualify_Operand
(Right_Opnd
(Op
), First
(Actuals
));
14772 end Qualify_Universal_Operands
;
14778 procedure Reset_Entity
(N
: Node_Id
) is
14779 procedure Set_Global_Type
(N
: Node_Id
; N2
: Node_Id
);
14780 -- If the type of N2 is global to the generic unit, save the type in
14781 -- the generic node. Just as we perform name capture for explicit
14782 -- references within the generic, we must capture the global types
14783 -- of local entities because they may participate in resolution in
14786 function Top_Ancestor
(E
: Entity_Id
) return Entity_Id
;
14787 -- Find the ultimate ancestor of the current unit. If it is not a
14788 -- generic unit, then the name of the current unit in the prefix of
14789 -- an expanded name must be replaced with its generic homonym to
14790 -- ensure that it will be properly resolved in an instance.
14792 ---------------------
14793 -- Set_Global_Type --
14794 ---------------------
14796 procedure Set_Global_Type
(N
: Node_Id
; N2
: Node_Id
) is
14797 Typ
: constant Entity_Id
:= Etype
(N2
);
14800 Set_Etype
(N
, Typ
);
14802 -- If the entity of N is not the associated node, this is a
14803 -- nested generic and it has an associated node as well, whose
14804 -- type is already the full view (see below). Indicate that the
14805 -- original node has a private view.
14807 if Entity
(N
) /= N2
and then Has_Private_View
(Entity
(N
)) then
14808 Set_Has_Private_View
(N
);
14811 -- If not a private type, nothing else to do
14813 if not Is_Private_Type
(Typ
) then
14814 if Is_Array_Type
(Typ
)
14815 and then Is_Private_Type
(Component_Type
(Typ
))
14817 Set_Has_Private_View
(N
);
14820 -- If it is a derivation of a private type in a context where no
14821 -- full view is needed, nothing to do either.
14823 elsif No
(Full_View
(Typ
)) and then Typ
/= Etype
(Typ
) then
14826 -- Otherwise mark the type for flipping and use the full view when
14830 Set_Has_Private_View
(N
);
14832 if Present
(Full_View
(Typ
)) then
14833 Set_Etype
(N2
, Full_View
(Typ
));
14837 if Is_Floating_Point_Type
(Typ
)
14838 and then Has_Dimension_System
(Typ
)
14840 Copy_Dimensions
(N2
, N
);
14842 end Set_Global_Type
;
14848 function Top_Ancestor
(E
: Entity_Id
) return Entity_Id
is
14853 while Is_Child_Unit
(Par
) loop
14854 Par
:= Scope
(Par
);
14860 -- Start of processing for Reset_Entity
14863 N2
:= Get_Associated_Node
(N
);
14866 if Present
(E
) then
14868 -- If the node is an entry call to an entry in an enclosing task,
14869 -- it is rewritten as a selected component. No global entity to
14870 -- preserve in this case, since the expansion will be redone in
14873 if not Nkind_In
(E
, N_Defining_Character_Literal
,
14874 N_Defining_Identifier
,
14875 N_Defining_Operator_Symbol
)
14877 Set_Associated_Node
(N
, Empty
);
14878 Set_Etype
(N
, Empty
);
14882 -- If the entity is an itype created as a subtype of an access
14883 -- type with a null exclusion restore source entity for proper
14884 -- visibility. The itype will be created anew in the instance.
14887 and then Ekind
(E
) = E_Access_Subtype
14888 and then Is_Entity_Name
(N
)
14889 and then Chars
(Etype
(E
)) = Chars
(N
)
14892 Set_Entity
(N2
, E
);
14896 if Is_Global
(E
) then
14898 -- If the entity is a package renaming that is the prefix of
14899 -- an expanded name, it has been rewritten as the renamed
14900 -- package, which is necessary semantically but complicates
14901 -- ASIS tree traversal, so we recover the original entity to
14902 -- expose the renaming. Take into account that the context may
14903 -- be a nested generic, that the original node may itself have
14904 -- an associated node that had better be an entity, and that
14905 -- the current node is still a selected component.
14907 if Ekind
(E
) = E_Package
14908 and then Nkind
(N
) = N_Selected_Component
14909 and then Nkind
(Parent
(N
)) = N_Expanded_Name
14910 and then Present
(Original_Node
(N2
))
14911 and then Is_Entity_Name
(Original_Node
(N2
))
14912 and then Present
(Entity
(Original_Node
(N2
)))
14914 if Is_Global
(Entity
(Original_Node
(N2
))) then
14915 N2
:= Original_Node
(N2
);
14916 Set_Associated_Node
(N
, N2
);
14917 Set_Global_Type
(N
, N2
);
14919 -- Renaming is local, and will be resolved in instance
14922 Set_Associated_Node
(N
, Empty
);
14923 Set_Etype
(N
, Empty
);
14927 Set_Global_Type
(N
, N2
);
14930 elsif Nkind
(N
) = N_Op_Concat
14931 and then Is_Generic_Type
(Etype
(N2
))
14932 and then (Base_Type
(Etype
(Right_Opnd
(N2
))) = Etype
(N2
)
14934 Base_Type
(Etype
(Left_Opnd
(N2
))) = Etype
(N2
))
14935 and then Is_Intrinsic_Subprogram
(E
)
14939 -- Entity is local. Mark generic node as unresolved. Note that now
14940 -- it does not have an entity.
14943 Set_Associated_Node
(N
, Empty
);
14944 Set_Etype
(N
, Empty
);
14947 if Nkind
(Parent
(N
)) in N_Generic_Instantiation
14948 and then N
= Name
(Parent
(N
))
14950 Save_Global_Defaults
(Parent
(N
), Parent
(N2
));
14953 elsif Nkind
(Parent
(N
)) = N_Selected_Component
14954 and then Nkind
(Parent
(N2
)) = N_Expanded_Name
14956 if Is_Global
(Entity
(Parent
(N2
))) then
14957 Change_Selected_Component_To_Expanded_Name
(Parent
(N
));
14958 Set_Associated_Node
(Parent
(N
), Parent
(N2
));
14959 Set_Global_Type
(Parent
(N
), Parent
(N2
));
14960 Save_Entity_Descendants
(N
);
14962 -- If this is a reference to the current generic entity, replace
14963 -- by the name of the generic homonym of the current package. This
14964 -- is because in an instantiation Par.P.Q will not resolve to the
14965 -- name of the instance, whose enclosing scope is not necessarily
14966 -- Par. We use the generic homonym rather that the name of the
14967 -- generic itself because it may be hidden by a local declaration.
14969 elsif In_Open_Scopes
(Entity
(Parent
(N2
)))
14971 Is_Generic_Unit
(Top_Ancestor
(Entity
(Prefix
(Parent
(N2
)))))
14973 if Ekind
(Entity
(Parent
(N2
))) = E_Generic_Package
then
14974 Rewrite
(Parent
(N
),
14975 Make_Identifier
(Sloc
(N
),
14977 Chars
(Generic_Homonym
(Entity
(Parent
(N2
))))));
14979 Rewrite
(Parent
(N
),
14980 Make_Identifier
(Sloc
(N
),
14981 Chars
=> Chars
(Selector_Name
(Parent
(N2
)))));
14985 if Nkind
(Parent
(Parent
(N
))) in N_Generic_Instantiation
14986 and then Parent
(N
) = Name
(Parent
(Parent
(N
)))
14988 Save_Global_Defaults
14989 (Parent
(Parent
(N
)), Parent
(Parent
(N2
)));
14992 -- A selected component may denote a static constant that has been
14993 -- folded. If the static constant is global to the generic, capture
14994 -- its value. Otherwise the folding will happen in any instantiation.
14996 elsif Nkind
(Parent
(N
)) = N_Selected_Component
14997 and then Nkind_In
(Parent
(N2
), N_Integer_Literal
, N_Real_Literal
)
14999 if Present
(Entity
(Original_Node
(Parent
(N2
))))
15000 and then Is_Global
(Entity
(Original_Node
(Parent
(N2
))))
15002 Rewrite
(Parent
(N
), New_Copy
(Parent
(N2
)));
15003 Set_Analyzed
(Parent
(N
), False);
15006 -- A selected component may be transformed into a parameterless
15007 -- function call. If the called entity is global, rewrite the node
15008 -- appropriately, i.e. as an extended name for the global entity.
15010 elsif Nkind
(Parent
(N
)) = N_Selected_Component
15011 and then Nkind
(Parent
(N2
)) = N_Function_Call
15012 and then N
= Selector_Name
(Parent
(N
))
15014 if No
(Parameter_Associations
(Parent
(N2
))) then
15015 if Is_Global
(Entity
(Name
(Parent
(N2
)))) then
15016 Change_Selected_Component_To_Expanded_Name
(Parent
(N
));
15017 Set_Associated_Node
(Parent
(N
), Name
(Parent
(N2
)));
15018 Set_Global_Type
(Parent
(N
), Name
(Parent
(N2
)));
15019 Save_Entity_Descendants
(N
);
15022 Set_Is_Prefixed_Call
(Parent
(N
));
15023 Set_Associated_Node
(N
, Empty
);
15024 Set_Etype
(N
, Empty
);
15027 -- In Ada 2005, X.F may be a call to a primitive operation,
15028 -- rewritten as F (X). This rewriting will be done again in an
15029 -- instance, so keep the original node. Global entities will be
15030 -- captured as for other constructs. Indicate that this must
15031 -- resolve as a call, to prevent accidental overloading in the
15032 -- instance, if both a component and a primitive operation appear
15036 Set_Is_Prefixed_Call
(Parent
(N
));
15039 -- Entity is local. Reset in generic unit, so that node is resolved
15040 -- anew at the point of instantiation.
15043 Set_Associated_Node
(N
, Empty
);
15044 Set_Etype
(N
, Empty
);
15048 -----------------------------
15049 -- Save_Entity_Descendants --
15050 -----------------------------
15052 procedure Save_Entity_Descendants
(N
: Node_Id
) is
15055 when N_Binary_Op
=>
15056 Save_Global_Descendant
(Union_Id
(Left_Opnd
(N
)));
15057 Save_Global_Descendant
(Union_Id
(Right_Opnd
(N
)));
15060 Save_Global_Descendant
(Union_Id
(Right_Opnd
(N
)));
15062 when N_Expanded_Name
15063 | N_Selected_Component
15065 Save_Global_Descendant
(Union_Id
(Prefix
(N
)));
15066 Save_Global_Descendant
(Union_Id
(Selector_Name
(N
)));
15068 when N_Character_Literal
15070 | N_Operator_Symbol
15075 raise Program_Error
;
15077 end Save_Entity_Descendants
;
15079 --------------------------
15080 -- Save_Global_Defaults --
15081 --------------------------
15083 procedure Save_Global_Defaults
(N1
: Node_Id
; N2
: Node_Id
) is
15084 Loc
: constant Source_Ptr
:= Sloc
(N1
);
15085 Assoc2
: constant List_Id
:= Generic_Associations
(N2
);
15086 Gen_Id
: constant Entity_Id
:= Get_Generic_Entity
(N2
);
15093 Actual
: Entity_Id
;
15096 Assoc1
:= Generic_Associations
(N1
);
15098 if Present
(Assoc1
) then
15099 Act1
:= First
(Assoc1
);
15102 Set_Generic_Associations
(N1
, New_List
);
15103 Assoc1
:= Generic_Associations
(N1
);
15106 if Present
(Assoc2
) then
15107 Act2
:= First
(Assoc2
);
15112 while Present
(Act1
) and then Present
(Act2
) loop
15117 -- Find the associations added for default subprograms
15119 if Present
(Act2
) then
15120 while Nkind
(Act2
) /= N_Generic_Association
15121 or else No
(Entity
(Selector_Name
(Act2
)))
15122 or else not Is_Overloadable
(Entity
(Selector_Name
(Act2
)))
15127 -- Add a similar association if the default is global. The
15128 -- renaming declaration for the actual has been analyzed, and
15129 -- its alias is the program it renames. Link the actual in the
15130 -- original generic tree with the node in the analyzed tree.
15132 while Present
(Act2
) loop
15133 Subp
:= Entity
(Selector_Name
(Act2
));
15134 Def
:= Explicit_Generic_Actual_Parameter
(Act2
);
15136 -- Following test is defence against rubbish errors
15138 if No
(Alias
(Subp
)) then
15142 -- Retrieve the resolved actual from the renaming declaration
15143 -- created for the instantiated formal.
15145 Actual
:= Entity
(Name
(Parent
(Parent
(Subp
))));
15146 Set_Entity
(Def
, Actual
);
15147 Set_Etype
(Def
, Etype
(Actual
));
15149 if Is_Global
(Actual
) then
15151 Make_Generic_Association
(Loc
,
15153 New_Occurrence_Of
(Subp
, Loc
),
15154 Explicit_Generic_Actual_Parameter
=>
15155 New_Occurrence_Of
(Actual
, Loc
));
15157 Set_Associated_Node
15158 (Explicit_Generic_Actual_Parameter
(Ndec
), Def
);
15160 Append
(Ndec
, Assoc1
);
15162 -- If there are other defaults, add a dummy association in case
15163 -- there are other defaulted formals with the same name.
15165 elsif Present
(Next
(Act2
)) then
15167 Make_Generic_Association
(Loc
,
15169 New_Occurrence_Of
(Subp
, Loc
),
15170 Explicit_Generic_Actual_Parameter
=> Empty
);
15172 Append
(Ndec
, Assoc1
);
15179 if Nkind
(Name
(N1
)) = N_Identifier
15180 and then Is_Child_Unit
(Gen_Id
)
15181 and then Is_Global
(Gen_Id
)
15182 and then Is_Generic_Unit
(Scope
(Gen_Id
))
15183 and then In_Open_Scopes
(Scope
(Gen_Id
))
15185 -- This is an instantiation of a child unit within a sibling, so
15186 -- that the generic parent is in scope. An eventual instance must
15187 -- occur within the scope of an instance of the parent. Make name
15188 -- in instance into an expanded name, to preserve the identifier
15189 -- of the parent, so it can be resolved subsequently.
15191 Rewrite
(Name
(N2
),
15192 Make_Expanded_Name
(Loc
,
15193 Chars
=> Chars
(Gen_Id
),
15194 Prefix
=> New_Occurrence_Of
(Scope
(Gen_Id
), Loc
),
15195 Selector_Name
=> New_Occurrence_Of
(Gen_Id
, Loc
)));
15196 Set_Entity
(Name
(N2
), Gen_Id
);
15198 Rewrite
(Name
(N1
),
15199 Make_Expanded_Name
(Loc
,
15200 Chars
=> Chars
(Gen_Id
),
15201 Prefix
=> New_Occurrence_Of
(Scope
(Gen_Id
), Loc
),
15202 Selector_Name
=> New_Occurrence_Of
(Gen_Id
, Loc
)));
15204 Set_Associated_Node
(Name
(N1
), Name
(N2
));
15205 Set_Associated_Node
(Prefix
(Name
(N1
)), Empty
);
15206 Set_Associated_Node
15207 (Selector_Name
(Name
(N1
)), Selector_Name
(Name
(N2
)));
15208 Set_Etype
(Name
(N1
), Etype
(Gen_Id
));
15210 end Save_Global_Defaults
;
15212 ----------------------------
15213 -- Save_Global_Descendant --
15214 ----------------------------
15216 procedure Save_Global_Descendant
(D
: Union_Id
) is
15220 if D
in Node_Range
then
15221 if D
= Union_Id
(Empty
) then
15224 elsif Nkind
(Node_Id
(D
)) /= N_Compilation_Unit
then
15225 Save_References
(Node_Id
(D
));
15228 elsif D
in List_Range
then
15229 pragma Assert
(D
/= Union_Id
(No_List
));
15230 -- Because No_List = Empty, which is in Node_Range above
15232 if Is_Empty_List
(List_Id
(D
)) then
15236 N1
:= First
(List_Id
(D
));
15237 while Present
(N1
) loop
15238 Save_References
(N1
);
15243 -- Element list or other non-node field, nothing to do
15248 end Save_Global_Descendant
;
15250 ---------------------
15251 -- Save_References --
15252 ---------------------
15254 -- This is the recursive procedure that does the work once the enclosing
15255 -- generic scope has been established. We have to treat specially a
15256 -- number of node rewritings that are required by semantic processing
15257 -- and which change the kind of nodes in the generic copy: typically
15258 -- constant-folding, replacing an operator node by a string literal, or
15259 -- a selected component by an expanded name. In each of those cases, the
15260 -- transformation is propagated to the generic unit.
15262 procedure Save_References
(N
: Node_Id
) is
15263 Loc
: constant Source_Ptr
:= Sloc
(N
);
15265 function Requires_Delayed_Save
(Nod
: Node_Id
) return Boolean;
15266 -- Determine whether arbitrary node Nod requires delayed capture of
15267 -- global references within its aspect specifications.
15269 procedure Save_References_In_Aggregate
(N
: Node_Id
);
15270 -- Save all global references in [extension] aggregate node N
15272 procedure Save_References_In_Char_Lit_Or_Op_Symbol
(N
: Node_Id
);
15273 -- Save all global references in a character literal or operator
15274 -- symbol denoted by N.
15276 procedure Save_References_In_Descendants
(N
: Node_Id
);
15277 -- Save all global references in all descendants of node N
15279 procedure Save_References_In_Identifier
(N
: Node_Id
);
15280 -- Save all global references in identifier node N
15282 procedure Save_References_In_Operator
(N
: Node_Id
);
15283 -- Save all global references in operator node N
15285 procedure Save_References_In_Pragma
(Prag
: Node_Id
);
15286 -- Save all global references found within the expression of pragma
15289 ---------------------------
15290 -- Requires_Delayed_Save --
15291 ---------------------------
15293 function Requires_Delayed_Save
(Nod
: Node_Id
) return Boolean is
15295 -- Generic packages and subprograms require delayed capture of
15296 -- global references within their aspects due to the timing of
15297 -- annotation analysis.
15299 if Nkind_In
(Nod
, N_Generic_Package_Declaration
,
15300 N_Generic_Subprogram_Declaration
,
15302 N_Package_Body_Stub
,
15304 N_Subprogram_Body_Stub
)
15306 -- Since the capture of global references is done on the
15307 -- unanalyzed generic template, there is no information around
15308 -- to infer the context. Use the Associated_Entity linkages to
15309 -- peek into the analyzed generic copy and determine what the
15310 -- template corresponds to.
15312 if Nod
= Templ
then
15314 Is_Generic_Declaration_Or_Body
15315 (Unit_Declaration_Node
15316 (Associated_Entity
(Defining_Entity
(Nod
))));
15318 -- Otherwise the generic unit being processed is not the top
15319 -- level template. It is safe to capture of global references
15320 -- within the generic unit because at this point the top level
15321 -- copy is fully analyzed.
15327 -- Otherwise capture the global references without interference
15332 end Requires_Delayed_Save
;
15334 ----------------------------------
15335 -- Save_References_In_Aggregate --
15336 ----------------------------------
15338 procedure Save_References_In_Aggregate
(N
: Node_Id
) is
15340 Qual
: Node_Id
:= Empty
;
15341 Typ
: Entity_Id
:= Empty
;
15343 use Atree
.Unchecked_Access
;
15344 -- This code section is part of implementing an untyped tree
15345 -- traversal, so it needs direct access to node fields.
15348 N2
:= Get_Associated_Node
(N
);
15350 if Present
(N2
) then
15353 -- In an instance within a generic, use the name of the actual
15354 -- and not the original generic parameter. If the actual is
15355 -- global in the current generic it must be preserved for its
15358 if Nkind
(Parent
(Typ
)) = N_Subtype_Declaration
15359 and then Present
(Generic_Parent_Type
(Parent
(Typ
)))
15361 Typ
:= Base_Type
(Typ
);
15362 Set_Etype
(N2
, Typ
);
15366 if No
(N2
) or else No
(Typ
) or else not Is_Global
(Typ
) then
15367 Set_Associated_Node
(N
, Empty
);
15369 -- If the aggregate is an actual in a call, it has been
15370 -- resolved in the current context, to some local type. The
15371 -- enclosing call may have been disambiguated by the aggregate,
15372 -- and this disambiguation might fail at instantiation time
15373 -- because the type to which the aggregate did resolve is not
15374 -- preserved. In order to preserve some of this information,
15375 -- wrap the aggregate in a qualified expression, using the id
15376 -- of its type. For further disambiguation we qualify the type
15377 -- name with its scope (if visible and not hidden by a local
15378 -- homograph) because both id's will have corresponding
15379 -- entities in an instance. This resolves most of the problems
15380 -- with missing type information on aggregates in instances.
15383 and then Nkind
(N2
) = Nkind
(N
)
15384 and then Nkind
(Parent
(N2
)) in N_Subprogram_Call
15385 and then Present
(Typ
)
15386 and then Comes_From_Source
(Typ
)
15388 Nam
:= Make_Identifier
(Loc
, Chars
(Typ
));
15390 if Is_Immediately_Visible
(Scope
(Typ
))
15392 (not In_Open_Scopes
(Scope
(Typ
))
15393 or else Current_Entity
(Scope
(Typ
)) = Scope
(Typ
))
15396 Make_Selected_Component
(Loc
,
15398 Make_Identifier
(Loc
, Chars
(Scope
(Typ
))),
15399 Selector_Name
=> Nam
);
15403 Make_Qualified_Expression
(Loc
,
15404 Subtype_Mark
=> Nam
,
15405 Expression
=> Relocate_Node
(N
));
15409 Save_Global_Descendant
(Field1
(N
));
15410 Save_Global_Descendant
(Field2
(N
));
15411 Save_Global_Descendant
(Field3
(N
));
15412 Save_Global_Descendant
(Field5
(N
));
15414 if Present
(Qual
) then
15417 end Save_References_In_Aggregate
;
15419 ----------------------------------------------
15420 -- Save_References_In_Char_Lit_Or_Op_Symbol --
15421 ----------------------------------------------
15423 procedure Save_References_In_Char_Lit_Or_Op_Symbol
(N
: Node_Id
) is
15425 if Nkind
(N
) = Nkind
(Get_Associated_Node
(N
)) then
15428 elsif Nkind
(N
) = N_Operator_Symbol
15429 and then Nkind
(Get_Associated_Node
(N
)) = N_String_Literal
15431 Change_Operator_Symbol_To_String_Literal
(N
);
15433 end Save_References_In_Char_Lit_Or_Op_Symbol
;
15435 ------------------------------------
15436 -- Save_References_In_Descendants --
15437 ------------------------------------
15439 procedure Save_References_In_Descendants
(N
: Node_Id
) is
15440 use Atree
.Unchecked_Access
;
15441 -- This code section is part of implementing an untyped tree
15442 -- traversal, so it needs direct access to node fields.
15445 Save_Global_Descendant
(Field1
(N
));
15446 Save_Global_Descendant
(Field2
(N
));
15447 Save_Global_Descendant
(Field3
(N
));
15448 Save_Global_Descendant
(Field4
(N
));
15449 Save_Global_Descendant
(Field5
(N
));
15450 end Save_References_In_Descendants
;
15452 -----------------------------------
15453 -- Save_References_In_Identifier --
15454 -----------------------------------
15456 procedure Save_References_In_Identifier
(N
: Node_Id
) is
15458 -- The node did not undergo a transformation
15460 if Nkind
(N
) = Nkind
(Get_Associated_Node
(N
)) then
15462 Aux_N2
: constant Node_Id
:= Get_Associated_Node
(N
);
15463 Orig_N2_Parent
: constant Node_Id
:=
15464 Original_Node
(Parent
(Aux_N2
));
15466 -- The parent of this identifier is a selected component
15467 -- which denotes a named number that was constant folded.
15468 -- Preserve the original name for ASIS and link the parent
15469 -- with its expanded name. The constant folding will be
15470 -- repeated in the instance.
15472 if Nkind
(Parent
(N
)) = N_Selected_Component
15473 and then Nkind_In
(Parent
(Aux_N2
), N_Integer_Literal
,
15475 and then Is_Entity_Name
(Orig_N2_Parent
)
15476 and then Ekind
(Entity
(Orig_N2_Parent
)) in Named_Kind
15477 and then Is_Global
(Entity
(Orig_N2_Parent
))
15480 Set_Associated_Node
15481 (Parent
(N
), Original_Node
(Parent
(N2
)));
15486 -- If this is a discriminant reference, always save it.
15487 -- It is used in the instance to find the corresponding
15488 -- discriminant positionally rather than by name.
15490 Set_Original_Discriminant
15491 (N
, Original_Discriminant
(Get_Associated_Node
(N
)));
15497 -- The analysis of the generic copy transformed the identifier
15498 -- into another construct. Propagate the changes to the template.
15501 N2
:= Get_Associated_Node
(N
);
15503 -- The identifier denotes a call to a parameterless function.
15504 -- Mark the node as resolved when the function is external.
15506 if Nkind
(N2
) = N_Function_Call
then
15507 E
:= Entity
(Name
(N2
));
15509 if Present
(E
) and then Is_Global
(E
) then
15510 Set_Etype
(N
, Etype
(N2
));
15512 Set_Associated_Node
(N
, Empty
);
15513 Set_Etype
(N
, Empty
);
15516 -- The identifier denotes a named number that was constant
15517 -- folded. Preserve the original name for ASIS and undo the
15518 -- constant folding which will be repeated in the instance.
15520 elsif Nkind_In
(N2
, N_Integer_Literal
, N_Real_Literal
)
15521 and then Is_Entity_Name
(Original_Node
(N2
))
15523 Set_Associated_Node
(N
, Original_Node
(N2
));
15526 -- The identifier resolved to a string literal. Propagate this
15527 -- information to the generic template.
15529 elsif Nkind
(N2
) = N_String_Literal
then
15530 Rewrite
(N
, New_Copy
(N2
));
15532 -- The identifier is rewritten as a dereference if it is the
15533 -- prefix of an implicit dereference. Preserve the original
15534 -- tree as the analysis of the instance will expand the node
15535 -- again, but preserve the resolved entity if it is global.
15537 elsif Nkind
(N2
) = N_Explicit_Dereference
then
15538 if Is_Entity_Name
(Prefix
(N2
))
15539 and then Present
(Entity
(Prefix
(N2
)))
15540 and then Is_Global
(Entity
(Prefix
(N2
)))
15542 Set_Associated_Node
(N
, Prefix
(N2
));
15544 elsif Nkind
(Prefix
(N2
)) = N_Function_Call
15545 and then Present
(Entity
(Name
(Prefix
(N2
))))
15546 and then Is_Global
(Entity
(Name
(Prefix
(N2
))))
15549 Make_Explicit_Dereference
(Loc
,
15551 Make_Function_Call
(Loc
,
15554 (Entity
(Name
(Prefix
(N2
))), Loc
))));
15557 Set_Associated_Node
(N
, Empty
);
15558 Set_Etype
(N
, Empty
);
15561 -- The subtype mark of a nominally unconstrained object is
15562 -- rewritten as a subtype indication using the bounds of the
15563 -- expression. Recover the original subtype mark.
15565 elsif Nkind
(N2
) = N_Subtype_Indication
15566 and then Is_Entity_Name
(Original_Node
(N2
))
15568 Set_Associated_Node
(N
, Original_Node
(N2
));
15572 end Save_References_In_Identifier
;
15574 ---------------------------------
15575 -- Save_References_In_Operator --
15576 ---------------------------------
15578 procedure Save_References_In_Operator
(N
: Node_Id
) is
15580 -- The node did not undergo a transformation
15582 if Nkind
(N
) = Nkind
(Get_Associated_Node
(N
)) then
15583 if Nkind
(N
) = N_Op_Concat
then
15584 Set_Is_Component_Left_Opnd
(N
,
15585 Is_Component_Left_Opnd
(Get_Associated_Node
(N
)));
15587 Set_Is_Component_Right_Opnd
(N
,
15588 Is_Component_Right_Opnd
(Get_Associated_Node
(N
)));
15593 -- The analysis of the generic copy transformed the operator into
15594 -- some other construct. Propagate the changes to the template if
15598 N2
:= Get_Associated_Node
(N
);
15600 -- The operator resoved to a function call
15602 if Nkind
(N2
) = N_Function_Call
then
15604 -- Add explicit qualifications in the generic template for
15605 -- all operands of universal type. This aids resolution by
15606 -- preserving the actual type of a literal or an attribute
15607 -- that yields a universal result.
15609 Qualify_Universal_Operands
(N
, N2
);
15611 E
:= Entity
(Name
(N2
));
15613 if Present
(E
) and then Is_Global
(E
) then
15614 Set_Etype
(N
, Etype
(N2
));
15616 Set_Associated_Node
(N
, Empty
);
15617 Set_Etype
(N
, Empty
);
15620 -- The operator was folded into a literal
15622 elsif Nkind_In
(N2
, N_Integer_Literal
,
15626 if Present
(Original_Node
(N2
))
15627 and then Nkind
(Original_Node
(N2
)) = Nkind
(N
)
15629 -- Operation was constant-folded. Whenever possible,
15630 -- recover semantic information from unfolded node,
15633 Set_Associated_Node
(N
, Original_Node
(N2
));
15635 if Nkind
(N
) = N_Op_Concat
then
15636 Set_Is_Component_Left_Opnd
(N
,
15637 Is_Component_Left_Opnd
(Get_Associated_Node
(N
)));
15638 Set_Is_Component_Right_Opnd
(N
,
15639 Is_Component_Right_Opnd
(Get_Associated_Node
(N
)));
15644 -- Propagate the constant folding back to the template
15647 Rewrite
(N
, New_Copy
(N2
));
15648 Set_Analyzed
(N
, False);
15651 -- The operator was folded into an enumeration literal. Retain
15652 -- the entity to avoid spurious ambiguities if it is overloaded
15653 -- at the point of instantiation or inlining.
15655 elsif Nkind
(N2
) = N_Identifier
15656 and then Ekind
(Entity
(N2
)) = E_Enumeration_Literal
15658 Rewrite
(N
, New_Copy
(N2
));
15659 Set_Analyzed
(N
, False);
15663 -- Complete the operands check if node has not been constant
15666 if Nkind
(N
) in N_Op
then
15667 Save_Entity_Descendants
(N
);
15669 end Save_References_In_Operator
;
15671 -------------------------------
15672 -- Save_References_In_Pragma --
15673 -------------------------------
15675 procedure Save_References_In_Pragma
(Prag
: Node_Id
) is
15677 Do_Save
: Boolean := True;
15679 use Atree
.Unchecked_Access
;
15680 -- This code section is part of implementing an untyped tree
15681 -- traversal, so it needs direct access to node fields.
15684 -- Do not save global references in pragmas generated from aspects
15685 -- because the pragmas will be regenerated at instantiation time.
15687 if From_Aspect_Specification
(Prag
) then
15690 -- The capture of global references within contract-related source
15691 -- pragmas associated with generic packages, subprograms or their
15692 -- respective bodies must be delayed due to timing of annotation
15693 -- analysis. Global references are still captured in routine
15694 -- Save_Global_References_In_Contract.
15696 elsif Is_Generic_Contract_Pragma
(Prag
) and then Prag
/= Templ
then
15697 if Is_Package_Contract_Annotation
(Prag
) then
15698 Context
:= Find_Related_Package_Or_Body
(Prag
);
15700 pragma Assert
(Is_Subprogram_Contract_Annotation
(Prag
));
15701 Context
:= Find_Related_Declaration_Or_Body
(Prag
);
15704 -- The use of Original_Node accounts for the case when the
15705 -- related context is generic template.
15707 if Requires_Delayed_Save
(Original_Node
(Context
)) then
15712 -- For all other cases, save all global references within the
15713 -- descendants, but skip the following semantic fields:
15715 -- Field1 - Next_Pragma
15716 -- Field3 - Corresponding_Aspect
15717 -- Field5 - Next_Rep_Item
15720 Save_Global_Descendant
(Field2
(Prag
));
15721 Save_Global_Descendant
(Field4
(Prag
));
15723 end Save_References_In_Pragma
;
15725 -- Start of processing for Save_References
15733 elsif Nkind_In
(N
, N_Aggregate
, N_Extension_Aggregate
) then
15734 Save_References_In_Aggregate
(N
);
15736 -- Character literals, operator symbols
15738 elsif Nkind_In
(N
, N_Character_Literal
, N_Operator_Symbol
) then
15739 Save_References_In_Char_Lit_Or_Op_Symbol
(N
);
15741 -- Defining identifiers
15743 elsif Nkind
(N
) in N_Entity
then
15748 elsif Nkind
(N
) = N_Identifier
then
15749 Save_References_In_Identifier
(N
);
15753 elsif Nkind
(N
) in N_Op
then
15754 Save_References_In_Operator
(N
);
15758 elsif Nkind
(N
) = N_Pragma
then
15759 Save_References_In_Pragma
(N
);
15762 Save_References_In_Descendants
(N
);
15765 -- Save all global references found within the aspect specifications
15766 -- of the related node.
15768 if Permits_Aspect_Specifications
(N
) and then Has_Aspects
(N
) then
15770 -- The capture of global references within aspects associated with
15771 -- generic packages, subprograms or their bodies must be delayed
15772 -- due to timing of annotation analysis. Global references are
15773 -- still captured in routine Save_Global_References_In_Contract.
15775 if Requires_Delayed_Save
(N
) then
15778 -- Otherwise save all global references within the aspects
15781 Save_Global_References_In_Aspects
(N
);
15784 end Save_References
;
15786 -- Start of processing for Save_Global_References
15789 Gen_Scope
:= Current_Scope
;
15791 -- If the generic unit is a child unit, references to entities in the
15792 -- parent are treated as local, because they will be resolved anew in
15793 -- the context of the instance of the parent.
15795 while Is_Child_Unit
(Gen_Scope
)
15796 and then Ekind
(Scope
(Gen_Scope
)) = E_Generic_Package
15798 Gen_Scope
:= Scope
(Gen_Scope
);
15801 Save_References
(Templ
);
15802 end Save_Global_References
;
15804 ---------------------------------------
15805 -- Save_Global_References_In_Aspects --
15806 ---------------------------------------
15808 procedure Save_Global_References_In_Aspects
(N
: Node_Id
) is
15813 Asp
:= First
(Aspect_Specifications
(N
));
15814 while Present
(Asp
) loop
15815 Expr
:= Expression
(Asp
);
15817 if Present
(Expr
) then
15818 Save_Global_References
(Expr
);
15823 end Save_Global_References_In_Aspects
;
15825 ------------------------------------------
15826 -- Set_Copied_Sloc_For_Inherited_Pragma --
15827 ------------------------------------------
15829 procedure Set_Copied_Sloc_For_Inherited_Pragma
15834 Create_Instantiation_Source
(N
, E
,
15835 Inlined_Body
=> False,
15836 Inherited_Pragma
=> True,
15837 Factor
=> S_Adjustment
);
15838 end Set_Copied_Sloc_For_Inherited_Pragma
;
15840 --------------------------------------
15841 -- Set_Copied_Sloc_For_Inlined_Body --
15842 --------------------------------------
15844 procedure Set_Copied_Sloc_For_Inlined_Body
(N
: Node_Id
; E
: Entity_Id
) is
15846 Create_Instantiation_Source
(N
, E
,
15847 Inlined_Body
=> True,
15848 Inherited_Pragma
=> False,
15849 Factor
=> S_Adjustment
);
15850 end Set_Copied_Sloc_For_Inlined_Body
;
15852 ---------------------
15853 -- Set_Instance_Of --
15854 ---------------------
15856 procedure Set_Instance_Of
(A
: Entity_Id
; B
: Entity_Id
) is
15858 Generic_Renamings
.Table
(Generic_Renamings
.Last
) := (A
, B
, Assoc_Null
);
15859 Generic_Renamings_HTable
.Set
(Generic_Renamings
.Last
);
15860 Generic_Renamings
.Increment_Last
;
15861 end Set_Instance_Of
;
15863 --------------------
15864 -- Set_Next_Assoc --
15865 --------------------
15867 procedure Set_Next_Assoc
(E
: Assoc_Ptr
; Next
: Assoc_Ptr
) is
15869 Generic_Renamings
.Table
(E
).Next_In_HTable
:= Next
;
15870 end Set_Next_Assoc
;
15872 -------------------
15873 -- Start_Generic --
15874 -------------------
15876 procedure Start_Generic
is
15878 -- ??? More things could be factored out in this routine.
15879 -- Should probably be done at a later stage.
15881 Generic_Flags
.Append
(Inside_A_Generic
);
15882 Inside_A_Generic
:= True;
15884 Expander_Mode_Save_And_Set
(False);
15887 ----------------------
15888 -- Set_Instance_Env --
15889 ----------------------
15891 -- WARNING: This routine manages SPARK regions
15893 procedure Set_Instance_Env
15894 (Gen_Unit
: Entity_Id
;
15895 Act_Unit
: Entity_Id
)
15897 Saved_AE
: constant Boolean := Assertions_Enabled
;
15898 Saved_SM
: constant SPARK_Mode_Type
:= SPARK_Mode
;
15899 Saved_SMP
: constant Node_Id
:= SPARK_Mode_Pragma
;
15900 -- Save the SPARK mode-related data because utilizing the configuration
15901 -- values of pragmas and switches will eliminate any previously set
15905 -- Regardless of the current mode, predefined units are analyzed in the
15906 -- most current Ada mode, and earlier version Ada checks do not apply
15907 -- to predefined units. Nothing needs to be done for non-internal units.
15908 -- These are always analyzed in the current mode.
15910 if In_Internal_Unit
(Gen_Unit
) then
15911 Set_Opt_Config_Switches
(True, Current_Sem_Unit
= Main_Unit
);
15913 -- In Ada2012 we may want to enable assertions in an instance of a
15914 -- predefined unit, in which case we need to preserve the current
15915 -- setting for the Assertions_Enabled flag. This will become more
15916 -- critical when pre/postconditions are added to predefined units,
15917 -- as is already the case for some numeric libraries.
15919 if Ada_Version
>= Ada_2012
then
15920 Assertions_Enabled
:= Saved_AE
;
15923 -- Reinstall the SPARK_Mode which was in effect at the point of
15926 Install_SPARK_Mode
(Saved_SM
, Saved_SMP
);
15929 Current_Instantiated_Parent
:=
15930 (Gen_Id
=> Gen_Unit
,
15931 Act_Id
=> Act_Unit
,
15932 Next_In_HTable
=> Assoc_Null
);
15933 end Set_Instance_Env
;
15939 procedure Switch_View
(T
: Entity_Id
) is
15940 BT
: constant Entity_Id
:= Base_Type
(T
);
15941 Priv_Elmt
: Elmt_Id
:= No_Elmt
;
15942 Priv_Sub
: Entity_Id
;
15945 -- T may be private but its base type may have been exchanged through
15946 -- some other occurrence, in which case there is nothing to switch
15947 -- besides T itself. Note that a private dependent subtype of a private
15948 -- type might not have been switched even if the base type has been,
15949 -- because of the last branch of Check_Private_View (see comment there).
15951 if not Is_Private_Type
(BT
) then
15952 Prepend_Elmt
(Full_View
(T
), Exchanged_Views
);
15953 Exchange_Declarations
(T
);
15957 Priv_Elmt
:= First_Elmt
(Private_Dependents
(BT
));
15959 if Present
(Full_View
(BT
)) then
15960 Prepend_Elmt
(Full_View
(BT
), Exchanged_Views
);
15961 Exchange_Declarations
(BT
);
15964 while Present
(Priv_Elmt
) loop
15965 Priv_Sub
:= (Node
(Priv_Elmt
));
15967 -- We avoid flipping the subtype if the Etype of its full view is
15968 -- private because this would result in a malformed subtype. This
15969 -- occurs when the Etype of the subtype full view is the full view of
15970 -- the base type (and since the base types were just switched, the
15971 -- subtype is pointing to the wrong view). This is currently the case
15972 -- for tagged record types, access types (maybe more?) and needs to
15973 -- be resolved. ???
15975 if Present
(Full_View
(Priv_Sub
))
15976 and then not Is_Private_Type
(Etype
(Full_View
(Priv_Sub
)))
15978 Prepend_Elmt
(Full_View
(Priv_Sub
), Exchanged_Views
);
15979 Exchange_Declarations
(Priv_Sub
);
15982 Next_Elmt
(Priv_Elmt
);
15990 function True_Parent
(N
: Node_Id
) return Node_Id
is
15992 if Nkind
(Parent
(N
)) = N_Subunit
then
15993 return Parent
(Corresponding_Stub
(Parent
(N
)));
15999 -----------------------------
16000 -- Valid_Default_Attribute --
16001 -----------------------------
16003 procedure Valid_Default_Attribute
(Nam
: Entity_Id
; Def
: Node_Id
) is
16004 Attr_Id
: constant Attribute_Id
:=
16005 Get_Attribute_Id
(Attribute_Name
(Def
));
16006 T
: constant Entity_Id
:= Entity
(Prefix
(Def
));
16007 Is_Fun
: constant Boolean := (Ekind
(Nam
) = E_Function
);
16013 if No
(T
) or else T
= Any_Id
then
16018 F
:= First_Formal
(Nam
);
16019 while Present
(F
) loop
16020 Num_F
:= Num_F
+ 1;
16025 when Attribute_Adjacent
16026 | Attribute_Ceiling
16027 | Attribute_Copy_Sign
16029 | Attribute_Fraction
16030 | Attribute_Machine
16032 | Attribute_Remainder
16033 | Attribute_Rounding
16034 | Attribute_Unbiased_Rounding
16038 and then Is_Floating_Point_Type
(T
);
16040 when Attribute_Image
16044 | Attribute_Wide_Image
16045 | Attribute_Wide_Value
16047 OK
:= Is_Fun
and then Num_F
= 1 and then Is_Scalar_Type
(T
);
16052 OK
:= Is_Fun
and then Num_F
= 2 and then Is_Scalar_Type
(T
);
16054 when Attribute_Input
=>
16055 OK
:= (Is_Fun
and then Num_F
= 1);
16057 when Attribute_Output
16061 OK
:= not Is_Fun
and then Num_F
= 2;
16069 ("attribute reference has wrong profile for subprogram", Def
);
16071 end Valid_Default_Attribute
;