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 Remove_Parent
(In_Body
: Boolean := False);
843 -- Reverse effect after instantiation of child is complete
845 procedure Restore_Hidden_Primitives
(Prims_List
: in out Elist_Id
);
846 -- Restore suffix 'P' to primitives of Prims_List and leave Prims_List
849 procedure Set_Instance_Env
850 (Gen_Unit
: Entity_Id
;
851 Act_Unit
: Entity_Id
);
852 -- Save current instance on saved environment, to be used to determine
853 -- the global status of entities in nested instances. Part of Save_Env.
854 -- called after verifying that the generic unit is legal for the instance,
855 -- The procedure also examines whether the generic unit is a predefined
856 -- unit, in order to set configuration switches accordingly. As a result
857 -- the procedure must be called after analyzing and freezing the actuals.
859 procedure Set_Instance_Of
(A
: Entity_Id
; B
: Entity_Id
);
860 -- Associate analyzed generic parameter with corresponding instance. Used
861 -- for semantic checks at instantiation time.
863 function True_Parent
(N
: Node_Id
) return Node_Id
;
864 -- For a subunit, return parent of corresponding stub, else return
867 procedure Valid_Default_Attribute
(Nam
: Entity_Id
; Def
: Node_Id
);
868 -- Verify that an attribute that appears as the default for a formal
869 -- subprogram is a function or procedure with the correct profile.
871 -------------------------------------------
872 -- Data Structures for Generic Renamings --
873 -------------------------------------------
875 -- The map Generic_Renamings associates generic entities with their
876 -- corresponding actuals. Currently used to validate type instances. It
877 -- will eventually be used for all generic parameters to eliminate the
878 -- need for overload resolution in the instance.
880 type Assoc_Ptr
is new Int
;
882 Assoc_Null
: constant Assoc_Ptr
:= -1;
887 Next_In_HTable
: Assoc_Ptr
;
890 package Generic_Renamings
is new Table
.Table
891 (Table_Component_Type
=> Assoc
,
892 Table_Index_Type
=> Assoc_Ptr
,
893 Table_Low_Bound
=> 0,
895 Table_Increment
=> 100,
896 Table_Name
=> "Generic_Renamings");
898 -- Variable to hold enclosing instantiation. When the environment is
899 -- saved for a subprogram inlining, the corresponding Act_Id is empty.
901 Current_Instantiated_Parent
: Assoc
:= (Empty
, Empty
, Assoc_Null
);
903 -- Hash table for associations
905 HTable_Size
: constant := 37;
906 type HTable_Range
is range 0 .. HTable_Size
- 1;
908 procedure Set_Next_Assoc
(E
: Assoc_Ptr
; Next
: Assoc_Ptr
);
909 function Next_Assoc
(E
: Assoc_Ptr
) return Assoc_Ptr
;
910 function Get_Gen_Id
(E
: Assoc_Ptr
) return Entity_Id
;
911 function Hash
(F
: Entity_Id
) return HTable_Range
;
913 package Generic_Renamings_HTable
is new GNAT
.HTable
.Static_HTable
(
914 Header_Num
=> HTable_Range
,
916 Elmt_Ptr
=> Assoc_Ptr
,
917 Null_Ptr
=> Assoc_Null
,
918 Set_Next
=> Set_Next_Assoc
,
921 Get_Key
=> Get_Gen_Id
,
925 Exchanged_Views
: Elist_Id
;
926 -- This list holds the private views that have been exchanged during
927 -- instantiation to restore the visibility of the generic declaration.
928 -- (see comments above). After instantiation, the current visibility is
929 -- reestablished by means of a traversal of this list.
931 Hidden_Entities
: Elist_Id
;
932 -- This list holds the entities of the current scope that are removed
933 -- from immediate visibility when instantiating a child unit. Their
934 -- visibility is restored in Remove_Parent.
936 -- Because instantiations can be recursive, the following must be saved
937 -- on entry and restored on exit from an instantiation (spec or body).
938 -- This is done by the two procedures Save_Env and Restore_Env. For
939 -- package and subprogram instantiations (but not for the body instances)
940 -- the action of Save_Env is done in two steps: Init_Env is called before
941 -- Check_Generic_Child_Unit, because setting the parent instances requires
942 -- that the visibility data structures be properly initialized. Once the
943 -- generic is unit is validated, Set_Instance_Env completes Save_Env.
945 Parent_Unit_Visible
: Boolean := False;
946 -- Parent_Unit_Visible is used when the generic is a child unit, and
947 -- indicates whether the ultimate parent of the generic is visible in the
948 -- instantiation environment. It is used to reset the visibility of the
949 -- parent at the end of the instantiation (see Remove_Parent).
951 Instance_Parent_Unit
: Entity_Id
:= Empty
;
952 -- This records the ultimate parent unit of an instance of a generic
953 -- child unit and is used in conjunction with Parent_Unit_Visible to
954 -- indicate the unit to which the Parent_Unit_Visible flag corresponds.
956 type Instance_Env
is record
957 Instantiated_Parent
: Assoc
;
958 Exchanged_Views
: Elist_Id
;
959 Hidden_Entities
: Elist_Id
;
960 Current_Sem_Unit
: Unit_Number_Type
;
961 Parent_Unit_Visible
: Boolean := False;
962 Instance_Parent_Unit
: Entity_Id
:= Empty
;
963 Switches
: Config_Switches_Type
;
966 package Instance_Envs
is new Table
.Table
(
967 Table_Component_Type
=> Instance_Env
,
968 Table_Index_Type
=> Int
,
969 Table_Low_Bound
=> 0,
971 Table_Increment
=> 100,
972 Table_Name
=> "Instance_Envs");
974 procedure Restore_Private_Views
975 (Pack_Id
: Entity_Id
;
976 Is_Package
: Boolean := True);
977 -- Restore the private views of external types, and unmark the generic
978 -- renamings of actuals, so that they become compatible subtypes again.
979 -- For subprograms, Pack_Id is the package constructed to hold the
982 procedure Switch_View
(T
: Entity_Id
);
983 -- Switch the partial and full views of a type and its private
984 -- dependents (i.e. its subtypes and derived types).
986 ------------------------------------
987 -- Structures for Error Reporting --
988 ------------------------------------
990 Instantiation_Node
: Node_Id
;
991 -- Used by subprograms that validate instantiation of formal parameters
992 -- where there might be no actual on which to place the error message.
993 -- Also used to locate the instantiation node for generic subunits.
995 Instantiation_Error
: exception;
996 -- When there is a semantic error in the generic parameter matching,
997 -- there is no point in continuing the instantiation, because the
998 -- number of cascaded errors is unpredictable. This exception aborts
999 -- the instantiation process altogether.
1001 S_Adjustment
: Sloc_Adjustment
;
1002 -- Offset created for each node in an instantiation, in order to keep
1003 -- track of the source position of the instantiation in each of its nodes.
1004 -- A subsequent semantic error or warning on a construct of the instance
1005 -- points to both places: the original generic node, and the point of
1006 -- instantiation. See Sinput and Sinput.L for additional details.
1008 ------------------------------------------------------------
1009 -- Data structure for keeping track when inside a Generic --
1010 ------------------------------------------------------------
1012 -- The following table is used to save values of the Inside_A_Generic
1013 -- flag (see spec of Sem) when they are saved by Start_Generic.
1015 package Generic_Flags
is new Table
.Table
(
1016 Table_Component_Type
=> Boolean,
1017 Table_Index_Type
=> Int
,
1018 Table_Low_Bound
=> 0,
1019 Table_Initial
=> 32,
1020 Table_Increment
=> 200,
1021 Table_Name
=> "Generic_Flags");
1023 ---------------------------
1024 -- Abandon_Instantiation --
1025 ---------------------------
1027 procedure Abandon_Instantiation
(N
: Node_Id
) is
1029 Error_Msg_N
("\instantiation abandoned!", N
);
1030 raise Instantiation_Error
;
1031 end Abandon_Instantiation
;
1033 --------------------------------
1034 -- Add_Pending_Instantiation --
1035 --------------------------------
1037 procedure Add_Pending_Instantiation
(Inst
: Node_Id
; Act_Decl
: Node_Id
) is
1040 -- Add to the instantiation node and the corresponding unit declaration
1041 -- the current values of global flags to be used when analyzing the
1044 Pending_Instantiations
.Append
1045 ((Inst_Node
=> Inst
,
1046 Act_Decl
=> Act_Decl
,
1047 Expander_Status
=> Expander_Active
,
1048 Current_Sem_Unit
=> Current_Sem_Unit
,
1049 Scope_Suppress
=> Scope_Suppress
,
1050 Local_Suppress_Stack_Top
=> Local_Suppress_Stack_Top
,
1051 Version
=> Ada_Version
,
1052 Version_Pragma
=> Ada_Version_Pragma
,
1053 Warnings
=> Save_Warnings
,
1054 SPARK_Mode
=> SPARK_Mode
,
1055 SPARK_Mode_Pragma
=> SPARK_Mode_Pragma
));
1056 end Add_Pending_Instantiation
;
1058 ----------------------------------
1059 -- Adjust_Inherited_Pragma_Sloc --
1060 ----------------------------------
1062 procedure Adjust_Inherited_Pragma_Sloc
(N
: Node_Id
) is
1064 Adjust_Instantiation_Sloc
(N
, S_Adjustment
);
1065 end Adjust_Inherited_Pragma_Sloc
;
1067 --------------------------
1068 -- Analyze_Associations --
1069 --------------------------
1071 function Analyze_Associations
1074 F_Copy
: List_Id
) return List_Id
1076 Actuals_To_Freeze
: constant Elist_Id
:= New_Elmt_List
;
1077 Assoc_List
: constant List_Id
:= New_List
;
1078 Default_Actuals
: constant List_Id
:= New_List
;
1079 Gen_Unit
: constant Entity_Id
:=
1080 Defining_Entity
(Parent
(F_Copy
));
1084 Analyzed_Formal
: Node_Id
;
1085 First_Named
: Node_Id
:= Empty
;
1089 Saved_Formal
: Node_Id
;
1091 Default_Formals
: constant List_Id
:= New_List
;
1092 -- If an Others_Choice is present, some of the formals may be defaulted.
1093 -- To simplify the treatment of visibility in an instance, we introduce
1094 -- individual defaults for each such formal. These defaults are
1095 -- appended to the list of associations and replace the Others_Choice.
1097 Found_Assoc
: Node_Id
;
1098 -- Association for the current formal being match. Empty if there are
1099 -- no remaining actuals, or if there is no named association with the
1100 -- name of the formal.
1102 Is_Named_Assoc
: Boolean;
1103 Num_Matched
: Nat
:= 0;
1104 Num_Actuals
: Nat
:= 0;
1106 Others_Present
: Boolean := False;
1107 Others_Choice
: Node_Id
:= Empty
;
1108 -- In Ada 2005, indicates partial parameterization of a formal
1109 -- package. As usual an other association must be last in the list.
1111 procedure Check_Fixed_Point_Actual
(Actual
: Node_Id
);
1112 -- Warn if an actual fixed-point type has user-defined arithmetic
1113 -- operations, but there is no corresponding formal in the generic,
1114 -- in which case the predefined operations will be used. This merits
1115 -- a warning because of the special semantics of fixed point ops.
1117 procedure Check_Overloaded_Formal_Subprogram
(Formal
: Entity_Id
);
1118 -- Apply RM 12.3(9): if a formal subprogram is overloaded, the instance
1119 -- cannot have a named association for it. AI05-0025 extends this rule
1120 -- to formals of formal packages by AI05-0025, and it also applies to
1121 -- box-initialized formals.
1123 function Has_Fully_Defined_Profile
(Subp
: Entity_Id
) return Boolean;
1124 -- Determine whether the parameter types and the return type of Subp
1125 -- are fully defined at the point of instantiation.
1127 function Matching_Actual
1129 A_F
: Entity_Id
) return Node_Id
;
1130 -- Find actual that corresponds to a given a formal parameter. If the
1131 -- actuals are positional, return the next one, if any. If the actuals
1132 -- are named, scan the parameter associations to find the right one.
1133 -- A_F is the corresponding entity in the analyzed generic, which is
1134 -- placed on the selector name for ASIS use.
1136 -- In Ada 2005, a named association may be given with a box, in which
1137 -- case Matching_Actual sets Found_Assoc to the generic association,
1138 -- but return Empty for the actual itself. In this case the code below
1139 -- creates a corresponding declaration for the formal.
1141 function Partial_Parameterization
return Boolean;
1142 -- Ada 2005: if no match is found for a given formal, check if the
1143 -- association for it includes a box, or whether the associations
1144 -- include an Others clause.
1146 procedure Process_Default
(F
: Entity_Id
);
1147 -- Add a copy of the declaration of generic formal F to the list of
1148 -- associations, and add an explicit box association for F if there
1149 -- is none yet, and the default comes from an Others_Choice.
1151 function Renames_Standard_Subprogram
(Subp
: Entity_Id
) return Boolean;
1152 -- Determine whether Subp renames one of the subprograms defined in the
1153 -- generated package Standard.
1155 procedure Set_Analyzed_Formal
;
1156 -- Find the node in the generic copy that corresponds to a given formal.
1157 -- The semantic information on this node is used to perform legality
1158 -- checks on the actuals. Because semantic analysis can introduce some
1159 -- anonymous entities or modify the declaration node itself, the
1160 -- correspondence between the two lists is not one-one. In addition to
1161 -- anonymous types, the presence a formal equality will introduce an
1162 -- implicit declaration for the corresponding inequality.
1164 ----------------------------------------
1165 -- Check_Overloaded_Formal_Subprogram --
1166 ----------------------------------------
1168 procedure Check_Overloaded_Formal_Subprogram
(Formal
: Entity_Id
) is
1169 Temp_Formal
: Entity_Id
;
1172 Temp_Formal
:= First
(Formals
);
1173 while Present
(Temp_Formal
) loop
1174 if Nkind
(Temp_Formal
) in N_Formal_Subprogram_Declaration
1175 and then Temp_Formal
/= Formal
1177 Chars
(Defining_Unit_Name
(Specification
(Formal
))) =
1178 Chars
(Defining_Unit_Name
(Specification
(Temp_Formal
)))
1180 if Present
(Found_Assoc
) then
1182 ("named association not allowed for overloaded formal",
1187 ("named association not allowed for overloaded formal",
1191 Abandon_Instantiation
(Instantiation_Node
);
1196 end Check_Overloaded_Formal_Subprogram
;
1198 -------------------------------
1199 -- Check_Fixed_Point_Actual --
1200 -------------------------------
1202 procedure Check_Fixed_Point_Actual
(Actual
: Node_Id
) is
1203 Typ
: constant Entity_Id
:= Entity
(Actual
);
1204 Prims
: constant Elist_Id
:= Collect_Primitive_Operations
(Typ
);
1210 -- Locate primitive operations of the type that are arithmetic
1213 Elem
:= First_Elmt
(Prims
);
1214 while Present
(Elem
) loop
1215 if Nkind
(Node
(Elem
)) = N_Defining_Operator_Symbol
then
1217 -- Check whether the generic unit has a formal subprogram of
1218 -- the same name. This does not check types but is good enough
1219 -- to justify a warning.
1221 Formal
:= First_Non_Pragma
(Formals
);
1222 Op
:= Alias
(Node
(Elem
));
1224 while Present
(Formal
) loop
1225 if Nkind
(Formal
) = N_Formal_Concrete_Subprogram_Declaration
1226 and then Chars
(Defining_Entity
(Formal
)) =
1231 elsif Nkind
(Formal
) = N_Formal_Package_Declaration
then
1237 -- Locate corresponding actual, and check whether it
1238 -- includes a fixed-point type.
1240 Assoc
:= First
(Assoc_List
);
1241 while Present
(Assoc
) loop
1243 Nkind
(Assoc
) = N_Package_Renaming_Declaration
1244 and then Chars
(Defining_Unit_Name
(Assoc
)) =
1245 Chars
(Defining_Identifier
(Formal
));
1250 if Present
(Assoc
) then
1252 -- If formal package declares a fixed-point type,
1253 -- and the user-defined operator is derived from
1254 -- a generic instance package, the fixed-point type
1255 -- does not use the corresponding predefined op.
1257 Ent
:= First_Entity
(Entity
(Name
(Assoc
)));
1258 while Present
(Ent
) loop
1259 if Is_Fixed_Point_Type
(Ent
)
1260 and then Present
(Op
)
1261 and then Is_Generic_Instance
(Scope
(Op
))
1276 Error_Msg_Sloc
:= Sloc
(Node
(Elem
));
1278 ("?instance does not use primitive operation&#",
1279 Actual
, Node
(Elem
));
1285 end Check_Fixed_Point_Actual
;
1287 -------------------------------
1288 -- Has_Fully_Defined_Profile --
1289 -------------------------------
1291 function Has_Fully_Defined_Profile
(Subp
: Entity_Id
) return Boolean is
1292 function Is_Fully_Defined_Type
(Typ
: Entity_Id
) return Boolean;
1293 -- Determine whethet type Typ is fully defined
1295 ---------------------------
1296 -- Is_Fully_Defined_Type --
1297 ---------------------------
1299 function Is_Fully_Defined_Type
(Typ
: Entity_Id
) return Boolean is
1301 -- A private type without a full view is not fully defined
1303 if Is_Private_Type
(Typ
)
1304 and then No
(Full_View
(Typ
))
1308 -- An incomplete type is never fully defined
1310 elsif Is_Incomplete_Type
(Typ
) then
1313 -- All other types are fully defined
1318 end Is_Fully_Defined_Type
;
1320 -- Local declarations
1324 -- Start of processing for Has_Fully_Defined_Profile
1327 -- Check the parameters
1329 Param
:= First_Formal
(Subp
);
1330 while Present
(Param
) loop
1331 if not Is_Fully_Defined_Type
(Etype
(Param
)) then
1335 Next_Formal
(Param
);
1338 -- Check the return type
1340 return Is_Fully_Defined_Type
(Etype
(Subp
));
1341 end Has_Fully_Defined_Profile
;
1343 ---------------------
1344 -- Matching_Actual --
1345 ---------------------
1347 function Matching_Actual
1349 A_F
: Entity_Id
) return Node_Id
1355 Is_Named_Assoc
:= False;
1357 -- End of list of purely positional parameters
1359 if No
(Actual
) or else Nkind
(Actual
) = N_Others_Choice
then
1360 Found_Assoc
:= Empty
;
1363 -- Case of positional parameter corresponding to current formal
1365 elsif No
(Selector_Name
(Actual
)) then
1366 Found_Assoc
:= Actual
;
1367 Act
:= Explicit_Generic_Actual_Parameter
(Actual
);
1368 Num_Matched
:= Num_Matched
+ 1;
1371 -- Otherwise scan list of named actuals to find the one with the
1372 -- desired name. All remaining actuals have explicit names.
1375 Is_Named_Assoc
:= True;
1376 Found_Assoc
:= Empty
;
1380 while Present
(Actual
) loop
1381 if Nkind
(Actual
) = N_Others_Choice
then
1382 Found_Assoc
:= Empty
;
1385 elsif Chars
(Selector_Name
(Actual
)) = Chars
(F
) then
1386 Set_Entity
(Selector_Name
(Actual
), A_F
);
1387 Set_Etype
(Selector_Name
(Actual
), Etype
(A_F
));
1388 Generate_Reference
(A_F
, Selector_Name
(Actual
));
1390 Found_Assoc
:= Actual
;
1391 Act
:= Explicit_Generic_Actual_Parameter
(Actual
);
1392 Num_Matched
:= Num_Matched
+ 1;
1400 -- Reset for subsequent searches. In most cases the named
1401 -- associations are in order. If they are not, we reorder them
1402 -- to avoid scanning twice the same actual. This is not just a
1403 -- question of efficiency: there may be multiple defaults with
1404 -- boxes that have the same name. In a nested instantiation we
1405 -- insert actuals for those defaults, and cannot rely on their
1406 -- names to disambiguate them.
1408 if Actual
= First_Named
then
1411 elsif Present
(Actual
) then
1412 Insert_Before
(First_Named
, Remove_Next
(Prev
));
1415 Actual
:= First_Named
;
1418 if Is_Entity_Name
(Act
) and then Present
(Entity
(Act
)) then
1419 Set_Used_As_Generic_Actual
(Entity
(Act
));
1423 end Matching_Actual
;
1425 ------------------------------
1426 -- Partial_Parameterization --
1427 ------------------------------
1429 function Partial_Parameterization
return Boolean is
1431 return Others_Present
1432 or else (Present
(Found_Assoc
) and then Box_Present
(Found_Assoc
));
1433 end Partial_Parameterization
;
1435 ---------------------
1436 -- Process_Default --
1437 ---------------------
1439 procedure Process_Default
(F
: Entity_Id
) is
1440 Loc
: constant Source_Ptr
:= Sloc
(I_Node
);
1441 F_Id
: constant Entity_Id
:= Defining_Entity
(F
);
1447 -- Append copy of formal declaration to associations, and create new
1448 -- defining identifier for it.
1450 Decl
:= New_Copy_Tree
(F
);
1451 Id
:= Make_Defining_Identifier
(Sloc
(F_Id
), Chars
(F_Id
));
1453 if Nkind
(F
) in N_Formal_Subprogram_Declaration
then
1454 Set_Defining_Unit_Name
(Specification
(Decl
), Id
);
1457 Set_Defining_Identifier
(Decl
, Id
);
1460 Append
(Decl
, Assoc_List
);
1462 if No
(Found_Assoc
) then
1464 Make_Generic_Association
(Loc
,
1466 New_Occurrence_Of
(Id
, Loc
),
1467 Explicit_Generic_Actual_Parameter
=> Empty
);
1468 Set_Box_Present
(Default
);
1469 Append
(Default
, Default_Formals
);
1471 end Process_Default
;
1473 ---------------------------------
1474 -- Renames_Standard_Subprogram --
1475 ---------------------------------
1477 function Renames_Standard_Subprogram
(Subp
: Entity_Id
) return Boolean is
1482 while Present
(Id
) loop
1483 if Scope
(Id
) = Standard_Standard
then
1491 end Renames_Standard_Subprogram
;
1493 -------------------------
1494 -- Set_Analyzed_Formal --
1495 -------------------------
1497 procedure Set_Analyzed_Formal
is
1501 while Present
(Analyzed_Formal
) loop
1502 Kind
:= Nkind
(Analyzed_Formal
);
1504 case Nkind
(Formal
) is
1505 when N_Formal_Subprogram_Declaration
=>
1506 exit when Kind
in N_Formal_Subprogram_Declaration
1509 (Defining_Unit_Name
(Specification
(Formal
))) =
1511 (Defining_Unit_Name
(Specification
(Analyzed_Formal
)));
1513 when N_Formal_Package_Declaration
=>
1514 exit when Nkind_In
(Kind
, N_Formal_Package_Declaration
,
1515 N_Generic_Package_Declaration
,
1516 N_Package_Declaration
);
1518 when N_Use_Package_Clause
1525 -- Skip freeze nodes, and nodes inserted to replace
1526 -- unrecognized pragmas.
1529 Kind
not in N_Formal_Subprogram_Declaration
1530 and then not Nkind_In
(Kind
, N_Subprogram_Declaration
,
1534 and then Chars
(Defining_Identifier
(Formal
)) =
1535 Chars
(Defining_Identifier
(Analyzed_Formal
));
1538 Next
(Analyzed_Formal
);
1540 end Set_Analyzed_Formal
;
1542 -- Start of processing for Analyze_Associations
1545 Actuals
:= Generic_Associations
(I_Node
);
1547 if Present
(Actuals
) then
1549 -- Check for an Others choice, indicating a partial parameterization
1550 -- for a formal package.
1552 Actual
:= First
(Actuals
);
1553 while Present
(Actual
) loop
1554 if Nkind
(Actual
) = N_Others_Choice
then
1555 Others_Present
:= True;
1556 Others_Choice
:= Actual
;
1558 if Present
(Next
(Actual
)) then
1559 Error_Msg_N
("others must be last association", Actual
);
1562 -- This subprogram is used both for formal packages and for
1563 -- instantiations. For the latter, associations must all be
1566 if Nkind
(I_Node
) /= N_Formal_Package_Declaration
1567 and then Comes_From_Source
(I_Node
)
1570 ("others association not allowed in an instance",
1574 -- In any case, nothing to do after the others association
1578 elsif Box_Present
(Actual
)
1579 and then Comes_From_Source
(I_Node
)
1580 and then Nkind
(I_Node
) /= N_Formal_Package_Declaration
1583 ("box association not allowed in an instance", Actual
);
1589 -- If named associations are present, save first named association
1590 -- (it may of course be Empty) to facilitate subsequent name search.
1592 First_Named
:= First
(Actuals
);
1593 while Present
(First_Named
)
1594 and then Nkind
(First_Named
) /= N_Others_Choice
1595 and then No
(Selector_Name
(First_Named
))
1597 Num_Actuals
:= Num_Actuals
+ 1;
1602 Named
:= First_Named
;
1603 while Present
(Named
) loop
1604 if Nkind
(Named
) /= N_Others_Choice
1605 and then No
(Selector_Name
(Named
))
1607 Error_Msg_N
("invalid positional actual after named one", Named
);
1608 Abandon_Instantiation
(Named
);
1611 -- A named association may lack an actual parameter, if it was
1612 -- introduced for a default subprogram that turns out to be local
1613 -- to the outer instantiation. If it has a box association it must
1614 -- correspond to some formal in the generic.
1616 if Nkind
(Named
) /= N_Others_Choice
1617 and then (Present
(Explicit_Generic_Actual_Parameter
(Named
))
1618 or else Box_Present
(Named
))
1620 Num_Actuals
:= Num_Actuals
+ 1;
1626 if Present
(Formals
) then
1627 Formal
:= First_Non_Pragma
(Formals
);
1628 Analyzed_Formal
:= First_Non_Pragma
(F_Copy
);
1630 if Present
(Actuals
) then
1631 Actual
:= First
(Actuals
);
1633 -- All formals should have default values
1639 while Present
(Formal
) loop
1640 Set_Analyzed_Formal
;
1641 Saved_Formal
:= Next_Non_Pragma
(Formal
);
1643 case Nkind
(Formal
) is
1644 when N_Formal_Object_Declaration
=>
1647 (Defining_Identifier
(Formal
),
1648 Defining_Identifier
(Analyzed_Formal
));
1650 if No
(Match
) and then Partial_Parameterization
then
1651 Process_Default
(Formal
);
1655 (Instantiate_Object
(Formal
, Match
, Analyzed_Formal
),
1658 -- For a defaulted in_parameter, create an entry in the
1659 -- the list of defaulted actuals, for GNATProve use. Do
1660 -- not included these defaults for an instance nested
1661 -- within a generic, because the defaults are also used
1662 -- in the analysis of the enclosing generic, and only
1663 -- defaulted subprograms are relevant there.
1665 if No
(Match
) and then not Inside_A_Generic
then
1666 Append_To
(Default_Actuals
,
1667 Make_Generic_Association
(Sloc
(I_Node
),
1670 (Defining_Identifier
(Formal
), Sloc
(I_Node
)),
1671 Explicit_Generic_Actual_Parameter
=>
1672 New_Copy_Tree
(Default_Expression
(Formal
))));
1676 -- If the object is a call to an expression function, this
1677 -- is a freezing point for it.
1679 if Is_Entity_Name
(Match
)
1680 and then Present
(Entity
(Match
))
1682 (Original_Node
(Unit_Declaration_Node
(Entity
(Match
))))
1683 = N_Expression_Function
1685 Append_Elmt
(Entity
(Match
), Actuals_To_Freeze
);
1688 when N_Formal_Type_Declaration
=>
1691 (Defining_Identifier
(Formal
),
1692 Defining_Identifier
(Analyzed_Formal
));
1695 if Partial_Parameterization
then
1696 Process_Default
(Formal
);
1699 Error_Msg_Sloc
:= Sloc
(Gen_Unit
);
1702 Instantiation_Node
, Defining_Identifier
(Formal
));
1704 ("\in instantiation of & declared#",
1705 Instantiation_Node
, Gen_Unit
);
1706 Abandon_Instantiation
(Instantiation_Node
);
1713 (Formal
, Match
, Analyzed_Formal
, Assoc_List
),
1716 if Is_Fixed_Point_Type
(Entity
(Match
)) then
1717 Check_Fixed_Point_Actual
(Match
);
1720 -- An instantiation is a freeze point for the actuals,
1721 -- unless this is a rewritten formal package, or the
1722 -- formal is an Ada 2012 formal incomplete type.
1724 if Nkind
(I_Node
) = N_Formal_Package_Declaration
1726 (Ada_Version
>= Ada_2012
1728 Ekind
(Defining_Identifier
(Analyzed_Formal
)) =
1734 Append_Elmt
(Entity
(Match
), Actuals_To_Freeze
);
1738 -- A remote access-to-class-wide type is not a legal actual
1739 -- for a generic formal of an access type (E.2.2(17/2)).
1740 -- In GNAT an exception to this rule is introduced when
1741 -- the formal is marked as remote using implementation
1742 -- defined aspect/pragma Remote_Access_Type. In that case
1743 -- the actual must be remote as well.
1745 -- If the current instantiation is the construction of a
1746 -- local copy for a formal package the actuals may be
1747 -- defaulted, and there is no matching actual to check.
1749 if Nkind
(Analyzed_Formal
) = N_Formal_Type_Declaration
1751 Nkind
(Formal_Type_Definition
(Analyzed_Formal
)) =
1752 N_Access_To_Object_Definition
1753 and then Present
(Match
)
1756 Formal_Ent
: constant Entity_Id
:=
1757 Defining_Identifier
(Analyzed_Formal
);
1759 if Is_Remote_Access_To_Class_Wide_Type
(Entity
(Match
))
1760 = Is_Remote_Types
(Formal_Ent
)
1762 -- Remoteness of formal and actual match
1766 elsif Is_Remote_Types
(Formal_Ent
) then
1768 -- Remote formal, non-remote actual
1771 ("actual for& must be remote", Match
, Formal_Ent
);
1774 -- Non-remote formal, remote actual
1777 ("actual for& may not be remote",
1783 when N_Formal_Subprogram_Declaration
=>
1786 (Defining_Unit_Name
(Specification
(Formal
)),
1787 Defining_Unit_Name
(Specification
(Analyzed_Formal
)));
1789 -- If the formal subprogram has the same name as another
1790 -- formal subprogram of the generic, then a named
1791 -- association is illegal (12.3(9)). Exclude named
1792 -- associations that are generated for a nested instance.
1795 and then Is_Named_Assoc
1796 and then Comes_From_Source
(Found_Assoc
)
1798 Check_Overloaded_Formal_Subprogram
(Formal
);
1801 -- If there is no corresponding actual, this may be case
1802 -- of partial parameterization, or else the formal has a
1803 -- default or a box.
1805 if No
(Match
) and then Partial_Parameterization
then
1806 Process_Default
(Formal
);
1808 if Nkind
(I_Node
) = N_Formal_Package_Declaration
then
1809 Check_Overloaded_Formal_Subprogram
(Formal
);
1813 Append_To
(Assoc_List
,
1814 Instantiate_Formal_Subprogram
1815 (Formal
, Match
, Analyzed_Formal
));
1817 -- An instantiation is a freeze point for the actuals,
1818 -- unless this is a rewritten formal package.
1820 if Nkind
(I_Node
) /= N_Formal_Package_Declaration
1821 and then Nkind
(Match
) = N_Identifier
1822 and then Is_Subprogram
(Entity
(Match
))
1824 -- The actual subprogram may rename a routine defined
1825 -- in Standard. Avoid freezing such renamings because
1826 -- subprograms coming from Standard cannot be frozen.
1829 not Renames_Standard_Subprogram
(Entity
(Match
))
1831 -- If the actual subprogram comes from a different
1832 -- unit, it is already frozen, either by a body in
1833 -- that unit or by the end of the declarative part
1834 -- of the unit. This check avoids the freezing of
1835 -- subprograms defined in Standard which are used
1836 -- as generic actuals.
1838 and then In_Same_Code_Unit
(Entity
(Match
), I_Node
)
1839 and then Has_Fully_Defined_Profile
(Entity
(Match
))
1841 -- Mark the subprogram as having a delayed freeze
1842 -- since this may be an out-of-order action.
1844 Set_Has_Delayed_Freeze
(Entity
(Match
));
1845 Append_Elmt
(Entity
(Match
), Actuals_To_Freeze
);
1849 -- If this is a nested generic, preserve default for later
1850 -- instantiations. We do this as well for GNATProve use,
1851 -- so that the list of generic associations is complete.
1853 if No
(Match
) and then Box_Present
(Formal
) then
1855 Subp
: constant Entity_Id
:=
1857 (Specification
(Last
(Assoc_List
)));
1860 Append_To
(Default_Actuals
,
1861 Make_Generic_Association
(Sloc
(I_Node
),
1863 New_Occurrence_Of
(Subp
, Sloc
(I_Node
)),
1864 Explicit_Generic_Actual_Parameter
=>
1865 New_Occurrence_Of
(Subp
, Sloc
(I_Node
))));
1869 when N_Formal_Package_Declaration
=>
1872 (Defining_Identifier
(Formal
),
1873 Defining_Identifier
(Original_Node
(Analyzed_Formal
)));
1876 if Partial_Parameterization
then
1877 Process_Default
(Formal
);
1880 Error_Msg_Sloc
:= Sloc
(Gen_Unit
);
1883 Instantiation_Node
, Defining_Identifier
(Formal
));
1885 ("\in instantiation of & declared#",
1886 Instantiation_Node
, Gen_Unit
);
1888 Abandon_Instantiation
(Instantiation_Node
);
1894 (Instantiate_Formal_Package
1895 (Formal
, Match
, Analyzed_Formal
),
1898 -- Determine whether the actual package needs an explicit
1899 -- freeze node. This is only the case if the actual is
1900 -- declared in the same unit and has a body. Normally
1901 -- packages do not have explicit freeze nodes, and gigi
1902 -- only uses them to elaborate entities in a package
1905 Explicit_Freeze_Check
: declare
1906 Actual
: constant Entity_Id
:= Entity
(Match
);
1908 Needs_Freezing
: Boolean;
1911 procedure Check_Generic_Parent
;
1912 -- The actual may be an instantiation of a unit
1913 -- declared in a previous instantiation. If that
1914 -- one is also in the current compilation, it must
1915 -- itself be frozen before the actual.
1916 -- Should this itself be recursive ???
1918 --------------------------
1919 -- Check_Generic_Parent --
1920 --------------------------
1922 procedure Check_Generic_Parent
is
1926 if Nkind
(Parent
(Actual
)) =
1927 N_Package_Specification
1929 Par
:= Scope
(Generic_Parent
(Parent
(Actual
)));
1931 if Is_Generic_Instance
(Par
)
1932 and then Scope
(Par
) = Current_Scope
1934 (No
(Freeze_Node
(Par
))
1936 not Is_List_Member
(Freeze_Node
(Par
)))
1938 Set_Has_Delayed_Freeze
(Par
);
1939 Append_Elmt
(Par
, Actuals_To_Freeze
);
1942 end Check_Generic_Parent
;
1944 -- Start of processing for Explicit_Freeze_Check
1947 if not Expander_Active
1948 or else not Has_Completion
(Actual
)
1949 or else not In_Same_Source_Unit
(I_Node
, Actual
)
1950 or else Is_Frozen
(Actual
)
1952 (Present
(Renamed_Entity
(Actual
))
1954 not In_Same_Source_Unit
1955 (I_Node
, (Renamed_Entity
(Actual
))))
1960 -- Finally we want to exclude such freeze nodes
1961 -- from statement sequences, which freeze
1962 -- everything before them.
1963 -- Is this strictly necessary ???
1965 Needs_Freezing
:= True;
1968 while Present
(S
) loop
1969 if Ekind_In
(S
, E_Block
,
1974 Needs_Freezing
:= False;
1981 if Needs_Freezing
then
1982 Check_Generic_Parent
;
1984 -- If the actual is a renaming of a proper
1985 -- instance of the formal package, indicate
1986 -- that it is the instance that must be frozen.
1988 if Nkind
(Parent
(Actual
)) =
1989 N_Package_Renaming_Declaration
1991 Set_Has_Delayed_Freeze
1992 (Renamed_Entity
(Actual
));
1994 (Renamed_Entity
(Actual
), Actuals_To_Freeze
);
1996 Set_Has_Delayed_Freeze
(Actual
);
1997 Append_Elmt
(Actual
, Actuals_To_Freeze
);
2001 end Explicit_Freeze_Check
;
2004 -- For use type and use package appearing in the generic part,
2005 -- we have already copied them, so we can just move them where
2006 -- they belong (we mustn't recopy them since this would mess up
2007 -- the Sloc values).
2009 when N_Use_Package_Clause
2012 if Nkind
(Original_Node
(I_Node
)) =
2013 N_Formal_Package_Declaration
2015 Append
(New_Copy_Tree
(Formal
), Assoc_List
);
2018 Append
(Formal
, Assoc_List
);
2022 raise Program_Error
;
2025 Formal
:= Saved_Formal
;
2026 Next_Non_Pragma
(Analyzed_Formal
);
2029 if Num_Actuals
> Num_Matched
then
2030 Error_Msg_Sloc
:= Sloc
(Gen_Unit
);
2032 if Present
(Selector_Name
(Actual
)) then
2034 ("unmatched actual &", Actual
, Selector_Name
(Actual
));
2036 ("\in instantiation of & declared#", Actual
, Gen_Unit
);
2039 ("unmatched actual in instantiation of & declared#",
2044 elsif Present
(Actuals
) then
2046 ("too many actuals in generic instantiation", Instantiation_Node
);
2049 -- An instantiation freezes all generic actuals. The only exceptions
2050 -- to this are incomplete types and subprograms which are not fully
2051 -- defined at the point of instantiation.
2054 Elmt
: Elmt_Id
:= First_Elmt
(Actuals_To_Freeze
);
2056 while Present
(Elmt
) loop
2057 Freeze_Before
(I_Node
, Node
(Elmt
));
2062 -- If there are default subprograms, normalize the tree by adding
2063 -- explicit associations for them. This is required if the instance
2064 -- appears within a generic.
2066 if not Is_Empty_List
(Default_Actuals
) then
2071 Default
:= First
(Default_Actuals
);
2072 while Present
(Default
) loop
2073 Mark_Rewrite_Insertion
(Default
);
2077 if No
(Actuals
) then
2078 Set_Generic_Associations
(I_Node
, Default_Actuals
);
2080 Append_List_To
(Actuals
, Default_Actuals
);
2085 -- If this is a formal package, normalize the parameter list by adding
2086 -- explicit box associations for the formals that are covered by an
2089 if not Is_Empty_List
(Default_Formals
) then
2090 Append_List
(Default_Formals
, Formals
);
2094 end Analyze_Associations
;
2096 -------------------------------
2097 -- Analyze_Formal_Array_Type --
2098 -------------------------------
2100 procedure Analyze_Formal_Array_Type
2101 (T
: in out Entity_Id
;
2107 -- Treated like a non-generic array declaration, with additional
2112 if Nkind
(Def
) = N_Constrained_Array_Definition
then
2113 DSS
:= First
(Discrete_Subtype_Definitions
(Def
));
2114 while Present
(DSS
) loop
2115 if Nkind_In
(DSS
, N_Subtype_Indication
,
2117 N_Attribute_Reference
)
2119 Error_Msg_N
("only a subtype mark is allowed in a formal", DSS
);
2126 Array_Type_Declaration
(T
, Def
);
2127 Set_Is_Generic_Type
(Base_Type
(T
));
2129 if Ekind
(Component_Type
(T
)) = E_Incomplete_Type
2130 and then No
(Full_View
(Component_Type
(T
)))
2132 Error_Msg_N
("premature usage of incomplete type", Def
);
2134 -- Check that range constraint is not allowed on the component type
2135 -- of a generic formal array type (AARM 12.5.3(3))
2137 elsif Is_Internal
(Component_Type
(T
))
2138 and then Present
(Subtype_Indication
(Component_Definition
(Def
)))
2139 and then Nkind
(Original_Node
2140 (Subtype_Indication
(Component_Definition
(Def
)))) =
2141 N_Subtype_Indication
2144 ("in a formal, a subtype indication can only be "
2145 & "a subtype mark (RM 12.5.3(3))",
2146 Subtype_Indication
(Component_Definition
(Def
)));
2149 end Analyze_Formal_Array_Type
;
2151 ---------------------------------------------
2152 -- Analyze_Formal_Decimal_Fixed_Point_Type --
2153 ---------------------------------------------
2155 -- As for other generic types, we create a valid type representation with
2156 -- legal but arbitrary attributes, whose values are never considered
2157 -- static. For all scalar types we introduce an anonymous base type, with
2158 -- the same attributes. We choose the corresponding integer type to be
2159 -- Standard_Integer.
2160 -- Here and in other similar routines, the Sloc of the generated internal
2161 -- type must be the same as the sloc of the defining identifier of the
2162 -- formal type declaration, to provide proper source navigation.
2164 procedure Analyze_Formal_Decimal_Fixed_Point_Type
2168 Loc
: constant Source_Ptr
:= Sloc
(Def
);
2170 Base
: constant Entity_Id
:=
2172 (E_Decimal_Fixed_Point_Type
,
2174 Sloc
(Defining_Identifier
(Parent
(Def
))), 'G');
2176 Int_Base
: constant Entity_Id
:= Standard_Integer
;
2177 Delta_Val
: constant Ureal
:= Ureal_1
;
2178 Digs_Val
: constant Uint
:= Uint_6
;
2180 function Make_Dummy_Bound
return Node_Id
;
2181 -- Return a properly typed universal real literal to use as a bound
2183 ----------------------
2184 -- Make_Dummy_Bound --
2185 ----------------------
2187 function Make_Dummy_Bound
return Node_Id
is
2188 Bound
: constant Node_Id
:= Make_Real_Literal
(Loc
, Ureal_1
);
2190 Set_Etype
(Bound
, Universal_Real
);
2192 end Make_Dummy_Bound
;
2194 -- Start of processing for Analyze_Formal_Decimal_Fixed_Point_Type
2199 Set_Etype
(Base
, Base
);
2200 Set_Size_Info
(Base
, Int_Base
);
2201 Set_RM_Size
(Base
, RM_Size
(Int_Base
));
2202 Set_First_Rep_Item
(Base
, First_Rep_Item
(Int_Base
));
2203 Set_Digits_Value
(Base
, Digs_Val
);
2204 Set_Delta_Value
(Base
, Delta_Val
);
2205 Set_Small_Value
(Base
, Delta_Val
);
2206 Set_Scalar_Range
(Base
,
2208 Low_Bound
=> Make_Dummy_Bound
,
2209 High_Bound
=> Make_Dummy_Bound
));
2211 Set_Is_Generic_Type
(Base
);
2212 Set_Parent
(Base
, Parent
(Def
));
2214 Set_Ekind
(T
, E_Decimal_Fixed_Point_Subtype
);
2215 Set_Etype
(T
, Base
);
2216 Set_Size_Info
(T
, Int_Base
);
2217 Set_RM_Size
(T
, RM_Size
(Int_Base
));
2218 Set_First_Rep_Item
(T
, First_Rep_Item
(Int_Base
));
2219 Set_Digits_Value
(T
, Digs_Val
);
2220 Set_Delta_Value
(T
, Delta_Val
);
2221 Set_Small_Value
(T
, Delta_Val
);
2222 Set_Scalar_Range
(T
, Scalar_Range
(Base
));
2223 Set_Is_Constrained
(T
);
2225 Check_Restriction
(No_Fixed_Point
, Def
);
2226 end Analyze_Formal_Decimal_Fixed_Point_Type
;
2228 -------------------------------------------
2229 -- Analyze_Formal_Derived_Interface_Type --
2230 -------------------------------------------
2232 procedure Analyze_Formal_Derived_Interface_Type
2237 Loc
: constant Source_Ptr
:= Sloc
(Def
);
2240 -- Rewrite as a type declaration of a derived type. This ensures that
2241 -- the interface list and primitive operations are properly captured.
2244 Make_Full_Type_Declaration
(Loc
,
2245 Defining_Identifier
=> T
,
2246 Type_Definition
=> Def
));
2248 Set_Is_Generic_Type
(T
);
2249 end Analyze_Formal_Derived_Interface_Type
;
2251 ---------------------------------
2252 -- Analyze_Formal_Derived_Type --
2253 ---------------------------------
2255 procedure Analyze_Formal_Derived_Type
2260 Loc
: constant Source_Ptr
:= Sloc
(Def
);
2261 Unk_Disc
: constant Boolean := Unknown_Discriminants_Present
(N
);
2265 Set_Is_Generic_Type
(T
);
2267 if Private_Present
(Def
) then
2269 Make_Private_Extension_Declaration
(Loc
,
2270 Defining_Identifier
=> T
,
2271 Discriminant_Specifications
=> Discriminant_Specifications
(N
),
2272 Unknown_Discriminants_Present
=> Unk_Disc
,
2273 Subtype_Indication
=> Subtype_Mark
(Def
),
2274 Interface_List
=> Interface_List
(Def
));
2276 Set_Abstract_Present
(New_N
, Abstract_Present
(Def
));
2277 Set_Limited_Present
(New_N
, Limited_Present
(Def
));
2278 Set_Synchronized_Present
(New_N
, Synchronized_Present
(Def
));
2282 Make_Full_Type_Declaration
(Loc
,
2283 Defining_Identifier
=> T
,
2284 Discriminant_Specifications
=>
2285 Discriminant_Specifications
(Parent
(T
)),
2287 Make_Derived_Type_Definition
(Loc
,
2288 Subtype_Indication
=> Subtype_Mark
(Def
)));
2290 Set_Abstract_Present
2291 (Type_Definition
(New_N
), Abstract_Present
(Def
));
2293 (Type_Definition
(New_N
), Limited_Present
(Def
));
2300 if not Is_Composite_Type
(T
) then
2302 ("unknown discriminants not allowed for elementary types", N
);
2304 Set_Has_Unknown_Discriminants
(T
);
2305 Set_Is_Constrained
(T
, False);
2309 -- If the parent type has a known size, so does the formal, which makes
2310 -- legal representation clauses that involve the formal.
2312 Set_Size_Known_At_Compile_Time
2313 (T
, Size_Known_At_Compile_Time
(Entity
(Subtype_Mark
(Def
))));
2314 end Analyze_Formal_Derived_Type
;
2316 ----------------------------------
2317 -- Analyze_Formal_Discrete_Type --
2318 ----------------------------------
2320 -- The operations defined for a discrete types are those of an enumeration
2321 -- type. The size is set to an arbitrary value, for use in analyzing the
2324 procedure Analyze_Formal_Discrete_Type
(T
: Entity_Id
; Def
: Node_Id
) is
2325 Loc
: constant Source_Ptr
:= Sloc
(Def
);
2329 Base
: constant Entity_Id
:=
2331 (E_Floating_Point_Type
, Current_Scope
,
2332 Sloc
(Defining_Identifier
(Parent
(Def
))), 'G');
2336 Set_Ekind
(T
, E_Enumeration_Subtype
);
2337 Set_Etype
(T
, Base
);
2340 Set_Is_Generic_Type
(T
);
2341 Set_Is_Constrained
(T
);
2343 -- For semantic analysis, the bounds of the type must be set to some
2344 -- non-static value. The simplest is to create attribute nodes for those
2345 -- bounds, that refer to the type itself. These bounds are never
2346 -- analyzed but serve as place-holders.
2349 Make_Attribute_Reference
(Loc
,
2350 Attribute_Name
=> Name_First
,
2351 Prefix
=> New_Occurrence_Of
(T
, Loc
));
2355 Make_Attribute_Reference
(Loc
,
2356 Attribute_Name
=> Name_Last
,
2357 Prefix
=> New_Occurrence_Of
(T
, Loc
));
2360 Set_Scalar_Range
(T
,
2365 Set_Ekind
(Base
, E_Enumeration_Type
);
2366 Set_Etype
(Base
, Base
);
2367 Init_Size
(Base
, 8);
2368 Init_Alignment
(Base
);
2369 Set_Is_Generic_Type
(Base
);
2370 Set_Scalar_Range
(Base
, Scalar_Range
(T
));
2371 Set_Parent
(Base
, Parent
(Def
));
2372 end Analyze_Formal_Discrete_Type
;
2374 ----------------------------------
2375 -- Analyze_Formal_Floating_Type --
2376 ---------------------------------
2378 procedure Analyze_Formal_Floating_Type
(T
: Entity_Id
; Def
: Node_Id
) is
2379 Base
: constant Entity_Id
:=
2381 (E_Floating_Point_Type
, Current_Scope
,
2382 Sloc
(Defining_Identifier
(Parent
(Def
))), 'G');
2385 -- The various semantic attributes are taken from the predefined type
2386 -- Float, just so that all of them are initialized. Their values are
2387 -- never used because no constant folding or expansion takes place in
2388 -- the generic itself.
2391 Set_Ekind
(T
, E_Floating_Point_Subtype
);
2392 Set_Etype
(T
, Base
);
2393 Set_Size_Info
(T
, (Standard_Float
));
2394 Set_RM_Size
(T
, RM_Size
(Standard_Float
));
2395 Set_Digits_Value
(T
, Digits_Value
(Standard_Float
));
2396 Set_Scalar_Range
(T
, Scalar_Range
(Standard_Float
));
2397 Set_Is_Constrained
(T
);
2399 Set_Is_Generic_Type
(Base
);
2400 Set_Etype
(Base
, Base
);
2401 Set_Size_Info
(Base
, (Standard_Float
));
2402 Set_RM_Size
(Base
, RM_Size
(Standard_Float
));
2403 Set_Digits_Value
(Base
, Digits_Value
(Standard_Float
));
2404 Set_Scalar_Range
(Base
, Scalar_Range
(Standard_Float
));
2405 Set_Parent
(Base
, Parent
(Def
));
2407 Check_Restriction
(No_Floating_Point
, Def
);
2408 end Analyze_Formal_Floating_Type
;
2410 -----------------------------------
2411 -- Analyze_Formal_Interface_Type;--
2412 -----------------------------------
2414 procedure Analyze_Formal_Interface_Type
2419 Loc
: constant Source_Ptr
:= Sloc
(N
);
2424 Make_Full_Type_Declaration
(Loc
,
2425 Defining_Identifier
=> T
,
2426 Type_Definition
=> Def
);
2430 Set_Is_Generic_Type
(T
);
2431 end Analyze_Formal_Interface_Type
;
2433 ---------------------------------
2434 -- Analyze_Formal_Modular_Type --
2435 ---------------------------------
2437 procedure Analyze_Formal_Modular_Type
(T
: Entity_Id
; Def
: Node_Id
) is
2439 -- Apart from their entity kind, generic modular types are treated like
2440 -- signed integer types, and have the same attributes.
2442 Analyze_Formal_Signed_Integer_Type
(T
, Def
);
2443 Set_Ekind
(T
, E_Modular_Integer_Subtype
);
2444 Set_Ekind
(Etype
(T
), E_Modular_Integer_Type
);
2446 end Analyze_Formal_Modular_Type
;
2448 ---------------------------------------
2449 -- Analyze_Formal_Object_Declaration --
2450 ---------------------------------------
2452 procedure Analyze_Formal_Object_Declaration
(N
: Node_Id
) is
2453 E
: constant Node_Id
:= Default_Expression
(N
);
2454 Id
: constant Node_Id
:= Defining_Identifier
(N
);
2461 -- Determine the mode of the formal object
2463 if Out_Present
(N
) then
2464 K
:= E_Generic_In_Out_Parameter
;
2466 if not In_Present
(N
) then
2467 Error_Msg_N
("formal generic objects cannot have mode OUT", N
);
2471 K
:= E_Generic_In_Parameter
;
2474 if Present
(Subtype_Mark
(N
)) then
2475 Find_Type
(Subtype_Mark
(N
));
2476 T
:= Entity
(Subtype_Mark
(N
));
2478 -- Verify that there is no redundant null exclusion
2480 if Null_Exclusion_Present
(N
) then
2481 if not Is_Access_Type
(T
) then
2483 ("null exclusion can only apply to an access type", N
);
2485 elsif Can_Never_Be_Null
(T
) then
2487 ("`NOT NULL` not allowed (& already excludes null)", N
, T
);
2491 -- Ada 2005 (AI-423): Formal object with an access definition
2494 Check_Access_Definition
(N
);
2495 T
:= Access_Definition
2497 N
=> Access_Definition
(N
));
2500 if Ekind
(T
) = E_Incomplete_Type
then
2502 Error_Node
: Node_Id
;
2505 if Present
(Subtype_Mark
(N
)) then
2506 Error_Node
:= Subtype_Mark
(N
);
2508 Check_Access_Definition
(N
);
2509 Error_Node
:= Access_Definition
(N
);
2512 Error_Msg_N
("premature usage of incomplete type", Error_Node
);
2516 if K
= E_Generic_In_Parameter
then
2518 -- Ada 2005 (AI-287): Limited aggregates allowed in generic formals
2520 if Ada_Version
< Ada_2005
and then Is_Limited_Type
(T
) then
2522 ("generic formal of mode IN must not be of limited type", N
);
2523 Explain_Limited_Type
(T
, N
);
2526 if Is_Abstract_Type
(T
) then
2528 ("generic formal of mode IN must not be of abstract type", N
);
2532 Preanalyze_Spec_Expression
(E
, T
);
2534 if Is_Limited_Type
(T
) and then not OK_For_Limited_Init
(T
, E
) then
2536 ("initialization not allowed for limited types", E
);
2537 Explain_Limited_Type
(T
, E
);
2544 -- Case of generic IN OUT parameter
2547 -- If the formal has an unconstrained type, construct its actual
2548 -- subtype, as is done for subprogram formals. In this fashion, all
2549 -- its uses can refer to specific bounds.
2554 if (Is_Array_Type
(T
) and then not Is_Constrained
(T
))
2555 or else (Ekind
(T
) = E_Record_Type
and then Has_Discriminants
(T
))
2558 Non_Freezing_Ref
: constant Node_Id
:=
2559 New_Occurrence_Of
(Id
, Sloc
(Id
));
2563 -- Make sure the actual subtype doesn't generate bogus freezing
2565 Set_Must_Not_Freeze
(Non_Freezing_Ref
);
2566 Decl
:= Build_Actual_Subtype
(T
, Non_Freezing_Ref
);
2567 Insert_Before_And_Analyze
(N
, Decl
);
2568 Set_Actual_Subtype
(Id
, Defining_Identifier
(Decl
));
2571 Set_Actual_Subtype
(Id
, T
);
2576 ("initialization not allowed for `IN OUT` formals", N
);
2580 if Has_Aspects
(N
) then
2581 Analyze_Aspect_Specifications
(N
, Id
);
2583 end Analyze_Formal_Object_Declaration
;
2585 ----------------------------------------------
2586 -- Analyze_Formal_Ordinary_Fixed_Point_Type --
2587 ----------------------------------------------
2589 procedure Analyze_Formal_Ordinary_Fixed_Point_Type
2593 Loc
: constant Source_Ptr
:= Sloc
(Def
);
2594 Base
: constant Entity_Id
:=
2596 (E_Ordinary_Fixed_Point_Type
, Current_Scope
,
2597 Sloc
(Defining_Identifier
(Parent
(Def
))), 'G');
2600 -- The semantic attributes are set for completeness only, their values
2601 -- will never be used, since all properties of the type are non-static.
2604 Set_Ekind
(T
, E_Ordinary_Fixed_Point_Subtype
);
2605 Set_Etype
(T
, Base
);
2606 Set_Size_Info
(T
, Standard_Integer
);
2607 Set_RM_Size
(T
, RM_Size
(Standard_Integer
));
2608 Set_Small_Value
(T
, Ureal_1
);
2609 Set_Delta_Value
(T
, Ureal_1
);
2610 Set_Scalar_Range
(T
,
2612 Low_Bound
=> Make_Real_Literal
(Loc
, Ureal_1
),
2613 High_Bound
=> Make_Real_Literal
(Loc
, Ureal_1
)));
2614 Set_Is_Constrained
(T
);
2616 Set_Is_Generic_Type
(Base
);
2617 Set_Etype
(Base
, Base
);
2618 Set_Size_Info
(Base
, Standard_Integer
);
2619 Set_RM_Size
(Base
, RM_Size
(Standard_Integer
));
2620 Set_Small_Value
(Base
, Ureal_1
);
2621 Set_Delta_Value
(Base
, Ureal_1
);
2622 Set_Scalar_Range
(Base
, Scalar_Range
(T
));
2623 Set_Parent
(Base
, Parent
(Def
));
2625 Check_Restriction
(No_Fixed_Point
, Def
);
2626 end Analyze_Formal_Ordinary_Fixed_Point_Type
;
2628 ----------------------------------------
2629 -- Analyze_Formal_Package_Declaration --
2630 ----------------------------------------
2632 procedure Analyze_Formal_Package_Declaration
(N
: Node_Id
) is
2633 Gen_Id
: constant Node_Id
:= Name
(N
);
2634 Loc
: constant Source_Ptr
:= Sloc
(N
);
2635 Pack_Id
: constant Entity_Id
:= Defining_Identifier
(N
);
2638 Gen_Unit
: Entity_Id
;
2641 Vis_Prims_List
: Elist_Id
:= No_Elist
;
2642 -- List of primitives made temporarily visible in the instantiation
2643 -- to match the visibility of the formal type.
2645 function Build_Local_Package
return Node_Id
;
2646 -- The formal package is rewritten so that its parameters are replaced
2647 -- with corresponding declarations. For parameters with bona fide
2648 -- associations these declarations are created by Analyze_Associations
2649 -- as for a regular instantiation. For boxed parameters, we preserve
2650 -- the formal declarations and analyze them, in order to introduce
2651 -- entities of the right kind in the environment of the formal.
2653 -------------------------
2654 -- Build_Local_Package --
2655 -------------------------
2657 function Build_Local_Package
return Node_Id
is
2659 Pack_Decl
: Node_Id
;
2662 -- Within the formal, the name of the generic package is a renaming
2663 -- of the formal (as for a regular instantiation).
2666 Make_Package_Declaration
(Loc
,
2669 (Specification
(Original_Node
(Gen_Decl
)),
2670 Empty
, Instantiating
=> True));
2673 Make_Package_Renaming_Declaration
(Loc
,
2674 Defining_Unit_Name
=>
2675 Make_Defining_Identifier
(Loc
, Chars
(Gen_Unit
)),
2676 Name
=> New_Occurrence_Of
(Formal
, Loc
));
2678 if Nkind
(Gen_Id
) = N_Identifier
2679 and then Chars
(Gen_Id
) = Chars
(Pack_Id
)
2682 ("& is hidden within declaration of instance", Gen_Id
, Gen_Unit
);
2685 -- If the formal is declared with a box, or with an others choice,
2686 -- create corresponding declarations for all entities in the formal
2687 -- part, so that names with the proper types are available in the
2688 -- specification of the formal package.
2690 -- On the other hand, if there are no associations, then all the
2691 -- formals must have defaults, and this will be checked by the
2692 -- call to Analyze_Associations.
2695 or else Nkind
(First
(Generic_Associations
(N
))) = N_Others_Choice
2698 Formal_Decl
: Node_Id
;
2701 -- TBA : for a formal package, need to recurse ???
2706 (Generic_Formal_Declarations
(Original_Node
(Gen_Decl
)));
2707 while Present
(Formal_Decl
) loop
2711 (Formal_Decl
, Empty
, Instantiating
=> True));
2716 -- If generic associations are present, use Analyze_Associations to
2717 -- create the proper renaming declarations.
2721 Act_Tree
: constant Node_Id
:=
2723 (Original_Node
(Gen_Decl
), Empty
,
2724 Instantiating
=> True);
2727 Generic_Renamings
.Set_Last
(0);
2728 Generic_Renamings_HTable
.Reset
;
2729 Instantiation_Node
:= N
;
2732 Analyze_Associations
2733 (I_Node
=> Original_Node
(N
),
2734 Formals
=> Generic_Formal_Declarations
(Act_Tree
),
2735 F_Copy
=> Generic_Formal_Declarations
(Gen_Decl
));
2737 Vis_Prims_List
:= Check_Hidden_Primitives
(Decls
);
2741 Append
(Renaming
, To
=> Decls
);
2743 -- Add generated declarations ahead of local declarations in
2746 if No
(Visible_Declarations
(Specification
(Pack_Decl
))) then
2747 Set_Visible_Declarations
(Specification
(Pack_Decl
), Decls
);
2750 (First
(Visible_Declarations
(Specification
(Pack_Decl
))),
2755 end Build_Local_Package
;
2759 Save_ISMP
: constant Boolean := Ignore_SPARK_Mode_Pragmas_In_Instance
;
2760 -- Save flag Ignore_SPARK_Mode_Pragmas_In_Instance for restore on exit
2762 Associations
: Boolean := True;
2764 Parent_Installed
: Boolean := False;
2765 Parent_Instance
: Entity_Id
;
2766 Renaming_In_Par
: Entity_Id
;
2768 -- Start of processing for Analyze_Formal_Package_Declaration
2771 Check_Text_IO_Special_Unit
(Gen_Id
);
2774 Check_Generic_Child_Unit
(Gen_Id
, Parent_Installed
);
2775 Gen_Unit
:= Entity
(Gen_Id
);
2777 -- Check for a formal package that is a package renaming
2779 if Present
(Renamed_Object
(Gen_Unit
)) then
2781 -- Indicate that unit is used, before replacing it with renamed
2782 -- entity for use below.
2784 if In_Extended_Main_Source_Unit
(N
) then
2785 Set_Is_Instantiated
(Gen_Unit
);
2786 Generate_Reference
(Gen_Unit
, N
);
2789 Gen_Unit
:= Renamed_Object
(Gen_Unit
);
2792 if Ekind
(Gen_Unit
) /= E_Generic_Package
then
2793 Error_Msg_N
("expect generic package name", Gen_Id
);
2797 elsif Gen_Unit
= Current_Scope
then
2799 ("generic package cannot be used as a formal package of itself",
2804 elsif In_Open_Scopes
(Gen_Unit
) then
2805 if Is_Compilation_Unit
(Gen_Unit
)
2806 and then Is_Child_Unit
(Current_Scope
)
2808 -- Special-case the error when the formal is a parent, and
2809 -- continue analysis to minimize cascaded errors.
2812 ("generic parent cannot be used as formal package of a child "
2817 ("generic package cannot be used as a formal package within "
2818 & "itself", Gen_Id
);
2824 -- Check that name of formal package does not hide name of generic,
2825 -- or its leading prefix. This check must be done separately because
2826 -- the name of the generic has already been analyzed.
2829 Gen_Name
: Entity_Id
;
2833 while Nkind
(Gen_Name
) = N_Expanded_Name
loop
2834 Gen_Name
:= Prefix
(Gen_Name
);
2837 if Chars
(Gen_Name
) = Chars
(Pack_Id
) then
2839 ("& is hidden within declaration of formal package",
2845 or else No
(Generic_Associations
(N
))
2846 or else Nkind
(First
(Generic_Associations
(N
))) = N_Others_Choice
2848 Associations
:= False;
2851 -- If there are no generic associations, the generic parameters appear
2852 -- as local entities and are instantiated like them. We copy the generic
2853 -- package declaration as if it were an instantiation, and analyze it
2854 -- like a regular package, except that we treat the formals as
2855 -- additional visible components.
2857 Gen_Decl
:= Unit_Declaration_Node
(Gen_Unit
);
2859 if In_Extended_Main_Source_Unit
(N
) then
2860 Set_Is_Instantiated
(Gen_Unit
);
2861 Generate_Reference
(Gen_Unit
, N
);
2864 Formal
:= New_Copy
(Pack_Id
);
2865 Create_Instantiation_Source
(N
, Gen_Unit
, S_Adjustment
);
2867 -- Make local generic without formals. The formals will be replaced with
2868 -- internal declarations.
2871 New_N
:= Build_Local_Package
;
2873 -- If there are errors in the parameter list, Analyze_Associations
2874 -- raises Instantiation_Error. Patch the declaration to prevent further
2875 -- exception propagation.
2878 when Instantiation_Error
=>
2879 Enter_Name
(Formal
);
2880 Set_Ekind
(Formal
, E_Variable
);
2881 Set_Etype
(Formal
, Any_Type
);
2882 Restore_Hidden_Primitives
(Vis_Prims_List
);
2884 if Parent_Installed
then
2892 Set_Defining_Unit_Name
(Specification
(New_N
), Formal
);
2893 Set_Generic_Parent
(Specification
(N
), Gen_Unit
);
2894 Set_Instance_Env
(Gen_Unit
, Formal
);
2895 Set_Is_Generic_Instance
(Formal
);
2897 Enter_Name
(Formal
);
2898 Set_Ekind
(Formal
, E_Package
);
2899 Set_Etype
(Formal
, Standard_Void_Type
);
2900 Set_Inner_Instances
(Formal
, New_Elmt_List
);
2901 Push_Scope
(Formal
);
2903 -- Manually set the SPARK_Mode from the context because the package
2904 -- declaration is never analyzed.
2906 Set_SPARK_Pragma
(Formal
, SPARK_Mode_Pragma
);
2907 Set_SPARK_Aux_Pragma
(Formal
, SPARK_Mode_Pragma
);
2908 Set_SPARK_Pragma_Inherited
(Formal
);
2909 Set_SPARK_Aux_Pragma_Inherited
(Formal
);
2911 if Is_Child_Unit
(Gen_Unit
) and then Parent_Installed
then
2913 -- Similarly, we have to make the name of the formal visible in the
2914 -- parent instance, to resolve properly fully qualified names that
2915 -- may appear in the generic unit. The parent instance has been
2916 -- placed on the scope stack ahead of the current scope.
2918 Parent_Instance
:= Scope_Stack
.Table
(Scope_Stack
.Last
- 1).Entity
;
2921 Make_Defining_Identifier
(Loc
, Chars
(Gen_Unit
));
2922 Set_Ekind
(Renaming_In_Par
, E_Package
);
2923 Set_Etype
(Renaming_In_Par
, Standard_Void_Type
);
2924 Set_Scope
(Renaming_In_Par
, Parent_Instance
);
2925 Set_Parent
(Renaming_In_Par
, Parent
(Formal
));
2926 Set_Renamed_Object
(Renaming_In_Par
, Formal
);
2927 Append_Entity
(Renaming_In_Par
, Parent_Instance
);
2930 -- A formal package declaration behaves as a package instantiation with
2931 -- respect to SPARK_Mode "off". If the annotation is "off" or altogether
2932 -- missing, set the global flag which signals Analyze_Pragma to ingnore
2933 -- all SPARK_Mode pragmas within the generic_package_name.
2935 if SPARK_Mode
/= On
then
2936 Ignore_SPARK_Mode_Pragmas_In_Instance
:= True;
2938 -- Mark the formal spec in case the body is instantiated at a later
2939 -- pass. This preserves the original context in effect for the body.
2941 Set_Ignore_SPARK_Mode_Pragmas
(Formal
);
2944 Analyze
(Specification
(N
));
2946 -- The formals for which associations are provided are not visible
2947 -- outside of the formal package. The others are still declared by a
2948 -- formal parameter declaration.
2950 -- If there are no associations, the only local entity to hide is the
2951 -- generated package renaming itself.
2957 E
:= First_Entity
(Formal
);
2958 while Present
(E
) loop
2959 if Associations
and then not Is_Generic_Formal
(E
) then
2963 if Ekind
(E
) = E_Package
and then Renamed_Entity
(E
) = Formal
then
2972 End_Package_Scope
(Formal
);
2973 Restore_Hidden_Primitives
(Vis_Prims_List
);
2975 if Parent_Installed
then
2981 -- Inside the generic unit, the formal package is a regular package, but
2982 -- no body is needed for it. Note that after instantiation, the defining
2983 -- unit name we need is in the new tree and not in the original (see
2984 -- Package_Instantiation). A generic formal package is an instance, and
2985 -- can be used as an actual for an inner instance.
2987 Set_Has_Completion
(Formal
, True);
2989 -- Add semantic information to the original defining identifier for ASIS
2992 Set_Ekind
(Pack_Id
, E_Package
);
2993 Set_Etype
(Pack_Id
, Standard_Void_Type
);
2994 Set_Scope
(Pack_Id
, Scope
(Formal
));
2995 Set_Has_Completion
(Pack_Id
, True);
2998 if Has_Aspects
(N
) then
2999 Analyze_Aspect_Specifications
(N
, Pack_Id
);
3002 Ignore_SPARK_Mode_Pragmas_In_Instance
:= Save_ISMP
;
3003 end Analyze_Formal_Package_Declaration
;
3005 ---------------------------------
3006 -- Analyze_Formal_Private_Type --
3007 ---------------------------------
3009 procedure Analyze_Formal_Private_Type
3015 New_Private_Type
(N
, T
, Def
);
3017 -- Set the size to an arbitrary but legal value
3019 Set_Size_Info
(T
, Standard_Integer
);
3020 Set_RM_Size
(T
, RM_Size
(Standard_Integer
));
3021 end Analyze_Formal_Private_Type
;
3023 ------------------------------------
3024 -- Analyze_Formal_Incomplete_Type --
3025 ------------------------------------
3027 procedure Analyze_Formal_Incomplete_Type
3033 Set_Ekind
(T
, E_Incomplete_Type
);
3035 Set_Private_Dependents
(T
, New_Elmt_List
);
3037 if Tagged_Present
(Def
) then
3038 Set_Is_Tagged_Type
(T
);
3039 Make_Class_Wide_Type
(T
);
3040 Set_Direct_Primitive_Operations
(T
, New_Elmt_List
);
3042 end Analyze_Formal_Incomplete_Type
;
3044 ----------------------------------------
3045 -- Analyze_Formal_Signed_Integer_Type --
3046 ----------------------------------------
3048 procedure Analyze_Formal_Signed_Integer_Type
3052 Base
: constant Entity_Id
:=
3054 (E_Signed_Integer_Type
,
3056 Sloc
(Defining_Identifier
(Parent
(Def
))), 'G');
3061 Set_Ekind
(T
, E_Signed_Integer_Subtype
);
3062 Set_Etype
(T
, Base
);
3063 Set_Size_Info
(T
, Standard_Integer
);
3064 Set_RM_Size
(T
, RM_Size
(Standard_Integer
));
3065 Set_Scalar_Range
(T
, Scalar_Range
(Standard_Integer
));
3066 Set_Is_Constrained
(T
);
3068 Set_Is_Generic_Type
(Base
);
3069 Set_Size_Info
(Base
, Standard_Integer
);
3070 Set_RM_Size
(Base
, RM_Size
(Standard_Integer
));
3071 Set_Etype
(Base
, Base
);
3072 Set_Scalar_Range
(Base
, Scalar_Range
(Standard_Integer
));
3073 Set_Parent
(Base
, Parent
(Def
));
3074 end Analyze_Formal_Signed_Integer_Type
;
3076 -------------------------------------------
3077 -- Analyze_Formal_Subprogram_Declaration --
3078 -------------------------------------------
3080 procedure Analyze_Formal_Subprogram_Declaration
(N
: Node_Id
) is
3081 Spec
: constant Node_Id
:= Specification
(N
);
3082 Def
: constant Node_Id
:= Default_Name
(N
);
3083 Nam
: constant Entity_Id
:= Defining_Unit_Name
(Spec
);
3091 if Nkind
(Nam
) = N_Defining_Program_Unit_Name
then
3092 Error_Msg_N
("name of formal subprogram must be a direct name", Nam
);
3096 Analyze_Subprogram_Declaration
(N
);
3097 Set_Is_Formal_Subprogram
(Nam
);
3098 Set_Has_Completion
(Nam
);
3100 if Nkind
(N
) = N_Formal_Abstract_Subprogram_Declaration
then
3101 Set_Is_Abstract_Subprogram
(Nam
);
3103 Set_Is_Dispatching_Operation
(Nam
);
3105 -- A formal abstract procedure cannot have a null default
3106 -- (RM 12.6(4.1/2)).
3108 if Nkind
(Spec
) = N_Procedure_Specification
3109 and then Null_Present
(Spec
)
3112 ("a formal abstract subprogram cannot default to null", Spec
);
3116 Ctrl_Type
: constant Entity_Id
:= Find_Dispatching_Type
(Nam
);
3118 if No
(Ctrl_Type
) then
3120 ("abstract formal subprogram must have a controlling type",
3123 elsif Ada_Version
>= Ada_2012
3124 and then Is_Incomplete_Type
(Ctrl_Type
)
3127 ("controlling type of abstract formal subprogram cannot "
3128 & "be incomplete type", N
, Ctrl_Type
);
3131 Check_Controlling_Formals
(Ctrl_Type
, Nam
);
3136 -- Default name is resolved at the point of instantiation
3138 if Box_Present
(N
) then
3141 -- Else default is bound at the point of generic declaration
3143 elsif Present
(Def
) then
3144 if Nkind
(Def
) = N_Operator_Symbol
then
3145 Find_Direct_Name
(Def
);
3147 elsif Nkind
(Def
) /= N_Attribute_Reference
then
3151 -- For an attribute reference, analyze the prefix and verify
3152 -- that it has the proper profile for the subprogram.
3154 Analyze
(Prefix
(Def
));
3155 Valid_Default_Attribute
(Nam
, Def
);
3159 -- Default name may be overloaded, in which case the interpretation
3160 -- with the correct profile must be selected, as for a renaming.
3161 -- If the definition is an indexed component, it must denote a
3162 -- member of an entry family. If it is a selected component, it
3163 -- can be a protected operation.
3165 if Etype
(Def
) = Any_Type
then
3168 elsif Nkind
(Def
) = N_Selected_Component
then
3169 if not Is_Overloadable
(Entity
(Selector_Name
(Def
))) then
3170 Error_Msg_N
("expect valid subprogram name as default", Def
);
3173 elsif Nkind
(Def
) = N_Indexed_Component
then
3174 if Is_Entity_Name
(Prefix
(Def
)) then
3175 if Ekind
(Entity
(Prefix
(Def
))) /= E_Entry_Family
then
3176 Error_Msg_N
("expect valid subprogram name as default", Def
);
3179 elsif Nkind
(Prefix
(Def
)) = N_Selected_Component
then
3180 if Ekind
(Entity
(Selector_Name
(Prefix
(Def
)))) /=
3183 Error_Msg_N
("expect valid subprogram name as default", Def
);
3187 Error_Msg_N
("expect valid subprogram name as default", Def
);
3191 elsif Nkind
(Def
) = N_Character_Literal
then
3193 -- Needs some type checks: subprogram should be parameterless???
3195 Resolve
(Def
, (Etype
(Nam
)));
3197 elsif not Is_Entity_Name
(Def
)
3198 or else not Is_Overloadable
(Entity
(Def
))
3200 Error_Msg_N
("expect valid subprogram name as default", Def
);
3203 elsif not Is_Overloaded
(Def
) then
3204 Subp
:= Entity
(Def
);
3207 Error_Msg_N
("premature usage of formal subprogram", Def
);
3209 elsif not Entity_Matches_Spec
(Subp
, Nam
) then
3210 Error_Msg_N
("no visible entity matches specification", Def
);
3213 -- More than one interpretation, so disambiguate as for a renaming
3218 I1
: Interp_Index
:= 0;
3224 Get_First_Interp
(Def
, I
, It
);
3225 while Present
(It
.Nam
) loop
3226 if Entity_Matches_Spec
(It
.Nam
, Nam
) then
3227 if Subp
/= Any_Id
then
3228 It1
:= Disambiguate
(Def
, I1
, I
, Etype
(Subp
));
3230 if It1
= No_Interp
then
3231 Error_Msg_N
("ambiguous default subprogram", Def
);
3244 Get_Next_Interp
(I
, It
);
3248 if Subp
/= Any_Id
then
3250 -- Subprogram found, generate reference to it
3252 Set_Entity
(Def
, Subp
);
3253 Generate_Reference
(Subp
, Def
);
3256 Error_Msg_N
("premature usage of formal subprogram", Def
);
3258 elsif Ekind
(Subp
) /= E_Operator
then
3259 Check_Mode_Conformant
(Subp
, Nam
);
3263 Error_Msg_N
("no visible subprogram matches specification", N
);
3269 if Has_Aspects
(N
) then
3270 Analyze_Aspect_Specifications
(N
, Nam
);
3273 end Analyze_Formal_Subprogram_Declaration
;
3275 -------------------------------------
3276 -- Analyze_Formal_Type_Declaration --
3277 -------------------------------------
3279 procedure Analyze_Formal_Type_Declaration
(N
: Node_Id
) is
3280 Def
: constant Node_Id
:= Formal_Type_Definition
(N
);
3284 T
:= Defining_Identifier
(N
);
3286 if Present
(Discriminant_Specifications
(N
))
3287 and then Nkind
(Def
) /= N_Formal_Private_Type_Definition
3290 ("discriminants not allowed for this formal type", T
);
3293 -- Enter the new name, and branch to specific routine
3296 when N_Formal_Private_Type_Definition
=>
3297 Analyze_Formal_Private_Type
(N
, T
, Def
);
3299 when N_Formal_Derived_Type_Definition
=>
3300 Analyze_Formal_Derived_Type
(N
, T
, Def
);
3302 when N_Formal_Incomplete_Type_Definition
=>
3303 Analyze_Formal_Incomplete_Type
(T
, Def
);
3305 when N_Formal_Discrete_Type_Definition
=>
3306 Analyze_Formal_Discrete_Type
(T
, Def
);
3308 when N_Formal_Signed_Integer_Type_Definition
=>
3309 Analyze_Formal_Signed_Integer_Type
(T
, Def
);
3311 when N_Formal_Modular_Type_Definition
=>
3312 Analyze_Formal_Modular_Type
(T
, Def
);
3314 when N_Formal_Floating_Point_Definition
=>
3315 Analyze_Formal_Floating_Type
(T
, Def
);
3317 when N_Formal_Ordinary_Fixed_Point_Definition
=>
3318 Analyze_Formal_Ordinary_Fixed_Point_Type
(T
, Def
);
3320 when N_Formal_Decimal_Fixed_Point_Definition
=>
3321 Analyze_Formal_Decimal_Fixed_Point_Type
(T
, Def
);
3323 when N_Array_Type_Definition
=>
3324 Analyze_Formal_Array_Type
(T
, Def
);
3326 when N_Access_Function_Definition
3327 | N_Access_Procedure_Definition
3328 | N_Access_To_Object_Definition
3330 Analyze_Generic_Access_Type
(T
, Def
);
3332 -- Ada 2005: a interface declaration is encoded as an abstract
3333 -- record declaration or a abstract type derivation.
3335 when N_Record_Definition
=>
3336 Analyze_Formal_Interface_Type
(N
, T
, Def
);
3338 when N_Derived_Type_Definition
=>
3339 Analyze_Formal_Derived_Interface_Type
(N
, T
, Def
);
3345 raise Program_Error
;
3348 Set_Is_Generic_Type
(T
);
3350 if Has_Aspects
(N
) then
3351 Analyze_Aspect_Specifications
(N
, T
);
3353 end Analyze_Formal_Type_Declaration
;
3355 ------------------------------------
3356 -- Analyze_Function_Instantiation --
3357 ------------------------------------
3359 procedure Analyze_Function_Instantiation
(N
: Node_Id
) is
3361 Analyze_Subprogram_Instantiation
(N
, E_Function
);
3362 end Analyze_Function_Instantiation
;
3364 ---------------------------------
3365 -- Analyze_Generic_Access_Type --
3366 ---------------------------------
3368 procedure Analyze_Generic_Access_Type
(T
: Entity_Id
; Def
: Node_Id
) is
3372 if Nkind
(Def
) = N_Access_To_Object_Definition
then
3373 Access_Type_Declaration
(T
, Def
);
3375 if Is_Incomplete_Or_Private_Type
(Designated_Type
(T
))
3376 and then No
(Full_View
(Designated_Type
(T
)))
3377 and then not Is_Generic_Type
(Designated_Type
(T
))
3379 Error_Msg_N
("premature usage of incomplete type", Def
);
3381 elsif not Is_Entity_Name
(Subtype_Indication
(Def
)) then
3383 ("only a subtype mark is allowed in a formal", Def
);
3387 Access_Subprogram_Declaration
(T
, Def
);
3389 end Analyze_Generic_Access_Type
;
3391 ---------------------------------
3392 -- Analyze_Generic_Formal_Part --
3393 ---------------------------------
3395 procedure Analyze_Generic_Formal_Part
(N
: Node_Id
) is
3396 Gen_Parm_Decl
: Node_Id
;
3399 -- The generic formals are processed in the scope of the generic unit,
3400 -- where they are immediately visible. The scope is installed by the
3403 Gen_Parm_Decl
:= First
(Generic_Formal_Declarations
(N
));
3404 while Present
(Gen_Parm_Decl
) loop
3405 Analyze
(Gen_Parm_Decl
);
3406 Next
(Gen_Parm_Decl
);
3409 Generate_Reference_To_Generic_Formals
(Current_Scope
);
3410 end Analyze_Generic_Formal_Part
;
3412 ------------------------------------------
3413 -- Analyze_Generic_Package_Declaration --
3414 ------------------------------------------
3416 procedure Analyze_Generic_Package_Declaration
(N
: Node_Id
) is
3417 Loc
: constant Source_Ptr
:= Sloc
(N
);
3418 Decls
: constant List_Id
:=
3419 Visible_Declarations
(Specification
(N
));
3424 Save_Parent
: Node_Id
;
3427 Check_SPARK_05_Restriction
("generic is not allowed", N
);
3429 -- We introduce a renaming of the enclosing package, to have a usable
3430 -- entity as the prefix of an expanded name for a local entity of the
3431 -- form Par.P.Q, where P is the generic package. This is because a local
3432 -- entity named P may hide it, so that the usual visibility rules in
3433 -- the instance will not resolve properly.
3436 Make_Package_Renaming_Declaration
(Loc
,
3437 Defining_Unit_Name
=>
3438 Make_Defining_Identifier
(Loc
,
3439 Chars
=> New_External_Name
(Chars
(Defining_Entity
(N
)), "GH")),
3441 Make_Identifier
(Loc
, Chars
(Defining_Entity
(N
))));
3443 if Present
(Decls
) then
3444 Decl
:= First
(Decls
);
3445 while Present
(Decl
) and then Nkind
(Decl
) = N_Pragma
loop
3449 if Present
(Decl
) then
3450 Insert_Before
(Decl
, Renaming
);
3452 Append
(Renaming
, Visible_Declarations
(Specification
(N
)));
3456 Set_Visible_Declarations
(Specification
(N
), New_List
(Renaming
));
3459 -- Create copy of generic unit, and save for instantiation. If the unit
3460 -- is a child unit, do not copy the specifications for the parent, which
3461 -- are not part of the generic tree.
3463 Save_Parent
:= Parent_Spec
(N
);
3464 Set_Parent_Spec
(N
, Empty
);
3466 New_N
:= Copy_Generic_Node
(N
, Empty
, Instantiating
=> False);
3467 Set_Parent_Spec
(New_N
, Save_Parent
);
3470 -- Once the contents of the generic copy and the template are swapped,
3471 -- do the same for their respective aspect specifications.
3473 Exchange_Aspects
(N
, New_N
);
3475 -- Collect all contract-related source pragmas found within the template
3476 -- and attach them to the contract of the package spec. This contract is
3477 -- used in the capture of global references within annotations.
3479 Create_Generic_Contract
(N
);
3481 Id
:= Defining_Entity
(N
);
3482 Generate_Definition
(Id
);
3484 -- Expansion is not applied to generic units
3489 Set_Ekind
(Id
, E_Generic_Package
);
3490 Set_Etype
(Id
, Standard_Void_Type
);
3492 -- Set SPARK_Mode from context
3494 Set_SPARK_Pragma
(Id
, SPARK_Mode_Pragma
);
3495 Set_SPARK_Aux_Pragma
(Id
, SPARK_Mode_Pragma
);
3496 Set_SPARK_Pragma_Inherited
(Id
);
3497 Set_SPARK_Aux_Pragma_Inherited
(Id
);
3499 -- Analyze aspects now, so that generated pragmas appear in the
3500 -- declarations before building and analyzing the generic copy.
3502 if Has_Aspects
(N
) then
3503 Analyze_Aspect_Specifications
(N
, Id
);
3507 Enter_Generic_Scope
(Id
);
3508 Set_Inner_Instances
(Id
, New_Elmt_List
);
3510 Set_Categorization_From_Pragmas
(N
);
3511 Set_Is_Pure
(Id
, Is_Pure
(Current_Scope
));
3513 -- Link the declaration of the generic homonym in the generic copy to
3514 -- the package it renames, so that it is always resolved properly.
3516 Set_Generic_Homonym
(Id
, Defining_Unit_Name
(Renaming
));
3517 Set_Entity
(Associated_Node
(Name
(Renaming
)), Id
);
3519 -- For a library unit, we have reconstructed the entity for the unit,
3520 -- and must reset it in the library tables.
3522 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
3523 Set_Cunit_Entity
(Current_Sem_Unit
, Id
);
3526 Analyze_Generic_Formal_Part
(N
);
3528 -- After processing the generic formals, analysis proceeds as for a
3529 -- non-generic package.
3531 Analyze
(Specification
(N
));
3533 Validate_Categorization_Dependency
(N
, Id
);
3537 End_Package_Scope
(Id
);
3538 Exit_Generic_Scope
(Id
);
3540 -- If the generic appears within a package unit, the body of that unit
3541 -- has to be present for instantiation and inlining.
3543 if Nkind
(Unit
(Cunit
(Current_Sem_Unit
))) = N_Package_Declaration
then
3544 Set_Body_Needed_For_Inlining
3545 (Defining_Entity
(Unit
(Cunit
(Current_Sem_Unit
))));
3548 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
3549 Move_Freeze_Nodes
(Id
, N
, Visible_Declarations
(Specification
(N
)));
3550 Move_Freeze_Nodes
(Id
, N
, Private_Declarations
(Specification
(N
)));
3551 Move_Freeze_Nodes
(Id
, N
, Generic_Formal_Declarations
(N
));
3554 Set_Body_Required
(Parent
(N
), Unit_Requires_Body
(Id
));
3555 Validate_RT_RAT_Component
(N
);
3557 -- If this is a spec without a body, check that generic parameters
3560 if not Body_Required
(Parent
(N
)) then
3561 Check_References
(Id
);
3565 -- If there is a specified storage pool in the context, create an
3566 -- aspect on the package declaration, so that it is used in any
3567 -- instance that does not override it.
3569 if Present
(Default_Pool
) then
3575 Make_Aspect_Specification
(Loc
,
3576 Identifier
=> Make_Identifier
(Loc
, Name_Default_Storage_Pool
),
3577 Expression
=> New_Copy
(Default_Pool
));
3579 if No
(Aspect_Specifications
(Specification
(N
))) then
3580 Set_Aspect_Specifications
(Specification
(N
), New_List
(ASN
));
3582 Append
(ASN
, Aspect_Specifications
(Specification
(N
)));
3586 end Analyze_Generic_Package_Declaration
;
3588 --------------------------------------------
3589 -- Analyze_Generic_Subprogram_Declaration --
3590 --------------------------------------------
3592 procedure Analyze_Generic_Subprogram_Declaration
(N
: Node_Id
) is
3596 Result_Type
: Entity_Id
;
3597 Save_Parent
: Node_Id
;
3602 Check_SPARK_05_Restriction
("generic is not allowed", N
);
3604 -- Create copy of generic unit, and save for instantiation. If the unit
3605 -- is a child unit, do not copy the specifications for the parent, which
3606 -- are not part of the generic tree.
3608 Save_Parent
:= Parent_Spec
(N
);
3609 Set_Parent_Spec
(N
, Empty
);
3611 New_N
:= Copy_Generic_Node
(N
, Empty
, Instantiating
=> False);
3612 Set_Parent_Spec
(New_N
, Save_Parent
);
3615 -- Once the contents of the generic copy and the template are swapped,
3616 -- do the same for their respective aspect specifications.
3618 Exchange_Aspects
(N
, New_N
);
3620 -- Collect all contract-related source pragmas found within the template
3621 -- and attach them to the contract of the subprogram spec. This contract
3622 -- is used in the capture of global references within annotations.
3624 Create_Generic_Contract
(N
);
3626 Spec
:= Specification
(N
);
3627 Id
:= Defining_Entity
(Spec
);
3628 Generate_Definition
(Id
);
3630 if Nkind
(Id
) = N_Defining_Operator_Symbol
then
3632 ("operator symbol not allowed for generic subprogram", Id
);
3638 Set_Scope_Depth_Value
(Id
, Scope_Depth
(Current_Scope
) + 1);
3640 -- Analyze the aspects of the generic copy to ensure that all generated
3641 -- pragmas (if any) perform their semantic effects.
3643 if Has_Aspects
(N
) then
3644 Analyze_Aspect_Specifications
(N
, Id
);
3648 Enter_Generic_Scope
(Id
);
3649 Set_Inner_Instances
(Id
, New_Elmt_List
);
3650 Set_Is_Pure
(Id
, Is_Pure
(Current_Scope
));
3652 Analyze_Generic_Formal_Part
(N
);
3654 Formals
:= Parameter_Specifications
(Spec
);
3656 if Nkind
(Spec
) = N_Function_Specification
then
3657 Set_Ekind
(Id
, E_Generic_Function
);
3659 Set_Ekind
(Id
, E_Generic_Procedure
);
3662 if Present
(Formals
) then
3663 Process_Formals
(Formals
, Spec
);
3666 if Nkind
(Spec
) = N_Function_Specification
then
3667 if Nkind
(Result_Definition
(Spec
)) = N_Access_Definition
then
3668 Result_Type
:= Access_Definition
(Spec
, Result_Definition
(Spec
));
3669 Set_Etype
(Id
, Result_Type
);
3671 -- Check restriction imposed by AI05-073: a generic function
3672 -- cannot return an abstract type or an access to such.
3674 -- This is a binding interpretation should it apply to earlier
3675 -- versions of Ada as well as Ada 2012???
3677 if Is_Abstract_Type
(Designated_Type
(Result_Type
))
3678 and then Ada_Version
>= Ada_2012
3681 ("generic function cannot have an access result "
3682 & "that designates an abstract type", Spec
);
3686 Find_Type
(Result_Definition
(Spec
));
3687 Typ
:= Entity
(Result_Definition
(Spec
));
3689 if Is_Abstract_Type
(Typ
)
3690 and then Ada_Version
>= Ada_2012
3693 ("generic function cannot have abstract result type", Spec
);
3696 -- If a null exclusion is imposed on the result type, then create
3697 -- a null-excluding itype (an access subtype) and use it as the
3698 -- function's Etype.
3700 if Is_Access_Type
(Typ
)
3701 and then Null_Exclusion_Present
(Spec
)
3704 Create_Null_Excluding_Itype
3706 Related_Nod
=> Spec
,
3707 Scope_Id
=> Defining_Unit_Name
(Spec
)));
3709 Set_Etype
(Id
, Typ
);
3714 Set_Etype
(Id
, Standard_Void_Type
);
3717 -- For a library unit, we have reconstructed the entity for the unit,
3718 -- and must reset it in the library tables. We also make sure that
3719 -- Body_Required is set properly in the original compilation unit node.
3721 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
3722 Set_Cunit_Entity
(Current_Sem_Unit
, Id
);
3723 Set_Body_Required
(Parent
(N
), Unit_Requires_Body
(Id
));
3726 -- If the generic appears within a package unit, the body of that unit
3727 -- has to be present for instantiation and inlining.
3729 if Nkind
(Unit
(Cunit
(Current_Sem_Unit
))) = N_Package_Declaration
3730 and then Unit_Requires_Body
(Id
)
3732 Set_Body_Needed_For_Inlining
3733 (Defining_Entity
(Unit
(Cunit
(Current_Sem_Unit
))));
3736 Set_Categorization_From_Pragmas
(N
);
3737 Validate_Categorization_Dependency
(N
, Id
);
3739 -- Capture all global references that occur within the profile of the
3740 -- generic subprogram. Aspects are not part of this processing because
3741 -- they must be delayed. If processed now, Save_Global_References will
3742 -- destroy the Associated_Node links and prevent the capture of global
3743 -- references when the contract of the generic subprogram is analyzed.
3745 Save_Global_References
(Original_Node
(N
));
3749 Exit_Generic_Scope
(Id
);
3750 Generate_Reference_To_Formals
(Id
);
3752 List_Inherited_Pre_Post_Aspects
(Id
);
3753 end Analyze_Generic_Subprogram_Declaration
;
3755 -----------------------------------
3756 -- Analyze_Package_Instantiation --
3757 -----------------------------------
3759 -- WARNING: This routine manages Ghost and SPARK regions. Return statements
3760 -- must be replaced by gotos which jump to the end of the routine in order
3761 -- to restore the Ghost and SPARK modes.
3763 procedure Analyze_Package_Instantiation
(N
: Node_Id
) is
3764 Has_Inline_Always
: Boolean := False;
3766 procedure Delay_Descriptors
(E
: Entity_Id
);
3767 -- Delay generation of subprogram descriptors for given entity
3769 function Might_Inline_Subp
(Gen_Unit
: Entity_Id
) return Boolean;
3770 -- If inlining is active and the generic contains inlined subprograms,
3771 -- we instantiate the body. This may cause superfluous instantiations,
3772 -- but it is simpler than detecting the need for the body at the point
3773 -- of inlining, when the context of the instance is not available.
3775 -----------------------
3776 -- Delay_Descriptors --
3777 -----------------------
3779 procedure Delay_Descriptors
(E
: Entity_Id
) is
3781 if not Delay_Subprogram_Descriptors
(E
) then
3782 Set_Delay_Subprogram_Descriptors
(E
);
3783 Pending_Descriptor
.Append
(E
);
3785 end Delay_Descriptors
;
3787 -----------------------
3788 -- Might_Inline_Subp --
3789 -----------------------
3791 function Might_Inline_Subp
(Gen_Unit
: Entity_Id
) return Boolean is
3795 if not Inline_Processing_Required
then
3799 E
:= First_Entity
(Gen_Unit
);
3800 while Present
(E
) loop
3801 if Is_Subprogram
(E
) and then Is_Inlined
(E
) then
3802 -- Remember if there are any subprograms with Inline_Always
3804 if Has_Pragma_Inline_Always
(E
) then
3805 Has_Inline_Always
:= True;
3816 end Might_Inline_Subp
;
3818 -- Local declarations
3820 Gen_Id
: constant Node_Id
:= Name
(N
);
3821 Is_Actual_Pack
: constant Boolean :=
3822 Is_Internal
(Defining_Entity
(N
));
3823 Loc
: constant Source_Ptr
:= Sloc
(N
);
3825 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
3826 Saved_ISMP
: constant Boolean :=
3827 Ignore_SPARK_Mode_Pragmas_In_Instance
;
3828 Saved_SM
: constant SPARK_Mode_Type
:= SPARK_Mode
;
3829 Saved_SMP
: constant Node_Id
:= SPARK_Mode_Pragma
;
3830 -- Save the Ghost and SPARK mode-related data to restore on exit
3832 Saved_Style_Check
: constant Boolean := Style_Check
;
3833 -- Save style check mode for restore on exit
3836 Act_Decl_Name
: Node_Id
;
3837 Act_Decl_Id
: Entity_Id
;
3840 Env_Installed
: Boolean := False;
3843 Gen_Unit
: Entity_Id
;
3844 Inline_Now
: Boolean := False;
3845 Needs_Body
: Boolean;
3846 Parent_Installed
: Boolean := False;
3847 Renaming_List
: List_Id
;
3848 Unit_Renaming
: Node_Id
;
3850 Vis_Prims_List
: Elist_Id
:= No_Elist
;
3851 -- List of primitives made temporarily visible in the instantiation
3852 -- to match the visibility of the formal type
3854 -- Start of processing for Analyze_Package_Instantiation
3857 Check_SPARK_05_Restriction
("generic is not allowed", N
);
3859 -- Very first thing: check for Text_IO special unit in case we are
3860 -- instantiating one of the children of [[Wide_]Wide_]Text_IO.
3862 Check_Text_IO_Special_Unit
(Name
(N
));
3864 -- Make node global for error reporting
3866 Instantiation_Node
:= N
;
3868 -- Case of instantiation of a generic package
3870 if Nkind
(N
) = N_Package_Instantiation
then
3871 Act_Decl_Id
:= New_Copy
(Defining_Entity
(N
));
3872 Set_Comes_From_Source
(Act_Decl_Id
, True);
3874 if Nkind
(Defining_Unit_Name
(N
)) = N_Defining_Program_Unit_Name
then
3876 Make_Defining_Program_Unit_Name
(Loc
,
3878 New_Copy_Tree
(Name
(Defining_Unit_Name
(N
))),
3879 Defining_Identifier
=> Act_Decl_Id
);
3881 Act_Decl_Name
:= Act_Decl_Id
;
3884 -- Case of instantiation of a formal package
3887 Act_Decl_Id
:= Defining_Identifier
(N
);
3888 Act_Decl_Name
:= Act_Decl_Id
;
3891 Generate_Definition
(Act_Decl_Id
);
3892 Set_Ekind
(Act_Decl_Id
, E_Package
);
3894 -- Initialize list of incomplete actuals before analysis
3896 Set_Incomplete_Actuals
(Act_Decl_Id
, New_Elmt_List
);
3898 Preanalyze_Actuals
(N
, Act_Decl_Id
);
3900 -- Turn off style checking in instances. If the check is enabled on the
3901 -- generic unit, a warning in an instance would just be noise. If not
3902 -- enabled on the generic, then a warning in an instance is just wrong.
3903 -- This must be done after analyzing the actuals, which do come from
3904 -- source and are subject to style checking.
3906 Style_Check
:= False;
3909 Env_Installed
:= True;
3911 -- Reset renaming map for formal types. The mapping is established
3912 -- when analyzing the generic associations, but some mappings are
3913 -- inherited from formal packages of parent units, and these are
3914 -- constructed when the parents are installed.
3916 Generic_Renamings
.Set_Last
(0);
3917 Generic_Renamings_HTable
.Reset
;
3919 Check_Generic_Child_Unit
(Gen_Id
, Parent_Installed
);
3920 Gen_Unit
:= Entity
(Gen_Id
);
3922 -- A package instantiation is Ghost when it is subject to pragma Ghost
3923 -- or the generic template is Ghost. Set the mode now to ensure that
3924 -- any nodes generated during analysis and expansion are marked as
3927 Mark_And_Set_Ghost_Instantiation
(N
, Gen_Unit
);
3929 -- Verify that it is the name of a generic package
3931 -- A visibility glitch: if the instance is a child unit and the generic
3932 -- is the generic unit of a parent instance (i.e. both the parent and
3933 -- the child units are instances of the same package) the name now
3934 -- denotes the renaming within the parent, not the intended generic
3935 -- unit. See if there is a homonym that is the desired generic. The
3936 -- renaming declaration must be visible inside the instance of the
3937 -- child, but not when analyzing the name in the instantiation itself.
3939 if Ekind
(Gen_Unit
) = E_Package
3940 and then Present
(Renamed_Entity
(Gen_Unit
))
3941 and then In_Open_Scopes
(Renamed_Entity
(Gen_Unit
))
3942 and then Is_Generic_Instance
(Renamed_Entity
(Gen_Unit
))
3943 and then Present
(Homonym
(Gen_Unit
))
3945 Gen_Unit
:= Homonym
(Gen_Unit
);
3948 if Etype
(Gen_Unit
) = Any_Type
then
3952 elsif Ekind
(Gen_Unit
) /= E_Generic_Package
then
3954 -- Ada 2005 (AI-50217): Cannot use instance in limited with_clause
3956 if From_Limited_With
(Gen_Unit
) then
3958 ("cannot instantiate a limited withed package", Gen_Id
);
3961 ("& is not the name of a generic package", Gen_Id
, Gen_Unit
);
3968 if In_Extended_Main_Source_Unit
(N
) then
3969 Set_Is_Instantiated
(Gen_Unit
);
3970 Generate_Reference
(Gen_Unit
, N
);
3972 if Present
(Renamed_Object
(Gen_Unit
)) then
3973 Set_Is_Instantiated
(Renamed_Object
(Gen_Unit
));
3974 Generate_Reference
(Renamed_Object
(Gen_Unit
), N
);
3978 if Nkind
(Gen_Id
) = N_Identifier
3979 and then Chars
(Gen_Unit
) = Chars
(Defining_Entity
(N
))
3982 ("& is hidden within declaration of instance", Gen_Id
, Gen_Unit
);
3984 elsif Nkind
(Gen_Id
) = N_Expanded_Name
3985 and then Is_Child_Unit
(Gen_Unit
)
3986 and then Nkind
(Prefix
(Gen_Id
)) = N_Identifier
3987 and then Chars
(Act_Decl_Id
) = Chars
(Prefix
(Gen_Id
))
3990 ("& is hidden within declaration of instance ", Prefix
(Gen_Id
));
3993 Set_Entity
(Gen_Id
, Gen_Unit
);
3995 -- If generic is a renaming, get original generic unit
3997 if Present
(Renamed_Object
(Gen_Unit
))
3998 and then Ekind
(Renamed_Object
(Gen_Unit
)) = E_Generic_Package
4000 Gen_Unit
:= Renamed_Object
(Gen_Unit
);
4003 -- Verify that there are no circular instantiations
4005 if In_Open_Scopes
(Gen_Unit
) then
4006 Error_Msg_NE
("instantiation of & within itself", N
, Gen_Unit
);
4010 elsif Contains_Instance_Of
(Gen_Unit
, Current_Scope
, Gen_Id
) then
4011 Error_Msg_Node_2
:= Current_Scope
;
4013 ("circular Instantiation: & instantiated in &!", N
, Gen_Unit
);
4014 Circularity_Detected
:= True;
4019 -- If the context of the instance is subject to SPARK_Mode "off" or
4020 -- the annotation is altogether missing, set the global flag which
4021 -- signals Analyze_Pragma to ignore all SPARK_Mode pragmas within
4024 if SPARK_Mode
/= On
then
4025 Ignore_SPARK_Mode_Pragmas_In_Instance
:= True;
4027 -- Mark the instance spec in case the body is instantiated at a
4028 -- later pass. This preserves the original context in effect for
4031 Set_Ignore_SPARK_Mode_Pragmas
(Act_Decl_Id
);
4034 Gen_Decl
:= Unit_Declaration_Node
(Gen_Unit
);
4035 Gen_Spec
:= Specification
(Gen_Decl
);
4037 -- Initialize renamings map, for error checking, and the list that
4038 -- holds private entities whose views have changed between generic
4039 -- definition and instantiation. If this is the instance created to
4040 -- validate an actual package, the instantiation environment is that
4041 -- of the enclosing instance.
4043 Create_Instantiation_Source
(N
, Gen_Unit
, S_Adjustment
);
4045 -- Copy original generic tree, to produce text for instantiation
4049 (Original_Node
(Gen_Decl
), Empty
, Instantiating
=> True);
4051 Act_Spec
:= Specification
(Act_Tree
);
4053 -- If this is the instance created to validate an actual package,
4054 -- only the formals matter, do not examine the package spec itself.
4056 if Is_Actual_Pack
then
4057 Set_Visible_Declarations
(Act_Spec
, New_List
);
4058 Set_Private_Declarations
(Act_Spec
, New_List
);
4062 Analyze_Associations
4064 Formals
=> Generic_Formal_Declarations
(Act_Tree
),
4065 F_Copy
=> Generic_Formal_Declarations
(Gen_Decl
));
4067 Vis_Prims_List
:= Check_Hidden_Primitives
(Renaming_List
);
4069 Set_Instance_Env
(Gen_Unit
, Act_Decl_Id
);
4070 Set_Defining_Unit_Name
(Act_Spec
, Act_Decl_Name
);
4071 Set_Is_Generic_Instance
(Act_Decl_Id
);
4072 Set_Generic_Parent
(Act_Spec
, Gen_Unit
);
4074 -- References to the generic in its own declaration or its body are
4075 -- references to the instance. Add a renaming declaration for the
4076 -- generic unit itself. This declaration, as well as the renaming
4077 -- declarations for the generic formals, must remain private to the
4078 -- unit: the formals, because this is the language semantics, and
4079 -- the unit because its use is an artifact of the implementation.
4082 Make_Package_Renaming_Declaration
(Loc
,
4083 Defining_Unit_Name
=>
4084 Make_Defining_Identifier
(Loc
, Chars
(Gen_Unit
)),
4085 Name
=> New_Occurrence_Of
(Act_Decl_Id
, Loc
));
4087 Append
(Unit_Renaming
, Renaming_List
);
4089 -- The renaming declarations are the first local declarations of the
4092 if Is_Non_Empty_List
(Visible_Declarations
(Act_Spec
)) then
4094 (First
(Visible_Declarations
(Act_Spec
)), Renaming_List
);
4096 Set_Visible_Declarations
(Act_Spec
, Renaming_List
);
4099 Act_Decl
:= Make_Package_Declaration
(Loc
, Specification
=> Act_Spec
);
4101 -- Propagate the aspect specifications from the package declaration
4102 -- template to the instantiated version of the package declaration.
4104 if Has_Aspects
(Act_Tree
) then
4105 Set_Aspect_Specifications
(Act_Decl
,
4106 New_Copy_List_Tree
(Aspect_Specifications
(Act_Tree
)));
4109 -- The generic may have a generated Default_Storage_Pool aspect,
4110 -- set at the point of generic declaration. If the instance has
4111 -- that aspect, it overrides the one inherited from the generic.
4113 if Has_Aspects
(Gen_Spec
) then
4114 if No
(Aspect_Specifications
(N
)) then
4115 Set_Aspect_Specifications
(N
,
4117 (Aspect_Specifications
(Gen_Spec
))));
4121 ASN1
, ASN2
: Node_Id
;
4124 ASN1
:= First
(Aspect_Specifications
(N
));
4125 while Present
(ASN1
) loop
4126 if Chars
(Identifier
(ASN1
)) = Name_Default_Storage_Pool
4128 -- If generic carries a default storage pool, remove
4129 -- it in favor of the instance one.
4131 ASN2
:= First
(Aspect_Specifications
(Gen_Spec
));
4132 while Present
(ASN2
) loop
4133 if Chars
(Identifier
(ASN2
)) =
4134 Name_Default_Storage_Pool
4147 Prepend_List_To
(Aspect_Specifications
(N
),
4149 (Aspect_Specifications
(Gen_Spec
))));
4154 -- Save the instantiation node, for subsequent instantiation of the
4155 -- body, if there is one and we are generating code for the current
4156 -- unit. Mark unit as having a body (avoids premature error message).
4158 -- We instantiate the body if we are generating code, if we are
4159 -- generating cross-reference information, or if we are building
4160 -- trees for ASIS use or GNATprove use.
4163 Enclosing_Body_Present
: Boolean := False;
4164 -- If the generic unit is not a compilation unit, then a body may
4165 -- be present in its parent even if none is required. We create a
4166 -- tentative pending instantiation for the body, which will be
4167 -- discarded if none is actually present.
4172 if Scope
(Gen_Unit
) /= Standard_Standard
4173 and then not Is_Child_Unit
(Gen_Unit
)
4175 Scop
:= Scope
(Gen_Unit
);
4176 while Present
(Scop
) and then Scop
/= Standard_Standard
loop
4177 if Unit_Requires_Body
(Scop
) then
4178 Enclosing_Body_Present
:= True;
4181 elsif In_Open_Scopes
(Scop
)
4182 and then In_Package_Body
(Scop
)
4184 Enclosing_Body_Present
:= True;
4188 exit when Is_Compilation_Unit
(Scop
);
4189 Scop
:= Scope
(Scop
);
4193 -- If front-end inlining is enabled or there are any subprograms
4194 -- marked with Inline_Always, and this is a unit for which code
4195 -- will be generated, we instantiate the body at once.
4197 -- This is done if the instance is not the main unit, and if the
4198 -- generic is not a child unit of another generic, to avoid scope
4199 -- problems and the reinstallation of parent instances.
4202 and then (not Is_Child_Unit
(Gen_Unit
)
4203 or else not Is_Generic_Unit
(Scope
(Gen_Unit
)))
4204 and then Might_Inline_Subp
(Gen_Unit
)
4205 and then not Is_Actual_Pack
4207 if not Back_End_Inlining
4208 and then (Front_End_Inlining
or else Has_Inline_Always
)
4209 and then (Is_In_Main_Unit
(N
)
4210 or else In_Main_Context
(Current_Scope
))
4211 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit
4215 -- In configurable_run_time mode we force the inlining of
4216 -- predefined subprograms marked Inline_Always, to minimize
4217 -- the use of the run-time library.
4219 elsif In_Predefined_Unit
(Gen_Decl
)
4220 and then Configurable_Run_Time_Mode
4221 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit
4226 -- If the current scope is itself an instance within a child
4227 -- unit, there will be duplications in the scope stack, and the
4228 -- unstacking mechanism in Inline_Instance_Body will fail.
4229 -- This loses some rare cases of optimization, and might be
4230 -- improved some day, if we can find a proper abstraction for
4231 -- "the complete compilation context" that can be saved and
4234 if Is_Generic_Instance
(Current_Scope
) then
4236 Curr_Unit
: constant Entity_Id
:=
4237 Cunit_Entity
(Current_Sem_Unit
);
4239 if Curr_Unit
/= Current_Scope
4240 and then Is_Child_Unit
(Curr_Unit
)
4242 Inline_Now
:= False;
4249 (Unit_Requires_Body
(Gen_Unit
)
4250 or else Enclosing_Body_Present
4251 or else Present
(Corresponding_Body
(Gen_Decl
)))
4252 and then (Is_In_Main_Unit
(N
)
4253 or else Might_Inline_Subp
(Gen_Unit
))
4254 and then not Is_Actual_Pack
4255 and then not Inline_Now
4256 and then (Operating_Mode
= Generate_Code
4258 -- Need comment for this check ???
4260 or else (Operating_Mode
= Check_Semantics
4261 and then (ASIS_Mode
or GNATprove_Mode
)));
4263 -- If front-end inlining is enabled or there are any subprograms
4264 -- marked with Inline_Always, do not instantiate body when within
4265 -- a generic context.
4267 if ((Front_End_Inlining
or else Has_Inline_Always
)
4268 and then not Expander_Active
)
4269 or else Is_Generic_Unit
(Cunit_Entity
(Main_Unit
))
4271 Needs_Body
:= False;
4274 -- If the current context is generic, and the package being
4275 -- instantiated is declared within a formal package, there is no
4276 -- body to instantiate until the enclosing generic is instantiated
4277 -- and there is an actual for the formal package. If the formal
4278 -- package has parameters, we build a regular package instance for
4279 -- it, that precedes the original formal package declaration.
4281 if In_Open_Scopes
(Scope
(Scope
(Gen_Unit
))) then
4283 Decl
: constant Node_Id
:=
4285 (Unit_Declaration_Node
(Scope
(Gen_Unit
)));
4287 if Nkind
(Decl
) = N_Formal_Package_Declaration
4288 or else (Nkind
(Decl
) = N_Package_Declaration
4289 and then Is_List_Member
(Decl
)
4290 and then Present
(Next
(Decl
))
4292 Nkind
(Next
(Decl
)) =
4293 N_Formal_Package_Declaration
)
4295 Needs_Body
:= False;
4301 -- For RCI unit calling stubs, we omit the instance body if the
4302 -- instance is the RCI library unit itself.
4304 -- However there is a special case for nested instances: in this case
4305 -- we do generate the instance body, as it might be required, e.g.
4306 -- because it provides stream attributes for some type used in the
4307 -- profile of a remote subprogram. This is consistent with 12.3(12),
4308 -- which indicates that the instance body occurs at the place of the
4309 -- instantiation, and thus is part of the RCI declaration, which is
4310 -- present on all client partitions (this is E.2.3(18)).
4312 -- Note that AI12-0002 may make it illegal at some point to have
4313 -- stream attributes defined in an RCI unit, in which case this
4314 -- special case will become unnecessary. In the meantime, there
4315 -- is known application code in production that depends on this
4316 -- being possible, so we definitely cannot eliminate the body in
4317 -- the case of nested instances for the time being.
4319 -- When we generate a nested instance body, calling stubs for any
4320 -- relevant subprogram will be be inserted immediately after the
4321 -- subprogram declarations, and will take precedence over the
4322 -- subsequent (original) body. (The stub and original body will be
4323 -- complete homographs, but this is permitted in an instance).
4324 -- (Could we do better and remove the original body???)
4326 if Distribution_Stub_Mode
= Generate_Caller_Stub_Body
4327 and then Comes_From_Source
(N
)
4328 and then Nkind
(Parent
(N
)) = N_Compilation_Unit
4330 Needs_Body
:= False;
4335 -- Here is a defence against a ludicrous number of instantiations
4336 -- caused by a circular set of instantiation attempts.
4338 if Pending_Instantiations
.Last
> Maximum_Instantiations
then
4339 Error_Msg_Uint_1
:= UI_From_Int
(Maximum_Instantiations
);
4340 Error_Msg_N
("too many instantiations, exceeds max of^", N
);
4341 Error_Msg_N
("\limit can be changed using -gnateinn switch", N
);
4342 raise Unrecoverable_Error
;
4345 -- Indicate that the enclosing scopes contain an instantiation,
4346 -- and that cleanup actions should be delayed until after the
4347 -- instance body is expanded.
4349 Check_Forward_Instantiation
(Gen_Decl
);
4350 if Nkind
(N
) = N_Package_Instantiation
then
4352 Enclosing_Master
: Entity_Id
;
4355 -- Loop to search enclosing masters
4357 Enclosing_Master
:= Current_Scope
;
4358 Scope_Loop
: while Enclosing_Master
/= Standard_Standard
loop
4359 if Ekind
(Enclosing_Master
) = E_Package
then
4360 if Is_Compilation_Unit
(Enclosing_Master
) then
4361 if In_Package_Body
(Enclosing_Master
) then
4363 (Body_Entity
(Enclosing_Master
));
4372 Enclosing_Master
:= Scope
(Enclosing_Master
);
4375 elsif Is_Generic_Unit
(Enclosing_Master
)
4376 or else Ekind
(Enclosing_Master
) = E_Void
4378 -- Cleanup actions will eventually be performed on the
4379 -- enclosing subprogram or package instance, if any.
4380 -- Enclosing scope is void in the formal part of a
4381 -- generic subprogram.
4386 if Ekind
(Enclosing_Master
) = E_Entry
4388 Ekind
(Scope
(Enclosing_Master
)) = E_Protected_Type
4390 if not Expander_Active
then
4394 Protected_Body_Subprogram
(Enclosing_Master
);
4398 Set_Delay_Cleanups
(Enclosing_Master
);
4400 while Ekind
(Enclosing_Master
) = E_Block
loop
4401 Enclosing_Master
:= Scope
(Enclosing_Master
);
4404 if Is_Subprogram
(Enclosing_Master
) then
4405 Delay_Descriptors
(Enclosing_Master
);
4407 elsif Is_Task_Type
(Enclosing_Master
) then
4409 TBP
: constant Node_Id
:=
4410 Get_Task_Body_Procedure
4413 if Present
(TBP
) then
4414 Delay_Descriptors
(TBP
);
4415 Set_Delay_Cleanups
(TBP
);
4422 end loop Scope_Loop
;
4425 -- Make entry in table
4427 Add_Pending_Instantiation
(N
, Act_Decl
);
4431 Set_Categorization_From_Pragmas
(Act_Decl
);
4433 if Parent_Installed
then
4437 Set_Instance_Spec
(N
, Act_Decl
);
4439 -- If not a compilation unit, insert the package declaration before
4440 -- the original instantiation node.
4442 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
4443 Mark_Rewrite_Insertion
(Act_Decl
);
4444 Insert_Before
(N
, Act_Decl
);
4446 if Has_Aspects
(N
) then
4447 Analyze_Aspect_Specifications
(N
, Act_Decl_Id
);
4449 -- The pragma created for a Default_Storage_Pool aspect must
4450 -- appear ahead of the declarations in the instance spec.
4451 -- Analysis has placed it after the instance node, so remove
4452 -- it and reinsert it properly now.
4455 ASN
: constant Node_Id
:= First
(Aspect_Specifications
(N
));
4456 A_Name
: constant Name_Id
:= Chars
(Identifier
(ASN
));
4460 if A_Name
= Name_Default_Storage_Pool
then
4461 if No
(Visible_Declarations
(Act_Spec
)) then
4462 Set_Visible_Declarations
(Act_Spec
, New_List
);
4466 while Present
(Decl
) loop
4467 if Nkind
(Decl
) = N_Pragma
then
4469 Prepend
(Decl
, Visible_Declarations
(Act_Spec
));
4481 -- For an instantiation that is a compilation unit, place
4482 -- declaration on current node so context is complete for analysis
4483 -- (including nested instantiations). If this is the main unit,
4484 -- the declaration eventually replaces the instantiation node.
4485 -- If the instance body is created later, it replaces the
4486 -- instance node, and the declaration is attached to it
4487 -- (see Build_Instance_Compilation_Unit_Nodes).
4490 if Cunit_Entity
(Current_Sem_Unit
) = Defining_Entity
(N
) then
4492 -- The entity for the current unit is the newly created one,
4493 -- and all semantic information is attached to it.
4495 Set_Cunit_Entity
(Current_Sem_Unit
, Act_Decl_Id
);
4497 -- If this is the main unit, replace the main entity as well
4499 if Current_Sem_Unit
= Main_Unit
then
4500 Main_Unit_Entity
:= Act_Decl_Id
;
4504 Set_Unit
(Parent
(N
), Act_Decl
);
4505 Set_Parent_Spec
(Act_Decl
, Parent_Spec
(N
));
4506 Set_Package_Instantiation
(Act_Decl_Id
, N
);
4508 -- Process aspect specifications of the instance node, if any, to
4509 -- take into account categorization pragmas before analyzing the
4512 if Has_Aspects
(N
) then
4513 Analyze_Aspect_Specifications
(N
, Act_Decl_Id
);
4517 Set_Unit
(Parent
(N
), N
);
4518 Set_Body_Required
(Parent
(N
), False);
4520 -- We never need elaboration checks on instantiations, since by
4521 -- definition, the body instantiation is elaborated at the same
4522 -- time as the spec instantiation.
4524 Set_Suppress_Elaboration_Warnings
(Act_Decl_Id
);
4525 Set_Kill_Elaboration_Checks
(Act_Decl_Id
);
4528 Check_Elab_Instantiation
(N
);
4530 if ABE_Is_Certain
(N
) and then Needs_Body
then
4531 Pending_Instantiations
.Decrement_Last
;
4534 Check_Hidden_Child_Unit
(N
, Gen_Unit
, Act_Decl_Id
);
4536 Set_First_Private_Entity
(Defining_Unit_Name
(Unit_Renaming
),
4537 First_Private_Entity
(Act_Decl_Id
));
4539 -- If the instantiation will receive a body, the unit will be
4540 -- transformed into a package body, and receive its own elaboration
4541 -- entity. Otherwise, the nature of the unit is now a package
4544 if Nkind
(Parent
(N
)) = N_Compilation_Unit
4545 and then not Needs_Body
4547 Rewrite
(N
, Act_Decl
);
4550 if Present
(Corresponding_Body
(Gen_Decl
))
4551 or else Unit_Requires_Body
(Gen_Unit
)
4553 Set_Has_Completion
(Act_Decl_Id
);
4556 Check_Formal_Packages
(Act_Decl_Id
);
4558 Restore_Hidden_Primitives
(Vis_Prims_List
);
4559 Restore_Private_Views
(Act_Decl_Id
);
4561 Inherit_Context
(Gen_Decl
, N
);
4563 if Parent_Installed
then
4568 Env_Installed
:= False;
4571 Validate_Categorization_Dependency
(N
, Act_Decl_Id
);
4573 -- There used to be a check here to prevent instantiations in local
4574 -- contexts if the No_Local_Allocators restriction was active. This
4575 -- check was removed by a binding interpretation in AI-95-00130/07,
4576 -- but we retain the code for documentation purposes.
4578 -- if Ekind (Act_Decl_Id) /= E_Void
4579 -- and then not Is_Library_Level_Entity (Act_Decl_Id)
4581 -- Check_Restriction (No_Local_Allocators, N);
4585 Inline_Instance_Body
(N
, Gen_Unit
, Act_Decl
);
4588 -- The following is a tree patch for ASIS: ASIS needs separate nodes to
4589 -- be used as defining identifiers for a formal package and for the
4590 -- corresponding expanded package.
4592 if Nkind
(N
) = N_Formal_Package_Declaration
then
4593 Act_Decl_Id
:= New_Copy
(Defining_Entity
(N
));
4594 Set_Comes_From_Source
(Act_Decl_Id
, True);
4595 Set_Is_Generic_Instance
(Act_Decl_Id
, False);
4596 Set_Defining_Identifier
(N
, Act_Decl_Id
);
4599 -- Check that if N is an instantiation of System.Dim_Float_IO or
4600 -- System.Dim_Integer_IO, the formal type has a dimension system.
4602 if Nkind
(N
) = N_Package_Instantiation
4603 and then Is_Dim_IO_Package_Instantiation
(N
)
4606 Assoc
: constant Node_Id
:= First
(Generic_Associations
(N
));
4608 if not Has_Dimension_System
4609 (Etype
(Explicit_Generic_Actual_Parameter
(Assoc
)))
4611 Error_Msg_N
("type with a dimension system expected", Assoc
);
4617 if Has_Aspects
(N
) and then Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
4618 Analyze_Aspect_Specifications
(N
, Act_Decl_Id
);
4621 Ignore_SPARK_Mode_Pragmas_In_Instance
:= Saved_ISMP
;
4622 Restore_Ghost_Mode
(Saved_GM
);
4623 Restore_SPARK_Mode
(Saved_SM
, Saved_SMP
);
4624 Style_Check
:= Saved_Style_Check
;
4627 when Instantiation_Error
=>
4628 if Parent_Installed
then
4632 if Env_Installed
then
4636 Ignore_SPARK_Mode_Pragmas_In_Instance
:= Saved_ISMP
;
4637 Restore_Ghost_Mode
(Saved_GM
);
4638 Restore_SPARK_Mode
(Saved_SM
, Saved_SMP
);
4639 Style_Check
:= Saved_Style_Check
;
4640 end Analyze_Package_Instantiation
;
4642 --------------------------
4643 -- Inline_Instance_Body --
4644 --------------------------
4646 -- WARNING: This routine manages SPARK regions. Return statements must be
4647 -- replaced by gotos which jump to the end of the routine and restore the
4650 procedure Inline_Instance_Body
4652 Gen_Unit
: Entity_Id
;
4655 Curr_Comp
: constant Node_Id
:= Cunit
(Current_Sem_Unit
);
4656 Curr_Unit
: constant Entity_Id
:= Cunit_Entity
(Current_Sem_Unit
);
4657 Gen_Comp
: constant Entity_Id
:=
4658 Cunit_Entity
(Get_Source_Unit
(Gen_Unit
));
4660 Saved_SM
: constant SPARK_Mode_Type
:= SPARK_Mode
;
4661 Saved_SMP
: constant Node_Id
:= SPARK_Mode_Pragma
;
4662 -- Save the SPARK mode-related data to restore on exit. Removing
4663 -- enclosing scopes to provide a clean environment for analysis of
4664 -- the inlined body will eliminate any previously set SPARK_Mode.
4666 Scope_Stack_Depth
: constant Pos
:=
4667 Scope_Stack
.Last
- Scope_Stack
.First
+ 1;
4669 Inner_Scopes
: array (1 .. Scope_Stack_Depth
) of Entity_Id
;
4670 Instances
: array (1 .. Scope_Stack_Depth
) of Entity_Id
;
4671 Use_Clauses
: array (1 .. Scope_Stack_Depth
) of Node_Id
;
4673 Curr_Scope
: Entity_Id
:= Empty
;
4675 N_Instances
: Nat
:= 0;
4676 Num_Inner
: Nat
:= 0;
4677 Num_Scopes
: Nat
:= 0;
4678 Removed
: Boolean := False;
4683 -- Case of generic unit defined in another unit. We must remove the
4684 -- complete context of the current unit to install that of the generic.
4686 if Gen_Comp
/= Cunit_Entity
(Current_Sem_Unit
) then
4688 -- Add some comments for the following two loops ???
4691 while Present
(S
) and then S
/= Standard_Standard
loop
4693 Num_Scopes
:= Num_Scopes
+ 1;
4695 Use_Clauses
(Num_Scopes
) :=
4697 (Scope_Stack
.Last
- Num_Scopes
+ 1).
4699 End_Use_Clauses
(Use_Clauses
(Num_Scopes
));
4701 exit when Scope_Stack
.Last
- Num_Scopes
+ 1 = Scope_Stack
.First
4702 or else Scope_Stack
.Table
4703 (Scope_Stack
.Last
- Num_Scopes
).Entity
= Scope
(S
);
4706 exit when Is_Generic_Instance
(S
)
4707 and then (In_Package_Body
(S
)
4708 or else Ekind
(S
) = E_Procedure
4709 or else Ekind
(S
) = E_Function
);
4713 Vis
:= Is_Immediately_Visible
(Gen_Comp
);
4715 -- Find and save all enclosing instances
4720 and then S
/= Standard_Standard
4722 if Is_Generic_Instance
(S
) then
4723 N_Instances
:= N_Instances
+ 1;
4724 Instances
(N_Instances
) := S
;
4726 exit when In_Package_Body
(S
);
4732 -- Remove context of current compilation unit, unless we are within a
4733 -- nested package instantiation, in which case the context has been
4734 -- removed previously.
4736 -- If current scope is the body of a child unit, remove context of
4737 -- spec as well. If an enclosing scope is an instance body, the
4738 -- context has already been removed, but the entities in the body
4739 -- must be made invisible as well.
4742 while Present
(S
) and then S
/= Standard_Standard
loop
4743 if Is_Generic_Instance
(S
)
4744 and then (In_Package_Body
(S
)
4745 or else Ekind_In
(S
, E_Procedure
, E_Function
))
4747 -- We still have to remove the entities of the enclosing
4748 -- instance from direct visibility.
4753 E
:= First_Entity
(S
);
4754 while Present
(E
) loop
4755 Set_Is_Immediately_Visible
(E
, False);
4764 or else (Ekind
(Curr_Unit
) = E_Package_Body
4765 and then S
= Spec_Entity
(Curr_Unit
))
4766 or else (Ekind
(Curr_Unit
) = E_Subprogram_Body
4767 and then S
= Corresponding_Spec
4768 (Unit_Declaration_Node
(Curr_Unit
)))
4772 -- Remove entities in current scopes from visibility, so that
4773 -- instance body is compiled in a clean environment.
4775 List
:= Save_Scope_Stack
(Handle_Use
=> False);
4777 if Is_Child_Unit
(S
) then
4779 -- Remove child unit from stack, as well as inner scopes.
4780 -- Removing the context of a child unit removes parent units
4783 while Current_Scope
/= S
loop
4784 Num_Inner
:= Num_Inner
+ 1;
4785 Inner_Scopes
(Num_Inner
) := Current_Scope
;
4790 Remove_Context
(Curr_Comp
);
4794 Remove_Context
(Curr_Comp
);
4797 if Ekind
(Curr_Unit
) = E_Package_Body
then
4798 Remove_Context
(Library_Unit
(Curr_Comp
));
4805 pragma Assert
(Num_Inner
< Num_Scopes
);
4807 -- The inlined package body must be analyzed with the SPARK_Mode of
4808 -- the enclosing context, otherwise the body may cause bogus errors
4809 -- if a configuration SPARK_Mode pragma in in effect.
4811 Push_Scope
(Standard_Standard
);
4812 Scope_Stack
.Table
(Scope_Stack
.Last
).Is_Active_Stack_Base
:= True;
4813 Instantiate_Package_Body
4816 Act_Decl
=> Act_Decl
,
4817 Expander_Status
=> Expander_Active
,
4818 Current_Sem_Unit
=> Current_Sem_Unit
,
4819 Scope_Suppress
=> Scope_Suppress
,
4820 Local_Suppress_Stack_Top
=> Local_Suppress_Stack_Top
,
4821 Version
=> Ada_Version
,
4822 Version_Pragma
=> Ada_Version_Pragma
,
4823 Warnings
=> Save_Warnings
,
4824 SPARK_Mode
=> Saved_SM
,
4825 SPARK_Mode_Pragma
=> Saved_SMP
)),
4826 Inlined_Body
=> True);
4832 Set_Is_Immediately_Visible
(Gen_Comp
, Vis
);
4834 -- Reset Generic_Instance flag so that use clauses can be installed
4835 -- in the proper order. (See Use_One_Package for effect of enclosing
4836 -- instances on processing of use clauses).
4838 for J
in 1 .. N_Instances
loop
4839 Set_Is_Generic_Instance
(Instances
(J
), False);
4843 Install_Context
(Curr_Comp
, Chain
=> False);
4845 if Present
(Curr_Scope
)
4846 and then Is_Child_Unit
(Curr_Scope
)
4848 Push_Scope
(Curr_Scope
);
4849 Set_Is_Immediately_Visible
(Curr_Scope
);
4851 -- Finally, restore inner scopes as well
4853 for J
in reverse 1 .. Num_Inner
loop
4854 Push_Scope
(Inner_Scopes
(J
));
4858 Restore_Scope_Stack
(List
, Handle_Use
=> False);
4860 if Present
(Curr_Scope
)
4862 (In_Private_Part
(Curr_Scope
)
4863 or else In_Package_Body
(Curr_Scope
))
4865 -- Install private declaration of ancestor units, which are
4866 -- currently available. Restore_Scope_Stack and Install_Context
4867 -- only install the visible part of parents.
4872 Par
:= Scope
(Curr_Scope
);
4873 while (Present
(Par
)) and then Par
/= Standard_Standard
loop
4874 Install_Private_Declarations
(Par
);
4881 -- Restore use clauses. For a child unit, use clauses in the parents
4882 -- are restored when installing the context, so only those in inner
4883 -- scopes (and those local to the child unit itself) need to be
4884 -- installed explicitly.
4886 if Is_Child_Unit
(Curr_Unit
) and then Removed
then
4887 for J
in reverse 1 .. Num_Inner
+ 1 loop
4888 Scope_Stack
.Table
(Scope_Stack
.Last
- J
+ 1).First_Use_Clause
:=
4890 Install_Use_Clauses
(Use_Clauses
(J
));
4894 for J
in reverse 1 .. Num_Scopes
loop
4895 Scope_Stack
.Table
(Scope_Stack
.Last
- J
+ 1).First_Use_Clause
:=
4897 Install_Use_Clauses
(Use_Clauses
(J
));
4901 -- Restore status of instances. If one of them is a body, make its
4902 -- local entities visible again.
4909 for J
in 1 .. N_Instances
loop
4910 Inst
:= Instances
(J
);
4911 Set_Is_Generic_Instance
(Inst
, True);
4913 if In_Package_Body
(Inst
)
4914 or else Ekind_In
(S
, E_Procedure
, E_Function
)
4916 E
:= First_Entity
(Instances
(J
));
4917 while Present
(E
) loop
4918 Set_Is_Immediately_Visible
(E
);
4925 -- If generic unit is in current unit, current context is correct. Note
4926 -- that the context is guaranteed to carry the correct SPARK_Mode as no
4927 -- enclosing scopes were removed.
4930 Instantiate_Package_Body
4933 Act_Decl
=> Act_Decl
,
4934 Expander_Status
=> Expander_Active
,
4935 Current_Sem_Unit
=> Current_Sem_Unit
,
4936 Scope_Suppress
=> Scope_Suppress
,
4937 Local_Suppress_Stack_Top
=> Local_Suppress_Stack_Top
,
4938 Version
=> Ada_Version
,
4939 Version_Pragma
=> Ada_Version_Pragma
,
4940 Warnings
=> Save_Warnings
,
4941 SPARK_Mode
=> SPARK_Mode
,
4942 SPARK_Mode_Pragma
=> SPARK_Mode_Pragma
)),
4943 Inlined_Body
=> True);
4945 end Inline_Instance_Body
;
4947 -------------------------------------
4948 -- Analyze_Procedure_Instantiation --
4949 -------------------------------------
4951 procedure Analyze_Procedure_Instantiation
(N
: Node_Id
) is
4953 Analyze_Subprogram_Instantiation
(N
, E_Procedure
);
4954 end Analyze_Procedure_Instantiation
;
4956 -----------------------------------
4957 -- Need_Subprogram_Instance_Body --
4958 -----------------------------------
4960 function Need_Subprogram_Instance_Body
4962 Subp
: Entity_Id
) return Boolean
4964 function Is_Inlined_Or_Child_Of_Inlined
(E
: Entity_Id
) return Boolean;
4965 -- Return True if E is an inlined subprogram, an inlined renaming or a
4966 -- subprogram nested in an inlined subprogram. The inlining machinery
4967 -- totally disregards nested subprograms since it considers that they
4968 -- will always be compiled if the parent is (see Inline.Is_Nested).
4970 ------------------------------------
4971 -- Is_Inlined_Or_Child_Of_Inlined --
4972 ------------------------------------
4974 function Is_Inlined_Or_Child_Of_Inlined
(E
: Entity_Id
) return Boolean is
4978 if Is_Inlined
(E
) or else Is_Inlined
(Alias
(E
)) then
4983 while Scop
/= Standard_Standard
loop
4984 if Ekind
(Scop
) in Subprogram_Kind
and then Is_Inlined
(Scop
) then
4988 Scop
:= Scope
(Scop
);
4992 end Is_Inlined_Or_Child_Of_Inlined
;
4995 -- Must be in the main unit or inlined (or child of inlined)
4997 if (Is_In_Main_Unit
(N
) or else Is_Inlined_Or_Child_Of_Inlined
(Subp
))
4999 -- Must be generating code or analyzing code in ASIS/GNATprove mode
5001 and then (Operating_Mode
= Generate_Code
5002 or else (Operating_Mode
= Check_Semantics
5003 and then (ASIS_Mode
or GNATprove_Mode
)))
5005 -- The body is needed when generating code (full expansion), in ASIS
5006 -- mode for other tools, and in GNATprove mode (special expansion) for
5007 -- formal verification of the body itself.
5009 and then (Expander_Active
or ASIS_Mode
or GNATprove_Mode
)
5011 -- No point in inlining if ABE is inevitable
5013 and then not ABE_Is_Certain
(N
)
5015 -- Or if subprogram is eliminated
5017 and then not Is_Eliminated
(Subp
)
5019 Add_Pending_Instantiation
(N
, Unit_Declaration_Node
(Subp
));
5022 -- Here if not inlined, or we ignore the inlining
5027 end Need_Subprogram_Instance_Body
;
5029 --------------------------------------
5030 -- Analyze_Subprogram_Instantiation --
5031 --------------------------------------
5033 -- WARNING: This routine manages Ghost and SPARK regions. Return statements
5034 -- must be replaced by gotos which jump to the end of the routine in order
5035 -- to restore the Ghost and SPARK modes.
5037 procedure Analyze_Subprogram_Instantiation
5041 Loc
: constant Source_Ptr
:= Sloc
(N
);
5042 Gen_Id
: constant Node_Id
:= Name
(N
);
5044 Anon_Id
: constant Entity_Id
:=
5045 Make_Defining_Identifier
(Sloc
(Defining_Entity
(N
)),
5046 Chars
=> New_External_Name
5047 (Chars
(Defining_Entity
(N
)), 'R'));
5049 Act_Decl_Id
: Entity_Id
;
5054 Env_Installed
: Boolean := False;
5055 Gen_Unit
: Entity_Id
;
5057 Pack_Id
: Entity_Id
;
5058 Parent_Installed
: Boolean := False;
5060 Renaming_List
: List_Id
;
5061 -- The list of declarations that link formals and actuals of the
5062 -- instance. These are subtype declarations for formal types, and
5063 -- renaming declarations for other formals. The subprogram declaration
5064 -- for the instance is then appended to the list, and the last item on
5065 -- the list is the renaming declaration for the instance.
5067 procedure Analyze_Instance_And_Renamings
;
5068 -- The instance must be analyzed in a context that includes the mappings
5069 -- of generic parameters into actuals. We create a package declaration
5070 -- for this purpose, and a subprogram with an internal name within the
5071 -- package. The subprogram instance is simply an alias for the internal
5072 -- subprogram, declared in the current scope.
5074 procedure Build_Subprogram_Renaming
;
5075 -- If the subprogram is recursive, there are occurrences of the name of
5076 -- the generic within the body, which must resolve to the current
5077 -- instance. We add a renaming declaration after the declaration, which
5078 -- is available in the instance body, as well as in the analysis of
5079 -- aspects that appear in the generic. This renaming declaration is
5080 -- inserted after the instance declaration which it renames.
5082 ------------------------------------
5083 -- Analyze_Instance_And_Renamings --
5084 ------------------------------------
5086 procedure Analyze_Instance_And_Renamings
is
5087 Def_Ent
: constant Entity_Id
:= Defining_Entity
(N
);
5088 Pack_Decl
: Node_Id
;
5091 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
5093 -- For the case of a compilation unit, the container package has
5094 -- the same name as the instantiation, to insure that the binder
5095 -- calls the elaboration procedure with the right name. Copy the
5096 -- entity of the instance, which may have compilation level flags
5097 -- (e.g. Is_Child_Unit) set.
5099 Pack_Id
:= New_Copy
(Def_Ent
);
5102 -- Otherwise we use the name of the instantiation concatenated
5103 -- with its source position to ensure uniqueness if there are
5104 -- several instantiations with the same name.
5107 Make_Defining_Identifier
(Loc
,
5108 Chars
=> New_External_Name
5109 (Related_Id
=> Chars
(Def_Ent
),
5111 Suffix_Index
=> Source_Offset
(Sloc
(Def_Ent
))));
5115 Make_Package_Declaration
(Loc
,
5116 Specification
=> Make_Package_Specification
(Loc
,
5117 Defining_Unit_Name
=> Pack_Id
,
5118 Visible_Declarations
=> Renaming_List
,
5119 End_Label
=> Empty
));
5121 Set_Instance_Spec
(N
, Pack_Decl
);
5122 Set_Is_Generic_Instance
(Pack_Id
);
5123 Set_Debug_Info_Needed
(Pack_Id
);
5125 -- Case of not a compilation unit
5127 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
5128 Mark_Rewrite_Insertion
(Pack_Decl
);
5129 Insert_Before
(N
, Pack_Decl
);
5130 Set_Has_Completion
(Pack_Id
);
5132 -- Case of an instantiation that is a compilation unit
5134 -- Place declaration on current node so context is complete for
5135 -- analysis (including nested instantiations), and for use in a
5136 -- context_clause (see Analyze_With_Clause).
5139 Set_Unit
(Parent
(N
), Pack_Decl
);
5140 Set_Parent_Spec
(Pack_Decl
, Parent_Spec
(N
));
5143 Analyze
(Pack_Decl
);
5144 Check_Formal_Packages
(Pack_Id
);
5145 Set_Is_Generic_Instance
(Pack_Id
, False);
5147 -- Why do we clear Is_Generic_Instance??? We set it 20 lines
5150 -- Body of the enclosing package is supplied when instantiating the
5151 -- subprogram body, after semantic analysis is completed.
5153 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
5155 -- Remove package itself from visibility, so it does not
5156 -- conflict with subprogram.
5158 Set_Name_Entity_Id
(Chars
(Pack_Id
), Homonym
(Pack_Id
));
5160 -- Set name and scope of internal subprogram so that the proper
5161 -- external name will be generated. The proper scope is the scope
5162 -- of the wrapper package. We need to generate debugging info for
5163 -- the internal subprogram, so set flag accordingly.
5165 Set_Chars
(Anon_Id
, Chars
(Defining_Entity
(N
)));
5166 Set_Scope
(Anon_Id
, Scope
(Pack_Id
));
5168 -- Mark wrapper package as referenced, to avoid spurious warnings
5169 -- if the instantiation appears in various with_ clauses of
5170 -- subunits of the main unit.
5172 Set_Referenced
(Pack_Id
);
5175 Set_Is_Generic_Instance
(Anon_Id
);
5176 Set_Debug_Info_Needed
(Anon_Id
);
5177 Act_Decl_Id
:= New_Copy
(Anon_Id
);
5179 Set_Parent
(Act_Decl_Id
, Parent
(Anon_Id
));
5180 Set_Chars
(Act_Decl_Id
, Chars
(Defining_Entity
(N
)));
5181 Set_Sloc
(Act_Decl_Id
, Sloc
(Defining_Entity
(N
)));
5183 -- Subprogram instance comes from source only if generic does
5185 Set_Comes_From_Source
(Act_Decl_Id
, Comes_From_Source
(Gen_Unit
));
5187 -- If the instance is a child unit, mark the Id accordingly. Mark
5188 -- the anonymous entity as well, which is the real subprogram and
5189 -- which is used when the instance appears in a context clause.
5190 -- Similarly, propagate the Is_Eliminated flag to handle properly
5191 -- nested eliminated subprograms.
5193 Set_Is_Child_Unit
(Act_Decl_Id
, Is_Child_Unit
(Defining_Entity
(N
)));
5194 Set_Is_Child_Unit
(Anon_Id
, Is_Child_Unit
(Defining_Entity
(N
)));
5195 New_Overloaded_Entity
(Act_Decl_Id
);
5196 Check_Eliminated
(Act_Decl_Id
);
5197 Set_Is_Eliminated
(Anon_Id
, Is_Eliminated
(Act_Decl_Id
));
5199 -- In compilation unit case, kill elaboration checks on the
5200 -- instantiation, since they are never needed -- the body is
5201 -- instantiated at the same point as the spec.
5203 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
5204 Set_Suppress_Elaboration_Warnings
(Act_Decl_Id
);
5205 Set_Kill_Elaboration_Checks
(Act_Decl_Id
);
5206 Set_Is_Compilation_Unit
(Anon_Id
);
5208 Set_Cunit_Entity
(Current_Sem_Unit
, Pack_Id
);
5211 -- The instance is not a freezing point for the new subprogram.
5212 -- The anonymous subprogram may have a freeze node, created for
5213 -- some delayed aspects. This freeze node must not be inherited
5214 -- by the visible subprogram entity.
5216 Set_Is_Frozen
(Act_Decl_Id
, False);
5217 Set_Freeze_Node
(Act_Decl_Id
, Empty
);
5219 if Nkind
(Defining_Entity
(N
)) = N_Defining_Operator_Symbol
then
5220 Valid_Operator_Definition
(Act_Decl_Id
);
5223 Set_Alias
(Act_Decl_Id
, Anon_Id
);
5224 Set_Parent
(Act_Decl_Id
, Parent
(Anon_Id
));
5225 Set_Has_Completion
(Act_Decl_Id
);
5226 Set_Related_Instance
(Pack_Id
, Act_Decl_Id
);
5228 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
5229 Set_Body_Required
(Parent
(N
), False);
5231 end Analyze_Instance_And_Renamings
;
5233 -------------------------------
5234 -- Build_Subprogram_Renaming --
5235 -------------------------------
5237 procedure Build_Subprogram_Renaming
is
5238 Renaming_Decl
: Node_Id
;
5239 Unit_Renaming
: Node_Id
;
5243 Make_Subprogram_Renaming_Declaration
(Loc
,
5246 (Specification
(Original_Node
(Gen_Decl
)),
5248 Instantiating
=> True),
5249 Name
=> New_Occurrence_Of
(Anon_Id
, Loc
));
5251 -- The generic may be a a child unit. The renaming needs an
5252 -- identifier with the proper name.
5254 Set_Defining_Unit_Name
(Specification
(Unit_Renaming
),
5255 Make_Defining_Identifier
(Loc
, Chars
(Gen_Unit
)));
5257 -- If there is a formal subprogram with the same name as the unit
5258 -- itself, do not add this renaming declaration, to prevent
5259 -- ambiguities when there is a call with that name in the body.
5260 -- This is a partial and ugly fix for one ACATS test. ???
5262 Renaming_Decl
:= First
(Renaming_List
);
5263 while Present
(Renaming_Decl
) loop
5264 if Nkind
(Renaming_Decl
) = N_Subprogram_Renaming_Declaration
5266 Chars
(Defining_Entity
(Renaming_Decl
)) = Chars
(Gen_Unit
)
5271 Next
(Renaming_Decl
);
5274 if No
(Renaming_Decl
) then
5275 Append
(Unit_Renaming
, Renaming_List
);
5277 end Build_Subprogram_Renaming
;
5281 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
5282 Saved_ISMP
: constant Boolean :=
5283 Ignore_SPARK_Mode_Pragmas_In_Instance
;
5284 Saved_SM
: constant SPARK_Mode_Type
:= SPARK_Mode
;
5285 Saved_SMP
: constant Node_Id
:= SPARK_Mode_Pragma
;
5286 -- Save the Ghost and SPARK mode-related data to restore on exit
5288 Vis_Prims_List
: Elist_Id
:= No_Elist
;
5289 -- List of primitives made temporarily visible in the instantiation
5290 -- to match the visibility of the formal type
5292 -- Start of processing for Analyze_Subprogram_Instantiation
5295 Check_SPARK_05_Restriction
("generic is not allowed", N
);
5297 -- Very first thing: check for special Text_IO unit in case we are
5298 -- instantiating one of the children of [[Wide_]Wide_]Text_IO. Of course
5299 -- such an instantiation is bogus (these are packages, not subprograms),
5300 -- but we get a better error message if we do this.
5302 Check_Text_IO_Special_Unit
(Gen_Id
);
5304 -- Make node global for error reporting
5306 Instantiation_Node
:= N
;
5308 -- For package instantiations we turn off style checks, because they
5309 -- will have been emitted in the generic. For subprogram instantiations
5310 -- we want to apply at least the check on overriding indicators so we
5311 -- do not modify the style check status.
5313 -- The renaming declarations for the actuals do not come from source and
5314 -- will not generate spurious warnings.
5316 Preanalyze_Actuals
(N
);
5319 Env_Installed
:= True;
5320 Check_Generic_Child_Unit
(Gen_Id
, Parent_Installed
);
5321 Gen_Unit
:= Entity
(Gen_Id
);
5323 -- A subprogram instantiation is Ghost when it is subject to pragma
5324 -- Ghost or the generic template is Ghost. Set the mode now to ensure
5325 -- that any nodes generated during analysis and expansion are marked as
5328 Mark_And_Set_Ghost_Instantiation
(N
, Gen_Unit
);
5330 Generate_Reference
(Gen_Unit
, Gen_Id
);
5332 if Nkind
(Gen_Id
) = N_Identifier
5333 and then Chars
(Gen_Unit
) = Chars
(Defining_Entity
(N
))
5336 ("& is hidden within declaration of instance", Gen_Id
, Gen_Unit
);
5339 if Etype
(Gen_Unit
) = Any_Type
then
5344 -- Verify that it is a generic subprogram of the right kind, and that
5345 -- it does not lead to a circular instantiation.
5347 if K
= E_Procedure
and then Ekind
(Gen_Unit
) /= E_Generic_Procedure
then
5349 ("& is not the name of a generic procedure", Gen_Id
, Gen_Unit
);
5351 elsif K
= E_Function
and then Ekind
(Gen_Unit
) /= E_Generic_Function
then
5353 ("& is not the name of a generic function", Gen_Id
, Gen_Unit
);
5355 elsif In_Open_Scopes
(Gen_Unit
) then
5356 Error_Msg_NE
("instantiation of & within itself", N
, Gen_Unit
);
5359 Set_Entity
(Gen_Id
, Gen_Unit
);
5360 Set_Is_Instantiated
(Gen_Unit
);
5362 if In_Extended_Main_Source_Unit
(N
) then
5363 Generate_Reference
(Gen_Unit
, N
);
5366 -- If renaming, get original unit
5368 if Present
(Renamed_Object
(Gen_Unit
))
5369 and then Ekind_In
(Renamed_Object
(Gen_Unit
), E_Generic_Procedure
,
5372 Gen_Unit
:= Renamed_Object
(Gen_Unit
);
5373 Set_Is_Instantiated
(Gen_Unit
);
5374 Generate_Reference
(Gen_Unit
, N
);
5377 if Contains_Instance_Of
(Gen_Unit
, Current_Scope
, Gen_Id
) then
5378 Error_Msg_Node_2
:= Current_Scope
;
5380 ("circular Instantiation: & instantiated in &!", N
, Gen_Unit
);
5381 Circularity_Detected
:= True;
5382 Restore_Hidden_Primitives
(Vis_Prims_List
);
5386 Gen_Decl
:= Unit_Declaration_Node
(Gen_Unit
);
5388 -- Initialize renamings map, for error checking
5390 Generic_Renamings
.Set_Last
(0);
5391 Generic_Renamings_HTable
.Reset
;
5393 Create_Instantiation_Source
(N
, Gen_Unit
, S_Adjustment
);
5395 -- Copy original generic tree, to produce text for instantiation
5399 (Original_Node
(Gen_Decl
), Empty
, Instantiating
=> True);
5401 -- Inherit overriding indicator from instance node
5403 Act_Spec
:= Specification
(Act_Tree
);
5404 Set_Must_Override
(Act_Spec
, Must_Override
(N
));
5405 Set_Must_Not_Override
(Act_Spec
, Must_Not_Override
(N
));
5408 Analyze_Associations
5410 Formals
=> Generic_Formal_Declarations
(Act_Tree
),
5411 F_Copy
=> Generic_Formal_Declarations
(Gen_Decl
));
5413 Vis_Prims_List
:= Check_Hidden_Primitives
(Renaming_List
);
5415 -- The subprogram itself cannot contain a nested instance, so the
5416 -- current parent is left empty.
5418 Set_Instance_Env
(Gen_Unit
, Empty
);
5420 -- Build the subprogram declaration, which does not appear in the
5421 -- generic template, and give it a sloc consistent with that of the
5424 Set_Defining_Unit_Name
(Act_Spec
, Anon_Id
);
5425 Set_Generic_Parent
(Act_Spec
, Gen_Unit
);
5427 Make_Subprogram_Declaration
(Sloc
(Act_Spec
),
5428 Specification
=> Act_Spec
);
5430 -- The aspects have been copied previously, but they have to be
5431 -- linked explicitly to the new subprogram declaration. Explicit
5432 -- pre/postconditions on the instance are analyzed below, in a
5435 Move_Aspects
(Act_Tree
, To
=> Act_Decl
);
5436 Set_Categorization_From_Pragmas
(Act_Decl
);
5438 if Parent_Installed
then
5442 Append
(Act_Decl
, Renaming_List
);
5444 -- Contract-related source pragmas that follow a generic subprogram
5445 -- must be instantiated explicitly because they are not part of the
5446 -- subprogram template.
5448 Instantiate_Subprogram_Contract
5449 (Original_Node
(Gen_Decl
), Renaming_List
);
5451 Build_Subprogram_Renaming
;
5453 -- If the context of the instance is subject to SPARK_Mode "off" or
5454 -- the annotation is altogether missing, set the global flag which
5455 -- signals Analyze_Pragma to ignore all SPARK_Mode pragmas within
5456 -- the instance. This should be done prior to analyzing the instance.
5458 if SPARK_Mode
/= On
then
5459 Ignore_SPARK_Mode_Pragmas_In_Instance
:= True;
5462 -- If the context of an instance is not subject to SPARK_Mode "off",
5463 -- and the generic spec is subject to an explicit SPARK_Mode pragma,
5464 -- the latter should be the one applicable to the instance.
5466 if not Ignore_SPARK_Mode_Pragmas_In_Instance
5467 and then Saved_SM
/= Off
5468 and then Present
(SPARK_Pragma
(Gen_Unit
))
5470 Set_SPARK_Mode
(Gen_Unit
);
5473 Analyze_Instance_And_Renamings
;
5475 -- Restore SPARK_Mode from the context after analysis of the package
5476 -- declaration, so that the SPARK_Mode on the generic spec does not
5477 -- apply to the pending instance for the instance body.
5479 if not Ignore_SPARK_Mode_Pragmas_In_Instance
5480 and then Saved_SM
/= Off
5481 and then Present
(SPARK_Pragma
(Gen_Unit
))
5483 Restore_SPARK_Mode
(Saved_SM
, Saved_SMP
);
5486 -- If the generic is marked Import (Intrinsic), then so is the
5487 -- instance. This indicates that there is no body to instantiate. If
5488 -- generic is marked inline, so it the instance, and the anonymous
5489 -- subprogram it renames. If inlined, or else if inlining is enabled
5490 -- for the compilation, we generate the instance body even if it is
5491 -- not within the main unit.
5493 if Is_Intrinsic_Subprogram
(Gen_Unit
) then
5494 Set_Is_Intrinsic_Subprogram
(Anon_Id
);
5495 Set_Is_Intrinsic_Subprogram
(Act_Decl_Id
);
5497 if Chars
(Gen_Unit
) = Name_Unchecked_Conversion
then
5498 Validate_Unchecked_Conversion
(N
, Act_Decl_Id
);
5502 -- Inherit convention from generic unit. Intrinsic convention, as for
5503 -- an instance of unchecked conversion, is not inherited because an
5504 -- explicit Ada instance has been created.
5506 if Has_Convention_Pragma
(Gen_Unit
)
5507 and then Convention
(Gen_Unit
) /= Convention_Intrinsic
5509 Set_Convention
(Act_Decl_Id
, Convention
(Gen_Unit
));
5510 Set_Is_Exported
(Act_Decl_Id
, Is_Exported
(Gen_Unit
));
5513 Generate_Definition
(Act_Decl_Id
);
5515 -- Inherit all inlining-related flags which apply to the generic in
5516 -- the subprogram and its declaration.
5518 Set_Is_Inlined
(Act_Decl_Id
, Is_Inlined
(Gen_Unit
));
5519 Set_Is_Inlined
(Anon_Id
, Is_Inlined
(Gen_Unit
));
5521 Set_Has_Pragma_Inline
(Act_Decl_Id
, Has_Pragma_Inline
(Gen_Unit
));
5522 Set_Has_Pragma_Inline
(Anon_Id
, Has_Pragma_Inline
(Gen_Unit
));
5524 -- Propagate No_Return if pragma applied to generic unit. This must
5525 -- be done explicitly because pragma does not appear in generic
5526 -- declaration (unlike the aspect case).
5528 if No_Return
(Gen_Unit
) then
5529 Set_No_Return
(Act_Decl_Id
);
5530 Set_No_Return
(Anon_Id
);
5533 Set_Has_Pragma_Inline_Always
5534 (Act_Decl_Id
, Has_Pragma_Inline_Always
(Gen_Unit
));
5535 Set_Has_Pragma_Inline_Always
5536 (Anon_Id
, Has_Pragma_Inline_Always
(Gen_Unit
));
5538 -- Mark both the instance spec and the anonymous package in case the
5539 -- body is instantiated at a later pass. This preserves the original
5540 -- context in effect for the body.
5542 if SPARK_Mode
/= On
then
5543 Set_Ignore_SPARK_Mode_Pragmas
(Act_Decl_Id
);
5544 Set_Ignore_SPARK_Mode_Pragmas
(Anon_Id
);
5547 if not Is_Intrinsic_Subprogram
(Gen_Unit
) then
5548 Check_Elab_Instantiation
(N
);
5551 if Is_Dispatching_Operation
(Act_Decl_Id
)
5552 and then Ada_Version
>= Ada_2005
5558 Formal
:= First_Formal
(Act_Decl_Id
);
5559 while Present
(Formal
) loop
5560 if Ekind
(Etype
(Formal
)) = E_Anonymous_Access_Type
5561 and then Is_Controlling_Formal
(Formal
)
5562 and then not Can_Never_Be_Null
(Formal
)
5565 ("access parameter& is controlling,", N
, Formal
);
5567 ("\corresponding parameter of & must be explicitly "
5568 & "null-excluding", N
, Gen_Id
);
5571 Next_Formal
(Formal
);
5576 Check_Hidden_Child_Unit
(N
, Gen_Unit
, Act_Decl_Id
);
5578 Validate_Categorization_Dependency
(N
, Act_Decl_Id
);
5580 if not Is_Intrinsic_Subprogram
(Act_Decl_Id
) then
5581 Inherit_Context
(Gen_Decl
, N
);
5583 Restore_Private_Views
(Pack_Id
, False);
5585 -- If the context requires a full instantiation, mark node for
5586 -- subsequent construction of the body.
5588 if Need_Subprogram_Instance_Body
(N
, Act_Decl_Id
) then
5589 Check_Forward_Instantiation
(Gen_Decl
);
5591 -- The wrapper package is always delayed, because it does not
5592 -- constitute a freeze point, but to insure that the freeze node
5593 -- is placed properly, it is created directly when instantiating
5594 -- the body (otherwise the freeze node might appear to early for
5595 -- nested instantiations). For ASIS purposes, indicate that the
5596 -- wrapper package has replaced the instantiation node.
5598 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
then
5599 Rewrite
(N
, Unit
(Parent
(N
)));
5600 Set_Unit
(Parent
(N
), N
);
5603 -- Replace instance node for library-level instantiations of
5604 -- intrinsic subprograms, for ASIS use.
5606 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
then
5607 Rewrite
(N
, Unit
(Parent
(N
)));
5608 Set_Unit
(Parent
(N
), N
);
5611 if Parent_Installed
then
5615 Restore_Hidden_Primitives
(Vis_Prims_List
);
5617 Env_Installed
:= False;
5618 Generic_Renamings
.Set_Last
(0);
5619 Generic_Renamings_HTable
.Reset
;
5623 if Has_Aspects
(N
) then
5624 Analyze_Aspect_Specifications
(N
, Act_Decl_Id
);
5627 Ignore_SPARK_Mode_Pragmas_In_Instance
:= Saved_ISMP
;
5628 Restore_Ghost_Mode
(Saved_GM
);
5629 Restore_SPARK_Mode
(Saved_SM
, Saved_SMP
);
5632 when Instantiation_Error
=>
5633 if Parent_Installed
then
5637 if Env_Installed
then
5641 Ignore_SPARK_Mode_Pragmas_In_Instance
:= Saved_ISMP
;
5642 Restore_Ghost_Mode
(Saved_GM
);
5643 Restore_SPARK_Mode
(Saved_SM
, Saved_SMP
);
5644 end Analyze_Subprogram_Instantiation
;
5646 -------------------------
5647 -- Get_Associated_Node --
5648 -------------------------
5650 function Get_Associated_Node
(N
: Node_Id
) return Node_Id
is
5654 Assoc
:= Associated_Node
(N
);
5656 if Nkind
(Assoc
) /= Nkind
(N
) then
5659 elsif Nkind_In
(Assoc
, N_Aggregate
, N_Extension_Aggregate
) then
5663 -- If the node is part of an inner generic, it may itself have been
5664 -- remapped into a further generic copy. Associated_Node is otherwise
5665 -- used for the entity of the node, and will be of a different node
5666 -- kind, or else N has been rewritten as a literal or function call.
5668 while Present
(Associated_Node
(Assoc
))
5669 and then Nkind
(Associated_Node
(Assoc
)) = Nkind
(Assoc
)
5671 Assoc
:= Associated_Node
(Assoc
);
5674 -- Follow an additional link in case the final node was rewritten.
5675 -- This can only happen with nested generic units.
5677 if (Nkind
(Assoc
) = N_Identifier
or else Nkind
(Assoc
) in N_Op
)
5678 and then Present
(Associated_Node
(Assoc
))
5679 and then (Nkind_In
(Associated_Node
(Assoc
), N_Function_Call
,
5680 N_Explicit_Dereference
,
5685 Assoc
:= Associated_Node
(Assoc
);
5688 -- An additional special case: an unconstrained type in an object
5689 -- declaration may have been rewritten as a local subtype constrained
5690 -- by the expression in the declaration. We need to recover the
5691 -- original entity, which may be global.
5693 if Present
(Original_Node
(Assoc
))
5694 and then Nkind
(Parent
(N
)) = N_Object_Declaration
5696 Assoc
:= Original_Node
(Assoc
);
5701 end Get_Associated_Node
;
5703 ----------------------------
5704 -- Build_Function_Wrapper --
5705 ----------------------------
5707 function Build_Function_Wrapper
5708 (Formal_Subp
: Entity_Id
;
5709 Actual_Subp
: Entity_Id
) return Node_Id
5711 Loc
: constant Source_Ptr
:= Sloc
(Current_Scope
);
5712 Ret_Type
: constant Entity_Id
:= Get_Instance_Of
(Etype
(Formal_Subp
));
5715 Func_Name
: Node_Id
;
5717 Parm_Type
: Node_Id
;
5718 Profile
: List_Id
:= New_List
;
5725 Func_Name
:= New_Occurrence_Of
(Actual_Subp
, Loc
);
5727 Func
:= Make_Defining_Identifier
(Loc
, Chars
(Formal_Subp
));
5728 Set_Ekind
(Func
, E_Function
);
5729 Set_Is_Generic_Actual_Subprogram
(Func
);
5731 Actuals
:= New_List
;
5732 Profile
:= New_List
;
5734 Act_F
:= First_Formal
(Actual_Subp
);
5735 Form_F
:= First_Formal
(Formal_Subp
);
5736 while Present
(Form_F
) loop
5738 -- Create new formal for profile of wrapper, and add a reference
5739 -- to it in the list of actuals for the enclosing call. The name
5740 -- must be that of the formal in the formal subprogram, because
5741 -- calls to it in the generic body may use named associations.
5743 New_F
:= Make_Defining_Identifier
(Loc
, Chars
(Form_F
));
5746 New_Occurrence_Of
(Get_Instance_Of
(Etype
(Form_F
)), Loc
);
5749 Make_Parameter_Specification
(Loc
,
5750 Defining_Identifier
=> New_F
,
5751 Parameter_Type
=> Parm_Type
));
5753 Append_To
(Actuals
, New_Occurrence_Of
(New_F
, Loc
));
5754 Next_Formal
(Form_F
);
5756 if Present
(Act_F
) then
5757 Next_Formal
(Act_F
);
5762 Make_Function_Specification
(Loc
,
5763 Defining_Unit_Name
=> Func
,
5764 Parameter_Specifications
=> Profile
,
5765 Result_Definition
=> New_Occurrence_Of
(Ret_Type
, Loc
));
5768 Make_Expression_Function
(Loc
,
5769 Specification
=> Spec
,
5771 Make_Function_Call
(Loc
,
5773 Parameter_Associations
=> Actuals
));
5776 end Build_Function_Wrapper
;
5778 ----------------------------
5779 -- Build_Operator_Wrapper --
5780 ----------------------------
5782 function Build_Operator_Wrapper
5783 (Formal_Subp
: Entity_Id
;
5784 Actual_Subp
: Entity_Id
) return Node_Id
5786 Loc
: constant Source_Ptr
:= Sloc
(Current_Scope
);
5787 Ret_Type
: constant Entity_Id
:=
5788 Get_Instance_Of
(Etype
(Formal_Subp
));
5789 Op_Type
: constant Entity_Id
:=
5790 Get_Instance_Of
(Etype
(First_Formal
(Formal_Subp
)));
5791 Is_Binary
: constant Boolean :=
5792 Present
(Next_Formal
(First_Formal
(Formal_Subp
)));
5796 pragma Warnings
(Off
, Expr
);
5804 Op_Name
:= Chars
(Actual_Subp
);
5806 -- Create entities for wrapper function and its formals
5808 F1
:= Make_Temporary
(Loc
, 'A');
5809 F2
:= Make_Temporary
(Loc
, 'B');
5810 L
:= New_Occurrence_Of
(F1
, Loc
);
5811 R
:= New_Occurrence_Of
(F2
, Loc
);
5813 Func
:= Make_Defining_Identifier
(Loc
, Chars
(Formal_Subp
));
5814 Set_Ekind
(Func
, E_Function
);
5815 Set_Is_Generic_Actual_Subprogram
(Func
);
5818 Make_Function_Specification
(Loc
,
5819 Defining_Unit_Name
=> Func
,
5820 Parameter_Specifications
=> New_List
(
5821 Make_Parameter_Specification
(Loc
,
5822 Defining_Identifier
=> F1
,
5823 Parameter_Type
=> New_Occurrence_Of
(Op_Type
, Loc
))),
5824 Result_Definition
=> New_Occurrence_Of
(Ret_Type
, Loc
));
5827 Append_To
(Parameter_Specifications
(Spec
),
5828 Make_Parameter_Specification
(Loc
,
5829 Defining_Identifier
=> F2
,
5830 Parameter_Type
=> New_Occurrence_Of
(Op_Type
, Loc
)));
5833 -- Build expression as a function call, or as an operator node
5834 -- that corresponds to the name of the actual, starting with
5835 -- binary operators.
5837 if Op_Name
not in Any_Operator_Name
then
5839 Make_Function_Call
(Loc
,
5841 New_Occurrence_Of
(Actual_Subp
, Loc
),
5842 Parameter_Associations
=> New_List
(L
));
5845 Append_To
(Parameter_Associations
(Expr
), R
);
5850 elsif Is_Binary
then
5851 if Op_Name
= Name_Op_And
then
5852 Expr
:= Make_Op_And
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
5853 elsif Op_Name
= Name_Op_Or
then
5854 Expr
:= Make_Op_Or
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
5855 elsif Op_Name
= Name_Op_Xor
then
5856 Expr
:= Make_Op_Xor
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
5857 elsif Op_Name
= Name_Op_Eq
then
5858 Expr
:= Make_Op_Eq
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
5859 elsif Op_Name
= Name_Op_Ne
then
5860 Expr
:= Make_Op_Ne
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
5861 elsif Op_Name
= Name_Op_Le
then
5862 Expr
:= Make_Op_Le
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
5863 elsif Op_Name
= Name_Op_Gt
then
5864 Expr
:= Make_Op_Gt
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
5865 elsif Op_Name
= Name_Op_Ge
then
5866 Expr
:= Make_Op_Ge
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
5867 elsif Op_Name
= Name_Op_Lt
then
5868 Expr
:= Make_Op_Lt
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
5869 elsif Op_Name
= Name_Op_Add
then
5870 Expr
:= Make_Op_Add
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
5871 elsif Op_Name
= Name_Op_Subtract
then
5872 Expr
:= Make_Op_Subtract
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
5873 elsif Op_Name
= Name_Op_Concat
then
5874 Expr
:= Make_Op_Concat
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
5875 elsif Op_Name
= Name_Op_Multiply
then
5876 Expr
:= Make_Op_Multiply
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
5877 elsif Op_Name
= Name_Op_Divide
then
5878 Expr
:= Make_Op_Divide
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
5879 elsif Op_Name
= Name_Op_Mod
then
5880 Expr
:= Make_Op_Mod
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
5881 elsif Op_Name
= Name_Op_Rem
then
5882 Expr
:= Make_Op_Rem
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
5883 elsif Op_Name
= Name_Op_Expon
then
5884 Expr
:= Make_Op_Expon
(Loc
, Left_Opnd
=> L
, Right_Opnd
=> R
);
5890 if Op_Name
= Name_Op_Add
then
5891 Expr
:= Make_Op_Plus
(Loc
, Right_Opnd
=> L
);
5892 elsif Op_Name
= Name_Op_Subtract
then
5893 Expr
:= Make_Op_Minus
(Loc
, Right_Opnd
=> L
);
5894 elsif Op_Name
= Name_Op_Abs
then
5895 Expr
:= Make_Op_Abs
(Loc
, Right_Opnd
=> L
);
5896 elsif Op_Name
= Name_Op_Not
then
5897 Expr
:= Make_Op_Not
(Loc
, Right_Opnd
=> L
);
5902 Make_Expression_Function
(Loc
,
5903 Specification
=> Spec
,
5904 Expression
=> Expr
);
5907 end Build_Operator_Wrapper
;
5909 -------------------------------------------
5910 -- Build_Instance_Compilation_Unit_Nodes --
5911 -------------------------------------------
5913 procedure Build_Instance_Compilation_Unit_Nodes
5918 Decl_Cunit
: Node_Id
;
5919 Body_Cunit
: Node_Id
;
5921 New_Main
: constant Entity_Id
:= Defining_Entity
(Act_Decl
);
5922 Old_Main
: constant Entity_Id
:= Cunit_Entity
(Main_Unit
);
5925 -- A new compilation unit node is built for the instance declaration
5928 Make_Compilation_Unit
(Sloc
(N
),
5929 Context_Items
=> Empty_List
,
5931 Aux_Decls_Node
=> Make_Compilation_Unit_Aux
(Sloc
(N
)));
5933 Set_Parent_Spec
(Act_Decl
, Parent_Spec
(N
));
5935 -- The new compilation unit is linked to its body, but both share the
5936 -- same file, so we do not set Body_Required on the new unit so as not
5937 -- to create a spurious dependency on a non-existent body in the ali.
5938 -- This simplifies CodePeer unit traversal.
5940 -- We use the original instantiation compilation unit as the resulting
5941 -- compilation unit of the instance, since this is the main unit.
5943 Rewrite
(N
, Act_Body
);
5945 -- Propagate the aspect specifications from the package body template to
5946 -- the instantiated version of the package body.
5948 if Has_Aspects
(Act_Body
) then
5949 Set_Aspect_Specifications
5950 (N
, New_Copy_List_Tree
(Aspect_Specifications
(Act_Body
)));
5953 Body_Cunit
:= Parent
(N
);
5955 -- The two compilation unit nodes are linked by the Library_Unit field
5957 Set_Library_Unit
(Decl_Cunit
, Body_Cunit
);
5958 Set_Library_Unit
(Body_Cunit
, Decl_Cunit
);
5960 -- Preserve the private nature of the package if needed
5962 Set_Private_Present
(Decl_Cunit
, Private_Present
(Body_Cunit
));
5964 -- If the instance is not the main unit, its context, categorization
5965 -- and elaboration entity are not relevant to the compilation.
5967 if Body_Cunit
/= Cunit
(Main_Unit
) then
5968 Make_Instance_Unit
(Body_Cunit
, In_Main
=> False);
5972 -- The context clause items on the instantiation, which are now attached
5973 -- to the body compilation unit (since the body overwrote the original
5974 -- instantiation node), semantically belong on the spec, so copy them
5975 -- there. It's harmless to leave them on the body as well. In fact one
5976 -- could argue that they belong in both places.
5978 Citem
:= First
(Context_Items
(Body_Cunit
));
5979 while Present
(Citem
) loop
5980 Append
(New_Copy
(Citem
), Context_Items
(Decl_Cunit
));
5984 -- Propagate categorization flags on packages, so that they appear in
5985 -- the ali file for the spec of the unit.
5987 if Ekind
(New_Main
) = E_Package
then
5988 Set_Is_Pure
(Old_Main
, Is_Pure
(New_Main
));
5989 Set_Is_Preelaborated
(Old_Main
, Is_Preelaborated
(New_Main
));
5990 Set_Is_Remote_Types
(Old_Main
, Is_Remote_Types
(New_Main
));
5991 Set_Is_Shared_Passive
(Old_Main
, Is_Shared_Passive
(New_Main
));
5992 Set_Is_Remote_Call_Interface
5993 (Old_Main
, Is_Remote_Call_Interface
(New_Main
));
5996 -- Make entry in Units table, so that binder can generate call to
5997 -- elaboration procedure for body, if any.
5999 Make_Instance_Unit
(Body_Cunit
, In_Main
=> True);
6000 Main_Unit_Entity
:= New_Main
;
6001 Set_Cunit_Entity
(Main_Unit
, Main_Unit_Entity
);
6003 -- Build elaboration entity, since the instance may certainly generate
6004 -- elaboration code requiring a flag for protection.
6006 Build_Elaboration_Entity
(Decl_Cunit
, New_Main
);
6007 end Build_Instance_Compilation_Unit_Nodes
;
6009 -----------------------------
6010 -- Check_Access_Definition --
6011 -----------------------------
6013 procedure Check_Access_Definition
(N
: Node_Id
) is
6016 (Ada_Version
>= Ada_2005
and then Present
(Access_Definition
(N
)));
6018 end Check_Access_Definition
;
6020 -----------------------------------
6021 -- Check_Formal_Package_Instance --
6022 -----------------------------------
6024 -- If the formal has specific parameters, they must match those of the
6025 -- actual. Both of them are instances, and the renaming declarations for
6026 -- their formal parameters appear in the same order in both. The analyzed
6027 -- formal has been analyzed in the context of the current instance.
6029 procedure Check_Formal_Package_Instance
6030 (Formal_Pack
: Entity_Id
;
6031 Actual_Pack
: Entity_Id
)
6033 E1
: Entity_Id
:= First_Entity
(Actual_Pack
);
6034 E2
: Entity_Id
:= First_Entity
(Formal_Pack
);
6035 Prev_E1
: Entity_Id
;
6040 procedure Check_Mismatch
(B
: Boolean);
6041 -- Common error routine for mismatch between the parameters of the
6042 -- actual instance and those of the formal package.
6044 function Same_Instantiated_Constant
(E1
, E2
: Entity_Id
) return Boolean;
6045 -- The formal may come from a nested formal package, and the actual may
6046 -- have been constant-folded. To determine whether the two denote the
6047 -- same entity we may have to traverse several definitions to recover
6048 -- the ultimate entity that they refer to.
6050 function Same_Instantiated_Function
(E1
, E2
: Entity_Id
) return Boolean;
6051 -- The formal and the actual must be identical, but if both are
6052 -- given by attributes they end up renaming different generated bodies,
6053 -- and we must verify that the attributes themselves match.
6055 function Same_Instantiated_Variable
(E1
, E2
: Entity_Id
) return Boolean;
6056 -- Similarly, if the formal comes from a nested formal package, the
6057 -- actual may designate the formal through multiple renamings, which
6058 -- have to be followed to determine the original variable in question.
6060 --------------------
6061 -- Check_Mismatch --
6062 --------------------
6064 procedure Check_Mismatch
(B
: Boolean) is
6065 -- A Formal_Type_Declaration for a derived private type is rewritten
6066 -- as a private extension decl. (see Analyze_Formal_Derived_Type),
6067 -- which is why we examine the original node.
6069 Kind
: constant Node_Kind
:= Nkind
(Original_Node
(Parent
(E2
)));
6072 if Kind
= N_Formal_Type_Declaration
then
6075 elsif Nkind_In
(Kind
, N_Formal_Object_Declaration
,
6076 N_Formal_Package_Declaration
)
6077 or else Kind
in N_Formal_Subprogram_Declaration
6081 -- Ada 2012: If both formal and actual are incomplete types they
6084 elsif Is_Incomplete_Type
(E1
) and then Is_Incomplete_Type
(E2
) then
6089 ("actual for & in actual instance does not match formal",
6090 Parent
(Actual_Pack
), E1
);
6094 --------------------------------
6095 -- Same_Instantiated_Constant --
6096 --------------------------------
6098 function Same_Instantiated_Constant
6099 (E1
, E2
: Entity_Id
) return Boolean
6105 while Present
(Ent
) loop
6109 elsif Ekind
(Ent
) /= E_Constant
then
6112 elsif Is_Entity_Name
(Constant_Value
(Ent
)) then
6113 if Entity
(Constant_Value
(Ent
)) = E1
then
6116 Ent
:= Entity
(Constant_Value
(Ent
));
6119 -- The actual may be a constant that has been folded. Recover
6122 elsif Is_Entity_Name
(Original_Node
(Constant_Value
(Ent
))) then
6123 Ent
:= Entity
(Original_Node
(Constant_Value
(Ent
)));
6131 end Same_Instantiated_Constant
;
6133 --------------------------------
6134 -- Same_Instantiated_Function --
6135 --------------------------------
6137 function Same_Instantiated_Function
6138 (E1
, E2
: Entity_Id
) return Boolean
6142 if Alias
(E1
) = Alias
(E2
) then
6145 elsif Present
(Alias
(E2
)) then
6146 U1
:= Original_Node
(Unit_Declaration_Node
(E1
));
6147 U2
:= Original_Node
(Unit_Declaration_Node
(Alias
(E2
)));
6149 return Nkind
(U1
) = N_Subprogram_Renaming_Declaration
6150 and then Nkind
(Name
(U1
)) = N_Attribute_Reference
6152 and then Nkind
(U2
) = N_Subprogram_Renaming_Declaration
6153 and then Nkind
(Name
(U2
)) = N_Attribute_Reference
6156 Attribute_Name
(Name
(U1
)) = Attribute_Name
(Name
(U2
));
6160 end Same_Instantiated_Function
;
6162 --------------------------------
6163 -- Same_Instantiated_Variable --
6164 --------------------------------
6166 function Same_Instantiated_Variable
6167 (E1
, E2
: Entity_Id
) return Boolean
6169 function Original_Entity
(E
: Entity_Id
) return Entity_Id
;
6170 -- Follow chain of renamings to the ultimate ancestor
6172 ---------------------
6173 -- Original_Entity --
6174 ---------------------
6176 function Original_Entity
(E
: Entity_Id
) return Entity_Id
is
6181 while Nkind
(Parent
(Orig
)) = N_Object_Renaming_Declaration
6182 and then Present
(Renamed_Object
(Orig
))
6183 and then Is_Entity_Name
(Renamed_Object
(Orig
))
6185 Orig
:= Entity
(Renamed_Object
(Orig
));
6189 end Original_Entity
;
6191 -- Start of processing for Same_Instantiated_Variable
6194 return Ekind
(E1
) = Ekind
(E2
)
6195 and then Original_Entity
(E1
) = Original_Entity
(E2
);
6196 end Same_Instantiated_Variable
;
6198 -- Start of processing for Check_Formal_Package_Instance
6202 while Present
(E1
) and then Present
(E2
) loop
6203 exit when Ekind
(E1
) = E_Package
6204 and then Renamed_Entity
(E1
) = Renamed_Entity
(Actual_Pack
);
6206 -- If the formal is the renaming of the formal package, this
6207 -- is the end of its formal part, which may occur before the
6208 -- end of the formal part in the actual in the presence of
6209 -- defaulted parameters in the formal package.
6211 exit when Nkind
(Parent
(E2
)) = N_Package_Renaming_Declaration
6212 and then Renamed_Entity
(E2
) = Scope
(E2
);
6214 -- The analysis of the actual may generate additional internal
6215 -- entities. If the formal is defaulted, there is no corresponding
6216 -- analysis and the internal entities must be skipped, until we
6217 -- find corresponding entities again.
6219 if Comes_From_Source
(E2
)
6220 and then not Comes_From_Source
(E1
)
6221 and then Chars
(E1
) /= Chars
(E2
)
6223 while Present
(E1
) and then Chars
(E1
) /= Chars
(E2
) loop
6231 -- Entities may be declared without full declaration, such as
6232 -- itypes and predefined operators (concatenation for arrays, eg).
6233 -- Skip it and keep the formal entity to find a later match for it.
6235 elsif No
(Parent
(E2
)) and then Ekind
(E1
) /= Ekind
(E2
) then
6239 -- If the formal entity comes from a formal declaration, it was
6240 -- defaulted in the formal package, and no check is needed on it.
6242 elsif Nkind_In
(Original_Node
(Parent
(E2
)),
6243 N_Formal_Object_Declaration
,
6244 N_Formal_Type_Declaration
)
6246 -- If the formal is a tagged type the corresponding class-wide
6247 -- type has been generated as well, and it must be skipped.
6249 if Is_Type
(E2
) and then Is_Tagged_Type
(E2
) then
6255 -- Ditto for defaulted formal subprograms.
6257 elsif Is_Overloadable
(E1
)
6258 and then Nkind
(Unit_Declaration_Node
(E2
)) in
6259 N_Formal_Subprogram_Declaration
6263 elsif Is_Type
(E1
) then
6265 -- Subtypes must statically match. E1, E2 are the local entities
6266 -- that are subtypes of the actuals. Itypes generated for other
6267 -- parameters need not be checked, the check will be performed
6268 -- on the parameters themselves.
6270 -- If E2 is a formal type declaration, it is a defaulted parameter
6271 -- and needs no checking.
6273 if not Is_Itype
(E1
) and then not Is_Itype
(E2
) then
6276 or else Etype
(E1
) /= Etype
(E2
)
6277 or else not Subtypes_Statically_Match
(E1
, E2
));
6280 elsif Ekind
(E1
) = E_Constant
then
6282 -- IN parameters must denote the same static value, or the same
6283 -- constant, or the literal null.
6285 Expr1
:= Expression
(Parent
(E1
));
6287 if Ekind
(E2
) /= E_Constant
then
6288 Check_Mismatch
(True);
6291 Expr2
:= Expression
(Parent
(E2
));
6294 if Is_OK_Static_Expression
(Expr1
) then
6295 if not Is_OK_Static_Expression
(Expr2
) then
6296 Check_Mismatch
(True);
6298 elsif Is_Discrete_Type
(Etype
(E1
)) then
6300 V1
: constant Uint
:= Expr_Value
(Expr1
);
6301 V2
: constant Uint
:= Expr_Value
(Expr2
);
6303 Check_Mismatch
(V1
/= V2
);
6306 elsif Is_Real_Type
(Etype
(E1
)) then
6308 V1
: constant Ureal
:= Expr_Value_R
(Expr1
);
6309 V2
: constant Ureal
:= Expr_Value_R
(Expr2
);
6311 Check_Mismatch
(V1
/= V2
);
6314 elsif Is_String_Type
(Etype
(E1
))
6315 and then Nkind
(Expr1
) = N_String_Literal
6317 if Nkind
(Expr2
) /= N_String_Literal
then
6318 Check_Mismatch
(True);
6321 (not String_Equal
(Strval
(Expr1
), Strval
(Expr2
)));
6325 elsif Is_Entity_Name
(Expr1
) then
6326 if Is_Entity_Name
(Expr2
) then
6327 if Entity
(Expr1
) = Entity
(Expr2
) then
6331 (not Same_Instantiated_Constant
6332 (Entity
(Expr1
), Entity
(Expr2
)));
6336 Check_Mismatch
(True);
6339 elsif Is_Entity_Name
(Original_Node
(Expr1
))
6340 and then Is_Entity_Name
(Expr2
)
6341 and then Same_Instantiated_Constant
6342 (Entity
(Original_Node
(Expr1
)), Entity
(Expr2
))
6346 elsif Nkind
(Expr1
) = N_Null
then
6347 Check_Mismatch
(Nkind
(Expr1
) /= N_Null
);
6350 Check_Mismatch
(True);
6353 elsif Ekind
(E1
) = E_Variable
then
6354 Check_Mismatch
(not Same_Instantiated_Variable
(E1
, E2
));
6356 elsif Ekind
(E1
) = E_Package
then
6358 (Ekind
(E1
) /= Ekind
(E2
)
6359 or else Renamed_Object
(E1
) /= Renamed_Object
(E2
));
6361 elsif Is_Overloadable
(E1
) then
6363 -- Verify that the actual subprograms match. Note that actuals
6364 -- that are attributes are rewritten as subprograms. If the
6365 -- subprogram in the formal package is defaulted, no check is
6366 -- needed. Note that this can only happen in Ada 2005 when the
6367 -- formal package can be partially parameterized.
6369 if Nkind
(Unit_Declaration_Node
(E1
)) =
6370 N_Subprogram_Renaming_Declaration
6371 and then From_Default
(Unit_Declaration_Node
(E1
))
6375 -- If the formal package has an "others" box association that
6376 -- covers this formal, there is no need for a check either.
6378 elsif Nkind
(Unit_Declaration_Node
(E2
)) in
6379 N_Formal_Subprogram_Declaration
6380 and then Box_Present
(Unit_Declaration_Node
(E2
))
6384 -- No check needed if subprogram is a defaulted null procedure
6386 elsif No
(Alias
(E2
))
6387 and then Ekind
(E2
) = E_Procedure
6389 Null_Present
(Specification
(Unit_Declaration_Node
(E2
)))
6393 -- Otherwise the actual in the formal and the actual in the
6394 -- instantiation of the formal must match, up to renamings.
6398 (Ekind
(E2
) /= Ekind
(E1
)
6399 or else not Same_Instantiated_Function
(E1
, E2
));
6403 raise Program_Error
;
6411 end Check_Formal_Package_Instance
;
6413 ---------------------------
6414 -- Check_Formal_Packages --
6415 ---------------------------
6417 procedure Check_Formal_Packages
(P_Id
: Entity_Id
) is
6419 Formal_P
: Entity_Id
;
6420 Formal_Decl
: Node_Id
;
6423 -- Iterate through the declarations in the instance, looking for package
6424 -- renaming declarations that denote instances of formal packages. Stop
6425 -- when we find the renaming of the current package itself. The
6426 -- declaration for a formal package without a box is followed by an
6427 -- internal entity that repeats the instantiation.
6429 E
:= First_Entity
(P_Id
);
6430 while Present
(E
) loop
6431 if Ekind
(E
) = E_Package
then
6432 if Renamed_Object
(E
) = P_Id
then
6435 elsif Nkind
(Parent
(E
)) /= N_Package_Renaming_Declaration
then
6439 Formal_Decl
:= Parent
(Associated_Formal_Package
(E
));
6441 -- Nothing to check if the formal has a box or an others_clause
6442 -- (necessarily with a box).
6444 if Box_Present
(Formal_Decl
) then
6447 elsif Nkind
(First
(Generic_Associations
(Formal_Decl
))) =
6450 -- The internal validating package was generated but formal
6451 -- and instance are known to be compatible.
6453 Formal_P
:= Next_Entity
(E
);
6454 Remove
(Unit_Declaration_Node
(Formal_P
));
6457 Formal_P
:= Next_Entity
(E
);
6459 -- If the instance is within an enclosing instance body
6460 -- there is no need to verify the legality of current formal
6461 -- packages because they were legal in the generic body.
6462 -- This optimization may be applicable elsewhere, and it
6463 -- also removes spurious errors that may arise with
6464 -- on-the-fly inlining and confusion between private and
6467 if not In_Instance_Body
then
6468 Check_Formal_Package_Instance
(Formal_P
, E
);
6471 -- After checking, remove the internal validating package.
6472 -- It is only needed for semantic checks, and as it may
6473 -- contain generic formal declarations it should not reach
6476 Remove
(Unit_Declaration_Node
(Formal_P
));
6483 end Check_Formal_Packages
;
6485 ---------------------------------
6486 -- Check_Forward_Instantiation --
6487 ---------------------------------
6489 procedure Check_Forward_Instantiation
(Decl
: Node_Id
) is
6491 Gen_Comp
: Entity_Id
:= Cunit_Entity
(Get_Source_Unit
(Decl
));
6494 -- The instantiation appears before the generic body if we are in the
6495 -- scope of the unit containing the generic, either in its spec or in
6496 -- the package body, and before the generic body.
6498 if Ekind
(Gen_Comp
) = E_Package_Body
then
6499 Gen_Comp
:= Spec_Entity
(Gen_Comp
);
6502 if In_Open_Scopes
(Gen_Comp
)
6503 and then No
(Corresponding_Body
(Decl
))
6508 and then not Is_Compilation_Unit
(S
)
6509 and then not Is_Child_Unit
(S
)
6511 if Ekind
(S
) = E_Package
then
6512 Set_Has_Forward_Instantiation
(S
);
6518 end Check_Forward_Instantiation
;
6520 ---------------------------
6521 -- Check_Generic_Actuals --
6522 ---------------------------
6524 -- The visibility of the actuals may be different between the point of
6525 -- generic instantiation and the instantiation of the body.
6527 procedure Check_Generic_Actuals
6528 (Instance
: Entity_Id
;
6529 Is_Formal_Box
: Boolean)
6534 function Denotes_Previous_Actual
(Typ
: Entity_Id
) return Boolean;
6535 -- For a formal that is an array type, the component type is often a
6536 -- previous formal in the same unit. The privacy status of the component
6537 -- type will have been examined earlier in the traversal of the
6538 -- corresponding actuals, and this status should not be modified for
6539 -- the array (sub)type itself. However, if the base type of the array
6540 -- (sub)type is private, its full view must be restored in the body to
6541 -- be consistent with subsequent index subtypes, etc.
6543 -- To detect this case we have to rescan the list of formals, which is
6544 -- usually short enough to ignore the resulting inefficiency.
6546 -----------------------------
6547 -- Denotes_Previous_Actual --
6548 -----------------------------
6550 function Denotes_Previous_Actual
(Typ
: Entity_Id
) return Boolean is
6554 Prev
:= First_Entity
(Instance
);
6555 while Present
(Prev
) loop
6557 and then Nkind
(Parent
(Prev
)) = N_Subtype_Declaration
6558 and then Is_Entity_Name
(Subtype_Indication
(Parent
(Prev
)))
6559 and then Entity
(Subtype_Indication
(Parent
(Prev
))) = Typ
6572 end Denotes_Previous_Actual
;
6574 -- Start of processing for Check_Generic_Actuals
6577 E
:= First_Entity
(Instance
);
6578 while Present
(E
) loop
6580 and then Nkind
(Parent
(E
)) = N_Subtype_Declaration
6581 and then Scope
(Etype
(E
)) /= Instance
6582 and then Is_Entity_Name
(Subtype_Indication
(Parent
(E
)))
6584 if Is_Array_Type
(E
)
6585 and then not Is_Private_Type
(Etype
(E
))
6586 and then Denotes_Previous_Actual
(Component_Type
(E
))
6590 Check_Private_View
(Subtype_Indication
(Parent
(E
)));
6593 Set_Is_Generic_Actual_Type
(E
, True);
6594 Set_Is_Hidden
(E
, False);
6595 Set_Is_Potentially_Use_Visible
(E
, In_Use
(Instance
));
6597 -- We constructed the generic actual type as a subtype of the
6598 -- supplied type. This means that it normally would not inherit
6599 -- subtype specific attributes of the actual, which is wrong for
6600 -- the generic case.
6602 Astype
:= Ancestor_Subtype
(E
);
6606 -- This can happen when E is an itype that is the full view of
6607 -- a private type completed, e.g. with a constrained array. In
6608 -- that case, use the first subtype, which will carry size
6609 -- information. The base type itself is unconstrained and will
6612 Astype
:= First_Subtype
(E
);
6615 Set_Size_Info
(E
, (Astype
));
6616 Set_RM_Size
(E
, RM_Size
(Astype
));
6617 Set_First_Rep_Item
(E
, First_Rep_Item
(Astype
));
6619 if Is_Discrete_Or_Fixed_Point_Type
(E
) then
6620 Set_RM_Size
(E
, RM_Size
(Astype
));
6622 -- In nested instances, the base type of an access actual may
6623 -- itself be private, and need to be exchanged.
6625 elsif Is_Access_Type
(E
)
6626 and then Is_Private_Type
(Etype
(E
))
6629 (New_Occurrence_Of
(Etype
(E
), Sloc
(Instance
)));
6632 elsif Ekind
(E
) = E_Package
then
6634 -- If this is the renaming for the current instance, we're done.
6635 -- Otherwise it is a formal package. If the corresponding formal
6636 -- was declared with a box, the (instantiations of the) generic
6637 -- formal part are also visible. Otherwise, ignore the entity
6638 -- created to validate the actuals.
6640 if Renamed_Object
(E
) = Instance
then
6643 elsif Nkind
(Parent
(E
)) /= N_Package_Renaming_Declaration
then
6646 -- The visibility of a formal of an enclosing generic is already
6649 elsif Denotes_Formal_Package
(E
) then
6652 elsif Present
(Associated_Formal_Package
(E
))
6653 and then not Is_Generic_Formal
(E
)
6655 if Box_Present
(Parent
(Associated_Formal_Package
(E
))) then
6656 Check_Generic_Actuals
(Renamed_Object
(E
), True);
6659 Check_Generic_Actuals
(Renamed_Object
(E
), False);
6662 Set_Is_Hidden
(E
, False);
6665 -- If this is a subprogram instance (in a wrapper package) the
6666 -- actual is fully visible.
6668 elsif Is_Wrapper_Package
(Instance
) then
6669 Set_Is_Hidden
(E
, False);
6671 -- If the formal package is declared with a box, or if the formal
6672 -- parameter is defaulted, it is visible in the body.
6674 elsif Is_Formal_Box
or else Is_Visible_Formal
(E
) then
6675 Set_Is_Hidden
(E
, False);
6678 if Ekind
(E
) = E_Constant
then
6680 -- If the type of the actual is a private type declared in the
6681 -- enclosing scope of the generic unit, the body of the generic
6682 -- sees the full view of the type (because it has to appear in
6683 -- the corresponding package body). If the type is private now,
6684 -- exchange views to restore the proper visiblity in the instance.
6687 Typ
: constant Entity_Id
:= Base_Type
(Etype
(E
));
6688 -- The type of the actual
6693 Parent_Scope
: Entity_Id
;
6694 -- The enclosing scope of the generic unit
6697 if Is_Wrapper_Package
(Instance
) then
6701 (Unit_Declaration_Node
6702 (Related_Instance
(Instance
))));
6705 Generic_Parent
(Package_Specification
(Instance
));
6708 Parent_Scope
:= Scope
(Gen_Id
);
6710 -- The exchange is only needed if the generic is defined
6711 -- within a package which is not a common ancestor of the
6712 -- scope of the instance, and is not already in scope.
6714 if Is_Private_Type
(Typ
)
6715 and then Scope
(Typ
) = Parent_Scope
6716 and then Scope
(Instance
) /= Parent_Scope
6717 and then Ekind
(Parent_Scope
) = E_Package
6718 and then not Is_Child_Unit
(Gen_Id
)
6722 -- If the type of the entity is a subtype, it may also have
6723 -- to be made visible, together with the base type of its
6724 -- full view, after exchange.
6726 if Is_Private_Type
(Etype
(E
)) then
6727 Switch_View
(Etype
(E
));
6728 Switch_View
(Base_Type
(Etype
(E
)));
6736 end Check_Generic_Actuals
;
6738 ------------------------------
6739 -- Check_Generic_Child_Unit --
6740 ------------------------------
6742 procedure Check_Generic_Child_Unit
6744 Parent_Installed
: in out Boolean)
6746 Loc
: constant Source_Ptr
:= Sloc
(Gen_Id
);
6747 Gen_Par
: Entity_Id
:= Empty
;
6749 Inst_Par
: Entity_Id
;
6752 function Find_Generic_Child
6754 Id
: Node_Id
) return Entity_Id
;
6755 -- Search generic parent for possible child unit with the given name
6757 function In_Enclosing_Instance
return Boolean;
6758 -- Within an instance of the parent, the child unit may be denoted by
6759 -- a simple name, or an abbreviated expanded name. Examine enclosing
6760 -- scopes to locate a possible parent instantiation.
6762 ------------------------
6763 -- Find_Generic_Child --
6764 ------------------------
6766 function Find_Generic_Child
6768 Id
: Node_Id
) return Entity_Id
6773 -- If entity of name is already set, instance has already been
6774 -- resolved, e.g. in an enclosing instantiation.
6776 if Present
(Entity
(Id
)) then
6777 if Scope
(Entity
(Id
)) = Scop
then
6784 E
:= First_Entity
(Scop
);
6785 while Present
(E
) loop
6786 if Chars
(E
) = Chars
(Id
)
6787 and then Is_Child_Unit
(E
)
6789 if Is_Child_Unit
(E
)
6790 and then not Is_Visible_Lib_Unit
(E
)
6793 ("generic child unit& is not visible", Gen_Id
, E
);
6805 end Find_Generic_Child
;
6807 ---------------------------
6808 -- In_Enclosing_Instance --
6809 ---------------------------
6811 function In_Enclosing_Instance
return Boolean is
6812 Enclosing_Instance
: Node_Id
;
6813 Instance_Decl
: Node_Id
;
6816 -- We do not inline any call that contains instantiations, except
6817 -- for instantiations of Unchecked_Conversion, so if we are within
6818 -- an inlined body the current instance does not require parents.
6820 if In_Inlined_Body
then
6821 pragma Assert
(Chars
(Gen_Id
) = Name_Unchecked_Conversion
);
6825 -- Loop to check enclosing scopes
6827 Enclosing_Instance
:= Current_Scope
;
6828 while Present
(Enclosing_Instance
) loop
6829 Instance_Decl
:= Unit_Declaration_Node
(Enclosing_Instance
);
6831 if Ekind
(Enclosing_Instance
) = E_Package
6832 and then Is_Generic_Instance
(Enclosing_Instance
)
6834 (Generic_Parent
(Specification
(Instance_Decl
)))
6836 -- Check whether the generic we are looking for is a child of
6839 E
:= Find_Generic_Child
6840 (Generic_Parent
(Specification
(Instance_Decl
)), Gen_Id
);
6841 exit when Present
(E
);
6847 Enclosing_Instance
:= Scope
(Enclosing_Instance
);
6859 Make_Expanded_Name
(Loc
,
6861 Prefix
=> New_Occurrence_Of
(Enclosing_Instance
, Loc
),
6862 Selector_Name
=> New_Occurrence_Of
(E
, Loc
)));
6864 Set_Entity
(Gen_Id
, E
);
6865 Set_Etype
(Gen_Id
, Etype
(E
));
6866 Parent_Installed
:= False; -- Already in scope.
6869 end In_Enclosing_Instance
;
6871 -- Start of processing for Check_Generic_Child_Unit
6874 -- If the name of the generic is given by a selected component, it may
6875 -- be the name of a generic child unit, and the prefix is the name of an
6876 -- instance of the parent, in which case the child unit must be visible.
6877 -- If this instance is not in scope, it must be placed there and removed
6878 -- after instantiation, because what is being instantiated is not the
6879 -- original child, but the corresponding child present in the instance
6882 -- If the child is instantiated within the parent, it can be given by
6883 -- a simple name. In this case the instance is already in scope, but
6884 -- the child generic must be recovered from the generic parent as well.
6886 if Nkind
(Gen_Id
) = N_Selected_Component
then
6887 S
:= Selector_Name
(Gen_Id
);
6888 Analyze
(Prefix
(Gen_Id
));
6889 Inst_Par
:= Entity
(Prefix
(Gen_Id
));
6891 if Ekind
(Inst_Par
) = E_Package
6892 and then Present
(Renamed_Object
(Inst_Par
))
6894 Inst_Par
:= Renamed_Object
(Inst_Par
);
6897 if Ekind
(Inst_Par
) = E_Package
then
6898 if Nkind
(Parent
(Inst_Par
)) = N_Package_Specification
then
6899 Gen_Par
:= Generic_Parent
(Parent
(Inst_Par
));
6901 elsif Nkind
(Parent
(Inst_Par
)) = N_Defining_Program_Unit_Name
6903 Nkind
(Parent
(Parent
(Inst_Par
))) = N_Package_Specification
6905 Gen_Par
:= Generic_Parent
(Parent
(Parent
(Inst_Par
)));
6908 elsif Ekind
(Inst_Par
) = E_Generic_Package
6909 and then Nkind
(Parent
(Gen_Id
)) = N_Formal_Package_Declaration
6911 -- A formal package may be a real child package, and not the
6912 -- implicit instance within a parent. In this case the child is
6913 -- not visible and has to be retrieved explicitly as well.
6915 Gen_Par
:= Inst_Par
;
6918 if Present
(Gen_Par
) then
6920 -- The prefix denotes an instantiation. The entity itself may be a
6921 -- nested generic, or a child unit.
6923 E
:= Find_Generic_Child
(Gen_Par
, S
);
6926 Change_Selected_Component_To_Expanded_Name
(Gen_Id
);
6927 Set_Entity
(Gen_Id
, E
);
6928 Set_Etype
(Gen_Id
, Etype
(E
));
6930 Set_Etype
(S
, Etype
(E
));
6932 -- Indicate that this is a reference to the parent
6934 if In_Extended_Main_Source_Unit
(Gen_Id
) then
6935 Set_Is_Instantiated
(Inst_Par
);
6938 -- A common mistake is to replicate the naming scheme of a
6939 -- hierarchy by instantiating a generic child directly, rather
6940 -- than the implicit child in a parent instance:
6942 -- generic .. package Gpar is ..
6943 -- generic .. package Gpar.Child is ..
6944 -- package Par is new Gpar ();
6947 -- package Par.Child is new Gpar.Child ();
6948 -- rather than Par.Child
6950 -- In this case the instantiation is within Par, which is an
6951 -- instance, but Gpar does not denote Par because we are not IN
6952 -- the instance of Gpar, so this is illegal. The test below
6953 -- recognizes this particular case.
6955 if Is_Child_Unit
(E
)
6956 and then not Comes_From_Source
(Entity
(Prefix
(Gen_Id
)))
6957 and then (not In_Instance
6958 or else Nkind
(Parent
(Parent
(Gen_Id
))) =
6962 ("prefix of generic child unit must be instance of parent",
6966 if not In_Open_Scopes
(Inst_Par
)
6967 and then Nkind
(Parent
(Gen_Id
)) not in
6968 N_Generic_Renaming_Declaration
6970 Install_Parent
(Inst_Par
);
6971 Parent_Installed
:= True;
6973 elsif In_Open_Scopes
(Inst_Par
) then
6975 -- If the parent is already installed, install the actuals
6976 -- for its formal packages. This is necessary when the child
6977 -- instance is a child of the parent instance: in this case,
6978 -- the parent is placed on the scope stack but the formal
6979 -- packages are not made visible.
6981 Install_Formal_Packages
(Inst_Par
);
6985 -- If the generic parent does not contain an entity that
6986 -- corresponds to the selector, the instance doesn't either.
6987 -- Analyzing the node will yield the appropriate error message.
6988 -- If the entity is not a child unit, then it is an inner
6989 -- generic in the parent.
6997 if Is_Child_Unit
(Entity
(Gen_Id
))
6999 Nkind
(Parent
(Gen_Id
)) not in N_Generic_Renaming_Declaration
7000 and then not In_Open_Scopes
(Inst_Par
)
7002 Install_Parent
(Inst_Par
);
7003 Parent_Installed
:= True;
7005 -- The generic unit may be the renaming of the implicit child
7006 -- present in an instance. In that case the parent instance is
7007 -- obtained from the name of the renamed entity.
7009 elsif Ekind
(Entity
(Gen_Id
)) = E_Generic_Package
7010 and then Present
(Renamed_Entity
(Entity
(Gen_Id
)))
7011 and then Is_Child_Unit
(Renamed_Entity
(Entity
(Gen_Id
)))
7014 Renamed_Package
: constant Node_Id
:=
7015 Name
(Parent
(Entity
(Gen_Id
)));
7017 if Nkind
(Renamed_Package
) = N_Expanded_Name
then
7018 Inst_Par
:= Entity
(Prefix
(Renamed_Package
));
7019 Install_Parent
(Inst_Par
);
7020 Parent_Installed
:= True;
7026 elsif Nkind
(Gen_Id
) = N_Expanded_Name
then
7028 -- Entity already present, analyze prefix, whose meaning may be an
7029 -- instance in the current context. If it is an instance of a
7030 -- relative within another, the proper parent may still have to be
7031 -- installed, if they are not of the same generation.
7033 Analyze
(Prefix
(Gen_Id
));
7035 -- Prevent cascaded errors
7037 if Etype
(Prefix
(Gen_Id
)) = Any_Type
then
7041 -- In the unlikely case that a local declaration hides the name of
7042 -- the parent package, locate it on the homonym chain. If the context
7043 -- is an instance of the parent, the renaming entity is flagged as
7046 Inst_Par
:= Entity
(Prefix
(Gen_Id
));
7047 while Present
(Inst_Par
)
7048 and then not Is_Package_Or_Generic_Package
(Inst_Par
)
7050 Inst_Par
:= Homonym
(Inst_Par
);
7053 pragma Assert
(Present
(Inst_Par
));
7054 Set_Entity
(Prefix
(Gen_Id
), Inst_Par
);
7056 if In_Enclosing_Instance
then
7059 elsif Present
(Entity
(Gen_Id
))
7060 and then Is_Child_Unit
(Entity
(Gen_Id
))
7061 and then not In_Open_Scopes
(Inst_Par
)
7063 Install_Parent
(Inst_Par
);
7064 Parent_Installed
:= True;
7067 elsif In_Enclosing_Instance
then
7069 -- The child unit is found in some enclosing scope
7076 -- If this is the renaming of the implicit child in a parent
7077 -- instance, recover the parent name and install it.
7079 if Is_Entity_Name
(Gen_Id
) then
7080 E
:= Entity
(Gen_Id
);
7082 if Is_Generic_Unit
(E
)
7083 and then Nkind
(Parent
(E
)) in N_Generic_Renaming_Declaration
7084 and then Is_Child_Unit
(Renamed_Object
(E
))
7085 and then Is_Generic_Unit
(Scope
(Renamed_Object
(E
)))
7086 and then Nkind
(Name
(Parent
(E
))) = N_Expanded_Name
7088 Rewrite
(Gen_Id
, New_Copy_Tree
(Name
(Parent
(E
))));
7089 Inst_Par
:= Entity
(Prefix
(Gen_Id
));
7091 if not In_Open_Scopes
(Inst_Par
) then
7092 Install_Parent
(Inst_Par
);
7093 Parent_Installed
:= True;
7096 -- If it is a child unit of a non-generic parent, it may be
7097 -- use-visible and given by a direct name. Install parent as
7100 elsif Is_Generic_Unit
(E
)
7101 and then Is_Child_Unit
(E
)
7103 Nkind
(Parent
(Gen_Id
)) not in N_Generic_Renaming_Declaration
7104 and then not Is_Generic_Unit
(Scope
(E
))
7106 if not In_Open_Scopes
(Scope
(E
)) then
7107 Install_Parent
(Scope
(E
));
7108 Parent_Installed
:= True;
7113 end Check_Generic_Child_Unit
;
7115 -----------------------------
7116 -- Check_Hidden_Child_Unit --
7117 -----------------------------
7119 procedure Check_Hidden_Child_Unit
7121 Gen_Unit
: Entity_Id
;
7122 Act_Decl_Id
: Entity_Id
)
7124 Gen_Id
: constant Node_Id
:= Name
(N
);
7127 if Is_Child_Unit
(Gen_Unit
)
7128 and then Is_Child_Unit
(Act_Decl_Id
)
7129 and then Nkind
(Gen_Id
) = N_Expanded_Name
7130 and then Entity
(Prefix
(Gen_Id
)) = Scope
(Act_Decl_Id
)
7131 and then Chars
(Gen_Unit
) = Chars
(Act_Decl_Id
)
7133 Error_Msg_Node_2
:= Scope
(Act_Decl_Id
);
7135 ("generic unit & is implicitly declared in &",
7136 Defining_Unit_Name
(N
), Gen_Unit
);
7137 Error_Msg_N
("\instance must have different name",
7138 Defining_Unit_Name
(N
));
7140 end Check_Hidden_Child_Unit
;
7142 ------------------------
7143 -- Check_Private_View --
7144 ------------------------
7146 procedure Check_Private_View
(N
: Node_Id
) is
7147 T
: constant Entity_Id
:= Etype
(N
);
7151 -- Exchange views if the type was not private in the generic but is
7152 -- private at the point of instantiation. Do not exchange views if
7153 -- the scope of the type is in scope. This can happen if both generic
7154 -- and instance are sibling units, or if type is defined in a parent.
7155 -- In this case the visibility of the type will be correct for all
7159 BT
:= Base_Type
(T
);
7161 if Is_Private_Type
(T
)
7162 and then not Has_Private_View
(N
)
7163 and then Present
(Full_View
(T
))
7164 and then not In_Open_Scopes
(Scope
(T
))
7166 -- In the generic, the full type was visible. Save the private
7167 -- entity, for subsequent exchange.
7171 elsif Has_Private_View
(N
)
7172 and then not Is_Private_Type
(T
)
7173 and then not Has_Been_Exchanged
(T
)
7174 and then Etype
(Get_Associated_Node
(N
)) /= T
7176 -- Only the private declaration was visible in the generic. If
7177 -- the type appears in a subtype declaration, the subtype in the
7178 -- instance must have a view compatible with that of its parent,
7179 -- which must be exchanged (see corresponding code in Restore_
7180 -- Private_Views). Otherwise, if the type is defined in a parent
7181 -- unit, leave full visibility within instance, which is safe.
7183 if In_Open_Scopes
(Scope
(Base_Type
(T
)))
7184 and then not Is_Private_Type
(Base_Type
(T
))
7185 and then Comes_From_Source
(Base_Type
(T
))
7189 elsif Nkind
(Parent
(N
)) = N_Subtype_Declaration
7190 or else not In_Private_Part
(Scope
(Base_Type
(T
)))
7192 Prepend_Elmt
(T
, Exchanged_Views
);
7193 Exchange_Declarations
(Etype
(Get_Associated_Node
(N
)));
7196 -- For composite types with inconsistent representation exchange
7197 -- component types accordingly.
7199 elsif Is_Access_Type
(T
)
7200 and then Is_Private_Type
(Designated_Type
(T
))
7201 and then not Has_Private_View
(N
)
7202 and then Present
(Full_View
(Designated_Type
(T
)))
7204 Switch_View
(Designated_Type
(T
));
7206 elsif Is_Array_Type
(T
) then
7207 if Is_Private_Type
(Component_Type
(T
))
7208 and then not Has_Private_View
(N
)
7209 and then Present
(Full_View
(Component_Type
(T
)))
7211 Switch_View
(Component_Type
(T
));
7214 -- The normal exchange mechanism relies on the setting of a
7215 -- flag on the reference in the generic. However, an additional
7216 -- mechanism is needed for types that are not explicitly
7217 -- mentioned in the generic, but may be needed in expanded code
7218 -- in the instance. This includes component types of arrays and
7219 -- designated types of access types. This processing must also
7220 -- include the index types of arrays which we take care of here.
7227 Indx
:= First_Index
(T
);
7228 while Present
(Indx
) loop
7229 Typ
:= Base_Type
(Etype
(Indx
));
7231 if Is_Private_Type
(Typ
)
7232 and then Present
(Full_View
(Typ
))
7241 elsif Is_Private_Type
(T
)
7242 and then Present
(Full_View
(T
))
7243 and then Is_Array_Type
(Full_View
(T
))
7244 and then Is_Private_Type
(Component_Type
(Full_View
(T
)))
7248 -- Finally, a non-private subtype may have a private base type, which
7249 -- must be exchanged for consistency. This can happen when a package
7250 -- body is instantiated, when the scope stack is empty but in fact
7251 -- the subtype and the base type are declared in an enclosing scope.
7253 -- Note that in this case we introduce an inconsistency in the view
7254 -- set, because we switch the base type BT, but there could be some
7255 -- private dependent subtypes of BT which remain unswitched. Such
7256 -- subtypes might need to be switched at a later point (see specific
7257 -- provision for that case in Switch_View).
7259 elsif not Is_Private_Type
(T
)
7260 and then not Has_Private_View
(N
)
7261 and then Is_Private_Type
(BT
)
7262 and then Present
(Full_View
(BT
))
7263 and then not Is_Generic_Type
(BT
)
7264 and then not In_Open_Scopes
(BT
)
7266 Prepend_Elmt
(Full_View
(BT
), Exchanged_Views
);
7267 Exchange_Declarations
(BT
);
7270 end Check_Private_View
;
7272 -----------------------------
7273 -- Check_Hidden_Primitives --
7274 -----------------------------
7276 function Check_Hidden_Primitives
(Assoc_List
: List_Id
) return Elist_Id
is
7279 Result
: Elist_Id
:= No_Elist
;
7282 if No
(Assoc_List
) then
7286 -- Traverse the list of associations between formals and actuals
7287 -- searching for renamings of tagged types
7289 Actual
:= First
(Assoc_List
);
7290 while Present
(Actual
) loop
7291 if Nkind
(Actual
) = N_Subtype_Declaration
then
7292 Gen_T
:= Generic_Parent_Type
(Actual
);
7294 if Present
(Gen_T
) and then Is_Tagged_Type
(Gen_T
) then
7296 -- Traverse the list of primitives of the actual types
7297 -- searching for hidden primitives that are visible in the
7298 -- corresponding generic formal; leave them visible and
7299 -- append them to Result to restore their decoration later.
7301 Install_Hidden_Primitives
7302 (Prims_List
=> Result
,
7304 Act_T
=> Entity
(Subtype_Indication
(Actual
)));
7312 end Check_Hidden_Primitives
;
7314 --------------------------
7315 -- Contains_Instance_Of --
7316 --------------------------
7318 function Contains_Instance_Of
7321 N
: Node_Id
) return Boolean
7329 -- Verify that there are no circular instantiations. We check whether
7330 -- the unit contains an instance of the current scope or some enclosing
7331 -- scope (in case one of the instances appears in a subunit). Longer
7332 -- circularities involving subunits might seem too pathological to
7333 -- consider, but they were not too pathological for the authors of
7334 -- DEC bc30vsq, so we loop over all enclosing scopes, and mark all
7335 -- enclosing generic scopes as containing an instance.
7338 -- Within a generic subprogram body, the scope is not generic, to
7339 -- allow for recursive subprograms. Use the declaration to determine
7340 -- whether this is a generic unit.
7342 if Ekind
(Scop
) = E_Generic_Package
7343 or else (Is_Subprogram
(Scop
)
7344 and then Nkind
(Unit_Declaration_Node
(Scop
)) =
7345 N_Generic_Subprogram_Declaration
)
7347 Elmt
:= First_Elmt
(Inner_Instances
(Inner
));
7349 while Present
(Elmt
) loop
7350 if Node
(Elmt
) = Scop
then
7351 Error_Msg_Node_2
:= Inner
;
7353 ("circular Instantiation: & instantiated within &!",
7357 elsif Node
(Elmt
) = Inner
then
7360 elsif Contains_Instance_Of
(Node
(Elmt
), Scop
, N
) then
7361 Error_Msg_Node_2
:= Inner
;
7363 ("circular Instantiation: & instantiated within &!",
7371 -- Indicate that Inner is being instantiated within Scop
7373 Append_Elmt
(Inner
, Inner_Instances
(Scop
));
7376 if Scop
= Standard_Standard
then
7379 Scop
:= Scope
(Scop
);
7384 end Contains_Instance_Of
;
7386 -----------------------
7387 -- Copy_Generic_Node --
7388 -----------------------
7390 function Copy_Generic_Node
7392 Parent_Id
: Node_Id
;
7393 Instantiating
: Boolean) return Node_Id
7398 function Copy_Generic_Descendant
(D
: Union_Id
) return Union_Id
;
7399 -- Check the given value of one of the Fields referenced by the current
7400 -- node to determine whether to copy it recursively. The field may hold
7401 -- a Node_Id, a List_Id, or an Elist_Id, or a plain value (Sloc, Uint,
7402 -- Char) in which case it need not be copied.
7404 procedure Copy_Descendants
;
7405 -- Common utility for various nodes
7407 function Copy_Generic_Elist
(E
: Elist_Id
) return Elist_Id
;
7408 -- Make copy of element list
7410 function Copy_Generic_List
7412 Parent_Id
: Node_Id
) return List_Id
;
7413 -- Apply Copy_Node recursively to the members of a node list
7415 function In_Defining_Unit_Name
(Nam
: Node_Id
) return Boolean;
7416 -- True if an identifier is part of the defining program unit name of
7417 -- a child unit. The entity of such an identifier must be kept (for
7418 -- ASIS use) even though as the name of an enclosing generic it would
7419 -- otherwise not be preserved in the generic tree.
7421 ----------------------
7422 -- Copy_Descendants --
7423 ----------------------
7425 procedure Copy_Descendants
is
7426 use Atree
.Unchecked_Access
;
7427 -- This code section is part of the implementation of an untyped
7428 -- tree traversal, so it needs direct access to node fields.
7431 Set_Field1
(New_N
, Copy_Generic_Descendant
(Field1
(N
)));
7432 Set_Field2
(New_N
, Copy_Generic_Descendant
(Field2
(N
)));
7433 Set_Field3
(New_N
, Copy_Generic_Descendant
(Field3
(N
)));
7434 Set_Field4
(New_N
, Copy_Generic_Descendant
(Field4
(N
)));
7435 Set_Field5
(New_N
, Copy_Generic_Descendant
(Field5
(N
)));
7436 end Copy_Descendants
;
7438 -----------------------------
7439 -- Copy_Generic_Descendant --
7440 -----------------------------
7442 function Copy_Generic_Descendant
(D
: Union_Id
) return Union_Id
is
7444 if D
= Union_Id
(Empty
) then
7447 elsif D
in Node_Range
then
7449 (Copy_Generic_Node
(Node_Id
(D
), New_N
, Instantiating
));
7451 elsif D
in List_Range
then
7452 return Union_Id
(Copy_Generic_List
(List_Id
(D
), New_N
));
7454 elsif D
in Elist_Range
then
7455 return Union_Id
(Copy_Generic_Elist
(Elist_Id
(D
)));
7457 -- Nothing else is copyable (e.g. Uint values), return as is
7462 end Copy_Generic_Descendant
;
7464 ------------------------
7465 -- Copy_Generic_Elist --
7466 ------------------------
7468 function Copy_Generic_Elist
(E
: Elist_Id
) return Elist_Id
is
7475 M
:= First_Elmt
(E
);
7476 while Present
(M
) loop
7478 (Copy_Generic_Node
(Node
(M
), Empty
, Instantiating
), L
);
7487 end Copy_Generic_Elist
;
7489 -----------------------
7490 -- Copy_Generic_List --
7491 -----------------------
7493 function Copy_Generic_List
7495 Parent_Id
: Node_Id
) return List_Id
7503 Set_Parent
(New_L
, Parent_Id
);
7506 while Present
(N
) loop
7507 Append
(Copy_Generic_Node
(N
, Empty
, Instantiating
), New_L
);
7516 end Copy_Generic_List
;
7518 ---------------------------
7519 -- In_Defining_Unit_Name --
7520 ---------------------------
7522 function In_Defining_Unit_Name
(Nam
: Node_Id
) return Boolean is
7525 Present
(Parent
(Nam
))
7526 and then (Nkind
(Parent
(Nam
)) = N_Defining_Program_Unit_Name
7528 (Nkind
(Parent
(Nam
)) = N_Expanded_Name
7529 and then In_Defining_Unit_Name
(Parent
(Nam
))));
7530 end In_Defining_Unit_Name
;
7532 -- Start of processing for Copy_Generic_Node
7539 New_N
:= New_Copy
(N
);
7541 -- Copy aspects if present
7543 if Has_Aspects
(N
) then
7544 Set_Has_Aspects
(New_N
, False);
7545 Set_Aspect_Specifications
7546 (New_N
, Copy_Generic_List
(Aspect_Specifications
(N
), Parent_Id
));
7549 -- If we are instantiating, we want to adjust the sloc based on the
7550 -- current S_Adjustment. However, if this is the root node of a subunit,
7551 -- we need to defer that adjustment to below (see "elsif Instantiating
7552 -- and Was_Stub"), so it comes after Create_Instantiation_Source has
7553 -- computed the adjustment.
7556 and then not (Nkind
(N
) in N_Proper_Body
7557 and then Was_Originally_Stub
(N
))
7559 Adjust_Instantiation_Sloc
(New_N
, S_Adjustment
);
7562 if not Is_List_Member
(N
) then
7563 Set_Parent
(New_N
, Parent_Id
);
7566 -- Special casing for identifiers and other entity names and operators
7568 if Nkind_In
(New_N
, N_Character_Literal
,
7572 or else Nkind
(New_N
) in N_Op
7574 if not Instantiating
then
7576 -- Link both nodes in order to assign subsequently the entity of
7577 -- the copy to the original node, in case this is a global
7580 Set_Associated_Node
(N
, New_N
);
7582 -- If we are within an instantiation, this is a nested generic
7583 -- that has already been analyzed at the point of definition.
7584 -- We must preserve references that were global to the enclosing
7585 -- parent at that point. Other occurrences, whether global or
7586 -- local to the current generic, must be resolved anew, so we
7587 -- reset the entity in the generic copy. A global reference has a
7588 -- smaller depth than the parent, or else the same depth in case
7589 -- both are distinct compilation units.
7591 -- A child unit is implicitly declared within the enclosing parent
7592 -- but is in fact global to it, and must be preserved.
7594 -- It is also possible for Current_Instantiated_Parent to be
7595 -- defined, and for this not to be a nested generic, namely if
7596 -- the unit is loaded through Rtsfind. In that case, the entity of
7597 -- New_N is only a link to the associated node, and not a defining
7600 -- The entities for parent units in the defining_program_unit of a
7601 -- generic child unit are established when the context of the unit
7602 -- is first analyzed, before the generic copy is made. They are
7603 -- preserved in the copy for use in ASIS queries.
7605 Ent
:= Entity
(New_N
);
7607 if No
(Current_Instantiated_Parent
.Gen_Id
) then
7609 or else Nkind
(Ent
) /= N_Defining_Identifier
7610 or else not In_Defining_Unit_Name
(N
)
7612 Set_Associated_Node
(New_N
, Empty
);
7617 not Nkind_In
(Ent
, N_Defining_Identifier
,
7618 N_Defining_Character_Literal
,
7619 N_Defining_Operator_Symbol
)
7620 or else No
(Scope
(Ent
))
7622 (Scope
(Ent
) = Current_Instantiated_Parent
.Gen_Id
7623 and then not Is_Child_Unit
(Ent
))
7625 (Scope_Depth
(Scope
(Ent
)) >
7626 Scope_Depth
(Current_Instantiated_Parent
.Gen_Id
)
7628 Get_Source_Unit
(Ent
) =
7629 Get_Source_Unit
(Current_Instantiated_Parent
.Gen_Id
))
7631 Set_Associated_Node
(New_N
, Empty
);
7634 -- Case of instantiating identifier or some other name or operator
7637 -- If the associated node is still defined, the entity in it
7638 -- is global, and must be copied to the instance. If this copy
7639 -- is being made for a body to inline, it is applied to an
7640 -- instantiated tree, and the entity is already present and
7641 -- must be also preserved.
7644 Assoc
: constant Node_Id
:= Get_Associated_Node
(N
);
7647 if Present
(Assoc
) then
7648 if Nkind
(Assoc
) = Nkind
(N
) then
7649 Set_Entity
(New_N
, Entity
(Assoc
));
7650 Check_Private_View
(N
);
7652 -- The node is a reference to a global type and acts as the
7653 -- subtype mark of a qualified expression created in order
7654 -- to aid resolution of accidental overloading in instances.
7655 -- Since N is a reference to a type, the Associated_Node of
7656 -- N denotes an entity rather than another identifier. See
7657 -- Qualify_Universal_Operands for details.
7659 elsif Nkind
(N
) = N_Identifier
7660 and then Nkind
(Parent
(N
)) = N_Qualified_Expression
7661 and then Subtype_Mark
(Parent
(N
)) = N
7662 and then Is_Qualified_Universal_Literal
(Parent
(N
))
7664 Set_Entity
(New_N
, Assoc
);
7666 -- The name in the call may be a selected component if the
7667 -- call has not been analyzed yet, as may be the case for
7668 -- pre/post conditions in a generic unit.
7670 elsif Nkind
(Assoc
) = N_Function_Call
7671 and then Is_Entity_Name
(Name
(Assoc
))
7673 Set_Entity
(New_N
, Entity
(Name
(Assoc
)));
7675 elsif Nkind_In
(Assoc
, N_Defining_Identifier
,
7676 N_Defining_Character_Literal
,
7677 N_Defining_Operator_Symbol
)
7678 and then Expander_Active
7680 -- Inlining case: we are copying a tree that contains
7681 -- global entities, which are preserved in the copy to be
7682 -- used for subsequent inlining.
7687 Set_Entity
(New_N
, Empty
);
7693 -- For expanded name, we must copy the Prefix and Selector_Name
7695 if Nkind
(N
) = N_Expanded_Name
then
7697 (New_N
, Copy_Generic_Node
(Prefix
(N
), New_N
, Instantiating
));
7699 Set_Selector_Name
(New_N
,
7700 Copy_Generic_Node
(Selector_Name
(N
), New_N
, Instantiating
));
7702 -- For operators, copy the operands
7704 elsif Nkind
(N
) in N_Op
then
7705 if Nkind
(N
) in N_Binary_Op
then
7706 Set_Left_Opnd
(New_N
,
7707 Copy_Generic_Node
(Left_Opnd
(N
), New_N
, Instantiating
));
7710 Set_Right_Opnd
(New_N
,
7711 Copy_Generic_Node
(Right_Opnd
(N
), New_N
, Instantiating
));
7714 -- Establish a link between an entity from the generic template and the
7715 -- corresponding entity in the generic copy to be analyzed.
7717 elsif Nkind
(N
) in N_Entity
then
7718 if not Instantiating
then
7719 Set_Associated_Entity
(N
, New_N
);
7722 -- Clear any existing link the copy may inherit from the replicated
7723 -- generic template entity.
7725 Set_Associated_Entity
(New_N
, Empty
);
7727 -- Special casing for stubs
7729 elsif Nkind
(N
) in N_Body_Stub
then
7731 -- In any case, we must copy the specification or defining
7732 -- identifier as appropriate.
7734 if Nkind
(N
) = N_Subprogram_Body_Stub
then
7735 Set_Specification
(New_N
,
7736 Copy_Generic_Node
(Specification
(N
), New_N
, Instantiating
));
7739 Set_Defining_Identifier
(New_N
,
7741 (Defining_Identifier
(N
), New_N
, Instantiating
));
7744 -- If we are not instantiating, then this is where we load and
7745 -- analyze subunits, i.e. at the point where the stub occurs. A
7746 -- more permissive system might defer this analysis to the point
7747 -- of instantiation, but this seems too complicated for now.
7749 if not Instantiating
then
7751 Subunit_Name
: constant Unit_Name_Type
:= Get_Unit_Name
(N
);
7753 Unum
: Unit_Number_Type
;
7757 -- Make sure that, if it is a subunit of the main unit that is
7758 -- preprocessed and if -gnateG is specified, the preprocessed
7759 -- file will be written.
7761 Lib
.Analysing_Subunit_Of_Main
:=
7762 Lib
.In_Extended_Main_Source_Unit
(N
);
7765 (Load_Name
=> Subunit_Name
,
7769 Lib
.Analysing_Subunit_Of_Main
:= False;
7771 -- If the proper body is not found, a warning message will be
7772 -- emitted when analyzing the stub, or later at the point of
7773 -- instantiation. Here we just leave the stub as is.
7775 if Unum
= No_Unit
then
7776 Subunits_Missing
:= True;
7777 goto Subunit_Not_Found
;
7780 Subunit
:= Cunit
(Unum
);
7782 if Nkind
(Unit
(Subunit
)) /= N_Subunit
then
7784 ("found child unit instead of expected SEPARATE subunit",
7786 Error_Msg_Sloc
:= Sloc
(N
);
7787 Error_Msg_N
("\to complete stub #", Subunit
);
7788 goto Subunit_Not_Found
;
7791 -- We must create a generic copy of the subunit, in order to
7792 -- perform semantic analysis on it, and we must replace the
7793 -- stub in the original generic unit with the subunit, in order
7794 -- to preserve non-local references within.
7796 -- Only the proper body needs to be copied. Library_Unit and
7797 -- context clause are simply inherited by the generic copy.
7798 -- Note that the copy (which may be recursive if there are
7799 -- nested subunits) must be done first, before attaching it to
7800 -- the enclosing generic.
7804 (Proper_Body
(Unit
(Subunit
)),
7805 Empty
, Instantiating
=> False);
7807 -- Now place the original proper body in the original generic
7808 -- unit. This is a body, not a compilation unit.
7810 Rewrite
(N
, Proper_Body
(Unit
(Subunit
)));
7811 Set_Is_Compilation_Unit
(Defining_Entity
(N
), False);
7812 Set_Was_Originally_Stub
(N
);
7814 -- Finally replace the body of the subunit with its copy, and
7815 -- make this new subunit into the library unit of the generic
7816 -- copy, which does not have stubs any longer.
7818 Set_Proper_Body
(Unit
(Subunit
), New_Body
);
7819 Set_Library_Unit
(New_N
, Subunit
);
7820 Inherit_Context
(Unit
(Subunit
), N
);
7823 -- If we are instantiating, this must be an error case, since
7824 -- otherwise we would have replaced the stub node by the proper body
7825 -- that corresponds. So just ignore it in the copy (i.e. we have
7826 -- copied it, and that is good enough).
7832 <<Subunit_Not_Found
>> null;
7834 -- If the node is a compilation unit, it is the subunit of a stub, which
7835 -- has been loaded already (see code below). In this case, the library
7836 -- unit field of N points to the parent unit (which is a compilation
7837 -- unit) and need not (and cannot) be copied.
7839 -- When the proper body of the stub is analyzed, the library_unit link
7840 -- is used to establish the proper context (see sem_ch10).
7842 -- The other fields of a compilation unit are copied as usual
7844 elsif Nkind
(N
) = N_Compilation_Unit
then
7846 -- This code can only be executed when not instantiating, because in
7847 -- the copy made for an instantiation, the compilation unit node has
7848 -- disappeared at the point that a stub is replaced by its proper
7851 pragma Assert
(not Instantiating
);
7853 Set_Context_Items
(New_N
,
7854 Copy_Generic_List
(Context_Items
(N
), New_N
));
7857 Copy_Generic_Node
(Unit
(N
), New_N
, Instantiating
=> False));
7859 Set_First_Inlined_Subprogram
(New_N
,
7861 (First_Inlined_Subprogram
(N
), New_N
, Instantiating
=> False));
7866 (Aux_Decls_Node
(N
), New_N
, Instantiating
=> False));
7868 -- For an assignment node, the assignment is known to be semantically
7869 -- legal if we are instantiating the template. This avoids incorrect
7870 -- diagnostics in generated code.
7872 elsif Nkind
(N
) = N_Assignment_Statement
then
7874 -- Copy name and expression fields in usual manner
7877 Copy_Generic_Node
(Name
(N
), New_N
, Instantiating
));
7879 Set_Expression
(New_N
,
7880 Copy_Generic_Node
(Expression
(N
), New_N
, Instantiating
));
7882 if Instantiating
then
7883 Set_Assignment_OK
(Name
(New_N
), True);
7886 elsif Nkind_In
(N
, N_Aggregate
, N_Extension_Aggregate
) then
7887 if not Instantiating
then
7888 Set_Associated_Node
(N
, New_N
);
7891 if Present
(Get_Associated_Node
(N
))
7892 and then Nkind
(Get_Associated_Node
(N
)) = Nkind
(N
)
7894 -- In the generic the aggregate has some composite type. If at
7895 -- the point of instantiation the type has a private view,
7896 -- install the full view (and that of its ancestors, if any).
7899 T
: Entity_Id
:= (Etype
(Get_Associated_Node
(New_N
)));
7903 if Present
(T
) and then Is_Private_Type
(T
) then
7908 and then Is_Tagged_Type
(T
)
7909 and then Is_Derived_Type
(T
)
7911 Rt
:= Root_Type
(T
);
7916 if Is_Private_Type
(T
) then
7927 -- Do not copy the associated node, which points to the generic copy
7928 -- of the aggregate.
7931 use Atree
.Unchecked_Access
;
7932 -- This code section is part of the implementation of an untyped
7933 -- tree traversal, so it needs direct access to node fields.
7936 Set_Field1
(New_N
, Copy_Generic_Descendant
(Field1
(N
)));
7937 Set_Field2
(New_N
, Copy_Generic_Descendant
(Field2
(N
)));
7938 Set_Field3
(New_N
, Copy_Generic_Descendant
(Field3
(N
)));
7939 Set_Field5
(New_N
, Copy_Generic_Descendant
(Field5
(N
)));
7942 -- Allocators do not have an identifier denoting the access type, so we
7943 -- must locate it through the expression to check whether the views are
7946 elsif Nkind
(N
) = N_Allocator
7947 and then Nkind
(Expression
(N
)) = N_Qualified_Expression
7948 and then Is_Entity_Name
(Subtype_Mark
(Expression
(N
)))
7949 and then Instantiating
7952 T
: constant Node_Id
:=
7953 Get_Associated_Node
(Subtype_Mark
(Expression
(N
)));
7959 -- Retrieve the allocator node in the generic copy
7961 Acc_T
:= Etype
(Parent
(Parent
(T
)));
7963 if Present
(Acc_T
) and then Is_Private_Type
(Acc_T
) then
7964 Switch_View
(Acc_T
);
7971 -- For a proper body, we must catch the case of a proper body that
7972 -- replaces a stub. This represents the point at which a separate
7973 -- compilation unit, and hence template file, may be referenced, so we
7974 -- must make a new source instantiation entry for the template of the
7975 -- subunit, and ensure that all nodes in the subunit are adjusted using
7976 -- this new source instantiation entry.
7978 elsif Nkind
(N
) in N_Proper_Body
then
7980 Save_Adjustment
: constant Sloc_Adjustment
:= S_Adjustment
;
7982 if Instantiating
and then Was_Originally_Stub
(N
) then
7983 Create_Instantiation_Source
7984 (Instantiation_Node
,
7985 Defining_Entity
(N
),
7988 Adjust_Instantiation_Sloc
(New_N
, S_Adjustment
);
7991 -- Now copy the fields of the proper body, using the new
7992 -- adjustment factor if one was needed as per test above.
7996 -- Restore the original adjustment factor
7998 S_Adjustment
:= Save_Adjustment
;
8001 elsif Nkind
(N
) = N_Pragma
and then Instantiating
then
8003 -- Do not copy Comment or Ident pragmas their content is relevant to
8004 -- the generic unit, not to the instantiating unit.
8006 if Nam_In
(Pragma_Name_Unmapped
(N
), Name_Comment
, Name_Ident
) then
8007 New_N
:= Make_Null_Statement
(Sloc
(N
));
8009 -- Do not copy pragmas generated from aspects because the pragmas do
8010 -- not carry any semantic information, plus they will be regenerated
8013 -- However, generating C we need to copy them since postconditions
8014 -- are inlined by the front end, and the front-end inlining machinery
8015 -- relies on this routine to perform inlining.
8017 elsif From_Aspect_Specification
(N
)
8018 and then not Modify_Tree_For_C
8020 New_N
:= Make_Null_Statement
(Sloc
(N
));
8026 elsif Nkind_In
(N
, N_Integer_Literal
, N_Real_Literal
) then
8028 -- No descendant fields need traversing
8032 elsif Nkind
(N
) = N_String_Literal
8033 and then Present
(Etype
(N
))
8034 and then Instantiating
8036 -- If the string is declared in an outer scope, the string_literal
8037 -- subtype created for it may have the wrong scope. Force reanalysis
8038 -- of the constant to generate a new itype in the proper context.
8040 Set_Etype
(New_N
, Empty
);
8041 Set_Analyzed
(New_N
, False);
8043 -- For the remaining nodes, copy their descendants recursively
8048 if Instantiating
and then Nkind
(N
) = N_Subprogram_Body
then
8049 Set_Generic_Parent
(Specification
(New_N
), N
);
8051 -- Should preserve Corresponding_Spec??? (12.3(14))
8055 -- Propagate dimensions if present, so that they are reflected in the
8058 if Nkind
(N
) in N_Has_Etype
8059 and then (Nkind
(N
) in N_Op
or else Is_Entity_Name
(N
))
8060 and then Present
(Etype
(N
))
8061 and then Is_Floating_Point_Type
(Etype
(N
))
8062 and then Has_Dimension_System
(Etype
(N
))
8064 Copy_Dimensions
(N
, New_N
);
8068 end Copy_Generic_Node
;
8070 ----------------------------
8071 -- Denotes_Formal_Package --
8072 ----------------------------
8074 function Denotes_Formal_Package
8076 On_Exit
: Boolean := False;
8077 Instance
: Entity_Id
:= Empty
) return Boolean
8080 Scop
: constant Entity_Id
:= Scope
(Pack
);
8083 function Is_Actual_Of_Previous_Formal
(P
: Entity_Id
) return Boolean;
8084 -- The package in question may be an actual for a previous formal
8085 -- package P of the current instance, so examine its actuals as well.
8086 -- This must be recursive over other formal packages.
8088 ----------------------------------
8089 -- Is_Actual_Of_Previous_Formal --
8090 ----------------------------------
8092 function Is_Actual_Of_Previous_Formal
(P
: Entity_Id
) return Boolean is
8096 E1
:= First_Entity
(P
);
8097 while Present
(E1
) and then E1
/= Instance
loop
8098 if Ekind
(E1
) = E_Package
8099 and then Nkind
(Parent
(E1
)) = N_Package_Renaming_Declaration
8101 if Renamed_Object
(E1
) = Pack
then
8104 elsif E1
= P
or else Renamed_Object
(E1
) = P
then
8107 elsif Is_Actual_Of_Previous_Formal
(E1
) then
8116 end Is_Actual_Of_Previous_Formal
;
8118 -- Start of processing for Denotes_Formal_Package
8124 (Instance_Envs
.Last
).Instantiated_Parent
.Act_Id
;
8126 Par
:= Current_Instantiated_Parent
.Act_Id
;
8129 if Ekind
(Scop
) = E_Generic_Package
8130 or else Nkind
(Unit_Declaration_Node
(Scop
)) =
8131 N_Generic_Subprogram_Declaration
8135 elsif Nkind
(Original_Node
(Unit_Declaration_Node
(Pack
))) =
8136 N_Formal_Package_Declaration
8144 -- Check whether this package is associated with a formal package of
8145 -- the enclosing instantiation. Iterate over the list of renamings.
8147 E
:= First_Entity
(Par
);
8148 while Present
(E
) loop
8149 if Ekind
(E
) /= E_Package
8150 or else Nkind
(Parent
(E
)) /= N_Package_Renaming_Declaration
8154 elsif Renamed_Object
(E
) = Par
then
8157 elsif Renamed_Object
(E
) = Pack
then
8160 elsif Is_Actual_Of_Previous_Formal
(E
) then
8170 end Denotes_Formal_Package
;
8176 procedure End_Generic
is
8178 -- ??? More things could be factored out in this routine. Should
8179 -- probably be done at a later stage.
8181 Inside_A_Generic
:= Generic_Flags
.Table
(Generic_Flags
.Last
);
8182 Generic_Flags
.Decrement_Last
;
8184 Expander_Mode_Restore
;
8191 function Earlier
(N1
, N2
: Node_Id
) return Boolean is
8192 procedure Find_Depth
(P
: in out Node_Id
; D
: in out Integer);
8193 -- Find distance from given node to enclosing compilation unit
8199 procedure Find_Depth
(P
: in out Node_Id
; D
: in out Integer) is
8202 and then Nkind
(P
) /= N_Compilation_Unit
8204 P
:= True_Parent
(P
);
8209 -- Local declarations
8218 -- Start of processing for Earlier
8221 Find_Depth
(P1
, D1
);
8222 Find_Depth
(P2
, D2
);
8232 P1
:= True_Parent
(P1
);
8237 P2
:= True_Parent
(P2
);
8241 -- At this point P1 and P2 are at the same distance from the root.
8242 -- We examine their parents until we find a common declarative list.
8243 -- If we reach the root, N1 and N2 do not descend from the same
8244 -- declarative list (e.g. one is nested in the declarative part and
8245 -- the other is in a block in the statement part) and the earlier
8246 -- one is already frozen.
8248 while not Is_List_Member
(P1
)
8249 or else not Is_List_Member
(P2
)
8250 or else List_Containing
(P1
) /= List_Containing
(P2
)
8252 P1
:= True_Parent
(P1
);
8253 P2
:= True_Parent
(P2
);
8255 if Nkind
(Parent
(P1
)) = N_Subunit
then
8256 P1
:= Corresponding_Stub
(Parent
(P1
));
8259 if Nkind
(Parent
(P2
)) = N_Subunit
then
8260 P2
:= Corresponding_Stub
(Parent
(P2
));
8268 -- Expanded code usually shares the source location of the original
8269 -- construct it was generated for. This however may not necessarily
8270 -- reflect the true location of the code within the tree.
8272 -- Before comparing the slocs of the two nodes, make sure that we are
8273 -- working with correct source locations. Assume that P1 is to the left
8274 -- of P2. If either one does not come from source, traverse the common
8275 -- list heading towards the other node and locate the first source
8279 -- ----+===+===+--------------+===+===+----
8280 -- expanded code expanded code
8282 if not Comes_From_Source
(P1
) then
8283 while Present
(P1
) loop
8285 -- Neither P2 nor a source statement were located during the
8286 -- search. If we reach the end of the list, then P1 does not
8287 -- occur earlier than P2.
8290 -- start --- P2 ----- P1 --- end
8292 if No
(Next
(P1
)) then
8295 -- We encounter P2 while going to the right of the list. This
8296 -- means that P1 does indeed appear earlier.
8299 -- start --- P1 ===== P2 --- end
8300 -- expanded code in between
8305 -- No need to look any further since we have located a source
8308 elsif Comes_From_Source
(P1
) then
8318 if not Comes_From_Source
(P2
) then
8319 while Present
(P2
) loop
8321 -- Neither P1 nor a source statement were located during the
8322 -- search. If we reach the start of the list, then P1 does not
8323 -- occur earlier than P2.
8326 -- start --- P2 --- P1 --- end
8328 if No
(Prev
(P2
)) then
8331 -- We encounter P1 while going to the left of the list. This
8332 -- means that P1 does indeed appear earlier.
8335 -- start --- P1 ===== P2 --- end
8336 -- expanded code in between
8341 -- No need to look any further since we have located a source
8344 elsif Comes_From_Source
(P2
) then
8354 -- At this point either both nodes came from source or we approximated
8355 -- their source locations through neighboring source statements.
8357 T1
:= Top_Level_Location
(Sloc
(P1
));
8358 T2
:= Top_Level_Location
(Sloc
(P2
));
8360 -- When two nodes come from the same instance, they have identical top
8361 -- level locations. To determine proper relation within the tree, check
8362 -- their locations within the template.
8365 return Sloc
(P1
) < Sloc
(P2
);
8367 -- The two nodes either come from unrelated instances or do not come
8368 -- from instantiated code at all.
8375 ----------------------
8376 -- Find_Actual_Type --
8377 ----------------------
8379 function Find_Actual_Type
8381 Gen_Type
: Entity_Id
) return Entity_Id
8383 Gen_Scope
: constant Entity_Id
:= Scope
(Gen_Type
);
8387 -- Special processing only applies to child units
8389 if not Is_Child_Unit
(Gen_Scope
) then
8390 return Get_Instance_Of
(Typ
);
8392 -- If designated or component type is itself a formal of the child unit,
8393 -- its instance is available.
8395 elsif Scope
(Typ
) = Gen_Scope
then
8396 return Get_Instance_Of
(Typ
);
8398 -- If the array or access type is not declared in the parent unit,
8399 -- no special processing needed.
8401 elsif not Is_Generic_Type
(Typ
)
8402 and then Scope
(Gen_Scope
) /= Scope
(Typ
)
8404 return Get_Instance_Of
(Typ
);
8406 -- Otherwise, retrieve designated or component type by visibility
8409 T
:= Current_Entity
(Typ
);
8410 while Present
(T
) loop
8411 if In_Open_Scopes
(Scope
(T
)) then
8413 elsif Is_Generic_Actual_Type
(T
) then
8422 end Find_Actual_Type
;
8424 ----------------------------
8425 -- Freeze_Subprogram_Body --
8426 ----------------------------
8428 procedure Freeze_Subprogram_Body
8429 (Inst_Node
: Node_Id
;
8431 Pack_Id
: Entity_Id
)
8433 Gen_Unit
: constant Entity_Id
:= Get_Generic_Entity
(Inst_Node
);
8434 Par
: constant Entity_Id
:= Scope
(Gen_Unit
);
8440 function Enclosing_Package_Body
(N
: Node_Id
) return Node_Id
;
8441 -- Find innermost package body that encloses the given node, and which
8442 -- is not a compilation unit. Freeze nodes for the instance, or for its
8443 -- enclosing body, may be inserted after the enclosing_body of the
8444 -- generic unit. Used to determine proper placement of freeze node for
8445 -- both package and subprogram instances.
8447 function Package_Freeze_Node
(B
: Node_Id
) return Node_Id
;
8448 -- Find entity for given package body, and locate or create a freeze
8451 ----------------------------
8452 -- Enclosing_Package_Body --
8453 ----------------------------
8455 function Enclosing_Package_Body
(N
: Node_Id
) return Node_Id
is
8461 and then Nkind
(Parent
(P
)) /= N_Compilation_Unit
8463 if Nkind
(P
) = N_Package_Body
then
8464 if Nkind
(Parent
(P
)) = N_Subunit
then
8465 return Corresponding_Stub
(Parent
(P
));
8471 P
:= True_Parent
(P
);
8475 end Enclosing_Package_Body
;
8477 -------------------------
8478 -- Package_Freeze_Node --
8479 -------------------------
8481 function Package_Freeze_Node
(B
: Node_Id
) return Node_Id
is
8485 if Nkind
(B
) = N_Package_Body
then
8486 Id
:= Corresponding_Spec
(B
);
8487 else pragma Assert
(Nkind
(B
) = N_Package_Body_Stub
);
8488 Id
:= Corresponding_Spec
(Proper_Body
(Unit
(Library_Unit
(B
))));
8491 Ensure_Freeze_Node
(Id
);
8492 return Freeze_Node
(Id
);
8493 end Package_Freeze_Node
;
8495 -- Start of processing for Freeze_Subprogram_Body
8498 -- If the instance and the generic body appear within the same unit, and
8499 -- the instance precedes the generic, the freeze node for the instance
8500 -- must appear after that of the generic. If the generic is nested
8501 -- within another instance I2, then current instance must be frozen
8502 -- after I2. In both cases, the freeze nodes are those of enclosing
8503 -- packages. Otherwise, the freeze node is placed at the end of the
8504 -- current declarative part.
8506 Enc_G
:= Enclosing_Package_Body
(Gen_Body
);
8507 Enc_I
:= Enclosing_Package_Body
(Inst_Node
);
8508 Ensure_Freeze_Node
(Pack_Id
);
8509 F_Node
:= Freeze_Node
(Pack_Id
);
8511 if Is_Generic_Instance
(Par
)
8512 and then Present
(Freeze_Node
(Par
))
8513 and then In_Same_Declarative_Part
(Freeze_Node
(Par
), Inst_Node
)
8515 -- The parent was a premature instantiation. Insert freeze node at
8516 -- the end the current declarative part.
8518 if ABE_Is_Certain
(Get_Unit_Instantiation_Node
(Par
)) then
8519 Insert_Freeze_Node_For_Instance
(Inst_Node
, F_Node
);
8521 -- Handle the following case:
8523 -- package Parent_Inst is new ...
8526 -- procedure P ... -- this body freezes Parent_Inst
8528 -- package Inst is new ...
8530 -- In this particular scenario, the freeze node for Inst must be
8531 -- inserted in the same manner as that of Parent_Inst - before the
8532 -- next source body or at the end of the declarative list (body not
8533 -- available). If body P did not exist and Parent_Inst was frozen
8534 -- after Inst, either by a body following Inst or at the end of the
8535 -- declarative region, the freeze node for Inst must be inserted
8536 -- after that of Parent_Inst. This relation is established by
8537 -- comparing the Slocs of Parent_Inst freeze node and Inst.
8539 elsif List_Containing
(Get_Unit_Instantiation_Node
(Par
)) =
8540 List_Containing
(Inst_Node
)
8541 and then Sloc
(Freeze_Node
(Par
)) < Sloc
(Inst_Node
)
8543 Insert_Freeze_Node_For_Instance
(Inst_Node
, F_Node
);
8546 Insert_After
(Freeze_Node
(Par
), F_Node
);
8549 -- The body enclosing the instance should be frozen after the body that
8550 -- includes the generic, because the body of the instance may make
8551 -- references to entities therein. If the two are not in the same
8552 -- declarative part, or if the one enclosing the instance is frozen
8553 -- already, freeze the instance at the end of the current declarative
8556 elsif Is_Generic_Instance
(Par
)
8557 and then Present
(Freeze_Node
(Par
))
8558 and then Present
(Enc_I
)
8560 if In_Same_Declarative_Part
(Freeze_Node
(Par
), Enc_I
)
8562 (Nkind
(Enc_I
) = N_Package_Body
8564 In_Same_Declarative_Part
(Freeze_Node
(Par
), Parent
(Enc_I
)))
8566 -- The enclosing package may contain several instances. Rather
8567 -- than computing the earliest point at which to insert its freeze
8568 -- node, we place it at the end of the declarative part of the
8569 -- parent of the generic.
8571 Insert_Freeze_Node_For_Instance
8572 (Freeze_Node
(Par
), Package_Freeze_Node
(Enc_I
));
8575 Insert_Freeze_Node_For_Instance
(Inst_Node
, F_Node
);
8577 elsif Present
(Enc_G
)
8578 and then Present
(Enc_I
)
8579 and then Enc_G
/= Enc_I
8580 and then Earlier
(Inst_Node
, Gen_Body
)
8582 if Nkind
(Enc_G
) = N_Package_Body
then
8584 Corresponding_Spec
(Enc_G
);
8585 else pragma Assert
(Nkind
(Enc_G
) = N_Package_Body_Stub
);
8587 Corresponding_Spec
(Proper_Body
(Unit
(Library_Unit
(Enc_G
))));
8590 -- Freeze package that encloses instance, and place node after the
8591 -- package that encloses generic. If enclosing package is already
8592 -- frozen we have to assume it is at the proper place. This may be a
8593 -- potential ABE that requires dynamic checking. Do not add a freeze
8594 -- node if the package that encloses the generic is inside the body
8595 -- that encloses the instance, because the freeze node would be in
8596 -- the wrong scope. Additional contortions needed if the bodies are
8597 -- within a subunit.
8600 Enclosing_Body
: Node_Id
;
8603 if Nkind
(Enc_I
) = N_Package_Body_Stub
then
8604 Enclosing_Body
:= Proper_Body
(Unit
(Library_Unit
(Enc_I
)));
8606 Enclosing_Body
:= Enc_I
;
8609 if Parent
(List_Containing
(Enc_G
)) /= Enclosing_Body
then
8610 Insert_Freeze_Node_For_Instance
8611 (Enc_G
, Package_Freeze_Node
(Enc_I
));
8615 -- Freeze enclosing subunit before instance
8617 Ensure_Freeze_Node
(E_G_Id
);
8619 if not Is_List_Member
(Freeze_Node
(E_G_Id
)) then
8620 Insert_After
(Enc_G
, Freeze_Node
(E_G_Id
));
8623 Insert_Freeze_Node_For_Instance
(Inst_Node
, F_Node
);
8626 -- If none of the above, insert freeze node at the end of the current
8627 -- declarative part.
8629 Insert_Freeze_Node_For_Instance
(Inst_Node
, F_Node
);
8631 end Freeze_Subprogram_Body
;
8637 function Get_Gen_Id
(E
: Assoc_Ptr
) return Entity_Id
is
8639 return Generic_Renamings
.Table
(E
).Gen_Id
;
8642 ---------------------
8643 -- Get_Instance_Of --
8644 ---------------------
8646 function Get_Instance_Of
(A
: Entity_Id
) return Entity_Id
is
8647 Res
: constant Assoc_Ptr
:= Generic_Renamings_HTable
.Get
(A
);
8650 if Res
/= Assoc_Null
then
8651 return Generic_Renamings
.Table
(Res
).Act_Id
;
8654 -- On exit, entity is not instantiated: not a generic parameter, or
8655 -- else parameter of an inner generic unit.
8659 end Get_Instance_Of
;
8661 ---------------------------------
8662 -- Get_Unit_Instantiation_Node --
8663 ---------------------------------
8665 function Get_Unit_Instantiation_Node
(A
: Entity_Id
) return Node_Id
is
8666 Decl
: Node_Id
:= Unit_Declaration_Node
(A
);
8670 -- If the Package_Instantiation attribute has been set on the package
8671 -- entity, then use it directly when it (or its Original_Node) refers
8672 -- to an N_Package_Instantiation node. In principle it should be
8673 -- possible to have this field set in all cases, which should be
8674 -- investigated, and would allow this function to be significantly
8677 Inst
:= Package_Instantiation
(A
);
8679 if Present
(Inst
) then
8680 if Nkind
(Inst
) = N_Package_Instantiation
then
8683 elsif Nkind
(Original_Node
(Inst
)) = N_Package_Instantiation
then
8684 return Original_Node
(Inst
);
8688 -- If the instantiation is a compilation unit that does not need body
8689 -- then the instantiation node has been rewritten as a package
8690 -- declaration for the instance, and we return the original node.
8692 -- If it is a compilation unit and the instance node has not been
8693 -- rewritten, then it is still the unit of the compilation. Finally, if
8694 -- a body is present, this is a parent of the main unit whose body has
8695 -- been compiled for inlining purposes, and the instantiation node has
8696 -- been rewritten with the instance body.
8698 -- Otherwise the instantiation node appears after the declaration. If
8699 -- the entity is a formal package, the declaration may have been
8700 -- rewritten as a generic declaration (in the case of a formal with box)
8701 -- or left as a formal package declaration if it has actuals, and is
8702 -- found with a forward search.
8704 if Nkind
(Parent
(Decl
)) = N_Compilation_Unit
then
8705 if Nkind
(Decl
) = N_Package_Declaration
8706 and then Present
(Corresponding_Body
(Decl
))
8708 Decl
:= Unit_Declaration_Node
(Corresponding_Body
(Decl
));
8711 if Nkind_In
(Original_Node
(Decl
), N_Function_Instantiation
,
8712 N_Package_Instantiation
,
8713 N_Procedure_Instantiation
)
8715 return Original_Node
(Decl
);
8717 return Unit
(Parent
(Decl
));
8720 elsif Nkind
(Decl
) = N_Package_Declaration
8721 and then Nkind
(Original_Node
(Decl
)) = N_Formal_Package_Declaration
8723 return Original_Node
(Decl
);
8726 Inst
:= Next
(Decl
);
8727 while not Nkind_In
(Inst
, N_Formal_Package_Declaration
,
8728 N_Function_Instantiation
,
8729 N_Package_Instantiation
,
8730 N_Procedure_Instantiation
)
8737 end Get_Unit_Instantiation_Node
;
8739 ------------------------
8740 -- Has_Been_Exchanged --
8741 ------------------------
8743 function Has_Been_Exchanged
(E
: Entity_Id
) return Boolean is
8747 Next
:= First_Elmt
(Exchanged_Views
);
8748 while Present
(Next
) loop
8749 if Full_View
(Node
(Next
)) = E
then
8757 end Has_Been_Exchanged
;
8763 function Hash
(F
: Entity_Id
) return HTable_Range
is
8765 return HTable_Range
(F
mod HTable_Size
);
8768 ------------------------
8769 -- Hide_Current_Scope --
8770 ------------------------
8772 procedure Hide_Current_Scope
is
8773 C
: constant Entity_Id
:= Current_Scope
;
8777 Set_Is_Hidden_Open_Scope
(C
);
8779 E
:= First_Entity
(C
);
8780 while Present
(E
) loop
8781 if Is_Immediately_Visible
(E
) then
8782 Set_Is_Immediately_Visible
(E
, False);
8783 Append_Elmt
(E
, Hidden_Entities
);
8789 -- Make the scope name invisible as well. This is necessary, but might
8790 -- conflict with calls to Rtsfind later on, in case the scope is a
8791 -- predefined one. There is no clean solution to this problem, so for
8792 -- now we depend on the user not redefining Standard itself in one of
8793 -- the parent units.
8795 if Is_Immediately_Visible
(C
) and then C
/= Standard_Standard
then
8796 Set_Is_Immediately_Visible
(C
, False);
8797 Append_Elmt
(C
, Hidden_Entities
);
8800 end Hide_Current_Scope
;
8806 procedure Init_Env
is
8807 Saved
: Instance_Env
;
8810 Saved
.Instantiated_Parent
:= Current_Instantiated_Parent
;
8811 Saved
.Exchanged_Views
:= Exchanged_Views
;
8812 Saved
.Hidden_Entities
:= Hidden_Entities
;
8813 Saved
.Current_Sem_Unit
:= Current_Sem_Unit
;
8814 Saved
.Parent_Unit_Visible
:= Parent_Unit_Visible
;
8815 Saved
.Instance_Parent_Unit
:= Instance_Parent_Unit
;
8817 -- Save configuration switches. These may be reset if the unit is a
8818 -- predefined unit, and the current mode is not Ada 2005.
8820 Save_Opt_Config_Switches
(Saved
.Switches
);
8822 Instance_Envs
.Append
(Saved
);
8824 Exchanged_Views
:= New_Elmt_List
;
8825 Hidden_Entities
:= New_Elmt_List
;
8827 -- Make dummy entry for Instantiated parent. If generic unit is legal,
8828 -- this is set properly in Set_Instance_Env.
8830 Current_Instantiated_Parent
:=
8831 (Current_Scope
, Current_Scope
, Assoc_Null
);
8834 ------------------------------
8835 -- In_Same_Declarative_Part --
8836 ------------------------------
8838 function In_Same_Declarative_Part
8840 Inst
: Node_Id
) return Boolean
8842 Decls
: constant Node_Id
:= Parent
(F_Node
);
8846 Nod
:= Parent
(Inst
);
8847 while Present
(Nod
) loop
8851 elsif Nkind_In
(Nod
, N_Subprogram_Body
,
8853 N_Package_Declaration
,
8860 elsif Nkind
(Nod
) = N_Subunit
then
8861 Nod
:= Corresponding_Stub
(Nod
);
8863 elsif Nkind
(Nod
) = N_Compilation_Unit
then
8867 Nod
:= Parent
(Nod
);
8872 end In_Same_Declarative_Part
;
8874 ---------------------
8875 -- In_Main_Context --
8876 ---------------------
8878 function In_Main_Context
(E
: Entity_Id
) return Boolean is
8884 if not Is_Compilation_Unit
(E
)
8885 or else Ekind
(E
) /= E_Package
8886 or else In_Private_Part
(E
)
8891 Context
:= Context_Items
(Cunit
(Main_Unit
));
8893 Clause
:= First
(Context
);
8894 while Present
(Clause
) loop
8895 if Nkind
(Clause
) = N_With_Clause
then
8896 Nam
:= Name
(Clause
);
8898 -- If the current scope is part of the context of the main unit,
8899 -- analysis of the corresponding with_clause is not complete, and
8900 -- the entity is not set. We use the Chars field directly, which
8901 -- might produce false positives in rare cases, but guarantees
8902 -- that we produce all the instance bodies we will need.
8904 if (Is_Entity_Name
(Nam
) and then Chars
(Nam
) = Chars
(E
))
8905 or else (Nkind
(Nam
) = N_Selected_Component
8906 and then Chars
(Selector_Name
(Nam
)) = Chars
(E
))
8916 end In_Main_Context
;
8918 ---------------------
8919 -- Inherit_Context --
8920 ---------------------
8922 procedure Inherit_Context
(Gen_Decl
: Node_Id
; Inst
: Node_Id
) is
8923 Current_Context
: List_Id
;
8924 Current_Unit
: Node_Id
;
8933 if Nkind
(Parent
(Gen_Decl
)) = N_Compilation_Unit
then
8935 -- The inherited context is attached to the enclosing compilation
8936 -- unit. This is either the main unit, or the declaration for the
8937 -- main unit (in case the instantiation appears within the package
8938 -- declaration and the main unit is its body).
8940 Current_Unit
:= Parent
(Inst
);
8941 while Present
(Current_Unit
)
8942 and then Nkind
(Current_Unit
) /= N_Compilation_Unit
8944 Current_Unit
:= Parent
(Current_Unit
);
8947 Current_Context
:= Context_Items
(Current_Unit
);
8949 Item
:= First
(Context_Items
(Parent
(Gen_Decl
)));
8950 while Present
(Item
) loop
8951 if Nkind
(Item
) = N_With_Clause
then
8952 Lib_Unit
:= Library_Unit
(Item
);
8954 -- Take care to prevent direct cyclic with's
8956 if Lib_Unit
/= Current_Unit
then
8958 -- Do not add a unit if it is already in the context
8960 Clause
:= First
(Current_Context
);
8962 while Present
(Clause
) loop
8963 if Nkind
(Clause
) = N_With_Clause
and then
8964 Library_Unit
(Clause
) = Lib_Unit
8974 New_I
:= New_Copy
(Item
);
8975 Set_Implicit_With
(New_I
, True);
8976 Set_Implicit_With_From_Instantiation
(New_I
, True);
8977 Append
(New_I
, Current_Context
);
8985 end Inherit_Context
;
8991 procedure Initialize
is
8993 Generic_Renamings
.Init
;
8996 Generic_Renamings_HTable
.Reset
;
8997 Circularity_Detected
:= False;
8998 Exchanged_Views
:= No_Elist
;
8999 Hidden_Entities
:= No_Elist
;
9002 -------------------------------------
9003 -- Insert_Freeze_Node_For_Instance --
9004 -------------------------------------
9006 procedure Insert_Freeze_Node_For_Instance
9015 function Enclosing_Body
(N
: Node_Id
) return Node_Id
;
9016 -- Find enclosing package or subprogram body, if any. Freeze node may
9017 -- be placed at end of current declarative list if previous instance
9018 -- and current one have different enclosing bodies.
9020 function Previous_Instance
(Gen
: Entity_Id
) return Entity_Id
;
9021 -- Find the local instance, if any, that declares the generic that is
9022 -- being instantiated. If present, the freeze node for this instance
9023 -- must follow the freeze node for the previous instance.
9025 --------------------
9026 -- Enclosing_Body --
9027 --------------------
9029 function Enclosing_Body
(N
: Node_Id
) return Node_Id
is
9035 and then Nkind
(Parent
(P
)) /= N_Compilation_Unit
9037 if Nkind_In
(P
, N_Package_Body
, N_Subprogram_Body
) then
9038 if Nkind
(Parent
(P
)) = N_Subunit
then
9039 return Corresponding_Stub
(Parent
(P
));
9045 P
:= True_Parent
(P
);
9051 -----------------------
9052 -- Previous_Instance --
9053 -----------------------
9055 function Previous_Instance
(Gen
: Entity_Id
) return Entity_Id
is
9060 while Present
(S
) and then S
/= Standard_Standard
loop
9061 if Is_Generic_Instance
(S
)
9062 and then In_Same_Source_Unit
(S
, N
)
9071 end Previous_Instance
;
9073 -- Start of processing for Insert_Freeze_Node_For_Instance
9076 if not Is_List_Member
(F_Node
) then
9078 Decls
:= List_Containing
(N
);
9079 Inst
:= Entity
(F_Node
);
9080 Par_N
:= Parent
(Decls
);
9082 -- When processing a subprogram instantiation, utilize the actual
9083 -- subprogram instantiation rather than its package wrapper as it
9084 -- carries all the context information.
9086 if Is_Wrapper_Package
(Inst
) then
9087 Inst
:= Related_Instance
(Inst
);
9090 -- If this is a package instance, check whether the generic is
9091 -- declared in a previous instance and the current instance is
9092 -- not within the previous one.
9094 if Present
(Generic_Parent
(Parent
(Inst
)))
9095 and then Is_In_Main_Unit
(N
)
9098 Enclosing_N
: constant Node_Id
:= Enclosing_Body
(N
);
9099 Par_I
: constant Entity_Id
:=
9101 (Generic_Parent
(Parent
(Inst
)));
9106 and then Earlier
(N
, Freeze_Node
(Par_I
))
9108 Scop
:= Scope
(Inst
);
9110 -- If the current instance is within the one that contains
9111 -- the generic, the freeze node for the current one must
9112 -- appear in the current declarative part. Ditto, if the
9113 -- current instance is within another package instance or
9114 -- within a body that does not enclose the current instance.
9115 -- In these three cases the freeze node of the previous
9116 -- instance is not relevant.
9118 while Present
(Scop
) and then Scop
/= Standard_Standard
loop
9119 exit when Scop
= Par_I
9121 (Is_Generic_Instance
(Scop
)
9122 and then Scope_Depth
(Scop
) > Scope_Depth
(Par_I
));
9123 Scop
:= Scope
(Scop
);
9126 -- Previous instance encloses current instance
9128 if Scop
= Par_I
then
9131 -- If the next node is a source body we must freeze in
9132 -- the current scope as well.
9134 elsif Present
(Next
(N
))
9135 and then Nkind_In
(Next
(N
), N_Subprogram_Body
,
9137 and then Comes_From_Source
(Next
(N
))
9141 -- Current instance is within an unrelated instance
9143 elsif Is_Generic_Instance
(Scop
) then
9146 -- Current instance is within an unrelated body
9148 elsif Present
(Enclosing_N
)
9149 and then Enclosing_N
/= Enclosing_Body
(Par_I
)
9154 Insert_After
(Freeze_Node
(Par_I
), F_Node
);
9161 -- When the instantiation occurs in a package declaration, append the
9162 -- freeze node to the private declarations (if any).
9164 if Nkind
(Par_N
) = N_Package_Specification
9165 and then Decls
= Visible_Declarations
(Par_N
)
9166 and then Present
(Private_Declarations
(Par_N
))
9167 and then not Is_Empty_List
(Private_Declarations
(Par_N
))
9169 Decls
:= Private_Declarations
(Par_N
);
9170 Decl
:= First
(Decls
);
9173 -- Determine the proper freeze point of a package instantiation. We
9174 -- adhere to the general rule of a package or subprogram body causing
9175 -- freezing of anything before it in the same declarative region. In
9176 -- this case, the proper freeze point of a package instantiation is
9177 -- before the first source body which follows, or before a stub. This
9178 -- ensures that entities coming from the instance are already frozen
9179 -- and usable in source bodies.
9181 if Nkind
(Par_N
) /= N_Package_Declaration
9182 and then Ekind
(Inst
) = E_Package
9183 and then Is_Generic_Instance
(Inst
)
9185 not In_Same_Source_Unit
(Generic_Parent
(Parent
(Inst
)), Inst
)
9187 while Present
(Decl
) loop
9188 if (Nkind
(Decl
) in N_Unit_Body
9190 Nkind
(Decl
) in N_Body_Stub
)
9191 and then Comes_From_Source
(Decl
)
9193 Insert_Before
(Decl
, F_Node
);
9201 -- In a package declaration, or if no previous body, insert at end
9204 Set_Sloc
(F_Node
, Sloc
(Last
(Decls
)));
9205 Insert_After
(Last
(Decls
), F_Node
);
9207 end Insert_Freeze_Node_For_Instance
;
9213 procedure Install_Body
9214 (Act_Body
: Node_Id
;
9219 function In_Same_Scope
(Gen_Id
, Act_Id
: Node_Id
) return Boolean;
9220 -- Check if the generic definition and the instantiation come from
9221 -- a common scope, in which case the instance must be frozen after
9222 -- the generic body.
9224 function True_Sloc
(N
, Act_Unit
: Node_Id
) return Source_Ptr
;
9225 -- If the instance is nested inside a generic unit, the Sloc of the
9226 -- instance indicates the place of the original definition, not the
9227 -- point of the current enclosing instance. Pending a better usage of
9228 -- Slocs to indicate instantiation places, we determine the place of
9229 -- origin of a node by finding the maximum sloc of any ancestor node.
9230 -- Why is this not equivalent to Top_Level_Location ???
9236 function In_Same_Scope
(Gen_Id
, Act_Id
: Node_Id
) return Boolean is
9237 Act_Scop
: Entity_Id
:= Scope
(Act_Id
);
9238 Gen_Scop
: Entity_Id
:= Scope
(Gen_Id
);
9241 while Act_Scop
/= Standard_Standard
9242 and then Gen_Scop
/= Standard_Standard
9244 if Act_Scop
= Gen_Scop
then
9248 Act_Scop
:= Scope
(Act_Scop
);
9249 Gen_Scop
:= Scope
(Gen_Scop
);
9259 function True_Sloc
(N
, Act_Unit
: Node_Id
) return Source_Ptr
is
9266 while Present
(N1
) and then N1
/= Act_Unit
loop
9267 if Sloc
(N1
) > Res
then
9277 Act_Id
: constant Entity_Id
:= Corresponding_Spec
(Act_Body
);
9278 Act_Unit
: constant Node_Id
:= Unit
(Cunit
(Get_Source_Unit
(N
)));
9279 Gen_Id
: constant Entity_Id
:= Corresponding_Spec
(Gen_Body
);
9280 Par
: constant Entity_Id
:= Scope
(Gen_Id
);
9281 Gen_Unit
: constant Node_Id
:=
9282 Unit
(Cunit
(Get_Source_Unit
(Gen_Decl
)));
9284 Body_Unit
: Node_Id
;
9286 Must_Delay
: Boolean;
9287 Orig_Body
: Node_Id
:= Gen_Body
;
9289 -- Start of processing for Install_Body
9292 -- Handle first the case of an instance with incomplete actual types.
9293 -- The instance body cannot be placed after the declaration because
9294 -- full views have not been seen yet. Any use of the non-limited views
9295 -- in the instance body requires the presence of a regular with_clause
9296 -- in the enclosing unit, and will fail if this with_clause is missing.
9297 -- We place the instance body at the beginning of the enclosing body,
9298 -- which is the unit being compiled. The freeze node for the instance
9299 -- is then placed after the instance body.
9301 if not Is_Empty_Elmt_List
(Incomplete_Actuals
(Act_Id
))
9302 and then Expander_Active
9303 and then Ekind
(Scope
(Act_Id
)) = E_Package
9306 Scop
: constant Entity_Id
:= Scope
(Act_Id
);
9307 Body_Id
: constant Node_Id
:=
9308 Corresponding_Body
(Unit_Declaration_Node
(Scop
));
9311 Ensure_Freeze_Node
(Act_Id
);
9312 F_Node
:= Freeze_Node
(Act_Id
);
9313 if Present
(Body_Id
) then
9314 Set_Is_Frozen
(Act_Id
, False);
9315 Prepend
(Act_Body
, Declarations
(Parent
(Body_Id
)));
9316 if Is_List_Member
(F_Node
) then
9320 Insert_After
(Act_Body
, F_Node
);
9326 -- If the body is a subunit, the freeze point is the corresponding stub
9327 -- in the current compilation, not the subunit itself.
9329 if Nkind
(Parent
(Gen_Body
)) = N_Subunit
then
9330 Orig_Body
:= Corresponding_Stub
(Parent
(Gen_Body
));
9332 Orig_Body
:= Gen_Body
;
9335 Body_Unit
:= Unit
(Cunit
(Get_Source_Unit
(Orig_Body
)));
9337 -- If the instantiation and the generic definition appear in the same
9338 -- package declaration, this is an early instantiation. If they appear
9339 -- in the same declarative part, it is an early instantiation only if
9340 -- the generic body appears textually later, and the generic body is
9341 -- also in the main unit.
9343 -- If instance is nested within a subprogram, and the generic body
9344 -- is not, the instance is delayed because the enclosing body is. If
9345 -- instance and body are within the same scope, or the same subprogram
9346 -- body, indicate explicitly that the instance is delayed.
9349 (Gen_Unit
= Act_Unit
9350 and then (Nkind_In
(Gen_Unit
, N_Generic_Package_Declaration
,
9351 N_Package_Declaration
)
9352 or else (Gen_Unit
= Body_Unit
9353 and then True_Sloc
(N
, Act_Unit
) <
9355 and then Is_In_Main_Unit
(Original_Node
(Gen_Unit
))
9356 and then In_Same_Scope
(Gen_Id
, Act_Id
));
9358 -- If this is an early instantiation, the freeze node is placed after
9359 -- the generic body. Otherwise, if the generic appears in an instance,
9360 -- we cannot freeze the current instance until the outer one is frozen.
9361 -- This is only relevant if the current instance is nested within some
9362 -- inner scope not itself within the outer instance. If this scope is
9363 -- a package body in the same declarative part as the outer instance,
9364 -- then that body needs to be frozen after the outer instance. Finally,
9365 -- if no delay is needed, we place the freeze node at the end of the
9366 -- current declarative part.
9369 and then (No
(Freeze_Node
(Act_Id
))
9370 or else not Is_List_Member
(Freeze_Node
(Act_Id
)))
9372 Ensure_Freeze_Node
(Act_Id
);
9373 F_Node
:= Freeze_Node
(Act_Id
);
9376 Insert_After
(Orig_Body
, F_Node
);
9378 elsif Is_Generic_Instance
(Par
)
9379 and then Present
(Freeze_Node
(Par
))
9380 and then Scope
(Act_Id
) /= Par
9382 -- Freeze instance of inner generic after instance of enclosing
9385 if In_Same_Declarative_Part
(Freeze_Node
(Par
), N
) then
9387 -- Handle the following case:
9389 -- package Parent_Inst is new ...
9392 -- procedure P ... -- this body freezes Parent_Inst
9394 -- package Inst is new ...
9396 -- In this particular scenario, the freeze node for Inst must
9397 -- be inserted in the same manner as that of Parent_Inst,
9398 -- before the next source body or at the end of the declarative
9399 -- list (body not available). If body P did not exist and
9400 -- Parent_Inst was frozen after Inst, either by a body
9401 -- following Inst or at the end of the declarative region,
9402 -- the freeze node for Inst must be inserted after that of
9403 -- Parent_Inst. This relation is established by comparing
9404 -- the Slocs of Parent_Inst freeze node and Inst.
9406 if List_Containing
(Get_Unit_Instantiation_Node
(Par
)) =
9408 and then Sloc
(Freeze_Node
(Par
)) < Sloc
(N
)
9410 Insert_Freeze_Node_For_Instance
(N
, F_Node
);
9412 Insert_After
(Freeze_Node
(Par
), F_Node
);
9415 -- Freeze package enclosing instance of inner generic after
9416 -- instance of enclosing generic.
9418 elsif Nkind_In
(Parent
(N
), N_Package_Body
, N_Subprogram_Body
)
9419 and then In_Same_Declarative_Part
(Freeze_Node
(Par
), Parent
(N
))
9422 Enclosing
: Entity_Id
;
9425 Enclosing
:= Corresponding_Spec
(Parent
(N
));
9427 if No
(Enclosing
) then
9428 Enclosing
:= Defining_Entity
(Parent
(N
));
9431 Insert_Freeze_Node_For_Instance
(N
, F_Node
);
9432 Ensure_Freeze_Node
(Enclosing
);
9434 if not Is_List_Member
(Freeze_Node
(Enclosing
)) then
9436 -- The enclosing context is a subunit, insert the freeze
9437 -- node after the stub.
9439 if Nkind
(Parent
(Parent
(N
))) = N_Subunit
then
9440 Insert_Freeze_Node_For_Instance
9441 (Corresponding_Stub
(Parent
(Parent
(N
))),
9442 Freeze_Node
(Enclosing
));
9444 -- The enclosing context is a package with a stub body
9445 -- which has already been replaced by the real body.
9446 -- Insert the freeze node after the actual body.
9448 elsif Ekind
(Enclosing
) = E_Package
9449 and then Present
(Body_Entity
(Enclosing
))
9450 and then Was_Originally_Stub
9451 (Parent
(Body_Entity
(Enclosing
)))
9453 Insert_Freeze_Node_For_Instance
9454 (Parent
(Body_Entity
(Enclosing
)),
9455 Freeze_Node
(Enclosing
));
9457 -- The parent instance has been frozen before the body of
9458 -- the enclosing package, insert the freeze node after
9461 elsif List_Containing
(Freeze_Node
(Par
)) =
9462 List_Containing
(Parent
(N
))
9463 and then Sloc
(Freeze_Node
(Par
)) < Sloc
(Parent
(N
))
9465 Insert_Freeze_Node_For_Instance
9466 (Parent
(N
), Freeze_Node
(Enclosing
));
9470 (Freeze_Node
(Par
), Freeze_Node
(Enclosing
));
9476 Insert_Freeze_Node_For_Instance
(N
, F_Node
);
9480 Insert_Freeze_Node_For_Instance
(N
, F_Node
);
9484 Set_Is_Frozen
(Act_Id
);
9485 Insert_Before
(N
, Act_Body
);
9486 Mark_Rewrite_Insertion
(Act_Body
);
9489 -----------------------------
9490 -- Install_Formal_Packages --
9491 -----------------------------
9493 procedure Install_Formal_Packages
(Par
: Entity_Id
) is
9496 Gen_E
: Entity_Id
:= Empty
;
9499 E
:= First_Entity
(Par
);
9501 -- If we are installing an instance parent, locate the formal packages
9502 -- of its generic parent.
9504 if Is_Generic_Instance
(Par
) then
9505 Gen
:= Generic_Parent
(Package_Specification
(Par
));
9506 Gen_E
:= First_Entity
(Gen
);
9509 while Present
(E
) loop
9510 if Ekind
(E
) = E_Package
9511 and then Nkind
(Parent
(E
)) = N_Package_Renaming_Declaration
9513 -- If this is the renaming for the parent instance, done
9515 if Renamed_Object
(E
) = Par
then
9518 -- The visibility of a formal of an enclosing generic is already
9521 elsif Denotes_Formal_Package
(E
) then
9524 elsif Present
(Associated_Formal_Package
(E
)) then
9525 Check_Generic_Actuals
(Renamed_Object
(E
), True);
9526 Set_Is_Hidden
(E
, False);
9528 -- Find formal package in generic unit that corresponds to
9529 -- (instance of) formal package in instance.
9531 while Present
(Gen_E
) and then Chars
(Gen_E
) /= Chars
(E
) loop
9532 Next_Entity
(Gen_E
);
9535 if Present
(Gen_E
) then
9536 Map_Formal_Package_Entities
(Gen_E
, E
);
9543 if Present
(Gen_E
) then
9544 Next_Entity
(Gen_E
);
9547 end Install_Formal_Packages
;
9549 --------------------
9550 -- Install_Parent --
9551 --------------------
9553 procedure Install_Parent
(P
: Entity_Id
; In_Body
: Boolean := False) is
9554 Ancestors
: constant Elist_Id
:= New_Elmt_List
;
9555 S
: constant Entity_Id
:= Current_Scope
;
9556 Inst_Par
: Entity_Id
;
9557 First_Par
: Entity_Id
;
9558 Inst_Node
: Node_Id
;
9559 Gen_Par
: Entity_Id
;
9560 First_Gen
: Entity_Id
;
9563 procedure Install_Noninstance_Specs
(Par
: Entity_Id
);
9564 -- Install the scopes of noninstance parent units ending with Par
9566 procedure Install_Spec
(Par
: Entity_Id
);
9567 -- The child unit is within the declarative part of the parent, so the
9568 -- declarations within the parent are immediately visible.
9570 -------------------------------
9571 -- Install_Noninstance_Specs --
9572 -------------------------------
9574 procedure Install_Noninstance_Specs
(Par
: Entity_Id
) is
9577 and then Par
/= Standard_Standard
9578 and then not In_Open_Scopes
(Par
)
9580 Install_Noninstance_Specs
(Scope
(Par
));
9583 end Install_Noninstance_Specs
;
9589 procedure Install_Spec
(Par
: Entity_Id
) is
9590 Spec
: constant Node_Id
:= Package_Specification
(Par
);
9593 -- If this parent of the child instance is a top-level unit,
9594 -- then record the unit and its visibility for later resetting in
9595 -- Remove_Parent. We exclude units that are generic instances, as we
9596 -- only want to record this information for the ultimate top-level
9597 -- noninstance parent (is that always correct???).
9599 if Scope
(Par
) = Standard_Standard
9600 and then not Is_Generic_Instance
(Par
)
9602 Parent_Unit_Visible
:= Is_Immediately_Visible
(Par
);
9603 Instance_Parent_Unit
:= Par
;
9606 -- Open the parent scope and make it and its declarations visible.
9607 -- If this point is not within a body, then only the visible
9608 -- declarations should be made visible, and installation of the
9609 -- private declarations is deferred until the appropriate point
9610 -- within analysis of the spec being instantiated (see the handling
9611 -- of parent visibility in Analyze_Package_Specification). This is
9612 -- relaxed in the case where the parent unit is Ada.Tags, to avoid
9613 -- private view problems that occur when compiling instantiations of
9614 -- a generic child of that package (Generic_Dispatching_Constructor).
9615 -- If the instance freezes a tagged type, inlinings of operations
9616 -- from Ada.Tags may need the full view of type Tag. If inlining took
9617 -- proper account of establishing visibility of inlined subprograms'
9618 -- parents then it should be possible to remove this
9619 -- special check. ???
9622 Set_Is_Immediately_Visible
(Par
);
9623 Install_Visible_Declarations
(Par
);
9624 Set_Use
(Visible_Declarations
(Spec
));
9626 if In_Body
or else Is_RTU
(Par
, Ada_Tags
) then
9627 Install_Private_Declarations
(Par
);
9628 Set_Use
(Private_Declarations
(Spec
));
9632 -- Start of processing for Install_Parent
9635 -- We need to install the parent instance to compile the instantiation
9636 -- of the child, but the child instance must appear in the current
9637 -- scope. Given that we cannot place the parent above the current scope
9638 -- in the scope stack, we duplicate the current scope and unstack both
9639 -- after the instantiation is complete.
9641 -- If the parent is itself the instantiation of a child unit, we must
9642 -- also stack the instantiation of its parent, and so on. Each such
9643 -- ancestor is the prefix of the name in a prior instantiation.
9645 -- If this is a nested instance, the parent unit itself resolves to
9646 -- a renaming of the parent instance, whose declaration we need.
9648 -- Finally, the parent may be a generic (not an instance) when the
9649 -- child unit appears as a formal package.
9653 if Present
(Renamed_Entity
(Inst_Par
)) then
9654 Inst_Par
:= Renamed_Entity
(Inst_Par
);
9657 First_Par
:= Inst_Par
;
9659 Gen_Par
:= Generic_Parent
(Package_Specification
(Inst_Par
));
9661 First_Gen
:= Gen_Par
;
9663 while Present
(Gen_Par
) and then Is_Child_Unit
(Gen_Par
) loop
9665 -- Load grandparent instance as well
9667 Inst_Node
:= Get_Unit_Instantiation_Node
(Inst_Par
);
9669 if Nkind
(Name
(Inst_Node
)) = N_Expanded_Name
then
9670 Inst_Par
:= Entity
(Prefix
(Name
(Inst_Node
)));
9672 if Present
(Renamed_Entity
(Inst_Par
)) then
9673 Inst_Par
:= Renamed_Entity
(Inst_Par
);
9676 Gen_Par
:= Generic_Parent
(Package_Specification
(Inst_Par
));
9678 if Present
(Gen_Par
) then
9679 Prepend_Elmt
(Inst_Par
, Ancestors
);
9682 -- Parent is not the name of an instantiation
9684 Install_Noninstance_Specs
(Inst_Par
);
9695 if Present
(First_Gen
) then
9696 Append_Elmt
(First_Par
, Ancestors
);
9698 Install_Noninstance_Specs
(First_Par
);
9701 if not Is_Empty_Elmt_List
(Ancestors
) then
9702 Elmt
:= First_Elmt
(Ancestors
);
9703 while Present
(Elmt
) loop
9704 Install_Spec
(Node
(Elmt
));
9705 Install_Formal_Packages
(Node
(Elmt
));
9715 -------------------------------
9716 -- Install_Hidden_Primitives --
9717 -------------------------------
9719 procedure Install_Hidden_Primitives
9720 (Prims_List
: in out Elist_Id
;
9725 List
: Elist_Id
:= No_Elist
;
9726 Prim_G_Elmt
: Elmt_Id
;
9727 Prim_A_Elmt
: Elmt_Id
;
9732 -- No action needed in case of serious errors because we cannot trust
9733 -- in the order of primitives
9735 if Serious_Errors_Detected
> 0 then
9738 -- No action possible if we don't have available the list of primitive
9742 or else not Is_Record_Type
(Gen_T
)
9743 or else not Is_Tagged_Type
(Gen_T
)
9744 or else not Is_Record_Type
(Act_T
)
9745 or else not Is_Tagged_Type
(Act_T
)
9749 -- There is no need to handle interface types since their primitives
9752 elsif Is_Interface
(Gen_T
) then
9756 Prim_G_Elmt
:= First_Elmt
(Primitive_Operations
(Gen_T
));
9758 if not Is_Class_Wide_Type
(Act_T
) then
9759 Prim_A_Elmt
:= First_Elmt
(Primitive_Operations
(Act_T
));
9761 Prim_A_Elmt
:= First_Elmt
(Primitive_Operations
(Root_Type
(Act_T
)));
9765 -- Skip predefined primitives in the generic formal
9767 while Present
(Prim_G_Elmt
)
9768 and then Is_Predefined_Dispatching_Operation
(Node
(Prim_G_Elmt
))
9770 Next_Elmt
(Prim_G_Elmt
);
9773 -- Skip predefined primitives in the generic actual
9775 while Present
(Prim_A_Elmt
)
9776 and then Is_Predefined_Dispatching_Operation
(Node
(Prim_A_Elmt
))
9778 Next_Elmt
(Prim_A_Elmt
);
9781 exit when No
(Prim_G_Elmt
) or else No
(Prim_A_Elmt
);
9783 Prim_G
:= Node
(Prim_G_Elmt
);
9784 Prim_A
:= Node
(Prim_A_Elmt
);
9786 -- There is no need to handle interface primitives because their
9787 -- primitives are not hidden
9789 exit when Present
(Interface_Alias
(Prim_G
));
9791 -- Here we install one hidden primitive
9793 if Chars
(Prim_G
) /= Chars
(Prim_A
)
9794 and then Has_Suffix
(Prim_A
, 'P')
9795 and then Remove_Suffix
(Prim_A
, 'P') = Chars
(Prim_G
)
9797 Set_Chars
(Prim_A
, Chars
(Prim_G
));
9798 Append_New_Elmt
(Prim_A
, To
=> List
);
9801 Next_Elmt
(Prim_A_Elmt
);
9802 Next_Elmt
(Prim_G_Elmt
);
9805 -- Append the elements to the list of temporarily visible primitives
9806 -- avoiding duplicates.
9808 if Present
(List
) then
9809 if No
(Prims_List
) then
9810 Prims_List
:= New_Elmt_List
;
9813 Elmt
:= First_Elmt
(List
);
9814 while Present
(Elmt
) loop
9815 Append_Unique_Elmt
(Node
(Elmt
), Prims_List
);
9819 end Install_Hidden_Primitives
;
9821 -------------------------------
9822 -- Restore_Hidden_Primitives --
9823 -------------------------------
9825 procedure Restore_Hidden_Primitives
(Prims_List
: in out Elist_Id
) is
9826 Prim_Elmt
: Elmt_Id
;
9830 if Prims_List
/= No_Elist
then
9831 Prim_Elmt
:= First_Elmt
(Prims_List
);
9832 while Present
(Prim_Elmt
) loop
9833 Prim
:= Node
(Prim_Elmt
);
9834 Set_Chars
(Prim
, Add_Suffix
(Prim
, 'P'));
9835 Next_Elmt
(Prim_Elmt
);
9838 Prims_List
:= No_Elist
;
9840 end Restore_Hidden_Primitives
;
9842 --------------------------------
9843 -- Instantiate_Formal_Package --
9844 --------------------------------
9846 function Instantiate_Formal_Package
9849 Analyzed_Formal
: Node_Id
) return List_Id
9851 Loc
: constant Source_Ptr
:= Sloc
(Actual
);
9852 Actual_Pack
: Entity_Id
;
9853 Formal_Pack
: Entity_Id
;
9854 Gen_Parent
: Entity_Id
;
9857 Parent_Spec
: Node_Id
;
9859 procedure Find_Matching_Actual
9861 Act
: in out Entity_Id
);
9862 -- We need to associate each formal entity in the formal package with
9863 -- the corresponding entity in the actual package. The actual package
9864 -- has been analyzed and possibly expanded, and as a result there is
9865 -- no one-to-one correspondence between the two lists (for example,
9866 -- the actual may include subtypes, itypes, and inherited primitive
9867 -- operations, interspersed among the renaming declarations for the
9868 -- actuals). We retrieve the corresponding actual by name because each
9869 -- actual has the same name as the formal, and they do appear in the
9872 function Get_Formal_Entity
(N
: Node_Id
) return Entity_Id
;
9873 -- Retrieve entity of defining entity of generic formal parameter.
9874 -- Only the declarations of formals need to be considered when
9875 -- linking them to actuals, but the declarative list may include
9876 -- internal entities generated during analysis, and those are ignored.
9878 procedure Match_Formal_Entity
9879 (Formal_Node
: Node_Id
;
9880 Formal_Ent
: Entity_Id
;
9881 Actual_Ent
: Entity_Id
);
9882 -- Associates the formal entity with the actual. In the case where
9883 -- Formal_Ent is a formal package, this procedure iterates through all
9884 -- of its formals and enters associations between the actuals occurring
9885 -- in the formal package's corresponding actual package (given by
9886 -- Actual_Ent) and the formal package's formal parameters. This
9887 -- procedure recurses if any of the parameters is itself a package.
9889 function Is_Instance_Of
9890 (Act_Spec
: Entity_Id
;
9891 Gen_Anc
: Entity_Id
) return Boolean;
9892 -- The actual can be an instantiation of a generic within another
9893 -- instance, in which case there is no direct link from it to the
9894 -- original generic ancestor. In that case, we recognize that the
9895 -- ultimate ancestor is the same by examining names and scopes.
9897 procedure Process_Nested_Formal
(Formal
: Entity_Id
);
9898 -- If the current formal is declared with a box, its own formals are
9899 -- visible in the instance, as they were in the generic, and their
9900 -- Hidden flag must be reset. If some of these formals are themselves
9901 -- packages declared with a box, the processing must be recursive.
9903 --------------------------
9904 -- Find_Matching_Actual --
9905 --------------------------
9907 procedure Find_Matching_Actual
9909 Act
: in out Entity_Id
)
9911 Formal_Ent
: Entity_Id
;
9914 case Nkind
(Original_Node
(F
)) is
9915 when N_Formal_Object_Declaration
9916 | N_Formal_Type_Declaration
9918 Formal_Ent
:= Defining_Identifier
(F
);
9920 while Chars
(Act
) /= Chars
(Formal_Ent
) loop
9924 when N_Formal_Package_Declaration
9925 | N_Formal_Subprogram_Declaration
9926 | N_Generic_Package_Declaration
9927 | N_Package_Declaration
9929 Formal_Ent
:= Defining_Entity
(F
);
9931 while Chars
(Act
) /= Chars
(Formal_Ent
) loop
9936 raise Program_Error
;
9938 end Find_Matching_Actual
;
9940 -------------------------
9941 -- Match_Formal_Entity --
9942 -------------------------
9944 procedure Match_Formal_Entity
9945 (Formal_Node
: Node_Id
;
9946 Formal_Ent
: Entity_Id
;
9947 Actual_Ent
: Entity_Id
)
9949 Act_Pkg
: Entity_Id
;
9952 Set_Instance_Of
(Formal_Ent
, Actual_Ent
);
9954 if Ekind
(Actual_Ent
) = E_Package
then
9956 -- Record associations for each parameter
9958 Act_Pkg
:= Actual_Ent
;
9961 A_Ent
: Entity_Id
:= First_Entity
(Act_Pkg
);
9970 -- Retrieve the actual given in the formal package declaration
9972 Actual
:= Entity
(Name
(Original_Node
(Formal_Node
)));
9974 -- The actual in the formal package declaration may be a
9975 -- renamed generic package, in which case we want to retrieve
9976 -- the original generic in order to traverse its formal part.
9978 if Present
(Renamed_Entity
(Actual
)) then
9979 Gen_Decl
:= Unit_Declaration_Node
(Renamed_Entity
(Actual
));
9981 Gen_Decl
:= Unit_Declaration_Node
(Actual
);
9984 Formals
:= Generic_Formal_Declarations
(Gen_Decl
);
9986 if Present
(Formals
) then
9987 F_Node
:= First_Non_Pragma
(Formals
);
9992 while Present
(A_Ent
)
9993 and then Present
(F_Node
)
9994 and then A_Ent
/= First_Private_Entity
(Act_Pkg
)
9996 F_Ent
:= Get_Formal_Entity
(F_Node
);
9998 if Present
(F_Ent
) then
10000 -- This is a formal of the original package. Record
10001 -- association and recurse.
10003 Find_Matching_Actual
(F_Node
, A_Ent
);
10004 Match_Formal_Entity
(F_Node
, F_Ent
, A_Ent
);
10005 Next_Entity
(A_Ent
);
10008 Next_Non_Pragma
(F_Node
);
10012 end Match_Formal_Entity
;
10014 -----------------------
10015 -- Get_Formal_Entity --
10016 -----------------------
10018 function Get_Formal_Entity
(N
: Node_Id
) return Entity_Id
is
10019 Kind
: constant Node_Kind
:= Nkind
(Original_Node
(N
));
10022 when N_Formal_Object_Declaration
=>
10023 return Defining_Identifier
(N
);
10025 when N_Formal_Type_Declaration
=>
10026 return Defining_Identifier
(N
);
10028 when N_Formal_Subprogram_Declaration
=>
10029 return Defining_Unit_Name
(Specification
(N
));
10031 when N_Formal_Package_Declaration
=>
10032 return Defining_Identifier
(Original_Node
(N
));
10034 when N_Generic_Package_Declaration
=>
10035 return Defining_Identifier
(Original_Node
(N
));
10037 -- All other declarations are introduced by semantic analysis and
10038 -- have no match in the actual.
10043 end Get_Formal_Entity
;
10045 --------------------
10046 -- Is_Instance_Of --
10047 --------------------
10049 function Is_Instance_Of
10050 (Act_Spec
: Entity_Id
;
10051 Gen_Anc
: Entity_Id
) return Boolean
10053 Gen_Par
: constant Entity_Id
:= Generic_Parent
(Act_Spec
);
10056 if No
(Gen_Par
) then
10059 -- Simplest case: the generic parent of the actual is the formal
10061 elsif Gen_Par
= Gen_Anc
then
10064 elsif Chars
(Gen_Par
) /= Chars
(Gen_Anc
) then
10067 -- The actual may be obtained through several instantiations. Its
10068 -- scope must itself be an instance of a generic declared in the
10069 -- same scope as the formal. Any other case is detected above.
10071 elsif not Is_Generic_Instance
(Scope
(Gen_Par
)) then
10075 return Generic_Parent
(Parent
(Scope
(Gen_Par
))) = Scope
(Gen_Anc
);
10077 end Is_Instance_Of
;
10079 ---------------------------
10080 -- Process_Nested_Formal --
10081 ---------------------------
10083 procedure Process_Nested_Formal
(Formal
: Entity_Id
) is
10087 if Present
(Associated_Formal_Package
(Formal
))
10088 and then Box_Present
(Parent
(Associated_Formal_Package
(Formal
)))
10090 Ent
:= First_Entity
(Formal
);
10091 while Present
(Ent
) loop
10092 Set_Is_Hidden
(Ent
, False);
10093 Set_Is_Visible_Formal
(Ent
);
10094 Set_Is_Potentially_Use_Visible
10095 (Ent
, Is_Potentially_Use_Visible
(Formal
));
10097 if Ekind
(Ent
) = E_Package
then
10098 exit when Renamed_Entity
(Ent
) = Renamed_Entity
(Formal
);
10099 Process_Nested_Formal
(Ent
);
10105 end Process_Nested_Formal
;
10107 -- Start of processing for Instantiate_Formal_Package
10112 if not Is_Entity_Name
(Actual
)
10113 or else Ekind
(Entity
(Actual
)) /= E_Package
10116 ("expect package instance to instantiate formal", Actual
);
10117 Abandon_Instantiation
(Actual
);
10118 raise Program_Error
;
10121 Actual_Pack
:= Entity
(Actual
);
10122 Set_Is_Instantiated
(Actual_Pack
);
10124 -- The actual may be a renamed package, or an outer generic formal
10125 -- package whose instantiation is converted into a renaming.
10127 if Present
(Renamed_Object
(Actual_Pack
)) then
10128 Actual_Pack
:= Renamed_Object
(Actual_Pack
);
10131 if Nkind
(Analyzed_Formal
) = N_Formal_Package_Declaration
then
10132 Gen_Parent
:= Get_Instance_Of
(Entity
(Name
(Analyzed_Formal
)));
10133 Formal_Pack
:= Defining_Identifier
(Analyzed_Formal
);
10136 Generic_Parent
(Specification
(Analyzed_Formal
));
10138 Defining_Unit_Name
(Specification
(Analyzed_Formal
));
10141 if Nkind
(Parent
(Actual_Pack
)) = N_Defining_Program_Unit_Name
then
10142 Parent_Spec
:= Package_Specification
(Actual_Pack
);
10144 Parent_Spec
:= Parent
(Actual_Pack
);
10147 if Gen_Parent
= Any_Id
then
10149 ("previous error in declaration of formal package", Actual
);
10150 Abandon_Instantiation
(Actual
);
10153 Is_Instance_Of
(Parent_Spec
, Get_Instance_Of
(Gen_Parent
))
10159 ("actual parameter must be instance of&", Actual
, Gen_Parent
);
10160 Abandon_Instantiation
(Actual
);
10163 Set_Instance_Of
(Defining_Identifier
(Formal
), Actual_Pack
);
10164 Map_Formal_Package_Entities
(Formal_Pack
, Actual_Pack
);
10167 Make_Package_Renaming_Declaration
(Loc
,
10168 Defining_Unit_Name
=> New_Copy
(Defining_Identifier
(Formal
)),
10169 Name
=> New_Occurrence_Of
(Actual_Pack
, Loc
));
10171 Set_Associated_Formal_Package
10172 (Defining_Unit_Name
(Nod
), Defining_Identifier
(Formal
));
10173 Decls
:= New_List
(Nod
);
10175 -- If the formal F has a box, then the generic declarations are
10176 -- visible in the generic G. In an instance of G, the corresponding
10177 -- entities in the actual for F (which are the actuals for the
10178 -- instantiation of the generic that F denotes) must also be made
10179 -- visible for analysis of the current instance. On exit from the
10180 -- current instance, those entities are made private again. If the
10181 -- actual is currently in use, these entities are also use-visible.
10183 -- The loop through the actual entities also steps through the formal
10184 -- entities and enters associations from formals to actuals into the
10185 -- renaming map. This is necessary to properly handle checking of
10186 -- actual parameter associations for later formals that depend on
10187 -- actuals declared in the formal package.
10189 -- In Ada 2005, partial parameterization requires that we make
10190 -- visible the actuals corresponding to formals that were defaulted
10191 -- in the formal package. There formals are identified because they
10192 -- remain formal generics within the formal package, rather than
10193 -- being renamings of the actuals supplied.
10196 Gen_Decl
: constant Node_Id
:=
10197 Unit_Declaration_Node
(Gen_Parent
);
10198 Formals
: constant List_Id
:=
10199 Generic_Formal_Declarations
(Gen_Decl
);
10201 Actual_Ent
: Entity_Id
;
10202 Actual_Of_Formal
: Node_Id
;
10203 Formal_Node
: Node_Id
;
10204 Formal_Ent
: Entity_Id
;
10207 if Present
(Formals
) then
10208 Formal_Node
:= First_Non_Pragma
(Formals
);
10210 Formal_Node
:= Empty
;
10213 Actual_Ent
:= First_Entity
(Actual_Pack
);
10214 Actual_Of_Formal
:=
10215 First
(Visible_Declarations
(Specification
(Analyzed_Formal
)));
10216 while Present
(Actual_Ent
)
10217 and then Actual_Ent
/= First_Private_Entity
(Actual_Pack
)
10219 if Present
(Formal_Node
) then
10220 Formal_Ent
:= Get_Formal_Entity
(Formal_Node
);
10222 if Present
(Formal_Ent
) then
10223 Find_Matching_Actual
(Formal_Node
, Actual_Ent
);
10224 Match_Formal_Entity
(Formal_Node
, Formal_Ent
, Actual_Ent
);
10226 -- We iterate at the same time over the actuals of the
10227 -- local package created for the formal, to determine
10228 -- which one of the formals of the original generic were
10229 -- defaulted in the formal. The corresponding actual
10230 -- entities are visible in the enclosing instance.
10232 if Box_Present
(Formal
)
10234 (Present
(Actual_Of_Formal
)
10237 (Get_Formal_Entity
(Actual_Of_Formal
)))
10239 Set_Is_Hidden
(Actual_Ent
, False);
10240 Set_Is_Visible_Formal
(Actual_Ent
);
10241 Set_Is_Potentially_Use_Visible
10242 (Actual_Ent
, In_Use
(Actual_Pack
));
10244 if Ekind
(Actual_Ent
) = E_Package
then
10245 Process_Nested_Formal
(Actual_Ent
);
10249 Set_Is_Hidden
(Actual_Ent
);
10250 Set_Is_Potentially_Use_Visible
(Actual_Ent
, False);
10254 Next_Non_Pragma
(Formal_Node
);
10255 Next
(Actual_Of_Formal
);
10258 -- No further formals to match, but the generic part may
10259 -- contain inherited operation that are not hidden in the
10260 -- enclosing instance.
10262 Next_Entity
(Actual_Ent
);
10266 -- Inherited subprograms generated by formal derived types are
10267 -- also visible if the types are.
10269 Actual_Ent
:= First_Entity
(Actual_Pack
);
10270 while Present
(Actual_Ent
)
10271 and then Actual_Ent
/= First_Private_Entity
(Actual_Pack
)
10273 if Is_Overloadable
(Actual_Ent
)
10275 Nkind
(Parent
(Actual_Ent
)) = N_Subtype_Declaration
10277 not Is_Hidden
(Defining_Identifier
(Parent
(Actual_Ent
)))
10279 Set_Is_Hidden
(Actual_Ent
, False);
10280 Set_Is_Potentially_Use_Visible
10281 (Actual_Ent
, In_Use
(Actual_Pack
));
10284 Next_Entity
(Actual_Ent
);
10288 -- If the formal is not declared with a box, reanalyze it as an
10289 -- abbreviated instantiation, to verify the matching rules of 12.7.
10290 -- The actual checks are performed after the generic associations
10291 -- have been analyzed, to guarantee the same visibility for this
10292 -- instantiation and for the actuals.
10294 -- In Ada 2005, the generic associations for the formal can include
10295 -- defaulted parameters. These are ignored during check. This
10296 -- internal instantiation is removed from the tree after conformance
10297 -- checking, because it contains formal declarations for those
10298 -- defaulted parameters, and those should not reach the back-end.
10300 if not Box_Present
(Formal
) then
10302 I_Pack
: constant Entity_Id
:=
10303 Make_Temporary
(Sloc
(Actual
), 'P');
10306 Set_Is_Internal
(I_Pack
);
10309 Make_Package_Instantiation
(Sloc
(Actual
),
10310 Defining_Unit_Name
=> I_Pack
,
10313 (Get_Instance_Of
(Gen_Parent
), Sloc
(Actual
)),
10314 Generic_Associations
=> Generic_Associations
(Formal
)));
10320 end Instantiate_Formal_Package
;
10322 -----------------------------------
10323 -- Instantiate_Formal_Subprogram --
10324 -----------------------------------
10326 function Instantiate_Formal_Subprogram
10329 Analyzed_Formal
: Node_Id
) return Node_Id
10331 Analyzed_S
: constant Entity_Id
:=
10332 Defining_Unit_Name
(Specification
(Analyzed_Formal
));
10333 Formal_Sub
: constant Entity_Id
:=
10334 Defining_Unit_Name
(Specification
(Formal
));
10336 function From_Parent_Scope
(Subp
: Entity_Id
) return Boolean;
10337 -- If the generic is a child unit, the parent has been installed on the
10338 -- scope stack, but a default subprogram cannot resolve to something
10339 -- on the parent because that parent is not really part of the visible
10340 -- context (it is there to resolve explicit local entities). If the
10341 -- default has resolved in this way, we remove the entity from immediate
10342 -- visibility and analyze the node again to emit an error message or
10343 -- find another visible candidate.
10345 procedure Valid_Actual_Subprogram
(Act
: Node_Id
);
10346 -- Perform legality check and raise exception on failure
10348 -----------------------
10349 -- From_Parent_Scope --
10350 -----------------------
10352 function From_Parent_Scope
(Subp
: Entity_Id
) return Boolean is
10353 Gen_Scope
: Node_Id
;
10356 Gen_Scope
:= Scope
(Analyzed_S
);
10357 while Present
(Gen_Scope
) and then Is_Child_Unit
(Gen_Scope
) loop
10358 if Scope
(Subp
) = Scope
(Gen_Scope
) then
10362 Gen_Scope
:= Scope
(Gen_Scope
);
10366 end From_Parent_Scope
;
10368 -----------------------------
10369 -- Valid_Actual_Subprogram --
10370 -----------------------------
10372 procedure Valid_Actual_Subprogram
(Act
: Node_Id
) is
10376 if Is_Entity_Name
(Act
) then
10377 Act_E
:= Entity
(Act
);
10379 elsif Nkind
(Act
) = N_Selected_Component
10380 and then Is_Entity_Name
(Selector_Name
(Act
))
10382 Act_E
:= Entity
(Selector_Name
(Act
));
10388 if (Present
(Act_E
) and then Is_Overloadable
(Act_E
))
10389 or else Nkind_In
(Act
, N_Attribute_Reference
,
10390 N_Indexed_Component
,
10391 N_Character_Literal
,
10392 N_Explicit_Dereference
)
10398 ("expect subprogram or entry name in instantiation of &",
10399 Instantiation_Node
, Formal_Sub
);
10400 Abandon_Instantiation
(Instantiation_Node
);
10401 end Valid_Actual_Subprogram
;
10405 Decl_Node
: Node_Id
;
10408 New_Spec
: Node_Id
;
10409 New_Subp
: Entity_Id
;
10411 -- Start of processing for Instantiate_Formal_Subprogram
10414 New_Spec
:= New_Copy_Tree
(Specification
(Formal
));
10416 -- The tree copy has created the proper instantiation sloc for the
10417 -- new specification. Use this location for all other constructed
10420 Loc
:= Sloc
(Defining_Unit_Name
(New_Spec
));
10422 -- Create new entity for the actual (New_Copy_Tree does not), and
10423 -- indicate that it is an actual.
10425 New_Subp
:= Make_Defining_Identifier
(Loc
, Chars
(Formal_Sub
));
10426 Set_Ekind
(New_Subp
, Ekind
(Analyzed_S
));
10427 Set_Is_Generic_Actual_Subprogram
(New_Subp
);
10428 Set_Defining_Unit_Name
(New_Spec
, New_Subp
);
10430 -- Create new entities for the each of the formals in the specification
10431 -- of the renaming declaration built for the actual.
10433 if Present
(Parameter_Specifications
(New_Spec
)) then
10439 F
:= First
(Parameter_Specifications
(New_Spec
));
10440 while Present
(F
) loop
10441 F_Id
:= Defining_Identifier
(F
);
10443 Set_Defining_Identifier
(F
,
10444 Make_Defining_Identifier
(Sloc
(F_Id
), Chars
(F_Id
)));
10450 -- Find entity of actual. If the actual is an attribute reference, it
10451 -- cannot be resolved here (its formal is missing) but is handled
10452 -- instead in Attribute_Renaming. If the actual is overloaded, it is
10453 -- fully resolved subsequently, when the renaming declaration for the
10454 -- formal is analyzed. If it is an explicit dereference, resolve the
10455 -- prefix but not the actual itself, to prevent interpretation as call.
10457 if Present
(Actual
) then
10458 Loc
:= Sloc
(Actual
);
10459 Set_Sloc
(New_Spec
, Loc
);
10461 if Nkind
(Actual
) = N_Operator_Symbol
then
10462 Find_Direct_Name
(Actual
);
10464 elsif Nkind
(Actual
) = N_Explicit_Dereference
then
10465 Analyze
(Prefix
(Actual
));
10467 elsif Nkind
(Actual
) /= N_Attribute_Reference
then
10471 Valid_Actual_Subprogram
(Actual
);
10474 elsif Present
(Default_Name
(Formal
)) then
10475 if not Nkind_In
(Default_Name
(Formal
), N_Attribute_Reference
,
10476 N_Selected_Component
,
10477 N_Indexed_Component
,
10478 N_Character_Literal
)
10479 and then Present
(Entity
(Default_Name
(Formal
)))
10481 Nam
:= New_Occurrence_Of
(Entity
(Default_Name
(Formal
)), Loc
);
10483 Nam
:= New_Copy
(Default_Name
(Formal
));
10484 Set_Sloc
(Nam
, Loc
);
10487 elsif Box_Present
(Formal
) then
10489 -- Actual is resolved at the point of instantiation. Create an
10490 -- identifier or operator with the same name as the formal.
10492 if Nkind
(Formal_Sub
) = N_Defining_Operator_Symbol
then
10494 Make_Operator_Symbol
(Loc
,
10495 Chars
=> Chars
(Formal_Sub
),
10496 Strval
=> No_String
);
10498 Nam
:= Make_Identifier
(Loc
, Chars
(Formal_Sub
));
10501 elsif Nkind
(Specification
(Formal
)) = N_Procedure_Specification
10502 and then Null_Present
(Specification
(Formal
))
10504 -- Generate null body for procedure, for use in the instance
10507 Make_Subprogram_Body
(Loc
,
10508 Specification
=> New_Spec
,
10509 Declarations
=> New_List
,
10510 Handled_Statement_Sequence
=>
10511 Make_Handled_Sequence_Of_Statements
(Loc
,
10512 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
10514 Set_Is_Intrinsic_Subprogram
(Defining_Unit_Name
(New_Spec
));
10518 Error_Msg_Sloc
:= Sloc
(Scope
(Analyzed_S
));
10520 ("missing actual&", Instantiation_Node
, Formal_Sub
);
10522 ("\in instantiation of & declared#",
10523 Instantiation_Node
, Scope
(Analyzed_S
));
10524 Abandon_Instantiation
(Instantiation_Node
);
10528 Make_Subprogram_Renaming_Declaration
(Loc
,
10529 Specification
=> New_Spec
,
10532 -- If we do not have an actual and the formal specified <> then set to
10533 -- get proper default.
10535 if No
(Actual
) and then Box_Present
(Formal
) then
10536 Set_From_Default
(Decl_Node
);
10539 -- Gather possible interpretations for the actual before analyzing the
10540 -- instance. If overloaded, it will be resolved when analyzing the
10541 -- renaming declaration.
10543 if Box_Present
(Formal
) and then No
(Actual
) then
10546 if Is_Child_Unit
(Scope
(Analyzed_S
))
10547 and then Present
(Entity
(Nam
))
10549 if not Is_Overloaded
(Nam
) then
10550 if From_Parent_Scope
(Entity
(Nam
)) then
10551 Set_Is_Immediately_Visible
(Entity
(Nam
), False);
10552 Set_Entity
(Nam
, Empty
);
10553 Set_Etype
(Nam
, Empty
);
10556 Set_Is_Immediately_Visible
(Entity
(Nam
));
10565 Get_First_Interp
(Nam
, I
, It
);
10566 while Present
(It
.Nam
) loop
10567 if From_Parent_Scope
(It
.Nam
) then
10571 Get_Next_Interp
(I
, It
);
10578 -- The generic instantiation freezes the actual. This can only be done
10579 -- once the actual is resolved, in the analysis of the renaming
10580 -- declaration. To make the formal subprogram entity available, we set
10581 -- Corresponding_Formal_Spec to point to the formal subprogram entity.
10582 -- This is also needed in Analyze_Subprogram_Renaming for the processing
10583 -- of formal abstract subprograms.
10585 Set_Corresponding_Formal_Spec
(Decl_Node
, Analyzed_S
);
10587 -- We cannot analyze the renaming declaration, and thus find the actual,
10588 -- until all the actuals are assembled in the instance. For subsequent
10589 -- checks of other actuals, indicate the node that will hold the
10590 -- instance of this formal.
10592 Set_Instance_Of
(Analyzed_S
, Nam
);
10594 if Nkind
(Actual
) = N_Selected_Component
10595 and then Is_Task_Type
(Etype
(Prefix
(Actual
)))
10596 and then not Is_Frozen
(Etype
(Prefix
(Actual
)))
10598 -- The renaming declaration will create a body, which must appear
10599 -- outside of the instantiation, We move the renaming declaration
10600 -- out of the instance, and create an additional renaming inside,
10601 -- to prevent freezing anomalies.
10604 Anon_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E');
10607 Set_Defining_Unit_Name
(New_Spec
, Anon_Id
);
10608 Insert_Before
(Instantiation_Node
, Decl_Node
);
10609 Analyze
(Decl_Node
);
10611 -- Now create renaming within the instance
10614 Make_Subprogram_Renaming_Declaration
(Loc
,
10615 Specification
=> New_Copy_Tree
(New_Spec
),
10616 Name
=> New_Occurrence_Of
(Anon_Id
, Loc
));
10618 Set_Defining_Unit_Name
(Specification
(Decl_Node
),
10619 Make_Defining_Identifier
(Loc
, Chars
(Formal_Sub
)));
10624 end Instantiate_Formal_Subprogram
;
10626 ------------------------
10627 -- Instantiate_Object --
10628 ------------------------
10630 function Instantiate_Object
10633 Analyzed_Formal
: Node_Id
) return List_Id
10635 Gen_Obj
: constant Entity_Id
:= Defining_Identifier
(Formal
);
10636 A_Gen_Obj
: constant Entity_Id
:=
10637 Defining_Identifier
(Analyzed_Formal
);
10638 Acc_Def
: Node_Id
:= Empty
;
10639 Act_Assoc
: constant Node_Id
:= Parent
(Actual
);
10640 Actual_Decl
: Node_Id
:= Empty
;
10641 Decl_Node
: Node_Id
;
10644 List
: constant List_Id
:= New_List
;
10645 Loc
: constant Source_Ptr
:= Sloc
(Actual
);
10646 Orig_Ftyp
: constant Entity_Id
:= Etype
(A_Gen_Obj
);
10647 Subt_Decl
: Node_Id
:= Empty
;
10648 Subt_Mark
: Node_Id
:= Empty
;
10650 function Copy_Access_Def
return Node_Id
;
10651 -- If formal is an anonymous access, copy access definition of formal
10652 -- for generated object declaration.
10654 ---------------------
10655 -- Copy_Access_Def --
10656 ---------------------
10658 function Copy_Access_Def
return Node_Id
is
10660 Def
:= New_Copy_Tree
(Acc_Def
);
10662 -- In addition, if formal is an access to subprogram we need to
10663 -- generate new formals for the signature of the default, so that
10664 -- the tree is properly formatted for ASIS use.
10666 if Present
(Access_To_Subprogram_Definition
(Acc_Def
)) then
10668 Par_Spec
: Node_Id
;
10671 First
(Parameter_Specifications
10672 (Access_To_Subprogram_Definition
(Def
)));
10673 while Present
(Par_Spec
) loop
10674 Set_Defining_Identifier
(Par_Spec
,
10675 Make_Defining_Identifier
(Sloc
(Acc_Def
),
10676 Chars
=> Chars
(Defining_Identifier
(Par_Spec
))));
10683 end Copy_Access_Def
;
10685 -- Start of processing for Instantiate_Object
10688 -- Formal may be an anonymous access
10690 if Present
(Subtype_Mark
(Formal
)) then
10691 Subt_Mark
:= Subtype_Mark
(Formal
);
10693 Check_Access_Definition
(Formal
);
10694 Acc_Def
:= Access_Definition
(Formal
);
10697 -- Sloc for error message on missing actual
10699 Error_Msg_Sloc
:= Sloc
(Scope
(A_Gen_Obj
));
10701 if Get_Instance_Of
(Gen_Obj
) /= Gen_Obj
then
10702 Error_Msg_N
("duplicate instantiation of generic parameter", Actual
);
10705 Set_Parent
(List
, Parent
(Actual
));
10709 if Out_Present
(Formal
) then
10711 -- An IN OUT generic actual must be a name. The instantiation is a
10712 -- renaming declaration. The actual is the name being renamed. We
10713 -- use the actual directly, rather than a copy, because it is not
10714 -- used further in the list of actuals, and because a copy or a use
10715 -- of relocate_node is incorrect if the instance is nested within a
10716 -- generic. In order to simplify ASIS searches, the Generic_Parent
10717 -- field links the declaration to the generic association.
10719 if No
(Actual
) then
10721 ("missing actual &",
10722 Instantiation_Node
, Gen_Obj
);
10724 ("\in instantiation of & declared#",
10725 Instantiation_Node
, Scope
(A_Gen_Obj
));
10726 Abandon_Instantiation
(Instantiation_Node
);
10729 if Present
(Subt_Mark
) then
10731 Make_Object_Renaming_Declaration
(Loc
,
10732 Defining_Identifier
=> New_Copy
(Gen_Obj
),
10733 Subtype_Mark
=> New_Copy_Tree
(Subt_Mark
),
10736 else pragma Assert
(Present
(Acc_Def
));
10738 Make_Object_Renaming_Declaration
(Loc
,
10739 Defining_Identifier
=> New_Copy
(Gen_Obj
),
10740 Access_Definition
=> New_Copy_Tree
(Acc_Def
),
10744 Set_Corresponding_Generic_Association
(Decl_Node
, Act_Assoc
);
10746 -- The analysis of the actual may produce Insert_Action nodes, so
10747 -- the declaration must have a context in which to attach them.
10749 Append
(Decl_Node
, List
);
10752 -- Return if the analysis of the actual reported some error
10754 if Etype
(Actual
) = Any_Type
then
10758 -- This check is performed here because Analyze_Object_Renaming will
10759 -- not check it when Comes_From_Source is False. Note though that the
10760 -- check for the actual being the name of an object will be performed
10761 -- in Analyze_Object_Renaming.
10763 if Is_Object_Reference
(Actual
)
10764 and then Is_Dependent_Component_Of_Mutable_Object
(Actual
)
10767 ("illegal discriminant-dependent component for in out parameter",
10771 -- The actual has to be resolved in order to check that it is a
10772 -- variable (due to cases such as F (1), where F returns access to
10773 -- an array, and for overloaded prefixes).
10775 Ftyp
:= Get_Instance_Of
(Etype
(A_Gen_Obj
));
10777 -- If the type of the formal is not itself a formal, and the current
10778 -- unit is a child unit, the formal type must be declared in a
10779 -- parent, and must be retrieved by visibility.
10781 if Ftyp
= Orig_Ftyp
10782 and then Is_Generic_Unit
(Scope
(Ftyp
))
10783 and then Is_Child_Unit
(Scope
(A_Gen_Obj
))
10786 Temp
: constant Node_Id
:=
10787 New_Copy_Tree
(Subtype_Mark
(Analyzed_Formal
));
10789 Set_Entity
(Temp
, Empty
);
10791 Ftyp
:= Entity
(Temp
);
10795 if Is_Private_Type
(Ftyp
)
10796 and then not Is_Private_Type
(Etype
(Actual
))
10797 and then (Base_Type
(Full_View
(Ftyp
)) = Base_Type
(Etype
(Actual
))
10798 or else Base_Type
(Etype
(Actual
)) = Ftyp
)
10800 -- If the actual has the type of the full view of the formal, or
10801 -- else a non-private subtype of the formal, then the visibility
10802 -- of the formal type has changed. Add to the actuals a subtype
10803 -- declaration that will force the exchange of views in the body
10804 -- of the instance as well.
10807 Make_Subtype_Declaration
(Loc
,
10808 Defining_Identifier
=> Make_Temporary
(Loc
, 'P'),
10809 Subtype_Indication
=> New_Occurrence_Of
(Ftyp
, Loc
));
10811 Prepend
(Subt_Decl
, List
);
10813 Prepend_Elmt
(Full_View
(Ftyp
), Exchanged_Views
);
10814 Exchange_Declarations
(Ftyp
);
10817 Resolve
(Actual
, Ftyp
);
10819 if not Denotes_Variable
(Actual
) then
10820 Error_Msg_NE
("actual for& must be a variable", Actual
, Gen_Obj
);
10822 elsif Base_Type
(Ftyp
) /= Base_Type
(Etype
(Actual
)) then
10824 -- Ada 2005 (AI-423): For a generic formal object of mode in out,
10825 -- the type of the actual shall resolve to a specific anonymous
10828 if Ada_Version
< Ada_2005
10829 or else Ekind
(Base_Type
(Ftyp
)) /=
10830 E_Anonymous_Access_Type
10831 or else Ekind
(Base_Type
(Etype
(Actual
))) /=
10832 E_Anonymous_Access_Type
10835 ("type of actual does not match type of&", Actual
, Gen_Obj
);
10839 Note_Possible_Modification
(Actual
, Sure
=> True);
10841 -- Check for instantiation of atomic/volatile actual for
10842 -- non-atomic/volatile formal (RM C.6 (12)).
10844 if Is_Atomic_Object
(Actual
) and then not Is_Atomic
(Orig_Ftyp
) then
10846 ("cannot instantiate non-atomic formal object "
10847 & "with atomic actual", Actual
);
10849 elsif Is_Volatile_Object
(Actual
) and then not Is_Volatile
(Orig_Ftyp
)
10852 ("cannot instantiate non-volatile formal object "
10853 & "with volatile actual", Actual
);
10856 -- Formal in-parameter
10859 -- The instantiation of a generic formal in-parameter is constant
10860 -- declaration. The actual is the expression for that declaration.
10861 -- Its type is a full copy of the type of the formal. This may be
10862 -- an access to subprogram, for which we need to generate entities
10863 -- for the formals in the new signature.
10865 if Present
(Actual
) then
10866 if Present
(Subt_Mark
) then
10867 Def
:= New_Copy_Tree
(Subt_Mark
);
10868 else pragma Assert
(Present
(Acc_Def
));
10869 Def
:= Copy_Access_Def
;
10873 Make_Object_Declaration
(Loc
,
10874 Defining_Identifier
=> New_Copy
(Gen_Obj
),
10875 Constant_Present
=> True,
10876 Null_Exclusion_Present
=> Null_Exclusion_Present
(Formal
),
10877 Object_Definition
=> Def
,
10878 Expression
=> Actual
);
10880 Set_Corresponding_Generic_Association
(Decl_Node
, Act_Assoc
);
10882 -- A generic formal object of a tagged type is defined to be
10883 -- aliased so the new constant must also be treated as aliased.
10885 if Is_Tagged_Type
(Etype
(A_Gen_Obj
)) then
10886 Set_Aliased_Present
(Decl_Node
);
10889 Append
(Decl_Node
, List
);
10891 -- No need to repeat (pre-)analysis of some expression nodes
10892 -- already handled in Preanalyze_Actuals.
10894 if Nkind
(Actual
) /= N_Allocator
then
10897 -- Return if the analysis of the actual reported some error
10899 if Etype
(Actual
) = Any_Type
then
10905 Formal_Type
: constant Entity_Id
:= Etype
(A_Gen_Obj
);
10909 Typ
:= Get_Instance_Of
(Formal_Type
);
10911 -- If the actual appears in the current or an enclosing scope,
10912 -- use its type directly. This is relevant if it has an actual
10913 -- subtype that is distinct from its nominal one. This cannot
10914 -- be done in general because the type of the actual may
10915 -- depend on other actuals, and only be fully determined when
10916 -- the enclosing instance is analyzed.
10918 if Present
(Etype
(Actual
))
10919 and then Is_Constr_Subt_For_U_Nominal
(Etype
(Actual
))
10921 Freeze_Before
(Instantiation_Node
, Etype
(Actual
));
10923 Freeze_Before
(Instantiation_Node
, Typ
);
10926 -- If the actual is an aggregate, perform name resolution on
10927 -- its components (the analysis of an aggregate does not do it)
10928 -- to capture local names that may be hidden if the generic is
10931 if Nkind
(Actual
) = N_Aggregate
then
10932 Preanalyze_And_Resolve
(Actual
, Typ
);
10935 if Is_Limited_Type
(Typ
)
10936 and then not OK_For_Limited_Init
(Typ
, Actual
)
10939 ("initialization not allowed for limited types", Actual
);
10940 Explain_Limited_Type
(Typ
, Actual
);
10944 elsif Present
(Default_Expression
(Formal
)) then
10946 -- Use default to construct declaration
10948 if Present
(Subt_Mark
) then
10949 Def
:= New_Copy
(Subt_Mark
);
10950 else pragma Assert
(Present
(Acc_Def
));
10951 Def
:= Copy_Access_Def
;
10955 Make_Object_Declaration
(Sloc
(Formal
),
10956 Defining_Identifier
=> New_Copy
(Gen_Obj
),
10957 Constant_Present
=> True,
10958 Null_Exclusion_Present
=> Null_Exclusion_Present
(Formal
),
10959 Object_Definition
=> Def
,
10960 Expression
=> New_Copy_Tree
10961 (Default_Expression
(Formal
)));
10963 Append
(Decl_Node
, List
);
10964 Set_Analyzed
(Expression
(Decl_Node
), False);
10967 Error_Msg_NE
("missing actual&", Instantiation_Node
, Gen_Obj
);
10968 Error_Msg_NE
("\in instantiation of & declared#",
10969 Instantiation_Node
, Scope
(A_Gen_Obj
));
10971 if Is_Scalar_Type
(Etype
(A_Gen_Obj
)) then
10973 -- Create dummy constant declaration so that instance can be
10974 -- analyzed, to minimize cascaded visibility errors.
10976 if Present
(Subt_Mark
) then
10978 else pragma Assert
(Present
(Acc_Def
));
10983 Make_Object_Declaration
(Loc
,
10984 Defining_Identifier
=> New_Copy
(Gen_Obj
),
10985 Constant_Present
=> True,
10986 Null_Exclusion_Present
=> Null_Exclusion_Present
(Formal
),
10987 Object_Definition
=> New_Copy
(Def
),
10989 Make_Attribute_Reference
(Sloc
(Gen_Obj
),
10990 Attribute_Name
=> Name_First
,
10991 Prefix
=> New_Copy
(Def
)));
10993 Append
(Decl_Node
, List
);
10996 Abandon_Instantiation
(Instantiation_Node
);
11001 if Nkind
(Actual
) in N_Has_Entity
then
11002 Actual_Decl
:= Parent
(Entity
(Actual
));
11005 -- Ada 2005 (AI-423): For a formal object declaration with a null
11006 -- exclusion or an access definition that has a null exclusion: If the
11007 -- actual matching the formal object declaration denotes a generic
11008 -- formal object of another generic unit G, and the instantiation
11009 -- containing the actual occurs within the body of G or within the body
11010 -- of a generic unit declared within the declarative region of G, then
11011 -- the declaration of the formal object of G must have a null exclusion.
11012 -- Otherwise, the subtype of the actual matching the formal object
11013 -- declaration shall exclude null.
11015 if Ada_Version
>= Ada_2005
11016 and then Present
(Actual_Decl
)
11017 and then Nkind_In
(Actual_Decl
, N_Formal_Object_Declaration
,
11018 N_Object_Declaration
)
11019 and then Nkind
(Analyzed_Formal
) = N_Formal_Object_Declaration
11020 and then not Has_Null_Exclusion
(Actual_Decl
)
11021 and then Has_Null_Exclusion
(Analyzed_Formal
)
11023 Error_Msg_Sloc
:= Sloc
(Analyzed_Formal
);
11025 ("actual must exclude null to match generic formal#", Actual
);
11028 -- An effectively volatile object cannot be used as an actual in a
11029 -- generic instantiation (SPARK RM 7.1.3(7)). The following check is
11030 -- relevant only when SPARK_Mode is on as it is not a standard Ada
11031 -- legality rule, and also verifies that the actual is an object.
11034 and then Present
(Actual
)
11035 and then Is_Object_Reference
(Actual
)
11036 and then Is_Effectively_Volatile_Object
(Actual
)
11039 ("volatile object cannot act as actual in generic instantiation",
11044 end Instantiate_Object
;
11046 ------------------------------
11047 -- Instantiate_Package_Body --
11048 ------------------------------
11050 -- WARNING: This routine manages Ghost and SPARK regions. Return statements
11051 -- must be replaced by gotos which jump to the end of the routine in order
11052 -- to restore the Ghost and SPARK modes.
11054 procedure Instantiate_Package_Body
11055 (Body_Info
: Pending_Body_Info
;
11056 Inlined_Body
: Boolean := False;
11057 Body_Optional
: Boolean := False)
11059 Act_Decl
: constant Node_Id
:= Body_Info
.Act_Decl
;
11060 Act_Decl_Id
: constant Entity_Id
:= Defining_Entity
(Act_Decl
);
11061 Act_Spec
: constant Node_Id
:= Specification
(Act_Decl
);
11062 Inst_Node
: constant Node_Id
:= Body_Info
.Inst_Node
;
11063 Gen_Id
: constant Node_Id
:= Name
(Inst_Node
);
11064 Gen_Unit
: constant Entity_Id
:= Get_Generic_Entity
(Inst_Node
);
11065 Gen_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Gen_Unit
);
11066 Loc
: constant Source_Ptr
:= Sloc
(Inst_Node
);
11068 Saved_ISMP
: constant Boolean :=
11069 Ignore_SPARK_Mode_Pragmas_In_Instance
;
11070 Saved_Style_Check
: constant Boolean := Style_Check
;
11072 procedure Check_Initialized_Types
;
11073 -- In a generic package body, an entity of a generic private type may
11074 -- appear uninitialized. This is suspicious, unless the actual is a
11075 -- fully initialized type.
11077 -----------------------------
11078 -- Check_Initialized_Types --
11079 -----------------------------
11081 procedure Check_Initialized_Types
is
11083 Formal
: Entity_Id
;
11084 Actual
: Entity_Id
;
11085 Uninit_Var
: Entity_Id
;
11088 Decl
:= First
(Generic_Formal_Declarations
(Gen_Decl
));
11089 while Present
(Decl
) loop
11090 Uninit_Var
:= Empty
;
11092 if Nkind
(Decl
) = N_Private_Extension_Declaration
then
11093 Uninit_Var
:= Uninitialized_Variable
(Decl
);
11095 elsif Nkind
(Decl
) = N_Formal_Type_Declaration
11096 and then Nkind
(Formal_Type_Definition
(Decl
)) =
11097 N_Formal_Private_Type_Definition
11100 Uninitialized_Variable
(Formal_Type_Definition
(Decl
));
11103 if Present
(Uninit_Var
) then
11104 Formal
:= Defining_Identifier
(Decl
);
11105 Actual
:= First_Entity
(Act_Decl_Id
);
11107 -- For each formal there is a subtype declaration that renames
11108 -- the actual and has the same name as the formal. Locate the
11109 -- formal for warning message about uninitialized variables
11110 -- in the generic, for which the actual type should be a fully
11111 -- initialized type.
11113 while Present
(Actual
) loop
11114 exit when Ekind
(Actual
) = E_Package
11115 and then Present
(Renamed_Object
(Actual
));
11117 if Chars
(Actual
) = Chars
(Formal
)
11118 and then not Is_Scalar_Type
(Actual
)
11119 and then not Is_Fully_Initialized_Type
(Actual
)
11120 and then Warn_On_No_Value_Assigned
11122 Error_Msg_Node_2
:= Formal
;
11124 ("generic unit has uninitialized variable& of "
11125 & "formal private type &?v?", Actual
, Uninit_Var
);
11127 ("actual type for& should be fully initialized type?v?",
11132 Next_Entity
(Actual
);
11138 end Check_Initialized_Types
;
11142 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
11143 Saved_SM
: constant SPARK_Mode_Type
:= SPARK_Mode
;
11144 Saved_SMP
: constant Node_Id
:= SPARK_Mode_Pragma
;
11145 -- Save the Ghost and SPARK mode-related data to restore on exit
11147 Act_Body
: Node_Id
;
11148 Act_Body_Id
: Entity_Id
;
11149 Act_Body_Name
: Node_Id
;
11150 Gen_Body
: Node_Id
;
11151 Gen_Body_Id
: Node_Id
;
11152 Par_Ent
: Entity_Id
:= Empty
;
11153 Par_Vis
: Boolean := False;
11154 Parent_Installed
: Boolean := False;
11156 Vis_Prims_List
: Elist_Id
:= No_Elist
;
11157 -- List of primitives made temporarily visible in the instantiation
11158 -- to match the visibility of the formal type.
11160 -- Start of processing for Instantiate_Package_Body
11163 Gen_Body_Id
:= Corresponding_Body
(Gen_Decl
);
11165 -- The instance body may already have been processed, as the parent of
11166 -- another instance that is inlined (Load_Parent_Of_Generic).
11168 if Present
(Corresponding_Body
(Instance_Spec
(Inst_Node
))) then
11172 -- The package being instantiated may be subject to pragma Ghost. Set
11173 -- the mode now to ensure that any nodes generated during instantiation
11174 -- are properly marked as Ghost.
11176 Set_Ghost_Mode
(Act_Decl_Id
);
11178 Expander_Mode_Save_And_Set
(Body_Info
.Expander_Status
);
11180 -- Re-establish the state of information on which checks are suppressed.
11181 -- This information was set in Body_Info at the point of instantiation,
11182 -- and now we restore it so that the instance is compiled using the
11183 -- check status at the instantiation (RM 11.5(7.2/2), AI95-00224-01).
11185 Local_Suppress_Stack_Top
:= Body_Info
.Local_Suppress_Stack_Top
;
11186 Scope_Suppress
:= Body_Info
.Scope_Suppress
;
11187 Opt
.Ada_Version
:= Body_Info
.Version
;
11188 Opt
.Ada_Version_Pragma
:= Body_Info
.Version_Pragma
;
11189 Restore_Warnings
(Body_Info
.Warnings
);
11191 -- Install the SPARK mode which applies to the package body
11193 Install_SPARK_Mode
(Body_Info
.SPARK_Mode
, Body_Info
.SPARK_Mode_Pragma
);
11195 if No
(Gen_Body_Id
) then
11197 -- Do not look for parent of generic body if none is required.
11198 -- This may happen when the routine is called as part of the
11199 -- Pending_Instantiations processing, when nested instances
11200 -- may precede the one generated from the main unit.
11202 if not Unit_Requires_Body
(Defining_Entity
(Gen_Decl
))
11203 and then Body_Optional
11207 Load_Parent_Of_Generic
11208 (Inst_Node
, Specification
(Gen_Decl
), Body_Optional
);
11209 Gen_Body_Id
:= Corresponding_Body
(Gen_Decl
);
11213 -- Establish global variable for sloc adjustment and for error recovery
11214 -- In the case of an instance body for an instantiation with actuals
11215 -- from a limited view, the instance body is placed at the beginning
11216 -- of the enclosing package body: use the body entity as the source
11217 -- location for nodes of the instance body.
11219 if not Is_Empty_Elmt_List
(Incomplete_Actuals
(Act_Decl_Id
)) then
11221 Scop
: constant Entity_Id
:= Scope
(Act_Decl_Id
);
11222 Body_Id
: constant Node_Id
:=
11223 Corresponding_Body
(Unit_Declaration_Node
(Scop
));
11226 Instantiation_Node
:= Body_Id
;
11229 Instantiation_Node
:= Inst_Node
;
11232 if Present
(Gen_Body_Id
) then
11233 Save_Env
(Gen_Unit
, Act_Decl_Id
);
11234 Style_Check
:= False;
11236 -- If the context of the instance is subject to SPARK_Mode "off", the
11237 -- annotation is missing, or the body is instantiated at a later pass
11238 -- and its spec ignored SPARK_Mode pragma, set the global flag which
11239 -- signals Analyze_Pragma to ignore all SPARK_Mode pragmas within the
11242 if SPARK_Mode
/= On
11243 or else Ignore_SPARK_Mode_Pragmas
(Act_Decl_Id
)
11245 Ignore_SPARK_Mode_Pragmas_In_Instance
:= True;
11248 Current_Sem_Unit
:= Body_Info
.Current_Sem_Unit
;
11249 Gen_Body
:= Unit_Declaration_Node
(Gen_Body_Id
);
11251 Create_Instantiation_Source
11252 (Inst_Node
, Gen_Body_Id
, S_Adjustment
);
11256 (Original_Node
(Gen_Body
), Empty
, Instantiating
=> True);
11258 -- Create proper (possibly qualified) defining name for the body, to
11259 -- correspond to the one in the spec.
11262 Make_Defining_Identifier
(Sloc
(Act_Decl_Id
), Chars
(Act_Decl_Id
));
11263 Set_Comes_From_Source
(Act_Body_Id
, Comes_From_Source
(Act_Decl_Id
));
11265 -- Some attributes of spec entity are not inherited by body entity
11267 Set_Handler_Records
(Act_Body_Id
, No_List
);
11269 if Nkind
(Defining_Unit_Name
(Act_Spec
)) =
11270 N_Defining_Program_Unit_Name
11273 Make_Defining_Program_Unit_Name
(Loc
,
11275 New_Copy_Tree
(Name
(Defining_Unit_Name
(Act_Spec
))),
11276 Defining_Identifier
=> Act_Body_Id
);
11278 Act_Body_Name
:= Act_Body_Id
;
11281 Set_Defining_Unit_Name
(Act_Body
, Act_Body_Name
);
11283 Set_Corresponding_Spec
(Act_Body
, Act_Decl_Id
);
11284 Check_Generic_Actuals
(Act_Decl_Id
, False);
11285 Check_Initialized_Types
;
11287 -- Install primitives hidden at the point of the instantiation but
11288 -- visible when processing the generic formals
11294 E
:= First_Entity
(Act_Decl_Id
);
11295 while Present
(E
) loop
11297 and then not Is_Itype
(E
)
11298 and then Is_Generic_Actual_Type
(E
)
11299 and then Is_Tagged_Type
(E
)
11301 Install_Hidden_Primitives
11302 (Prims_List
=> Vis_Prims_List
,
11303 Gen_T
=> Generic_Parent_Type
(Parent
(E
)),
11311 -- If it is a child unit, make the parent instance (which is an
11312 -- instance of the parent of the generic) visible. The parent
11313 -- instance is the prefix of the name of the generic unit.
11315 if Ekind
(Scope
(Gen_Unit
)) = E_Generic_Package
11316 and then Nkind
(Gen_Id
) = N_Expanded_Name
11318 Par_Ent
:= Entity
(Prefix
(Gen_Id
));
11319 Par_Vis
:= Is_Immediately_Visible
(Par_Ent
);
11320 Install_Parent
(Par_Ent
, In_Body
=> True);
11321 Parent_Installed
:= True;
11323 elsif Is_Child_Unit
(Gen_Unit
) then
11324 Par_Ent
:= Scope
(Gen_Unit
);
11325 Par_Vis
:= Is_Immediately_Visible
(Par_Ent
);
11326 Install_Parent
(Par_Ent
, In_Body
=> True);
11327 Parent_Installed
:= True;
11330 -- If the instantiation is a library unit, and this is the main unit,
11331 -- then build the resulting compilation unit nodes for the instance.
11332 -- If this is a compilation unit but it is not the main unit, then it
11333 -- is the body of a unit in the context, that is being compiled
11334 -- because it is encloses some inlined unit or another generic unit
11335 -- being instantiated. In that case, this body is not part of the
11336 -- current compilation, and is not attached to the tree, but its
11337 -- parent must be set for analysis.
11339 if Nkind
(Parent
(Inst_Node
)) = N_Compilation_Unit
then
11341 -- Replace instance node with body of instance, and create new
11342 -- node for corresponding instance declaration.
11344 Build_Instance_Compilation_Unit_Nodes
11345 (Inst_Node
, Act_Body
, Act_Decl
);
11346 Analyze
(Inst_Node
);
11348 if Parent
(Inst_Node
) = Cunit
(Main_Unit
) then
11350 -- If the instance is a child unit itself, then set the scope
11351 -- of the expanded body to be the parent of the instantiation
11352 -- (ensuring that the fully qualified name will be generated
11353 -- for the elaboration subprogram).
11355 if Nkind
(Defining_Unit_Name
(Act_Spec
)) =
11356 N_Defining_Program_Unit_Name
11358 Set_Scope
(Defining_Entity
(Inst_Node
), Scope
(Act_Decl_Id
));
11362 -- Case where instantiation is not a library unit
11365 -- If this is an early instantiation, i.e. appears textually
11366 -- before the corresponding body and must be elaborated first,
11367 -- indicate that the body instance is to be delayed.
11369 Install_Body
(Act_Body
, Inst_Node
, Gen_Body
, Gen_Decl
);
11371 -- Now analyze the body. We turn off all checks if this is an
11372 -- internal unit, since there is no reason to have checks on for
11373 -- any predefined run-time library code. All such code is designed
11374 -- to be compiled with checks off.
11376 -- Note that we do NOT apply this criterion to children of GNAT
11377 -- The latter units must suppress checks explicitly if needed.
11379 -- We also do not suppress checks in CodePeer mode where we are
11380 -- interested in finding possible runtime errors.
11382 if not CodePeer_Mode
11383 and then In_Predefined_Unit
(Gen_Decl
)
11385 Analyze
(Act_Body
, Suppress
=> All_Checks
);
11387 Analyze
(Act_Body
);
11391 Inherit_Context
(Gen_Body
, Inst_Node
);
11393 -- Remove the parent instances if they have been placed on the scope
11394 -- stack to compile the body.
11396 if Parent_Installed
then
11397 Remove_Parent
(In_Body
=> True);
11399 -- Restore the previous visibility of the parent
11401 Set_Is_Immediately_Visible
(Par_Ent
, Par_Vis
);
11404 Restore_Hidden_Primitives
(Vis_Prims_List
);
11405 Restore_Private_Views
(Act_Decl_Id
);
11407 -- Remove the current unit from visibility if this is an instance
11408 -- that is not elaborated on the fly for inlining purposes.
11410 if not Inlined_Body
then
11411 Set_Is_Immediately_Visible
(Act_Decl_Id
, False);
11416 -- If we have no body, and the unit requires a body, then complain. This
11417 -- complaint is suppressed if we have detected other errors (since a
11418 -- common reason for missing the body is that it had errors).
11419 -- In CodePeer mode, a warning has been emitted already, no need for
11420 -- further messages.
11422 elsif Unit_Requires_Body
(Gen_Unit
)
11423 and then not Body_Optional
11425 if CodePeer_Mode
then
11428 elsif Serious_Errors_Detected
= 0 then
11430 ("cannot find body of generic package &", Inst_Node
, Gen_Unit
);
11432 -- Don't attempt to perform any cleanup actions if some other error
11433 -- was already detected, since this can cause blowups.
11439 -- Case of package that does not need a body
11442 -- If the instantiation of the declaration is a library unit, rewrite
11443 -- the original package instantiation as a package declaration in the
11444 -- compilation unit node.
11446 if Nkind
(Parent
(Inst_Node
)) = N_Compilation_Unit
then
11447 Set_Parent_Spec
(Act_Decl
, Parent_Spec
(Inst_Node
));
11448 Rewrite
(Inst_Node
, Act_Decl
);
11450 -- Generate elaboration entity, in case spec has elaboration code.
11451 -- This cannot be done when the instance is analyzed, because it
11452 -- is not known yet whether the body exists.
11454 Set_Elaboration_Entity_Required
(Act_Decl_Id
, False);
11455 Build_Elaboration_Entity
(Parent
(Inst_Node
), Act_Decl_Id
);
11457 -- If the instantiation is not a library unit, then append the
11458 -- declaration to the list of implicitly generated entities, unless
11459 -- it is already a list member which means that it was already
11462 elsif not Is_List_Member
(Act_Decl
) then
11463 Mark_Rewrite_Insertion
(Act_Decl
);
11464 Insert_Before
(Inst_Node
, Act_Decl
);
11468 Expander_Mode_Restore
;
11471 Ignore_SPARK_Mode_Pragmas_In_Instance
:= Saved_ISMP
;
11472 Restore_Ghost_Mode
(Saved_GM
);
11473 Restore_SPARK_Mode
(Saved_SM
, Saved_SMP
);
11474 Style_Check
:= Saved_Style_Check
;
11475 end Instantiate_Package_Body
;
11477 ---------------------------------
11478 -- Instantiate_Subprogram_Body --
11479 ---------------------------------
11481 -- WARNING: This routine manages Ghost and SPARK regions. Return statements
11482 -- must be replaced by gotos which jump to the end of the routine in order
11483 -- to restore the Ghost and SPARK modes.
11485 procedure Instantiate_Subprogram_Body
11486 (Body_Info
: Pending_Body_Info
;
11487 Body_Optional
: Boolean := False)
11489 Act_Decl
: constant Node_Id
:= Body_Info
.Act_Decl
;
11490 Act_Decl_Id
: constant Entity_Id
:= Defining_Entity
(Act_Decl
);
11491 Inst_Node
: constant Node_Id
:= Body_Info
.Inst_Node
;
11492 Gen_Id
: constant Node_Id
:= Name
(Inst_Node
);
11493 Gen_Unit
: constant Entity_Id
:= Get_Generic_Entity
(Inst_Node
);
11494 Gen_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Gen_Unit
);
11495 Loc
: constant Source_Ptr
:= Sloc
(Inst_Node
);
11496 Pack_Id
: constant Entity_Id
:=
11497 Defining_Unit_Name
(Parent
(Act_Decl
));
11499 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
11500 Saved_ISMP
: constant Boolean :=
11501 Ignore_SPARK_Mode_Pragmas_In_Instance
;
11502 Saved_SM
: constant SPARK_Mode_Type
:= SPARK_Mode
;
11503 Saved_SMP
: constant Node_Id
:= SPARK_Mode_Pragma
;
11504 -- Save the Ghost and SPARK mode-related data to restore on exit
11506 Saved_Style_Check
: constant Boolean := Style_Check
;
11507 Saved_Warnings
: constant Warning_Record
:= Save_Warnings
;
11509 Act_Body
: Node_Id
;
11510 Act_Body_Id
: Entity_Id
;
11511 Gen_Body
: Node_Id
;
11512 Gen_Body_Id
: Node_Id
;
11513 Pack_Body
: Node_Id
;
11514 Par_Ent
: Entity_Id
:= Empty
;
11515 Par_Vis
: Boolean := False;
11516 Ret_Expr
: Node_Id
;
11518 Parent_Installed
: Boolean := False;
11521 Gen_Body_Id
:= Corresponding_Body
(Gen_Decl
);
11523 -- Subprogram body may have been created already because of an inline
11524 -- pragma, or because of multiple elaborations of the enclosing package
11525 -- when several instances of the subprogram appear in the main unit.
11527 if Present
(Corresponding_Body
(Act_Decl
)) then
11531 -- The subprogram being instantiated may be subject to pragma Ghost. Set
11532 -- the mode now to ensure that any nodes generated during instantiation
11533 -- are properly marked as Ghost.
11535 Set_Ghost_Mode
(Act_Decl_Id
);
11537 Expander_Mode_Save_And_Set
(Body_Info
.Expander_Status
);
11539 -- Re-establish the state of information on which checks are suppressed.
11540 -- This information was set in Body_Info at the point of instantiation,
11541 -- and now we restore it so that the instance is compiled using the
11542 -- check status at the instantiation (RM 11.5(7.2/2), AI95-00224-01).
11544 Local_Suppress_Stack_Top
:= Body_Info
.Local_Suppress_Stack_Top
;
11545 Scope_Suppress
:= Body_Info
.Scope_Suppress
;
11546 Opt
.Ada_Version
:= Body_Info
.Version
;
11547 Opt
.Ada_Version_Pragma
:= Body_Info
.Version_Pragma
;
11548 Restore_Warnings
(Body_Info
.Warnings
);
11550 -- Install the SPARK mode which applies to the subprogram body from the
11551 -- instantiation context. This may be refined further if an explicit
11552 -- SPARK_Mode pragma applies to the generic body.
11554 Install_SPARK_Mode
(Body_Info
.SPARK_Mode
, Body_Info
.SPARK_Mode_Pragma
);
11556 if No
(Gen_Body_Id
) then
11558 -- For imported generic subprogram, no body to compile, complete
11559 -- the spec entity appropriately.
11561 if Is_Imported
(Gen_Unit
) then
11562 Set_Is_Imported
(Act_Decl_Id
);
11563 Set_First_Rep_Item
(Act_Decl_Id
, First_Rep_Item
(Gen_Unit
));
11564 Set_Interface_Name
(Act_Decl_Id
, Interface_Name
(Gen_Unit
));
11565 Set_Convention
(Act_Decl_Id
, Convention
(Gen_Unit
));
11566 Set_Has_Completion
(Act_Decl_Id
);
11569 -- For other cases, compile the body
11572 Load_Parent_Of_Generic
11573 (Inst_Node
, Specification
(Gen_Decl
), Body_Optional
);
11574 Gen_Body_Id
:= Corresponding_Body
(Gen_Decl
);
11578 Instantiation_Node
:= Inst_Node
;
11580 if Present
(Gen_Body_Id
) then
11581 Gen_Body
:= Unit_Declaration_Node
(Gen_Body_Id
);
11583 if Nkind
(Gen_Body
) = N_Subprogram_Body_Stub
then
11585 -- Either body is not present, or context is non-expanding, as
11586 -- when compiling a subunit. Mark the instance as completed, and
11587 -- diagnose a missing body when needed.
11590 and then Operating_Mode
= Generate_Code
11592 Error_Msg_N
("missing proper body for instantiation", Gen_Body
);
11595 Set_Has_Completion
(Act_Decl_Id
);
11599 Save_Env
(Gen_Unit
, Act_Decl_Id
);
11600 Style_Check
:= False;
11602 -- If the context of the instance is subject to SPARK_Mode "off", the
11603 -- annotation is missing, or the body is instantiated at a later pass
11604 -- and its spec ignored SPARK_Mode pragma, set the global flag which
11605 -- signals Analyze_Pragma to ignore all SPARK_Mode pragmas within the
11608 if SPARK_Mode
/= On
11609 or else Ignore_SPARK_Mode_Pragmas
(Act_Decl_Id
)
11611 Ignore_SPARK_Mode_Pragmas_In_Instance
:= True;
11614 -- If the context of an instance is not subject to SPARK_Mode "off",
11615 -- and the generic body is subject to an explicit SPARK_Mode pragma,
11616 -- the latter should be the one applicable to the instance.
11618 if not Ignore_SPARK_Mode_Pragmas_In_Instance
11619 and then SPARK_Mode
/= Off
11620 and then Present
(SPARK_Pragma
(Gen_Body_Id
))
11622 Set_SPARK_Mode
(Gen_Body_Id
);
11625 Current_Sem_Unit
:= Body_Info
.Current_Sem_Unit
;
11626 Create_Instantiation_Source
11633 (Original_Node
(Gen_Body
), Empty
, Instantiating
=> True);
11635 -- Create proper defining name for the body, to correspond to the one
11639 Make_Defining_Identifier
(Sloc
(Act_Decl_Id
), Chars
(Act_Decl_Id
));
11641 Set_Comes_From_Source
(Act_Body_Id
, Comes_From_Source
(Act_Decl_Id
));
11642 Set_Defining_Unit_Name
(Specification
(Act_Body
), Act_Body_Id
);
11644 Set_Corresponding_Spec
(Act_Body
, Act_Decl_Id
);
11645 Set_Has_Completion
(Act_Decl_Id
);
11646 Check_Generic_Actuals
(Pack_Id
, False);
11648 -- Generate a reference to link the visible subprogram instance to
11649 -- the generic body, which for navigation purposes is the only
11650 -- available source for the instance.
11653 (Related_Instance
(Pack_Id
),
11654 Gen_Body_Id
, 'b', Set_Ref
=> False, Force
=> True);
11656 -- If it is a child unit, make the parent instance (which is an
11657 -- instance of the parent of the generic) visible. The parent
11658 -- instance is the prefix of the name of the generic unit.
11660 if Ekind
(Scope
(Gen_Unit
)) = E_Generic_Package
11661 and then Nkind
(Gen_Id
) = N_Expanded_Name
11663 Par_Ent
:= Entity
(Prefix
(Gen_Id
));
11664 Par_Vis
:= Is_Immediately_Visible
(Par_Ent
);
11665 Install_Parent
(Par_Ent
, In_Body
=> True);
11666 Parent_Installed
:= True;
11668 elsif Is_Child_Unit
(Gen_Unit
) then
11669 Par_Ent
:= Scope
(Gen_Unit
);
11670 Par_Vis
:= Is_Immediately_Visible
(Par_Ent
);
11671 Install_Parent
(Par_Ent
, In_Body
=> True);
11672 Parent_Installed
:= True;
11675 -- Subprogram body is placed in the body of wrapper package,
11676 -- whose spec contains the subprogram declaration as well as
11677 -- the renaming declarations for the generic parameters.
11680 Make_Package_Body
(Loc
,
11681 Defining_Unit_Name
=> New_Copy
(Pack_Id
),
11682 Declarations
=> New_List
(Act_Body
));
11684 Set_Corresponding_Spec
(Pack_Body
, Pack_Id
);
11686 -- If the instantiation is a library unit, then build resulting
11687 -- compilation unit nodes for the instance. The declaration of
11688 -- the enclosing package is the grandparent of the subprogram
11689 -- declaration. First replace the instantiation node as the unit
11690 -- of the corresponding compilation.
11692 if Nkind
(Parent
(Inst_Node
)) = N_Compilation_Unit
then
11693 if Parent
(Inst_Node
) = Cunit
(Main_Unit
) then
11694 Set_Unit
(Parent
(Inst_Node
), Inst_Node
);
11695 Build_Instance_Compilation_Unit_Nodes
11696 (Inst_Node
, Pack_Body
, Parent
(Parent
(Act_Decl
)));
11697 Analyze
(Inst_Node
);
11699 Set_Parent
(Pack_Body
, Parent
(Inst_Node
));
11700 Analyze
(Pack_Body
);
11704 Insert_Before
(Inst_Node
, Pack_Body
);
11705 Mark_Rewrite_Insertion
(Pack_Body
);
11706 Analyze
(Pack_Body
);
11708 if Expander_Active
then
11709 Freeze_Subprogram_Body
(Inst_Node
, Gen_Body
, Pack_Id
);
11713 Inherit_Context
(Gen_Body
, Inst_Node
);
11715 Restore_Private_Views
(Pack_Id
, False);
11717 if Parent_Installed
then
11718 Remove_Parent
(In_Body
=> True);
11720 -- Restore the previous visibility of the parent
11722 Set_Is_Immediately_Visible
(Par_Ent
, Par_Vis
);
11726 Restore_Warnings
(Saved_Warnings
);
11728 -- Body not found. Error was emitted already. If there were no previous
11729 -- errors, this may be an instance whose scope is a premature instance.
11730 -- In that case we must insure that the (legal) program does raise
11731 -- program error if executed. We generate a subprogram body for this
11732 -- purpose. See DEC ac30vso.
11734 -- Should not reference proprietary DEC tests in comments ???
11736 elsif Serious_Errors_Detected
= 0
11737 and then Nkind
(Parent
(Inst_Node
)) /= N_Compilation_Unit
11739 if Body_Optional
then
11742 elsif Ekind
(Act_Decl_Id
) = E_Procedure
then
11744 Make_Subprogram_Body
(Loc
,
11746 Make_Procedure_Specification
(Loc
,
11747 Defining_Unit_Name
=>
11748 Make_Defining_Identifier
(Loc
, Chars
(Act_Decl_Id
)),
11749 Parameter_Specifications
=>
11751 (Parameter_Specifications
(Parent
(Act_Decl_Id
)))),
11753 Declarations
=> Empty_List
,
11754 Handled_Statement_Sequence
=>
11755 Make_Handled_Sequence_Of_Statements
(Loc
,
11756 Statements
=> New_List
(
11757 Make_Raise_Program_Error
(Loc
,
11758 Reason
=> PE_Access_Before_Elaboration
))));
11762 Make_Raise_Program_Error
(Loc
,
11763 Reason
=> PE_Access_Before_Elaboration
);
11765 Set_Etype
(Ret_Expr
, (Etype
(Act_Decl_Id
)));
11766 Set_Analyzed
(Ret_Expr
);
11769 Make_Subprogram_Body
(Loc
,
11771 Make_Function_Specification
(Loc
,
11772 Defining_Unit_Name
=>
11773 Make_Defining_Identifier
(Loc
, Chars
(Act_Decl_Id
)),
11774 Parameter_Specifications
=>
11776 (Parameter_Specifications
(Parent
(Act_Decl_Id
))),
11777 Result_Definition
=>
11778 New_Occurrence_Of
(Etype
(Act_Decl_Id
), Loc
)),
11780 Declarations
=> Empty_List
,
11781 Handled_Statement_Sequence
=>
11782 Make_Handled_Sequence_Of_Statements
(Loc
,
11783 Statements
=> New_List
(
11784 Make_Simple_Return_Statement
(Loc
, Ret_Expr
))));
11788 Make_Package_Body
(Loc
,
11789 Defining_Unit_Name
=> New_Copy
(Pack_Id
),
11790 Declarations
=> New_List
(Act_Body
));
11792 Insert_After
(Inst_Node
, Pack_Body
);
11793 Set_Corresponding_Spec
(Pack_Body
, Pack_Id
);
11794 Analyze
(Pack_Body
);
11797 Expander_Mode_Restore
;
11800 Ignore_SPARK_Mode_Pragmas_In_Instance
:= Saved_ISMP
;
11801 Restore_Ghost_Mode
(Saved_GM
);
11802 Restore_SPARK_Mode
(Saved_SM
, Saved_SMP
);
11803 Style_Check
:= Saved_Style_Check
;
11804 end Instantiate_Subprogram_Body
;
11806 ----------------------
11807 -- Instantiate_Type --
11808 ----------------------
11810 function Instantiate_Type
11813 Analyzed_Formal
: Node_Id
;
11814 Actual_Decls
: List_Id
) return List_Id
11816 A_Gen_T
: constant Entity_Id
:=
11817 Defining_Identifier
(Analyzed_Formal
);
11818 Def
: constant Node_Id
:= Formal_Type_Definition
(Formal
);
11819 Gen_T
: constant Entity_Id
:= Defining_Identifier
(Formal
);
11821 Ancestor
: Entity_Id
:= Empty
;
11822 Decl_Node
: Node_Id
;
11823 Decl_Nodes
: List_Id
;
11827 procedure Diagnose_Predicated_Actual
;
11828 -- There are a number of constructs in which a discrete type with
11829 -- predicates is illegal, e.g. as an index in an array type declaration.
11830 -- If a generic type is used is such a construct in a generic package
11831 -- declaration, it carries the flag No_Predicate_On_Actual. it is part
11832 -- of the generic contract that the actual cannot have predicates.
11834 procedure Validate_Array_Type_Instance
;
11835 procedure Validate_Access_Subprogram_Instance
;
11836 procedure Validate_Access_Type_Instance
;
11837 procedure Validate_Derived_Type_Instance
;
11838 procedure Validate_Derived_Interface_Type_Instance
;
11839 procedure Validate_Discriminated_Formal_Type
;
11840 procedure Validate_Interface_Type_Instance
;
11841 procedure Validate_Private_Type_Instance
;
11842 procedure Validate_Incomplete_Type_Instance
;
11843 -- These procedures perform validation tests for the named case.
11844 -- Validate_Discriminated_Formal_Type is shared by formal private
11845 -- types and Ada 2012 formal incomplete types.
11847 function Subtypes_Match
(Gen_T
, Act_T
: Entity_Id
) return Boolean;
11848 -- Check that base types are the same and that the subtypes match
11849 -- statically. Used in several of the above.
11851 ---------------------------------
11852 -- Diagnose_Predicated_Actual --
11853 ---------------------------------
11855 procedure Diagnose_Predicated_Actual
is
11857 if No_Predicate_On_Actual
(A_Gen_T
)
11858 and then Has_Predicates
(Act_T
)
11861 ("actual for& cannot be a type with predicate",
11862 Instantiation_Node
, A_Gen_T
);
11864 elsif No_Dynamic_Predicate_On_Actual
(A_Gen_T
)
11865 and then Has_Predicates
(Act_T
)
11866 and then not Has_Static_Predicate_Aspect
(Act_T
)
11869 ("actual for& cannot be a type with a dynamic predicate",
11870 Instantiation_Node
, A_Gen_T
);
11872 end Diagnose_Predicated_Actual
;
11874 --------------------
11875 -- Subtypes_Match --
11876 --------------------
11878 function Subtypes_Match
(Gen_T
, Act_T
: Entity_Id
) return Boolean is
11879 T
: constant Entity_Id
:= Get_Instance_Of
(Gen_T
);
11882 -- Some detailed comments would be useful here ???
11884 return ((Base_Type
(T
) = Act_T
11885 or else Base_Type
(T
) = Base_Type
(Act_T
))
11886 and then Subtypes_Statically_Match
(T
, Act_T
))
11888 or else (Is_Class_Wide_Type
(Gen_T
)
11889 and then Is_Class_Wide_Type
(Act_T
)
11890 and then Subtypes_Match
11891 (Get_Instance_Of
(Root_Type
(Gen_T
)),
11892 Root_Type
(Act_T
)))
11895 (Ekind_In
(Gen_T
, E_Anonymous_Access_Subprogram_Type
,
11896 E_Anonymous_Access_Type
)
11897 and then Ekind
(Act_T
) = Ekind
(Gen_T
)
11898 and then Subtypes_Statically_Match
11899 (Designated_Type
(Gen_T
), Designated_Type
(Act_T
)));
11900 end Subtypes_Match
;
11902 -----------------------------------------
11903 -- Validate_Access_Subprogram_Instance --
11904 -----------------------------------------
11906 procedure Validate_Access_Subprogram_Instance
is
11908 if not Is_Access_Type
(Act_T
)
11909 or else Ekind
(Designated_Type
(Act_T
)) /= E_Subprogram_Type
11912 ("expect access type in instantiation of &", Actual
, Gen_T
);
11913 Abandon_Instantiation
(Actual
);
11916 -- According to AI05-288, actuals for access_to_subprograms must be
11917 -- subtype conformant with the generic formal. Previous to AI05-288
11918 -- only mode conformance was required.
11920 -- This is a binding interpretation that applies to previous versions
11921 -- of the language, no need to maintain previous weaker checks.
11923 Check_Subtype_Conformant
11924 (Designated_Type
(Act_T
),
11925 Designated_Type
(A_Gen_T
),
11929 if Ekind
(Base_Type
(Act_T
)) = E_Access_Protected_Subprogram_Type
then
11930 if Ekind
(A_Gen_T
) = E_Access_Subprogram_Type
then
11932 ("protected access type not allowed for formal &",
11936 elsif Ekind
(A_Gen_T
) = E_Access_Protected_Subprogram_Type
then
11938 ("expect protected access type for formal &",
11942 -- If the formal has a specified convention (which in most cases
11943 -- will be StdCall) verify that the actual has the same convention.
11945 if Has_Convention_Pragma
(A_Gen_T
)
11946 and then Convention
(A_Gen_T
) /= Convention
(Act_T
)
11948 Error_Msg_Name_1
:= Get_Convention_Name
(Convention
(A_Gen_T
));
11950 ("actual for formal & must have convention %", Actual
, Gen_T
);
11952 end Validate_Access_Subprogram_Instance
;
11954 -----------------------------------
11955 -- Validate_Access_Type_Instance --
11956 -----------------------------------
11958 procedure Validate_Access_Type_Instance
is
11959 Desig_Type
: constant Entity_Id
:=
11960 Find_Actual_Type
(Designated_Type
(A_Gen_T
), A_Gen_T
);
11961 Desig_Act
: Entity_Id
;
11964 if not Is_Access_Type
(Act_T
) then
11966 ("expect access type in instantiation of &", Actual
, Gen_T
);
11967 Abandon_Instantiation
(Actual
);
11970 if Is_Access_Constant
(A_Gen_T
) then
11971 if not Is_Access_Constant
(Act_T
) then
11973 ("actual type must be access-to-constant type", Actual
);
11974 Abandon_Instantiation
(Actual
);
11977 if Is_Access_Constant
(Act_T
) then
11979 ("actual type must be access-to-variable type", Actual
);
11980 Abandon_Instantiation
(Actual
);
11982 elsif Ekind
(A_Gen_T
) = E_General_Access_Type
11983 and then Ekind
(Base_Type
(Act_T
)) /= E_General_Access_Type
11985 Error_Msg_N
-- CODEFIX
11986 ("actual must be general access type!", Actual
);
11987 Error_Msg_NE
-- CODEFIX
11988 ("add ALL to }!", Actual
, Act_T
);
11989 Abandon_Instantiation
(Actual
);
11993 -- The designated subtypes, that is to say the subtypes introduced
11994 -- by an access type declaration (and not by a subtype declaration)
11997 Desig_Act
:= Designated_Type
(Base_Type
(Act_T
));
11999 -- The designated type may have been introduced through a limited_
12000 -- with clause, in which case retrieve the non-limited view. This
12001 -- applies to incomplete types as well as to class-wide types.
12003 if From_Limited_With
(Desig_Act
) then
12004 Desig_Act
:= Available_View
(Desig_Act
);
12007 if not Subtypes_Match
(Desig_Type
, Desig_Act
) then
12009 ("designated type of actual does not match that of formal &",
12012 if not Predicates_Match
(Desig_Type
, Desig_Act
) then
12013 Error_Msg_N
("\predicates do not match", Actual
);
12016 Abandon_Instantiation
(Actual
);
12018 elsif Is_Access_Type
(Designated_Type
(Act_T
))
12019 and then Is_Constrained
(Designated_Type
(Designated_Type
(Act_T
)))
12021 Is_Constrained
(Designated_Type
(Desig_Type
))
12024 ("designated type of actual does not match that of formal &",
12027 if not Predicates_Match
(Desig_Type
, Desig_Act
) then
12028 Error_Msg_N
("\predicates do not match", Actual
);
12031 Abandon_Instantiation
(Actual
);
12034 -- Ada 2005: null-exclusion indicators of the two types must agree
12036 if Can_Never_Be_Null
(A_Gen_T
) /= Can_Never_Be_Null
(Act_T
) then
12038 ("non null exclusion of actual and formal & do not match",
12041 end Validate_Access_Type_Instance
;
12043 ----------------------------------
12044 -- Validate_Array_Type_Instance --
12045 ----------------------------------
12047 procedure Validate_Array_Type_Instance
is
12052 function Formal_Dimensions
return Nat
;
12053 -- Count number of dimensions in array type formal
12055 -----------------------
12056 -- Formal_Dimensions --
12057 -----------------------
12059 function Formal_Dimensions
return Nat
is
12064 if Nkind
(Def
) = N_Constrained_Array_Definition
then
12065 Index
:= First
(Discrete_Subtype_Definitions
(Def
));
12067 Index
:= First
(Subtype_Marks
(Def
));
12070 while Present
(Index
) loop
12072 Next_Index
(Index
);
12076 end Formal_Dimensions
;
12078 -- Start of processing for Validate_Array_Type_Instance
12081 if not Is_Array_Type
(Act_T
) then
12083 ("expect array type in instantiation of &", Actual
, Gen_T
);
12084 Abandon_Instantiation
(Actual
);
12086 elsif Nkind
(Def
) = N_Constrained_Array_Definition
then
12087 if not (Is_Constrained
(Act_T
)) then
12089 ("expect constrained array in instantiation of &",
12091 Abandon_Instantiation
(Actual
);
12095 if Is_Constrained
(Act_T
) then
12097 ("expect unconstrained array in instantiation of &",
12099 Abandon_Instantiation
(Actual
);
12103 if Formal_Dimensions
/= Number_Dimensions
(Act_T
) then
12105 ("dimensions of actual do not match formal &", Actual
, Gen_T
);
12106 Abandon_Instantiation
(Actual
);
12109 I1
:= First_Index
(A_Gen_T
);
12110 I2
:= First_Index
(Act_T
);
12111 for J
in 1 .. Formal_Dimensions
loop
12113 -- If the indexes of the actual were given by a subtype_mark,
12114 -- the index was transformed into a range attribute. Retrieve
12115 -- the original type mark for checking.
12117 if Is_Entity_Name
(Original_Node
(I2
)) then
12118 T2
:= Entity
(Original_Node
(I2
));
12123 if not Subtypes_Match
12124 (Find_Actual_Type
(Etype
(I1
), A_Gen_T
), T2
)
12127 ("index types of actual do not match those of formal &",
12129 Abandon_Instantiation
(Actual
);
12136 -- Check matching subtypes. Note that there are complex visibility
12137 -- issues when the generic is a child unit and some aspect of the
12138 -- generic type is declared in a parent unit of the generic. We do
12139 -- the test to handle this special case only after a direct check
12140 -- for static matching has failed. The case where both the component
12141 -- type and the array type are separate formals, and the component
12142 -- type is a private view may also require special checking in
12143 -- Subtypes_Match. Finally, we assume that a child instance where
12144 -- the component type comes from a formal of a parent instance is
12145 -- correct because the generic was correct. A more precise check
12146 -- seems too complex to install???
12149 (Component_Type
(A_Gen_T
), Component_Type
(Act_T
))
12152 (Find_Actual_Type
(Component_Type
(A_Gen_T
), A_Gen_T
),
12153 Component_Type
(Act_T
))
12155 (not Inside_A_Generic
12156 and then Is_Child_Unit
(Scope
(Component_Type
(A_Gen_T
))))
12161 ("component subtype of actual does not match that of formal &",
12163 Abandon_Instantiation
(Actual
);
12166 if Has_Aliased_Components
(A_Gen_T
)
12167 and then not Has_Aliased_Components
(Act_T
)
12170 ("actual must have aliased components to match formal type &",
12173 end Validate_Array_Type_Instance
;
12175 -----------------------------------------------
12176 -- Validate_Derived_Interface_Type_Instance --
12177 -----------------------------------------------
12179 procedure Validate_Derived_Interface_Type_Instance
is
12180 Par
: constant Entity_Id
:= Entity
(Subtype_Indication
(Def
));
12184 -- First apply interface instance checks
12186 Validate_Interface_Type_Instance
;
12188 -- Verify that immediate parent interface is an ancestor of
12192 and then not Interface_Present_In_Ancestor
(Act_T
, Par
)
12195 ("interface actual must include progenitor&", Actual
, Par
);
12198 -- Now verify that the actual includes all other ancestors of
12201 Elmt
:= First_Elmt
(Interfaces
(A_Gen_T
));
12202 while Present
(Elmt
) loop
12203 if not Interface_Present_In_Ancestor
12204 (Act_T
, Get_Instance_Of
(Node
(Elmt
)))
12207 ("interface actual must include progenitor&",
12208 Actual
, Node
(Elmt
));
12213 end Validate_Derived_Interface_Type_Instance
;
12215 ------------------------------------
12216 -- Validate_Derived_Type_Instance --
12217 ------------------------------------
12219 procedure Validate_Derived_Type_Instance
is
12220 Actual_Discr
: Entity_Id
;
12221 Ancestor_Discr
: Entity_Id
;
12224 -- If the parent type in the generic declaration is itself a previous
12225 -- formal type, then it is local to the generic and absent from the
12226 -- analyzed generic definition. In that case the ancestor is the
12227 -- instance of the formal (which must have been instantiated
12228 -- previously), unless the ancestor is itself a formal derived type.
12229 -- In this latter case (which is the subject of Corrigendum 8652/0038
12230 -- (AI-202) the ancestor of the formals is the ancestor of its
12231 -- parent. Otherwise, the analyzed generic carries the parent type.
12232 -- If the parent type is defined in a previous formal package, then
12233 -- the scope of that formal package is that of the generic type
12234 -- itself, and it has already been mapped into the corresponding type
12235 -- in the actual package.
12237 -- Common case: parent type defined outside of the generic
12239 if Is_Entity_Name
(Subtype_Mark
(Def
))
12240 and then Present
(Entity
(Subtype_Mark
(Def
)))
12242 Ancestor
:= Get_Instance_Of
(Entity
(Subtype_Mark
(Def
)));
12244 -- Check whether parent is defined in a previous formal package
12247 Scope
(Scope
(Base_Type
(Etype
(A_Gen_T
)))) = Scope
(A_Gen_T
)
12250 Get_Instance_Of
(Base_Type
(Etype
(A_Gen_T
)));
12252 -- The type may be a local derivation, or a type extension of a
12253 -- previous formal, or of a formal of a parent package.
12255 elsif Is_Derived_Type
(Get_Instance_Of
(A_Gen_T
))
12257 Ekind
(Get_Instance_Of
(A_Gen_T
)) = E_Record_Type_With_Private
12259 -- Check whether the parent is another derived formal type in the
12260 -- same generic unit.
12262 if Etype
(A_Gen_T
) /= A_Gen_T
12263 and then Is_Generic_Type
(Etype
(A_Gen_T
))
12264 and then Scope
(Etype
(A_Gen_T
)) = Scope
(A_Gen_T
)
12265 and then Etype
(Etype
(A_Gen_T
)) /= Etype
(A_Gen_T
)
12267 -- Locate ancestor of parent from the subtype declaration
12268 -- created for the actual.
12274 Decl
:= First
(Actual_Decls
);
12275 while Present
(Decl
) loop
12276 if Nkind
(Decl
) = N_Subtype_Declaration
12277 and then Chars
(Defining_Identifier
(Decl
)) =
12278 Chars
(Etype
(A_Gen_T
))
12280 Ancestor
:= Generic_Parent_Type
(Decl
);
12288 pragma Assert
(Present
(Ancestor
));
12290 -- The ancestor itself may be a previous formal that has been
12293 Ancestor
:= Get_Instance_Of
(Ancestor
);
12297 Get_Instance_Of
(Base_Type
(Get_Instance_Of
(A_Gen_T
)));
12300 -- Check whether parent is a previous formal of the current generic
12302 elsif Is_Derived_Type
(A_Gen_T
)
12303 and then Is_Generic_Type
(Etype
(A_Gen_T
))
12304 and then Scope
(A_Gen_T
) = Scope
(Etype
(A_Gen_T
))
12306 Ancestor
:= Get_Instance_Of
(First_Subtype
(Etype
(A_Gen_T
)));
12308 -- An unusual case: the actual is a type declared in a parent unit,
12309 -- but is not a formal type so there is no instance_of for it.
12310 -- Retrieve it by analyzing the record extension.
12312 elsif Is_Child_Unit
(Scope
(A_Gen_T
))
12313 and then In_Open_Scopes
(Scope
(Act_T
))
12314 and then Is_Generic_Instance
(Scope
(Act_T
))
12316 Analyze
(Subtype_Mark
(Def
));
12317 Ancestor
:= Entity
(Subtype_Mark
(Def
));
12320 Ancestor
:= Get_Instance_Of
(Etype
(Base_Type
(A_Gen_T
)));
12323 -- If the formal derived type has pragma Preelaborable_Initialization
12324 -- then the actual type must have preelaborable initialization.
12326 if Known_To_Have_Preelab_Init
(A_Gen_T
)
12327 and then not Has_Preelaborable_Initialization
(Act_T
)
12330 ("actual for & must have preelaborable initialization",
12334 -- Ada 2005 (AI-251)
12336 if Ada_Version
>= Ada_2005
and then Is_Interface
(Ancestor
) then
12337 if not Interface_Present_In_Ancestor
(Act_T
, Ancestor
) then
12339 ("(Ada 2005) expected type implementing & in instantiation",
12343 -- Finally verify that the (instance of) the ancestor is an ancestor
12346 elsif not Is_Ancestor
(Base_Type
(Ancestor
), Act_T
) then
12348 ("expect type derived from & in instantiation",
12349 Actual
, First_Subtype
(Ancestor
));
12350 Abandon_Instantiation
(Actual
);
12353 -- Ada 2005 (AI-443): Synchronized formal derived type checks. Note
12354 -- that the formal type declaration has been rewritten as a private
12357 if Ada_Version
>= Ada_2005
12358 and then Nkind
(Parent
(A_Gen_T
)) = N_Private_Extension_Declaration
12359 and then Synchronized_Present
(Parent
(A_Gen_T
))
12361 -- The actual must be a synchronized tagged type
12363 if not Is_Tagged_Type
(Act_T
) then
12365 ("actual of synchronized type must be tagged", Actual
);
12366 Abandon_Instantiation
(Actual
);
12368 elsif Nkind
(Parent
(Act_T
)) = N_Full_Type_Declaration
12369 and then Nkind
(Type_Definition
(Parent
(Act_T
))) =
12370 N_Derived_Type_Definition
12371 and then not Synchronized_Present
12372 (Type_Definition
(Parent
(Act_T
)))
12375 ("actual of synchronized type must be synchronized", Actual
);
12376 Abandon_Instantiation
(Actual
);
12380 -- Perform atomic/volatile checks (RM C.6(12)). Note that AI05-0218-1
12381 -- removes the second instance of the phrase "or allow pass by copy".
12383 if Is_Atomic
(Act_T
) and then not Is_Atomic
(Ancestor
) then
12385 ("cannot have atomic actual type for non-atomic formal type",
12388 elsif Is_Volatile
(Act_T
) and then not Is_Volatile
(Ancestor
) then
12390 ("cannot have volatile actual type for non-volatile formal type",
12394 -- It should not be necessary to check for unknown discriminants on
12395 -- Formal, but for some reason Has_Unknown_Discriminants is false for
12396 -- A_Gen_T, so Is_Definite_Subtype incorrectly returns True. This
12397 -- needs fixing. ???
12399 if Is_Definite_Subtype
(A_Gen_T
)
12400 and then not Unknown_Discriminants_Present
(Formal
)
12401 and then not Is_Definite_Subtype
(Act_T
)
12403 Error_Msg_N
("actual subtype must be constrained", Actual
);
12404 Abandon_Instantiation
(Actual
);
12407 if not Unknown_Discriminants_Present
(Formal
) then
12408 if Is_Constrained
(Ancestor
) then
12409 if not Is_Constrained
(Act_T
) then
12410 Error_Msg_N
("actual subtype must be constrained", Actual
);
12411 Abandon_Instantiation
(Actual
);
12414 -- Ancestor is unconstrained, Check if generic formal and actual
12415 -- agree on constrainedness. The check only applies to array types
12416 -- and discriminated types.
12418 elsif Is_Constrained
(Act_T
) then
12419 if Ekind
(Ancestor
) = E_Access_Type
12420 or else (not Is_Constrained
(A_Gen_T
)
12421 and then Is_Composite_Type
(A_Gen_T
))
12423 Error_Msg_N
("actual subtype must be unconstrained", Actual
);
12424 Abandon_Instantiation
(Actual
);
12427 -- A class-wide type is only allowed if the formal has unknown
12430 elsif Is_Class_Wide_Type
(Act_T
)
12431 and then not Has_Unknown_Discriminants
(Ancestor
)
12434 ("actual for & cannot be a class-wide type", Actual
, Gen_T
);
12435 Abandon_Instantiation
(Actual
);
12437 -- Otherwise, the formal and actual must have the same number
12438 -- of discriminants and each discriminant of the actual must
12439 -- correspond to a discriminant of the formal.
12441 elsif Has_Discriminants
(Act_T
)
12442 and then not Has_Unknown_Discriminants
(Act_T
)
12443 and then Has_Discriminants
(Ancestor
)
12445 Actual_Discr
:= First_Discriminant
(Act_T
);
12446 Ancestor_Discr
:= First_Discriminant
(Ancestor
);
12447 while Present
(Actual_Discr
)
12448 and then Present
(Ancestor_Discr
)
12450 if Base_Type
(Act_T
) /= Base_Type
(Ancestor
) and then
12451 No
(Corresponding_Discriminant
(Actual_Discr
))
12454 ("discriminant & does not correspond "
12455 & "to ancestor discriminant", Actual
, Actual_Discr
);
12456 Abandon_Instantiation
(Actual
);
12459 Next_Discriminant
(Actual_Discr
);
12460 Next_Discriminant
(Ancestor_Discr
);
12463 if Present
(Actual_Discr
) or else Present
(Ancestor_Discr
) then
12465 ("actual for & must have same number of discriminants",
12467 Abandon_Instantiation
(Actual
);
12470 -- This case should be caught by the earlier check for
12471 -- constrainedness, but the check here is added for completeness.
12473 elsif Has_Discriminants
(Act_T
)
12474 and then not Has_Unknown_Discriminants
(Act_T
)
12477 ("actual for & must not have discriminants", Actual
, Gen_T
);
12478 Abandon_Instantiation
(Actual
);
12480 elsif Has_Discriminants
(Ancestor
) then
12482 ("actual for & must have known discriminants", Actual
, Gen_T
);
12483 Abandon_Instantiation
(Actual
);
12486 if not Subtypes_Statically_Compatible
12487 (Act_T
, Ancestor
, Formal_Derived_Matching
=> True)
12490 ("constraint on actual is incompatible with formal", Actual
);
12491 Abandon_Instantiation
(Actual
);
12495 -- If the formal and actual types are abstract, check that there
12496 -- are no abstract primitives of the actual type that correspond to
12497 -- nonabstract primitives of the formal type (second sentence of
12500 if Is_Abstract_Type
(A_Gen_T
) and then Is_Abstract_Type
(Act_T
) then
12501 Check_Abstract_Primitives
: declare
12502 Gen_Prims
: constant Elist_Id
:=
12503 Primitive_Operations
(A_Gen_T
);
12504 Gen_Elmt
: Elmt_Id
;
12505 Gen_Subp
: Entity_Id
;
12506 Anc_Subp
: Entity_Id
;
12507 Anc_Formal
: Entity_Id
;
12508 Anc_F_Type
: Entity_Id
;
12510 Act_Prims
: constant Elist_Id
:= Primitive_Operations
(Act_T
);
12511 Act_Elmt
: Elmt_Id
;
12512 Act_Subp
: Entity_Id
;
12513 Act_Formal
: Entity_Id
;
12514 Act_F_Type
: Entity_Id
;
12516 Subprograms_Correspond
: Boolean;
12518 function Is_Tagged_Ancestor
(T1
, T2
: Entity_Id
) return Boolean;
12519 -- Returns true if T2 is derived directly or indirectly from
12520 -- T1, including derivations from interfaces. T1 and T2 are
12521 -- required to be specific tagged base types.
12523 ------------------------
12524 -- Is_Tagged_Ancestor --
12525 ------------------------
12527 function Is_Tagged_Ancestor
(T1
, T2
: Entity_Id
) return Boolean
12529 Intfc_Elmt
: Elmt_Id
;
12532 -- The predicate is satisfied if the types are the same
12537 -- If we've reached the top of the derivation chain then
12538 -- we know that T1 is not an ancestor of T2.
12540 elsif Etype
(T2
) = T2
then
12543 -- Proceed to check T2's immediate parent
12545 elsif Is_Ancestor
(T1
, Base_Type
(Etype
(T2
))) then
12548 -- Finally, check to see if T1 is an ancestor of any of T2's
12552 Intfc_Elmt
:= First_Elmt
(Interfaces
(T2
));
12553 while Present
(Intfc_Elmt
) loop
12554 if Is_Ancestor
(T1
, Node
(Intfc_Elmt
)) then
12558 Next_Elmt
(Intfc_Elmt
);
12563 end Is_Tagged_Ancestor
;
12565 -- Start of processing for Check_Abstract_Primitives
12568 -- Loop over all of the formal derived type's primitives
12570 Gen_Elmt
:= First_Elmt
(Gen_Prims
);
12571 while Present
(Gen_Elmt
) loop
12572 Gen_Subp
:= Node
(Gen_Elmt
);
12574 -- If the primitive of the formal is not abstract, then
12575 -- determine whether there is a corresponding primitive of
12576 -- the actual type that's abstract.
12578 if not Is_Abstract_Subprogram
(Gen_Subp
) then
12579 Act_Elmt
:= First_Elmt
(Act_Prims
);
12580 while Present
(Act_Elmt
) loop
12581 Act_Subp
:= Node
(Act_Elmt
);
12583 -- If we find an abstract primitive of the actual,
12584 -- then we need to test whether it corresponds to the
12585 -- subprogram from which the generic formal primitive
12588 if Is_Abstract_Subprogram
(Act_Subp
) then
12589 Anc_Subp
:= Alias
(Gen_Subp
);
12591 -- Test whether we have a corresponding primitive
12592 -- by comparing names, kinds, formal types, and
12595 if Chars
(Anc_Subp
) = Chars
(Act_Subp
)
12596 and then Ekind
(Anc_Subp
) = Ekind
(Act_Subp
)
12598 Anc_Formal
:= First_Formal
(Anc_Subp
);
12599 Act_Formal
:= First_Formal
(Act_Subp
);
12600 while Present
(Anc_Formal
)
12601 and then Present
(Act_Formal
)
12603 Anc_F_Type
:= Etype
(Anc_Formal
);
12604 Act_F_Type
:= Etype
(Act_Formal
);
12606 if Ekind
(Anc_F_Type
) =
12607 E_Anonymous_Access_Type
12609 Anc_F_Type
:= Designated_Type
(Anc_F_Type
);
12611 if Ekind
(Act_F_Type
) =
12612 E_Anonymous_Access_Type
12615 Designated_Type
(Act_F_Type
);
12621 Ekind
(Act_F_Type
) = E_Anonymous_Access_Type
12626 Anc_F_Type
:= Base_Type
(Anc_F_Type
);
12627 Act_F_Type
:= Base_Type
(Act_F_Type
);
12629 -- If the formal is controlling, then the
12630 -- the type of the actual primitive's formal
12631 -- must be derived directly or indirectly
12632 -- from the type of the ancestor primitive's
12635 if Is_Controlling_Formal
(Anc_Formal
) then
12636 if not Is_Tagged_Ancestor
12637 (Anc_F_Type
, Act_F_Type
)
12642 -- Otherwise the types of the formals must
12645 elsif Anc_F_Type
/= Act_F_Type
then
12649 Next_Entity
(Anc_Formal
);
12650 Next_Entity
(Act_Formal
);
12653 -- If we traversed through all of the formals
12654 -- then so far the subprograms correspond, so
12655 -- now check that any result types correspond.
12657 if No
(Anc_Formal
) and then No
(Act_Formal
) then
12658 Subprograms_Correspond
:= True;
12660 if Ekind
(Act_Subp
) = E_Function
then
12661 Anc_F_Type
:= Etype
(Anc_Subp
);
12662 Act_F_Type
:= Etype
(Act_Subp
);
12664 if Ekind
(Anc_F_Type
) =
12665 E_Anonymous_Access_Type
12668 Designated_Type
(Anc_F_Type
);
12670 if Ekind
(Act_F_Type
) =
12671 E_Anonymous_Access_Type
12674 Designated_Type
(Act_F_Type
);
12676 Subprograms_Correspond
:= False;
12681 = E_Anonymous_Access_Type
12683 Subprograms_Correspond
:= False;
12686 Anc_F_Type
:= Base_Type
(Anc_F_Type
);
12687 Act_F_Type
:= Base_Type
(Act_F_Type
);
12689 -- Now either the result types must be
12690 -- the same or, if the result type is
12691 -- controlling, the result type of the
12692 -- actual primitive must descend from the
12693 -- result type of the ancestor primitive.
12695 if Subprograms_Correspond
12696 and then Anc_F_Type
/= Act_F_Type
12698 Has_Controlling_Result
(Anc_Subp
)
12699 and then not Is_Tagged_Ancestor
12700 (Anc_F_Type
, Act_F_Type
)
12702 Subprograms_Correspond
:= False;
12706 -- Found a matching subprogram belonging to
12707 -- formal ancestor type, so actual subprogram
12708 -- corresponds and this violates 3.9.3(9).
12710 if Subprograms_Correspond
then
12712 ("abstract subprogram & overrides "
12713 & "nonabstract subprogram of ancestor",
12720 Next_Elmt
(Act_Elmt
);
12724 Next_Elmt
(Gen_Elmt
);
12726 end Check_Abstract_Primitives
;
12729 -- Verify that limitedness matches. If parent is a limited
12730 -- interface then the generic formal is not unless declared
12731 -- explicitly so. If not declared limited, the actual cannot be
12732 -- limited (see AI05-0087).
12734 -- Even though this AI is a binding interpretation, we enable the
12735 -- check only in Ada 2012 mode, because this improper construct
12736 -- shows up in user code and in existing B-tests.
12738 if Is_Limited_Type
(Act_T
)
12739 and then not Is_Limited_Type
(A_Gen_T
)
12740 and then Ada_Version
>= Ada_2012
12742 if In_Instance
then
12746 ("actual for non-limited & cannot be a limited type",
12748 Explain_Limited_Type
(Act_T
, Actual
);
12749 Abandon_Instantiation
(Actual
);
12752 end Validate_Derived_Type_Instance
;
12754 ----------------------------------------
12755 -- Validate_Discriminated_Formal_Type --
12756 ----------------------------------------
12758 procedure Validate_Discriminated_Formal_Type
is
12759 Formal_Discr
: Entity_Id
;
12760 Actual_Discr
: Entity_Id
;
12761 Formal_Subt
: Entity_Id
;
12764 if Has_Discriminants
(A_Gen_T
) then
12765 if not Has_Discriminants
(Act_T
) then
12767 ("actual for & must have discriminants", Actual
, Gen_T
);
12768 Abandon_Instantiation
(Actual
);
12770 elsif Is_Constrained
(Act_T
) then
12772 ("actual for & must be unconstrained", Actual
, Gen_T
);
12773 Abandon_Instantiation
(Actual
);
12776 Formal_Discr
:= First_Discriminant
(A_Gen_T
);
12777 Actual_Discr
:= First_Discriminant
(Act_T
);
12778 while Formal_Discr
/= Empty
loop
12779 if Actual_Discr
= Empty
then
12781 ("discriminants on actual do not match formal",
12783 Abandon_Instantiation
(Actual
);
12786 Formal_Subt
:= Get_Instance_Of
(Etype
(Formal_Discr
));
12788 -- Access discriminants match if designated types do
12790 if Ekind
(Base_Type
(Formal_Subt
)) = E_Anonymous_Access_Type
12791 and then (Ekind
(Base_Type
(Etype
(Actual_Discr
)))) =
12792 E_Anonymous_Access_Type
12795 (Designated_Type
(Base_Type
(Formal_Subt
))) =
12796 Designated_Type
(Base_Type
(Etype
(Actual_Discr
)))
12800 elsif Base_Type
(Formal_Subt
) /=
12801 Base_Type
(Etype
(Actual_Discr
))
12804 ("types of actual discriminants must match formal",
12806 Abandon_Instantiation
(Actual
);
12808 elsif not Subtypes_Statically_Match
12809 (Formal_Subt
, Etype
(Actual_Discr
))
12810 and then Ada_Version
>= Ada_95
12813 ("subtypes of actual discriminants must match formal",
12815 Abandon_Instantiation
(Actual
);
12818 Next_Discriminant
(Formal_Discr
);
12819 Next_Discriminant
(Actual_Discr
);
12822 if Actual_Discr
/= Empty
then
12824 ("discriminants on actual do not match formal",
12826 Abandon_Instantiation
(Actual
);
12830 end Validate_Discriminated_Formal_Type
;
12832 ---------------------------------------
12833 -- Validate_Incomplete_Type_Instance --
12834 ---------------------------------------
12836 procedure Validate_Incomplete_Type_Instance
is
12838 if not Is_Tagged_Type
(Act_T
)
12839 and then Is_Tagged_Type
(A_Gen_T
)
12842 ("actual for & must be a tagged type", Actual
, Gen_T
);
12845 Validate_Discriminated_Formal_Type
;
12846 end Validate_Incomplete_Type_Instance
;
12848 --------------------------------------
12849 -- Validate_Interface_Type_Instance --
12850 --------------------------------------
12852 procedure Validate_Interface_Type_Instance
is
12854 if not Is_Interface
(Act_T
) then
12856 ("actual for formal interface type must be an interface",
12859 elsif Is_Limited_Type
(Act_T
) /= Is_Limited_Type
(A_Gen_T
)
12860 or else Is_Task_Interface
(A_Gen_T
) /= Is_Task_Interface
(Act_T
)
12861 or else Is_Protected_Interface
(A_Gen_T
) /=
12862 Is_Protected_Interface
(Act_T
)
12863 or else Is_Synchronized_Interface
(A_Gen_T
) /=
12864 Is_Synchronized_Interface
(Act_T
)
12867 ("actual for interface& does not match (RM 12.5.5(4))",
12870 end Validate_Interface_Type_Instance
;
12872 ------------------------------------
12873 -- Validate_Private_Type_Instance --
12874 ------------------------------------
12876 procedure Validate_Private_Type_Instance
is
12878 if Is_Limited_Type
(Act_T
)
12879 and then not Is_Limited_Type
(A_Gen_T
)
12881 if In_Instance
then
12885 ("actual for non-limited & cannot be a limited type", Actual
,
12887 Explain_Limited_Type
(Act_T
, Actual
);
12888 Abandon_Instantiation
(Actual
);
12891 elsif Known_To_Have_Preelab_Init
(A_Gen_T
)
12892 and then not Has_Preelaborable_Initialization
(Act_T
)
12895 ("actual for & must have preelaborable initialization", Actual
,
12898 elsif not Is_Definite_Subtype
(Act_T
)
12899 and then Is_Definite_Subtype
(A_Gen_T
)
12900 and then Ada_Version
>= Ada_95
12903 ("actual for & must be a definite subtype", Actual
, Gen_T
);
12905 elsif not Is_Tagged_Type
(Act_T
)
12906 and then Is_Tagged_Type
(A_Gen_T
)
12909 ("actual for & must be a tagged type", Actual
, Gen_T
);
12912 Validate_Discriminated_Formal_Type
;
12914 end Validate_Private_Type_Instance
;
12916 -- Start of processing for Instantiate_Type
12919 if Get_Instance_Of
(A_Gen_T
) /= A_Gen_T
then
12920 Error_Msg_N
("duplicate instantiation of generic type", Actual
);
12921 return New_List
(Error
);
12923 elsif not Is_Entity_Name
(Actual
)
12924 or else not Is_Type
(Entity
(Actual
))
12927 ("expect valid subtype mark to instantiate &", Actual
, Gen_T
);
12928 Abandon_Instantiation
(Actual
);
12931 Act_T
:= Entity
(Actual
);
12933 -- Ada 2005 (AI-216): An Unchecked_Union subtype shall only be passed
12934 -- as a generic actual parameter if the corresponding formal type
12935 -- does not have a known_discriminant_part, or is a formal derived
12936 -- type that is an Unchecked_Union type.
12938 if Is_Unchecked_Union
(Base_Type
(Act_T
)) then
12939 if not Has_Discriminants
(A_Gen_T
)
12940 or else (Is_Derived_Type
(A_Gen_T
)
12941 and then Is_Unchecked_Union
(A_Gen_T
))
12945 Error_Msg_N
("unchecked union cannot be the actual for a "
12946 & "discriminated formal type", Act_T
);
12951 -- Deal with fixed/floating restrictions
12953 if Is_Floating_Point_Type
(Act_T
) then
12954 Check_Restriction
(No_Floating_Point
, Actual
);
12955 elsif Is_Fixed_Point_Type
(Act_T
) then
12956 Check_Restriction
(No_Fixed_Point
, Actual
);
12959 -- Deal with error of using incomplete type as generic actual.
12960 -- This includes limited views of a type, even if the non-limited
12961 -- view may be available.
12963 if Ekind
(Act_T
) = E_Incomplete_Type
12964 or else (Is_Class_Wide_Type
(Act_T
)
12965 and then Ekind
(Root_Type
(Act_T
)) = E_Incomplete_Type
)
12967 -- If the formal is an incomplete type, the actual can be
12968 -- incomplete as well.
12970 if Ekind
(A_Gen_T
) = E_Incomplete_Type
then
12973 elsif Is_Class_Wide_Type
(Act_T
)
12974 or else No
(Full_View
(Act_T
))
12976 Error_Msg_N
("premature use of incomplete type", Actual
);
12977 Abandon_Instantiation
(Actual
);
12979 Act_T
:= Full_View
(Act_T
);
12980 Set_Entity
(Actual
, Act_T
);
12982 if Has_Private_Component
(Act_T
) then
12984 ("premature use of type with private component", Actual
);
12988 -- Deal with error of premature use of private type as generic actual
12990 elsif Is_Private_Type
(Act_T
)
12991 and then Is_Private_Type
(Base_Type
(Act_T
))
12992 and then not Is_Generic_Type
(Act_T
)
12993 and then not Is_Derived_Type
(Act_T
)
12994 and then No
(Full_View
(Root_Type
(Act_T
)))
12996 -- If the formal is an incomplete type, the actual can be
12997 -- private or incomplete as well.
12999 if Ekind
(A_Gen_T
) = E_Incomplete_Type
then
13002 Error_Msg_N
("premature use of private type", Actual
);
13005 elsif Has_Private_Component
(Act_T
) then
13007 ("premature use of type with private component", Actual
);
13010 Set_Instance_Of
(A_Gen_T
, Act_T
);
13012 -- If the type is generic, the class-wide type may also be used
13014 if Is_Tagged_Type
(A_Gen_T
)
13015 and then Is_Tagged_Type
(Act_T
)
13016 and then not Is_Class_Wide_Type
(A_Gen_T
)
13018 Set_Instance_Of
(Class_Wide_Type
(A_Gen_T
),
13019 Class_Wide_Type
(Act_T
));
13022 if not Is_Abstract_Type
(A_Gen_T
)
13023 and then Is_Abstract_Type
(Act_T
)
13026 ("actual of non-abstract formal cannot be abstract", Actual
);
13029 -- A generic scalar type is a first subtype for which we generate
13030 -- an anonymous base type. Indicate that the instance of this base
13031 -- is the base type of the actual.
13033 if Is_Scalar_Type
(A_Gen_T
) then
13034 Set_Instance_Of
(Etype
(A_Gen_T
), Etype
(Act_T
));
13038 if Error_Posted
(Act_T
) then
13041 case Nkind
(Def
) is
13042 when N_Formal_Private_Type_Definition
=>
13043 Validate_Private_Type_Instance
;
13045 when N_Formal_Incomplete_Type_Definition
=>
13046 Validate_Incomplete_Type_Instance
;
13048 when N_Formal_Derived_Type_Definition
=>
13049 Validate_Derived_Type_Instance
;
13051 when N_Formal_Discrete_Type_Definition
=>
13052 if not Is_Discrete_Type
(Act_T
) then
13054 ("expect discrete type in instantiation of&",
13056 Abandon_Instantiation
(Actual
);
13059 Diagnose_Predicated_Actual
;
13061 when N_Formal_Signed_Integer_Type_Definition
=>
13062 if not Is_Signed_Integer_Type
(Act_T
) then
13064 ("expect signed integer type in instantiation of&",
13066 Abandon_Instantiation
(Actual
);
13069 Diagnose_Predicated_Actual
;
13071 when N_Formal_Modular_Type_Definition
=>
13072 if not Is_Modular_Integer_Type
(Act_T
) then
13074 ("expect modular type in instantiation of &",
13076 Abandon_Instantiation
(Actual
);
13079 Diagnose_Predicated_Actual
;
13081 when N_Formal_Floating_Point_Definition
=>
13082 if not Is_Floating_Point_Type
(Act_T
) then
13084 ("expect float type in instantiation of &", Actual
, Gen_T
);
13085 Abandon_Instantiation
(Actual
);
13088 when N_Formal_Ordinary_Fixed_Point_Definition
=>
13089 if not Is_Ordinary_Fixed_Point_Type
(Act_T
) then
13091 ("expect ordinary fixed point type in instantiation of &",
13093 Abandon_Instantiation
(Actual
);
13096 when N_Formal_Decimal_Fixed_Point_Definition
=>
13097 if not Is_Decimal_Fixed_Point_Type
(Act_T
) then
13099 ("expect decimal type in instantiation of &",
13101 Abandon_Instantiation
(Actual
);
13104 when N_Array_Type_Definition
=>
13105 Validate_Array_Type_Instance
;
13107 when N_Access_To_Object_Definition
=>
13108 Validate_Access_Type_Instance
;
13110 when N_Access_Function_Definition
13111 | N_Access_Procedure_Definition
13113 Validate_Access_Subprogram_Instance
;
13115 when N_Record_Definition
=>
13116 Validate_Interface_Type_Instance
;
13118 when N_Derived_Type_Definition
=>
13119 Validate_Derived_Interface_Type_Instance
;
13122 raise Program_Error
;
13126 Subt
:= New_Copy
(Gen_T
);
13128 -- Use adjusted sloc of subtype name as the location for other nodes in
13129 -- the subtype declaration.
13131 Loc
:= Sloc
(Subt
);
13134 Make_Subtype_Declaration
(Loc
,
13135 Defining_Identifier
=> Subt
,
13136 Subtype_Indication
=> New_Occurrence_Of
(Act_T
, Loc
));
13138 if Is_Private_Type
(Act_T
) then
13139 Set_Has_Private_View
(Subtype_Indication
(Decl_Node
));
13141 elsif Is_Access_Type
(Act_T
)
13142 and then Is_Private_Type
(Designated_Type
(Act_T
))
13144 Set_Has_Private_View
(Subtype_Indication
(Decl_Node
));
13147 -- In Ada 2012 the actual may be a limited view. Indicate that
13148 -- the local subtype must be treated as such.
13150 if From_Limited_With
(Act_T
) then
13151 Set_Ekind
(Subt
, E_Incomplete_Subtype
);
13152 Set_From_Limited_With
(Subt
);
13155 Decl_Nodes
:= New_List
(Decl_Node
);
13157 -- Flag actual derived types so their elaboration produces the
13158 -- appropriate renamings for the primitive operations of the ancestor.
13159 -- Flag actual for formal private types as well, to determine whether
13160 -- operations in the private part may override inherited operations.
13161 -- If the formal has an interface list, the ancestor is not the
13162 -- parent, but the analyzed formal that includes the interface
13163 -- operations of all its progenitors.
13165 -- Same treatment for formal private types, so we can check whether the
13166 -- type is tagged limited when validating derivations in the private
13167 -- part. (See AI05-096).
13169 if Nkind
(Def
) = N_Formal_Derived_Type_Definition
then
13170 if Present
(Interface_List
(Def
)) then
13171 Set_Generic_Parent_Type
(Decl_Node
, A_Gen_T
);
13173 Set_Generic_Parent_Type
(Decl_Node
, Ancestor
);
13176 elsif Nkind_In
(Def
, N_Formal_Private_Type_Definition
,
13177 N_Formal_Incomplete_Type_Definition
)
13179 Set_Generic_Parent_Type
(Decl_Node
, A_Gen_T
);
13182 -- If the actual is a synchronized type that implements an interface,
13183 -- the primitive operations are attached to the corresponding record,
13184 -- and we have to treat it as an additional generic actual, so that its
13185 -- primitive operations become visible in the instance. The task or
13186 -- protected type itself does not carry primitive operations.
13188 if Is_Concurrent_Type
(Act_T
)
13189 and then Is_Tagged_Type
(Act_T
)
13190 and then Present
(Corresponding_Record_Type
(Act_T
))
13191 and then Present
(Ancestor
)
13192 and then Is_Interface
(Ancestor
)
13195 Corr_Rec
: constant Entity_Id
:=
13196 Corresponding_Record_Type
(Act_T
);
13197 New_Corr
: Entity_Id
;
13198 Corr_Decl
: Node_Id
;
13201 New_Corr
:= Make_Temporary
(Loc
, 'S');
13203 Make_Subtype_Declaration
(Loc
,
13204 Defining_Identifier
=> New_Corr
,
13205 Subtype_Indication
=>
13206 New_Occurrence_Of
(Corr_Rec
, Loc
));
13207 Append_To
(Decl_Nodes
, Corr_Decl
);
13209 if Ekind
(Act_T
) = E_Task_Type
then
13210 Set_Ekind
(Subt
, E_Task_Subtype
);
13212 Set_Ekind
(Subt
, E_Protected_Subtype
);
13215 Set_Corresponding_Record_Type
(Subt
, Corr_Rec
);
13216 Set_Generic_Parent_Type
(Corr_Decl
, Ancestor
);
13217 Set_Generic_Parent_Type
(Decl_Node
, Empty
);
13221 -- For a floating-point type, capture dimension info if any, because
13222 -- the generated subtype declaration does not come from source and
13223 -- will not process dimensions.
13225 if Is_Floating_Point_Type
(Act_T
) then
13226 Copy_Dimensions
(Act_T
, Subt
);
13230 end Instantiate_Type
;
13232 ---------------------
13233 -- Is_In_Main_Unit --
13234 ---------------------
13236 function Is_In_Main_Unit
(N
: Node_Id
) return Boolean is
13237 Unum
: constant Unit_Number_Type
:= Get_Source_Unit
(N
);
13238 Current_Unit
: Node_Id
;
13241 if Unum
= Main_Unit
then
13244 -- If the current unit is a subunit then it is either the main unit or
13245 -- is being compiled as part of the main unit.
13247 elsif Nkind
(N
) = N_Compilation_Unit
then
13248 return Nkind
(Unit
(N
)) = N_Subunit
;
13251 Current_Unit
:= Parent
(N
);
13252 while Present
(Current_Unit
)
13253 and then Nkind
(Current_Unit
) /= N_Compilation_Unit
13255 Current_Unit
:= Parent
(Current_Unit
);
13258 -- The instantiation node is in the main unit, or else the current node
13259 -- (perhaps as the result of nested instantiations) is in the main unit,
13260 -- or in the declaration of the main unit, which in this last case must
13264 Current_Unit
= Cunit
(Main_Unit
)
13265 or else Current_Unit
= Library_Unit
(Cunit
(Main_Unit
))
13266 or else (Present
(Current_Unit
)
13267 and then Present
(Library_Unit
(Current_Unit
))
13268 and then Is_In_Main_Unit
(Library_Unit
(Current_Unit
)));
13269 end Is_In_Main_Unit
;
13271 ----------------------------
13272 -- Load_Parent_Of_Generic --
13273 ----------------------------
13275 procedure Load_Parent_Of_Generic
13278 Body_Optional
: Boolean := False)
13280 Comp_Unit
: constant Node_Id
:= Cunit
(Get_Source_Unit
(Spec
));
13281 Saved_Style_Check
: constant Boolean := Style_Check
;
13282 Saved_Warnings
: constant Warning_Record
:= Save_Warnings
;
13283 True_Parent
: Node_Id
;
13284 Inst_Node
: Node_Id
;
13286 Previous_Instances
: constant Elist_Id
:= New_Elmt_List
;
13288 procedure Collect_Previous_Instances
(Decls
: List_Id
);
13289 -- Collect all instantiations in the given list of declarations, that
13290 -- precede the generic that we need to load. If the bodies of these
13291 -- instantiations are available, we must analyze them, to ensure that
13292 -- the public symbols generated are the same when the unit is compiled
13293 -- to generate code, and when it is compiled in the context of a unit
13294 -- that needs a particular nested instance. This process is applied to
13295 -- both package and subprogram instances.
13297 --------------------------------
13298 -- Collect_Previous_Instances --
13299 --------------------------------
13301 procedure Collect_Previous_Instances
(Decls
: List_Id
) is
13305 Decl
:= First
(Decls
);
13306 while Present
(Decl
) loop
13307 if Sloc
(Decl
) >= Sloc
(Inst_Node
) then
13310 -- If Decl is an instantiation, then record it as requiring
13311 -- instantiation of the corresponding body, except if it is an
13312 -- abbreviated instantiation generated internally for conformance
13313 -- checking purposes only for the case of a formal package
13314 -- declared without a box (see Instantiate_Formal_Package). Such
13315 -- an instantiation does not generate any code (the actual code
13316 -- comes from actual) and thus does not need to be analyzed here.
13317 -- If the instantiation appears with a generic package body it is
13318 -- not analyzed here either.
13320 elsif Nkind
(Decl
) = N_Package_Instantiation
13321 and then not Is_Internal
(Defining_Entity
(Decl
))
13323 Append_Elmt
(Decl
, Previous_Instances
);
13325 -- For a subprogram instantiation, omit instantiations intrinsic
13326 -- operations (Unchecked_Conversions, etc.) that have no bodies.
13328 elsif Nkind_In
(Decl
, N_Function_Instantiation
,
13329 N_Procedure_Instantiation
)
13330 and then not Is_Intrinsic_Subprogram
(Entity
(Name
(Decl
)))
13332 Append_Elmt
(Decl
, Previous_Instances
);
13334 elsif Nkind
(Decl
) = N_Package_Declaration
then
13335 Collect_Previous_Instances
13336 (Visible_Declarations
(Specification
(Decl
)));
13337 Collect_Previous_Instances
13338 (Private_Declarations
(Specification
(Decl
)));
13340 -- Previous non-generic bodies may contain instances as well
13342 elsif Nkind
(Decl
) = N_Package_Body
13343 and then Ekind
(Corresponding_Spec
(Decl
)) /= E_Generic_Package
13345 Collect_Previous_Instances
(Declarations
(Decl
));
13347 elsif Nkind
(Decl
) = N_Subprogram_Body
13348 and then not Acts_As_Spec
(Decl
)
13349 and then not Is_Generic_Subprogram
(Corresponding_Spec
(Decl
))
13351 Collect_Previous_Instances
(Declarations
(Decl
));
13356 end Collect_Previous_Instances
;
13358 -- Start of processing for Load_Parent_Of_Generic
13361 if not In_Same_Source_Unit
(N
, Spec
)
13362 or else Nkind
(Unit
(Comp_Unit
)) = N_Package_Declaration
13363 or else (Nkind
(Unit
(Comp_Unit
)) = N_Package_Body
13364 and then not Is_In_Main_Unit
(Spec
))
13366 -- Find body of parent of spec, and analyze it. A special case arises
13367 -- when the parent is an instantiation, that is to say when we are
13368 -- currently instantiating a nested generic. In that case, there is
13369 -- no separate file for the body of the enclosing instance. Instead,
13370 -- the enclosing body must be instantiated as if it were a pending
13371 -- instantiation, in order to produce the body for the nested generic
13372 -- we require now. Note that in that case the generic may be defined
13373 -- in a package body, the instance defined in the same package body,
13374 -- and the original enclosing body may not be in the main unit.
13376 Inst_Node
:= Empty
;
13378 True_Parent
:= Parent
(Spec
);
13379 while Present
(True_Parent
)
13380 and then Nkind
(True_Parent
) /= N_Compilation_Unit
13382 if Nkind
(True_Parent
) = N_Package_Declaration
13384 Nkind
(Original_Node
(True_Parent
)) = N_Package_Instantiation
13386 -- Parent is a compilation unit that is an instantiation.
13387 -- Instantiation node has been replaced with package decl.
13389 Inst_Node
:= Original_Node
(True_Parent
);
13392 elsif Nkind
(True_Parent
) = N_Package_Declaration
13393 and then Present
(Generic_Parent
(Specification
(True_Parent
)))
13394 and then Nkind
(Parent
(True_Parent
)) /= N_Compilation_Unit
13396 -- Parent is an instantiation within another specification.
13397 -- Declaration for instance has been inserted before original
13398 -- instantiation node. A direct link would be preferable?
13400 Inst_Node
:= Next
(True_Parent
);
13401 while Present
(Inst_Node
)
13402 and then Nkind
(Inst_Node
) /= N_Package_Instantiation
13407 -- If the instance appears within a generic, and the generic
13408 -- unit is defined within a formal package of the enclosing
13409 -- generic, there is no generic body available, and none
13410 -- needed. A more precise test should be used ???
13412 if No
(Inst_Node
) then
13419 True_Parent
:= Parent
(True_Parent
);
13423 -- Case where we are currently instantiating a nested generic
13425 if Present
(Inst_Node
) then
13426 if Nkind
(Parent
(True_Parent
)) = N_Compilation_Unit
then
13428 -- Instantiation node and declaration of instantiated package
13429 -- were exchanged when only the declaration was needed.
13430 -- Restore instantiation node before proceeding with body.
13432 Set_Unit
(Parent
(True_Parent
), Inst_Node
);
13435 -- Now complete instantiation of enclosing body, if it appears in
13436 -- some other unit. If it appears in the current unit, the body
13437 -- will have been instantiated already.
13439 if No
(Corresponding_Body
(Instance_Spec
(Inst_Node
))) then
13441 -- We need to determine the expander mode to instantiate the
13442 -- enclosing body. Because the generic body we need may use
13443 -- global entities declared in the enclosing package (including
13444 -- aggregates) it is in general necessary to compile this body
13445 -- with expansion enabled, except if we are within a generic
13446 -- package, in which case the usual generic rule applies.
13449 Exp_Status
: Boolean := True;
13453 -- Loop through scopes looking for generic package
13455 Scop
:= Scope
(Defining_Entity
(Instance_Spec
(Inst_Node
)));
13456 while Present
(Scop
)
13457 and then Scop
/= Standard_Standard
13459 if Ekind
(Scop
) = E_Generic_Package
then
13460 Exp_Status
:= False;
13464 Scop
:= Scope
(Scop
);
13467 -- Collect previous instantiations in the unit that contains
13468 -- the desired generic.
13470 if Nkind
(Parent
(True_Parent
)) /= N_Compilation_Unit
13471 and then not Body_Optional
13475 Info
: Pending_Body_Info
;
13479 Par
:= Parent
(Inst_Node
);
13480 while Present
(Par
) loop
13481 exit when Nkind
(Parent
(Par
)) = N_Compilation_Unit
;
13482 Par
:= Parent
(Par
);
13485 pragma Assert
(Present
(Par
));
13487 if Nkind
(Par
) = N_Package_Body
then
13488 Collect_Previous_Instances
(Declarations
(Par
));
13490 elsif Nkind
(Par
) = N_Package_Declaration
then
13491 Collect_Previous_Instances
13492 (Visible_Declarations
(Specification
(Par
)));
13493 Collect_Previous_Instances
13494 (Private_Declarations
(Specification
(Par
)));
13497 -- Enclosing unit is a subprogram body. In this
13498 -- case all instance bodies are processed in order
13499 -- and there is no need to collect them separately.
13504 Decl
:= First_Elmt
(Previous_Instances
);
13505 while Present
(Decl
) loop
13507 (Inst_Node
=> Node
(Decl
),
13509 Instance_Spec
(Node
(Decl
)),
13510 Expander_Status
=> Exp_Status
,
13511 Current_Sem_Unit
=>
13512 Get_Code_Unit
(Sloc
(Node
(Decl
))),
13513 Scope_Suppress
=> Scope_Suppress
,
13514 Local_Suppress_Stack_Top
=>
13515 Local_Suppress_Stack_Top
,
13516 Version
=> Ada_Version
,
13517 Version_Pragma
=> Ada_Version_Pragma
,
13518 Warnings
=> Save_Warnings
,
13519 SPARK_Mode
=> SPARK_Mode
,
13520 SPARK_Mode_Pragma
=> SPARK_Mode_Pragma
);
13522 -- Package instance
13524 if Nkind
(Node
(Decl
)) = N_Package_Instantiation
13526 Instantiate_Package_Body
13527 (Info
, Body_Optional
=> True);
13529 -- Subprogram instance
13532 -- The instance_spec is in the wrapper package,
13533 -- usually followed by its local renaming
13534 -- declaration. See Build_Subprogram_Renaming
13535 -- for details. If the instance carries aspects,
13536 -- these result in the corresponding pragmas,
13537 -- inserted after the subprogram declaration.
13538 -- They must be skipped as well when retrieving
13539 -- the desired spec. Some of them may have been
13540 -- rewritten as null statements.
13541 -- A direct link would be more robust ???
13545 (Last
(Visible_Declarations
13546 (Specification
(Info
.Act_Decl
))));
13548 while Nkind_In
(Decl
,
13551 N_Subprogram_Renaming_Declaration
)
13553 Decl
:= Prev
(Decl
);
13556 Info
.Act_Decl
:= Decl
;
13559 Instantiate_Subprogram_Body
13560 (Info
, Body_Optional
=> True);
13568 Instantiate_Package_Body
13570 ((Inst_Node
=> Inst_Node
,
13571 Act_Decl
=> True_Parent
,
13572 Expander_Status
=> Exp_Status
,
13573 Current_Sem_Unit
=> Get_Code_Unit
13574 (Sloc
(Inst_Node
)),
13575 Scope_Suppress
=> Scope_Suppress
,
13576 Local_Suppress_Stack_Top
=> Local_Suppress_Stack_Top
,
13577 Version
=> Ada_Version
,
13578 Version_Pragma
=> Ada_Version_Pragma
,
13579 Warnings
=> Save_Warnings
,
13580 SPARK_Mode
=> SPARK_Mode
,
13581 SPARK_Mode_Pragma
=> SPARK_Mode_Pragma
)),
13582 Body_Optional
=> Body_Optional
);
13586 -- Case where we are not instantiating a nested generic
13589 Opt
.Style_Check
:= False;
13590 Expander_Mode_Save_And_Set
(True);
13591 Load_Needed_Body
(Comp_Unit
, OK
);
13592 Opt
.Style_Check
:= Saved_Style_Check
;
13593 Restore_Warnings
(Saved_Warnings
);
13594 Expander_Mode_Restore
;
13597 and then Unit_Requires_Body
(Defining_Entity
(Spec
))
13598 and then not Body_Optional
13601 Bname
: constant Unit_Name_Type
:=
13602 Get_Body_Name
(Get_Unit_Name
(Unit
(Comp_Unit
)));
13605 -- In CodePeer mode, the missing body may make the analysis
13606 -- incomplete, but we do not treat it as fatal.
13608 if CodePeer_Mode
then
13612 Error_Msg_Unit_1
:= Bname
;
13613 Error_Msg_N
("this instantiation requires$!", N
);
13614 Error_Msg_File_1
:=
13615 Get_File_Name
(Bname
, Subunit
=> False);
13616 Error_Msg_N
("\but file{ was not found!", N
);
13617 raise Unrecoverable_Error
;
13624 -- If loading parent of the generic caused an instantiation circularity,
13625 -- we abandon compilation at this point, because otherwise in some cases
13626 -- we get into trouble with infinite recursions after this point.
13628 if Circularity_Detected
then
13629 raise Unrecoverable_Error
;
13631 end Load_Parent_Of_Generic
;
13633 ---------------------------------
13634 -- Map_Formal_Package_Entities --
13635 ---------------------------------
13637 procedure Map_Formal_Package_Entities
(Form
: Entity_Id
; Act
: Entity_Id
) is
13642 Set_Instance_Of
(Form
, Act
);
13644 -- Traverse formal and actual package to map the corresponding entities.
13645 -- We skip over internal entities that may be generated during semantic
13646 -- analysis, and find the matching entities by name, given that they
13647 -- must appear in the same order.
13649 E1
:= First_Entity
(Form
);
13650 E2
:= First_Entity
(Act
);
13651 while Present
(E1
) and then E1
/= First_Private_Entity
(Form
) loop
13652 -- Could this test be a single condition??? Seems like it could, and
13653 -- isn't FPE (Form) a constant anyway???
13655 if not Is_Internal
(E1
)
13656 and then Present
(Parent
(E1
))
13657 and then not Is_Class_Wide_Type
(E1
)
13658 and then not Is_Internal_Name
(Chars
(E1
))
13660 while Present
(E2
) and then Chars
(E2
) /= Chars
(E1
) loop
13667 Set_Instance_Of
(E1
, E2
);
13669 if Is_Type
(E1
) and then Is_Tagged_Type
(E2
) then
13670 Set_Instance_Of
(Class_Wide_Type
(E1
), Class_Wide_Type
(E2
));
13673 if Is_Constrained
(E1
) then
13674 Set_Instance_Of
(Base_Type
(E1
), Base_Type
(E2
));
13677 if Ekind
(E1
) = E_Package
and then No
(Renamed_Object
(E1
)) then
13678 Map_Formal_Package_Entities
(E1
, E2
);
13685 end Map_Formal_Package_Entities
;
13687 -----------------------
13688 -- Move_Freeze_Nodes --
13689 -----------------------
13691 procedure Move_Freeze_Nodes
13692 (Out_Of
: Entity_Id
;
13697 Next_Decl
: Node_Id
;
13698 Next_Node
: Node_Id
:= After
;
13701 function Is_Outer_Type
(T
: Entity_Id
) return Boolean;
13702 -- Check whether entity is declared in a scope external to that of the
13705 -------------------
13706 -- Is_Outer_Type --
13707 -------------------
13709 function Is_Outer_Type
(T
: Entity_Id
) return Boolean is
13710 Scop
: Entity_Id
:= Scope
(T
);
13713 if Scope_Depth
(Scop
) < Scope_Depth
(Out_Of
) then
13717 while Scop
/= Standard_Standard
loop
13718 if Scop
= Out_Of
then
13721 Scop
:= Scope
(Scop
);
13729 -- Start of processing for Move_Freeze_Nodes
13736 -- First remove the freeze nodes that may appear before all other
13740 while Present
(Decl
)
13741 and then Nkind
(Decl
) = N_Freeze_Entity
13742 and then Is_Outer_Type
(Entity
(Decl
))
13744 Decl
:= Remove_Head
(L
);
13745 Insert_After
(Next_Node
, Decl
);
13746 Set_Analyzed
(Decl
, False);
13751 -- Next scan the list of declarations and remove each freeze node that
13752 -- appears ahead of the current node.
13754 while Present
(Decl
) loop
13755 while Present
(Next
(Decl
))
13756 and then Nkind
(Next
(Decl
)) = N_Freeze_Entity
13757 and then Is_Outer_Type
(Entity
(Next
(Decl
)))
13759 Next_Decl
:= Remove_Next
(Decl
);
13760 Insert_After
(Next_Node
, Next_Decl
);
13761 Set_Analyzed
(Next_Decl
, False);
13762 Next_Node
:= Next_Decl
;
13765 -- If the declaration is a nested package or concurrent type, then
13766 -- recurse. Nested generic packages will have been processed from the
13769 case Nkind
(Decl
) is
13770 when N_Package_Declaration
=>
13771 Spec
:= Specification
(Decl
);
13773 when N_Task_Type_Declaration
=>
13774 Spec
:= Task_Definition
(Decl
);
13776 when N_Protected_Type_Declaration
=>
13777 Spec
:= Protected_Definition
(Decl
);
13783 if Present
(Spec
) then
13784 Move_Freeze_Nodes
(Out_Of
, Next_Node
, Visible_Declarations
(Spec
));
13785 Move_Freeze_Nodes
(Out_Of
, Next_Node
, Private_Declarations
(Spec
));
13790 end Move_Freeze_Nodes
;
13796 function Next_Assoc
(E
: Assoc_Ptr
) return Assoc_Ptr
is
13798 return Generic_Renamings
.Table
(E
).Next_In_HTable
;
13801 ------------------------
13802 -- Preanalyze_Actuals --
13803 ------------------------
13805 procedure Preanalyze_Actuals
(N
: Node_Id
; Inst
: Entity_Id
:= Empty
) is
13808 Errs
: constant Nat
:= Serious_Errors_Detected
;
13810 Cur
: Entity_Id
:= Empty
;
13811 -- Current homograph of the instance name
13813 Vis
: Boolean := False;
13814 -- Saved visibility status of the current homograph
13817 Assoc
:= First
(Generic_Associations
(N
));
13819 -- If the instance is a child unit, its name may hide an outer homonym,
13820 -- so make it invisible to perform name resolution on the actuals.
13822 if Nkind
(Defining_Unit_Name
(N
)) = N_Defining_Program_Unit_Name
13824 (Current_Entity
(Defining_Identifier
(Defining_Unit_Name
(N
))))
13826 Cur
:= Current_Entity
(Defining_Identifier
(Defining_Unit_Name
(N
)));
13828 if Is_Compilation_Unit
(Cur
) then
13829 Vis
:= Is_Immediately_Visible
(Cur
);
13830 Set_Is_Immediately_Visible
(Cur
, False);
13836 while Present
(Assoc
) loop
13837 if Nkind
(Assoc
) /= N_Others_Choice
then
13838 Act
:= Explicit_Generic_Actual_Parameter
(Assoc
);
13840 -- Within a nested instantiation, a defaulted actual is an empty
13841 -- association, so nothing to analyze. If the subprogram actual
13842 -- is an attribute, analyze prefix only, because actual is not a
13843 -- complete attribute reference.
13845 -- If actual is an allocator, analyze expression only. The full
13846 -- analysis can generate code, and if instance is a compilation
13847 -- unit we have to wait until the package instance is installed
13848 -- to have a proper place to insert this code.
13850 -- String literals may be operators, but at this point we do not
13851 -- know whether the actual is a formal subprogram or a string.
13856 elsif Nkind
(Act
) = N_Attribute_Reference
then
13857 Analyze
(Prefix
(Act
));
13859 elsif Nkind
(Act
) = N_Explicit_Dereference
then
13860 Analyze
(Prefix
(Act
));
13862 elsif Nkind
(Act
) = N_Allocator
then
13864 Expr
: constant Node_Id
:= Expression
(Act
);
13867 if Nkind
(Expr
) = N_Subtype_Indication
then
13868 Analyze
(Subtype_Mark
(Expr
));
13870 -- Analyze separately each discriminant constraint, when
13871 -- given with a named association.
13877 Constr
:= First
(Constraints
(Constraint
(Expr
)));
13878 while Present
(Constr
) loop
13879 if Nkind
(Constr
) = N_Discriminant_Association
then
13880 Analyze
(Expression
(Constr
));
13894 elsif Nkind
(Act
) /= N_Operator_Symbol
then
13897 -- Within a package instance, mark actuals that are limited
13898 -- views, so their use can be moved to the body of the
13901 if Is_Entity_Name
(Act
)
13902 and then Is_Type
(Entity
(Act
))
13903 and then From_Limited_With
(Entity
(Act
))
13904 and then Present
(Inst
)
13906 Append_Elmt
(Entity
(Act
), Incomplete_Actuals
(Inst
));
13910 if Errs
/= Serious_Errors_Detected
then
13912 -- Do a minimal analysis of the generic, to prevent spurious
13913 -- warnings complaining about the generic being unreferenced,
13914 -- before abandoning the instantiation.
13916 Analyze
(Name
(N
));
13918 if Is_Entity_Name
(Name
(N
))
13919 and then Etype
(Name
(N
)) /= Any_Type
13921 Generate_Reference
(Entity
(Name
(N
)), Name
(N
));
13922 Set_Is_Instantiated
(Entity
(Name
(N
)));
13925 if Present
(Cur
) then
13927 -- For the case of a child instance hiding an outer homonym,
13928 -- provide additional warning which might explain the error.
13930 Set_Is_Immediately_Visible
(Cur
, Vis
);
13932 ("& hides outer unit with the same name??",
13933 N
, Defining_Unit_Name
(N
));
13936 Abandon_Instantiation
(Act
);
13943 if Present
(Cur
) then
13944 Set_Is_Immediately_Visible
(Cur
, Vis
);
13946 end Preanalyze_Actuals
;
13948 -------------------
13949 -- Remove_Parent --
13950 -------------------
13952 procedure Remove_Parent
(In_Body
: Boolean := False) is
13953 S
: Entity_Id
:= Current_Scope
;
13954 -- S is the scope containing the instantiation just completed. The scope
13955 -- stack contains the parent instances of the instantiation, followed by
13964 -- After child instantiation is complete, remove from scope stack the
13965 -- extra copy of the current scope, and then remove parent instances.
13967 if not In_Body
then
13970 while Current_Scope
/= S
loop
13971 P
:= Current_Scope
;
13972 End_Package_Scope
(Current_Scope
);
13974 if In_Open_Scopes
(P
) then
13975 E
:= First_Entity
(P
);
13976 while Present
(E
) loop
13977 Set_Is_Immediately_Visible
(E
, True);
13981 -- If instantiation is declared in a block, it is the enclosing
13982 -- scope that might be a parent instance. Note that only one
13983 -- block can be involved, because the parent instances have
13984 -- been installed within it.
13986 if Ekind
(P
) = E_Block
then
13987 Cur_P
:= Scope
(P
);
13992 if Is_Generic_Instance
(Cur_P
) and then P
/= Current_Scope
then
13993 -- We are within an instance of some sibling. Retain
13994 -- visibility of parent, for proper subsequent cleanup, and
13995 -- reinstall private declarations as well.
13997 Set_In_Private_Part
(P
);
13998 Install_Private_Declarations
(P
);
14001 -- If the ultimate parent is a top-level unit recorded in
14002 -- Instance_Parent_Unit, then reset its visibility to what it was
14003 -- before instantiation. (It's not clear what the purpose is of
14004 -- testing whether Scope (P) is In_Open_Scopes, but that test was
14005 -- present before the ultimate parent test was added.???)
14007 elsif not In_Open_Scopes
(Scope
(P
))
14008 or else (P
= Instance_Parent_Unit
14009 and then not Parent_Unit_Visible
)
14011 Set_Is_Immediately_Visible
(P
, False);
14013 -- If the current scope is itself an instantiation of a generic
14014 -- nested within P, and we are in the private part of body of this
14015 -- instantiation, restore the full views of P, that were removed
14016 -- in End_Package_Scope above. This obscure case can occur when a
14017 -- subunit of a generic contains an instance of a child unit of
14018 -- its generic parent unit.
14020 elsif S
= Current_Scope
and then Is_Generic_Instance
(S
) then
14022 Par
: constant Entity_Id
:=
14023 Generic_Parent
(Package_Specification
(S
));
14026 and then P
= Scope
(Par
)
14027 and then (In_Package_Body
(S
) or else In_Private_Part
(S
))
14029 Set_In_Private_Part
(P
);
14030 Install_Private_Declarations
(P
);
14036 -- Reset visibility of entities in the enclosing scope
14038 Set_Is_Hidden_Open_Scope
(Current_Scope
, False);
14040 Hidden
:= First_Elmt
(Hidden_Entities
);
14041 while Present
(Hidden
) loop
14042 Set_Is_Immediately_Visible
(Node
(Hidden
), True);
14043 Next_Elmt
(Hidden
);
14047 -- Each body is analyzed separately, and there is no context that
14048 -- needs preserving from one body instance to the next, so remove all
14049 -- parent scopes that have been installed.
14051 while Present
(S
) loop
14052 End_Package_Scope
(S
);
14053 Set_Is_Immediately_Visible
(S
, False);
14054 S
:= Current_Scope
;
14055 exit when S
= Standard_Standard
;
14064 procedure Restore_Env
is
14065 Saved
: Instance_Env
renames Instance_Envs
.Table
(Instance_Envs
.Last
);
14068 if No
(Current_Instantiated_Parent
.Act_Id
) then
14069 -- Restore environment after subprogram inlining
14071 Restore_Private_Views
(Empty
);
14074 Current_Instantiated_Parent
:= Saved
.Instantiated_Parent
;
14075 Exchanged_Views
:= Saved
.Exchanged_Views
;
14076 Hidden_Entities
:= Saved
.Hidden_Entities
;
14077 Current_Sem_Unit
:= Saved
.Current_Sem_Unit
;
14078 Parent_Unit_Visible
:= Saved
.Parent_Unit_Visible
;
14079 Instance_Parent_Unit
:= Saved
.Instance_Parent_Unit
;
14081 Restore_Opt_Config_Switches
(Saved
.Switches
);
14083 Instance_Envs
.Decrement_Last
;
14086 ---------------------------
14087 -- Restore_Private_Views --
14088 ---------------------------
14090 procedure Restore_Private_Views
14091 (Pack_Id
: Entity_Id
;
14092 Is_Package
: Boolean := True)
14097 Dep_Elmt
: Elmt_Id
;
14100 procedure Restore_Nested_Formal
(Formal
: Entity_Id
);
14101 -- Hide the generic formals of formal packages declared with box which
14102 -- were reachable in the current instantiation.
14104 ---------------------------
14105 -- Restore_Nested_Formal --
14106 ---------------------------
14108 procedure Restore_Nested_Formal
(Formal
: Entity_Id
) is
14112 if Present
(Renamed_Object
(Formal
))
14113 and then Denotes_Formal_Package
(Renamed_Object
(Formal
), True)
14117 elsif Present
(Associated_Formal_Package
(Formal
)) then
14118 Ent
:= First_Entity
(Formal
);
14119 while Present
(Ent
) loop
14120 exit when Ekind
(Ent
) = E_Package
14121 and then Renamed_Entity
(Ent
) = Renamed_Entity
(Formal
);
14123 Set_Is_Hidden
(Ent
);
14124 Set_Is_Potentially_Use_Visible
(Ent
, False);
14126 -- If package, then recurse
14128 if Ekind
(Ent
) = E_Package
then
14129 Restore_Nested_Formal
(Ent
);
14135 end Restore_Nested_Formal
;
14137 -- Start of processing for Restore_Private_Views
14140 M
:= First_Elmt
(Exchanged_Views
);
14141 while Present
(M
) loop
14144 -- Subtypes of types whose views have been exchanged, and that are
14145 -- defined within the instance, were not on the Private_Dependents
14146 -- list on entry to the instance, so they have to be exchanged
14147 -- explicitly now, in order to remain consistent with the view of the
14150 if Ekind_In
(Typ
, E_Private_Type
,
14151 E_Limited_Private_Type
,
14152 E_Record_Type_With_Private
)
14154 Dep_Elmt
:= First_Elmt
(Private_Dependents
(Typ
));
14155 while Present
(Dep_Elmt
) loop
14156 Dep_Typ
:= Node
(Dep_Elmt
);
14158 if Scope
(Dep_Typ
) = Pack_Id
14159 and then Present
(Full_View
(Dep_Typ
))
14161 Replace_Elmt
(Dep_Elmt
, Full_View
(Dep_Typ
));
14162 Exchange_Declarations
(Dep_Typ
);
14165 Next_Elmt
(Dep_Elmt
);
14169 Exchange_Declarations
(Node
(M
));
14173 if No
(Pack_Id
) then
14177 -- Make the generic formal parameters private, and make the formal types
14178 -- into subtypes of the actuals again.
14180 E
:= First_Entity
(Pack_Id
);
14181 while Present
(E
) loop
14182 Set_Is_Hidden
(E
, True);
14185 and then Nkind
(Parent
(E
)) = N_Subtype_Declaration
14187 -- If the actual for E is itself a generic actual type from
14188 -- an enclosing instance, E is still a generic actual type
14189 -- outside of the current instance. This matter when resolving
14190 -- an overloaded call that may be ambiguous in the enclosing
14191 -- instance, when two of its actuals coincide.
14193 if Is_Entity_Name
(Subtype_Indication
(Parent
(E
)))
14194 and then Is_Generic_Actual_Type
14195 (Entity
(Subtype_Indication
(Parent
(E
))))
14199 Set_Is_Generic_Actual_Type
(E
, False);
14202 -- An unusual case of aliasing: the actual may also be directly
14203 -- visible in the generic, and be private there, while it is fully
14204 -- visible in the context of the instance. The internal subtype
14205 -- is private in the instance but has full visibility like its
14206 -- parent in the enclosing scope. This enforces the invariant that
14207 -- the privacy status of all private dependents of a type coincide
14208 -- with that of the parent type. This can only happen when a
14209 -- generic child unit is instantiated within a sibling.
14211 if Is_Private_Type
(E
)
14212 and then not Is_Private_Type
(Etype
(E
))
14214 Exchange_Declarations
(E
);
14217 elsif Ekind
(E
) = E_Package
then
14219 -- The end of the renaming list is the renaming of the generic
14220 -- package itself. If the instance is a subprogram, all entities
14221 -- in the corresponding package are renamings. If this entity is
14222 -- a formal package, make its own formals private as well. The
14223 -- actual in this case is itself the renaming of an instantiation.
14224 -- If the entity is not a package renaming, it is the entity
14225 -- created to validate formal package actuals: ignore it.
14227 -- If the actual is itself a formal package for the enclosing
14228 -- generic, or the actual for such a formal package, it remains
14229 -- visible on exit from the instance, and therefore nothing needs
14230 -- to be done either, except to keep it accessible.
14232 if Is_Package
and then Renamed_Object
(E
) = Pack_Id
then
14235 elsif Nkind
(Parent
(E
)) /= N_Package_Renaming_Declaration
then
14239 Denotes_Formal_Package
(Renamed_Object
(E
), True, Pack_Id
)
14241 Set_Is_Hidden
(E
, False);
14245 Act_P
: constant Entity_Id
:= Renamed_Object
(E
);
14249 Id
:= First_Entity
(Act_P
);
14251 and then Id
/= First_Private_Entity
(Act_P
)
14253 exit when Ekind
(Id
) = E_Package
14254 and then Renamed_Object
(Id
) = Act_P
;
14256 Set_Is_Hidden
(Id
, True);
14257 Set_Is_Potentially_Use_Visible
(Id
, In_Use
(Act_P
));
14259 if Ekind
(Id
) = E_Package
then
14260 Restore_Nested_Formal
(Id
);
14271 end Restore_Private_Views
;
14278 (Gen_Unit
: Entity_Id
;
14279 Act_Unit
: Entity_Id
)
14283 Set_Instance_Env
(Gen_Unit
, Act_Unit
);
14286 ----------------------------
14287 -- Save_Global_References --
14288 ----------------------------
14290 procedure Save_Global_References
(Templ
: Node_Id
) is
14292 -- ??? it is horrible to use global variables in highly recursive code
14295 -- The entity of the current associated node
14297 Gen_Scope
: Entity_Id
;
14298 -- The scope of the generic for which references are being saved
14301 -- The current associated node
14303 function Is_Global
(E
: Entity_Id
) return Boolean;
14304 -- Check whether entity is defined outside of generic unit. Examine the
14305 -- scope of an entity, and the scope of the scope, etc, until we find
14306 -- either Standard, in which case the entity is global, or the generic
14307 -- unit itself, which indicates that the entity is local. If the entity
14308 -- is the generic unit itself, as in the case of a recursive call, or
14309 -- the enclosing generic unit, if different from the current scope, then
14310 -- it is local as well, because it will be replaced at the point of
14311 -- instantiation. On the other hand, if it is a reference to a child
14312 -- unit of a common ancestor, which appears in an instantiation, it is
14313 -- global because it is used to denote a specific compilation unit at
14314 -- the time the instantiations will be analyzed.
14316 procedure Qualify_Universal_Operands
14318 Func_Call
: Node_Id
);
14319 -- Op denotes a binary or unary operator in generic template Templ. Node
14320 -- Func_Call is the function call alternative of the operator within the
14321 -- the analyzed copy of the template. Change each operand which yields a
14322 -- universal type by wrapping it into a qualified expression
14324 -- Actual_Typ'(Operand)
14326 -- where Actual_Typ is the type of corresponding actual parameter of
14327 -- Operand in Func_Call.
14329 procedure Reset_Entity
(N
: Node_Id
);
14330 -- Save semantic information on global entity so that it is not resolved
14331 -- again at instantiation time.
14333 procedure Save_Entity_Descendants
(N
: Node_Id
);
14334 -- Apply Save_Global_References to the two syntactic descendants of
14335 -- non-terminal nodes that carry an Associated_Node and are processed
14336 -- through Reset_Entity. Once the global entity (if any) has been
14337 -- captured together with its type, only two syntactic descendants need
14338 -- to be traversed to complete the processing of the tree rooted at N.
14339 -- This applies to Selected_Components, Expanded_Names, and to Operator
14340 -- nodes. N can also be a character literal, identifier, or operator
14341 -- symbol node, but the call has no effect in these cases.
14343 procedure Save_Global_Defaults
(N1
: Node_Id
; N2
: Node_Id
);
14344 -- Default actuals in nested instances must be handled specially
14345 -- because there is no link to them from the original tree. When an
14346 -- actual subprogram is given by a default, we add an explicit generic
14347 -- association for it in the instantiation node. When we save the
14348 -- global references on the name of the instance, we recover the list
14349 -- of generic associations, and add an explicit one to the original
14350 -- generic tree, through which a global actual can be preserved.
14351 -- Similarly, if a child unit is instantiated within a sibling, in the
14352 -- context of the parent, we must preserve the identifier of the parent
14353 -- so that it can be properly resolved in a subsequent instantiation.
14355 procedure Save_Global_Descendant
(D
: Union_Id
);
14356 -- Apply Save_References recursively to the descendants of node D
14358 procedure Save_References
(N
: Node_Id
);
14359 -- This is the recursive procedure that does the work, once the
14360 -- enclosing generic scope has been established.
14366 function Is_Global
(E
: Entity_Id
) return Boolean is
14369 function Is_Instance_Node
(Decl
: Node_Id
) return Boolean;
14370 -- Determine whether the parent node of a reference to a child unit
14371 -- denotes an instantiation or a formal package, in which case the
14372 -- reference to the child unit is global, even if it appears within
14373 -- the current scope (e.g. when the instance appears within the body
14374 -- of an ancestor).
14376 ----------------------
14377 -- Is_Instance_Node --
14378 ----------------------
14380 function Is_Instance_Node
(Decl
: Node_Id
) return Boolean is
14382 return Nkind
(Decl
) in N_Generic_Instantiation
14384 Nkind
(Original_Node
(Decl
)) = N_Formal_Package_Declaration
;
14385 end Is_Instance_Node
;
14387 -- Start of processing for Is_Global
14390 if E
= Gen_Scope
then
14393 elsif E
= Standard_Standard
then
14396 elsif Is_Child_Unit
(E
)
14397 and then (Is_Instance_Node
(Parent
(N2
))
14398 or else (Nkind
(Parent
(N2
)) = N_Expanded_Name
14399 and then N2
= Selector_Name
(Parent
(N2
))
14401 Is_Instance_Node
(Parent
(Parent
(N2
)))))
14407 while Se
/= Gen_Scope
loop
14408 if Se
= Standard_Standard
then
14419 --------------------------------
14420 -- Qualify_Universal_Operands --
14421 --------------------------------
14423 procedure Qualify_Universal_Operands
14425 Func_Call
: Node_Id
)
14427 procedure Qualify_Operand
(Opnd
: Node_Id
; Actual
: Node_Id
);
14428 -- Rewrite operand Opnd as a qualified expression of the form
14430 -- Actual_Typ'(Opnd)
14432 -- where Actual is the corresponding actual parameter of Opnd in
14433 -- function call Func_Call.
14435 function Qualify_Type
14437 Typ
: Entity_Id
) return Node_Id
;
14438 -- Qualify type Typ by creating a selected component of the form
14440 -- Scope_Of_Typ.Typ
14442 ---------------------
14443 -- Qualify_Operand --
14444 ---------------------
14446 procedure Qualify_Operand
(Opnd
: Node_Id
; Actual
: Node_Id
) is
14447 Loc
: constant Source_Ptr
:= Sloc
(Opnd
);
14448 Typ
: constant Entity_Id
:= Etype
(Actual
);
14453 -- Qualify the operand when it is of a universal type. Note that
14454 -- the template is unanalyzed and it is not possible to directly
14455 -- query the type. This transformation is not done when the type
14456 -- of the actual is internally generated because the type will be
14457 -- regenerated in the instance.
14459 if Yields_Universal_Type
(Opnd
)
14460 and then Comes_From_Source
(Typ
)
14461 and then not Is_Hidden
(Typ
)
14463 -- The type of the actual may be a global reference. Save this
14464 -- information by creating a reference to it.
14466 if Is_Global
(Typ
) then
14467 Mark
:= New_Occurrence_Of
(Typ
, Loc
);
14469 -- Otherwise rely on resolution to find the proper type within
14473 Mark
:= Qualify_Type
(Loc
, Typ
);
14477 Make_Qualified_Expression
(Loc
,
14478 Subtype_Mark
=> Mark
,
14479 Expression
=> Relocate_Node
(Opnd
));
14481 -- Mark the qualification to distinguish it from other source
14482 -- constructs and signal the instantiation mechanism that this
14483 -- node requires special processing. See Copy_Generic_Node for
14486 Set_Is_Qualified_Universal_Literal
(Qual
);
14488 Rewrite
(Opnd
, Qual
);
14490 end Qualify_Operand
;
14496 function Qualify_Type
14498 Typ
: Entity_Id
) return Node_Id
14500 Scop
: constant Entity_Id
:= Scope
(Typ
);
14504 Result
:= Make_Identifier
(Loc
, Chars
(Typ
));
14506 if Present
(Scop
) and then not Is_Generic_Unit
(Scop
) then
14508 Make_Selected_Component
(Loc
,
14509 Prefix
=> Make_Identifier
(Loc
, Chars
(Scop
)),
14510 Selector_Name
=> Result
);
14518 Actuals
: constant List_Id
:= Parameter_Associations
(Func_Call
);
14520 -- Start of processing for Qualify_Universal_Operands
14523 if Nkind
(Op
) in N_Binary_Op
then
14524 Qualify_Operand
(Left_Opnd
(Op
), First
(Actuals
));
14525 Qualify_Operand
(Right_Opnd
(Op
), Next
(First
(Actuals
)));
14527 elsif Nkind
(Op
) in N_Unary_Op
then
14528 Qualify_Operand
(Right_Opnd
(Op
), First
(Actuals
));
14530 end Qualify_Universal_Operands
;
14536 procedure Reset_Entity
(N
: Node_Id
) is
14537 procedure Set_Global_Type
(N
: Node_Id
; N2
: Node_Id
);
14538 -- If the type of N2 is global to the generic unit, save the type in
14539 -- the generic node. Just as we perform name capture for explicit
14540 -- references within the generic, we must capture the global types
14541 -- of local entities because they may participate in resolution in
14544 function Top_Ancestor
(E
: Entity_Id
) return Entity_Id
;
14545 -- Find the ultimate ancestor of the current unit. If it is not a
14546 -- generic unit, then the name of the current unit in the prefix of
14547 -- an expanded name must be replaced with its generic homonym to
14548 -- ensure that it will be properly resolved in an instance.
14550 ---------------------
14551 -- Set_Global_Type --
14552 ---------------------
14554 procedure Set_Global_Type
(N
: Node_Id
; N2
: Node_Id
) is
14555 Typ
: constant Entity_Id
:= Etype
(N2
);
14558 Set_Etype
(N
, Typ
);
14560 -- If the entity of N is not the associated node, this is a
14561 -- nested generic and it has an associated node as well, whose
14562 -- type is already the full view (see below). Indicate that the
14563 -- original node has a private view.
14565 if Entity
(N
) /= N2
and then Has_Private_View
(Entity
(N
)) then
14566 Set_Has_Private_View
(N
);
14569 -- If not a private type, nothing else to do
14571 if not Is_Private_Type
(Typ
) then
14572 if Is_Array_Type
(Typ
)
14573 and then Is_Private_Type
(Component_Type
(Typ
))
14575 Set_Has_Private_View
(N
);
14578 -- If it is a derivation of a private type in a context where no
14579 -- full view is needed, nothing to do either.
14581 elsif No
(Full_View
(Typ
)) and then Typ
/= Etype
(Typ
) then
14584 -- Otherwise mark the type for flipping and use the full view when
14588 Set_Has_Private_View
(N
);
14590 if Present
(Full_View
(Typ
)) then
14591 Set_Etype
(N2
, Full_View
(Typ
));
14595 if Is_Floating_Point_Type
(Typ
)
14596 and then Has_Dimension_System
(Typ
)
14598 Copy_Dimensions
(N2
, N
);
14600 end Set_Global_Type
;
14606 function Top_Ancestor
(E
: Entity_Id
) return Entity_Id
is
14611 while Is_Child_Unit
(Par
) loop
14612 Par
:= Scope
(Par
);
14618 -- Start of processing for Reset_Entity
14621 N2
:= Get_Associated_Node
(N
);
14624 if Present
(E
) then
14626 -- If the node is an entry call to an entry in an enclosing task,
14627 -- it is rewritten as a selected component. No global entity to
14628 -- preserve in this case, since the expansion will be redone in
14631 if not Nkind_In
(E
, N_Defining_Character_Literal
,
14632 N_Defining_Identifier
,
14633 N_Defining_Operator_Symbol
)
14635 Set_Associated_Node
(N
, Empty
);
14636 Set_Etype
(N
, Empty
);
14640 -- If the entity is an itype created as a subtype of an access
14641 -- type with a null exclusion restore source entity for proper
14642 -- visibility. The itype will be created anew in the instance.
14645 and then Ekind
(E
) = E_Access_Subtype
14646 and then Is_Entity_Name
(N
)
14647 and then Chars
(Etype
(E
)) = Chars
(N
)
14650 Set_Entity
(N2
, E
);
14654 if Is_Global
(E
) then
14656 -- If the entity is a package renaming that is the prefix of
14657 -- an expanded name, it has been rewritten as the renamed
14658 -- package, which is necessary semantically but complicates
14659 -- ASIS tree traversal, so we recover the original entity to
14660 -- expose the renaming. Take into account that the context may
14661 -- be a nested generic, that the original node may itself have
14662 -- an associated node that had better be an entity, and that
14663 -- the current node is still a selected component.
14665 if Ekind
(E
) = E_Package
14666 and then Nkind
(N
) = N_Selected_Component
14667 and then Nkind
(Parent
(N
)) = N_Expanded_Name
14668 and then Present
(Original_Node
(N2
))
14669 and then Is_Entity_Name
(Original_Node
(N2
))
14670 and then Present
(Entity
(Original_Node
(N2
)))
14672 if Is_Global
(Entity
(Original_Node
(N2
))) then
14673 N2
:= Original_Node
(N2
);
14674 Set_Associated_Node
(N
, N2
);
14675 Set_Global_Type
(N
, N2
);
14677 -- Renaming is local, and will be resolved in instance
14680 Set_Associated_Node
(N
, Empty
);
14681 Set_Etype
(N
, Empty
);
14685 Set_Global_Type
(N
, N2
);
14688 elsif Nkind
(N
) = N_Op_Concat
14689 and then Is_Generic_Type
(Etype
(N2
))
14690 and then (Base_Type
(Etype
(Right_Opnd
(N2
))) = Etype
(N2
)
14692 Base_Type
(Etype
(Left_Opnd
(N2
))) = Etype
(N2
))
14693 and then Is_Intrinsic_Subprogram
(E
)
14697 -- Entity is local. Mark generic node as unresolved. Note that now
14698 -- it does not have an entity.
14701 Set_Associated_Node
(N
, Empty
);
14702 Set_Etype
(N
, Empty
);
14705 if Nkind
(Parent
(N
)) in N_Generic_Instantiation
14706 and then N
= Name
(Parent
(N
))
14708 Save_Global_Defaults
(Parent
(N
), Parent
(N2
));
14711 elsif Nkind
(Parent
(N
)) = N_Selected_Component
14712 and then Nkind
(Parent
(N2
)) = N_Expanded_Name
14714 if Is_Global
(Entity
(Parent
(N2
))) then
14715 Change_Selected_Component_To_Expanded_Name
(Parent
(N
));
14716 Set_Associated_Node
(Parent
(N
), Parent
(N2
));
14717 Set_Global_Type
(Parent
(N
), Parent
(N2
));
14718 Save_Entity_Descendants
(N
);
14720 -- If this is a reference to the current generic entity, replace
14721 -- by the name of the generic homonym of the current package. This
14722 -- is because in an instantiation Par.P.Q will not resolve to the
14723 -- name of the instance, whose enclosing scope is not necessarily
14724 -- Par. We use the generic homonym rather that the name of the
14725 -- generic itself because it may be hidden by a local declaration.
14727 elsif In_Open_Scopes
(Entity
(Parent
(N2
)))
14729 Is_Generic_Unit
(Top_Ancestor
(Entity
(Prefix
(Parent
(N2
)))))
14731 if Ekind
(Entity
(Parent
(N2
))) = E_Generic_Package
then
14732 Rewrite
(Parent
(N
),
14733 Make_Identifier
(Sloc
(N
),
14735 Chars
(Generic_Homonym
(Entity
(Parent
(N2
))))));
14737 Rewrite
(Parent
(N
),
14738 Make_Identifier
(Sloc
(N
),
14739 Chars
=> Chars
(Selector_Name
(Parent
(N2
)))));
14743 if Nkind
(Parent
(Parent
(N
))) in N_Generic_Instantiation
14744 and then Parent
(N
) = Name
(Parent
(Parent
(N
)))
14746 Save_Global_Defaults
14747 (Parent
(Parent
(N
)), Parent
(Parent
(N2
)));
14750 -- A selected component may denote a static constant that has been
14751 -- folded. If the static constant is global to the generic, capture
14752 -- its value. Otherwise the folding will happen in any instantiation.
14754 elsif Nkind
(Parent
(N
)) = N_Selected_Component
14755 and then Nkind_In
(Parent
(N2
), N_Integer_Literal
, N_Real_Literal
)
14757 if Present
(Entity
(Original_Node
(Parent
(N2
))))
14758 and then Is_Global
(Entity
(Original_Node
(Parent
(N2
))))
14760 Rewrite
(Parent
(N
), New_Copy
(Parent
(N2
)));
14761 Set_Analyzed
(Parent
(N
), False);
14764 -- A selected component may be transformed into a parameterless
14765 -- function call. If the called entity is global, rewrite the node
14766 -- appropriately, i.e. as an extended name for the global entity.
14768 elsif Nkind
(Parent
(N
)) = N_Selected_Component
14769 and then Nkind
(Parent
(N2
)) = N_Function_Call
14770 and then N
= Selector_Name
(Parent
(N
))
14772 if No
(Parameter_Associations
(Parent
(N2
))) then
14773 if Is_Global
(Entity
(Name
(Parent
(N2
)))) then
14774 Change_Selected_Component_To_Expanded_Name
(Parent
(N
));
14775 Set_Associated_Node
(Parent
(N
), Name
(Parent
(N2
)));
14776 Set_Global_Type
(Parent
(N
), Name
(Parent
(N2
)));
14777 Save_Entity_Descendants
(N
);
14780 Set_Is_Prefixed_Call
(Parent
(N
));
14781 Set_Associated_Node
(N
, Empty
);
14782 Set_Etype
(N
, Empty
);
14785 -- In Ada 2005, X.F may be a call to a primitive operation,
14786 -- rewritten as F (X). This rewriting will be done again in an
14787 -- instance, so keep the original node. Global entities will be
14788 -- captured as for other constructs. Indicate that this must
14789 -- resolve as a call, to prevent accidental overloading in the
14790 -- instance, if both a component and a primitive operation appear
14794 Set_Is_Prefixed_Call
(Parent
(N
));
14797 -- Entity is local. Reset in generic unit, so that node is resolved
14798 -- anew at the point of instantiation.
14801 Set_Associated_Node
(N
, Empty
);
14802 Set_Etype
(N
, Empty
);
14806 -----------------------------
14807 -- Save_Entity_Descendants --
14808 -----------------------------
14810 procedure Save_Entity_Descendants
(N
: Node_Id
) is
14813 when N_Binary_Op
=>
14814 Save_Global_Descendant
(Union_Id
(Left_Opnd
(N
)));
14815 Save_Global_Descendant
(Union_Id
(Right_Opnd
(N
)));
14818 Save_Global_Descendant
(Union_Id
(Right_Opnd
(N
)));
14820 when N_Expanded_Name
14821 | N_Selected_Component
14823 Save_Global_Descendant
(Union_Id
(Prefix
(N
)));
14824 Save_Global_Descendant
(Union_Id
(Selector_Name
(N
)));
14826 when N_Character_Literal
14828 | N_Operator_Symbol
14833 raise Program_Error
;
14835 end Save_Entity_Descendants
;
14837 --------------------------
14838 -- Save_Global_Defaults --
14839 --------------------------
14841 procedure Save_Global_Defaults
(N1
: Node_Id
; N2
: Node_Id
) is
14842 Loc
: constant Source_Ptr
:= Sloc
(N1
);
14843 Assoc2
: constant List_Id
:= Generic_Associations
(N2
);
14844 Gen_Id
: constant Entity_Id
:= Get_Generic_Entity
(N2
);
14851 Actual
: Entity_Id
;
14854 Assoc1
:= Generic_Associations
(N1
);
14856 if Present
(Assoc1
) then
14857 Act1
:= First
(Assoc1
);
14860 Set_Generic_Associations
(N1
, New_List
);
14861 Assoc1
:= Generic_Associations
(N1
);
14864 if Present
(Assoc2
) then
14865 Act2
:= First
(Assoc2
);
14870 while Present
(Act1
) and then Present
(Act2
) loop
14875 -- Find the associations added for default subprograms
14877 if Present
(Act2
) then
14878 while Nkind
(Act2
) /= N_Generic_Association
14879 or else No
(Entity
(Selector_Name
(Act2
)))
14880 or else not Is_Overloadable
(Entity
(Selector_Name
(Act2
)))
14885 -- Add a similar association if the default is global. The
14886 -- renaming declaration for the actual has been analyzed, and
14887 -- its alias is the program it renames. Link the actual in the
14888 -- original generic tree with the node in the analyzed tree.
14890 while Present
(Act2
) loop
14891 Subp
:= Entity
(Selector_Name
(Act2
));
14892 Def
:= Explicit_Generic_Actual_Parameter
(Act2
);
14894 -- Following test is defence against rubbish errors
14896 if No
(Alias
(Subp
)) then
14900 -- Retrieve the resolved actual from the renaming declaration
14901 -- created for the instantiated formal.
14903 Actual
:= Entity
(Name
(Parent
(Parent
(Subp
))));
14904 Set_Entity
(Def
, Actual
);
14905 Set_Etype
(Def
, Etype
(Actual
));
14907 if Is_Global
(Actual
) then
14909 Make_Generic_Association
(Loc
,
14911 New_Occurrence_Of
(Subp
, Loc
),
14912 Explicit_Generic_Actual_Parameter
=>
14913 New_Occurrence_Of
(Actual
, Loc
));
14915 Set_Associated_Node
14916 (Explicit_Generic_Actual_Parameter
(Ndec
), Def
);
14918 Append
(Ndec
, Assoc1
);
14920 -- If there are other defaults, add a dummy association in case
14921 -- there are other defaulted formals with the same name.
14923 elsif Present
(Next
(Act2
)) then
14925 Make_Generic_Association
(Loc
,
14927 New_Occurrence_Of
(Subp
, Loc
),
14928 Explicit_Generic_Actual_Parameter
=> Empty
);
14930 Append
(Ndec
, Assoc1
);
14937 if Nkind
(Name
(N1
)) = N_Identifier
14938 and then Is_Child_Unit
(Gen_Id
)
14939 and then Is_Global
(Gen_Id
)
14940 and then Is_Generic_Unit
(Scope
(Gen_Id
))
14941 and then In_Open_Scopes
(Scope
(Gen_Id
))
14943 -- This is an instantiation of a child unit within a sibling, so
14944 -- that the generic parent is in scope. An eventual instance must
14945 -- occur within the scope of an instance of the parent. Make name
14946 -- in instance into an expanded name, to preserve the identifier
14947 -- of the parent, so it can be resolved subsequently.
14949 Rewrite
(Name
(N2
),
14950 Make_Expanded_Name
(Loc
,
14951 Chars
=> Chars
(Gen_Id
),
14952 Prefix
=> New_Occurrence_Of
(Scope
(Gen_Id
), Loc
),
14953 Selector_Name
=> New_Occurrence_Of
(Gen_Id
, Loc
)));
14954 Set_Entity
(Name
(N2
), Gen_Id
);
14956 Rewrite
(Name
(N1
),
14957 Make_Expanded_Name
(Loc
,
14958 Chars
=> Chars
(Gen_Id
),
14959 Prefix
=> New_Occurrence_Of
(Scope
(Gen_Id
), Loc
),
14960 Selector_Name
=> New_Occurrence_Of
(Gen_Id
, Loc
)));
14962 Set_Associated_Node
(Name
(N1
), Name
(N2
));
14963 Set_Associated_Node
(Prefix
(Name
(N1
)), Empty
);
14964 Set_Associated_Node
14965 (Selector_Name
(Name
(N1
)), Selector_Name
(Name
(N2
)));
14966 Set_Etype
(Name
(N1
), Etype
(Gen_Id
));
14968 end Save_Global_Defaults
;
14970 ----------------------------
14971 -- Save_Global_Descendant --
14972 ----------------------------
14974 procedure Save_Global_Descendant
(D
: Union_Id
) is
14978 if D
in Node_Range
then
14979 if D
= Union_Id
(Empty
) then
14982 elsif Nkind
(Node_Id
(D
)) /= N_Compilation_Unit
then
14983 Save_References
(Node_Id
(D
));
14986 elsif D
in List_Range
then
14987 pragma Assert
(D
/= Union_Id
(No_List
));
14988 -- Because No_List = Empty, which is in Node_Range above
14990 if Is_Empty_List
(List_Id
(D
)) then
14994 N1
:= First
(List_Id
(D
));
14995 while Present
(N1
) loop
14996 Save_References
(N1
);
15001 -- Element list or other non-node field, nothing to do
15006 end Save_Global_Descendant
;
15008 ---------------------
15009 -- Save_References --
15010 ---------------------
15012 -- This is the recursive procedure that does the work once the enclosing
15013 -- generic scope has been established. We have to treat specially a
15014 -- number of node rewritings that are required by semantic processing
15015 -- and which change the kind of nodes in the generic copy: typically
15016 -- constant-folding, replacing an operator node by a string literal, or
15017 -- a selected component by an expanded name. In each of those cases, the
15018 -- transformation is propagated to the generic unit.
15020 procedure Save_References
(N
: Node_Id
) is
15021 Loc
: constant Source_Ptr
:= Sloc
(N
);
15023 function Requires_Delayed_Save
(Nod
: Node_Id
) return Boolean;
15024 -- Determine whether arbitrary node Nod requires delayed capture of
15025 -- global references within its aspect specifications.
15027 procedure Save_References_In_Aggregate
(N
: Node_Id
);
15028 -- Save all global references in [extension] aggregate node N
15030 procedure Save_References_In_Char_Lit_Or_Op_Symbol
(N
: Node_Id
);
15031 -- Save all global references in a character literal or operator
15032 -- symbol denoted by N.
15034 procedure Save_References_In_Descendants
(N
: Node_Id
);
15035 -- Save all global references in all descendants of node N
15037 procedure Save_References_In_Identifier
(N
: Node_Id
);
15038 -- Save all global references in identifier node N
15040 procedure Save_References_In_Operator
(N
: Node_Id
);
15041 -- Save all global references in operator node N
15043 procedure Save_References_In_Pragma
(Prag
: Node_Id
);
15044 -- Save all global references found within the expression of pragma
15047 ---------------------------
15048 -- Requires_Delayed_Save --
15049 ---------------------------
15051 function Requires_Delayed_Save
(Nod
: Node_Id
) return Boolean is
15053 -- Generic packages and subprograms require delayed capture of
15054 -- global references within their aspects due to the timing of
15055 -- annotation analysis.
15057 if Nkind_In
(Nod
, N_Generic_Package_Declaration
,
15058 N_Generic_Subprogram_Declaration
,
15060 N_Package_Body_Stub
,
15062 N_Subprogram_Body_Stub
)
15064 -- Since the capture of global references is done on the
15065 -- unanalyzed generic template, there is no information around
15066 -- to infer the context. Use the Associated_Entity linkages to
15067 -- peek into the analyzed generic copy and determine what the
15068 -- template corresponds to.
15070 if Nod
= Templ
then
15072 Is_Generic_Declaration_Or_Body
15073 (Unit_Declaration_Node
15074 (Associated_Entity
(Defining_Entity
(Nod
))));
15076 -- Otherwise the generic unit being processed is not the top
15077 -- level template. It is safe to capture of global references
15078 -- within the generic unit because at this point the top level
15079 -- copy is fully analyzed.
15085 -- Otherwise capture the global references without interference
15090 end Requires_Delayed_Save
;
15092 ----------------------------------
15093 -- Save_References_In_Aggregate --
15094 ----------------------------------
15096 procedure Save_References_In_Aggregate
(N
: Node_Id
) is
15098 Qual
: Node_Id
:= Empty
;
15099 Typ
: Entity_Id
:= Empty
;
15101 use Atree
.Unchecked_Access
;
15102 -- This code section is part of implementing an untyped tree
15103 -- traversal, so it needs direct access to node fields.
15106 N2
:= Get_Associated_Node
(N
);
15108 if Present
(N2
) then
15111 -- In an instance within a generic, use the name of the actual
15112 -- and not the original generic parameter. If the actual is
15113 -- global in the current generic it must be preserved for its
15116 if Nkind
(Parent
(Typ
)) = N_Subtype_Declaration
15117 and then Present
(Generic_Parent_Type
(Parent
(Typ
)))
15119 Typ
:= Base_Type
(Typ
);
15120 Set_Etype
(N2
, Typ
);
15124 if No
(N2
) or else No
(Typ
) or else not Is_Global
(Typ
) then
15125 Set_Associated_Node
(N
, Empty
);
15127 -- If the aggregate is an actual in a call, it has been
15128 -- resolved in the current context, to some local type. The
15129 -- enclosing call may have been disambiguated by the aggregate,
15130 -- and this disambiguation might fail at instantiation time
15131 -- because the type to which the aggregate did resolve is not
15132 -- preserved. In order to preserve some of this information,
15133 -- wrap the aggregate in a qualified expression, using the id
15134 -- of its type. For further disambiguation we qualify the type
15135 -- name with its scope (if visible and not hidden by a local
15136 -- homograph) because both id's will have corresponding
15137 -- entities in an instance. This resolves most of the problems
15138 -- with missing type information on aggregates in instances.
15141 and then Nkind
(N2
) = Nkind
(N
)
15142 and then Nkind
(Parent
(N2
)) in N_Subprogram_Call
15143 and then Present
(Typ
)
15144 and then Comes_From_Source
(Typ
)
15146 Nam
:= Make_Identifier
(Loc
, Chars
(Typ
));
15148 if Is_Immediately_Visible
(Scope
(Typ
))
15150 (not In_Open_Scopes
(Scope
(Typ
))
15151 or else Current_Entity
(Scope
(Typ
)) = Scope
(Typ
))
15154 Make_Selected_Component
(Loc
,
15156 Make_Identifier
(Loc
, Chars
(Scope
(Typ
))),
15157 Selector_Name
=> Nam
);
15161 Make_Qualified_Expression
(Loc
,
15162 Subtype_Mark
=> Nam
,
15163 Expression
=> Relocate_Node
(N
));
15167 Save_Global_Descendant
(Field1
(N
));
15168 Save_Global_Descendant
(Field2
(N
));
15169 Save_Global_Descendant
(Field3
(N
));
15170 Save_Global_Descendant
(Field5
(N
));
15172 if Present
(Qual
) then
15175 end Save_References_In_Aggregate
;
15177 ----------------------------------------------
15178 -- Save_References_In_Char_Lit_Or_Op_Symbol --
15179 ----------------------------------------------
15181 procedure Save_References_In_Char_Lit_Or_Op_Symbol
(N
: Node_Id
) is
15183 if Nkind
(N
) = Nkind
(Get_Associated_Node
(N
)) then
15186 elsif Nkind
(N
) = N_Operator_Symbol
15187 and then Nkind
(Get_Associated_Node
(N
)) = N_String_Literal
15189 Change_Operator_Symbol_To_String_Literal
(N
);
15191 end Save_References_In_Char_Lit_Or_Op_Symbol
;
15193 ------------------------------------
15194 -- Save_References_In_Descendants --
15195 ------------------------------------
15197 procedure Save_References_In_Descendants
(N
: Node_Id
) is
15198 use Atree
.Unchecked_Access
;
15199 -- This code section is part of implementing an untyped tree
15200 -- traversal, so it needs direct access to node fields.
15203 Save_Global_Descendant
(Field1
(N
));
15204 Save_Global_Descendant
(Field2
(N
));
15205 Save_Global_Descendant
(Field3
(N
));
15206 Save_Global_Descendant
(Field4
(N
));
15207 Save_Global_Descendant
(Field5
(N
));
15208 end Save_References_In_Descendants
;
15210 -----------------------------------
15211 -- Save_References_In_Identifier --
15212 -----------------------------------
15214 procedure Save_References_In_Identifier
(N
: Node_Id
) is
15216 -- The node did not undergo a transformation
15218 if Nkind
(N
) = Nkind
(Get_Associated_Node
(N
)) then
15220 Aux_N2
: constant Node_Id
:= Get_Associated_Node
(N
);
15221 Orig_N2_Parent
: constant Node_Id
:=
15222 Original_Node
(Parent
(Aux_N2
));
15224 -- The parent of this identifier is a selected component
15225 -- which denotes a named number that was constant folded.
15226 -- Preserve the original name for ASIS and link the parent
15227 -- with its expanded name. The constant folding will be
15228 -- repeated in the instance.
15230 if Nkind
(Parent
(N
)) = N_Selected_Component
15231 and then Nkind_In
(Parent
(Aux_N2
), N_Integer_Literal
,
15233 and then Is_Entity_Name
(Orig_N2_Parent
)
15234 and then Ekind
(Entity
(Orig_N2_Parent
)) in Named_Kind
15235 and then Is_Global
(Entity
(Orig_N2_Parent
))
15238 Set_Associated_Node
15239 (Parent
(N
), Original_Node
(Parent
(N2
)));
15244 -- If this is a discriminant reference, always save it.
15245 -- It is used in the instance to find the corresponding
15246 -- discriminant positionally rather than by name.
15248 Set_Original_Discriminant
15249 (N
, Original_Discriminant
(Get_Associated_Node
(N
)));
15255 -- The analysis of the generic copy transformed the identifier
15256 -- into another construct. Propagate the changes to the template.
15259 N2
:= Get_Associated_Node
(N
);
15261 -- The identifier denotes a call to a parameterless function.
15262 -- Mark the node as resolved when the function is external.
15264 if Nkind
(N2
) = N_Function_Call
then
15265 E
:= Entity
(Name
(N2
));
15267 if Present
(E
) and then Is_Global
(E
) then
15268 Set_Etype
(N
, Etype
(N2
));
15270 Set_Associated_Node
(N
, Empty
);
15271 Set_Etype
(N
, Empty
);
15274 -- The identifier denotes a named number that was constant
15275 -- folded. Preserve the original name for ASIS and undo the
15276 -- constant folding which will be repeated in the instance.
15278 elsif Nkind_In
(N2
, N_Integer_Literal
, N_Real_Literal
)
15279 and then Is_Entity_Name
(Original_Node
(N2
))
15281 Set_Associated_Node
(N
, Original_Node
(N2
));
15284 -- The identifier resolved to a string literal. Propagate this
15285 -- information to the generic template.
15287 elsif Nkind
(N2
) = N_String_Literal
then
15288 Rewrite
(N
, New_Copy
(N2
));
15290 -- The identifier is rewritten as a dereference if it is the
15291 -- prefix of an implicit dereference. Preserve the original
15292 -- tree as the analysis of the instance will expand the node
15293 -- again, but preserve the resolved entity if it is global.
15295 elsif Nkind
(N2
) = N_Explicit_Dereference
then
15296 if Is_Entity_Name
(Prefix
(N2
))
15297 and then Present
(Entity
(Prefix
(N2
)))
15298 and then Is_Global
(Entity
(Prefix
(N2
)))
15300 Set_Associated_Node
(N
, Prefix
(N2
));
15302 elsif Nkind
(Prefix
(N2
)) = N_Function_Call
15303 and then Present
(Entity
(Name
(Prefix
(N2
))))
15304 and then Is_Global
(Entity
(Name
(Prefix
(N2
))))
15307 Make_Explicit_Dereference
(Loc
,
15309 Make_Function_Call
(Loc
,
15312 (Entity
(Name
(Prefix
(N2
))), Loc
))));
15315 Set_Associated_Node
(N
, Empty
);
15316 Set_Etype
(N
, Empty
);
15319 -- The subtype mark of a nominally unconstrained object is
15320 -- rewritten as a subtype indication using the bounds of the
15321 -- expression. Recover the original subtype mark.
15323 elsif Nkind
(N2
) = N_Subtype_Indication
15324 and then Is_Entity_Name
(Original_Node
(N2
))
15326 Set_Associated_Node
(N
, Original_Node
(N2
));
15330 end Save_References_In_Identifier
;
15332 ---------------------------------
15333 -- Save_References_In_Operator --
15334 ---------------------------------
15336 procedure Save_References_In_Operator
(N
: Node_Id
) is
15338 -- The node did not undergo a transformation
15340 if Nkind
(N
) = Nkind
(Get_Associated_Node
(N
)) then
15341 if Nkind
(N
) = N_Op_Concat
then
15342 Set_Is_Component_Left_Opnd
(N
,
15343 Is_Component_Left_Opnd
(Get_Associated_Node
(N
)));
15345 Set_Is_Component_Right_Opnd
(N
,
15346 Is_Component_Right_Opnd
(Get_Associated_Node
(N
)));
15351 -- The analysis of the generic copy transformed the operator into
15352 -- some other construct. Propagate the changes to the template if
15356 N2
:= Get_Associated_Node
(N
);
15358 -- The operator resoved to a function call
15360 if Nkind
(N2
) = N_Function_Call
then
15362 -- Add explicit qualifications in the generic template for
15363 -- all operands of universal type. This aids resolution by
15364 -- preserving the actual type of a literal or an attribute
15365 -- that yields a universal result.
15367 Qualify_Universal_Operands
(N
, N2
);
15369 E
:= Entity
(Name
(N2
));
15371 if Present
(E
) and then Is_Global
(E
) then
15372 Set_Etype
(N
, Etype
(N2
));
15374 Set_Associated_Node
(N
, Empty
);
15375 Set_Etype
(N
, Empty
);
15378 -- The operator was folded into a literal
15380 elsif Nkind_In
(N2
, N_Integer_Literal
,
15384 if Present
(Original_Node
(N2
))
15385 and then Nkind
(Original_Node
(N2
)) = Nkind
(N
)
15387 -- Operation was constant-folded. Whenever possible,
15388 -- recover semantic information from unfolded node,
15391 Set_Associated_Node
(N
, Original_Node
(N2
));
15393 if Nkind
(N
) = N_Op_Concat
then
15394 Set_Is_Component_Left_Opnd
(N
,
15395 Is_Component_Left_Opnd
(Get_Associated_Node
(N
)));
15396 Set_Is_Component_Right_Opnd
(N
,
15397 Is_Component_Right_Opnd
(Get_Associated_Node
(N
)));
15402 -- Propagate the constant folding back to the template
15405 Rewrite
(N
, New_Copy
(N2
));
15406 Set_Analyzed
(N
, False);
15409 -- The operator was folded into an enumeration literal. Retain
15410 -- the entity to avoid spurious ambiguities if it is overloaded
15411 -- at the point of instantiation or inlining.
15413 elsif Nkind
(N2
) = N_Identifier
15414 and then Ekind
(Entity
(N2
)) = E_Enumeration_Literal
15416 Rewrite
(N
, New_Copy
(N2
));
15417 Set_Analyzed
(N
, False);
15421 -- Complete the operands check if node has not been constant
15424 if Nkind
(N
) in N_Op
then
15425 Save_Entity_Descendants
(N
);
15427 end Save_References_In_Operator
;
15429 -------------------------------
15430 -- Save_References_In_Pragma --
15431 -------------------------------
15433 procedure Save_References_In_Pragma
(Prag
: Node_Id
) is
15435 Do_Save
: Boolean := True;
15437 use Atree
.Unchecked_Access
;
15438 -- This code section is part of implementing an untyped tree
15439 -- traversal, so it needs direct access to node fields.
15442 -- Do not save global references in pragmas generated from aspects
15443 -- because the pragmas will be regenerated at instantiation time.
15445 if From_Aspect_Specification
(Prag
) then
15448 -- The capture of global references within contract-related source
15449 -- pragmas associated with generic packages, subprograms or their
15450 -- respective bodies must be delayed due to timing of annotation
15451 -- analysis. Global references are still captured in routine
15452 -- Save_Global_References_In_Contract.
15454 elsif Is_Generic_Contract_Pragma
(Prag
) and then Prag
/= Templ
then
15455 if Is_Package_Contract_Annotation
(Prag
) then
15456 Context
:= Find_Related_Package_Or_Body
(Prag
);
15458 pragma Assert
(Is_Subprogram_Contract_Annotation
(Prag
));
15459 Context
:= Find_Related_Declaration_Or_Body
(Prag
);
15462 -- The use of Original_Node accounts for the case when the
15463 -- related context is generic template.
15465 if Requires_Delayed_Save
(Original_Node
(Context
)) then
15470 -- For all other cases, save all global references within the
15471 -- descendants, but skip the following semantic fields:
15473 -- Field1 - Next_Pragma
15474 -- Field3 - Corresponding_Aspect
15475 -- Field5 - Next_Rep_Item
15478 Save_Global_Descendant
(Field2
(Prag
));
15479 Save_Global_Descendant
(Field4
(Prag
));
15481 end Save_References_In_Pragma
;
15483 -- Start of processing for Save_References
15491 elsif Nkind_In
(N
, N_Aggregate
, N_Extension_Aggregate
) then
15492 Save_References_In_Aggregate
(N
);
15494 -- Character literals, operator symbols
15496 elsif Nkind_In
(N
, N_Character_Literal
, N_Operator_Symbol
) then
15497 Save_References_In_Char_Lit_Or_Op_Symbol
(N
);
15499 -- Defining identifiers
15501 elsif Nkind
(N
) in N_Entity
then
15506 elsif Nkind
(N
) = N_Identifier
then
15507 Save_References_In_Identifier
(N
);
15511 elsif Nkind
(N
) in N_Op
then
15512 Save_References_In_Operator
(N
);
15516 elsif Nkind
(N
) = N_Pragma
then
15517 Save_References_In_Pragma
(N
);
15520 Save_References_In_Descendants
(N
);
15523 -- Save all global references found within the aspect specifications
15524 -- of the related node.
15526 if Permits_Aspect_Specifications
(N
) and then Has_Aspects
(N
) then
15528 -- The capture of global references within aspects associated with
15529 -- generic packages, subprograms or their bodies must be delayed
15530 -- due to timing of annotation analysis. Global references are
15531 -- still captured in routine Save_Global_References_In_Contract.
15533 if Requires_Delayed_Save
(N
) then
15536 -- Otherwise save all global references within the aspects
15539 Save_Global_References_In_Aspects
(N
);
15542 end Save_References
;
15544 -- Start of processing for Save_Global_References
15547 Gen_Scope
:= Current_Scope
;
15549 -- If the generic unit is a child unit, references to entities in the
15550 -- parent are treated as local, because they will be resolved anew in
15551 -- the context of the instance of the parent.
15553 while Is_Child_Unit
(Gen_Scope
)
15554 and then Ekind
(Scope
(Gen_Scope
)) = E_Generic_Package
15556 Gen_Scope
:= Scope
(Gen_Scope
);
15559 Save_References
(Templ
);
15560 end Save_Global_References
;
15562 ---------------------------------------
15563 -- Save_Global_References_In_Aspects --
15564 ---------------------------------------
15566 procedure Save_Global_References_In_Aspects
(N
: Node_Id
) is
15571 Asp
:= First
(Aspect_Specifications
(N
));
15572 while Present
(Asp
) loop
15573 Expr
:= Expression
(Asp
);
15575 if Present
(Expr
) then
15576 Save_Global_References
(Expr
);
15581 end Save_Global_References_In_Aspects
;
15583 ------------------------------------------
15584 -- Set_Copied_Sloc_For_Inherited_Pragma --
15585 ------------------------------------------
15587 procedure Set_Copied_Sloc_For_Inherited_Pragma
15592 Create_Instantiation_Source
(N
, E
,
15593 Inlined_Body
=> False,
15594 Inherited_Pragma
=> True,
15595 Factor
=> S_Adjustment
);
15596 end Set_Copied_Sloc_For_Inherited_Pragma
;
15598 --------------------------------------
15599 -- Set_Copied_Sloc_For_Inlined_Body --
15600 --------------------------------------
15602 procedure Set_Copied_Sloc_For_Inlined_Body
(N
: Node_Id
; E
: Entity_Id
) is
15604 Create_Instantiation_Source
(N
, E
,
15605 Inlined_Body
=> True,
15606 Inherited_Pragma
=> False,
15607 Factor
=> S_Adjustment
);
15608 end Set_Copied_Sloc_For_Inlined_Body
;
15610 ---------------------
15611 -- Set_Instance_Of --
15612 ---------------------
15614 procedure Set_Instance_Of
(A
: Entity_Id
; B
: Entity_Id
) is
15616 Generic_Renamings
.Table
(Generic_Renamings
.Last
) := (A
, B
, Assoc_Null
);
15617 Generic_Renamings_HTable
.Set
(Generic_Renamings
.Last
);
15618 Generic_Renamings
.Increment_Last
;
15619 end Set_Instance_Of
;
15621 --------------------
15622 -- Set_Next_Assoc --
15623 --------------------
15625 procedure Set_Next_Assoc
(E
: Assoc_Ptr
; Next
: Assoc_Ptr
) is
15627 Generic_Renamings
.Table
(E
).Next_In_HTable
:= Next
;
15628 end Set_Next_Assoc
;
15630 -------------------
15631 -- Start_Generic --
15632 -------------------
15634 procedure Start_Generic
is
15636 -- ??? More things could be factored out in this routine.
15637 -- Should probably be done at a later stage.
15639 Generic_Flags
.Append
(Inside_A_Generic
);
15640 Inside_A_Generic
:= True;
15642 Expander_Mode_Save_And_Set
(False);
15645 ----------------------
15646 -- Set_Instance_Env --
15647 ----------------------
15649 -- WARNING: This routine manages SPARK regions
15651 procedure Set_Instance_Env
15652 (Gen_Unit
: Entity_Id
;
15653 Act_Unit
: Entity_Id
)
15655 Saved_AE
: constant Boolean := Assertions_Enabled
;
15656 Saved_SM
: constant SPARK_Mode_Type
:= SPARK_Mode
;
15657 Saved_SMP
: constant Node_Id
:= SPARK_Mode_Pragma
;
15658 -- Save the SPARK mode-related data because utilizing the configuration
15659 -- values of pragmas and switches will eliminate any previously set
15663 -- Regardless of the current mode, predefined units are analyzed in the
15664 -- most current Ada mode, and earlier version Ada checks do not apply
15665 -- to predefined units. Nothing needs to be done for non-internal units.
15666 -- These are always analyzed in the current mode.
15668 if In_Internal_Unit
(Gen_Unit
) then
15669 Set_Opt_Config_Switches
(True, Current_Sem_Unit
= Main_Unit
);
15671 -- In Ada2012 we may want to enable assertions in an instance of a
15672 -- predefined unit, in which case we need to preserve the current
15673 -- setting for the Assertions_Enabled flag. This will become more
15674 -- critical when pre/postconditions are added to predefined units,
15675 -- as is already the case for some numeric libraries.
15677 if Ada_Version
>= Ada_2012
then
15678 Assertions_Enabled
:= Saved_AE
;
15681 -- Reinstall the SPARK_Mode which was in effect at the point of
15684 Install_SPARK_Mode
(Saved_SM
, Saved_SMP
);
15687 Current_Instantiated_Parent
:=
15688 (Gen_Id
=> Gen_Unit
,
15689 Act_Id
=> Act_Unit
,
15690 Next_In_HTable
=> Assoc_Null
);
15691 end Set_Instance_Env
;
15697 procedure Switch_View
(T
: Entity_Id
) is
15698 BT
: constant Entity_Id
:= Base_Type
(T
);
15699 Priv_Elmt
: Elmt_Id
:= No_Elmt
;
15700 Priv_Sub
: Entity_Id
;
15703 -- T may be private but its base type may have been exchanged through
15704 -- some other occurrence, in which case there is nothing to switch
15705 -- besides T itself. Note that a private dependent subtype of a private
15706 -- type might not have been switched even if the base type has been,
15707 -- because of the last branch of Check_Private_View (see comment there).
15709 if not Is_Private_Type
(BT
) then
15710 Prepend_Elmt
(Full_View
(T
), Exchanged_Views
);
15711 Exchange_Declarations
(T
);
15715 Priv_Elmt
:= First_Elmt
(Private_Dependents
(BT
));
15717 if Present
(Full_View
(BT
)) then
15718 Prepend_Elmt
(Full_View
(BT
), Exchanged_Views
);
15719 Exchange_Declarations
(BT
);
15722 while Present
(Priv_Elmt
) loop
15723 Priv_Sub
:= (Node
(Priv_Elmt
));
15725 -- We avoid flipping the subtype if the Etype of its full view is
15726 -- private because this would result in a malformed subtype. This
15727 -- occurs when the Etype of the subtype full view is the full view of
15728 -- the base type (and since the base types were just switched, the
15729 -- subtype is pointing to the wrong view). This is currently the case
15730 -- for tagged record types, access types (maybe more?) and needs to
15731 -- be resolved. ???
15733 if Present
(Full_View
(Priv_Sub
))
15734 and then not Is_Private_Type
(Etype
(Full_View
(Priv_Sub
)))
15736 Prepend_Elmt
(Full_View
(Priv_Sub
), Exchanged_Views
);
15737 Exchange_Declarations
(Priv_Sub
);
15740 Next_Elmt
(Priv_Elmt
);
15748 function True_Parent
(N
: Node_Id
) return Node_Id
is
15750 if Nkind
(Parent
(N
)) = N_Subunit
then
15751 return Parent
(Corresponding_Stub
(Parent
(N
)));
15757 -----------------------------
15758 -- Valid_Default_Attribute --
15759 -----------------------------
15761 procedure Valid_Default_Attribute
(Nam
: Entity_Id
; Def
: Node_Id
) is
15762 Attr_Id
: constant Attribute_Id
:=
15763 Get_Attribute_Id
(Attribute_Name
(Def
));
15764 T
: constant Entity_Id
:= Entity
(Prefix
(Def
));
15765 Is_Fun
: constant Boolean := (Ekind
(Nam
) = E_Function
);
15771 if No
(T
) or else T
= Any_Id
then
15776 F
:= First_Formal
(Nam
);
15777 while Present
(F
) loop
15778 Num_F
:= Num_F
+ 1;
15783 when Attribute_Adjacent
15784 | Attribute_Ceiling
15785 | Attribute_Copy_Sign
15787 | Attribute_Fraction
15788 | Attribute_Machine
15790 | Attribute_Remainder
15791 | Attribute_Rounding
15792 | Attribute_Unbiased_Rounding
15796 and then Is_Floating_Point_Type
(T
);
15798 when Attribute_Image
15802 | Attribute_Wide_Image
15803 | Attribute_Wide_Value
15805 OK
:= Is_Fun
and then Num_F
= 1 and then Is_Scalar_Type
(T
);
15810 OK
:= Is_Fun
and then Num_F
= 2 and then Is_Scalar_Type
(T
);
15812 when Attribute_Input
=>
15813 OK
:= (Is_Fun
and then Num_F
= 1);
15815 when Attribute_Output
15819 OK
:= not Is_Fun
and then Num_F
= 2;
15827 ("attribute reference has wrong profile for subprogram", Def
);
15829 end Valid_Default_Attribute
;