1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2023, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree
; use Atree
;
27 with Debug
; use Debug
;
28 with Einfo
; use Einfo
;
29 with Einfo
.Utils
; use Einfo
.Utils
;
30 with Elists
; use Elists
;
31 with Errout
; use Errout
;
32 with Exp_Disp
; use Exp_Disp
;
33 with Exp_Tss
; use Exp_Tss
;
34 with Exp_Util
; use Exp_Util
;
35 with Freeze
; use Freeze
;
36 with Ghost
; use Ghost
;
37 with Impunit
; use Impunit
;
39 with Lib
.Load
; use Lib
.Load
;
40 with Lib
.Xref
; use Lib
.Xref
;
41 with Namet
; use Namet
;
42 with Namet
.Sp
; use Namet
.Sp
;
43 with Nlists
; use Nlists
;
44 with Nmake
; use Nmake
;
46 with Output
; use Output
;
47 with Restrict
; use Restrict
;
48 with Rident
; use Rident
;
49 with Rtsfind
; use Rtsfind
;
51 with Sem_Aux
; use Sem_Aux
;
52 with Sem_Cat
; use Sem_Cat
;
53 with Sem_Ch3
; use Sem_Ch3
;
54 with Sem_Ch4
; use Sem_Ch4
;
55 with Sem_Ch6
; use Sem_Ch6
;
56 with Sem_Ch10
; use Sem_Ch10
;
57 with Sem_Ch12
; use Sem_Ch12
;
58 with Sem_Ch13
; use Sem_Ch13
;
59 with Sem_Dim
; use Sem_Dim
;
60 with Sem_Disp
; use Sem_Disp
;
61 with Sem_Dist
; use Sem_Dist
;
62 with Sem_Elab
; use Sem_Elab
;
63 with Sem_Eval
; use Sem_Eval
;
64 with Sem_Prag
; use Sem_Prag
;
65 with Sem_Res
; use Sem_Res
;
66 with Sem_Util
; use Sem_Util
;
67 with Sem_Type
; use Sem_Type
;
68 with Stand
; use Stand
;
69 with Sinfo
; use Sinfo
;
70 with Sinfo
.Nodes
; use Sinfo
.Nodes
;
71 with Sinfo
.Utils
; use Sinfo
.Utils
;
72 with Sinfo
.CN
; use Sinfo
.CN
;
73 with Snames
; use Snames
;
76 with Tbuild
; use Tbuild
;
77 with Uintp
; use Uintp
;
78 with Warnsw
; use Warnsw
;
80 package body Sem_Ch8
is
82 ------------------------------------
83 -- Visibility and Name Resolution --
84 ------------------------------------
86 -- This package handles name resolution and the collection of possible
87 -- interpretations for overloaded names, prior to overload resolution.
89 -- Name resolution is the process that establishes a mapping between source
90 -- identifiers and the entities they denote at each point in the program.
91 -- Each entity is represented by a defining occurrence. Each identifier
92 -- that denotes an entity points to the corresponding defining occurrence.
93 -- This is the entity of the applied occurrence. Each occurrence holds
94 -- an index into the names table, where source identifiers are stored.
96 -- Each entry in the names table for an identifier or designator uses the
97 -- Info pointer to hold a link to the currently visible entity that has
98 -- this name (see subprograms Get_Name_Entity_Id and Set_Name_Entity_Id
99 -- in package Sem_Util). The visibility is initialized at the beginning of
100 -- semantic processing to make entities in package Standard immediately
101 -- visible. The visibility table is used in a more subtle way when
102 -- compiling subunits (see below).
104 -- Entities that have the same name (i.e. homonyms) are chained. In the
105 -- case of overloaded entities, this chain holds all the possible meanings
106 -- of a given identifier. The process of overload resolution uses type
107 -- information to select from this chain the unique meaning of a given
110 -- Entities are also chained in their scope, through the Next_Entity link.
111 -- As a consequence, the name space is organized as a sparse matrix, where
112 -- each row corresponds to a scope, and each column to a source identifier.
113 -- Open scopes, that is to say scopes currently being compiled, have their
114 -- corresponding rows of entities in order, innermost scope first.
116 -- The scopes of packages that are mentioned in context clauses appear in
117 -- no particular order, interspersed among open scopes. This is because
118 -- in the course of analyzing the context of a compilation, a package
119 -- declaration is first an open scope, and subsequently an element of the
120 -- context. If subunits or child units are present, a parent unit may
121 -- appear under various guises at various times in the compilation.
123 -- When the compilation of the innermost scope is complete, the entities
124 -- defined therein are no longer visible. If the scope is not a package
125 -- declaration, these entities are never visible subsequently, and can be
126 -- removed from visibility chains. If the scope is a package declaration,
127 -- its visible declarations may still be accessible. Therefore the entities
128 -- defined in such a scope are left on the visibility chains, and only
129 -- their visibility (immediately visibility or potential use-visibility)
132 -- The ordering of homonyms on their chain does not necessarily follow
133 -- the order of their corresponding scopes on the scope stack. For
134 -- example, if package P and the enclosing scope both contain entities
135 -- named E, then when compiling the package body the chain for E will
136 -- hold the global entity first, and the local one (corresponding to
137 -- the current inner scope) next. As a result, name resolution routines
138 -- do not assume any relative ordering of the homonym chains, either
139 -- for scope nesting or to order of appearance of context clauses.
141 -- When compiling a child unit, entities in the parent scope are always
142 -- immediately visible. When compiling the body of a child unit, private
143 -- entities in the parent must also be made immediately visible. There
144 -- are separate routines to make the visible and private declarations
145 -- visible at various times (see package Sem_Ch7).
147 -- +--------+ +-----+
148 -- | In use |-------->| EU1 |-------------------------->
149 -- +--------+ +-----+
151 -- +--------+ +-----+ +-----+
152 -- | Stand. |---------------->| ES1 |--------------->| ES2 |--->
153 -- +--------+ +-----+ +-----+
155 -- +---------+ | +-----+
156 -- | with'ed |------------------------------>| EW2 |--->
157 -- +---------+ | +-----+
159 -- +--------+ +-----+ +-----+
160 -- | Scope2 |---------------->| E12 |--------------->| E22 |--->
161 -- +--------+ +-----+ +-----+
163 -- +--------+ +-----+ +-----+
164 -- | Scope1 |---------------->| E11 |--------------->| E12 |--->
165 -- +--------+ +-----+ +-----+
169 -- | | with'ed |----------------------------------------->
173 -- (innermost first) | |
174 -- +----------------------------+
175 -- Names table => | Id1 | | | | Id2 |
176 -- +----------------------------+
178 -- Name resolution must deal with several syntactic forms: simple names,
179 -- qualified names, indexed names, and various forms of calls.
181 -- Each identifier points to an entry in the names table. The resolution
182 -- of a simple name consists in traversing the homonym chain, starting
183 -- from the names table. If an entry is immediately visible, it is the one
184 -- designated by the identifier. If only potentially use-visible entities
185 -- are on the chain, we must verify that they do not hide each other. If
186 -- the entity we find is overloadable, we collect all other overloadable
187 -- entities on the chain as long as they are not hidden.
189 -- To resolve expanded names, we must find the entity at the intersection
190 -- of the entity chain for the scope (the prefix) and the homonym chain
191 -- for the selector. In general, homonym chains will be much shorter than
192 -- entity chains, so it is preferable to start from the names table as
193 -- well. If the entity found is overloadable, we must collect all other
194 -- interpretations that are defined in the scope denoted by the prefix.
196 -- For records, protected types, and tasks, their local entities are
197 -- removed from visibility chains on exit from the corresponding scope.
198 -- From the outside, these entities are always accessed by selected
199 -- notation, and the entity chain for the record type, protected type,
200 -- etc. is traversed sequentially in order to find the designated entity.
202 -- The discriminants of a type and the operations of a protected type or
203 -- task are unchained on exit from the first view of the type, (such as
204 -- a private or incomplete type declaration, or a protected type speci-
205 -- fication) and re-chained when compiling the second view.
207 -- In the case of operators, we do not make operators on derived types
208 -- explicit. As a result, the notation P."+" may denote either a user-
209 -- defined function with name "+", or else an implicit declaration of the
210 -- operator "+" in package P. The resolution of expanded names always
211 -- tries to resolve an operator name as such an implicitly defined entity,
212 -- in addition to looking for explicit declarations.
214 -- All forms of names that denote entities (simple names, expanded names,
215 -- character literals in some cases) have a Entity attribute, which
216 -- identifies the entity denoted by the name.
218 ---------------------
219 -- The Scope Stack --
220 ---------------------
222 -- The Scope stack keeps track of the scopes currently been compiled.
223 -- Every entity that contains declarations (including records) is placed
224 -- on the scope stack while it is being processed, and removed at the end.
225 -- Whenever a non-package scope is exited, the entities defined therein
226 -- are removed from the visibility table, so that entities in outer scopes
227 -- become visible (see previous description). On entry to Sem, the scope
228 -- stack only contains the package Standard. As usual, subunits complicate
229 -- this picture ever so slightly.
231 -- The Rtsfind mechanism can force a call to Semantics while another
232 -- compilation is in progress. The unit retrieved by Rtsfind must be
233 -- compiled in its own context, and has no access to the visibility of
234 -- the unit currently being compiled. The procedures Save_Scope_Stack and
235 -- Restore_Scope_Stack make entities in current open scopes invisible
236 -- before compiling the retrieved unit, and restore the compilation
237 -- environment afterwards.
239 ------------------------
240 -- Compiling subunits --
241 ------------------------
243 -- Subunits must be compiled in the environment of the corresponding stub,
244 -- that is to say with the same visibility into the parent (and its
245 -- context) that is available at the point of the stub declaration, but
246 -- with the additional visibility provided by the context clause of the
247 -- subunit itself. As a result, compilation of a subunit forces compilation
248 -- of the parent (see description in lib-). At the point of the stub
249 -- declaration, Analyze is called recursively to compile the proper body of
250 -- the subunit, but without reinitializing the names table, nor the scope
251 -- stack (i.e. standard is not pushed on the stack). In this fashion the
252 -- context of the subunit is added to the context of the parent, and the
253 -- subunit is compiled in the correct environment. Note that in the course
254 -- of processing the context of a subunit, Standard will appear twice on
255 -- the scope stack: once for the parent of the subunit, and once for the
256 -- unit in the context clause being compiled. However, the two sets of
257 -- entities are not linked by homonym chains, so that the compilation of
258 -- any context unit happens in a fresh visibility environment.
260 -------------------------------
261 -- Processing of USE Clauses --
262 -------------------------------
264 -- Every defining occurrence has a flag indicating if it is potentially use
265 -- visible. Resolution of simple names examines this flag. The processing
266 -- of use clauses consists in setting this flag on all visible entities
267 -- defined in the corresponding package. On exit from the scope of the use
268 -- clause, the corresponding flag must be reset. However, a package may
269 -- appear in several nested use clauses (pathological but legal, alas)
270 -- which forces us to use a slightly more involved scheme:
272 -- a) The defining occurrence for a package holds a flag -In_Use- to
273 -- indicate that it is currently in the scope of a use clause. If a
274 -- redundant use clause is encountered, then the corresponding occurrence
275 -- of the package name is flagged -Redundant_Use-.
277 -- b) On exit from a scope, the use clauses in its declarative part are
278 -- scanned. The visibility flag is reset in all entities declared in
279 -- package named in a use clause, as long as the package is not flagged
280 -- as being in a redundant use clause (in which case the outer use
281 -- clause is still in effect, and the direct visibility of its entities
282 -- must be retained).
284 -- Note that entities are not removed from their homonym chains on exit
285 -- from the package specification. A subsequent use clause does not need
286 -- to rechain the visible entities, but only to establish their direct
289 -----------------------------------
290 -- Handling private declarations --
291 -----------------------------------
293 -- The principle that each entity has a single defining occurrence clashes
294 -- with the presence of two separate definitions for private types: the
295 -- first is the private type declaration, and second is the full type
296 -- declaration. It is important that all references to the type point to
297 -- the same defining occurrence, namely the first one. To enforce the two
298 -- separate views of the entity, the corresponding information is swapped
299 -- between the two declarations. Outside of the package, the defining
300 -- occurrence only contains the private declaration information, while in
301 -- the private part and the body of the package the defining occurrence
302 -- contains the full declaration. To simplify the swap, the defining
303 -- occurrence that currently holds the private declaration points to the
304 -- full declaration. During semantic processing the defining occurrence
305 -- also points to a list of private dependents, that is to say access types
306 -- or composite types whose designated types or component types are
307 -- subtypes or derived types of the private type in question. After the
308 -- full declaration has been seen, the private dependents are updated to
309 -- indicate that they have full definitions.
311 ------------------------------------
312 -- Handling of Undefined Messages --
313 ------------------------------------
315 -- In normal mode, only the first use of an undefined identifier generates
316 -- a message. The table Urefs is used to record error messages that have
317 -- been issued so that second and subsequent ones do not generate further
318 -- messages. However, the second reference causes text to be added to the
319 -- original undefined message noting "(more references follow)". The
320 -- full error list option (-gnatf) forces messages to be generated for
321 -- every reference and disconnects the use of this table.
323 type Uref_Entry
is record
325 -- Node for identifier for which original message was posted. The
326 -- Chars field of this identifier is used to detect later references
327 -- to the same identifier.
330 -- Records error message Id of original undefined message. Reset to
331 -- No_Error_Msg after the second occurrence, where it is used to add
332 -- text to the original message as described above.
335 -- Set if the message is not visible rather than undefined
338 -- Records location of error message. Used to make sure that we do
339 -- not consider a, b : undefined as two separate instances, which
340 -- would otherwise happen, since the parser converts this sequence
341 -- to a : undefined; b : undefined.
345 package Urefs
is new Table
.Table
(
346 Table_Component_Type
=> Uref_Entry
,
347 Table_Index_Type
=> Nat
,
348 Table_Low_Bound
=> 1,
350 Table_Increment
=> 100,
351 Table_Name
=> "Urefs");
353 Candidate_Renaming
: Entity_Id
;
354 -- Holds a candidate interpretation that appears in a subprogram renaming
355 -- declaration and does not match the given specification, but matches at
356 -- least on the first formal. Allows better error message when given
357 -- specification omits defaulted parameters, a common error.
359 -----------------------
360 -- Local Subprograms --
361 -----------------------
363 procedure Analyze_Generic_Renaming
366 -- Common processing for all three kinds of generic renaming declarations.
367 -- Enter new name and indicate that it renames the generic unit.
369 procedure Analyze_Renamed_Character
373 -- Renamed entity is given by a character literal, which must belong
374 -- to the return type of the new entity. Is_Body indicates whether the
375 -- declaration is a renaming_as_body. If the original declaration has
376 -- already been frozen (because of an intervening body, e.g.) the body of
377 -- the function must be built now. The same applies to the following
378 -- various renaming procedures.
380 procedure Analyze_Renamed_Dereference
384 -- Renamed entity is given by an explicit dereference. Prefix must be a
385 -- conformant access_to_subprogram type.
387 procedure Analyze_Renamed_Entry
391 -- If the renamed entity in a subprogram renaming is an entry or protected
392 -- subprogram, build a body for the new entity whose only statement is a
393 -- call to the renamed entity.
395 procedure Analyze_Renamed_Family_Member
399 -- Used when the renamed entity is an indexed component. The prefix must
400 -- denote an entry family.
402 procedure Analyze_Renamed_Primitive_Operation
406 -- If the renamed entity in a subprogram renaming is a primitive operation
407 -- or a class-wide operation in prefix form, save the target object,
408 -- which must be added to the list of actuals in any subsequent call.
409 -- The renaming operation is intrinsic because the compiler must in
410 -- fact generate a wrapper for it (6.3.1 (10 1/2)).
412 procedure Attribute_Renaming
(N
: Node_Id
);
413 -- Analyze renaming of attribute as subprogram. The renaming declaration N
414 -- is rewritten as a subprogram body that returns the attribute reference
415 -- applied to the formals of the function.
417 procedure Set_Entity_Or_Discriminal
(N
: Node_Id
; E
: Entity_Id
);
418 -- Set Entity, with style check if need be. For a discriminant reference,
419 -- replace by the corresponding discriminal, i.e. the parameter of the
420 -- initialization procedure that corresponds to the discriminant.
422 procedure Check_Frozen_Renaming
(N
: Node_Id
; Subp
: Entity_Id
);
423 -- A renaming_as_body may occur after the entity of the original decla-
424 -- ration has been frozen. In that case, the body of the new entity must
425 -- be built now, because the usual mechanism of building the renamed
426 -- body at the point of freezing will not work. Subp is the subprogram
427 -- for which N provides the Renaming_As_Body.
429 procedure Check_In_Previous_With_Clause
(N
, Nam
: Node_Id
);
430 -- N is a use_package clause and Nam the package name, or N is a use_type
431 -- clause and Nam is the prefix of the type name. In either case, verify
432 -- that the package is visible at that point in the context: either it
433 -- appears in a previous with_clause, or because it is a fully qualified
434 -- name and the root ancestor appears in a previous with_clause.
436 procedure Check_Library_Unit_Renaming
(N
: Node_Id
; Old_E
: Entity_Id
);
437 -- Verify that the entity in a renaming declaration that is a library unit
438 -- is itself a library unit and not a nested unit or subunit. Also check
439 -- that if the renaming is a child unit of a generic parent, then the
440 -- renamed unit must also be a child unit of that parent. Finally, verify
441 -- that a renamed generic unit is not an implicit child declared within
442 -- an instance of the parent.
444 procedure Chain_Use_Clause
(N
: Node_Id
);
445 -- Chain use clause onto list of uses clauses headed by First_Use_Clause in
446 -- the proper scope table entry. This is usually the current scope, but it
447 -- will be an inner scope when installing the use clauses of the private
448 -- declarations of a parent unit prior to compiling the private part of a
449 -- child unit. This chain is traversed when installing/removing use clauses
450 -- when compiling a subunit or instantiating a generic body on the fly,
451 -- when it is necessary to save and restore full environments.
453 function Enclosing_Instance
return Entity_Id
;
454 -- In an instance nested within another one, several semantic checks are
455 -- unnecessary because the legality of the nested instance has been checked
456 -- in the enclosing generic unit. This applies in particular to legality
457 -- checks on actuals for formal subprograms of the inner instance, which
458 -- are checked as subprogram renamings, and may be complicated by confusion
459 -- in private/full views. This function returns the instance enclosing the
460 -- current one if there is such, else it returns Empty.
462 -- If the renaming determines the entity for the default of a formal
463 -- subprogram nested within another instance, choose the innermost
464 -- candidate. This is because if the formal has a box, and we are within
465 -- an enclosing instance where some candidate interpretations are local
466 -- to this enclosing instance, we know that the default was properly
467 -- resolved when analyzing the generic, so we prefer the local
468 -- candidates to those that are external. This is not always the case
469 -- but is a reasonable heuristic on the use of nested generics. The
470 -- proper solution requires a full renaming model.
472 function Entity_Of_Unit
(U
: Node_Id
) return Entity_Id
;
473 -- Return the appropriate entity for determining which unit has a deeper
474 -- scope: the defining entity for U, unless U is a package instance, in
475 -- which case we retrieve the entity of the instance spec.
477 procedure Error_Missing_With_Of_Known_Unit
(Pkg
: Node_Id
);
478 -- Display an error message denoting a "with" is missing for a given known
479 -- package Pkg with its full path name.
481 procedure Find_Expanded_Name
(N
: Node_Id
);
482 -- The input is a selected component known to be an expanded name. Verify
483 -- legality of selector given the scope denoted by prefix, and change node
484 -- N into a expanded name with a properly set Entity field.
486 function Find_First_Use
(Use_Clause
: Node_Id
) return Node_Id
;
487 -- Find the most previous use clause (that is, the first one to appear in
488 -- the source) by traversing the previous clause chain that exists in both
489 -- N_Use_Package_Clause nodes and N_Use_Type_Clause nodes.
491 function Find_Renamed_Entity
495 Is_Actual
: Boolean := False) return Entity_Id
;
496 -- Find the renamed entity that corresponds to the given parameter profile
497 -- in a subprogram renaming declaration. The renamed entity may be an
498 -- operator, a subprogram, an entry, or a protected operation. Is_Actual
499 -- indicates that the renaming is the one generated for an actual subpro-
500 -- gram in an instance, for which special visibility checks apply.
502 function Has_Implicit_Character_Literal
(N
: Node_Id
) return Boolean;
503 -- Find a type derived from Character or Wide_Character in the prefix of N.
504 -- Used to resolved qualified names whose selector is a character literal.
506 function Has_Private_With
(E
: Entity_Id
) return Boolean;
507 -- Ada 2005 (AI-262): Determines if the current compilation unit has a
508 -- private with on E.
510 function Has_Components
(Typ
: Entity_Id
) return Boolean;
511 -- Determine if given type has components, i.e. is either a record type or
512 -- type or a type that has discriminants.
514 function Has_Implicit_Operator
(N
: Node_Id
) return Boolean;
515 -- N is an expanded name whose selector is an operator name (e.g. P."+").
516 -- Determine if N denotes an operator implicitly declared in prefix P: P's
517 -- declarative part contains an implicit declaration of an operator if it
518 -- has a declaration of a type to which one of the predefined operators
519 -- apply. The existence of this routine is an implementation artifact. A
520 -- more straightforward but more space-consuming choice would be to make
521 -- all inherited operators explicit in the symbol table.
523 procedure Inherit_Renamed_Profile
(New_S
: Entity_Id
; Old_S
: Entity_Id
);
524 -- A subprogram defined by a renaming declaration inherits the parameter
525 -- profile of the renamed entity. The subtypes given in the subprogram
526 -- specification are discarded and replaced with those of the renamed
527 -- subprogram, which are then used to recheck the default values.
529 function Most_Descendant_Use_Clause
530 (Clause1
: Entity_Id
;
531 Clause2
: Entity_Id
) return Entity_Id
;
532 -- Determine which use clause parameter is the most descendant in terms of
535 procedure Premature_Usage
(N
: Node_Id
);
536 -- Diagnose usage of an entity before it is visible
538 function Is_Self_Hidden
(E
: Entity_Id
) return Boolean;
539 -- True within a declaration if it is hidden from all visibility by itself
540 -- (see RM-8.3(16-18)). This is mostly just "not Is_Not_Self_Hidden", but
541 -- we need to check for E_Void in case of errors.
543 procedure Use_One_Package
545 Pack_Name
: Entity_Id
:= Empty
;
546 Force
: Boolean := False);
547 -- Make visible entities declared in package P potentially use-visible
548 -- in the current context. Also used in the analysis of subunits, when
549 -- re-installing use clauses of parent units. N is the use_clause that
550 -- names P (and possibly other packages).
552 procedure Use_One_Type
554 Installed
: Boolean := False;
555 Force
: Boolean := False);
556 -- Id is the subtype mark from a use_type_clause. This procedure makes
557 -- the primitive operators of the type potentially use-visible. The
558 -- boolean flag Installed indicates that the clause is being reinstalled
559 -- after previous analysis, and primitive operations are already chained
560 -- on the Used_Operations list of the clause.
562 procedure Write_Info
;
563 -- Write debugging information on entities declared in current scope
565 --------------------------------
566 -- Analyze_Exception_Renaming --
567 --------------------------------
569 -- The language only allows a single identifier, but the tree holds an
570 -- identifier list. The parser has already issued an error message if
571 -- there is more than one element in the list.
573 procedure Analyze_Exception_Renaming
(N
: Node_Id
) is
574 Id
: constant Entity_Id
:= Defining_Entity
(N
);
575 Nam
: constant Node_Id
:= Name
(N
);
581 Mutate_Ekind
(Id
, E_Exception
);
582 Set_Etype
(Id
, Standard_Exception_Type
);
583 Set_Is_Pure
(Id
, Is_Pure
(Current_Scope
));
585 if Is_Entity_Name
(Nam
)
586 and then Present
(Entity
(Nam
))
587 and then Ekind
(Entity
(Nam
)) = E_Exception
589 if Present
(Renamed_Entity
(Entity
(Nam
))) then
590 Set_Renamed_Entity
(Id
, Renamed_Entity
(Entity
(Nam
)));
592 Set_Renamed_Entity
(Id
, Entity
(Nam
));
595 -- The exception renaming declaration may become Ghost if it renames
598 Mark_Ghost_Renaming
(N
, Entity
(Nam
));
600 Error_Msg_N
("invalid exception name in renaming", Nam
);
603 -- Implementation-defined aspect specifications can appear in a renaming
604 -- declaration, but not language-defined ones. The call to procedure
605 -- Analyze_Aspect_Specifications will take care of this error check.
607 if Has_Aspects
(N
) then
608 Analyze_Aspect_Specifications
(N
, Id
);
610 end Analyze_Exception_Renaming
;
612 ---------------------------
613 -- Analyze_Expanded_Name --
614 ---------------------------
616 procedure Analyze_Expanded_Name
(N
: Node_Id
) is
618 -- If the entity pointer is already set, this is an internal node, or a
619 -- node that is analyzed more than once, after a tree modification. In
620 -- such a case there is no resolution to perform, just set the type. In
621 -- either case, start by analyzing the prefix.
623 Analyze
(Prefix
(N
));
625 if Present
(Entity
(N
)) then
626 if Is_Type
(Entity
(N
)) then
627 Set_Etype
(N
, Entity
(N
));
629 Set_Etype
(N
, Etype
(Entity
(N
)));
633 Find_Expanded_Name
(N
);
636 -- In either case, propagate dimension of entity to expanded name
638 Analyze_Dimension
(N
);
639 end Analyze_Expanded_Name
;
641 ---------------------------------------
642 -- Analyze_Generic_Function_Renaming --
643 ---------------------------------------
645 procedure Analyze_Generic_Function_Renaming
(N
: Node_Id
) is
647 Analyze_Generic_Renaming
(N
, E_Generic_Function
);
648 end Analyze_Generic_Function_Renaming
;
650 --------------------------------------
651 -- Analyze_Generic_Package_Renaming --
652 --------------------------------------
654 procedure Analyze_Generic_Package_Renaming
(N
: Node_Id
) is
656 -- Test for the Text_IO special unit case here, since we may be renaming
657 -- one of the subpackages of Text_IO, then join common routine.
659 Check_Text_IO_Special_Unit
(Name
(N
));
661 Analyze_Generic_Renaming
(N
, E_Generic_Package
);
662 end Analyze_Generic_Package_Renaming
;
664 ----------------------------------------
665 -- Analyze_Generic_Procedure_Renaming --
666 ----------------------------------------
668 procedure Analyze_Generic_Procedure_Renaming
(N
: Node_Id
) is
670 Analyze_Generic_Renaming
(N
, E_Generic_Procedure
);
671 end Analyze_Generic_Procedure_Renaming
;
673 ------------------------------
674 -- Analyze_Generic_Renaming --
675 ------------------------------
677 procedure Analyze_Generic_Renaming
681 New_P
: constant Entity_Id
:= Defining_Entity
(N
);
682 Inst
: Boolean := False;
686 if Name
(N
) = Error
then
690 Generate_Definition
(New_P
);
692 if Current_Scope
/= Standard_Standard
then
693 Set_Is_Pure
(New_P
, Is_Pure
(Current_Scope
));
696 if Nkind
(Name
(N
)) = N_Selected_Component
then
697 Check_Generic_Child_Unit
(Name
(N
), Inst
);
702 if not Is_Entity_Name
(Name
(N
)) then
703 Error_Msg_N
("expect entity name in renaming declaration", Name
(N
));
706 Old_P
:= Entity
(Name
(N
));
710 Mutate_Ekind
(New_P
, K
);
712 if Etype
(Old_P
) = Any_Type
then
715 elsif Ekind
(Old_P
) /= K
then
716 Error_Msg_N
("invalid generic unit name", Name
(N
));
719 if Present
(Renamed_Entity
(Old_P
)) then
720 Set_Renamed_Entity
(New_P
, Renamed_Entity
(Old_P
));
722 Set_Renamed_Entity
(New_P
, Old_P
);
725 -- The generic renaming declaration may become Ghost if it renames a
728 Mark_Ghost_Renaming
(N
, Old_P
);
730 Set_Is_Pure
(New_P
, Is_Pure
(Old_P
));
731 Set_Is_Preelaborated
(New_P
, Is_Preelaborated
(Old_P
));
733 Set_Etype
(New_P
, Etype
(Old_P
));
734 Set_Has_Completion
(New_P
);
736 if In_Open_Scopes
(Old_P
) then
737 Error_Msg_N
("within its scope, generic denotes its instance", N
);
740 -- For subprograms, propagate the Intrinsic flag, to allow, e.g.
741 -- renamings and subsequent instantiations of Unchecked_Conversion.
743 if Is_Generic_Subprogram
(Old_P
) then
744 Set_Is_Intrinsic_Subprogram
745 (New_P
, Is_Intrinsic_Subprogram
(Old_P
));
748 Check_Library_Unit_Renaming
(N
, Old_P
);
751 -- Implementation-defined aspect specifications can appear in a renaming
752 -- declaration, but not language-defined ones. The call to procedure
753 -- Analyze_Aspect_Specifications will take care of this error check.
755 if Has_Aspects
(N
) then
756 Analyze_Aspect_Specifications
(N
, New_P
);
758 end Analyze_Generic_Renaming
;
760 -----------------------------
761 -- Analyze_Object_Renaming --
762 -----------------------------
764 procedure Analyze_Object_Renaming
(N
: Node_Id
) is
765 Id
: constant Entity_Id
:= Defining_Identifier
(N
);
766 Loc
: constant Source_Ptr
:= Sloc
(N
);
767 Nam
: constant Node_Id
:= Name
(N
);
768 Is_Object_Ref
: Boolean;
774 procedure Check_Constrained_Object
;
775 -- If the nominal type is unconstrained but the renamed object is
776 -- constrained, as can happen with renaming an explicit dereference or
777 -- a function return, build a constrained subtype from the object. If
778 -- the renaming is for a formal in an accept statement, the analysis
779 -- has already established its actual subtype. This is only relevant
780 -- if the renamed object is an explicit dereference.
782 function Get_Object_Name
(Nod
: Node_Id
) return Node_Id
;
783 -- Obtain the name of the object from node Nod which is being renamed by
784 -- the object renaming declaration N.
786 function Find_Raise_Node
(N
: Node_Id
) return Traverse_Result
;
787 -- Process one node in search for N_Raise_xxx_Error nodes.
788 -- Return Abandon if found, OK otherwise.
790 ---------------------
791 -- Find_Raise_Node --
792 ---------------------
794 function Find_Raise_Node
(N
: Node_Id
) return Traverse_Result
is
796 if Nkind
(N
) in N_Raise_xxx_Error
then
803 ------------------------
804 -- No_Raise_xxx_Error --
805 ------------------------
807 function No_Raise_xxx_Error
is new Traverse_Func
(Find_Raise_Node
);
808 -- Traverse tree to look for a N_Raise_xxx_Error node and returns
809 -- Abandon if so and OK if none found.
811 ------------------------------
812 -- Check_Constrained_Object --
813 ------------------------------
815 procedure Check_Constrained_Object
is
816 Typ
: constant Entity_Id
:= Etype
(Nam
);
818 Loop_Scheme
: Node_Id
;
821 if Nkind
(Nam
) in N_Function_Call | N_Explicit_Dereference
822 and then Is_Composite_Type
(Typ
)
823 and then not Is_Constrained
(Typ
)
824 and then not Has_Unknown_Discriminants
(Typ
)
825 and then Expander_Active
827 -- If Actual_Subtype is already set, nothing to do
829 if Ekind
(Id
) in E_Variable | E_Constant
830 and then Present
(Actual_Subtype
(Id
))
834 -- A renaming of an unchecked union has no actual subtype
836 elsif Is_Unchecked_Union
(Typ
) then
839 -- If a record is limited its size is invariant. This is the case
840 -- in particular with record types with an access discriminant
841 -- that are used in iterators. This is an optimization, but it
842 -- also prevents typing anomalies when the prefix is further
845 -- Note that we cannot just use the Is_Limited_Record flag because
846 -- it does not apply to records with limited components, for which
847 -- this syntactic flag is not set, but whose size is also fixed.
849 -- Note also that we need to build the constrained subtype for an
850 -- array in order to make the bounds explicit in most cases, but
851 -- not if the object comes from an extended return statement, as
852 -- this would create dangling references to them later on.
854 elsif Is_Limited_Type
(Typ
)
855 and then (not Is_Array_Type
(Typ
) or else Is_Return_Object
(Id
))
860 Subt
:= Make_Temporary
(Loc
, 'T');
861 Remove_Side_Effects
(Nam
);
863 Make_Subtype_Declaration
(Loc
,
864 Defining_Identifier
=> Subt
,
865 Subtype_Indication
=>
866 Make_Subtype_From_Expr
(Nam
, Typ
)));
867 Rewrite
(Subtype_Mark
(N
), New_Occurrence_Of
(Subt
, Loc
));
868 Set_Etype
(Nam
, Subt
);
870 -- Suppress discriminant checks on this subtype if the original
871 -- type has defaulted discriminants and Id is a "for of" loop
874 if Has_Defaulted_Discriminants
(Typ
)
875 and then Nkind
(Original_Node
(Parent
(N
))) = N_Loop_Statement
877 Loop_Scheme
:= Iteration_Scheme
(Original_Node
(Parent
(N
)));
879 if Present
(Loop_Scheme
)
880 and then Present
(Iterator_Specification
(Loop_Scheme
))
883 (Iterator_Specification
(Loop_Scheme
)) = Id
885 Set_Checks_May_Be_Suppressed
(Subt
);
886 Push_Local_Suppress_Stack_Entry
888 Check
=> Discriminant_Check
,
893 -- Freeze subtype at once, to prevent order of elaboration
894 -- issues in the backend. The renamed object exists, so its
895 -- type is already frozen in any case.
897 Freeze_Before
(N
, Subt
);
900 end Check_Constrained_Object
;
902 ---------------------
903 -- Get_Object_Name --
904 ---------------------
906 function Get_Object_Name
(Nod
: Node_Id
) return Node_Id
is
911 while Present
(Obj_Nam
) loop
912 case Nkind
(Obj_Nam
) is
913 when N_Attribute_Reference
914 | N_Explicit_Dereference
915 | N_Indexed_Component
918 Obj_Nam
:= Prefix
(Obj_Nam
);
920 when N_Selected_Component
=>
921 Obj_Nam
:= Selector_Name
(Obj_Nam
);
923 when N_Qualified_Expression | N_Type_Conversion
=>
924 Obj_Nam
:= Expression
(Obj_Nam
);
934 -- Start of processing for Analyze_Object_Renaming
941 Set_Is_Pure
(Id
, Is_Pure
(Current_Scope
));
944 -- The renaming of a component that depends on a discriminant requires
945 -- an actual subtype, because in subsequent use of the object Gigi will
946 -- be unable to locate the actual bounds. This explicit step is required
947 -- when the renaming is generated in removing side effects of an
948 -- already-analyzed expression.
950 if Nkind
(Nam
) = N_Selected_Component
and then Analyzed
(Nam
) then
952 -- The object renaming declaration may become Ghost if it renames a
955 if Is_Entity_Name
(Nam
) then
956 Mark_Ghost_Renaming
(N
, Entity
(Nam
));
960 Dec
:= Build_Actual_Subtype_Of_Component
(Etype
(Nam
), Nam
);
962 if Present
(Dec
) then
963 Insert_Action
(N
, Dec
);
964 T
:= Defining_Identifier
(Dec
);
967 elsif Present
(Subtype_Mark
(N
))
968 or else No
(Access_Definition
(N
))
970 if Present
(Subtype_Mark
(N
)) then
971 Find_Type
(Subtype_Mark
(N
));
972 T
:= Entity
(Subtype_Mark
(N
));
975 -- AI12-0275: Case of object renaming without a subtype_mark
980 -- Normal case of no overloading in object name
982 if not Is_Overloaded
(Nam
) then
984 -- Catch error cases (such as attempting to rename a procedure
985 -- or package) using the shorthand form.
988 or else Etype
(Nam
) = Standard_Void_Type
991 ("object name or value expected in renaming", Nam
);
993 Mutate_Ekind
(Id
, E_Variable
);
994 Set_Etype
(Id
, Any_Type
);
1002 -- Case of overloaded name, which will be illegal if there's more
1003 -- than one acceptable interpretation (such as overloaded function
1015 -- More than one candidate interpretation is available
1017 -- Remove procedure calls, which syntactically cannot appear
1018 -- in this context, but which cannot be removed by type
1019 -- checking, because the context does not impose a type.
1021 Get_First_Interp
(Nam
, I
, It
);
1022 while Present
(It
.Typ
) loop
1023 if It
.Typ
= Standard_Void_Type
then
1027 Get_Next_Interp
(I
, It
);
1030 Get_First_Interp
(Nam
, I
, It
);
1034 -- If there's no type present, we have an error case (such
1035 -- as overloaded procedures named in the object renaming).
1039 ("object name or value expected in renaming", Nam
);
1041 Mutate_Ekind
(Id
, E_Variable
);
1042 Set_Etype
(Id
, Any_Type
);
1047 Get_Next_Interp
(I
, It
);
1049 if Present
(It
.Typ
) then
1051 It1
:= Disambiguate
(Nam
, I1
, I
, Any_Type
);
1053 if It1
= No_Interp
then
1054 Error_Msg_N
("ambiguous name in object renaming", Nam
);
1056 Error_Msg_Sloc
:= Sloc
(It
.Nam
);
1057 Error_Msg_N
("\\possible interpretation#!", Nam
);
1059 Error_Msg_Sloc
:= Sloc
(Nam1
);
1060 Error_Msg_N
("\\possible interpretation#!", Nam
);
1066 Set_Etype
(Nam
, It1
.Typ
);
1071 if Etype
(Nam
) = Standard_Exception_Type
then
1073 ("exception requires a subtype mark in renaming", Nam
);
1078 -- The object renaming declaration may become Ghost if it renames a
1081 if Is_Entity_Name
(Nam
) then
1082 Mark_Ghost_Renaming
(N
, Entity
(Nam
));
1085 -- Check against AI12-0401 here before Resolve may rewrite Nam and
1086 -- potentially generate spurious warnings.
1088 -- In the case where the object_name is a qualified_expression with
1089 -- a nominal subtype T and whose expression is a name that denotes
1091 -- * if T is an elementary subtype, then:
1092 -- * Q shall be a constant other than a dereference of an access
1094 -- * the nominal subtype of Q shall be statically compatible with
1096 -- * T shall statically match the base subtype of its type if
1097 -- scalar, or the first subtype of its type if an access type.
1098 -- * if T is a composite subtype, then Q shall be known to be
1099 -- constrained or T shall statically match the first subtype of
1102 if Nkind
(Nam
) = N_Qualified_Expression
1103 and then Is_Object_Reference
(Expression
(Nam
))
1105 Q
:= Expression
(Nam
);
1107 if (Is_Elementary_Type
(T
)
1109 not ((not Is_Variable
(Q
)
1110 and then Nkind
(Q
) /= N_Explicit_Dereference
)
1111 or else Subtypes_Statically_Compatible
(Etype
(Q
), T
)
1112 or else (Is_Scalar_Type
(T
)
1113 and then Subtypes_Statically_Match
1115 or else (Is_Access_Type
(T
)
1116 and then Subtypes_Statically_Match
1117 (T
, First_Subtype
(T
)))))
1118 or else (Is_Composite_Type
(T
)
1121 -- If Q is an aggregate, Is_Constrained may not be set
1122 -- yet and its type may not be resolved yet.
1123 -- This doesn't quite correspond to the complex notion
1124 -- of "known to be constrained" but this is good enough
1125 -- for a rule which is in any case too complex.
1127 not (Is_Constrained
(Etype
(Q
))
1128 or else Nkind
(Q
) = N_Aggregate
1129 or else Subtypes_Statically_Match
1130 (T
, First_Subtype
(T
))))
1133 ("subtype of renamed qualified expression does not " &
1134 "statically match", N
);
1141 -- If the renamed object is a function call of a limited type,
1142 -- the expansion of the renaming is complicated by the presence
1143 -- of various temporaries and subtypes that capture constraints
1144 -- of the renamed object. Rewrite node as an object declaration,
1145 -- whose expansion is simpler. Given that the object is limited
1146 -- there is no copy involved and no performance hit.
1148 if Nkind
(Nam
) = N_Function_Call
1149 and then Is_Limited_View
(Etype
(Nam
))
1150 and then not Is_Constrained
(Etype
(Nam
))
1151 and then Comes_From_Source
(N
)
1154 Mutate_Ekind
(Id
, E_Constant
);
1156 Make_Object_Declaration
(Loc
,
1157 Defining_Identifier
=> Id
,
1158 Constant_Present
=> True,
1159 Object_Definition
=> New_Occurrence_Of
(Etype
(Nam
), Loc
),
1160 Expression
=> Relocate_Node
(Nam
)));
1164 -- Ada 2012 (AI05-149): Reject renaming of an anonymous access object
1165 -- when renaming declaration has a named access type. The Ada 2012
1166 -- coverage rules allow an anonymous access type in the context of
1167 -- an expected named general access type, but the renaming rules
1168 -- require the types to be the same. (An exception is when the type
1169 -- of the renaming is also an anonymous access type, which can only
1170 -- happen due to a renaming created by the expander.)
1172 if Nkind
(Nam
) = N_Type_Conversion
1173 and then not Comes_From_Source
(Nam
)
1174 and then Is_Anonymous_Access_Type
(Etype
(Expression
(Nam
)))
1175 and then not Is_Anonymous_Access_Type
(T
)
1178 ("cannot rename anonymous access object "
1179 & "as a named access type", Expression
(Nam
), T
);
1182 -- Check that a class-wide object is not being renamed as an object
1183 -- of a specific type. The test for access types is needed to exclude
1184 -- cases where the renamed object is a dynamically tagged access
1185 -- result, such as occurs in certain expansions.
1187 if Is_Tagged_Type
(T
) then
1188 Check_Dynamically_Tagged_Expression
1194 -- Ada 2005 (AI-230/AI-254): Access renaming
1196 else pragma Assert
(Present
(Access_Definition
(N
)));
1200 N
=> Access_Definition
(N
));
1204 -- The object renaming declaration may become Ghost if it renames a
1207 if Is_Entity_Name
(Nam
) then
1208 Mark_Ghost_Renaming
(N
, Entity
(Nam
));
1211 -- Ada 2005 AI05-105: if the declaration has an anonymous access
1212 -- type, the renamed object must also have an anonymous type, and
1213 -- this is a name resolution rule. This was implicit in the last part
1214 -- of the first sentence in 8.5.1(3/2), and is made explicit by this
1217 if not Is_Overloaded
(Nam
) then
1218 if Ekind
(Etype
(Nam
)) /= Ekind
(T
) then
1220 ("expect anonymous access type in object renaming", N
);
1227 Typ
: Entity_Id
:= Empty
;
1228 Seen
: Boolean := False;
1231 Get_First_Interp
(Nam
, I
, It
);
1232 while Present
(It
.Typ
) loop
1234 -- Renaming is ambiguous if more than one candidate
1235 -- interpretation is type-conformant with the context.
1237 if Ekind
(It
.Typ
) = Ekind
(T
) then
1238 if Ekind
(T
) = E_Anonymous_Access_Subprogram_Type
1241 (Designated_Type
(T
), Designated_Type
(It
.Typ
))
1247 ("ambiguous expression in renaming", Nam
);
1250 elsif Ekind
(T
) = E_Anonymous_Access_Type
1252 Covers
(Designated_Type
(T
), Designated_Type
(It
.Typ
))
1258 ("ambiguous expression in renaming", Nam
);
1262 if Covers
(T
, It
.Typ
) then
1264 Set_Etype
(Nam
, Typ
);
1265 Set_Is_Overloaded
(Nam
, False);
1269 Get_Next_Interp
(I
, It
);
1276 -- Do not perform the legality checks below when the resolution of
1277 -- the renaming name failed because the associated type is Any_Type.
1279 if Etype
(Nam
) = Any_Type
then
1282 -- Ada 2005 (AI-231): In the case where the type is defined by an
1283 -- access_definition, the renamed entity shall be of an access-to-
1284 -- constant type if and only if the access_definition defines an
1285 -- access-to-constant type. ARM 8.5.1(4)
1287 elsif Constant_Present
(Access_Definition
(N
))
1288 and then not Is_Access_Constant
(Etype
(Nam
))
1291 ("(Ada 2005): the renamed object is not access-to-constant "
1292 & "(RM 8.5.1(6))", N
);
1294 elsif not Constant_Present
(Access_Definition
(N
))
1295 and then Is_Access_Constant
(Etype
(Nam
))
1298 ("(Ada 2005): the renamed object is not access-to-variable "
1299 & "(RM 8.5.1(6))", N
);
1302 if Is_Access_Subprogram_Type
(Etype
(Nam
)) then
1303 Check_Subtype_Conformant
1304 (Designated_Type
(T
), Designated_Type
(Etype
(Nam
)));
1306 elsif not Subtypes_Statically_Match
1307 (Designated_Type
(T
),
1308 Available_View
(Designated_Type
(Etype
(Nam
))))
1311 ("subtype of renamed object does not statically match", N
);
1315 -- Special processing for renaming function return object. Some errors
1316 -- and warnings are produced only for calls that come from source.
1318 if Nkind
(Nam
) = N_Function_Call
then
1321 -- Usage is illegal in Ada 83, but renamings are also introduced
1322 -- during expansion, and error does not apply to those.
1325 if Comes_From_Source
(N
) then
1327 ("(Ada 83) cannot rename function return object", Nam
);
1330 -- In Ada 95, warn for odd case of renaming parameterless function
1331 -- call if this is not a limited type (where this is useful).
1334 if Warn_On_Object_Renames_Function
1335 and then No
(Parameter_Associations
(Nam
))
1336 and then not Is_Limited_Type
(Etype
(Nam
))
1337 and then Comes_From_Source
(Nam
)
1340 ("renaming function result object is suspicious?.r?", Nam
);
1342 ("\function & will be called only once?.r?", Nam
,
1343 Entity
(Name
(Nam
)));
1344 Error_Msg_N
-- CODEFIX
1345 ("\suggest using an initialized constant object "
1346 & "instead?.r?", Nam
);
1351 Check_Constrained_Object
;
1353 -- An object renaming requires an exact match of the type. Class-wide
1354 -- matching is not allowed.
1356 if Is_Class_Wide_Type
(T
)
1357 and then Base_Type
(Etype
(Nam
)) /= Base_Type
(T
)
1359 Wrong_Type
(Nam
, T
);
1362 -- We must search for an actual subtype here so that the bounds of
1363 -- objects of unconstrained types don't get dropped on the floor - such
1364 -- as with renamings of formal parameters.
1366 T2
:= Get_Actual_Subtype_If_Available
(Nam
);
1368 -- Ada 2005 (AI-326): Handle wrong use of incomplete type
1370 if Nkind
(Nam
) = N_Explicit_Dereference
1371 and then Ekind
(Etype
(T2
)) = E_Incomplete_Type
1373 Error_Msg_NE
("invalid use of incomplete type&", Id
, T2
);
1376 elsif Ekind
(Etype
(T
)) = E_Incomplete_Type
then
1377 Error_Msg_NE
("invalid use of incomplete type&", Id
, T
);
1381 if Ada_Version
>= Ada_2005
and then Nkind
(Nam
) in N_Has_Entity
then
1383 Nam_Ent
: constant Entity_Id
:= Entity
(Get_Object_Name
(Nam
));
1384 Nam_Decl
: constant Node_Id
:= Declaration_Node
(Nam_Ent
);
1387 if Has_Null_Exclusion
(N
)
1388 and then not Has_Null_Exclusion
(Nam_Decl
)
1390 -- Ada 2005 (AI-423): If the object name denotes a generic
1391 -- formal object of a generic unit G, and the object renaming
1392 -- declaration occurs within the body of G or within the body
1393 -- of a generic unit declared within the declarative region
1394 -- of G, then the declaration of the formal object of G must
1395 -- have a null exclusion or a null-excluding subtype.
1397 if Is_Formal_Object
(Nam_Ent
)
1398 and then In_Generic_Scope
(Id
)
1400 if not Can_Never_Be_Null
(Etype
(Nam_Ent
)) then
1402 ("object does not exclude `NULL` "
1403 & "(RM 8.5.1(4.6/2))", N
);
1405 elsif In_Package_Body
(Scope
(Id
)) then
1407 ("formal object does not have a null exclusion"
1408 & "(RM 8.5.1(4.6/2))", N
);
1411 -- Ada 2005 (AI-423): Otherwise, the subtype of the object name
1412 -- shall exclude null.
1414 elsif not Can_Never_Be_Null
(Etype
(Nam_Ent
)) then
1416 ("object does not exclude `NULL` "
1417 & "(RM 8.5.1(4.6/2))", N
);
1419 -- An instance is illegal if it contains a renaming that
1420 -- excludes null, and the actual does not. The renaming
1421 -- declaration has already indicated that the declaration
1422 -- of the renamed actual in the instance will raise
1423 -- constraint_error.
1425 elsif Nkind
(Nam_Decl
) = N_Object_Declaration
1426 and then In_Instance
1428 Present
(Corresponding_Generic_Association
(Nam_Decl
))
1429 and then Nkind
(Expression
(Nam_Decl
)) =
1430 N_Raise_Constraint_Error
1433 ("actual does not exclude `NULL` (RM 8.5.1(4.6/2))", N
);
1435 -- Finally, if there is a null exclusion, the subtype mark
1436 -- must not be null-excluding.
1438 elsif No
(Access_Definition
(N
))
1439 and then Can_Never_Be_Null
(T
)
1442 ("`NOT NULL` not allowed (& already excludes null)",
1447 elsif Can_Never_Be_Null
(T
)
1448 and then not Can_Never_Be_Null
(Etype
(Nam_Ent
))
1451 ("object does not exclude `NULL` (RM 8.5.1(4.6/2))", N
);
1453 elsif Has_Null_Exclusion
(N
)
1454 and then No
(Access_Definition
(N
))
1455 and then Can_Never_Be_Null
(T
)
1458 ("`NOT NULL` not allowed (& already excludes null)", N
, T
);
1463 -- Set the Ekind of the entity, unless it has been set already, as is
1464 -- the case for the iteration object over a container with no variable
1465 -- indexing. In that case it's been marked as a constant, and we do not
1466 -- want to change it to a variable.
1468 if Ekind
(Id
) /= E_Constant
then
1469 Mutate_Ekind
(Id
, E_Variable
);
1472 Reinit_Object_Size_Align
(Id
);
1474 -- If N comes from source then check that the original node is an
1475 -- object reference since there may have been several rewritting and
1476 -- folding. Do not do this for N_Function_Call or N_Explicit_Dereference
1477 -- which might correspond to rewrites of e.g. N_Selected_Component
1478 -- (for example Object.Method rewriting).
1479 -- If N does not come from source then assume the tree is properly
1480 -- formed and accept any object reference. In such cases we do support
1481 -- more cases of renamings anyway, so the actual check on which renaming
1482 -- is valid is better left to the code generator as a last sanity
1485 if Comes_From_Source
(N
) then
1486 if Nkind
(Nam
) in N_Function_Call | N_Explicit_Dereference
then
1487 Is_Object_Ref
:= Is_Object_Reference
(Nam
);
1489 Is_Object_Ref
:= Is_Object_Reference
(Original_Node
(Nam
));
1492 Is_Object_Ref
:= True;
1495 if T
= Any_Type
or else Etype
(Nam
) = Any_Type
then
1498 -- Verify that the renamed entity is an object or function call
1500 elsif Is_Object_Ref
then
1501 if Comes_From_Source
(N
) then
1502 if Is_Dependent_Component_Of_Mutable_Object
(Nam
) then
1504 ("illegal renaming of discriminant-dependent component", Nam
);
1507 -- If the renaming comes from source and the renamed object is a
1508 -- dereference, then mark the prefix as needing debug information,
1509 -- since it might have been rewritten hence internally generated
1510 -- and Debug_Renaming_Declaration will link the renaming to it.
1512 if Nkind
(Nam
) = N_Explicit_Dereference
1513 and then Is_Entity_Name
(Prefix
(Nam
))
1515 Set_Debug_Info_Needed
(Entity
(Prefix
(Nam
)));
1519 -- Weird but legal, equivalent to renaming a function call. Illegal
1520 -- if the literal is the result of constant-folding an attribute
1521 -- reference that is not a function.
1523 elsif Is_Entity_Name
(Nam
)
1524 and then Ekind
(Entity
(Nam
)) = E_Enumeration_Literal
1525 and then Nkind
(Original_Node
(Nam
)) /= N_Attribute_Reference
1529 -- A named number can only be renamed without a subtype mark
1531 elsif Nkind
(Nam
) in N_Real_Literal | N_Integer_Literal
1532 and then Present
(Subtype_Mark
(N
))
1533 and then Present
(Original_Entity
(Nam
))
1535 Error_Msg_N
("incompatible types in renaming", Nam
);
1537 -- AI12-0383: Names that denote values can be renamed.
1538 -- Ignore (accept) N_Raise_xxx_Error nodes in this context.
1540 elsif No_Raise_xxx_Error
(Nam
) = OK
then
1541 Error_Msg_Ada_2022_Feature
("value in renaming", Sloc
(Nam
));
1546 if not Is_Variable
(Nam
) then
1547 Mutate_Ekind
(Id
, E_Constant
);
1548 Set_Never_Set_In_Source
(Id
, True);
1549 Set_Is_True_Constant
(Id
, True);
1552 -- The entity of the renaming declaration needs to reflect whether the
1553 -- renamed object is atomic, independent, volatile or VFA. These flags
1554 -- are set on the renamed object in the RM legality sense.
1556 Set_Is_Atomic
(Id
, Is_Atomic_Object
(Nam
));
1557 Set_Is_Independent
(Id
, Is_Independent_Object
(Nam
));
1558 Set_Is_Volatile
(Id
, Is_Volatile_Object_Ref
(Nam
));
1559 Set_Is_Volatile_Full_Access
1560 (Id
, Is_Volatile_Full_Access_Object_Ref
(Nam
));
1562 -- Treat as volatile if we just set the Volatile flag
1566 -- Or if we are renaming an entity which was marked this way
1568 -- Are there more cases, e.g. X(J) where X is Treat_As_Volatile ???
1570 or else (Is_Entity_Name
(Nam
)
1571 and then Treat_As_Volatile
(Entity
(Nam
)))
1573 Set_Treat_As_Volatile
(Id
, True);
1576 -- Now make the link to the renamed object
1578 Set_Renamed_Object
(Id
, Nam
);
1580 -- Implementation-defined aspect specifications can appear in a renaming
1581 -- declaration, but not language-defined ones. The call to procedure
1582 -- Analyze_Aspect_Specifications will take care of this error check.
1584 if Has_Aspects
(N
) then
1585 Analyze_Aspect_Specifications
(N
, Id
);
1588 -- Deal with dimensions
1590 Analyze_Dimension
(N
);
1591 end Analyze_Object_Renaming
;
1593 ------------------------------
1594 -- Analyze_Package_Renaming --
1595 ------------------------------
1597 procedure Analyze_Package_Renaming
(N
: Node_Id
) is
1598 New_P
: constant Entity_Id
:= Defining_Entity
(N
);
1603 if Name
(N
) = Error
then
1607 -- Check for Text_IO special units (we may be renaming a Text_IO child),
1608 -- but make sure not to catch renamings generated for package instances
1609 -- that have nothing to do with them but are nevertheless homonyms.
1611 if Is_Entity_Name
(Name
(N
))
1612 and then Present
(Entity
(Name
(N
)))
1613 and then Is_Generic_Instance
(Entity
(Name
(N
)))
1617 Check_Text_IO_Special_Unit
(Name
(N
));
1620 if Current_Scope
/= Standard_Standard
then
1621 Set_Is_Pure
(New_P
, Is_Pure
(Current_Scope
));
1627 if Is_Entity_Name
(Name
(N
)) then
1628 Old_P
:= Entity
(Name
(N
));
1633 if Etype
(Old_P
) = Any_Type
then
1634 Error_Msg_N
("expect package name in renaming", Name
(N
));
1636 elsif Ekind
(Old_P
) /= E_Package
1637 and then not (Ekind
(Old_P
) = E_Generic_Package
1638 and then In_Open_Scopes
(Old_P
))
1640 if Ekind
(Old_P
) = E_Generic_Package
then
1642 ("generic package cannot be renamed as a package", Name
(N
));
1644 Error_Msg_Sloc
:= Sloc
(Old_P
);
1646 ("expect package name in renaming, found& declared#",
1650 -- Set basic attributes to minimize cascaded errors
1652 Mutate_Ekind
(New_P
, E_Package
);
1653 Set_Etype
(New_P
, Standard_Void_Type
);
1655 elsif Present
(Renamed_Entity
(Old_P
))
1656 and then (From_Limited_With
(Renamed_Entity
(Old_P
))
1657 or else Has_Limited_View
(Renamed_Entity
(Old_P
)))
1659 Unit_Is_Visible
(Cunit
(Get_Source_Unit
(Renamed_Entity
(Old_P
))))
1662 ("renaming of limited view of package & not usable in this context"
1663 & " (RM 8.5.3(3.1/2))", Name
(N
), Renamed_Entity
(Old_P
));
1665 -- Set basic attributes to minimize cascaded errors
1667 Mutate_Ekind
(New_P
, E_Package
);
1668 Set_Etype
(New_P
, Standard_Void_Type
);
1670 -- Here for OK package renaming
1673 -- Entities in the old package are accessible through the renaming
1674 -- entity. The simplest implementation is to have both packages share
1677 Mutate_Ekind
(New_P
, E_Package
);
1678 Set_Etype
(New_P
, Standard_Void_Type
);
1680 if Present
(Renamed_Entity
(Old_P
)) then
1681 Set_Renamed_Entity
(New_P
, Renamed_Entity
(Old_P
));
1683 Set_Renamed_Entity
(New_P
, Old_P
);
1686 -- The package renaming declaration may become Ghost if it renames a
1689 Mark_Ghost_Renaming
(N
, Old_P
);
1691 Set_Has_Completion
(New_P
);
1692 Set_First_Entity
(New_P
, First_Entity
(Old_P
));
1693 Set_Last_Entity
(New_P
, Last_Entity
(Old_P
));
1694 Set_First_Private_Entity
(New_P
, First_Private_Entity
(Old_P
));
1695 Check_Library_Unit_Renaming
(N
, Old_P
);
1696 Generate_Reference
(Old_P
, Name
(N
));
1698 -- If the renaming is in the visible part of a package, then we set
1699 -- Renamed_In_Spec for the renamed package, to prevent giving
1700 -- warnings about no entities referenced. Such a warning would be
1701 -- overenthusiastic, since clients can see entities in the renamed
1702 -- package via the visible package renaming.
1705 Ent
: constant Entity_Id
:= Cunit_Entity
(Current_Sem_Unit
);
1707 if Ekind
(Ent
) = E_Package
1708 and then not In_Private_Part
(Ent
)
1709 and then In_Extended_Main_Source_Unit
(N
)
1710 and then Ekind
(Old_P
) = E_Package
1712 Set_Renamed_In_Spec
(Old_P
);
1716 -- If this is the renaming declaration of a package instantiation
1717 -- within itself, it is the declaration that ends the list of actuals
1718 -- for the instantiation. At this point, the subtypes that rename
1719 -- the actuals are flagged as generic, to avoid spurious ambiguities
1720 -- if the actuals for two distinct formals happen to coincide. If
1721 -- the actual is a private type, the subtype has a private completion
1722 -- that is flagged in the same fashion.
1724 -- Resolution is identical to what is was in the original generic.
1725 -- On exit from the generic instance, these are turned into regular
1726 -- subtypes again, so they are compatible with types in their class.
1728 if not Is_Generic_Instance
(Old_P
) then
1731 Spec
:= Specification
(Unit_Declaration_Node
(Old_P
));
1734 if Nkind
(Spec
) = N_Package_Specification
1735 and then Present
(Generic_Parent
(Spec
))
1736 and then Old_P
= Current_Scope
1737 and then Chars
(New_P
) = Chars
(Generic_Parent
(Spec
))
1743 E
:= First_Entity
(Old_P
);
1744 while Present
(E
) and then E
/= New_P
loop
1746 and then Nkind
(Parent
(E
)) = N_Subtype_Declaration
1748 Set_Is_Generic_Actual_Type
(E
);
1750 if Is_Private_Type
(E
)
1751 and then Present
(Full_View
(E
))
1753 Set_Is_Generic_Actual_Type
(Full_View
(E
));
1763 -- Implementation-defined aspect specifications can appear in a renaming
1764 -- declaration, but not language-defined ones. The call to procedure
1765 -- Analyze_Aspect_Specifications will take care of this error check.
1767 if Has_Aspects
(N
) then
1768 Analyze_Aspect_Specifications
(N
, New_P
);
1770 end Analyze_Package_Renaming
;
1772 -------------------------------
1773 -- Analyze_Renamed_Character --
1774 -------------------------------
1776 procedure Analyze_Renamed_Character
1781 C
: constant Node_Id
:= Name
(N
);
1784 if Ekind
(New_S
) = E_Function
then
1785 Resolve
(C
, Etype
(New_S
));
1788 Check_Frozen_Renaming
(N
, New_S
);
1792 Error_Msg_N
("character literal can only be renamed as function", N
);
1794 end Analyze_Renamed_Character
;
1796 ---------------------------------
1797 -- Analyze_Renamed_Dereference --
1798 ---------------------------------
1800 procedure Analyze_Renamed_Dereference
1805 Nam
: constant Node_Id
:= Name
(N
);
1806 P
: constant Node_Id
:= Prefix
(Nam
);
1812 if not Is_Overloaded
(P
) then
1813 if Ekind
(Etype
(Nam
)) /= E_Subprogram_Type
1814 or else not Type_Conformant
(Etype
(Nam
), New_S
)
1816 Error_Msg_N
("designated type does not match specification", P
);
1825 Get_First_Interp
(Nam
, Ind
, It
);
1827 while Present
(It
.Nam
) loop
1829 if Ekind
(It
.Nam
) = E_Subprogram_Type
1830 and then Type_Conformant
(It
.Nam
, New_S
)
1832 if Typ
/= Any_Id
then
1833 Error_Msg_N
("ambiguous renaming", P
);
1840 Get_Next_Interp
(Ind
, It
);
1843 if Typ
= Any_Type
then
1844 Error_Msg_N
("designated type does not match specification", P
);
1849 Check_Frozen_Renaming
(N
, New_S
);
1853 end Analyze_Renamed_Dereference
;
1855 ---------------------------
1856 -- Analyze_Renamed_Entry --
1857 ---------------------------
1859 procedure Analyze_Renamed_Entry
1864 Nam
: constant Node_Id
:= Name
(N
);
1865 Sel
: constant Node_Id
:= Selector_Name
(Nam
);
1866 Is_Actual
: constant Boolean := Present
(Corresponding_Formal_Spec
(N
));
1870 if Entity
(Sel
) = Any_Id
then
1872 -- Selector is undefined on prefix. Error emitted already
1874 Set_Has_Completion
(New_S
);
1878 -- Otherwise find renamed entity and build body of New_S as a call to it
1880 Old_S
:= Find_Renamed_Entity
(N
, Selector_Name
(Nam
), New_S
);
1882 if Old_S
= Any_Id
then
1883 Error_Msg_N
("no subprogram or entry matches specification", N
);
1886 Check_Subtype_Conformant
(New_S
, Old_S
, N
);
1887 Generate_Reference
(New_S
, Defining_Entity
(N
), 'b');
1888 Style
.Check_Identifier
(Defining_Entity
(N
), New_S
);
1891 -- Only mode conformance required for a renaming_as_declaration
1893 Check_Mode_Conformant
(New_S
, Old_S
, N
);
1896 Inherit_Renamed_Profile
(New_S
, Old_S
);
1898 -- The prefix can be an arbitrary expression that yields a task or
1899 -- protected object, so it must be resolved.
1901 if Is_Access_Type
(Etype
(Prefix
(Nam
))) then
1902 Insert_Explicit_Dereference
(Prefix
(Nam
));
1904 Resolve
(Prefix
(Nam
), Scope
(Old_S
));
1907 Set_Convention
(New_S
, Convention
(Old_S
));
1908 Set_Has_Completion
(New_S
, Inside_A_Generic
);
1910 -- AI05-0225: If the renamed entity is a procedure or entry of a
1911 -- protected object, the target object must be a variable.
1913 if Is_Protected_Type
(Scope
(Old_S
))
1914 and then Ekind
(New_S
) = E_Procedure
1915 and then not Is_Variable
(Prefix
(Nam
))
1919 ("target object of protected operation used as actual for "
1920 & "formal procedure must be a variable", Nam
);
1923 ("target object of protected operation renamed as procedure, "
1924 & "must be a variable", Nam
);
1929 Check_Frozen_Renaming
(N
, New_S
);
1931 end Analyze_Renamed_Entry
;
1933 -----------------------------------
1934 -- Analyze_Renamed_Family_Member --
1935 -----------------------------------
1937 procedure Analyze_Renamed_Family_Member
1942 Nam
: constant Node_Id
:= Name
(N
);
1943 P
: constant Node_Id
:= Prefix
(Nam
);
1947 if (Is_Entity_Name
(P
) and then Ekind
(Entity
(P
)) = E_Entry_Family
)
1948 or else (Nkind
(P
) = N_Selected_Component
1949 and then Ekind
(Entity
(Selector_Name
(P
))) = E_Entry_Family
)
1951 if Is_Entity_Name
(P
) then
1952 Old_S
:= Entity
(P
);
1954 Old_S
:= Entity
(Selector_Name
(P
));
1957 if not Entity_Matches_Spec
(Old_S
, New_S
) then
1958 Error_Msg_N
("entry family does not match specification", N
);
1961 Check_Subtype_Conformant
(New_S
, Old_S
, N
);
1962 Generate_Reference
(New_S
, Defining_Entity
(N
), 'b');
1963 Style
.Check_Identifier
(Defining_Entity
(N
), New_S
);
1967 Error_Msg_N
("no entry family matches specification", N
);
1970 Set_Has_Completion
(New_S
, Inside_A_Generic
);
1973 Check_Frozen_Renaming
(N
, New_S
);
1975 end Analyze_Renamed_Family_Member
;
1977 -----------------------------------------
1978 -- Analyze_Renamed_Primitive_Operation --
1979 -----------------------------------------
1981 procedure Analyze_Renamed_Primitive_Operation
1991 Ctyp
: Conformance_Type
) return Boolean;
1992 -- Verify that the signatures of the renamed entity and the new entity
1993 -- match. The first formal of the renamed entity is skipped because it
1994 -- is the target object in any subsequent call.
2002 Ctyp
: Conformance_Type
) return Boolean
2008 if Ekind
(Subp
) /= Ekind
(New_S
) then
2012 Old_F
:= Next_Formal
(First_Formal
(Subp
));
2013 New_F
:= First_Formal
(New_S
);
2014 while Present
(Old_F
) and then Present
(New_F
) loop
2015 if not Conforming_Types
(Etype
(Old_F
), Etype
(New_F
), Ctyp
) then
2019 if Ctyp
>= Mode_Conformant
2020 and then Ekind
(Old_F
) /= Ekind
(New_F
)
2025 Next_Formal
(New_F
);
2026 Next_Formal
(Old_F
);
2032 -- Start of processing for Analyze_Renamed_Primitive_Operation
2035 if not Is_Overloaded
(Selector_Name
(Name
(N
))) then
2036 Old_S
:= Entity
(Selector_Name
(Name
(N
)));
2038 if not Conforms
(Old_S
, Type_Conformant
) then
2043 -- Find the operation that matches the given signature
2051 Get_First_Interp
(Selector_Name
(Name
(N
)), Ind
, It
);
2053 while Present
(It
.Nam
) loop
2054 if Conforms
(It
.Nam
, Type_Conformant
) then
2058 Get_Next_Interp
(Ind
, It
);
2063 if Old_S
= Any_Id
then
2064 Error_Msg_N
("no subprogram or entry matches specification", N
);
2068 if not Conforms
(Old_S
, Subtype_Conformant
) then
2069 Error_Msg_N
("subtype conformance error in renaming", N
);
2072 Generate_Reference
(New_S
, Defining_Entity
(N
), 'b');
2073 Style
.Check_Identifier
(Defining_Entity
(N
), New_S
);
2076 -- Only mode conformance required for a renaming_as_declaration
2078 if not Conforms
(Old_S
, Mode_Conformant
) then
2079 Error_Msg_N
("mode conformance error in renaming", N
);
2082 -- AI12-0204: The prefix of a prefixed view that is renamed or
2083 -- passed as a formal subprogram must be renamable as an object.
2085 Nam
:= Prefix
(Name
(N
));
2087 if Is_Object_Reference
(Nam
) then
2088 if Is_Dependent_Component_Of_Mutable_Object
(Nam
) then
2090 ("illegal renaming of discriminant-dependent component",
2094 Error_Msg_N
("expect object name in renaming", Nam
);
2097 -- Enforce the rule given in (RM 6.3.1 (10.1/2)): a prefixed
2098 -- view of a subprogram is intrinsic, because the compiler has
2099 -- to generate a wrapper for any call to it. If the name in a
2100 -- subprogram renaming is a prefixed view, the entity is thus
2101 -- intrinsic, and 'Access cannot be applied to it.
2103 Set_Convention
(New_S
, Convention_Intrinsic
);
2106 -- Inherit_Renamed_Profile (New_S, Old_S);
2108 -- The prefix can be an arbitrary expression that yields an
2109 -- object, so it must be resolved.
2111 Resolve
(Prefix
(Name
(N
)));
2113 end Analyze_Renamed_Primitive_Operation
;
2115 ---------------------------------
2116 -- Analyze_Subprogram_Renaming --
2117 ---------------------------------
2119 procedure Analyze_Subprogram_Renaming
(N
: Node_Id
) is
2120 Formal_Spec
: constant Entity_Id
:= Corresponding_Formal_Spec
(N
);
2121 Is_Actual
: constant Boolean := Present
(Formal_Spec
);
2122 Nam
: constant Node_Id
:= Name
(N
);
2123 Save_AV
: constant Ada_Version_Type
:= Ada_Version
;
2124 Save_AVP
: constant Node_Id
:= Ada_Version_Pragma
;
2125 Save_AV_Exp
: constant Ada_Version_Type
:= Ada_Version_Explicit
;
2126 Spec
: constant Node_Id
:= Specification
(N
);
2128 Old_S
: Entity_Id
:= Empty
;
2129 Rename_Spec
: Entity_Id
;
2131 procedure Check_Null_Exclusion
2134 -- Ada 2005 (AI-423): Given renaming Ren of subprogram Sub, check the
2135 -- following AI rules:
2137 -- If Ren denotes a generic formal object of a generic unit G, and the
2138 -- renaming (or instantiation containing the actual) occurs within the
2139 -- body of G or within the body of a generic unit declared within the
2140 -- declarative region of G, then the corresponding parameter of G
2141 -- shall have a null_exclusion; Otherwise the subtype of the Sub's
2142 -- formal parameter shall exclude null.
2144 -- Similarly for its return profile.
2146 procedure Check_SPARK_Primitive_Operation
(Subp_Id
: Entity_Id
);
2147 -- Ensure that a SPARK renaming denoted by its entity Subp_Id does not
2148 -- declare a primitive operation of a tagged type (SPARK RM 6.1.1(3)).
2150 procedure Freeze_Actual_Profile
;
2151 -- In Ada 2012, enforce the freezing rule concerning formal incomplete
2152 -- types: a callable entity freezes its profile, unless it has an
2153 -- incomplete untagged formal (RM 13.14(10.2/3)).
2155 function Has_Class_Wide_Actual
return Boolean;
2156 -- Ada 2012 (AI05-071, AI05-0131) and Ada 2022 (AI12-0165): True if N is
2157 -- the renaming for a defaulted formal subprogram where the actual for
2158 -- the controlling formal type is class-wide.
2160 procedure Handle_Instance_With_Class_Wide_Type
2161 (Inst_Node
: Node_Id
;
2163 Wrapped_Prim
: out Entity_Id
;
2164 Wrap_Id
: out Entity_Id
);
2165 -- Ada 2012 (AI05-0071), Ada 2022 (AI12-0165): when the actual type
2166 -- of an instantiation is a class-wide type T'Class we may need to
2167 -- wrap a primitive operation of T; this routine looks for a suitable
2168 -- primitive to be wrapped and (if the wrapper is required) returns the
2169 -- Id of the wrapped primitive and the Id of the built wrapper. Ren_Id
2170 -- is the defining entity for the renamed subprogram specification.
2172 function Original_Subprogram
(Subp
: Entity_Id
) return Entity_Id
;
2173 -- Find renamed entity when the declaration is a renaming_as_body and
2174 -- the renamed entity may itself be a renaming_as_body. Used to enforce
2175 -- rule that a renaming_as_body is illegal if the declaration occurs
2176 -- before the subprogram it completes is frozen, and renaming indirectly
2177 -- renames the subprogram itself.(Defect Report 8652/0027).
2179 --------------------------
2180 -- Check_Null_Exclusion --
2181 --------------------------
2183 procedure Check_Null_Exclusion
2187 Ren_Formal
: Entity_Id
;
2188 Sub_Formal
: Entity_Id
;
2190 function Null_Exclusion_Mismatch
2191 (Renaming
: Entity_Id
; Renamed
: Entity_Id
) return Boolean;
2192 -- Return True if there is a null exclusion mismatch between
2193 -- Renaming and Renamed, False otherwise.
2195 -----------------------------
2196 -- Null_Exclusion_Mismatch --
2197 -----------------------------
2199 function Null_Exclusion_Mismatch
2200 (Renaming
: Entity_Id
; Renamed
: Entity_Id
) return Boolean is
2202 return Has_Null_Exclusion
(Parent
(Renaming
))
2204 not (Has_Null_Exclusion
(Parent
(Renamed
))
2205 or else (Can_Never_Be_Null
(Etype
(Renamed
))
2207 (Is_Formal_Subprogram
(Sub
)
2208 and then In_Generic_Body
(Current_Scope
))));
2209 end Null_Exclusion_Mismatch
;
2214 Ren_Formal
:= First_Formal
(Ren
);
2215 Sub_Formal
:= First_Formal
(Sub
);
2216 while Present
(Ren_Formal
) and then Present
(Sub_Formal
) loop
2217 if Null_Exclusion_Mismatch
(Ren_Formal
, Sub_Formal
) then
2218 Error_Msg_Sloc
:= Sloc
(Sub_Formal
);
2220 ("`NOT NULL` required for parameter &#",
2221 Ren_Formal
, Sub_Formal
);
2224 Next_Formal
(Ren_Formal
);
2225 Next_Formal
(Sub_Formal
);
2228 -- Return profile check
2230 if Nkind
(Parent
(Ren
)) = N_Function_Specification
2231 and then Nkind
(Parent
(Sub
)) = N_Function_Specification
2232 and then Null_Exclusion_Mismatch
(Ren
, Sub
)
2234 Error_Msg_Sloc
:= Sloc
(Sub
);
2235 Error_Msg_N
("return must specify `NOT NULL`#", Ren
);
2237 end Check_Null_Exclusion
;
2239 -------------------------------------
2240 -- Check_SPARK_Primitive_Operation --
2241 -------------------------------------
2243 procedure Check_SPARK_Primitive_Operation
(Subp_Id
: Entity_Id
) is
2244 Prag
: constant Node_Id
:= SPARK_Pragma
(Subp_Id
);
2248 -- Nothing to do when the subprogram is not subject to SPARK_Mode On
2249 -- because this check applies to SPARK code only.
2251 if not (Present
(Prag
)
2252 and then Get_SPARK_Mode_From_Annotation
(Prag
) = On
)
2256 -- Nothing to do when the subprogram is not a primitive operation
2258 elsif not Is_Primitive
(Subp_Id
) then
2262 Typ
:= Find_Dispatching_Type
(Subp_Id
);
2264 -- Nothing to do when the subprogram is a primitive operation of an
2271 -- At this point a renaming declaration introduces a new primitive
2272 -- operation for a tagged type.
2274 Error_Msg_Node_2
:= Typ
;
2276 ("subprogram renaming & cannot declare primitive for type & "
2277 & "(SPARK RM 6.1.1(3))", N
, Subp_Id
);
2278 end Check_SPARK_Primitive_Operation
;
2280 ---------------------------
2281 -- Freeze_Actual_Profile --
2282 ---------------------------
2284 procedure Freeze_Actual_Profile
is
2286 Has_Untagged_Inc
: Boolean;
2287 Instantiation_Node
: constant Node_Id
:= Parent
(N
);
2290 if Ada_Version
>= Ada_2012
then
2291 F
:= First_Formal
(Formal_Spec
);
2292 Has_Untagged_Inc
:= False;
2293 while Present
(F
) loop
2294 if Ekind
(Etype
(F
)) = E_Incomplete_Type
2295 and then not Is_Tagged_Type
(Etype
(F
))
2297 Has_Untagged_Inc
:= True;
2304 if Ekind
(Formal_Spec
) = E_Function
2305 and then not Is_Tagged_Type
(Etype
(Formal_Spec
))
2307 Has_Untagged_Inc
:= True;
2310 if not Has_Untagged_Inc
then
2311 F
:= First_Formal
(Old_S
);
2312 while Present
(F
) loop
2313 Freeze_Before
(Instantiation_Node
, Etype
(F
));
2315 if Is_Incomplete_Or_Private_Type
(Etype
(F
))
2316 and then No
(Underlying_Type
(Etype
(F
)))
2318 -- Exclude generic types, or types derived from them.
2319 -- They will be frozen in the enclosing instance.
2321 if Is_Generic_Type
(Etype
(F
))
2322 or else Is_Generic_Type
(Root_Type
(Etype
(F
)))
2326 -- A limited view of a type declared elsewhere needs no
2327 -- freezing actions.
2329 elsif From_Limited_With
(Etype
(F
)) then
2334 ("type& must be frozen before this point",
2335 Instantiation_Node
, Etype
(F
));
2343 end Freeze_Actual_Profile
;
2345 ---------------------------
2346 -- Has_Class_Wide_Actual --
2347 ---------------------------
2349 function Has_Class_Wide_Actual
return Boolean is
2351 Formal_Typ
: Entity_Id
;
2355 Formal
:= First_Formal
(Formal_Spec
);
2356 while Present
(Formal
) loop
2357 Formal_Typ
:= Etype
(Formal
);
2359 if Has_Unknown_Discriminants
(Formal_Typ
)
2360 and then not Is_Class_Wide_Type
(Formal_Typ
)
2361 and then Is_Class_Wide_Type
(Get_Instance_Of
(Formal_Typ
))
2366 Next_Formal
(Formal
);
2371 end Has_Class_Wide_Actual
;
2373 ------------------------------------------
2374 -- Handle_Instance_With_Class_Wide_Type --
2375 ------------------------------------------
2377 procedure Handle_Instance_With_Class_Wide_Type
2378 (Inst_Node
: Node_Id
;
2380 Wrapped_Prim
: out Entity_Id
;
2381 Wrap_Id
: out Entity_Id
)
2383 procedure Build_Class_Wide_Wrapper
2384 (Ren_Id
: Entity_Id
;
2385 Prim_Op
: Entity_Id
;
2386 Wrap_Id
: out Entity_Id
);
2387 -- Build a wrapper for the renaming Ren_Id of subprogram Prim_Op.
2389 procedure Find_Suitable_Candidate
2390 (Prim_Op
: out Entity_Id
;
2391 Is_CW_Prim
: out Boolean);
2392 -- Look for a suitable primitive to be wrapped (Prim_Op); Is_CW_Prim
2393 -- indicates that the found candidate is a class-wide primitive (to
2394 -- help the caller decide if the wrapper is required).
2396 ------------------------------
2397 -- Build_Class_Wide_Wrapper --
2398 ------------------------------
2400 procedure Build_Class_Wide_Wrapper
2401 (Ren_Id
: Entity_Id
;
2402 Prim_Op
: Entity_Id
;
2403 Wrap_Id
: out Entity_Id
)
2405 Loc
: constant Source_Ptr
:= Sloc
(N
);
2408 (Subp_Id
: Entity_Id
;
2409 Params
: List_Id
) return Node_Id
;
2410 -- Create a dispatching call to invoke routine Subp_Id with
2411 -- actuals built from the parameter specifications of list Params.
2413 function Build_Expr_Fun_Call
2414 (Subp_Id
: Entity_Id
;
2415 Params
: List_Id
) return Node_Id
;
2416 -- Create a dispatching call to invoke function Subp_Id with
2417 -- actuals built from the parameter specifications of list Params.
2418 -- Directly return the call, so that it can be used inside an
2419 -- expression function. This is a requirement of GNATprove mode.
2421 function Build_Spec
(Subp_Id
: Entity_Id
) return Node_Id
;
2422 -- Create a subprogram specification based on the subprogram
2423 -- profile of Subp_Id.
2430 (Subp_Id
: Entity_Id
;
2431 Params
: List_Id
) return Node_Id
2433 Actuals
: constant List_Id
:= New_List
;
2434 Call_Ref
: constant Node_Id
:= New_Occurrence_Of
(Subp_Id
, Loc
);
2438 -- Build the actual parameters of the call
2440 Formal
:= First
(Params
);
2441 while Present
(Formal
) loop
2443 Make_Identifier
(Loc
,
2444 Chars
(Defining_Identifier
(Formal
))));
2449 -- return Subp_Id (Actuals);
2451 if Ekind
(Subp_Id
) in E_Function | E_Operator
then
2453 Make_Simple_Return_Statement
(Loc
,
2455 Make_Function_Call
(Loc
,
2457 Parameter_Associations
=> Actuals
));
2460 -- Subp_Id (Actuals);
2464 Make_Procedure_Call_Statement
(Loc
,
2466 Parameter_Associations
=> Actuals
);
2470 -------------------------
2471 -- Build_Expr_Fun_Call --
2472 -------------------------
2474 function Build_Expr_Fun_Call
2475 (Subp_Id
: Entity_Id
;
2476 Params
: List_Id
) return Node_Id
2478 Actuals
: constant List_Id
:= New_List
;
2479 Call_Ref
: constant Node_Id
:= New_Occurrence_Of
(Subp_Id
, Loc
);
2483 pragma Assert
(Ekind
(Subp_Id
) in E_Function | E_Operator
);
2485 -- Build the actual parameters of the call
2487 Formal
:= First
(Params
);
2488 while Present
(Formal
) loop
2490 Make_Identifier
(Loc
,
2491 Chars
(Defining_Identifier
(Formal
))));
2496 -- Subp_Id (Actuals);
2499 Make_Function_Call
(Loc
,
2501 Parameter_Associations
=> Actuals
);
2502 end Build_Expr_Fun_Call
;
2508 function Build_Spec
(Subp_Id
: Entity_Id
) return Node_Id
is
2509 Params
: constant List_Id
:= Copy_Parameter_List
(Subp_Id
);
2510 Spec_Id
: constant Entity_Id
:=
2511 Make_Defining_Identifier
(Loc
,
2512 New_External_Name
(Chars
(Subp_Id
), 'R'));
2515 if Ekind
(Formal_Spec
) = E_Procedure
then
2517 Make_Procedure_Specification
(Loc
,
2518 Defining_Unit_Name
=> Spec_Id
,
2519 Parameter_Specifications
=> Params
);
2522 Make_Function_Specification
(Loc
,
2523 Defining_Unit_Name
=> Spec_Id
,
2524 Parameter_Specifications
=> Params
,
2525 Result_Definition
=>
2526 New_Copy_Tree
(Result_Definition
(Spec
)));
2532 Body_Decl
: Node_Id
;
2533 Spec_Decl
: Node_Id
;
2536 -- Start of processing for Build_Class_Wide_Wrapper
2539 pragma Assert
(not Error_Posted
(Nam
));
2541 -- Step 1: Create the declaration and the body of the wrapper,
2542 -- insert all the pieces into the tree.
2544 -- In GNATprove mode, create a function wrapper in the form of an
2545 -- expression function, so that an implicit postcondition relating
2546 -- the result of calling the wrapper function and the result of
2547 -- the dispatching call to the wrapped function is known during
2551 and then Ekind
(Ren_Id
) in E_Function | E_Operator
2553 New_Spec
:= Build_Spec
(Ren_Id
);
2555 Make_Expression_Function
(Loc
,
2556 Specification
=> New_Spec
,
2559 (Subp_Id
=> Prim_Op
,
2560 Params
=> Parameter_Specifications
(New_Spec
)));
2562 Wrap_Id
:= Defining_Entity
(Body_Decl
);
2564 -- Otherwise, create separate spec and body for the subprogram
2568 Make_Subprogram_Declaration
(Loc
,
2569 Specification
=> Build_Spec
(Ren_Id
));
2570 Insert_Before_And_Analyze
(N
, Spec_Decl
);
2572 Wrap_Id
:= Defining_Entity
(Spec_Decl
);
2575 Make_Subprogram_Body
(Loc
,
2576 Specification
=> Build_Spec
(Ren_Id
),
2577 Declarations
=> New_List
,
2578 Handled_Statement_Sequence
=>
2579 Make_Handled_Sequence_Of_Statements
(Loc
,
2580 Statements
=> New_List
(
2582 (Subp_Id
=> Prim_Op
,
2584 Parameter_Specifications
2585 (Specification
(Spec_Decl
))))));
2587 Set_Corresponding_Body
(Spec_Decl
, Defining_Entity
(Body_Decl
));
2590 Set_Is_Class_Wide_Wrapper
(Wrap_Id
);
2592 -- If the operator carries an Eliminated pragma, indicate that
2593 -- the wrapper is also to be eliminated, to prevent spurious
2594 -- errors when using gnatelim on programs that include box-
2595 -- defaulted initialization of equality operators.
2597 Set_Is_Eliminated
(Wrap_Id
, Is_Eliminated
(Prim_Op
));
2599 -- In GNATprove mode, insert the body in the tree for analysis
2601 if GNATprove_Mode
then
2602 Insert_Before_And_Analyze
(N
, Body_Decl
);
2605 -- The generated body does not freeze and must be analyzed when
2606 -- the class-wide wrapper is frozen. The body is only needed if
2607 -- expansion is enabled.
2609 if Expander_Active
then
2610 Append_Freeze_Action
(Wrap_Id
, Body_Decl
);
2613 -- Step 2: The subprogram renaming aliases the wrapper
2615 Rewrite
(Name
(N
), New_Occurrence_Of
(Wrap_Id
, Loc
));
2616 end Build_Class_Wide_Wrapper
;
2618 -----------------------------
2619 -- Find_Suitable_Candidate --
2620 -----------------------------
2622 procedure Find_Suitable_Candidate
2623 (Prim_Op
: out Entity_Id
;
2624 Is_CW_Prim
: out Boolean)
2626 Loc
: constant Source_Ptr
:= Sloc
(N
);
2628 function Find_Primitive
(Typ
: Entity_Id
) return Entity_Id
;
2629 -- Find a primitive subprogram of type Typ which matches the
2630 -- profile of the renaming declaration.
2632 procedure Interpretation_Error
(Subp_Id
: Entity_Id
);
2633 -- Emit a continuation error message suggesting subprogram Subp_Id
2634 -- as a possible interpretation.
2636 function Is_Intrinsic_Equality
2637 (Subp_Id
: Entity_Id
) return Boolean;
2638 -- Determine whether subprogram Subp_Id denotes the intrinsic "="
2641 function Is_Suitable_Candidate
2642 (Subp_Id
: Entity_Id
) return Boolean;
2643 -- Determine whether subprogram Subp_Id is a suitable candidate
2644 -- for the role of a wrapped subprogram.
2646 --------------------
2647 -- Find_Primitive --
2648 --------------------
2650 function Find_Primitive
(Typ
: Entity_Id
) return Entity_Id
is
2651 procedure Replace_Parameter_Types
(Spec
: Node_Id
);
2652 -- Given a specification Spec, replace all class-wide parameter
2653 -- types with reference to type Typ.
2655 -----------------------------
2656 -- Replace_Parameter_Types --
2657 -----------------------------
2659 procedure Replace_Parameter_Types
(Spec
: Node_Id
) is
2661 Formal_Id
: Entity_Id
;
2662 Formal_Typ
: Node_Id
;
2665 Formal
:= First
(Parameter_Specifications
(Spec
));
2666 while Present
(Formal
) loop
2667 Formal_Id
:= Defining_Identifier
(Formal
);
2668 Formal_Typ
:= Parameter_Type
(Formal
);
2670 -- Create a new entity for each class-wide formal to
2671 -- prevent aliasing with the original renaming. Replace
2672 -- the type of such a parameter with the candidate type.
2674 if Nkind
(Formal_Typ
) = N_Identifier
2675 and then Is_Class_Wide_Type
(Etype
(Formal_Typ
))
2677 Set_Defining_Identifier
(Formal
,
2678 Make_Defining_Identifier
(Loc
, Chars
(Formal_Id
)));
2680 Set_Parameter_Type
(Formal
,
2681 New_Occurrence_Of
(Typ
, Loc
));
2686 end Replace_Parameter_Types
;
2690 Alt_Ren
: constant Node_Id
:= New_Copy_Tree
(N
);
2691 Alt_Nam
: constant Node_Id
:= Name
(Alt_Ren
);
2692 Alt_Spec
: constant Node_Id
:= Specification
(Alt_Ren
);
2693 Subp_Id
: Entity_Id
;
2695 -- Start of processing for Find_Primitive
2698 -- Each attempt to find a suitable primitive of a particular
2699 -- type operates on its own copy of the original renaming.
2700 -- As a result the original renaming is kept decoration and
2701 -- side-effect free.
2703 -- Inherit the overloaded status of the renamed subprogram name
2705 if Is_Overloaded
(Nam
) then
2706 Set_Is_Overloaded
(Alt_Nam
);
2707 Save_Interps
(Nam
, Alt_Nam
);
2710 -- The copied renaming is hidden from visibility to prevent the
2711 -- pollution of the enclosing context.
2713 Set_Defining_Unit_Name
(Alt_Spec
, Make_Temporary
(Loc
, 'R'));
2715 -- The types of all class-wide parameters must be changed to
2716 -- the candidate type.
2718 Replace_Parameter_Types
(Alt_Spec
);
2720 -- Try to find a suitable primitive that matches the altered
2721 -- profile of the renaming specification.
2726 Nam
=> Name
(Alt_Ren
),
2727 New_S
=> Analyze_Subprogram_Specification
(Alt_Spec
),
2728 Is_Actual
=> Is_Actual
);
2730 -- Do not return Any_Id if the resolution of the altered
2731 -- profile failed as this complicates further checks on
2732 -- the caller side; return Empty instead.
2734 if Subp_Id
= Any_Id
then
2741 --------------------------
2742 -- Interpretation_Error --
2743 --------------------------
2745 procedure Interpretation_Error
(Subp_Id
: Entity_Id
) is
2747 Error_Msg_Sloc
:= Sloc
(Subp_Id
);
2749 if Is_Internal
(Subp_Id
) then
2751 ("\\possible interpretation: predefined & #",
2755 ("\\possible interpretation: & defined #",
2758 end Interpretation_Error
;
2760 ---------------------------
2761 -- Is_Intrinsic_Equality --
2762 ---------------------------
2764 function Is_Intrinsic_Equality
(Subp_Id
: Entity_Id
) return Boolean
2768 Ekind
(Subp_Id
) = E_Operator
2769 and then Chars
(Subp_Id
) = Name_Op_Eq
2770 and then Is_Intrinsic_Subprogram
(Subp_Id
);
2771 end Is_Intrinsic_Equality
;
2773 ---------------------------
2774 -- Is_Suitable_Candidate --
2775 ---------------------------
2777 function Is_Suitable_Candidate
(Subp_Id
: Entity_Id
) return Boolean
2780 if No
(Subp_Id
) then
2783 -- An intrinsic subprogram is never a good candidate. This
2784 -- is an indication of a missing primitive, either defined
2785 -- directly or inherited from a parent tagged type.
2787 elsif Is_Intrinsic_Subprogram
(Subp_Id
) then
2793 end Is_Suitable_Candidate
;
2797 Actual_Typ
: Entity_Id
:= Empty
;
2798 -- The actual class-wide type for Formal_Typ
2800 CW_Prim_OK
: Boolean;
2801 CW_Prim_Op
: Entity_Id
;
2802 -- The class-wide subprogram (if available) that corresponds to
2803 -- the renamed generic formal subprogram.
2805 Formal_Typ
: Entity_Id
:= Empty
;
2806 -- The generic formal type with unknown discriminants
2808 Root_Prim_OK
: Boolean;
2809 Root_Prim_Op
: Entity_Id
;
2810 -- The root type primitive (if available) that corresponds to the
2811 -- renamed generic formal subprogram.
2813 Root_Typ
: Entity_Id
:= Empty
;
2814 -- The root type of Actual_Typ
2818 -- Start of processing for Find_Suitable_Candidate
2821 pragma Assert
(not Error_Posted
(Nam
));
2824 Is_CW_Prim
:= False;
2826 -- Analyze the renamed name, but do not resolve it. The resolution
2827 -- is completed once a suitable subprogram is found.
2831 -- When the renamed name denotes the intrinsic operator equals,
2832 -- the name must be treated as overloaded. This allows for a
2833 -- potential match against the root type's predefined equality
2836 if Is_Intrinsic_Equality
(Entity
(Nam
)) then
2837 Set_Is_Overloaded
(Nam
);
2838 Collect_Interps
(Nam
);
2841 -- Step 1: Find the generic formal type and its corresponding
2842 -- class-wide actual type from the renamed generic formal
2845 Formal
:= First_Formal
(Formal_Spec
);
2846 while Present
(Formal
) loop
2847 if Has_Unknown_Discriminants
(Etype
(Formal
))
2848 and then not Is_Class_Wide_Type
(Etype
(Formal
))
2849 and then Is_Class_Wide_Type
(Get_Instance_Of
(Etype
(Formal
)))
2851 Formal_Typ
:= Etype
(Formal
);
2852 Actual_Typ
:= Base_Type
(Get_Instance_Of
(Formal_Typ
));
2853 Root_Typ
:= Root_Type
(Actual_Typ
);
2857 Next_Formal
(Formal
);
2860 -- The specification of the generic formal subprogram should
2861 -- always contain a formal type with unknown discriminants whose
2862 -- actual is a class-wide type; otherwise this indicates a failure
2863 -- in function Has_Class_Wide_Actual.
2865 pragma Assert
(Present
(Formal_Typ
));
2867 -- Step 2: Find the proper class-wide subprogram or primitive
2868 -- that corresponds to the renamed generic formal subprogram.
2870 CW_Prim_Op
:= Find_Primitive
(Actual_Typ
);
2871 CW_Prim_OK
:= Is_Suitable_Candidate
(CW_Prim_Op
);
2872 Root_Prim_Op
:= Find_Primitive
(Root_Typ
);
2873 Root_Prim_OK
:= Is_Suitable_Candidate
(Root_Prim_Op
);
2875 -- The class-wide actual type has two subprograms that correspond
2876 -- to the renamed generic formal subprogram:
2878 -- with procedure Prim_Op (Param : Formal_Typ);
2880 -- procedure Prim_Op (Param : Actual_Typ); -- may be inherited
2881 -- procedure Prim_Op (Param : Actual_Typ'Class);
2883 -- Even though the declaration of the two subprograms is legal, a
2884 -- call to either one is ambiguous and therefore illegal.
2886 if CW_Prim_OK
and Root_Prim_OK
then
2888 -- A user-defined primitive has precedence over a predefined
2891 if Is_Internal
(CW_Prim_Op
)
2892 and then not Is_Internal
(Root_Prim_Op
)
2894 Prim_Op
:= Root_Prim_Op
;
2896 elsif Is_Internal
(Root_Prim_Op
)
2897 and then not Is_Internal
(CW_Prim_Op
)
2899 Prim_Op
:= CW_Prim_Op
;
2902 elsif CW_Prim_Op
= Root_Prim_Op
then
2903 Prim_Op
:= Root_Prim_Op
;
2905 -- The two subprograms are legal but the class-wide subprogram
2906 -- is a class-wide wrapper built for a previous instantiation;
2907 -- the wrapper has precedence.
2909 elsif Present
(Alias
(CW_Prim_Op
))
2910 and then Is_Class_Wide_Wrapper
(Ultimate_Alias
(CW_Prim_Op
))
2912 Prim_Op
:= CW_Prim_Op
;
2915 -- Otherwise both candidate subprograms are user-defined and
2920 ("ambiguous actual for generic subprogram &",
2922 Interpretation_Error
(Root_Prim_Op
);
2923 Interpretation_Error
(CW_Prim_Op
);
2927 elsif CW_Prim_OK
and not Root_Prim_OK
then
2928 Prim_Op
:= CW_Prim_Op
;
2931 elsif not CW_Prim_OK
and Root_Prim_OK
then
2932 Prim_Op
:= Root_Prim_Op
;
2934 -- An intrinsic equality may act as a suitable candidate in the
2935 -- case of a null type extension where the parent's equality
2936 -- is hidden. A call to an intrinsic equality is expanded as
2939 elsif Present
(Root_Prim_Op
)
2940 and then Is_Intrinsic_Equality
(Root_Prim_Op
)
2942 Prim_Op
:= Root_Prim_Op
;
2944 -- Otherwise there are no candidate subprograms. Let the caller
2945 -- diagnose the error.
2951 -- At this point resolution has taken place and the name is no
2952 -- longer overloaded. Mark the primitive as referenced.
2954 Set_Is_Overloaded
(Name
(N
), False);
2955 Set_Referenced
(Prim_Op
);
2956 end Find_Suitable_Candidate
;
2960 Is_CW_Prim
: Boolean;
2962 -- Start of processing for Handle_Instance_With_Class_Wide_Type
2965 Wrapped_Prim
:= Empty
;
2968 -- Ada 2012 (AI05-0071): A generic/instance scenario involving a
2969 -- formal type with unknown discriminants and a generic primitive
2970 -- operation of the said type with a box require special processing
2971 -- when the actual is a class-wide type:
2974 -- type Formal_Typ (<>) is private;
2975 -- with procedure Prim_Op (Param : Formal_Typ) is <>;
2976 -- package Gen is ...
2978 -- package Inst is new Gen (Actual_Typ'Class);
2980 -- In this case the general renaming mechanism used in the prologue
2981 -- of an instance no longer applies:
2983 -- procedure Prim_Op (Param : Formal_Typ) renames Prim_Op;
2985 -- The above is replaced the following wrapper/renaming combination:
2987 -- procedure Wrapper (Param : Formal_Typ) is -- wrapper
2989 -- Prim_Op (Param); -- primitive
2992 -- procedure Prim_Op (Param : Formal_Typ) renames Wrapper;
2994 -- This transformation applies only if there is no explicit visible
2995 -- class-wide operation at the point of the instantiation. Ren_Id is
2996 -- the entity of the renaming declaration. When the transformation
2997 -- applies, Wrapped_Prim is the entity of the wrapped primitive.
2999 if Box_Present
(Inst_Node
) then
3000 Find_Suitable_Candidate
3001 (Prim_Op
=> Wrapped_Prim
,
3002 Is_CW_Prim
=> Is_CW_Prim
);
3004 if Present
(Wrapped_Prim
) then
3005 if not Is_CW_Prim
then
3006 Build_Class_Wide_Wrapper
(Ren_Id
, Wrapped_Prim
, Wrap_Id
);
3008 -- Small optimization: When the candidate is a class-wide
3009 -- subprogram we don't build the wrapper; we modify the
3010 -- renaming declaration to directly map the actual to the
3011 -- generic formal and discard the candidate.
3014 Rewrite
(Nam
, New_Occurrence_Of
(Wrapped_Prim
, Sloc
(N
)));
3015 Wrapped_Prim
:= Empty
;
3019 -- Ada 2022 (AI12-0165, RM 12.6(8.5/3)): The actual subprogram for a
3020 -- formal_abstract_subprogram_declaration shall be:
3021 -- a) a dispatching operation of the controlling type; or
3022 -- b) if the controlling type is a formal type, and the actual
3023 -- type corresponding to that formal type is a specific type T,
3024 -- a dispatching operation of type T; or
3025 -- c) if the controlling type is a formal type, and the actual
3026 -- type is a class-wide type T'Class, an implicitly declared
3027 -- subprogram corresponding to a primitive operation of type T.
3029 elsif Nkind
(Inst_Node
) = N_Formal_Abstract_Subprogram_Declaration
3030 and then Is_Entity_Name
(Nam
)
3032 Find_Suitable_Candidate
3033 (Prim_Op
=> Wrapped_Prim
,
3034 Is_CW_Prim
=> Is_CW_Prim
);
3036 if Present
(Wrapped_Prim
) then
3038 -- Cases (a) and (b); see previous description.
3040 if not Is_CW_Prim
then
3041 Build_Class_Wide_Wrapper
(Ren_Id
, Wrapped_Prim
, Wrap_Id
);
3043 -- Case (c); see previous description.
3045 -- Implicit operations of T'Class for subtype declarations
3046 -- are built by Derive_Subprogram, and their Alias attribute
3047 -- references the primitive operation of T.
3049 elsif not Comes_From_Source
(Wrapped_Prim
)
3050 and then Nkind
(Parent
(Wrapped_Prim
)) = N_Subtype_Declaration
3051 and then Present
(Alias
(Wrapped_Prim
))
3053 -- We don't need to build the wrapper; we modify the
3054 -- renaming declaration to directly map the actual to
3055 -- the generic formal and discard the candidate.
3058 New_Occurrence_Of
(Alias
(Wrapped_Prim
), Sloc
(N
)));
3059 Wrapped_Prim
:= Empty
;
3061 -- Legality rules do not apply; discard the candidate.
3064 Wrapped_Prim
:= Empty
;
3068 end Handle_Instance_With_Class_Wide_Type
;
3070 -------------------------
3071 -- Original_Subprogram --
3072 -------------------------
3074 function Original_Subprogram
(Subp
: Entity_Id
) return Entity_Id
is
3075 Orig_Decl
: Node_Id
;
3076 Orig_Subp
: Entity_Id
;
3079 -- First case: renamed entity is itself a renaming
3081 if Present
(Alias
(Subp
)) then
3082 return Alias
(Subp
);
3084 elsif Nkind
(Unit_Declaration_Node
(Subp
)) = N_Subprogram_Declaration
3085 and then Present
(Corresponding_Body
(Unit_Declaration_Node
(Subp
)))
3087 -- Check if renamed entity is a renaming_as_body
3090 Unit_Declaration_Node
3091 (Corresponding_Body
(Unit_Declaration_Node
(Subp
)));
3093 if Nkind
(Orig_Decl
) = N_Subprogram_Renaming_Declaration
then
3094 Orig_Subp
:= Entity
(Name
(Orig_Decl
));
3096 if Orig_Subp
= Rename_Spec
then
3098 -- Circularity detected
3103 return (Original_Subprogram
(Orig_Subp
));
3111 end Original_Subprogram
;
3115 CW_Actual
: constant Boolean := Has_Class_Wide_Actual
;
3116 -- Ada 2012 (AI05-071, AI05-0131) and Ada 2022 (AI12-0165): True if the
3117 -- renaming is for a defaulted formal subprogram when the actual for a
3118 -- related formal type is class-wide.
3120 Inst_Node
: Node_Id
:= Empty
;
3121 New_S
: Entity_Id
:= Empty
;
3122 Wrapped_Prim
: Entity_Id
:= Empty
;
3124 -- Start of processing for Analyze_Subprogram_Renaming
3127 -- We must test for the attribute renaming case before the Analyze
3128 -- call because otherwise Sem_Attr will complain that the attribute
3129 -- is missing an argument when it is analyzed.
3131 if Nkind
(Nam
) = N_Attribute_Reference
then
3133 -- In the case of an abstract formal subprogram association, rewrite
3134 -- an actual given by a stream or Put_Image attribute as the name of
3135 -- the corresponding stream or Put_Image primitive of the type.
3137 -- In a generic context the stream and Put_Image operations are not
3138 -- generated, and this must be treated as a normal attribute
3139 -- reference, to be expanded in subsequent instantiations.
3142 and then Is_Abstract_Subprogram
(Formal_Spec
)
3143 and then Expander_Active
3146 Prefix_Type
: constant Entity_Id
:= Entity
(Prefix
(Nam
));
3150 -- The class-wide forms of the stream and Put_Image attributes
3151 -- are not primitive dispatching operations (even though they
3152 -- internally dispatch).
3154 if Is_Class_Wide_Type
(Prefix_Type
) then
3156 ("attribute must be a primitive dispatching operation",
3161 -- Retrieve the primitive subprogram associated with the
3162 -- attribute. This can only be a stream attribute, since those
3163 -- are the only ones that are dispatching (and the actual for
3164 -- an abstract formal subprogram must be dispatching
3167 case Attribute_Name
(Nam
) is
3170 Find_Optional_Prim_Op
(Prefix_Type
, TSS_Stream_Input
);
3174 Find_Optional_Prim_Op
(Prefix_Type
, TSS_Stream_Output
);
3178 Find_Optional_Prim_Op
(Prefix_Type
, TSS_Stream_Read
);
3182 Find_Optional_Prim_Op
(Prefix_Type
, TSS_Stream_Write
);
3184 when Name_Put_Image
=>
3186 Find_Optional_Prim_Op
(Prefix_Type
, TSS_Put_Image
);
3190 ("attribute must be a primitive dispatching operation",
3195 -- If no stream operation was found, and the type is limited,
3196 -- the user should have defined one. This rule does not apply
3200 and then Attribute_Name
(Nam
) /= Name_Put_Image
3202 if Is_Limited_Type
(Prefix_Type
) then
3204 ("stream operation not defined for type&",
3208 -- Otherwise, compiler should have generated default
3211 raise Program_Error
;
3215 -- Rewrite the attribute into the name of its corresponding
3216 -- primitive dispatching subprogram. We can then proceed with
3217 -- the usual processing for subprogram renamings.
3220 Prim_Name
: constant Node_Id
:=
3221 Make_Identifier
(Sloc
(Nam
),
3222 Chars
=> Chars
(Prim
));
3224 Set_Entity
(Prim_Name
, Prim
);
3225 Rewrite
(Nam
, Prim_Name
);
3230 -- Normal processing for a renaming of an attribute
3233 Attribute_Renaming
(N
);
3238 -- Check whether this declaration corresponds to the instantiation of a
3239 -- formal subprogram.
3241 -- If this is an instantiation, the corresponding actual is frozen and
3242 -- error messages can be made more precise. If this is a default
3243 -- subprogram, the entity is already established in the generic, and is
3244 -- not retrieved by visibility. If it is a default with a box, the
3245 -- candidate interpretations, if any, have been collected when building
3246 -- the renaming declaration. If overloaded, the proper interpretation is
3247 -- determined in Find_Renamed_Entity. If the entity is an operator,
3248 -- Find_Renamed_Entity applies additional visibility checks.
3251 Inst_Node
:= Unit_Declaration_Node
(Formal_Spec
);
3253 -- Ada 2012 (AI05-0071) and Ada 2022 (AI12-0165): when the actual
3254 -- type is a class-wide type T'Class we may need to wrap a primitive
3255 -- operation of T. Search for the wrapped primitive and (if required)
3256 -- build a wrapper whose body consists of a dispatching call to the
3257 -- wrapped primitive of T, with its formal parameters as the actual
3260 if CW_Actual
and then
3262 -- Ada 2012 (AI05-0071): Check whether the renaming is for a
3263 -- defaulted actual subprogram with a class-wide actual.
3265 (Box_Present
(Inst_Node
)
3269 -- Ada 2022 (AI12-0165): Check whether the renaming is for a formal
3270 -- abstract subprogram declaration with a class-wide actual.
3272 (Nkind
(Inst_Node
) = N_Formal_Abstract_Subprogram_Declaration
3273 and then Is_Entity_Name
(Nam
)))
3275 New_S
:= Analyze_Subprogram_Specification
(Spec
);
3277 -- Do not attempt to build the wrapper if the renaming is in error
3279 if not Error_Posted
(Nam
) then
3280 Handle_Instance_With_Class_Wide_Type
3281 (Inst_Node
=> Inst_Node
,
3283 Wrapped_Prim
=> Wrapped_Prim
,
3286 -- If several candidates were found, then we reported the
3287 -- ambiguity; stop processing the renaming declaration to
3288 -- avoid reporting further (spurious) errors.
3290 if Error_Posted
(Spec
) then
3297 if Present
(Wrapped_Prim
) then
3299 -- When the wrapper is built, the subprogram renaming aliases
3304 pragma Assert
(Old_S
= Entity
(Nam
)
3305 and then Is_Class_Wide_Wrapper
(Old_S
));
3307 -- The subprogram renaming declaration may become Ghost if it
3308 -- renames a wrapper of a Ghost entity.
3310 Mark_Ghost_Renaming
(N
, Wrapped_Prim
);
3312 elsif Is_Entity_Name
(Nam
)
3313 and then Present
(Entity
(Nam
))
3314 and then not Comes_From_Source
(Nam
)
3315 and then not Is_Overloaded
(Nam
)
3317 Old_S
:= Entity
(Nam
);
3319 -- The subprogram renaming declaration may become Ghost if it
3320 -- renames a Ghost entity.
3322 Mark_Ghost_Renaming
(N
, Old_S
);
3324 New_S
:= Analyze_Subprogram_Specification
(Spec
);
3328 if Ekind
(Old_S
) = E_Operator
then
3332 if Box_Present
(Inst_Node
) then
3333 Old_S
:= Find_Renamed_Entity
(N
, Name
(N
), New_S
, Is_Actual
);
3335 -- If there is an immediately visible homonym of the operator
3336 -- and the declaration has a default, this is worth a warning
3337 -- because the user probably did not intend to get the pre-
3338 -- defined operator, visible in the generic declaration. To
3339 -- find if there is an intended candidate, analyze the renaming
3340 -- again in the current context.
3342 elsif Scope
(Old_S
) = Standard_Standard
3343 and then Present
(Default_Name
(Inst_Node
))
3346 Decl
: constant Node_Id
:= New_Copy_Tree
(N
);
3350 Set_Entity
(Name
(Decl
), Empty
);
3351 Analyze
(Name
(Decl
));
3353 Find_Renamed_Entity
(Decl
, Name
(Decl
), New_S
, True);
3356 and then In_Open_Scopes
(Scope
(Hidden
))
3357 and then Is_Immediately_Visible
(Hidden
)
3358 and then Comes_From_Source
(Hidden
)
3359 and then Hidden
/= Old_S
3361 Error_Msg_Sloc
:= Sloc
(Hidden
);
3363 ("default subprogram is resolved in the generic "
3364 & "declaration (RM 12.6(17))??", N
);
3365 Error_Msg_NE
("\and will not use & #??", N
, Hidden
);
3374 -- The subprogram renaming declaration may become Ghost if it
3375 -- renames a Ghost entity.
3377 if Is_Entity_Name
(Nam
) then
3378 Mark_Ghost_Renaming
(N
, Entity
(Nam
));
3381 New_S
:= Analyze_Subprogram_Specification
(Spec
);
3385 -- Renamed entity must be analyzed first, to avoid being hidden by
3386 -- new name (which might be the same in a generic instance).
3390 -- The subprogram renaming declaration may become Ghost if it renames
3393 if Is_Entity_Name
(Nam
) then
3394 Mark_Ghost_Renaming
(N
, Entity
(Nam
));
3397 -- The renaming defines a new overloaded entity, which is analyzed
3398 -- like a subprogram declaration.
3400 New_S
:= Analyze_Subprogram_Specification
(Spec
);
3403 if Current_Scope
/= Standard_Standard
then
3404 Set_Is_Pure
(New_S
, Is_Pure
(Current_Scope
));
3407 -- Set SPARK mode from current context
3409 Set_SPARK_Pragma
(New_S
, SPARK_Mode_Pragma
);
3410 Set_SPARK_Pragma_Inherited
(New_S
);
3412 Rename_Spec
:= Find_Corresponding_Spec
(N
);
3414 -- Case of Renaming_As_Body
3416 if Present
(Rename_Spec
) then
3417 Check_Previous_Null_Procedure
(N
, Rename_Spec
);
3419 -- Renaming declaration is the completion of the declaration of
3420 -- Rename_Spec. We build an actual body for it at the freezing point.
3422 Set_Corresponding_Spec
(N
, Rename_Spec
);
3424 -- Deal with special case of stream functions of abstract types
3427 if Nkind
(Unit_Declaration_Node
(Rename_Spec
)) =
3428 N_Abstract_Subprogram_Declaration
3430 -- Input stream functions are abstract if the object type is
3431 -- abstract. Similarly, all default stream functions for an
3432 -- interface type are abstract. However, these subprograms may
3433 -- receive explicit declarations in representation clauses, making
3434 -- the attribute subprograms usable as defaults in subsequent
3436 -- In this case we rewrite the declaration to make the subprogram
3437 -- non-abstract. We remove the previous declaration, and insert
3438 -- the new one at the point of the renaming, to prevent premature
3439 -- access to unfrozen types. The new declaration reuses the
3440 -- specification of the previous one, and must not be analyzed.
3443 (Is_Primitive
(Entity
(Nam
))
3445 Is_Abstract_Type
(Find_Dispatching_Type
(Entity
(Nam
))));
3447 Old_Decl
: constant Node_Id
:=
3448 Unit_Declaration_Node
(Rename_Spec
);
3449 New_Decl
: constant Node_Id
:=
3450 Make_Subprogram_Declaration
(Sloc
(N
),
3452 Relocate_Node
(Specification
(Old_Decl
)));
3455 Insert_After
(N
, New_Decl
);
3456 Set_Is_Abstract_Subprogram
(Rename_Spec
, False);
3457 Set_Analyzed
(New_Decl
);
3461 Set_Corresponding_Body
(Unit_Declaration_Node
(Rename_Spec
), New_S
);
3463 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
3464 Error_Msg_N
("(Ada 83) renaming cannot serve as a body", N
);
3467 Set_Convention
(New_S
, Convention
(Rename_Spec
));
3468 Check_Fully_Conformant
(New_S
, Rename_Spec
);
3469 Set_Public_Status
(New_S
);
3471 if No_Return
(Rename_Spec
)
3472 and then not No_Return
(Entity
(Nam
))
3475 ("renamed subprogram & must be No_Return", N
, Entity
(Nam
));
3477 ("\since renaming subprogram is No_Return (RM 6.5.1(7/2))", N
);
3480 -- The specification does not introduce new formals, but only
3481 -- repeats the formals of the original subprogram declaration.
3482 -- For cross-reference purposes, and for refactoring tools, we
3483 -- treat the formals of the renaming declaration as body formals.
3485 Reference_Body_Formals
(Rename_Spec
, New_S
);
3487 -- Indicate that the entity in the declaration functions like the
3488 -- corresponding body, and is not a new entity. The body will be
3489 -- constructed later at the freeze point, so indicate that the
3490 -- completion has not been seen yet.
3492 Reinit_Field_To_Zero
(New_S
, F_Has_Out_Or_In_Out_Parameter
,
3493 Old_Ekind
=> (E_Function | E_Procedure
=> True, others => False));
3494 Reinit_Field_To_Zero
(New_S
, F_Needs_No_Actuals
);
3495 Reinit_Field_To_Zero
(New_S
, F_Is_Predicate_Function
);
3496 Reinit_Field_To_Zero
(New_S
, F_Protected_Subprogram
);
3497 Reinit_Field_To_Zero
(New_S
, F_Is_Inlined_Always
);
3498 Reinit_Field_To_Zero
(New_S
, F_Is_Generic_Actual_Subprogram
);
3499 Mutate_Ekind
(New_S
, E_Subprogram_Body
);
3500 New_S
:= Rename_Spec
;
3501 Set_Has_Completion
(Rename_Spec
, False);
3503 -- Ada 2005: check overriding indicator
3505 if Present
(Overridden_Operation
(Rename_Spec
)) then
3506 if Must_Not_Override
(Specification
(N
)) then
3508 ("subprogram& overrides inherited operation",
3512 and then not Must_Override
(Specification
(N
))
3514 Style
.Missing_Overriding
(N
, Rename_Spec
);
3517 elsif Must_Override
(Specification
(N
))
3518 and then not Can_Override_Operator
(Rename_Spec
)
3520 Error_Msg_NE
("subprogram& is not overriding", N
, Rename_Spec
);
3523 -- AI12-0132: a renames-as-body freezes the expression of any
3524 -- expression function that it renames.
3526 if Is_Entity_Name
(Nam
)
3527 and then Is_Expression_Function
(Entity
(Nam
))
3528 and then not Inside_A_Generic
3531 (Def_Id
=> Entity
(Nam
),
3532 Typ
=> Etype
(Entity
(Nam
)),
3535 (Original_Node
(Unit_Declaration_Node
(Entity
(Nam
)))),
3539 -- Normal subprogram renaming (not renaming as body)
3542 Generate_Definition
(New_S
);
3543 New_Overloaded_Entity
(New_S
);
3545 if not (Is_Entity_Name
(Nam
)
3546 and then Is_Intrinsic_Subprogram
(Entity
(Nam
)))
3548 Check_Delayed_Subprogram
(New_S
);
3551 -- Verify that a SPARK renaming does not declare a primitive
3552 -- operation of a tagged type.
3554 Check_SPARK_Primitive_Operation
(New_S
);
3557 -- There is no need for elaboration checks on the new entity, which may
3558 -- be called before the next freezing point where the body will appear.
3559 -- Elaboration checks refer to the real entity, not the one created by
3560 -- the renaming declaration.
3562 Set_Kill_Elaboration_Checks
(New_S
, True);
3564 -- If we had a previous error, indicate a completion is present to stop
3565 -- junk cascaded messages, but don't take any further action.
3567 if Etype
(Nam
) = Any_Type
then
3568 Set_Has_Completion
(New_S
);
3571 -- Case where name has the form of a selected component
3573 elsif Nkind
(Nam
) = N_Selected_Component
then
3575 -- A name which has the form A.B can designate an entry of task A, a
3576 -- protected operation of protected object A, or finally a primitive
3577 -- operation of object A. In the later case, A is an object of some
3578 -- tagged type, or an access type that denotes one such. To further
3579 -- distinguish these cases, note that the scope of a task entry or
3580 -- protected operation is type of the prefix.
3582 -- The prefix could be an overloaded function call that returns both
3583 -- kinds of operations. This overloading pathology is left to the
3584 -- dedicated reader ???
3587 T
: constant Entity_Id
:= Etype
(Prefix
(Nam
));
3595 and then Is_Tagged_Type
(Designated_Type
(T
))))
3596 and then Scope
(Entity
(Selector_Name
(Nam
))) /= T
3598 Analyze_Renamed_Primitive_Operation
3599 (N
, New_S
, Present
(Rename_Spec
));
3603 -- Renamed entity is an entry or protected operation. For those
3604 -- cases an explicit body is built (at the point of freezing of
3605 -- this entity) that contains a call to the renamed entity.
3607 -- This is not allowed for renaming as body if the renamed
3608 -- spec is already frozen (see RM 8.5.4(5) for details).
3610 if Present
(Rename_Spec
) and then Is_Frozen
(Rename_Spec
) then
3612 ("renaming-as-body cannot rename entry as subprogram", N
);
3614 ("\since & is already frozen (RM 8.5.4(5))",
3617 Analyze_Renamed_Entry
(N
, New_S
, Present
(Rename_Spec
));
3624 -- Case where name is an explicit dereference X.all
3626 elsif Nkind
(Nam
) = N_Explicit_Dereference
then
3628 -- Renamed entity is designated by access_to_subprogram expression.
3629 -- Must build body to encapsulate call, as in the entry case.
3631 Analyze_Renamed_Dereference
(N
, New_S
, Present
(Rename_Spec
));
3634 -- Indexed component
3636 elsif Nkind
(Nam
) = N_Indexed_Component
then
3637 Analyze_Renamed_Family_Member
(N
, New_S
, Present
(Rename_Spec
));
3640 -- Character literal
3642 elsif Nkind
(Nam
) = N_Character_Literal
then
3643 Analyze_Renamed_Character
(N
, New_S
, Present
(Rename_Spec
));
3646 -- Only remaining case is where we have a non-entity name, or a renaming
3647 -- of some other non-overloadable entity.
3649 elsif not Is_Entity_Name
(Nam
)
3650 or else not Is_Overloadable
(Entity
(Nam
))
3652 -- Do not mention the renaming if it comes from an instance
3654 if not Is_Actual
then
3655 Error_Msg_N
("expect valid subprogram name in renaming", N
);
3657 Error_Msg_NE
("no visible subprogram for formal&", N
, Nam
);
3663 -- Find the renamed entity that matches the given specification. Disable
3664 -- Ada_83 because there is no requirement of full conformance between
3665 -- renamed entity and new entity, even though the same circuit is used.
3667 -- This is a bit of an odd case, which introduces a really irregular use
3668 -- of Ada_Version[_Explicit]. Would be nice to find cleaner way to do
3671 Ada_Version
:= Ada_Version_Type
'Max (Ada_Version
, Ada_95
);
3672 Ada_Version_Pragma
:= Empty
;
3673 Ada_Version_Explicit
:= Ada_Version
;
3676 Old_S
:= Find_Renamed_Entity
(N
, Name
(N
), New_S
, Is_Actual
);
3678 -- The visible operation may be an inherited abstract operation that
3679 -- was overridden in the private part, in which case a call will
3680 -- dispatch to the overriding operation. Use the overriding one in
3681 -- the renaming declaration, to prevent spurious errors below.
3683 if Is_Overloadable
(Old_S
)
3684 and then Is_Abstract_Subprogram
(Old_S
)
3685 and then No
(DTC_Entity
(Old_S
))
3686 and then Present
(Alias
(Old_S
))
3687 and then not Is_Abstract_Subprogram
(Alias
(Old_S
))
3688 and then Present
(Overridden_Operation
(Alias
(Old_S
)))
3690 Old_S
:= Alias
(Old_S
);
3693 -- When the renamed subprogram is overloaded and used as an actual
3694 -- of a generic, its entity is set to the first available homonym.
3695 -- We must first disambiguate the name, then set the proper entity.
3697 if Is_Actual
and then Is_Overloaded
(Nam
) then
3698 Set_Entity
(Nam
, Old_S
);
3702 -- Most common case: subprogram renames subprogram. No body is generated
3703 -- in this case, so we must indicate the declaration is complete as is.
3704 -- and inherit various attributes of the renamed subprogram.
3706 if No
(Rename_Spec
) then
3707 Set_Has_Completion
(New_S
);
3708 Set_Is_Imported
(New_S
, Is_Imported
(Entity
(Nam
)));
3709 Set_Is_Pure
(New_S
, Is_Pure
(Entity
(Nam
)));
3710 Set_Is_Preelaborated
(New_S
, Is_Preelaborated
(Entity
(Nam
)));
3712 -- Ada 2005 (AI-423): Check the consistency of null exclusions
3713 -- between a subprogram and its correct renaming.
3715 -- Note: the Any_Id check is a guard that prevents compiler crashes
3716 -- when performing a null exclusion check between a renaming and a
3717 -- renamed subprogram that has been found to be illegal.
3719 if Ada_Version
>= Ada_2005
and then Entity
(Nam
) /= Any_Id
then
3720 Check_Null_Exclusion
3722 Sub
=> Entity
(Nam
));
3725 -- Enforce the Ada 2005 rule that the renamed entity cannot require
3726 -- overriding. The flag Requires_Overriding is set very selectively
3727 -- and misses some other illegal cases. The additional conditions
3728 -- checked below are sufficient but not necessary ???
3730 -- The rule does not apply to the renaming generated for an actual
3731 -- subprogram in an instance.
3736 -- Guard against previous errors, and omit renamings of predefined
3739 elsif Ekind
(Old_S
) not in E_Function | E_Procedure
then
3742 elsif Requires_Overriding
(Old_S
)
3744 (Is_Abstract_Subprogram
(Old_S
)
3745 and then Present
(Find_Dispatching_Type
(Old_S
))
3746 and then not Is_Abstract_Type
(Find_Dispatching_Type
(Old_S
)))
3749 ("renamed entity cannot be subprogram that requires overriding "
3750 & "(RM 8.5.4 (5.1))", N
);
3754 Prev
: constant Entity_Id
:= Overridden_Operation
(New_S
);
3758 (Has_Non_Trivial_Precondition
(Prev
)
3759 or else Has_Non_Trivial_Precondition
(Old_S
))
3762 ("conflicting inherited classwide preconditions in renaming "
3763 & "of& (RM 6.1.1 (17)", N
, Old_S
);
3768 if Old_S
/= Any_Id
then
3769 if Is_Actual
and then From_Default
(N
) then
3771 -- This is an implicit reference to the default actual
3773 Generate_Reference
(Old_S
, Nam
, Typ
=> 'i', Force
=> True);
3776 Generate_Reference
(Old_S
, Nam
);
3779 Check_Internal_Protected_Use
(N
, Old_S
);
3781 -- For a renaming-as-body, require subtype conformance, but if the
3782 -- declaration being completed has not been frozen, then inherit the
3783 -- convention of the renamed subprogram prior to checking conformance
3784 -- (unless the renaming has an explicit convention established; the
3785 -- rule stated in the RM doesn't seem to address this ???).
3787 if Present
(Rename_Spec
) then
3788 Generate_Reference
(Rename_Spec
, Defining_Entity
(Spec
), 'b');
3789 Style
.Check_Identifier
(Defining_Entity
(Spec
), Rename_Spec
);
3791 if not Is_Frozen
(Rename_Spec
) then
3792 if not Has_Convention_Pragma
(Rename_Spec
) then
3793 Set_Convention
(New_S
, Convention
(Old_S
));
3796 if Ekind
(Old_S
) /= E_Operator
then
3797 Check_Mode_Conformant
(New_S
, Old_S
, Spec
);
3800 if Original_Subprogram
(Old_S
) = Rename_Spec
then
3801 Error_Msg_N
("unfrozen subprogram cannot rename itself", N
);
3803 Check_Formal_Subprogram_Conformance
(New_S
, Old_S
, Spec
);
3806 Check_Subtype_Conformant
(New_S
, Old_S
, Spec
);
3809 Check_Frozen_Renaming
(N
, Rename_Spec
);
3811 -- Check explicitly that renamed entity is not intrinsic, because
3812 -- in a generic the renamed body is not built. In this case,
3813 -- the renaming_as_body is a completion.
3815 if Inside_A_Generic
then
3816 if Is_Frozen
(Rename_Spec
)
3817 and then Is_Intrinsic_Subprogram
(Old_S
)
3820 ("subprogram in renaming_as_body cannot be intrinsic",
3824 Set_Has_Completion
(Rename_Spec
);
3827 elsif Ekind
(Old_S
) /= E_Operator
then
3829 -- If this a defaulted subprogram for a class-wide actual there is
3830 -- no check for mode conformance, given that the signatures don't
3831 -- match (the source mentions T but the actual mentions T'Class).
3836 -- No need for a redundant error message if this is a nested
3837 -- instance, unless the current instantiation (of a child unit)
3838 -- is a compilation unit, which is not analyzed when the parent
3839 -- generic is analyzed.
3842 or else No
(Enclosing_Instance
)
3843 or else Is_Compilation_Unit
(Current_Scope
)
3845 Check_Mode_Conformant
(New_S
, Old_S
);
3849 if No
(Rename_Spec
) then
3851 -- The parameter profile of the new entity is that of the renamed
3852 -- entity: the subtypes given in the specification are irrelevant.
3854 Inherit_Renamed_Profile
(New_S
, Old_S
);
3856 -- A call to the subprogram is transformed into a call to the
3857 -- renamed entity. This is transitive if the renamed entity is
3858 -- itself a renaming.
3860 if Present
(Alias
(Old_S
)) then
3861 Set_Alias
(New_S
, Alias
(Old_S
));
3863 Set_Alias
(New_S
, Old_S
);
3866 -- Note that we do not set Is_Intrinsic_Subprogram if we have a
3867 -- renaming as body, since the entity in this case is not an
3868 -- intrinsic (it calls an intrinsic, but we have a real body for
3869 -- this call, and it is in this body that the required intrinsic
3870 -- processing will take place).
3872 -- Also, if this is a renaming of inequality, the renamed operator
3873 -- is intrinsic, but what matters is the corresponding equality
3874 -- operator, which may be user-defined.
3876 Set_Is_Intrinsic_Subprogram
3878 Is_Intrinsic_Subprogram
(Old_S
)
3880 (Chars
(Old_S
) /= Name_Op_Ne
3881 or else Ekind
(Old_S
) = E_Operator
3882 or else Is_Intrinsic_Subprogram
3883 (Corresponding_Equality
(Old_S
))));
3885 if Ekind
(Alias
(New_S
)) = E_Operator
then
3886 Set_Has_Delayed_Freeze
(New_S
, False);
3889 -- If the renaming corresponds to an association for an abstract
3890 -- formal subprogram, then various attributes must be set to
3891 -- indicate that the renaming is an abstract dispatching operation
3892 -- with a controlling type.
3894 -- Skip this decoration when the renaming corresponds to an
3895 -- association with class-wide wrapper (see above) because such
3896 -- wrapper is neither abstract nor a dispatching operation (its
3897 -- body has the dispatching call to the wrapped primitive).
3900 and then Is_Abstract_Subprogram
(Formal_Spec
)
3901 and then No
(Wrapped_Prim
)
3904 -- Mark the renaming as abstract here, so Find_Dispatching_Type
3905 -- see it as corresponding to a generic association for a
3906 -- formal abstract subprogram
3908 Set_Is_Abstract_Subprogram
(New_S
);
3911 New_S_Ctrl_Type
: constant Entity_Id
:=
3912 Find_Dispatching_Type
(New_S
);
3913 Old_S_Ctrl_Type
: constant Entity_Id
:=
3914 Find_Dispatching_Type
(Old_S
);
3918 -- The actual must match the (instance of the) formal,
3919 -- and must be a controlling type.
3921 if Old_S_Ctrl_Type
/= New_S_Ctrl_Type
3922 or else No
(New_S_Ctrl_Type
)
3924 if No
(New_S_Ctrl_Type
) then
3926 ("actual must be dispatching subprogram", Nam
);
3929 ("actual must be dispatching subprogram for type&",
3930 Nam
, New_S_Ctrl_Type
);
3934 Set_Is_Dispatching_Operation
(New_S
);
3935 Check_Controlling_Formals
(New_S_Ctrl_Type
, New_S
);
3937 -- If the actual in the formal subprogram is itself a
3938 -- formal abstract subprogram association, there's no
3939 -- dispatch table component or position to inherit.
3941 if Present
(DTC_Entity
(Old_S
)) then
3942 Set_DTC_Entity
(New_S
, DTC_Entity
(Old_S
));
3943 Set_DT_Position_Value
(New_S
, DT_Position
(Old_S
));
3953 -- The following is illegal, because F hides whatever other F may
3955 -- function F (...) renames F;
3958 or else (Nkind
(Nam
) /= N_Expanded_Name
3959 and then Chars
(Old_S
) = Chars
(New_S
))
3961 Error_Msg_N
("subprogram cannot rename itself", N
);
3963 -- This is illegal even if we use a selector:
3964 -- function F (...) renames Pkg.F;
3965 -- because F is still hidden.
3967 elsif Nkind
(Nam
) = N_Expanded_Name
3968 and then Entity
(Prefix
(Nam
)) = Current_Scope
3969 and then Chars
(Selector_Name
(Nam
)) = Chars
(New_S
)
3971 -- This is an error, but we overlook the error and accept the
3972 -- renaming if the special Overriding_Renamings mode is in effect.
3974 if not Overriding_Renamings
then
3976 ("implicit operation& is not visible (RM 8.3 (15))",
3980 -- Check whether an expanded name used for the renamed subprogram
3981 -- begins with the same name as the renaming itself, and if so,
3982 -- issue an error about the prefix being hidden by the renaming.
3983 -- We exclude generic instances from this checking, since such
3984 -- normally illegal renamings can be constructed when expanding
3987 elsif Nkind
(Nam
) = N_Expanded_Name
and then not In_Instance
then
3989 function Ult_Expanded_Prefix
(N
: Node_Id
) return Node_Id
is
3990 (if Nkind
(N
) /= N_Expanded_Name
3992 else Ult_Expanded_Prefix
(Prefix
(N
)));
3993 -- Returns the ultimate prefix of an expanded name
3996 if Chars
(Entity
(Ult_Expanded_Prefix
(Nam
))) = Chars
(New_S
)
3998 Error_Msg_Sloc
:= Sloc
(N
);
4000 ("& is hidden by declaration#", Nam
, New_S
);
4005 Set_Convention
(New_S
, Convention
(Old_S
));
4007 if Is_Abstract_Subprogram
(Old_S
) then
4008 if Present
(Rename_Spec
) then
4010 ("a renaming-as-body cannot rename an abstract subprogram",
4012 Set_Has_Completion
(Rename_Spec
);
4014 Set_Is_Abstract_Subprogram
(New_S
);
4018 Check_Library_Unit_Renaming
(N
, Old_S
);
4020 -- Pathological case: procedure renames entry in the scope of its
4021 -- task. Entry is given by simple name, but body must be built for
4022 -- procedure. Of course if called it will deadlock.
4024 if Ekind
(Old_S
) = E_Entry
then
4025 Set_Has_Completion
(New_S
, False);
4026 Set_Alias
(New_S
, Empty
);
4029 -- Do not freeze the renaming nor the renamed entity when the context
4030 -- is an enclosing generic. Freezing is an expansion activity, and in
4031 -- addition the renamed entity may depend on the generic formals of
4032 -- the enclosing generic.
4034 if Is_Actual
and not Inside_A_Generic
then
4035 Freeze_Before
(N
, Old_S
);
4036 Freeze_Actual_Profile
;
4037 Set_Has_Delayed_Freeze
(New_S
, False);
4038 Freeze_Before
(N
, New_S
);
4040 if (Ekind
(Old_S
) = E_Procedure
or else Ekind
(Old_S
) = E_Function
)
4041 and then not Is_Abstract_Subprogram
(Formal_Spec
)
4043 -- An abstract subprogram is only allowed as an actual in the
4044 -- case where the formal subprogram is also abstract.
4046 if Is_Abstract_Subprogram
(Old_S
) then
4048 ("abstract subprogram not allowed as generic actual", Nam
);
4051 -- AI12-0412: A primitive of an abstract type with Pre'Class
4052 -- or Post'Class aspects specified with nonstatic expressions
4053 -- is not allowed as actual for a nonabstract formal subprogram
4054 -- (see RM 6.1.1(18.2/5).
4056 if Is_Dispatching_Operation
(Old_S
)
4058 Is_Prim_Of_Abst_Type_With_Nonstatic_CW_Pre_Post
(Old_S
)
4061 ("primitive of abstract type with nonstatic class-wide "
4062 & "pre/postconditions not allowed as actual",
4069 -- A common error is to assume that implicit operators for types are
4070 -- defined in Standard, or in the scope of a subtype. In those cases
4071 -- where the renamed entity is given with an expanded name, it is
4072 -- worth mentioning that operators for the type are not declared in
4073 -- the scope given by the prefix.
4075 if Nkind
(Nam
) = N_Expanded_Name
4076 and then Nkind
(Selector_Name
(Nam
)) = N_Operator_Symbol
4077 and then Scope
(Entity
(Nam
)) = Standard_Standard
4080 T
: constant Entity_Id
:=
4081 Base_Type
(Etype
(First_Formal
(New_S
)));
4083 Error_Msg_Node_2
:= Prefix
(Nam
);
4085 ("operator for type& is not declared in&", Prefix
(Nam
), T
);
4090 ("no visible subprogram matches the specification for&",
4094 if Present
(Candidate_Renaming
) then
4101 F1
:= First_Formal
(Candidate_Renaming
);
4102 F2
:= First_Formal
(New_S
);
4103 T1
:= First_Subtype
(Etype
(F1
));
4104 while Present
(F1
) and then Present
(F2
) loop
4109 if Present
(F1
) and then Present
(Default_Value
(F1
)) then
4110 if Present
(Next_Formal
(F1
)) then
4112 ("\missing specification for & and other formals with "
4113 & "defaults", Spec
, F1
);
4115 Error_Msg_NE
("\missing specification for &", Spec
, F1
);
4119 if Nkind
(Nam
) = N_Operator_Symbol
4120 and then From_Default
(N
)
4122 Error_Msg_Node_2
:= T1
;
4124 ("default & on & is not directly visible", Nam
, Nam
);
4130 -- Ada 2005 AI 404: if the new subprogram is dispatching, verify that
4131 -- controlling access parameters are known non-null for the renamed
4132 -- subprogram. Test also applies to a subprogram instantiation that
4133 -- is dispatching. Test is skipped if some previous error was detected
4134 -- that set Old_S to Any_Id.
4136 if Ada_Version
>= Ada_2005
4137 and then Old_S
/= Any_Id
4138 and then not Is_Dispatching_Operation
(Old_S
)
4139 and then Is_Dispatching_Operation
(New_S
)
4146 Old_F
:= First_Formal
(Old_S
);
4147 New_F
:= First_Formal
(New_S
);
4148 while Present
(Old_F
) loop
4149 if Ekind
(Etype
(Old_F
)) = E_Anonymous_Access_Type
4150 and then Is_Controlling_Formal
(New_F
)
4151 and then not Can_Never_Be_Null
(Old_F
)
4153 Error_Msg_N
("access parameter is controlling,", New_F
);
4155 ("\corresponding parameter of& must be explicitly null "
4156 & "excluding", New_F
, Old_S
);
4159 Next_Formal
(Old_F
);
4160 Next_Formal
(New_F
);
4165 -- A useful warning, suggested by Ada Bug Finder (Ada-Europe 2005)
4166 -- is to warn if an operator is being renamed as a different operator.
4167 -- If the operator is predefined, examine the kind of the entity, not
4168 -- the abbreviated declaration in Standard.
4170 if Comes_From_Source
(N
)
4171 and then Present
(Old_S
)
4172 and then (Nkind
(Old_S
) = N_Defining_Operator_Symbol
4173 or else Ekind
(Old_S
) = E_Operator
)
4174 and then Nkind
(New_S
) = N_Defining_Operator_Symbol
4175 and then Chars
(Old_S
) /= Chars
(New_S
)
4178 ("& is being renamed as a different operator??", N
, Old_S
);
4181 -- Check for renaming of obsolescent subprogram
4183 Check_Obsolescent_2005_Entity
(Entity
(Nam
), Nam
);
4185 -- Another warning or some utility: if the new subprogram as the same
4186 -- name as the old one, the old one is not hidden by an outer homograph,
4187 -- the new one is not a public symbol, and the old one is otherwise
4188 -- directly visible, the renaming is superfluous.
4190 if Chars
(Old_S
) = Chars
(New_S
)
4191 and then Comes_From_Source
(N
)
4192 and then Scope
(Old_S
) /= Standard_Standard
4193 and then Warn_On_Redundant_Constructs
4194 and then (Is_Immediately_Visible
(Old_S
)
4195 or else Is_Potentially_Use_Visible
(Old_S
))
4196 and then Is_Overloadable
(Current_Scope
)
4197 and then Chars
(Current_Scope
) /= Chars
(Old_S
)
4200 ("redundant renaming, entity is directly visible?r?", Name
(N
));
4203 -- Implementation-defined aspect specifications can appear in a renaming
4204 -- declaration, but not language-defined ones. The call to procedure
4205 -- Analyze_Aspect_Specifications will take care of this error check.
4207 if Has_Aspects
(N
) then
4208 Analyze_Aspect_Specifications
(N
, New_S
);
4214 and then Has_Yield_Aspect
(Formal_Spec
)
4215 and then not Has_Yield_Aspect
(Old_S
)
4217 Error_Msg_Name_1
:= Name_Yield
;
4219 ("actual subprogram& must have aspect% to match formal", Name
(N
));
4222 Ada_Version
:= Save_AV
;
4223 Ada_Version_Pragma
:= Save_AVP
;
4224 Ada_Version_Explicit
:= Save_AV_Exp
;
4226 -- Check if we are looking at an Ada 2012 defaulted formal subprogram
4227 -- and mark any use_package_clauses that affect the visibility of the
4228 -- implicit generic actual.
4230 -- Also, we may be looking at an internal renaming of a user-defined
4231 -- subprogram created for a generic formal subprogram association,
4232 -- which will also have to be marked here. This can occur when the
4233 -- corresponding formal subprogram contains references to other generic
4236 if Is_Generic_Actual_Subprogram
(New_S
)
4237 and then (Is_Intrinsic_Subprogram
(New_S
)
4238 or else From_Default
(N
)
4239 or else Nkind
(N
) = N_Subprogram_Renaming_Declaration
)
4241 Mark_Use_Clauses
(New_S
);
4243 -- Handle overloaded subprograms
4245 if Present
(Alias
(New_S
)) then
4246 Mark_Use_Clauses
(Alias
(New_S
));
4249 end Analyze_Subprogram_Renaming
;
4251 -------------------------
4252 -- Analyze_Use_Package --
4253 -------------------------
4255 -- Resolve the package names in the use clause, and make all the visible
4256 -- entities defined in the package potentially use-visible. If the package
4257 -- is already in use from a previous use clause, its visible entities are
4258 -- already use-visible. In that case, mark the occurrence as a redundant
4259 -- use. If the package is an open scope, i.e. if the use clause occurs
4260 -- within the package itself, ignore it.
4262 procedure Analyze_Use_Package
(N
: Node_Id
; Chain
: Boolean := True) is
4263 procedure Analyze_Package_Name
(Clause
: Node_Id
);
4264 -- Perform analysis on a package name from a use_package_clause
4266 procedure Analyze_Package_Name_List
(Head_Clause
: Node_Id
);
4267 -- Similar to Analyze_Package_Name but iterates over all the names
4270 --------------------------
4271 -- Analyze_Package_Name --
4272 --------------------------
4274 procedure Analyze_Package_Name
(Clause
: Node_Id
) is
4275 Pack
: constant Node_Id
:= Name
(Clause
);
4279 pragma Assert
(Nkind
(Clause
) = N_Use_Package_Clause
);
4282 -- Verify that the package standard is not directly named in a
4283 -- use_package_clause.
4285 if Nkind
(Parent
(Clause
)) = N_Compilation_Unit
4286 and then Nkind
(Pack
) = N_Expanded_Name
4288 Pref
:= Prefix
(Pack
);
4290 while Nkind
(Pref
) = N_Expanded_Name
loop
4291 Pref
:= Prefix
(Pref
);
4294 if Entity
(Pref
) = Standard_Standard
then
4296 ("predefined package Standard cannot appear in a context "
4300 end Analyze_Package_Name
;
4302 -------------------------------
4303 -- Analyze_Package_Name_List --
4304 -------------------------------
4306 procedure Analyze_Package_Name_List
(Head_Clause
: Node_Id
) is
4310 -- Due to the way source use clauses are split during parsing we are
4311 -- forced to simply iterate through all entities in scope until the
4312 -- clause representing the last name in the list is found.
4314 Curr
:= Head_Clause
;
4315 while Present
(Curr
) loop
4316 Analyze_Package_Name
(Curr
);
4318 -- Stop iterating over the names in the use clause when we are at
4321 exit when not More_Ids
(Curr
) and then Prev_Ids
(Curr
);
4324 end Analyze_Package_Name_List
;
4330 -- Start of processing for Analyze_Use_Package
4333 Set_Hidden_By_Use_Clause
(N
, No_Elist
);
4335 -- Use clause not allowed in a spec of a predefined package declaration
4336 -- except that packages whose file name starts a-n are OK (these are
4337 -- children of Ada.Numerics, which are never loaded by Rtsfind).
4339 if Is_Predefined_Unit
(Current_Sem_Unit
)
4340 and then Get_Name_String
4341 (Unit_File_Name
(Current_Sem_Unit
)) (1 .. 3) /= "a-n"
4342 and then Nkind
(Unit
(Cunit
(Current_Sem_Unit
))) =
4343 N_Package_Declaration
4345 Error_Msg_N
("use clause not allowed in predefined spec", N
);
4348 -- Loop through all package names from the original use clause in
4349 -- order to analyze referenced packages. A use_package_clause with only
4350 -- one name does not have More_Ids or Prev_Ids set, while a clause with
4351 -- More_Ids only starts the chain produced by the parser.
4353 if not More_Ids
(N
) and then not Prev_Ids
(N
) then
4354 Analyze_Package_Name
(N
);
4356 elsif More_Ids
(N
) and then not Prev_Ids
(N
) then
4357 Analyze_Package_Name_List
(N
);
4360 if not Is_Entity_Name
(Name
(N
)) then
4361 Error_Msg_N
("& is not a package", Name
(N
));
4367 Chain_Use_Clause
(N
);
4370 Pack
:= Entity
(Name
(N
));
4372 -- There are many cases where scopes are manipulated during analysis, so
4373 -- check that Pack's current use clause has not already been chained
4374 -- before setting its previous use clause.
4376 if Ekind
(Pack
) = E_Package
4377 and then Present
(Current_Use_Clause
(Pack
))
4378 and then Current_Use_Clause
(Pack
) /= N
4379 and then No
(Prev_Use_Clause
(N
))
4380 and then Prev_Use_Clause
(Current_Use_Clause
(Pack
)) /= N
4382 Set_Prev_Use_Clause
(N
, Current_Use_Clause
(Pack
));
4385 -- Mark all entities as potentially use visible
4387 if Ekind
(Pack
) /= E_Package
and then Etype
(Pack
) /= Any_Type
then
4388 if Ekind
(Pack
) = E_Generic_Package
then
4389 Error_Msg_N
-- CODEFIX
4390 ("a generic package is not allowed in a use clause", Name
(N
));
4392 elsif Is_Generic_Subprogram
(Pack
) then
4393 Error_Msg_N
-- CODEFIX
4394 ("a generic subprogram is not allowed in a use clause",
4397 elsif Is_Subprogram
(Pack
) then
4398 Error_Msg_N
-- CODEFIX
4399 ("a subprogram is not allowed in a use clause", Name
(N
));
4402 Error_Msg_N
("& is not allowed in a use clause", Name
(N
));
4406 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
4407 Check_In_Previous_With_Clause
(N
, Name
(N
));
4410 Use_One_Package
(N
, Name
(N
));
4413 Mark_Ghost_Clause
(N
);
4414 end Analyze_Use_Package
;
4416 ----------------------
4417 -- Analyze_Use_Type --
4418 ----------------------
4420 procedure Analyze_Use_Type
(N
: Node_Id
; Chain
: Boolean := True) is
4425 Set_Hidden_By_Use_Clause
(N
, No_Elist
);
4427 -- Chain clause to list of use clauses in current scope when flagged
4430 Chain_Use_Clause
(N
);
4433 -- Obtain the base type of the type denoted within the use_type_clause's
4436 Id
:= Subtype_Mark
(N
);
4438 E
:= Base_Type
(Entity
(Id
));
4440 -- There are many cases where a use_type_clause may be reanalyzed due to
4441 -- manipulation of the scope stack so we much guard against those cases
4442 -- here, otherwise, we must add the new use_type_clause to the previous
4443 -- use_type_clause chain in order to mark redundant use_type_clauses as
4444 -- used. When the redundant use-type clauses appear in a parent unit and
4445 -- a child unit we must prevent a circularity in the chain that would
4446 -- otherwise result from the separate steps of analysis and installation
4447 -- of the parent context.
4449 if Present
(Current_Use_Clause
(E
))
4450 and then Current_Use_Clause
(E
) /= N
4451 and then Prev_Use_Clause
(Current_Use_Clause
(E
)) /= N
4452 and then No
(Prev_Use_Clause
(N
))
4454 Set_Prev_Use_Clause
(N
, Current_Use_Clause
(E
));
4457 -- If the Used_Operations list is already initialized, the clause has
4458 -- been analyzed previously, and it is being reinstalled, for example
4459 -- when the clause appears in a package spec and we are compiling the
4460 -- corresponding package body. In that case, make the entities on the
4461 -- existing list use_visible, and mark the corresponding types In_Use.
4463 if Present
(Used_Operations
(N
)) then
4468 Use_One_Type
(Subtype_Mark
(N
), Installed
=> True);
4470 Elmt
:= First_Elmt
(Used_Operations
(N
));
4471 while Present
(Elmt
) loop
4472 Set_Is_Potentially_Use_Visible
(Node
(Elmt
));
4480 -- Otherwise, create new list and attach to it the operations that are
4481 -- made use-visible by the clause.
4483 Set_Used_Operations
(N
, New_Elmt_List
);
4486 if E
/= Any_Type
then
4489 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
4490 if Nkind
(Id
) = N_Identifier
then
4491 Error_Msg_N
("type is not directly visible", Id
);
4493 elsif Is_Child_Unit
(Scope
(E
))
4494 and then Scope
(E
) /= System_Aux_Id
4496 Check_In_Previous_With_Clause
(N
, Prefix
(Id
));
4501 -- If the use_type_clause appears in a compilation unit context,
4502 -- check whether it comes from a unit that may appear in a
4503 -- limited_with_clause, for a better error message.
4505 if Nkind
(Parent
(N
)) = N_Compilation_Unit
4506 and then Nkind
(Id
) /= N_Identifier
4512 function Mentioned
(Nam
: Node_Id
) return Boolean;
4513 -- Check whether the prefix of expanded name for the type
4514 -- appears in the prefix of some limited_with_clause.
4520 function Mentioned
(Nam
: Node_Id
) return Boolean is
4522 return Nkind
(Name
(Item
)) = N_Selected_Component
4523 and then Chars
(Prefix
(Name
(Item
))) = Chars
(Nam
);
4527 Pref
:= Prefix
(Id
);
4528 Item
:= First
(Context_Items
(Parent
(N
)));
4529 while Present
(Item
) and then Item
/= N
loop
4530 if Nkind
(Item
) = N_With_Clause
4531 and then Limited_Present
(Item
)
4532 and then Mentioned
(Pref
)
4535 (Get_Msg_Id
, "premature usage of incomplete type");
4544 Mark_Ghost_Clause
(N
);
4545 end Analyze_Use_Type
;
4547 ------------------------
4548 -- Attribute_Renaming --
4549 ------------------------
4551 procedure Attribute_Renaming
(N
: Node_Id
) is
4552 Loc
: constant Source_Ptr
:= Sloc
(N
);
4553 Nam
: constant Node_Id
:= Name
(N
);
4554 Spec
: constant Node_Id
:= Specification
(N
);
4555 New_S
: constant Entity_Id
:= Defining_Unit_Name
(Spec
);
4556 Aname
: constant Name_Id
:= Attribute_Name
(Nam
);
4558 Form_Num
: Nat
:= 0;
4559 Expr_List
: List_Id
:= No_List
;
4561 Attr_Node
: Node_Id
;
4562 Body_Node
: Node_Id
;
4563 Param_Spec
: Node_Id
;
4566 Generate_Definition
(New_S
);
4568 -- This procedure is called in the context of subprogram renaming, and
4569 -- thus the attribute must be one that is a subprogram. All of those
4570 -- have at least one formal parameter, with the exceptions of the GNAT
4571 -- attribute 'Img, which GNAT treats as renameable.
4573 if Is_Empty_List
(Parameter_Specifications
(Spec
)) then
4574 if Aname
/= Name_Img
then
4576 ("subprogram renaming an attribute must have formals", N
);
4581 Param_Spec
:= First
(Parameter_Specifications
(Spec
));
4582 while Present
(Param_Spec
) loop
4583 Form_Num
:= Form_Num
+ 1;
4585 if Nkind
(Parameter_Type
(Param_Spec
)) /= N_Access_Definition
then
4586 Find_Type
(Parameter_Type
(Param_Spec
));
4588 -- The profile of the new entity denotes the base type (s) of
4589 -- the types given in the specification. For access parameters
4590 -- there are no subtypes involved.
4592 Rewrite
(Parameter_Type
(Param_Spec
),
4594 (Base_Type
(Entity
(Parameter_Type
(Param_Spec
))), Loc
));
4597 if No
(Expr_List
) then
4598 Expr_List
:= New_List
;
4601 Append_To
(Expr_List
,
4602 Make_Identifier
(Loc
,
4603 Chars
=> Chars
(Defining_Identifier
(Param_Spec
))));
4605 -- The expressions in the attribute reference are not freeze
4606 -- points. Neither is the attribute as a whole, see below.
4608 Set_Must_Not_Freeze
(Last
(Expr_List
));
4613 -- Immediate error if too many formals. Other mismatches in number or
4614 -- types of parameters are detected when we analyze the body of the
4615 -- subprogram that we construct.
4617 if Form_Num
> 2 then
4618 Error_Msg_N
("too many formals for attribute", N
);
4620 -- Error if the attribute reference has expressions that look like
4621 -- formal parameters.
4623 elsif Present
(Expressions
(Nam
)) then
4624 Error_Msg_N
("illegal expressions in attribute reference", Nam
);
4626 elsif Aname
in Name_Compose | Name_Exponent | Name_Leading_Part |
4627 Name_Pos | Name_Round | Name_Scaling |
4630 if Nkind
(N
) = N_Subprogram_Renaming_Declaration
4631 and then Present
(Corresponding_Formal_Spec
(N
))
4634 ("generic actual cannot be attribute involving universal type",
4638 ("attribute involving a universal type cannot be renamed",
4643 -- Rewrite attribute node to have a list of expressions corresponding to
4644 -- the subprogram formals. A renaming declaration is not a freeze point,
4645 -- and the analysis of the attribute reference should not freeze the
4646 -- type of the prefix. We use the original node in the renaming so that
4647 -- its source location is preserved, and checks on stream attributes are
4648 -- properly applied.
4650 Attr_Node
:= Relocate_Node
(Nam
);
4651 Set_Expressions
(Attr_Node
, Expr_List
);
4653 Set_Must_Not_Freeze
(Attr_Node
);
4654 Set_Must_Not_Freeze
(Prefix
(Nam
));
4656 -- Case of renaming a function
4658 if Nkind
(Spec
) = N_Function_Specification
then
4659 if Is_Procedure_Attribute_Name
(Aname
) then
4660 Error_Msg_N
("attribute can only be renamed as procedure", Nam
);
4664 Find_Type
(Result_Definition
(Spec
));
4665 Rewrite
(Result_Definition
(Spec
),
4667 (Base_Type
(Entity
(Result_Definition
(Spec
))), Loc
));
4670 Make_Subprogram_Body
(Loc
,
4671 Specification
=> Spec
,
4672 Declarations
=> New_List
,
4673 Handled_Statement_Sequence
=>
4674 Make_Handled_Sequence_Of_Statements
(Loc
,
4675 Statements
=> New_List
(
4676 Make_Simple_Return_Statement
(Loc
,
4677 Expression
=> Attr_Node
))));
4679 -- Case of renaming a procedure
4682 if not Is_Procedure_Attribute_Name
(Aname
) then
4683 Error_Msg_N
("attribute can only be renamed as function", Nam
);
4688 Make_Subprogram_Body
(Loc
,
4689 Specification
=> Spec
,
4690 Declarations
=> New_List
,
4691 Handled_Statement_Sequence
=>
4692 Make_Handled_Sequence_Of_Statements
(Loc
,
4693 Statements
=> New_List
(Attr_Node
)));
4696 -- Signal the ABE mechanism that the generated subprogram body has not
4697 -- ABE ramifications.
4699 Set_Was_Attribute_Reference
(Body_Node
);
4701 -- In case of tagged types we add the body of the generated function to
4702 -- the freezing actions of the type (because in the general case such
4703 -- type is still not frozen). We exclude from this processing generic
4704 -- formal subprograms found in instantiations.
4706 -- We must exclude restricted run-time libraries because
4707 -- entity AST_Handler is defined in package System.Aux_Dec which is not
4708 -- available in those platforms. Note that we cannot use the function
4709 -- Restricted_Profile (instead of Configurable_Run_Time_Mode) because
4710 -- the ZFP run-time library is not defined as a profile, and we do not
4711 -- want to deal with AST_Handler in ZFP mode.
4713 if not Configurable_Run_Time_Mode
4714 and then No
(Corresponding_Formal_Spec
(N
))
4715 and then not Is_RTE
(Etype
(Nam
), RE_AST_Handler
)
4718 P
: constant Node_Id
:= Prefix
(Nam
);
4721 -- The prefix of 'Img is an object that is evaluated for each call
4722 -- of the function that renames it.
4724 if Aname
= Name_Img
then
4725 Preanalyze_And_Resolve
(P
);
4727 -- For all other attribute renamings, the prefix is a subtype
4733 -- If the target type is not yet frozen, add the body to the
4734 -- actions to be elaborated at freeze time.
4736 if Is_Tagged_Type
(Etype
(P
))
4737 and then In_Open_Scopes
(Scope
(Etype
(P
)))
4739 Append_Freeze_Action
(Etype
(P
), Body_Node
);
4741 Rewrite
(N
, Body_Node
);
4743 Set_Etype
(New_S
, Base_Type
(Etype
(New_S
)));
4747 -- Generic formal subprograms or AST_Handler renaming
4750 Rewrite
(N
, Body_Node
);
4752 Set_Etype
(New_S
, Base_Type
(Etype
(New_S
)));
4755 if Is_Compilation_Unit
(New_S
) then
4757 ("a library unit can only rename another library unit", N
);
4760 -- We suppress elaboration warnings for the resulting entity, since
4761 -- clearly they are not needed, and more particularly, in the case
4762 -- of a generic formal subprogram, the resulting entity can appear
4763 -- after the instantiation itself, and thus look like a bogus case
4764 -- of access before elaboration.
4766 if Legacy_Elaboration_Checks
then
4767 Set_Suppress_Elaboration_Warnings
(New_S
);
4769 end Attribute_Renaming
;
4771 ----------------------
4772 -- Chain_Use_Clause --
4773 ----------------------
4775 procedure Chain_Use_Clause
(N
: Node_Id
) is
4776 Level
: Int
:= Scope_Stack
.Last
;
4782 if not Is_Compilation_Unit
(Current_Scope
)
4783 or else not Is_Child_Unit
(Current_Scope
)
4787 -- Common case for compilation unit
4789 elsif Defining_Entity
(Parent
(N
)) = Current_Scope
then
4793 -- If declaration appears in some other scope, it must be in some
4794 -- parent unit when compiling a child.
4796 Pack
:= Defining_Entity
(Parent
(N
));
4798 if not In_Open_Scopes
(Pack
) then
4801 -- If the use clause appears in an ancestor and we are in the
4802 -- private part of the immediate parent, the use clauses are
4803 -- already installed.
4805 elsif Pack
/= Scope
(Current_Scope
)
4806 and then In_Private_Part
(Scope
(Current_Scope
))
4811 -- Find entry for parent unit in scope stack
4813 while Scope_Stack
.Table
(Level
).Entity
/= Pack
loop
4819 Set_Next_Use_Clause
(N
,
4820 Scope_Stack
.Table
(Level
).First_Use_Clause
);
4821 Scope_Stack
.Table
(Level
).First_Use_Clause
:= N
;
4822 end Chain_Use_Clause
;
4824 ---------------------------
4825 -- Check_Frozen_Renaming --
4826 ---------------------------
4828 procedure Check_Frozen_Renaming
(N
: Node_Id
; Subp
: Entity_Id
) is
4833 if Is_Frozen
(Subp
) and then not Has_Completion
(Subp
) then
4836 (Parent
(Declaration_Node
(Subp
)), Defining_Entity
(N
));
4838 if Is_Entity_Name
(Name
(N
)) then
4839 Old_S
:= Entity
(Name
(N
));
4841 if not Is_Frozen
(Old_S
)
4842 and then Operating_Mode
/= Check_Semantics
4844 Append_Freeze_Action
(Old_S
, B_Node
);
4846 Insert_After
(N
, B_Node
);
4850 if Is_Intrinsic_Subprogram
(Old_S
)
4851 and then not In_Instance
4852 and then not Relaxed_RM_Semantics
4855 ("subprogram used in renaming_as_body cannot be intrinsic",
4860 Insert_After
(N
, B_Node
);
4864 end Check_Frozen_Renaming
;
4866 -------------------------------
4867 -- Set_Entity_Or_Discriminal --
4868 -------------------------------
4870 procedure Set_Entity_Or_Discriminal
(N
: Node_Id
; E
: Entity_Id
) is
4874 -- If the entity is not a discriminant, or else expansion is disabled,
4875 -- simply set the entity.
4877 if not In_Spec_Expression
4878 or else Ekind
(E
) /= E_Discriminant
4879 or else Inside_A_Generic
4881 Set_Entity_With_Checks
(N
, E
);
4883 -- The replacement of a discriminant by the corresponding discriminal
4884 -- is not done for a task discriminant that appears in a default
4885 -- expression of an entry parameter. See Exp_Ch2.Expand_Discriminant
4886 -- for details on their handling.
4888 elsif Is_Concurrent_Type
(Scope
(E
)) then
4891 and then Nkind
(P
) not in
4892 N_Parameter_Specification | N_Component_Declaration
4898 and then Nkind
(P
) = N_Parameter_Specification
4902 -- Don't replace a non-qualified discriminant in strict preanalysis
4903 -- mode since it can lead to errors during full analysis when the
4904 -- discriminant gets referenced later.
4906 -- This can occur in situations where a protected type contains
4907 -- an expression function which references a non-prefixed
4911 and then Preanalysis_Active
4912 and then Inside_Preanalysis_Without_Freezing
= 0
4917 Set_Entity
(N
, Discriminal
(E
));
4920 -- Otherwise, this is a discriminant in a context in which
4921 -- it is a reference to the corresponding parameter of the
4922 -- init proc for the enclosing type.
4925 Set_Entity
(N
, Discriminal
(E
));
4927 end Set_Entity_Or_Discriminal
;
4929 -----------------------------------
4930 -- Check_In_Previous_With_Clause --
4931 -----------------------------------
4933 procedure Check_In_Previous_With_Clause
(N
, Nam
: Node_Id
) is
4934 Pack
: constant Entity_Id
:= Entity
(Original_Node
(Nam
));
4939 Item
:= First
(Context_Items
(Parent
(N
)));
4940 while Present
(Item
) and then Item
/= N
loop
4941 if Nkind
(Item
) = N_With_Clause
4943 -- Protect the frontend against previous critical errors
4945 and then Nkind
(Name
(Item
)) /= N_Selected_Component
4946 and then Entity
(Name
(Item
)) = Pack
4950 -- Find root library unit in with_clause
4952 while Nkind
(Par
) = N_Expanded_Name
loop
4953 Par
:= Prefix
(Par
);
4956 if Is_Child_Unit
(Entity
(Original_Node
(Par
))) then
4957 Error_Msg_NE
("& is not directly visible", Par
, Entity
(Par
));
4966 -- On exit, package is not mentioned in a previous with_clause.
4967 -- Check if its prefix is.
4969 if Nkind
(Nam
) = N_Expanded_Name
then
4970 Check_In_Previous_With_Clause
(N
, Prefix
(Nam
));
4972 elsif Pack
/= Any_Id
then
4973 Error_Msg_NE
("& is not visible", Nam
, Pack
);
4975 end Check_In_Previous_With_Clause
;
4977 ---------------------------------
4978 -- Check_Library_Unit_Renaming --
4979 ---------------------------------
4981 procedure Check_Library_Unit_Renaming
(N
: Node_Id
; Old_E
: Entity_Id
) is
4985 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
4988 -- Check for library unit. Note that we used to check for the scope
4989 -- being Standard here, but that was wrong for Standard itself.
4991 elsif not Is_Compilation_Unit
(Old_E
)
4992 and then not Is_Child_Unit
(Old_E
)
4994 Error_Msg_N
("renamed unit must be a library unit", Name
(N
));
4996 -- Entities defined in Standard (operators and boolean literals) cannot
4997 -- be renamed as library units.
4999 elsif Scope
(Old_E
) = Standard_Standard
5000 and then Sloc
(Old_E
) = Standard_Location
5002 Error_Msg_N
("renamed unit must be a library unit", Name
(N
));
5004 elsif Present
(Parent_Spec
(N
))
5005 and then Nkind
(Unit
(Parent_Spec
(N
))) = N_Generic_Package_Declaration
5006 and then not Is_Child_Unit
(Old_E
)
5009 ("renamed unit must be a child unit of generic parent", Name
(N
));
5011 elsif Nkind
(N
) in N_Generic_Renaming_Declaration
5012 and then Nkind
(Name
(N
)) = N_Expanded_Name
5013 and then Is_Generic_Instance
(Entity
(Prefix
(Name
(N
))))
5014 and then Is_Generic_Unit
(Old_E
)
5017 ("renamed generic unit must be a library unit", Name
(N
));
5019 elsif Is_Package_Or_Generic_Package
(Old_E
) then
5021 -- Inherit categorization flags
5023 New_E
:= Defining_Entity
(N
);
5024 Set_Is_Pure
(New_E
, Is_Pure
(Old_E
));
5025 Set_Is_Preelaborated
(New_E
, Is_Preelaborated
(Old_E
));
5026 Set_Is_Remote_Call_Interface
(New_E
,
5027 Is_Remote_Call_Interface
(Old_E
));
5028 Set_Is_Remote_Types
(New_E
, Is_Remote_Types
(Old_E
));
5029 Set_Is_Shared_Passive
(New_E
, Is_Shared_Passive
(Old_E
));
5031 end Check_Library_Unit_Renaming
;
5033 ------------------------
5034 -- Enclosing_Instance --
5035 ------------------------
5037 function Enclosing_Instance
return Entity_Id
is
5041 if not Is_Generic_Instance
(Current_Scope
) then
5045 S
:= Scope
(Current_Scope
);
5046 while S
/= Standard_Standard
loop
5047 if Is_Generic_Instance
(S
) then
5055 end Enclosing_Instance
;
5061 procedure End_Scope
is
5067 Id
:= First_Entity
(Current_Scope
);
5068 while Present
(Id
) loop
5069 -- An entity in the current scope is not necessarily the first one
5070 -- on its homonym chain. Find its predecessor if any,
5071 -- If it is an internal entity, it will not be in the visibility
5072 -- chain altogether, and there is nothing to unchain.
5074 if Id
/= Current_Entity
(Id
) then
5075 Prev
:= Current_Entity
(Id
);
5076 while Present
(Prev
)
5077 and then Homonym
(Prev
) /= Id
5079 Prev
:= Homonym
(Prev
);
5082 -- Skip to end of loop if Id is not in the visibility chain
5092 Set_Is_Immediately_Visible
(Id
, False);
5094 Outer
:= Homonym
(Id
);
5095 while Present
(Outer
) and then Scope
(Outer
) = Current_Scope
loop
5096 Outer
:= Homonym
(Outer
);
5099 -- Reset homonym link of other entities, but do not modify link
5100 -- between entities in current scope, so that the back-end can have
5101 -- a proper count of local overloadings.
5104 Set_Name_Entity_Id
(Chars
(Id
), Outer
);
5106 elsif Scope
(Prev
) /= Scope
(Id
) then
5107 Set_Homonym
(Prev
, Outer
);
5114 -- If the scope generated freeze actions, place them before the
5115 -- current declaration and analyze them. Type declarations and
5116 -- the bodies of initialization procedures can generate such nodes.
5117 -- We follow the parent chain until we reach a list node, which is
5118 -- the enclosing list of declarations. If the list appears within
5119 -- a protected definition, move freeze nodes outside the protected
5123 (Scope_Stack
.Table
(Scope_Stack
.Last
).Pending_Freeze_Actions
)
5127 L
: constant List_Id
:= Scope_Stack
.Table
5128 (Scope_Stack
.Last
).Pending_Freeze_Actions
;
5131 if Is_Itype
(Current_Scope
) then
5132 Decl
:= Associated_Node_For_Itype
(Current_Scope
);
5134 Decl
:= Parent
(Current_Scope
);
5139 while not Is_List_Member
(Decl
)
5140 or else Nkind
(Parent
(Decl
)) in N_Protected_Definition
5143 Decl
:= Parent
(Decl
);
5146 Insert_List_Before_And_Analyze
(Decl
, L
);
5154 ---------------------
5155 -- End_Use_Clauses --
5156 ---------------------
5158 procedure End_Use_Clauses
(Clause
: Node_Id
) is
5162 -- Remove use_type_clauses first, because they affect the visibility of
5163 -- operators in subsequent used packages.
5166 while Present
(U
) loop
5167 if Nkind
(U
) = N_Use_Type_Clause
then
5171 Next_Use_Clause
(U
);
5175 while Present
(U
) loop
5176 if Nkind
(U
) = N_Use_Package_Clause
then
5177 End_Use_Package
(U
);
5180 Next_Use_Clause
(U
);
5182 end End_Use_Clauses
;
5184 ---------------------
5185 -- End_Use_Package --
5186 ---------------------
5188 procedure End_Use_Package
(N
: Node_Id
) is
5190 Pack_Name
: Node_Id
;
5194 function Is_Primitive_Operator_In_Use
5196 F
: Entity_Id
) return Boolean;
5197 -- Check whether Op is a primitive operator of a use-visible type
5199 ----------------------------------
5200 -- Is_Primitive_Operator_In_Use --
5201 ----------------------------------
5203 function Is_Primitive_Operator_In_Use
5205 F
: Entity_Id
) return Boolean
5207 T
: constant Entity_Id
:= Base_Type
(Etype
(F
));
5209 return In_Use
(T
) and then Scope
(T
) = Scope
(Op
);
5210 end Is_Primitive_Operator_In_Use
;
5212 -- Start of processing for End_Use_Package
5215 Pack_Name
:= Name
(N
);
5217 -- Test that Pack_Name actually denotes a package before processing
5219 if Is_Entity_Name
(Pack_Name
)
5220 and then Ekind
(Entity
(Pack_Name
)) = E_Package
5222 Pack
:= Entity
(Pack_Name
);
5224 if In_Open_Scopes
(Pack
) then
5227 elsif not Redundant_Use
(Pack_Name
) then
5228 Set_In_Use
(Pack
, False);
5229 Set_Current_Use_Clause
(Pack
, Empty
);
5231 Id
:= First_Entity
(Pack
);
5232 while Present
(Id
) loop
5234 -- Preserve use-visibility of operators that are primitive
5235 -- operators of a type that is use-visible through an active
5238 if Nkind
(Id
) = N_Defining_Operator_Symbol
5240 (Is_Primitive_Operator_In_Use
(Id
, First_Formal
(Id
))
5242 (Present
(Next_Formal
(First_Formal
(Id
)))
5244 Is_Primitive_Operator_In_Use
5245 (Id
, Next_Formal
(First_Formal
(Id
)))))
5249 Set_Is_Potentially_Use_Visible
(Id
, False);
5252 if Is_Private_Type
(Id
)
5253 and then Present
(Full_View
(Id
))
5255 Set_Is_Potentially_Use_Visible
(Full_View
(Id
), False);
5261 if Present
(Renamed_Entity
(Pack
)) then
5262 Set_In_Use
(Renamed_Entity
(Pack
), False);
5263 Set_Current_Use_Clause
(Renamed_Entity
(Pack
), Empty
);
5266 if Chars
(Pack
) = Name_System
5267 and then Scope
(Pack
) = Standard_Standard
5268 and then Present_System_Aux
5270 Id
:= First_Entity
(System_Aux_Id
);
5271 while Present
(Id
) loop
5272 Set_Is_Potentially_Use_Visible
(Id
, False);
5274 if Is_Private_Type
(Id
)
5275 and then Present
(Full_View
(Id
))
5277 Set_Is_Potentially_Use_Visible
(Full_View
(Id
), False);
5283 Set_In_Use
(System_Aux_Id
, False);
5286 Set_Redundant_Use
(Pack_Name
, False);
5290 if Present
(Hidden_By_Use_Clause
(N
)) then
5291 Elmt
:= First_Elmt
(Hidden_By_Use_Clause
(N
));
5292 while Present
(Elmt
) loop
5294 E
: constant Entity_Id
:= Node
(Elmt
);
5297 -- Reset either Use_Visibility or Direct_Visibility, depending
5298 -- on how the entity was hidden by the use clause.
5300 if In_Use
(Scope
(E
))
5301 and then Used_As_Generic_Actual
(Scope
(E
))
5303 Set_Is_Potentially_Use_Visible
(Node
(Elmt
));
5305 Set_Is_Immediately_Visible
(Node
(Elmt
));
5312 Set_Hidden_By_Use_Clause
(N
, No_Elist
);
5314 end End_Use_Package
;
5320 procedure End_Use_Type
(N
: Node_Id
) is
5325 -- Start of processing for End_Use_Type
5328 Id
:= Subtype_Mark
(N
);
5330 -- A call to Rtsfind may occur while analyzing a use_type_clause, in
5331 -- which case the type marks are not resolved yet, so guard against that
5334 if Is_Entity_Name
(Id
) and then Present
(Entity
(Id
)) then
5337 if T
= Any_Type
or else From_Limited_With
(T
) then
5340 -- Note that the use_type_clause may mention a subtype of the type
5341 -- whose primitive operations have been made visible. Here as
5342 -- elsewhere, it is the base type that matters for visibility.
5344 elsif In_Open_Scopes
(Scope
(Base_Type
(T
))) then
5347 elsif not Redundant_Use
(Id
) then
5348 Set_In_Use
(T
, False);
5349 Set_In_Use
(Base_Type
(T
), False);
5350 Set_Current_Use_Clause
(T
, Empty
);
5351 Set_Current_Use_Clause
(Base_Type
(T
), Empty
);
5353 -- See Use_One_Type for the rationale. This is a bit on the naive
5354 -- side, but should be good enough in practice.
5356 if Is_Tagged_Type
(T
) then
5357 Set_In_Use
(Class_Wide_Type
(T
), False);
5362 if Is_Empty_Elmt_List
(Used_Operations
(N
)) then
5366 Elmt
:= First_Elmt
(Used_Operations
(N
));
5367 while Present
(Elmt
) loop
5368 Set_Is_Potentially_Use_Visible
(Node
(Elmt
), False);
5374 --------------------
5375 -- Entity_Of_Unit --
5376 --------------------
5378 function Entity_Of_Unit
(U
: Node_Id
) return Entity_Id
is
5380 if Nkind
(U
) = N_Package_Instantiation
and then Analyzed
(U
) then
5381 return Defining_Entity
(Instance_Spec
(U
));
5383 return Defining_Entity
(U
);
5387 --------------------------------------
5388 -- Error_Missing_With_Of_Known_Unit --
5389 --------------------------------------
5391 procedure Error_Missing_With_Of_Known_Unit
(Pkg
: Node_Id
) is
5392 Selectors
: array (1 .. 6) of Node_Id
;
5393 -- Contains the chars of the full package name up to maximum number
5394 -- allowed as per Errout.Error_Msg_Name_# variables.
5396 Count
: Integer := Selectors
'First;
5397 -- Count of selector names forming the full package name
5399 Current_Pkg
: Node_Id
:= Parent
(Pkg
);
5402 Selectors
(Count
) := Pkg
;
5404 -- Gather all the selectors we can display
5406 while Nkind
(Current_Pkg
) = N_Selected_Component
5407 and then Is_Known_Unit
(Current_Pkg
)
5408 and then Count
< Selectors
'Length
5411 Selectors
(Count
) := Selector_Name
(Current_Pkg
);
5412 Current_Pkg
:= Parent
(Current_Pkg
);
5415 -- Display the error message based on the number of selectors found
5419 Error_Msg_Node_1
:= Selectors
(1);
5420 Error_Msg_N
-- CODEFIX
5421 ("\\missing `WITH &;`", Pkg
);
5423 Error_Msg_Node_1
:= Selectors
(1);
5424 Error_Msg_Node_2
:= Selectors
(2);
5425 Error_Msg_N
-- CODEFIX
5426 ("\\missing `WITH &.&;`", Pkg
);
5428 Error_Msg_Node_1
:= Selectors
(1);
5429 Error_Msg_Node_2
:= Selectors
(2);
5430 Error_Msg_Node_3
:= Selectors
(3);
5431 Error_Msg_N
-- CODEFIX
5432 ("\\missing `WITH &.&.&;`", Pkg
);
5434 Error_Msg_Node_1
:= Selectors
(1);
5435 Error_Msg_Node_2
:= Selectors
(2);
5436 Error_Msg_Node_3
:= Selectors
(3);
5437 Error_Msg_Node_3
:= Selectors
(4);
5438 Error_Msg_N
-- CODEFIX
5439 ("\\missing `WITH &.&.&.&;`", Pkg
);
5441 Error_Msg_Node_1
:= Selectors
(1);
5442 Error_Msg_Node_2
:= Selectors
(2);
5443 Error_Msg_Node_3
:= Selectors
(3);
5444 Error_Msg_Node_3
:= Selectors
(4);
5445 Error_Msg_Node_3
:= Selectors
(5);
5446 Error_Msg_N
-- CODEFIX
5447 ("\\missing `WITH &.&.&.&.&;`", Pkg
);
5449 Error_Msg_Node_1
:= Selectors
(1);
5450 Error_Msg_Node_2
:= Selectors
(2);
5451 Error_Msg_Node_3
:= Selectors
(3);
5452 Error_Msg_Node_4
:= Selectors
(4);
5453 Error_Msg_Node_5
:= Selectors
(5);
5454 Error_Msg_Node_6
:= Selectors
(6);
5455 Error_Msg_N
-- CODEFIX
5456 ("\\missing `WITH &.&.&.&.&.&;`", Pkg
);
5458 raise Program_Error
;
5460 end Error_Missing_With_Of_Known_Unit
;
5462 --------------------
5463 -- Is_Self_Hidden --
5464 --------------------
5466 function Is_Self_Hidden
(E
: Entity_Id
) return Boolean is
5468 if Is_Not_Self_Hidden
(E
) then
5469 return Ekind
(E
) = E_Void
;
5475 ----------------------
5476 -- Find_Direct_Name --
5477 ----------------------
5479 procedure Find_Direct_Name
(N
: Node_Id
) is
5484 Homonyms
: Entity_Id
;
5485 -- Saves start of homonym chain
5487 Inst
: Entity_Id
:= Empty
;
5488 -- Enclosing instance, if any
5490 Nvis_Entity
: Boolean;
5491 -- Set True to indicate that there is at least one entity on the homonym
5492 -- chain which, while not visible, is visible enough from the user point
5493 -- of view to warrant an error message of "not visible" rather than
5496 Nvis_Is_Private_Subprg
: Boolean := False;
5497 -- Ada 2005 (AI-262): Set True to indicate that a form of Beaujolais
5498 -- effect concerning library subprograms has been detected. Used to
5499 -- generate the precise error message.
5501 function From_Actual_Package
(E
: Entity_Id
) return Boolean;
5502 -- Returns true if the entity is an actual for a package that is itself
5503 -- an actual for a formal package of the current instance. Such an
5504 -- entity requires special handling because it may be use-visible but
5505 -- hides directly visible entities defined outside the instance, because
5506 -- the corresponding formal did so in the generic.
5508 function Is_Actual_Parameter
return Boolean;
5509 -- This function checks if the node N is an identifier that is an actual
5510 -- parameter of a procedure call. If so it returns True, otherwise it
5511 -- return False. The reason for this check is that at this stage we do
5512 -- not know what procedure is being called if the procedure might be
5513 -- overloaded, so it is premature to go setting referenced flags or
5514 -- making calls to Generate_Reference. We will wait till Resolve_Actuals
5515 -- for that processing.
5516 -- Note: there is a similar routine Sem_Util.Is_Actual_Parameter, but
5517 -- it works for both function and procedure calls, while here we are
5518 -- only concerned with procedure calls (and with entry calls as well,
5519 -- but they are parsed as procedure calls and only later rewritten to
5522 function Known_But_Invisible
(E
: Entity_Id
) return Boolean;
5523 -- This function determines whether a reference to the entity E, which
5524 -- is not visible, can reasonably be considered to be known to the
5525 -- writer of the reference. This is a heuristic test, used only for
5526 -- the purposes of figuring out whether we prefer to complain that an
5527 -- entity is undefined or invisible (and identify the declaration of
5528 -- the invisible entity in the latter case). The point here is that we
5529 -- don't want to complain that something is invisible and then point to
5530 -- something entirely mysterious to the writer.
5532 procedure Nvis_Messages
;
5533 -- Called if there are no visible entries for N, but there is at least
5534 -- one non-directly visible, or hidden declaration. This procedure
5535 -- outputs an appropriate set of error messages.
5537 procedure Undefined
(Nvis
: Boolean);
5538 -- This function is called if the current node has no corresponding
5539 -- visible entity or entities. The value set in Msg indicates whether
5540 -- an error message was generated (multiple error messages for the
5541 -- same variable are generally suppressed, see body for details).
5542 -- Msg is True if an error message was generated, False if not. This
5543 -- value is used by the caller to determine whether or not to output
5544 -- additional messages where appropriate. The parameter is set False
5545 -- to get the message "X is undefined", and True to get the message
5546 -- "X is not visible".
5548 -------------------------
5549 -- From_Actual_Package --
5550 -------------------------
5552 function From_Actual_Package
(E
: Entity_Id
) return Boolean is
5553 Scop
: constant Entity_Id
:= Scope
(E
);
5554 -- Declared scope of candidate entity
5556 function Declared_In_Actual
(Pack
: Entity_Id
) return Boolean;
5557 -- Recursive function that does the work and examines actuals of
5558 -- actual packages of current instance.
5560 ------------------------
5561 -- Declared_In_Actual --
5562 ------------------------
5564 function Declared_In_Actual
(Pack
: Entity_Id
) return Boolean is
5565 pragma Assert
(Ekind
(Pack
) = E_Package
);
5568 if No
(Associated_Formal_Package
(Pack
)) then
5572 Act
:= First_Entity
(Pack
);
5573 while Present
(Act
) loop
5574 if Renamed_Entity
(Pack
) = Scop
then
5577 -- Check for end of list of actuals
5579 elsif Ekind
(Act
) = E_Package
5580 and then Renamed_Entity
(Act
) = Pack
5584 elsif Ekind
(Act
) = E_Package
5585 and then Declared_In_Actual
(Act
)
5595 end Declared_In_Actual
;
5601 -- Start of processing for From_Actual_Package
5604 if not In_Instance
then
5608 Inst
:= Current_Scope
;
5609 while Present
(Inst
)
5610 and then Ekind
(Inst
) /= E_Package
5611 and then not Is_Generic_Instance
(Inst
)
5613 Inst
:= Scope
(Inst
);
5620 Act
:= First_Entity
(Inst
);
5621 while Present
(Act
) loop
5622 if Ekind
(Act
) = E_Package
5623 and then Declared_In_Actual
(Act
)
5633 end From_Actual_Package
;
5635 -------------------------
5636 -- Is_Actual_Parameter --
5637 -------------------------
5639 function Is_Actual_Parameter
return Boolean is
5641 if Nkind
(N
) = N_Identifier
then
5642 case Nkind
(Parent
(N
)) is
5643 when N_Procedure_Call_Statement
=>
5644 return Is_List_Member
(N
)
5645 and then List_Containing
(N
) =
5646 Parameter_Associations
(Parent
(N
));
5648 when N_Parameter_Association
=>
5649 return N
= Explicit_Actual_Parameter
(Parent
(N
))
5650 and then Nkind
(Parent
(Parent
(N
))) =
5651 N_Procedure_Call_Statement
;
5659 end Is_Actual_Parameter
;
5661 -------------------------
5662 -- Known_But_Invisible --
5663 -------------------------
5665 function Known_But_Invisible
(E
: Entity_Id
) return Boolean is
5666 Fname
: File_Name_Type
;
5669 -- Entities in Standard are always considered to be known
5671 if Sloc
(E
) <= Standard_Location
then
5674 -- An entity that does not come from source is always considered
5675 -- to be unknown, since it is an artifact of code expansion.
5677 elsif not Comes_From_Source
(E
) then
5681 -- Here we have an entity that is not from package Standard, and
5682 -- which comes from Source. See if it comes from an internal file.
5684 Fname
:= Unit_File_Name
(Get_Source_Unit
(E
));
5686 -- Case of from internal file
5688 if In_Internal_Unit
(E
) then
5690 -- Private part entities in internal files are never considered
5691 -- to be known to the writer of normal application code.
5693 if Is_Hidden
(E
) then
5697 -- Entities from System packages other than System and
5698 -- System.Storage_Elements are not considered to be known.
5699 -- System.Auxxxx files are also considered known to the user.
5701 -- Should refine this at some point to generally distinguish
5702 -- between known and unknown internal files ???
5704 Get_Name_String
(Fname
);
5709 Name_Buffer
(1 .. 2) /= "s-"
5711 Name_Buffer
(3 .. 8) = "stoele"
5713 Name_Buffer
(3 .. 5) = "aux";
5715 -- If not an internal file, then entity is definitely known, even if
5716 -- it is in a private part (the message generated will note that it
5717 -- is in a private part).
5722 end Known_But_Invisible
;
5728 procedure Nvis_Messages
is
5729 Comp_Unit
: Node_Id
;
5731 Found
: Boolean := False;
5732 Hidden
: Boolean := False;
5736 -- Ada 2005 (AI-262): Generate a precise error concerning the
5737 -- Beaujolais effect that was previously detected
5739 if Nvis_Is_Private_Subprg
then
5741 pragma Assert
(Nkind
(E2
) = N_Defining_Identifier
5742 and then Ekind
(E2
) = E_Function
5743 and then Scope
(E2
) = Standard_Standard
5744 and then Has_Private_With
(E2
));
5746 -- Find the sloc corresponding to the private with'ed unit
5748 Comp_Unit
:= Cunit
(Current_Sem_Unit
);
5749 Error_Msg_Sloc
:= No_Location
;
5751 Item
:= First
(Context_Items
(Comp_Unit
));
5752 while Present
(Item
) loop
5753 if Nkind
(Item
) = N_With_Clause
5754 and then Private_Present
(Item
)
5755 and then Entity
(Name
(Item
)) = E2
5757 Error_Msg_Sloc
:= Sloc
(Item
);
5764 pragma Assert
(Error_Msg_Sloc
/= No_Location
);
5766 Error_Msg_N
("(Ada 2005): hidden by private with clause #", N
);
5770 Undefined
(Nvis
=> True);
5774 -- First loop does hidden declarations
5777 while Present
(Ent
) loop
5778 if Is_Potentially_Use_Visible
(Ent
) then
5780 Error_Msg_N
-- CODEFIX
5781 ("multiple use clauses cause hiding!", N
);
5785 Error_Msg_Sloc
:= Sloc
(Ent
);
5786 Error_Msg_N
-- CODEFIX
5787 ("hidden declaration#!", N
);
5790 Ent
:= Homonym
(Ent
);
5793 -- If we found hidden declarations, then that's enough, don't
5794 -- bother looking for non-visible declarations as well.
5800 -- Second loop does non-directly visible declarations
5803 while Present
(Ent
) loop
5804 if not Is_Potentially_Use_Visible
(Ent
) then
5806 -- Do not bother the user with unknown entities
5808 if not Known_But_Invisible
(Ent
) then
5812 Error_Msg_Sloc
:= Sloc
(Ent
);
5814 -- Output message noting that there is a non-visible
5815 -- declaration, distinguishing the private part case.
5817 if Is_Hidden
(Ent
) then
5818 Error_Msg_N
("non-visible (private) declaration#!", N
);
5820 -- If the entity is declared in a generic package, it
5821 -- cannot be visible, so there is no point in adding it
5822 -- to the list of candidates if another homograph from a
5823 -- non-generic package has been seen.
5825 elsif Ekind
(Scope
(Ent
)) = E_Generic_Package
5831 -- When the entity comes from a generic instance the
5832 -- normal error message machinery will give the line
5833 -- number of the generic package and the location of
5834 -- the generic instance, but not the name of the
5837 -- So, in order to give more descriptive error messages
5838 -- in this case, we include the name of the generic
5841 if Is_Generic_Instance
(Scope
(Ent
)) then
5842 Error_Msg_Name_1
:= Chars
(Scope
(Ent
));
5843 Error_Msg_N
-- CODEFIX
5844 ("non-visible declaration from %#!", N
);
5846 -- Otherwise print the message normally
5849 Error_Msg_N
-- CODEFIX
5850 ("non-visible declaration#!", N
);
5853 if Ekind
(Scope
(Ent
)) /= E_Generic_Package
then
5857 if Is_Compilation_Unit
(Ent
)
5859 Nkind
(Parent
(Parent
(N
))) = N_Use_Package_Clause
5861 Error_Msg_Qual_Level
:= 99;
5862 Error_Msg_NE
-- CODEFIX
5863 ("\\missing `WITH &;`", N
, Ent
);
5864 Error_Msg_Qual_Level
:= 0;
5867 if Ekind
(Ent
) = E_Discriminant
5868 and then Present
(Corresponding_Discriminant
(Ent
))
5869 and then Scope
(Corresponding_Discriminant
(Ent
)) =
5873 ("inherited discriminant not allowed here" &
5874 " (RM 3.8 (12), 3.8.1 (6))!", N
);
5878 -- Set entity and its containing package as referenced. We
5879 -- can't be sure of this, but this seems a better choice
5880 -- to avoid unused entity messages.
5882 if Comes_From_Source
(Ent
) then
5883 Set_Referenced
(Ent
);
5884 Set_Referenced
(Cunit_Entity
(Get_Source_Unit
(Ent
)));
5889 Ent
:= Homonym
(Ent
);
5898 procedure Undefined
(Nvis
: Boolean) is
5899 Emsg
: Error_Msg_Id
;
5902 -- We should never find an undefined internal name. If we do, then
5903 -- see if we have previous errors. If so, ignore on the grounds that
5904 -- it is probably a cascaded message (e.g. a block label from a badly
5905 -- formed block). If no previous errors, then we have a real internal
5906 -- error of some kind so raise an exception.
5908 if Is_Internal_Name
(Chars
(N
)) then
5909 if Total_Errors_Detected
/= 0 then
5912 raise Program_Error
;
5916 -- A very specialized error check, if the undefined variable is
5917 -- a case tag, and the case type is an enumeration type, check
5918 -- for a possible misspelling, and if so, modify the identifier
5920 -- Named aggregate should also be handled similarly ???
5922 if Nkind
(N
) = N_Identifier
5923 and then Nkind
(Parent
(N
)) = N_Case_Statement_Alternative
5926 Case_Stm
: constant Node_Id
:= Parent
(Parent
(N
));
5927 Case_Typ
: constant Entity_Id
:= Etype
(Expression
(Case_Stm
));
5932 if Is_Enumeration_Type
(Case_Typ
)
5933 and then not Is_Standard_Character_Type
(Case_Typ
)
5935 Lit
:= First_Literal
(Case_Typ
);
5936 Get_Name_String
(Chars
(Lit
));
5938 if Chars
(Lit
) /= Chars
(N
)
5939 and then Is_Bad_Spelling_Of
(Chars
(N
), Chars
(Lit
))
5941 Error_Msg_Node_2
:= Lit
;
5942 Error_Msg_N
-- CODEFIX
5943 ("& is undefined, assume misspelling of &", N
);
5944 Rewrite
(N
, New_Occurrence_Of
(Lit
, Sloc
(N
)));
5953 -- Normal processing
5955 Set_Entity
(N
, Any_Id
);
5956 Set_Etype
(N
, Any_Type
);
5958 -- We use the table Urefs to keep track of entities for which we
5959 -- have issued errors for undefined references. Multiple errors
5960 -- for a single name are normally suppressed, however we modify
5961 -- the error message to alert the programmer to this effect.
5963 for J
in Urefs
.First
.. Urefs
.Last
loop
5964 if Chars
(N
) = Chars
(Urefs
.Table
(J
).Node
) then
5965 if Urefs
.Table
(J
).Err
/= No_Error_Msg
5966 and then Sloc
(N
) /= Urefs
.Table
(J
).Loc
5968 Error_Msg_Node_1
:= Urefs
.Table
(J
).Node
;
5970 if Urefs
.Table
(J
).Nvis
then
5971 Change_Error_Text
(Urefs
.Table
(J
).Err
,
5972 "& is not visible (more references follow)");
5974 Change_Error_Text
(Urefs
.Table
(J
).Err
,
5975 "& is undefined (more references follow)");
5978 Urefs
.Table
(J
).Err
:= No_Error_Msg
;
5981 -- Although we will set Msg False, and thus suppress the
5982 -- message, we also set Error_Posted True, to avoid any
5983 -- cascaded messages resulting from the undefined reference.
5986 Set_Error_Posted
(N
);
5991 -- If entry not found, this is first undefined occurrence
5994 Error_Msg_N
("& is not visible!", N
);
5998 Error_Msg_N
("& is undefined!", N
);
6001 -- A very bizarre special check, if the undefined identifier
6002 -- is Put or Put_Line, then add a special error message (since
6003 -- this is a very common error for beginners to make).
6005 if Chars
(N
) in Name_Put | Name_Put_Line
then
6006 Error_Msg_N
-- CODEFIX
6007 ("\\possible missing `WITH Ada.Text_'I'O; " &
6008 "USE Ada.Text_'I'O`!", N
);
6010 -- Another special check if N is the prefix of a selected
6011 -- component which is a known unit: add message complaining
6012 -- about missing with for this unit.
6014 elsif Nkind
(Parent
(N
)) = N_Selected_Component
6015 and then N
= Prefix
(Parent
(N
))
6016 and then Is_Known_Unit
(Parent
(N
))
6018 Error_Missing_With_Of_Known_Unit
(N
);
6021 -- Now check for possible misspellings
6025 Ematch
: Entity_Id
:= Empty
;
6027 for Nam
in First_Name_Id
.. Last_Name_Id
loop
6028 E
:= Get_Name_Entity_Id
(Nam
);
6031 and then (Is_Immediately_Visible
(E
)
6033 Is_Potentially_Use_Visible
(E
))
6035 if Is_Bad_Spelling_Of
(Chars
(N
), Nam
) then
6042 if Present
(Ematch
) then
6043 Error_Msg_NE
-- CODEFIX
6044 ("\possible misspelling of&", N
, Ematch
);
6049 -- Make entry in undefined references table unless the full errors
6050 -- switch is set, in which case by refraining from generating the
6051 -- table entry we guarantee that we get an error message for every
6052 -- undefined reference. The entry is not added if we are ignoring
6055 if not All_Errors_Mode
6056 and then Ignore_Errors_Enable
= 0
6057 and then not Get_Ignore_Errors
6071 Nested_Inst
: Entity_Id
:= Empty
;
6072 -- The entity of a nested instance which appears within Inst (if any)
6074 -- Start of processing for Find_Direct_Name
6077 -- If the entity pointer is already set, this is an internal node, or
6078 -- a node that is analyzed more than once, after a tree modification.
6079 -- In such a case there is no resolution to perform, just set the type.
6081 if Present
(Entity
(N
)) then
6082 if Is_Type
(Entity
(N
)) then
6083 Set_Etype
(N
, Entity
(N
));
6087 Entyp
: constant Entity_Id
:= Etype
(Entity
(N
));
6090 -- One special case here. If the Etype field is already set,
6091 -- and references the packed array type corresponding to the
6092 -- etype of the referenced entity, then leave it alone. This
6093 -- happens for trees generated from Exp_Pakd, where expressions
6094 -- can be deliberately "mis-typed" to the packed array type.
6096 if Is_Packed_Array
(Entyp
)
6097 and then Present
(Etype
(N
))
6098 and then Etype
(N
) = Packed_Array_Impl_Type
(Entyp
)
6102 -- If not that special case, then just reset the Etype
6105 Set_Etype
(N
, Entyp
);
6110 -- Although the marking of use clauses happens at the end of
6111 -- Find_Direct_Name, a certain case where a generic actual satisfies
6112 -- a use clause must be checked here due to how the generic machinery
6113 -- handles the analysis of said actuals.
6116 and then Nkind
(Parent
(N
)) = N_Generic_Association
6118 Mark_Use_Clauses
(Entity
(N
));
6124 -- Preserve relevant elaboration-related attributes of the context which
6125 -- are no longer available or very expensive to recompute once analysis,
6126 -- resolution, and expansion are over.
6128 if Nkind
(N
) = N_Identifier
then
6129 Mark_Elaboration_Attributes
6136 -- Here if Entity pointer was not set, we need full visibility analysis
6137 -- First we generate debugging output if the debug E flag is set.
6139 if Debug_Flag_E
then
6140 Write_Str
("Looking for ");
6141 Write_Name
(Chars
(N
));
6145 Homonyms
:= Current_Entity
(N
);
6146 Nvis_Entity
:= False;
6149 while Present
(E
) loop
6151 -- If entity is immediately visible or potentially use visible, then
6152 -- process the entity and we are done.
6154 if Is_Immediately_Visible
(E
) then
6155 goto Immediately_Visible_Entity
;
6157 elsif Is_Potentially_Use_Visible
(E
) then
6158 goto Potentially_Use_Visible_Entity
;
6160 -- Note if a known but invisible entity encountered
6162 elsif Known_But_Invisible
(E
) then
6163 Nvis_Entity
:= True;
6166 -- Move to next entity in chain and continue search
6171 -- If no entries on homonym chain that were potentially visible,
6172 -- and no entities reasonably considered as non-visible, then
6173 -- we have a plain undefined reference, with no additional
6174 -- explanation required.
6176 if not Nvis_Entity
then
6177 Undefined
(Nvis
=> False);
6179 -- Otherwise there is at least one entry on the homonym chain that
6180 -- is reasonably considered as being known and non-visible.
6188 -- Processing for a potentially use visible entry found. We must search
6189 -- the rest of the homonym chain for two reasons. First, if there is a
6190 -- directly visible entry, then none of the potentially use-visible
6191 -- entities are directly visible (RM 8.4(10)). Second, we need to check
6192 -- for the case of multiple potentially use-visible entries hiding one
6193 -- another and as a result being non-directly visible (RM 8.4(11)).
6195 <<Potentially_Use_Visible_Entity
>> declare
6196 Only_One_Visible
: Boolean := True;
6197 All_Overloadable
: Boolean := Is_Overloadable
(E
);
6201 while Present
(E2
) loop
6202 if Is_Immediately_Visible
(E2
) then
6204 -- If the use-visible entity comes from the actual for a
6205 -- formal package, it hides a directly visible entity from
6206 -- outside the instance.
6208 if From_Actual_Package
(E
)
6209 and then Scope_Depth
(Scope
(E2
)) < Scope_Depth
(Inst
)
6214 goto Immediately_Visible_Entity
;
6217 elsif Is_Potentially_Use_Visible
(E2
) then
6218 Only_One_Visible
:= False;
6219 All_Overloadable
:= All_Overloadable
and Is_Overloadable
(E2
);
6221 -- Ada 2005 (AI-262): Protect against a form of Beaujolais effect
6222 -- that can occur in private_with clauses. Example:
6225 -- private with B; package A is
6226 -- package C is function B return Integer;
6228 -- V1 : Integer := B;
6229 -- private function B return Integer;
6230 -- V2 : Integer := B;
6233 -- V1 resolves to A.B, but V2 resolves to library unit B
6235 elsif Ekind
(E2
) = E_Function
6236 and then Scope
(E2
) = Standard_Standard
6237 and then Has_Private_With
(E2
)
6239 Only_One_Visible
:= False;
6240 All_Overloadable
:= False;
6241 Nvis_Is_Private_Subprg
:= True;
6248 -- On falling through this loop, we have checked that there are no
6249 -- immediately visible entities. Only_One_Visible is set if exactly
6250 -- one potentially use visible entity exists. All_Overloadable is
6251 -- set if all the potentially use visible entities are overloadable.
6252 -- The condition for legality is that either there is one potentially
6253 -- use visible entity, or if there is more than one, then all of them
6254 -- are overloadable.
6256 if Only_One_Visible
or All_Overloadable
then
6259 -- If there is more than one potentially use-visible entity and at
6260 -- least one of them non-overloadable, we have an error (RM 8.4(11)).
6261 -- Note that E points to the first such entity on the homonym list.
6264 -- If one of the entities is declared in an actual package, it
6265 -- was visible in the generic, and takes precedence over other
6266 -- entities that are potentially use-visible. The same applies
6267 -- if the entity is declared in a local instantiation of the
6268 -- current instance.
6272 -- Find the current instance
6274 Inst
:= Current_Scope
;
6275 while Present
(Inst
) and then Inst
/= Standard_Standard
loop
6276 if Is_Generic_Instance
(Inst
) then
6280 Inst
:= Scope
(Inst
);
6283 -- Reexamine the candidate entities, giving priority to those
6284 -- that were visible within the generic.
6287 while Present
(E2
) loop
6288 Nested_Inst
:= Nearest_Enclosing_Instance
(E2
);
6290 -- The entity is declared within an actual package, or in a
6291 -- nested instance. The ">=" accounts for the case where the
6292 -- current instance and the nested instance are the same.
6294 if From_Actual_Package
(E2
)
6295 or else (Present
(Nested_Inst
)
6296 and then Scope_Depth
(Nested_Inst
) >=
6309 elsif Is_Predefined_Unit
(Current_Sem_Unit
) then
6310 -- A use clause in the body of a system file creates conflict
6311 -- with some entity in a user scope, while rtsfind is active.
6312 -- Keep only the entity coming from another predefined unit.
6315 while Present
(E2
) loop
6316 if In_Predefined_Unit
(E2
) then
6324 -- Entity must exist because predefined unit is correct
6326 raise Program_Error
;
6335 -- Come here with E set to the first immediately visible entity on
6336 -- the homonym chain. This is the one we want unless there is another
6337 -- immediately visible entity further on in the chain for an inner
6338 -- scope (RM 8.3(8)).
6340 <<Immediately_Visible_Entity
>> declare
6345 -- Find scope level of initial entity. When compiling through
6346 -- Rtsfind, the previous context is not completely invisible, and
6347 -- an outer entity may appear on the chain, whose scope is below
6348 -- the entry for Standard that delimits the current scope stack.
6349 -- Indicate that the level for this spurious entry is outside of
6350 -- the current scope stack.
6352 Level
:= Scope_Stack
.Last
;
6354 Scop
:= Scope_Stack
.Table
(Level
).Entity
;
6355 exit when Scop
= Scope
(E
);
6357 exit when Scop
= Standard_Standard
;
6360 -- Now search remainder of homonym chain for more inner entry
6361 -- If the entity is Standard itself, it has no scope, and we
6362 -- compare it with the stack entry directly.
6365 while Present
(E2
) loop
6366 if Is_Immediately_Visible
(E2
) then
6368 -- If a generic package contains a local declaration that
6369 -- has the same name as the generic, there may be a visibility
6370 -- conflict in an instance, where the local declaration must
6371 -- also hide the name of the corresponding package renaming.
6372 -- We check explicitly for a package declared by a renaming,
6373 -- whose renamed entity is an instance that is on the scope
6374 -- stack, and that contains a homonym in the same scope. Once
6375 -- we have found it, we know that the package renaming is not
6376 -- immediately visible, and that the identifier denotes the
6377 -- other entity (and its homonyms if overloaded).
6379 if Scope
(E
) = Scope
(E2
)
6380 and then Ekind
(E
) = E_Package
6381 and then Present
(Renamed_Entity
(E
))
6382 and then Is_Generic_Instance
(Renamed_Entity
(E
))
6383 and then In_Open_Scopes
(Renamed_Entity
(E
))
6384 and then Comes_From_Source
(N
)
6386 Set_Is_Immediately_Visible
(E
, False);
6390 for J
in Level
+ 1 .. Scope_Stack
.Last
loop
6391 if Scope_Stack
.Table
(J
).Entity
= Scope
(E2
)
6392 or else Scope_Stack
.Table
(J
).Entity
= E2
6405 -- At the end of that loop, E is the innermost immediately
6406 -- visible entity, so we are all set.
6409 -- Come here with entity found, and stored in E
6413 -- Check violation of No_Wide_Characters restriction
6415 Check_Wide_Character_Restriction
(E
, N
);
6417 -- When distribution features are available (Get_PCS_Name /=
6418 -- Name_No_DSA), a remote access-to-subprogram type is converted
6419 -- into a record type holding whatever information is needed to
6420 -- perform a remote call on an RCI subprogram. In that case we
6421 -- rewrite any occurrence of the RAS type into the equivalent record
6422 -- type here. 'Access attribute references and RAS dereferences are
6423 -- then implemented using specific TSSs. However when distribution is
6424 -- not available (case of Get_PCS_Name = Name_No_DSA), we bypass the
6425 -- generation of these TSSs, and we must keep the RAS type in its
6426 -- original access-to-subprogram form (since all calls through a
6427 -- value of such type will be local anyway in the absence of a PCS).
6429 if Comes_From_Source
(N
)
6430 and then Is_Remote_Access_To_Subprogram_Type
(E
)
6431 and then Ekind
(E
) = E_Access_Subprogram_Type
6432 and then Expander_Active
6433 and then Get_PCS_Name
/= Name_No_DSA
6435 Rewrite
(N
, New_Occurrence_Of
(Equivalent_Type
(E
), Sloc
(N
)));
6439 -- Set the entity. Note that the reason we call Set_Entity for the
6440 -- overloadable case, as opposed to Set_Entity_With_Checks is
6441 -- that in the overloaded case, the initial call can set the wrong
6442 -- homonym. The call that sets the right homonym is in Sem_Res and
6443 -- that call does use Set_Entity_With_Checks, so we don't miss
6446 if Is_Overloadable
(E
) then
6449 Set_Entity_With_Checks
(N
, E
);
6455 Set_Etype
(N
, Get_Full_View
(Etype
(E
)));
6458 if Debug_Flag_E
then
6459 Write_Str
(" found ");
6460 Write_Entity_Info
(E
, " ");
6463 if Is_Self_Hidden
(E
)
6465 (not Is_Record_Type
(Current_Scope
)
6466 or else Nkind
(Parent
(N
)) /= N_Pragma_Argument_Association
)
6468 Premature_Usage
(N
);
6470 -- If the entity is overloadable, collect all interpretations of the
6471 -- name for subsequent overload resolution. We optimize a bit here to
6472 -- do this only if we have an overloadable entity that is not on its
6473 -- own on the homonym chain.
6475 elsif Is_Overloadable
(E
)
6476 and then (Present
(Homonym
(E
)) or else Current_Entity
(N
) /= E
)
6478 Collect_Interps
(N
);
6480 -- If no homonyms were visible, the entity is unambiguous
6482 if not Is_Overloaded
(N
) then
6483 if not Is_Actual_Parameter
then
6484 Generate_Reference
(E
, N
);
6488 -- Case of non-overloadable entity, set the entity providing that
6489 -- we do not have the case of a discriminant reference within a
6490 -- default expression. Such references are replaced with the
6491 -- corresponding discriminal, which is the formal corresponding to
6492 -- to the discriminant in the initialization procedure.
6495 -- Entity is unambiguous, indicate that it is referenced here
6497 -- For a renaming of an object, always generate simple reference,
6498 -- we don't try to keep track of assignments in this case, except
6499 -- in SPARK mode where renamings are traversed for generating
6500 -- local effects of subprograms.
6503 and then Present
(Renamed_Object
(E
))
6504 and then not GNATprove_Mode
6506 Generate_Reference
(E
, N
);
6508 -- If the renamed entity is a private protected component,
6509 -- reference the original component as well. This needs to be
6510 -- done because the private renamings are installed before any
6511 -- analysis has occurred. Reference to a private component will
6512 -- resolve to the renaming and the original component will be
6513 -- left unreferenced, hence the following.
6515 if Is_Prival
(E
) then
6516 Generate_Reference
(Prival_Link
(E
), N
);
6519 -- One odd case is that we do not want to set the Referenced flag
6520 -- if the entity is a label, and the identifier is the label in
6521 -- the source, since this is not a reference from the point of
6522 -- view of the user.
6524 elsif Nkind
(Parent
(N
)) = N_Label
then
6526 R
: constant Boolean := Referenced
(E
);
6529 -- Generate reference unless this is an actual parameter
6530 -- (see comment below).
6532 if not Is_Actual_Parameter
then
6533 Generate_Reference
(E
, N
);
6534 Set_Referenced
(E
, R
);
6538 -- Normal case, not a label: generate reference
6541 if not Is_Actual_Parameter
then
6543 -- Package or generic package is always a simple reference
6545 if Is_Package_Or_Generic_Package
(E
) then
6546 Generate_Reference
(E
, N
, 'r');
6548 -- Else see if we have a left hand side
6551 case Known_To_Be_Assigned
(N
, Only_LHS
=> True) is
6553 Generate_Reference
(E
, N
, 'm');
6556 Generate_Reference
(E
, N
, 'r');
6563 Set_Entity_Or_Discriminal
(N
, E
);
6565 -- The name may designate a generalized reference, in which case
6566 -- the dereference interpretation will be included. Context is
6567 -- one in which a name is legal.
6569 if Ada_Version
>= Ada_2012
6571 (Nkind
(Parent
(N
)) in N_Subexpr
6572 or else Nkind
(Parent
(N
)) in N_Assignment_Statement
6573 | N_Object_Declaration
6574 | N_Parameter_Association
)
6576 Check_Implicit_Dereference
(N
, Etype
(E
));
6581 -- Mark relevant use-type and use-package clauses as effective if the
6582 -- node in question is not overloaded and therefore does not require
6585 -- Note: Generic actual subprograms do not follow the normal resolution
6586 -- path, so ignore the fact that they are overloaded and mark them
6589 if Nkind
(N
) not in N_Subexpr
or else not Is_Overloaded
(N
) then
6590 Mark_Use_Clauses
(N
);
6593 -- Come here with entity set
6596 Check_Restriction_No_Use_Of_Entity
(N
);
6598 -- Annotate the tree by creating a variable reference marker in case the
6599 -- original variable reference is folded or optimized away. The variable
6600 -- reference marker is automatically saved for later examination by the
6601 -- ABE Processing phase. Variable references which act as actuals in a
6602 -- call require special processing and are left to Resolve_Actuals. The
6603 -- reference is a write when it appears on the left hand side of an
6606 if Needs_Variable_Reference_Marker
(N
=> N
, Calls_OK
=> False) then
6608 Is_Assignment_LHS
: constant Boolean := Known_To_Be_Assigned
(N
);
6611 Build_Variable_Reference_Marker
6613 Read
=> not Is_Assignment_LHS
,
6614 Write
=> Is_Assignment_LHS
);
6617 end Find_Direct_Name
;
6619 ------------------------
6620 -- Find_Expanded_Name --
6621 ------------------------
6623 -- This routine searches the homonym chain of the entity until it finds
6624 -- an entity declared in the scope denoted by the prefix. If the entity
6625 -- is private, it may nevertheless be immediately visible, if we are in
6626 -- the scope of its declaration.
6628 procedure Find_Expanded_Name
(N
: Node_Id
) is
6629 function In_Abstract_View_Pragma
(Nod
: Node_Id
) return Boolean;
6630 -- Determine whether expanded name Nod appears within a pragma which is
6631 -- a suitable context for an abstract view of a state or variable. The
6632 -- following pragmas fall in this category:
6639 -- In addition, pragma Abstract_State is also considered suitable even
6640 -- though it is an illegal context for an abstract view as this allows
6641 -- for proper resolution of abstract views of variables. This illegal
6642 -- context is later flagged in the analysis of indicator Part_Of.
6644 -----------------------------
6645 -- In_Abstract_View_Pragma --
6646 -----------------------------
6648 function In_Abstract_View_Pragma
(Nod
: Node_Id
) return Boolean is
6652 -- Climb the parent chain looking for a pragma
6655 while Present
(Par
) loop
6656 if Nkind
(Par
) = N_Pragma
then
6657 if Pragma_Name_Unmapped
(Par
)
6658 in Name_Abstract_State
6662 | Name_Refined_Depends
6663 | Name_Refined_Global
6667 -- Otherwise the pragma is not a legal context for an abstract
6674 -- Prevent the search from going too far
6676 elsif Is_Body_Or_Package_Declaration
(Par
) then
6680 Par
:= Parent
(Par
);
6684 end In_Abstract_View_Pragma
;
6688 Selector
: constant Node_Id
:= Selector_Name
(N
);
6690 Candidate
: Entity_Id
:= Empty
;
6694 -- Start of processing for Find_Expanded_Name
6697 P_Name
:= Entity
(Prefix
(N
));
6699 -- If the prefix is a renamed package, look for the entity in the
6700 -- original package.
6702 if Ekind
(P_Name
) = E_Package
6703 and then Present
(Renamed_Entity
(P_Name
))
6705 P_Name
:= Renamed_Entity
(P_Name
);
6707 if From_Limited_With
(P_Name
)
6708 and then not Unit_Is_Visible
(Cunit
(Get_Source_Unit
(P_Name
)))
6711 ("renaming of limited view of package & not usable in this"
6712 & " context (RM 8.5.3(3.1/2))", Prefix
(N
), P_Name
);
6714 elsif Has_Limited_View
(P_Name
)
6715 and then not Unit_Is_Visible
(Cunit
(Get_Source_Unit
(P_Name
)))
6716 and then not Is_Visible_Through_Renamings
(P_Name
)
6719 ("renaming of limited view of package & not usable in this"
6720 & " context (RM 8.5.3(3.1/2))", Prefix
(N
), P_Name
);
6723 -- Rewrite node with entity field pointing to renamed object
6725 Rewrite
(Prefix
(N
), New_Copy
(Prefix
(N
)));
6726 Set_Entity
(Prefix
(N
), P_Name
);
6728 -- If the prefix is an object of a concurrent type, look for
6729 -- the entity in the associated task or protected type.
6731 elsif Is_Concurrent_Type
(Etype
(P_Name
)) then
6732 P_Name
:= Etype
(P_Name
);
6735 Id
:= Current_Entity
(Selector
);
6738 Is_New_Candidate
: Boolean;
6741 while Present
(Id
) loop
6742 if Scope
(Id
) = P_Name
then
6744 Is_New_Candidate
:= True;
6746 -- Handle abstract views of states and variables. These are
6747 -- acceptable candidates only when the reference to the view
6748 -- appears in certain pragmas.
6750 if Ekind
(Id
) = E_Abstract_State
6751 and then From_Limited_With
(Id
)
6752 and then Present
(Non_Limited_View
(Id
))
6754 if In_Abstract_View_Pragma
(N
) then
6755 Candidate
:= Non_Limited_View
(Id
);
6756 Is_New_Candidate
:= True;
6758 -- Hide the candidate because it is not used in a proper
6763 Is_New_Candidate
:= False;
6767 -- Ada 2005 (AI-217): Handle shadow entities associated with
6768 -- types declared in limited-withed nested packages. We don't need
6769 -- to handle E_Incomplete_Subtype entities because the entities
6770 -- in the limited view are always E_Incomplete_Type and
6771 -- E_Class_Wide_Type entities (see Build_Limited_Views).
6773 -- Regarding the expression used to evaluate the scope, it
6774 -- is important to note that the limited view also has shadow
6775 -- entities associated nested packages. For this reason the
6776 -- correct scope of the entity is the scope of the real entity.
6777 -- The non-limited view may itself be incomplete, in which case
6778 -- get the full view if available.
6780 elsif Ekind
(Id
) in E_Incomplete_Type | E_Class_Wide_Type
6781 and then From_Limited_With
(Id
)
6782 and then Present
(Non_Limited_View
(Id
))
6783 and then Scope
(Non_Limited_View
(Id
)) = P_Name
6785 Candidate
:= Get_Full_View
(Non_Limited_View
(Id
));
6786 Is_New_Candidate
:= True;
6788 -- Handle special case where the prefix is a renaming of a shadow
6789 -- package which is visible. Required to avoid reporting spurious
6792 elsif Ekind
(P_Name
) = E_Package
6793 and then From_Limited_With
(P_Name
)
6794 and then not From_Limited_With
(Id
)
6795 and then Sloc
(Scope
(Id
)) = Sloc
(P_Name
)
6796 and then Unit_Is_Visible
(Cunit
(Get_Source_Unit
(P_Name
)))
6798 Candidate
:= Get_Full_View
(Id
);
6799 Is_New_Candidate
:= True;
6801 -- An unusual case arises with a fully qualified name for an
6802 -- entity local to a generic child unit package, within an
6803 -- instantiation of that package. The name of the unit now
6804 -- denotes the renaming created within the instance. This is
6805 -- only relevant in an instance body, see below.
6807 elsif Is_Generic_Instance
(Scope
(Id
))
6808 and then In_Open_Scopes
(Scope
(Id
))
6809 and then In_Instance_Body
6810 and then Ekind
(Scope
(Id
)) = E_Package
6811 and then Ekind
(Id
) = E_Package
6812 and then Renamed_Entity
(Id
) = Scope
(Id
)
6813 and then Is_Immediately_Visible
(P_Name
)
6815 Is_New_Candidate
:= True;
6818 Is_New_Candidate
:= False;
6821 if Is_New_Candidate
then
6823 -- If entity is a child unit, either it is a visible child of
6824 -- the prefix, or we are in the body of a generic prefix, as
6825 -- will happen when a child unit is instantiated in the body
6826 -- of a generic parent. This is because the instance body does
6827 -- not restore the full compilation context, given that all
6828 -- non-local references have been captured.
6830 if Is_Child_Unit
(Id
) or else P_Name
= Standard_Standard
then
6831 exit when Is_Visible_Lib_Unit
(Id
)
6832 or else (Is_Child_Unit
(Id
)
6833 and then In_Open_Scopes
(Scope
(Id
))
6834 and then In_Instance_Body
);
6836 exit when not Is_Hidden
(Id
);
6839 exit when Is_Immediately_Visible
(Id
);
6847 and then Ekind
(P_Name
) in E_Procedure | E_Function
6848 and then Is_Generic_Instance
(P_Name
)
6850 -- Expanded name denotes entity in (instance of) generic subprogram.
6851 -- The entity may be in the subprogram instance, or may denote one of
6852 -- the formals, which is declared in the enclosing wrapper package.
6854 P_Name
:= Scope
(P_Name
);
6856 Id
:= Current_Entity
(Selector
);
6857 while Present
(Id
) loop
6858 exit when Scope
(Id
) = P_Name
;
6863 if No
(Id
) or else Chars
(Id
) /= Chars
(Selector
) then
6864 Set_Etype
(N
, Any_Type
);
6866 -- If we are looking for an entity defined in System, try to find it
6867 -- in the child package that may have been provided as an extension
6868 -- to System. The Extend_System pragma will have supplied the name of
6869 -- the extension, which may have to be loaded.
6871 if Chars
(P_Name
) = Name_System
6872 and then Scope
(P_Name
) = Standard_Standard
6873 and then Present
(System_Extend_Unit
)
6874 and then Present_System_Aux
(N
)
6876 Set_Entity
(Prefix
(N
), System_Aux_Id
);
6877 Find_Expanded_Name
(N
);
6880 -- There is an implicit instance of the predefined operator in
6881 -- the given scope. The operator entity is defined in Standard.
6882 -- Has_Implicit_Operator makes the node into an Expanded_Name.
6884 elsif Nkind
(Selector
) = N_Operator_Symbol
6885 and then Has_Implicit_Operator
(N
)
6889 -- If there is no literal defined in the scope denoted by the
6890 -- prefix, the literal may belong to (a type derived from)
6891 -- Standard_Character, for which we have no explicit literals.
6893 elsif Nkind
(Selector
) = N_Character_Literal
6894 and then Has_Implicit_Character_Literal
(N
)
6899 -- If the prefix is a single concurrent object, use its name in
6900 -- the error message, rather than that of the anonymous type.
6902 if Is_Concurrent_Type
(P_Name
)
6903 and then Is_Internal_Name
(Chars
(P_Name
))
6905 Error_Msg_Node_2
:= Entity
(Prefix
(N
));
6907 Error_Msg_Node_2
:= P_Name
;
6910 if P_Name
= System_Aux_Id
then
6911 P_Name
:= Scope
(P_Name
);
6912 Set_Entity
(Prefix
(N
), P_Name
);
6915 if Present
(Candidate
) then
6917 -- If we know that the unit is a child unit we can give a more
6918 -- accurate error message.
6920 if Is_Child_Unit
(Candidate
) then
6922 -- If the candidate is a private child unit and we are in
6923 -- the visible part of a public unit, specialize the error
6924 -- message. There might be a private with_clause for it,
6925 -- but it is not currently active.
6927 if Is_Private_Descendant
(Candidate
)
6928 and then Ekind
(Current_Scope
) = E_Package
6929 and then not In_Private_Part
(Current_Scope
)
6930 and then not Is_Private_Descendant
(Current_Scope
)
6933 ("private child unit& is not visible here", Selector
);
6935 -- Normal case where we have a missing with for a child unit
6938 Error_Msg_Qual_Level
:= 99;
6939 Error_Msg_NE
-- CODEFIX
6940 ("missing `WITH &;`", Selector
, Candidate
);
6941 Error_Msg_Qual_Level
:= 0;
6944 -- Here we don't know that this is a child unit
6947 Error_Msg_NE
("& is not a visible entity of&", N
, Selector
);
6951 -- Within the instantiation of a child unit, the prefix may
6952 -- denote the parent instance, but the selector has the name
6953 -- of the original child. That is to say, when A.B appears
6954 -- within an instantiation of generic child unit B, the scope
6955 -- stack includes an instance of A (P_Name) and an instance
6956 -- of B under some other name. We scan the scope to find this
6957 -- child instance, which is the desired entity.
6958 -- Note that the parent may itself be a child instance, if
6959 -- the reference is of the form A.B.C, in which case A.B has
6960 -- already been rewritten with the proper entity.
6962 if In_Open_Scopes
(P_Name
)
6963 and then Is_Generic_Instance
(P_Name
)
6966 Gen_Par
: constant Entity_Id
:=
6967 Generic_Parent
(Specification
6968 (Unit_Declaration_Node
(P_Name
)));
6969 S
: Entity_Id
:= Current_Scope
;
6973 for J
in reverse 0 .. Scope_Stack
.Last
loop
6974 S
:= Scope_Stack
.Table
(J
).Entity
;
6976 exit when S
= Standard_Standard
;
6978 if Ekind
(S
) in E_Function | E_Package | E_Procedure
6981 Generic_Parent
(Specification
6982 (Unit_Declaration_Node
(S
)));
6984 -- Check that P is a generic child of the generic
6985 -- parent of the prefix.
6988 and then Chars
(P
) = Chars
(Selector
)
6989 and then Scope
(P
) = Gen_Par
7000 -- If this is a selection from Ada, System or Interfaces, then
7001 -- we assume a missing with for the corresponding package.
7003 if Is_Known_Unit
(N
)
7004 and then not (Present
(Entity
(Prefix
(N
)))
7005 and then Scope
(Entity
(Prefix
(N
))) /=
7008 if not Error_Posted
(N
) then
7010 ("& is not a visible entity of&", Prefix
(N
), Selector
);
7011 Error_Missing_With_Of_Known_Unit
(Prefix
(N
));
7014 -- If this is a selection from a dummy package, then suppress
7015 -- the error message, of course the entity is missing if the
7016 -- package is missing.
7018 elsif Sloc
(Error_Msg_Node_2
) = No_Location
then
7021 -- Here we have the case of an undefined component
7024 -- The prefix may hide a homonym in the context that
7025 -- declares the desired entity. This error can use a
7026 -- specialized message.
7028 if In_Open_Scopes
(P_Name
) then
7030 H
: constant Entity_Id
:= Homonym
(P_Name
);
7034 and then Is_Compilation_Unit
(H
)
7036 (Is_Immediately_Visible
(H
)
7037 or else Is_Visible_Lib_Unit
(H
))
7039 Id
:= First_Entity
(H
);
7040 while Present
(Id
) loop
7041 if Chars
(Id
) = Chars
(Selector
) then
7042 Error_Msg_Qual_Level
:= 99;
7043 Error_Msg_Name_1
:= Chars
(Selector
);
7045 ("% not declared in&", N
, P_Name
);
7047 ("\use fully qualified name starting with "
7048 & "Standard to make& visible", N
, H
);
7049 Error_Msg_Qual_Level
:= 0;
7057 -- If not found, standard error message
7059 Error_Msg_NE
("& not declared in&", N
, Selector
);
7065 -- Might be worth specializing the case when the prefix
7066 -- is a limited view.
7067 -- ... not declared in limited view of...
7069 Error_Msg_NE
("& not declared in&", N
, Selector
);
7072 -- Check for misspelling of some entity in prefix
7074 Id
:= First_Entity
(P_Name
);
7075 while Present
(Id
) loop
7076 if Is_Bad_Spelling_Of
(Chars
(Id
), Chars
(Selector
))
7077 and then not Is_Internal_Name
(Chars
(Id
))
7079 Error_Msg_NE
-- CODEFIX
7080 ("possible misspelling of&", Selector
, Id
);
7087 -- Specialize the message if this may be an instantiation
7088 -- of a child unit that was not mentioned in the context.
7090 if Nkind
(Parent
(N
)) = N_Package_Instantiation
7091 and then Is_Generic_Instance
(Entity
(Prefix
(N
)))
7092 and then Is_Compilation_Unit
7093 (Generic_Parent
(Parent
(Entity
(Prefix
(N
)))))
7095 Error_Msg_Node_2
:= Selector
;
7096 Error_Msg_N
-- CODEFIX
7097 ("\missing `WITH &.&;`", Prefix
(N
));
7107 if Comes_From_Source
(N
)
7108 and then Is_Remote_Access_To_Subprogram_Type
(Id
)
7109 and then Ekind
(Id
) = E_Access_Subprogram_Type
7110 and then Present
(Equivalent_Type
(Id
))
7112 -- If we are not actually generating distribution code (i.e. the
7113 -- current PCS is the dummy non-distributed version), then the
7114 -- Equivalent_Type will be missing, and Id should be treated as
7115 -- a regular access-to-subprogram type.
7117 Id
:= Equivalent_Type
(Id
);
7118 Set_Chars
(Selector
, Chars
(Id
));
7121 -- Ada 2005 (AI-50217): Check usage of entities in limited withed units
7123 if Ekind
(P_Name
) = E_Package
and then From_Limited_With
(P_Name
) then
7124 if From_Limited_With
(Id
)
7125 or else Is_Type
(Id
)
7126 or else Ekind
(Id
) = E_Package
7131 ("limited withed package can only be used to access incomplete "
7136 if Is_Task_Type
(P_Name
)
7137 and then ((Ekind
(Id
) = E_Entry
7138 and then Nkind
(Parent
(N
)) /= N_Attribute_Reference
)
7140 (Ekind
(Id
) = E_Entry_Family
7142 Nkind
(Parent
(Parent
(N
))) /= N_Attribute_Reference
))
7144 -- If both the task type and the entry are in scope, this may still
7145 -- be the expanded name of an entry formal.
7147 if In_Open_Scopes
(Id
)
7148 and then Nkind
(Parent
(N
)) = N_Selected_Component
7153 -- It is an entry call after all, either to the current task
7154 -- (which will deadlock) or to an enclosing task.
7156 Analyze_Selected_Component
(N
);
7162 when N_Selected_Component
=>
7163 Reinit_Field_To_Zero
(N
, F_Is_Prefixed_Call
);
7164 Change_Selected_Component_To_Expanded_Name
(N
);
7166 when N_Expanded_Name
=>
7170 pragma Assert
(False);
7173 -- Preserve relevant elaboration-related attributes of the context which
7174 -- are no longer available or very expensive to recompute once analysis,
7175 -- resolution, and expansion are over.
7177 Mark_Elaboration_Attributes
7183 -- Set appropriate type
7185 if Is_Type
(Id
) then
7188 Set_Etype
(N
, Get_Full_View
(Etype
(Id
)));
7191 -- Do style check and generate reference, but skip both steps if this
7192 -- entity has homonyms, since we may not have the right homonym set yet.
7193 -- The proper homonym will be set during the resolve phase.
7195 if Has_Homonym
(Id
) then
7199 Set_Entity_Or_Discriminal
(N
, Id
);
7201 case Known_To_Be_Assigned
(N
, Only_LHS
=> True) is
7203 Generate_Reference
(Id
, N
, 'm');
7206 Generate_Reference
(Id
, N
, 'r');
7211 -- Check for violation of No_Wide_Characters
7213 Check_Wide_Character_Restriction
(Id
, N
);
7215 if Is_Self_Hidden
(Id
) then
7216 Premature_Usage
(N
);
7218 elsif Is_Overloadable
(Id
) and then Present
(Homonym
(Id
)) then
7220 H
: Entity_Id
:= Homonym
(Id
);
7223 while Present
(H
) loop
7224 if Scope
(H
) = Scope
(Id
)
7225 and then (not Is_Hidden
(H
)
7226 or else Is_Immediately_Visible
(H
))
7228 Collect_Interps
(N
);
7235 -- If an extension of System is present, collect possible explicit
7236 -- overloadings declared in the extension.
7238 if Chars
(P_Name
) = Name_System
7239 and then Scope
(P_Name
) = Standard_Standard
7240 and then Present
(System_Extend_Unit
)
7241 and then Present_System_Aux
(N
)
7243 H
:= Current_Entity
(Id
);
7245 while Present
(H
) loop
7246 if Scope
(H
) = System_Aux_Id
then
7247 Add_One_Interp
(N
, H
, Etype
(H
));
7256 if Nkind
(Selector_Name
(N
)) = N_Operator_Symbol
7257 and then Scope
(Id
) /= Standard_Standard
7259 -- In addition to user-defined operators in the given scope, there
7260 -- may be an implicit instance of the predefined operator. The
7261 -- operator (defined in Standard) is found in Has_Implicit_Operator,
7262 -- and added to the interpretations. Procedure Add_One_Interp will
7263 -- determine which hides which.
7265 if Has_Implicit_Operator
(N
) then
7270 -- If there is a single interpretation for N we can generate a
7271 -- reference to the unique entity found.
7273 if Is_Overloadable
(Id
) and then not Is_Overloaded
(N
) then
7274 Generate_Reference
(Id
, N
);
7277 -- Mark relevant use-type and use-package clauses as effective if the
7278 -- node in question is not overloaded and therefore does not require
7281 if Nkind
(N
) not in N_Subexpr
or else not Is_Overloaded
(N
) then
7282 Mark_Use_Clauses
(N
);
7285 Check_Restriction_No_Use_Of_Entity
(N
);
7287 -- Annotate the tree by creating a variable reference marker in case the
7288 -- original variable reference is folded or optimized away. The variable
7289 -- reference marker is automatically saved for later examination by the
7290 -- ABE Processing phase. Variable references which act as actuals in a
7291 -- call require special processing and are left to Resolve_Actuals. The
7292 -- reference is a write when it appears on the left hand side of an
7295 if Needs_Variable_Reference_Marker
7300 Is_Assignment_LHS
: constant Boolean := Known_To_Be_Assigned
(N
);
7303 Build_Variable_Reference_Marker
7305 Read
=> not Is_Assignment_LHS
,
7306 Write
=> Is_Assignment_LHS
);
7309 end Find_Expanded_Name
;
7311 --------------------
7312 -- Find_First_Use --
7313 --------------------
7315 function Find_First_Use
(Use_Clause
: Node_Id
) return Node_Id
is
7319 -- Loop through the Prev_Use_Clause chain
7322 while Present
(Prev_Use_Clause
(Curr
)) loop
7323 Curr
:= Prev_Use_Clause
(Curr
);
7329 -------------------------
7330 -- Find_Renamed_Entity --
7331 -------------------------
7333 function Find_Renamed_Entity
7337 Is_Actual
: Boolean := False) return Entity_Id
7340 I1
: Interp_Index
:= 0; -- Suppress junk warnings
7346 function Find_Nearer_Entity
7349 Old2_S
: Entity_Id
) return Entity_Id
;
7350 -- Determine whether one of Old_S1 and Old_S2 is nearer to New_S than
7351 -- the other, and return it if so. Return Empty otherwise. We use this
7352 -- in conjunction with Inherit_Renamed_Profile to simplify later type
7353 -- disambiguation for actual subprograms in instances.
7355 function Is_Visible_Operation
(Op
: Entity_Id
) return Boolean;
7356 -- If the renamed entity is an implicit operator, check whether it is
7357 -- visible because its operand type is properly visible. This check
7358 -- applies to explicit renamed entities that appear in the source in a
7359 -- renaming declaration or a formal subprogram instance, but not to
7360 -- default generic actuals with a name.
7362 function Report_Overload
return Entity_Id
;
7363 -- List possible interpretations, and specialize message in the
7364 -- case of a generic actual.
7366 function Within
(Inner
, Outer
: Entity_Id
) return Boolean;
7367 -- Determine whether a candidate subprogram is defined within the
7368 -- enclosing instance. If yes, it has precedence over outer candidates.
7370 --------------------------
7371 -- Find_Nearer_Entity --
7372 --------------------------
7374 function Find_Nearer_Entity
7377 Old2_S
: Entity_Id
) return Entity_Id
7385 New_F
:= First_Formal
(New_S
);
7386 Old1_F
:= First_Formal
(Old1_S
);
7387 Old2_F
:= First_Formal
(Old2_S
);
7389 -- The criterion is whether the type of the formals of one of Old1_S
7390 -- and Old2_S is an ancestor subtype of the type of the corresponding
7391 -- formals of New_S while the other is not (we already know that they
7392 -- are all subtypes of the same base type).
7394 -- This makes it possible to find the more correct renamed entity in
7395 -- the case of a generic instantiation nested in an enclosing one for
7396 -- which different formal types get the same actual type, which will
7397 -- in turn make it possible for Inherit_Renamed_Profile to preserve
7398 -- types on formal parameters and ultimately simplify disambiguation.
7400 -- Consider the follow package G:
7403 -- type Item_T is private;
7404 -- with function Compare (L, R: Item_T) return Boolean is <>;
7406 -- type Bound_T is private;
7407 -- with function Compare (L, R : Bound_T) return Boolean is <>;
7412 -- package body G is
7413 -- package My_Inner is Inner_G (Bound_T);
7417 -- with the following package Inner_G:
7420 -- type T is private;
7421 -- with function Compare (L, R: T) return Boolean is <>;
7422 -- package Inner_G is
7423 -- function "<" (L, R: T) return Boolean is (Compare (L, R));
7426 -- If G is instantiated on the same actual type with a single Compare
7430 -- function Compare (L, R : T) return Boolean;
7431 -- package My_G is new (T, T);
7433 -- then the renaming generated for Compare in the inner instantiation
7434 -- is ambiguous: it can rename either of the renamings generated for
7435 -- the outer instantiation. Now if the first one is picked up, then
7436 -- the subtypes of the formal parameters of the renaming will not be
7437 -- preserved in Inherit_Renamed_Profile because they are subtypes of
7438 -- the Bound_T formal type and not of the Item_T formal type, so we
7439 -- need to arrange for the second one to be picked up instead.
7441 while Present
(New_F
) loop
7442 if Etype
(Old1_F
) /= Etype
(Old2_F
) then
7443 Anc_T
:= Ancestor_Subtype
(Etype
(New_F
));
7445 if Etype
(Old1_F
) = Anc_T
then
7447 elsif Etype
(Old2_F
) = Anc_T
then
7452 Next_Formal
(New_F
);
7453 Next_Formal
(Old1_F
);
7454 Next_Formal
(Old2_F
);
7457 pragma Assert
(No
(Old1_F
));
7458 pragma Assert
(No
(Old2_F
));
7461 end Find_Nearer_Entity
;
7463 --------------------------
7464 -- Is_Visible_Operation --
7465 --------------------------
7467 function Is_Visible_Operation
(Op
: Entity_Id
) return Boolean is
7473 if Ekind
(Op
) /= E_Operator
7474 or else Scope
(Op
) /= Standard_Standard
7475 or else (In_Instance
7476 and then (not Is_Actual
7477 or else Present
(Enclosing_Instance
)))
7482 -- For a fixed point type operator, check the resulting type,
7483 -- because it may be a mixed mode integer * fixed operation.
7485 if Present
(Next_Formal
(First_Formal
(New_S
)))
7486 and then Is_Fixed_Point_Type
(Etype
(New_S
))
7488 Typ
:= Etype
(New_S
);
7490 Typ
:= Etype
(First_Formal
(New_S
));
7493 Btyp
:= Base_Type
(Typ
);
7495 if Nkind
(Nam
) /= N_Expanded_Name
then
7496 return (In_Open_Scopes
(Scope
(Btyp
))
7497 or else Is_Potentially_Use_Visible
(Btyp
)
7498 or else In_Use
(Btyp
)
7499 or else In_Use
(Scope
(Btyp
)));
7502 Scop
:= Entity
(Prefix
(Nam
));
7504 if Ekind
(Scop
) = E_Package
7505 and then Present
(Renamed_Entity
(Scop
))
7507 Scop
:= Renamed_Entity
(Scop
);
7510 -- Operator is visible if prefix of expanded name denotes
7511 -- scope of type, or else type is defined in System_Aux
7512 -- and the prefix denotes System.
7514 return Scope
(Btyp
) = Scop
7515 or else (Scope
(Btyp
) = System_Aux_Id
7516 and then Scope
(Scope
(Btyp
)) = Scop
);
7519 end Is_Visible_Operation
;
7525 function Within
(Inner
, Outer
: Entity_Id
) return Boolean is
7529 Sc
:= Scope
(Inner
);
7530 while Sc
/= Standard_Standard
loop
7541 ---------------------
7542 -- Report_Overload --
7543 ---------------------
7545 function Report_Overload
return Entity_Id
is
7548 Error_Msg_NE
-- CODEFIX
7549 ("ambiguous actual subprogram&, " &
7550 "possible interpretations:", N
, Nam
);
7552 Error_Msg_N
-- CODEFIX
7553 ("ambiguous subprogram, " &
7554 "possible interpretations:", N
);
7557 List_Interps
(Nam
, N
);
7559 end Report_Overload
;
7561 -- Start of processing for Find_Renamed_Entity
7565 Candidate_Renaming
:= Empty
;
7567 if Is_Overloaded
(Nam
) then
7568 Get_First_Interp
(Nam
, Ind
, It
);
7569 while Present
(It
.Nam
) loop
7570 if Entity_Matches_Spec
(It
.Nam
, New_S
)
7571 and then Is_Visible_Operation
(It
.Nam
)
7573 if Old_S
/= Any_Id
then
7575 -- Note: The call to Disambiguate only happens if a
7576 -- previous interpretation was found, in which case I1
7577 -- has received a value.
7579 It1
:= Disambiguate
(Nam
, I1
, Ind
, Etype
(Old_S
));
7581 if It1
= No_Interp
then
7582 Inst
:= Enclosing_Instance
;
7584 if Present
(Inst
) then
7585 if Within
(It
.Nam
, Inst
) then
7586 if Within
(Old_S
, Inst
) then
7588 It_D
: constant Uint
:=
7589 Scope_Depth_Default_0
(It
.Nam
);
7590 Old_D
: constant Uint
:=
7591 Scope_Depth_Default_0
(Old_S
);
7594 -- Choose the innermost subprogram, which
7595 -- would hide the outer one in the generic.
7597 if Old_D
> It_D
then
7599 elsif It_D
> Old_D
then
7603 -- Otherwise, if we can determine that one
7604 -- of the entities is nearer to the renaming
7605 -- than the other, choose it. If not, then
7606 -- return the newer one as done historically.
7609 Find_Nearer_Entity
(New_S
, Old_S
, It
.Nam
);
7610 if Present
(N_Ent
) then
7618 elsif Within
(Old_S
, Inst
) then
7622 return Report_Overload
;
7625 -- If not within an instance, ambiguity is real
7628 return Report_Overload
;
7642 Present
(First_Formal
(It
.Nam
))
7643 and then Present
(First_Formal
(New_S
))
7644 and then Base_Type
(Etype
(First_Formal
(It
.Nam
))) =
7645 Base_Type
(Etype
(First_Formal
(New_S
)))
7647 Candidate_Renaming
:= It
.Nam
;
7650 Get_Next_Interp
(Ind
, It
);
7653 Set_Entity
(Nam
, Old_S
);
7655 if Old_S
/= Any_Id
then
7656 Set_Is_Overloaded
(Nam
, False);
7659 -- Non-overloaded case
7663 and then Present
(Enclosing_Instance
)
7664 and then Entity_Matches_Spec
(Entity
(Nam
), New_S
)
7666 Old_S
:= Entity
(Nam
);
7668 elsif Entity_Matches_Spec
(Entity
(Nam
), New_S
) then
7669 Candidate_Renaming
:= New_S
;
7671 if Is_Visible_Operation
(Entity
(Nam
)) then
7672 Old_S
:= Entity
(Nam
);
7675 elsif Present
(First_Formal
(Entity
(Nam
)))
7676 and then Present
(First_Formal
(New_S
))
7677 and then Base_Type
(Etype
(First_Formal
(Entity
(Nam
)))) =
7678 Base_Type
(Etype
(First_Formal
(New_S
)))
7680 Candidate_Renaming
:= Entity
(Nam
);
7685 end Find_Renamed_Entity
;
7687 -----------------------------
7688 -- Find_Selected_Component --
7689 -----------------------------
7691 procedure Find_Selected_Component
(N
: Node_Id
) is
7692 P
: constant Node_Id
:= Prefix
(N
);
7695 -- Entity denoted by prefix
7702 function Available_Subtype
return Boolean;
7703 -- A small optimization: if the prefix is constrained and the component
7704 -- is an array type we may already have a usable subtype for it, so we
7705 -- can use it rather than generating a new one, because the bounds
7706 -- will be the values of the discriminants and not discriminant refs.
7707 -- This simplifies value tracing in GNATprove. For consistency, both
7708 -- the entity name and the subtype come from the constrained component.
7710 -- This is only used in GNATprove mode: when generating code it may be
7711 -- necessary to create an itype in the scope of use of the selected
7712 -- component, e.g. in the context of a expanded record equality.
7714 function Is_Reference_In_Subunit
return Boolean;
7715 -- In a subunit, the scope depth is not a proper measure of hiding,
7716 -- because the context of the proper body may itself hide entities in
7717 -- parent units. This rare case requires inspecting the tree directly
7718 -- because the proper body is inserted in the main unit and its context
7719 -- is simply added to that of the parent.
7721 -----------------------
7722 -- Available_Subtype --
7723 -----------------------
7725 function Available_Subtype
return Boolean is
7729 if GNATprove_Mode
then
7730 Comp
:= First_Entity
(Etype
(P
));
7731 while Present
(Comp
) loop
7732 if Chars
(Comp
) = Chars
(Selector_Name
(N
)) then
7733 Set_Etype
(N
, Etype
(Comp
));
7734 Set_Entity
(Selector_Name
(N
), Comp
);
7735 Set_Etype
(Selector_Name
(N
), Etype
(Comp
));
7739 Next_Component
(Comp
);
7744 end Available_Subtype
;
7746 -----------------------------
7747 -- Is_Reference_In_Subunit --
7748 -----------------------------
7750 function Is_Reference_In_Subunit
return Boolean is
7752 Comp_Unit
: Node_Id
;
7756 while Present
(Comp_Unit
)
7757 and then Nkind
(Comp_Unit
) /= N_Compilation_Unit
7759 Comp_Unit
:= Parent
(Comp_Unit
);
7762 if No
(Comp_Unit
) or else Nkind
(Unit
(Comp_Unit
)) /= N_Subunit
then
7766 -- Now check whether the package is in the context of the subunit
7768 Clause
:= First
(Context_Items
(Comp_Unit
));
7769 while Present
(Clause
) loop
7770 if Nkind
(Clause
) = N_With_Clause
7771 and then Entity
(Name
(Clause
)) = P_Name
7780 end Is_Reference_In_Subunit
;
7782 -- Start of processing for Find_Selected_Component
7787 if Nkind
(P
) = N_Error
then
7791 -- If the selector already has an entity, the node has been constructed
7792 -- in the course of expansion, and is known to be valid. Do not verify
7793 -- that it is defined for the type (it may be a private component used
7794 -- in the expansion of record equality).
7796 if Present
(Entity
(Selector_Name
(N
))) then
7797 if No
(Etype
(N
)) or else Etype
(N
) = Any_Type
then
7799 Sel_Name
: constant Node_Id
:= Selector_Name
(N
);
7800 Selector
: constant Entity_Id
:= Entity
(Sel_Name
);
7804 Set_Etype
(Sel_Name
, Etype
(Selector
));
7806 if not Is_Entity_Name
(P
) then
7810 -- Build an actual subtype except for the first parameter
7811 -- of an init proc, where this actual subtype is by
7812 -- definition incorrect, since the object is uninitialized
7813 -- (and does not even have defined discriminants etc.)
7815 if Is_Entity_Name
(P
)
7816 and then Ekind
(Entity
(P
)) = E_Function
7818 Nam
:= New_Copy
(P
);
7820 if Is_Overloaded
(P
) then
7821 Save_Interps
(P
, Nam
);
7824 Rewrite
(P
, Make_Function_Call
(Sloc
(P
), Name
=> Nam
));
7826 Analyze_Selected_Component
(N
);
7829 elsif Ekind
(Selector
) = E_Component
7830 and then (not Is_Entity_Name
(P
)
7831 or else Chars
(Entity
(P
)) /= Name_uInit
)
7833 -- Check if we already have an available subtype we can use
7835 if Ekind
(Etype
(P
)) = E_Record_Subtype
7836 and then Nkind
(Parent
(Etype
(P
))) = N_Subtype_Declaration
7837 and then Is_Array_Type
(Etype
(Selector
))
7838 and then not Is_Packed
(Etype
(Selector
))
7839 and then Available_Subtype
7843 -- Do not build the subtype when referencing components of
7844 -- dispatch table wrappers. Required to avoid generating
7845 -- elaboration code with HI runtimes.
7847 elsif Is_RTE
(Scope
(Selector
), RE_Dispatch_Table_Wrapper
)
7849 Is_RTE
(Scope
(Selector
), RE_No_Dispatch_Table_Wrapper
)
7854 Build_Actual_Subtype_Of_Component
7855 (Etype
(Selector
), N
);
7862 if No
(C_Etype
) then
7863 C_Etype
:= Etype
(Selector
);
7865 Insert_Action
(N
, C_Etype
);
7866 C_Etype
:= Defining_Identifier
(C_Etype
);
7869 Set_Etype
(N
, C_Etype
);
7872 -- If the selected component appears within a default expression
7873 -- and it has an actual subtype, the preanalysis has not yet
7874 -- completed its analysis, because Insert_Actions is disabled in
7875 -- that context. Within the init proc of the enclosing type we
7876 -- must complete this analysis, if an actual subtype was created.
7878 elsif Inside_Init_Proc
then
7880 Typ
: constant Entity_Id
:= Etype
(N
);
7881 Decl
: constant Node_Id
:= Declaration_Node
(Typ
);
7883 if Nkind
(Decl
) = N_Subtype_Declaration
7884 and then not Analyzed
(Decl
)
7885 and then Is_List_Member
(Decl
)
7886 and then No
(Parent
(Decl
))
7889 Insert_Action
(N
, Decl
);
7896 elsif Is_Entity_Name
(P
) then
7897 P_Name
:= Entity
(P
);
7899 -- The prefix may denote an enclosing type which is the completion
7900 -- of an incomplete type declaration.
7902 if Is_Type
(P_Name
) then
7903 Set_Entity
(P
, Get_Full_View
(P_Name
));
7904 Set_Etype
(P
, Entity
(P
));
7905 P_Name
:= Entity
(P
);
7908 P_Type
:= Base_Type
(Etype
(P
));
7910 if Debug_Flag_E
then
7911 Write_Str
("Found prefix type to be ");
7912 Write_Entity_Info
(P_Type
, " "); Write_Eol
;
7915 -- If the prefix's type is an access type, get to the record type
7917 if Is_Access_Type
(P_Type
) then
7918 P_Type
:= Implicitly_Designated_Type
(P_Type
);
7921 -- First check for components of a record object (not the result of
7922 -- a call, which is handled below). This also covers the case where
7923 -- the extension feature that supports the prefixed form of calls
7924 -- for primitives of untagged types is enabled (excluding concurrent
7925 -- cases, which are handled further below).
7928 and then (Has_Components
(P_Type
)
7929 or else (Core_Extensions_Allowed
7930 and then not Is_Concurrent_Type
(P_Type
)))
7931 and then not Is_Overloadable
(P_Name
)
7932 and then not Is_Type
(P_Name
)
7934 -- Selected component of record. Type checking will validate
7935 -- name of selector.
7937 -- ??? Could we rewrite an implicit dereference into an explicit
7940 Analyze_Selected_Component
(N
);
7942 -- Reference to type name in predicate/invariant expression
7944 elsif Is_Concurrent_Type
(P_Type
)
7945 and then not In_Open_Scopes
(P_Name
)
7946 and then (not Is_Concurrent_Type
(Etype
(P_Name
))
7947 or else not In_Open_Scopes
(Etype
(P_Name
)))
7949 -- Call to protected operation or entry. Type checking is
7950 -- needed on the prefix.
7952 Analyze_Selected_Component
(N
);
7954 elsif (In_Open_Scopes
(P_Name
)
7955 and then Ekind
(P_Name
) /= E_Void
7956 and then not Is_Overloadable
(P_Name
))
7957 or else (Is_Concurrent_Type
(Etype
(P_Name
))
7958 and then In_Open_Scopes
(Etype
(P_Name
)))
7960 -- Prefix denotes an enclosing loop, block, or task, i.e. an
7961 -- enclosing construct that is not a subprogram or accept.
7963 -- A special case: a protected body may call an operation
7964 -- on an external object of the same type, in which case it
7965 -- is not an expanded name. If the prefix is the type itself,
7966 -- or the context is a single synchronized object it can only
7967 -- be interpreted as an expanded name.
7969 if Is_Concurrent_Type
(Etype
(P_Name
)) then
7971 or else Present
(Anonymous_Object
(Etype
(P_Name
)))
7973 Find_Expanded_Name
(N
);
7976 Analyze_Selected_Component
(N
);
7981 Find_Expanded_Name
(N
);
7984 elsif Ekind
(P_Name
) = E_Package
then
7985 Find_Expanded_Name
(N
);
7987 elsif Is_Overloadable
(P_Name
) then
7989 -- The subprogram may be a renaming (of an enclosing scope) as
7990 -- in the case of the name of the generic within an instantiation.
7992 if Ekind
(P_Name
) in E_Procedure | E_Function
7993 and then Present
(Alias
(P_Name
))
7994 and then Is_Generic_Instance
(Alias
(P_Name
))
7996 P_Name
:= Alias
(P_Name
);
7999 if Is_Overloaded
(P
) then
8001 -- The prefix must resolve to a unique enclosing construct
8004 Found
: Boolean := False;
8009 Get_First_Interp
(P
, Ind
, It
);
8010 while Present
(It
.Nam
) loop
8011 if In_Open_Scopes
(It
.Nam
) then
8014 "prefix must be unique enclosing scope", N
);
8015 Set_Entity
(N
, Any_Id
);
8016 Set_Etype
(N
, Any_Type
);
8025 Get_Next_Interp
(Ind
, It
);
8030 if In_Open_Scopes
(P_Name
) then
8031 Set_Entity
(P
, P_Name
);
8032 Set_Is_Overloaded
(P
, False);
8033 Find_Expanded_Name
(N
);
8036 -- If no interpretation as an expanded name is possible, it
8037 -- must be a selected component of a record returned by a
8038 -- function call. Reformat prefix as a function call, the rest
8039 -- is done by type resolution.
8041 -- Error if the prefix is procedure or entry, as is P.X
8043 if Ekind
(P_Name
) /= E_Function
8045 (not Is_Overloaded
(P
)
8046 or else Nkind
(Parent
(N
)) = N_Procedure_Call_Statement
)
8048 -- Prefix may mention a package that is hidden by a local
8049 -- declaration: let the user know. Scan the full homonym
8050 -- chain, the candidate package may be anywhere on it.
8052 if Present
(Homonym
(Current_Entity
(P_Name
))) then
8053 P_Name
:= Current_Entity
(P_Name
);
8055 while Present
(P_Name
) loop
8056 exit when Ekind
(P_Name
) = E_Package
;
8057 P_Name
:= Homonym
(P_Name
);
8060 if Present
(P_Name
) then
8061 if not Is_Reference_In_Subunit
then
8062 Error_Msg_Sloc
:= Sloc
(Entity
(Prefix
(N
)));
8064 ("package& is hidden by declaration#", N
, P_Name
);
8067 Set_Entity
(Prefix
(N
), P_Name
);
8068 Find_Expanded_Name
(N
);
8072 P_Name
:= Entity
(Prefix
(N
));
8077 ("invalid prefix in selected component&", N
, P_Name
);
8078 Change_Selected_Component_To_Expanded_Name
(N
);
8079 Set_Entity
(N
, Any_Id
);
8080 Set_Etype
(N
, Any_Type
);
8082 -- Here we have a function call, so do the reformatting
8085 Nam
:= New_Copy
(P
);
8086 Save_Interps
(P
, Nam
);
8088 -- We use Replace here because this is one of those cases
8089 -- where the parser has missclassified the node, and we fix
8090 -- things up and then do the semantic analysis on the fixed
8091 -- up node. Normally we do this using one of the Sinfo.CN
8092 -- routines, but this is too tricky for that.
8094 -- Note that using Rewrite would be wrong, because we would
8095 -- have a tree where the original node is unanalyzed.
8098 Make_Function_Call
(Sloc
(P
), Name
=> Nam
));
8100 -- Now analyze the reformatted node
8104 -- If the prefix is illegal after this transformation, there
8105 -- may be visibility errors on the prefix. The safest is to
8106 -- treat the selected component as an error.
8108 if Error_Posted
(P
) then
8109 Set_Etype
(N
, Any_Type
);
8113 Analyze_Selected_Component
(N
);
8118 -- Remaining cases generate various error messages
8121 -- Format node as expanded name, to avoid cascaded errors
8123 Change_Selected_Component_To_Expanded_Name
(N
);
8124 Set_Entity
(N
, Any_Id
);
8125 Set_Etype
(N
, Any_Type
);
8127 -- Issue error message, but avoid this if error issued already.
8128 -- Use identifier of prefix if one is available.
8130 if P_Name
= Any_Id
then
8133 -- It is not an error if the prefix is the current instance of
8134 -- type name, e.g. the expression of a type aspect, when it is
8135 -- analyzed within a generic unit. We still have to verify that a
8136 -- component of that name exists, and decorate the node
8139 elsif Is_Entity_Name
(P
) and then Is_Current_Instance
(P
) then
8144 Comp
:= First_Entity
(Entity
(P
));
8145 while Present
(Comp
) loop
8146 if Chars
(Comp
) = Chars
(Selector_Name
(N
)) then
8147 Set_Entity
(N
, Comp
);
8148 Set_Etype
(N
, Etype
(Comp
));
8149 Set_Entity
(Selector_Name
(N
), Comp
);
8150 Set_Etype
(Selector_Name
(N
), Etype
(Comp
));
8158 elsif Is_Self_Hidden
(P_Name
) then
8159 Premature_Usage
(P
);
8161 elsif Ekind
(P_Name
) = E_Generic_Package
then
8162 Error_Msg_N
("prefix must not be a generic package", N
);
8163 Error_Msg_N
("\use package instantiation as prefix instead", N
);
8165 elsif Nkind
(P
) /= N_Attribute_Reference
then
8167 -- This may have been meant as a prefixed call to a primitive
8168 -- of an untagged type. If it is a function call check type of
8169 -- its first formal and add explanation.
8172 F
: constant Entity_Id
:=
8173 Current_Entity
(Selector_Name
(N
));
8176 and then Is_Overloadable
(F
)
8177 and then Present
(First_Entity
(F
))
8178 and then not Is_Tagged_Type
(Etype
(First_Entity
(F
)))
8181 ("prefixed call is only allowed for objects of a "
8182 & "tagged type unless -gnatX is used", N
);
8184 if not Core_Extensions_Allowed
8186 Try_Object_Operation
(N
, Allow_Extensions
=> True)
8189 ("\using -gnatX would make the prefixed call legal",
8195 Error_Msg_N
("invalid prefix in selected component&", P
);
8197 if Is_Incomplete_Type
(P_Type
)
8198 and then Is_Access_Type
(Etype
(P
))
8201 ("\dereference must not be of an incomplete type "
8202 & "(RM 3.10.1)", P
);
8206 Error_Msg_N
("invalid prefix in selected component", P
);
8210 -- If prefix is not the name of an entity, it must be an expression,
8211 -- whose type is appropriate for a record. This is determined by
8214 Analyze_Selected_Component
(N
);
8217 Analyze_Dimension
(N
);
8218 end Find_Selected_Component
;
8224 procedure Find_Type
(N
: Node_Id
) is
8234 elsif Nkind
(N
) = N_Attribute_Reference
then
8236 -- Class attribute. This is not valid in Ada 83 mode, but we do not
8237 -- need to enforce that at this point, since the declaration of the
8238 -- tagged type in the prefix would have been flagged already.
8240 if Attribute_Name
(N
) = Name_Class
then
8241 Check_Restriction
(No_Dispatch
, N
);
8242 Find_Type
(Prefix
(N
));
8244 -- Propagate error from bad prefix
8246 if Etype
(Prefix
(N
)) = Any_Type
then
8247 Set_Entity
(N
, Any_Type
);
8248 Set_Etype
(N
, Any_Type
);
8252 T
:= Base_Type
(Entity
(Prefix
(N
)));
8254 -- Case where type is not known to be tagged. Its appearance in
8255 -- the prefix of the 'Class attribute indicates that the full view
8258 if not Is_Tagged_Type
(T
) then
8259 if Ekind
(T
) = E_Incomplete_Type
then
8261 -- It is legal to denote the class type of an incomplete
8262 -- type. The full type will have to be tagged, of course.
8263 -- In Ada 2005 this usage is declared obsolescent, so we
8264 -- warn accordingly. This usage is only legal if the type
8265 -- is completed in the current scope, and not for a limited
8268 if Ada_Version
>= Ada_2005
then
8270 -- Test whether the Available_View of a limited type view
8271 -- is tagged, since the limited view may not be marked as
8272 -- tagged if the type itself has an untagged incomplete
8273 -- type view in its package.
8275 if From_Limited_With
(T
)
8276 and then not Is_Tagged_Type
(Available_View
(T
))
8279 ("prefix of Class attribute must be tagged", N
);
8280 Set_Etype
(N
, Any_Type
);
8281 Set_Entity
(N
, Any_Type
);
8285 if Restriction_Check_Required
(No_Obsolescent_Features
)
8288 (No_Obsolescent_Features
, Prefix
(N
));
8291 if Warn_On_Obsolescent_Feature
then
8293 ("applying ''Class to an untagged incomplete type"
8294 & " is an obsolescent feature (RM J.11)?r?", N
);
8299 Set_Is_Tagged_Type
(T
);
8300 Set_Direct_Primitive_Operations
(T
, New_Elmt_List
);
8301 Make_Class_Wide_Type
(T
);
8302 Set_Entity
(N
, Class_Wide_Type
(T
));
8303 Set_Etype
(N
, Class_Wide_Type
(T
));
8305 elsif Ekind
(T
) = E_Private_Type
8306 and then not Is_Generic_Type
(T
)
8307 and then In_Private_Part
(Scope
(T
))
8309 -- The Class attribute can be applied to an untagged private
8310 -- type fulfilled by a tagged type prior to the full type
8311 -- declaration (but only within the parent package's private
8312 -- part). Create the class-wide type now and check that the
8313 -- full type is tagged later during its analysis. Note that
8314 -- we do not mark the private type as tagged, unlike the
8315 -- case of incomplete types, because the type must still
8316 -- appear untagged to outside units.
8318 if No
(Class_Wide_Type
(T
)) then
8319 Make_Class_Wide_Type
(T
);
8322 Set_Entity
(N
, Class_Wide_Type
(T
));
8323 Set_Etype
(N
, Class_Wide_Type
(T
));
8326 -- Should we introduce a type Any_Tagged and use Wrong_Type
8327 -- here, it would be a bit more consistent???
8330 ("tagged type required, found}",
8331 Prefix
(N
), First_Subtype
(T
));
8332 Set_Entity
(N
, Any_Type
);
8336 -- Case of tagged type
8339 if Is_Concurrent_Type
(T
) then
8340 if No
(Corresponding_Record_Type
(Entity
(Prefix
(N
)))) then
8342 -- Previous error. Create a class-wide type for the
8343 -- synchronized type itself, with minimal semantic
8344 -- attributes, to catch other errors in some ACATS tests.
8346 pragma Assert
(Serious_Errors_Detected
/= 0);
8347 Make_Class_Wide_Type
(T
);
8348 C
:= Class_Wide_Type
(T
);
8349 Set_First_Entity
(C
, First_Entity
(T
));
8352 C
:= Class_Wide_Type
8353 (Corresponding_Record_Type
(Entity
(Prefix
(N
))));
8357 C
:= Class_Wide_Type
(Entity
(Prefix
(N
)));
8360 Set_Entity_With_Checks
(N
, C
);
8361 Generate_Reference
(C
, N
);
8365 -- Base attribute, not allowed in Ada 83
8367 elsif Attribute_Name
(N
) = Name_Base
then
8368 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
8370 ("(Ada 83) Base attribute not allowed in subtype mark", N
);
8373 Find_Type
(Prefix
(N
));
8374 Typ
:= Entity
(Prefix
(N
));
8376 if Ada_Version
>= Ada_95
8377 and then not Is_Scalar_Type
(Typ
)
8378 and then not Is_Generic_Type
(Typ
)
8381 ("prefix of Base attribute must be scalar type",
8384 elsif Warn_On_Redundant_Constructs
8385 and then Base_Type
(Typ
) = Typ
8387 Error_Msg_NE
-- CODEFIX
8388 ("redundant attribute, & is its own base type?r?", N
, Typ
);
8391 T
:= Base_Type
(Typ
);
8393 -- Rewrite attribute reference with type itself (see similar
8394 -- processing in Analyze_Attribute, case Base). Preserve prefix
8395 -- if present, for other legality checks.
8397 if Nkind
(Prefix
(N
)) = N_Expanded_Name
then
8399 Make_Expanded_Name
(Sloc
(N
),
8401 Prefix
=> New_Copy
(Prefix
(Prefix
(N
))),
8402 Selector_Name
=> New_Occurrence_Of
(T
, Sloc
(N
))));
8405 Rewrite
(N
, New_Occurrence_Of
(T
, Sloc
(N
)));
8412 elsif Attribute_Name
(N
) = Name_Stub_Type
then
8414 -- This is handled in Analyze_Attribute
8418 -- All other attributes are invalid in a subtype mark
8421 Error_Msg_N
("invalid attribute in subtype mark", N
);
8427 if Is_Entity_Name
(N
) then
8428 T_Name
:= Entity
(N
);
8430 Error_Msg_N
("subtype mark required in this context", N
);
8431 Set_Etype
(N
, Any_Type
);
8435 if T_Name
= Any_Id
or else Etype
(N
) = Any_Type
then
8437 -- Undefined id. Make it into a valid type
8439 Set_Entity
(N
, Any_Type
);
8441 elsif not Is_Type
(T_Name
)
8442 and then T_Name
/= Standard_Void_Type
8444 Error_Msg_Sloc
:= Sloc
(T_Name
);
8445 Error_Msg_N
("subtype mark required in this context", N
);
8446 Error_Msg_NE
("\\found & declared#", N
, T_Name
);
8447 Set_Entity
(N
, Any_Type
);
8450 -- If the type is an incomplete type created to handle
8451 -- anonymous access components of a record type, then the
8452 -- incomplete type is the visible entity and subsequent
8453 -- references will point to it. Mark the original full
8454 -- type as referenced, to prevent spurious warnings.
8456 if Is_Incomplete_Type
(T_Name
)
8457 and then Present
(Full_View
(T_Name
))
8458 and then not Comes_From_Source
(T_Name
)
8460 Set_Referenced
(Full_View
(T_Name
));
8463 T_Name
:= Get_Full_View
(T_Name
);
8465 -- Ada 2005 (AI-251, AI-50217): Handle interfaces visible through
8466 -- limited-with clauses
8468 if From_Limited_With
(T_Name
)
8469 and then Is_Incomplete_Type
(T_Name
)
8470 and then Present
(Non_Limited_View
(T_Name
))
8471 and then Is_Interface
(Non_Limited_View
(T_Name
))
8473 T_Name
:= Non_Limited_View
(T_Name
);
8476 if In_Open_Scopes
(T_Name
) then
8477 if Ekind
(Base_Type
(T_Name
)) = E_Task_Type
then
8479 -- In Ada 2005, a task name can be used in an access
8480 -- definition within its own body.
8482 if Ada_Version
>= Ada_2005
8483 and then Nkind
(Parent
(N
)) = N_Access_Definition
8485 Set_Entity
(N
, T_Name
);
8486 Set_Etype
(N
, T_Name
);
8491 ("task type cannot be used as type mark " &
8492 "within its own spec or body", N
);
8495 elsif Ekind
(Base_Type
(T_Name
)) = E_Protected_Type
then
8497 -- In Ada 2005, a protected name can be used in an access
8498 -- definition within its own body.
8500 if Ada_Version
>= Ada_2005
8501 and then Nkind
(Parent
(N
)) = N_Access_Definition
8503 Set_Entity
(N
, T_Name
);
8504 Set_Etype
(N
, T_Name
);
8509 ("protected type cannot be used as type mark " &
8510 "within its own spec or body", N
);
8514 Error_Msg_N
("type declaration cannot refer to itself", N
);
8517 Set_Etype
(N
, Any_Type
);
8518 Set_Entity
(N
, Any_Type
);
8519 Set_Error_Posted
(T_Name
);
8523 Set_Entity
(N
, T_Name
);
8524 Set_Etype
(N
, T_Name
);
8528 if Present
(Etype
(N
)) and then Comes_From_Source
(N
) then
8529 if Is_Fixed_Point_Type
(Etype
(N
)) then
8530 Check_Restriction
(No_Fixed_Point
, N
);
8531 elsif Is_Floating_Point_Type
(Etype
(N
)) then
8532 Check_Restriction
(No_Floating_Point
, N
);
8535 -- A Ghost type must appear in a specific context
8537 if Is_Ghost_Entity
(Etype
(N
)) then
8538 Check_Ghost_Context
(Etype
(N
), N
);
8543 --------------------
8544 -- Has_Components --
8545 --------------------
8547 function Has_Components
(Typ
: Entity_Id
) return Boolean is
8549 return Is_Record_Type
(Typ
)
8550 or else (Is_Private_Type
(Typ
) and then Has_Discriminants
(Typ
))
8551 or else (Is_Task_Type
(Typ
) and then Has_Discriminants
(Typ
))
8552 or else (Is_Incomplete_Type
(Typ
)
8553 and then From_Limited_With
(Typ
)
8554 and then Is_Record_Type
(Available_View
(Typ
)));
8557 ------------------------------------
8558 -- Has_Implicit_Character_Literal --
8559 ------------------------------------
8561 function Has_Implicit_Character_Literal
(N
: Node_Id
) return Boolean is
8563 Found
: Boolean := False;
8564 P
: constant Entity_Id
:= Entity
(Prefix
(N
));
8565 Priv_Id
: Entity_Id
:= Empty
;
8568 if Ekind
(P
) = E_Package
and then not In_Open_Scopes
(P
) then
8569 Priv_Id
:= First_Private_Entity
(P
);
8572 if P
= Standard_Standard
then
8573 Change_Selected_Component_To_Expanded_Name
(N
);
8574 Rewrite
(N
, Selector_Name
(N
));
8576 Set_Etype
(Original_Node
(N
), Standard_Character
);
8580 Id
:= First_Entity
(P
);
8581 while Present
(Id
) and then Id
/= Priv_Id
loop
8582 if Is_Standard_Character_Type
(Id
) and then Is_Base_Type
(Id
) then
8584 -- We replace the node with the literal itself, resolve as a
8585 -- character, and set the type correctly.
8588 Change_Selected_Component_To_Expanded_Name
(N
);
8589 Rewrite
(N
, Selector_Name
(N
));
8592 Set_Etype
(Original_Node
(N
), Id
);
8596 -- More than one type derived from Character in given scope.
8597 -- Collect all possible interpretations.
8599 Add_One_Interp
(N
, Id
, Id
);
8607 end Has_Implicit_Character_Literal
;
8609 ----------------------
8610 -- Has_Private_With --
8611 ----------------------
8613 function Has_Private_With
(E
: Entity_Id
) return Boolean is
8614 Comp_Unit
: constant Node_Id
:= Cunit
(Current_Sem_Unit
);
8618 Item
:= First
(Context_Items
(Comp_Unit
));
8619 while Present
(Item
) loop
8620 if Nkind
(Item
) = N_With_Clause
8621 and then Private_Present
(Item
)
8622 and then Entity
(Name
(Item
)) = E
8631 end Has_Private_With
;
8633 ---------------------------
8634 -- Has_Implicit_Operator --
8635 ---------------------------
8637 function Has_Implicit_Operator
(N
: Node_Id
) return Boolean is
8638 Op_Id
: constant Name_Id
:= Chars
(Selector_Name
(N
));
8639 P
: constant Entity_Id
:= Entity
(Prefix
(N
));
8641 Priv_Id
: Entity_Id
:= Empty
;
8643 procedure Add_Implicit_Operator
8645 Op_Type
: Entity_Id
:= Empty
);
8646 -- Add implicit interpretation to node N, using the type for which a
8647 -- predefined operator exists. If the operator yields a boolean type,
8648 -- the Operand_Type is implicitly referenced by the operator, and a
8649 -- reference to it must be generated.
8651 ---------------------------
8652 -- Add_Implicit_Operator --
8653 ---------------------------
8655 procedure Add_Implicit_Operator
8657 Op_Type
: Entity_Id
:= Empty
)
8659 Predef_Op
: Entity_Id
;
8662 Predef_Op
:= Current_Entity
(Selector_Name
(N
));
8663 while Present
(Predef_Op
)
8664 and then Scope
(Predef_Op
) /= Standard_Standard
8666 Predef_Op
:= Homonym
(Predef_Op
);
8669 if Nkind
(N
) = N_Selected_Component
then
8670 Change_Selected_Component_To_Expanded_Name
(N
);
8673 -- If the context is an unanalyzed function call, determine whether
8674 -- a binary or unary interpretation is required.
8676 if Nkind
(Parent
(N
)) = N_Indexed_Component
then
8678 Is_Binary_Call
: constant Boolean :=
8680 (Next
(First
(Expressions
(Parent
(N
)))));
8681 Is_Binary_Op
: constant Boolean :=
8683 (Predef_Op
) /= Last_Entity
(Predef_Op
);
8684 Predef_Op2
: constant Entity_Id
:= Homonym
(Predef_Op
);
8687 if Is_Binary_Call
then
8688 if Is_Binary_Op
then
8689 Add_One_Interp
(N
, Predef_Op
, T
);
8691 Add_One_Interp
(N
, Predef_Op2
, T
);
8694 if not Is_Binary_Op
then
8695 Add_One_Interp
(N
, Predef_Op
, T
);
8697 -- Predef_Op2 may be empty in case of previous errors
8699 elsif Present
(Predef_Op2
) then
8700 Add_One_Interp
(N
, Predef_Op2
, T
);
8706 Add_One_Interp
(N
, Predef_Op
, T
);
8708 -- For operators with unary and binary interpretations, if
8709 -- context is not a call, add both
8711 if Present
(Homonym
(Predef_Op
)) then
8712 Add_One_Interp
(N
, Homonym
(Predef_Op
), T
);
8716 -- The node is a reference to a predefined operator, and
8717 -- an implicit reference to the type of its operands.
8719 if Present
(Op_Type
) then
8720 Generate_Operator_Reference
(N
, Op_Type
);
8722 Generate_Operator_Reference
(N
, T
);
8724 end Add_Implicit_Operator
;
8726 -- Start of processing for Has_Implicit_Operator
8729 if Ekind
(P
) = E_Package
and then not In_Open_Scopes
(P
) then
8730 Priv_Id
:= First_Private_Entity
(P
);
8733 Id
:= First_Entity
(P
);
8737 -- Boolean operators: an implicit declaration exists if the scope
8738 -- contains a declaration for a derived Boolean type, or for an
8739 -- array of Boolean type.
8746 while Id
/= Priv_Id
loop
8748 and then Valid_Boolean_Arg
(Id
)
8749 and then Is_Base_Type
(Id
)
8751 Add_Implicit_Operator
(Id
);
8758 -- Equality: look for any non-limited type (result is Boolean)
8763 while Id
/= Priv_Id
loop
8765 and then Valid_Equality_Arg
(Id
)
8766 and then Is_Base_Type
(Id
)
8768 Add_Implicit_Operator
(Standard_Boolean
, Id
);
8775 -- Comparison operators: scalar type, or array of scalar
8782 while Id
/= Priv_Id
loop
8784 and then Valid_Comparison_Arg
(Id
)
8785 and then Is_Base_Type
(Id
)
8787 Add_Implicit_Operator
(Standard_Boolean
, Id
);
8794 -- Arithmetic operators: any numeric type
8805 while Id
/= Priv_Id
loop
8806 if Is_Numeric_Type
(Id
) and then Is_Base_Type
(Id
) then
8807 Add_Implicit_Operator
(Id
);
8814 -- Concatenation: any one-dimensional array type
8816 when Name_Op_Concat
=>
8817 while Id
/= Priv_Id
loop
8818 if Is_Array_Type
(Id
)
8819 and then Number_Dimensions
(Id
) = 1
8820 and then Is_Base_Type
(Id
)
8822 Add_Implicit_Operator
(Id
);
8829 -- What is the others condition here? Should we be using a
8830 -- subtype of Name_Id that would restrict to operators ???
8836 -- If we fall through, then we do not have an implicit operator
8839 end Has_Implicit_Operator
;
8841 -----------------------------------
8842 -- Has_Loop_In_Inner_Open_Scopes --
8843 -----------------------------------
8845 function Has_Loop_In_Inner_Open_Scopes
(S
: Entity_Id
) return Boolean is
8847 -- Several scope stacks are maintained by Scope_Stack. The base of the
8848 -- currently active scope stack is denoted by the Is_Active_Stack_Base
8849 -- flag in the scope stack entry. Note that the scope stacks used to
8850 -- simply be delimited implicitly by the presence of Standard_Standard
8851 -- at their base, but there now are cases where this is not sufficient
8852 -- because Standard_Standard actually may appear in the middle of the
8853 -- active set of scopes.
8855 for J
in reverse 0 .. Scope_Stack
.Last
loop
8857 -- S was reached without seing a loop scope first
8859 if Scope_Stack
.Table
(J
).Entity
= S
then
8862 -- S was not yet reached, so it contains at least one inner loop
8864 elsif Ekind
(Scope_Stack
.Table
(J
).Entity
) = E_Loop
then
8868 -- Check Is_Active_Stack_Base to tell us when to stop, as there are
8869 -- cases where Standard_Standard appears in the middle of the active
8870 -- set of scopes. This affects the declaration and overriding of
8871 -- private inherited operations in instantiations of generic child
8874 pragma Assert
(not Scope_Stack
.Table
(J
).Is_Active_Stack_Base
);
8877 raise Program_Error
; -- unreachable
8878 end Has_Loop_In_Inner_Open_Scopes
;
8880 --------------------
8881 -- In_Open_Scopes --
8882 --------------------
8884 function In_Open_Scopes
(S
: Entity_Id
) return Boolean is
8886 -- Several scope stacks are maintained by Scope_Stack. The base of the
8887 -- currently active scope stack is denoted by the Is_Active_Stack_Base
8888 -- flag in the scope stack entry. Note that the scope stacks used to
8889 -- simply be delimited implicitly by the presence of Standard_Standard
8890 -- at their base, but there now are cases where this is not sufficient
8891 -- because Standard_Standard actually may appear in the middle of the
8892 -- active set of scopes.
8894 for J
in reverse 0 .. Scope_Stack
.Last
loop
8895 if Scope_Stack
.Table
(J
).Entity
= S
then
8899 -- Check Is_Active_Stack_Base to tell us when to stop, as there are
8900 -- cases where Standard_Standard appears in the middle of the active
8901 -- set of scopes. This affects the declaration and overriding of
8902 -- private inherited operations in instantiations of generic child
8905 exit when Scope_Stack
.Table
(J
).Is_Active_Stack_Base
;
8911 -----------------------------
8912 -- Inherit_Renamed_Profile --
8913 -----------------------------
8915 procedure Inherit_Renamed_Profile
(New_S
: Entity_Id
; Old_S
: Entity_Id
) is
8922 if Ekind
(Old_S
) = E_Operator
then
8923 New_F
:= First_Formal
(New_S
);
8925 while Present
(New_F
) loop
8926 Set_Etype
(New_F
, Base_Type
(Etype
(New_F
)));
8927 Next_Formal
(New_F
);
8930 Set_Etype
(New_S
, Base_Type
(Etype
(New_S
)));
8933 New_F
:= First_Formal
(New_S
);
8934 Old_F
:= First_Formal
(Old_S
);
8936 while Present
(New_F
) loop
8937 New_T
:= Etype
(New_F
);
8938 Old_T
:= Etype
(Old_F
);
8940 -- If the new type is a renaming of the old one, as is the case
8941 -- for actuals in instances, retain its name, to simplify later
8944 if Nkind
(Parent
(New_T
)) = N_Subtype_Declaration
8945 and then Is_Entity_Name
(Subtype_Indication
(Parent
(New_T
)))
8946 and then Entity
(Subtype_Indication
(Parent
(New_T
))) = Old_T
8950 Set_Etype
(New_F
, Old_T
);
8953 Next_Formal
(New_F
);
8954 Next_Formal
(Old_F
);
8957 pragma Assert
(No
(Old_F
));
8959 if Ekind
(Old_S
) in E_Function | E_Enumeration_Literal
then
8960 Set_Etype
(New_S
, Etype
(Old_S
));
8963 end Inherit_Renamed_Profile
;
8969 procedure Initialize
is
8974 -------------------------
8975 -- Install_Use_Clauses --
8976 -------------------------
8978 procedure Install_Use_Clauses
8980 Force_Installation
: Boolean := False)
8986 while Present
(U
) loop
8988 -- Case of USE package
8990 if Nkind
(U
) = N_Use_Package_Clause
then
8991 Use_One_Package
(U
, Name
(U
), True);
8996 Use_One_Type
(Subtype_Mark
(U
), Force
=> Force_Installation
);
9000 Next_Use_Clause
(U
);
9002 end Install_Use_Clauses
;
9004 ----------------------
9005 -- Mark_Use_Clauses --
9006 ----------------------
9008 procedure Mark_Use_Clauses
(Id
: Node_Or_Entity_Id
) is
9009 procedure Mark_Parameters
(Call
: Entity_Id
);
9010 -- Perform use_type_clause marking for all parameters in a subprogram
9011 -- or operator call.
9013 procedure Mark_Use_Package
(Pak
: Entity_Id
);
9014 -- Move up the Prev_Use_Clause chain for packages denoted by Pak -
9015 -- marking each clause in the chain as effective in the process.
9017 procedure Mark_Use_Type
(E
: Entity_Id
);
9018 -- Similar to Do_Use_Package_Marking except we move up the
9019 -- Prev_Use_Clause chain for the type denoted by E.
9021 ---------------------
9022 -- Mark_Parameters --
9023 ---------------------
9025 procedure Mark_Parameters
(Call
: Entity_Id
) is
9029 -- Move through all of the formals
9031 Curr
:= First_Formal
(Call
);
9032 while Present
(Curr
) loop
9033 Mark_Use_Type
(Curr
);
9038 -- Handle the return type
9040 Mark_Use_Type
(Call
);
9041 end Mark_Parameters
;
9043 ----------------------
9044 -- Mark_Use_Package --
9045 ----------------------
9047 procedure Mark_Use_Package
(Pak
: Entity_Id
) is
9051 -- Ignore cases where the scope of the type is not a package (e.g.
9052 -- Standard_Standard).
9054 if Ekind
(Pak
) /= E_Package
then
9058 Curr
:= Current_Use_Clause
(Pak
);
9059 while Present
(Curr
)
9060 and then not Is_Effective_Use_Clause
(Curr
)
9062 -- We need to mark the previous use clauses as effective, but
9063 -- each use clause may in turn render other use_package_clauses
9064 -- effective. Additionally, it is possible to have a parent
9065 -- package renamed as a child of itself so we must check the
9066 -- prefix entity is not the same as the package we are marking.
9068 if Nkind
(Name
(Curr
)) /= N_Identifier
9069 and then Present
(Prefix
(Name
(Curr
)))
9070 and then Entity
(Prefix
(Name
(Curr
))) /= Pak
9072 Mark_Use_Package
(Entity
(Prefix
(Name
(Curr
))));
9074 -- It is also possible to have a child package without a prefix
9075 -- that relies on a previous use_package_clause.
9077 elsif Nkind
(Name
(Curr
)) = N_Identifier
9078 and then Is_Child_Unit
(Entity
(Name
(Curr
)))
9080 Mark_Use_Package
(Scope
(Entity
(Name
(Curr
))));
9083 -- Mark the use_package_clause as effective and move up the chain
9085 Set_Is_Effective_Use_Clause
(Curr
);
9087 Curr
:= Prev_Use_Clause
(Curr
);
9089 end Mark_Use_Package
;
9095 procedure Mark_Use_Type
(E
: Entity_Id
) is
9100 -- Ignore void types and unresolved string literals and primitives
9102 if Nkind
(E
) = N_String_Literal
9103 or else Nkind
(Etype
(E
)) not in N_Entity
9104 or else not Is_Type
(Etype
(E
))
9109 -- Primitives with class-wide operands might additionally render
9110 -- their base type's use_clauses effective - so do a recursive check
9113 Base
:= Base_Type
(Etype
(E
));
9115 if Ekind
(Base
) = E_Class_Wide_Type
then
9116 Mark_Use_Type
(Base
);
9119 -- The package containing the type or operator function being used
9120 -- may be in use as well, so mark any use_package_clauses for it as
9121 -- effective. There are also additional sanity checks performed here
9122 -- for ignoring previous errors.
9124 Mark_Use_Package
(Scope
(Base
));
9126 if Nkind
(E
) in N_Op
9127 and then Present
(Entity
(E
))
9128 and then Present
(Scope
(Entity
(E
)))
9130 Mark_Use_Package
(Scope
(Entity
(E
)));
9133 Curr
:= Current_Use_Clause
(Base
);
9134 while Present
(Curr
)
9135 and then not Is_Effective_Use_Clause
(Curr
)
9137 -- Current use_type_clause may render other use_package_clauses
9140 if Nkind
(Subtype_Mark
(Curr
)) /= N_Identifier
9141 and then Present
(Prefix
(Subtype_Mark
(Curr
)))
9143 Mark_Use_Package
(Entity
(Prefix
(Subtype_Mark
(Curr
))));
9146 -- Mark the use_type_clause as effective and move up the chain
9148 Set_Is_Effective_Use_Clause
(Curr
);
9150 Curr
:= Prev_Use_Clause
(Curr
);
9154 -- Start of processing for Mark_Use_Clauses
9157 -- Use clauses in and of themselves do not count as a "use" of a
9160 if Nkind
(Parent
(Id
)) in N_Use_Package_Clause | N_Use_Type_Clause
then
9166 if Nkind
(Id
) in N_Entity
then
9168 -- Mark the entity's package
9170 if Is_Potentially_Use_Visible
(Id
) then
9171 Mark_Use_Package
(Scope
(Id
));
9174 -- Mark enumeration literals
9176 if Ekind
(Id
) = E_Enumeration_Literal
then
9181 elsif (Is_Overloadable
(Id
)
9182 or else Is_Generic_Subprogram
(Id
))
9183 and then (Is_Potentially_Use_Visible
(Id
)
9184 or else Is_Intrinsic_Subprogram
(Id
)
9185 or else (Ekind
(Id
) in E_Function | E_Procedure
9186 and then Is_Generic_Actual_Subprogram
(Id
)))
9188 Mark_Parameters
(Id
);
9196 if Nkind
(Id
) in N_Op
then
9198 -- At this point the left operand may not be resolved if we are
9199 -- encountering multiple operators next to eachother in an
9202 if Nkind
(Id
) in N_Binary_Op
9203 and then not (Nkind
(Left_Opnd
(Id
)) in N_Op
)
9205 Mark_Use_Type
(Left_Opnd
(Id
));
9208 Mark_Use_Type
(Right_Opnd
(Id
));
9211 -- Mark entity identifiers
9213 elsif Nkind
(Id
) in N_Has_Entity
9214 and then (Is_Potentially_Use_Visible
(Entity
(Id
))
9215 or else (Is_Generic_Instance
(Entity
(Id
))
9216 and then Is_Immediately_Visible
(Entity
(Id
))))
9218 -- Ignore fully qualified names as they do not count as a "use" of
9221 if Nkind
(Id
) in N_Identifier | N_Operator_Symbol
9222 or else (Present
(Prefix
(Id
))
9223 and then Scope
(Entity
(Id
)) /= Entity
(Prefix
(Id
)))
9225 Mark_Use_Clauses
(Entity
(Id
));
9229 end Mark_Use_Clauses
;
9231 --------------------------------
9232 -- Most_Descendant_Use_Clause --
9233 --------------------------------
9235 function Most_Descendant_Use_Clause
9236 (Clause1
: Entity_Id
;
9237 Clause2
: Entity_Id
) return Entity_Id
9239 function Determine_Package_Scope
(Clause
: Node_Id
) return Entity_Id
;
9240 -- Given a use clause, determine which package it belongs to
9242 -----------------------------
9243 -- Determine_Package_Scope --
9244 -----------------------------
9246 function Determine_Package_Scope
(Clause
: Node_Id
) return Entity_Id
is
9248 -- Check if the clause appears in the context area
9250 -- Note we cannot employ Enclosing_Packge for use clauses within
9251 -- context clauses since they are not actually "enclosed."
9253 if Nkind
(Parent
(Clause
)) = N_Compilation_Unit
then
9254 return Entity_Of_Unit
(Unit
(Parent
(Clause
)));
9257 -- Otherwise, obtain the enclosing package normally
9259 return Enclosing_Package
(Clause
);
9260 end Determine_Package_Scope
;
9265 -- Start of processing for Most_Descendant_Use_Clause
9268 if Clause1
= Clause2
then
9272 -- We determine which one is the most descendant by the scope distance
9273 -- to the ultimate parent unit.
9275 Scope1
:= Determine_Package_Scope
(Clause1
);
9276 Scope2
:= Determine_Package_Scope
(Clause2
);
9277 while Scope1
/= Standard_Standard
9278 and then Scope2
/= Standard_Standard
9280 Scope1
:= Scope
(Scope1
);
9281 Scope2
:= Scope
(Scope2
);
9285 elsif No
(Scope2
) then
9290 if Scope1
= Standard_Standard
then
9295 end Most_Descendant_Use_Clause
;
9301 procedure Pop_Scope
is
9302 SST
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Scope_Stack
.Last
);
9303 S
: constant Scope_Kind_Id
:= SST
.Entity
;
9306 if Debug_Flag_E
then
9310 -- Set Default_Storage_Pool field of the library unit if necessary
9312 if Is_Package_Or_Generic_Package
(S
)
9314 Nkind
(Parent
(Unit_Declaration_Node
(S
))) = N_Compilation_Unit
9317 Aux
: constant Node_Id
:=
9318 Aux_Decls_Node
(Parent
(Unit_Declaration_Node
(S
)));
9320 if No
(Default_Storage_Pool
(Aux
)) then
9321 Set_Default_Storage_Pool
(Aux
, Default_Pool
);
9326 Scope_Suppress
:= SST
.Save_Scope_Suppress
;
9327 Local_Suppress_Stack_Top
:= SST
.Save_Local_Suppress_Stack_Top
;
9328 Check_Policy_List
:= SST
.Save_Check_Policy_List
;
9329 Default_Pool
:= SST
.Save_Default_Storage_Pool
;
9330 No_Tagged_Streams
:= SST
.Save_No_Tagged_Streams
;
9331 SPARK_Mode
:= SST
.Save_SPARK_Mode
;
9332 SPARK_Mode_Pragma
:= SST
.Save_SPARK_Mode_Pragma
;
9333 Default_SSO
:= SST
.Save_Default_SSO
;
9334 Uneval_Old
:= SST
.Save_Uneval_Old
;
9336 if Debug_Flag_W
then
9337 Write_Str
("<-- exiting scope: ");
9338 Write_Name
(Chars
(Current_Scope
));
9339 Write_Str
(", Depth=");
9340 Write_Int
(Int
(Scope_Stack
.Last
));
9344 End_Use_Clauses
(SST
.First_Use_Clause
);
9346 -- If the actions to be wrapped are still there they will get lost
9347 -- causing incomplete code to be generated. It is better to abort in
9348 -- this case (and we do the abort even with assertions off since the
9349 -- penalty is incorrect code generation).
9351 if SST
.Actions_To_Be_Wrapped
/= Scope_Actions
'(others => No_List) then
9352 raise Program_Error;
9355 -- Free last subprogram name if allocated, and pop scope
9357 Free (SST.Last_Subprogram_Name);
9358 Scope_Stack.Decrement_Last;
9365 procedure Push_Scope (S : Scope_Kind_Id) is
9366 E : constant Entity_Id := Scope (S);
9368 function Component_Alignment_Default return Component_Alignment_Kind;
9369 -- Return Component_Alignment_Kind for the newly-pushed scope.
9371 function Component_Alignment_Default return Component_Alignment_Kind is
9373 -- Each new scope pushed onto the scope stack inherits the component
9374 -- alignment of the previous scope. This emulates the "visibility"
9375 -- semantics of pragma Component_Alignment.
9377 if Scope_Stack.Last > Scope_Stack.First then
9378 return Scope_Stack.Table
9379 (Scope_Stack.Last - 1).Component_Alignment_Default;
9381 -- Otherwise, this is the first scope being pushed on the scope
9382 -- stack. Inherit the component alignment from the configuration
9383 -- form of pragma Component_Alignment (if any).
9386 return Configuration_Component_Alignment;
9388 end Component_Alignment_Default;
9391 if Ekind (S) = E_Void then
9394 -- Set scope depth if not a nonconcurrent type, and we have not yet set
9395 -- the scope depth. This means that we have the first occurrence of the
9396 -- scope, and this is where the depth is set.
9398 elsif (not Is_Type (S) or else Is_Concurrent_Type (S))
9399 and then not Scope_Depth_Set (S)
9401 if S = Standard_Standard then
9402 Set_Scope_Depth_Value (S, Uint_0);
9404 elsif Is_Child_Unit (S) then
9405 Set_Scope_Depth_Value (S, Uint_1);
9407 elsif not Is_Record_Type (Current_Scope) then
9408 if Scope_Depth_Set (Current_Scope) then
9409 if Ekind (S) = E_Loop then
9410 Set_Scope_Depth_Value (S, Scope_Depth (Current_Scope));
9412 Set_Scope_Depth_Value (S, Scope_Depth (Current_Scope) + 1);
9418 Scope_Stack.Increment_Last;
9420 Scope_Stack.Table (Scope_Stack.Last) :=
9422 Save_Scope_Suppress => Scope_Suppress,
9423 Save_Local_Suppress_Stack_Top => Local_Suppress_Stack_Top,
9424 Save_Check_Policy_List => Check_Policy_List,
9425 Save_Default_Storage_Pool => Default_Pool,
9426 Save_No_Tagged_Streams => No_Tagged_Streams,
9427 Save_SPARK_Mode => SPARK_Mode,
9428 Save_SPARK_Mode_Pragma => SPARK_Mode_Pragma,
9429 Save_Default_SSO => Default_SSO,
9430 Save_Uneval_Old => Uneval_Old,
9431 Component_Alignment_Default => Component_Alignment_Default,
9432 Last_Subprogram_Name => null,
9433 Is_Transient => False,
9434 Node_To_Be_Wrapped => Empty,
9435 Pending_Freeze_Actions => No_List,
9436 Actions_To_Be_Wrapped => (others => No_List),
9437 First_Use_Clause => Empty,
9438 Is_Active_Stack_Base => False,
9439 Previous_Visibility => False,
9440 Locked_Shared_Objects => No_Elist);
9442 if Debug_Flag_W then
9443 Write_Str ("--> new scope: ");
9444 Write_Name (Chars (Current_Scope));
9445 Write_Str (", Id=");
9446 Write_Int (Int (Current_Scope));
9447 Write_Str (", Depth=");
9448 Write_Int (Int (Scope_Stack.Last));
9452 -- Deal with copying flags from the previous scope to this one. This is
9453 -- not necessary if either scope is standard, or if the new scope is a
9456 if S /= Standard_Standard
9457 and then Scope (S) /= Standard_Standard
9458 and then not Is_Child_Unit (S)
9460 if Nkind (E) not in N_Entity then
9464 -- Copy categorization flags from Scope (S) to S, this is not done
9465 -- when Scope (S) is Standard_Standard since propagation is from
9466 -- library unit entity inwards. Copy other relevant attributes as
9467 -- well (Discard_Names in particular).
9469 -- We only propagate inwards for library level entities,
9470 -- inner level subprograms do not inherit the categorization.
9472 if Is_Library_Level_Entity (S) then
9473 Set_Is_Preelaborated (S, Is_Preelaborated (E));
9474 Set_Is_Shared_Passive (S, Is_Shared_Passive (E));
9475 Set_Discard_Names (S, Discard_Names (E));
9476 Set_Suppress_Value_Tracking_On_Call
9477 (S, Suppress_Value_Tracking_On_Call (E));
9478 Set_Categorization_From_Scope (E => S, Scop => E);
9482 if Is_Child_Unit (S)
9483 and then Present (E)
9484 and then Is_Package_Or_Generic_Package (E)
9486 Nkind (Parent (Unit_Declaration_Node (E))) = N_Compilation_Unit
9489 Aux : constant Node_Id :=
9490 Aux_Decls_Node (Parent (Unit_Declaration_Node (E)));
9492 if Present (Default_Storage_Pool (Aux)) then
9493 Default_Pool := Default_Storage_Pool (Aux);
9499 ---------------------
9500 -- Premature_Usage --
9501 ---------------------
9503 procedure Premature_Usage (N : Node_Id) is
9504 Kind : constant Node_Kind := Nkind (Parent (Entity (N)));
9505 E : Entity_Id := Entity (N);
9508 -- Within an instance, the analysis of the actual for a formal object
9509 -- does not see the name of the object itself. This is significant only
9510 -- if the object is an aggregate, where its analysis does not do any
9511 -- name resolution on component associations. (see 4717-008). In such a
9512 -- case, look for the visible homonym on the chain.
9514 if In_Instance and then Present (Homonym (E)) then
9516 while Present (E) and then not In_Open_Scopes (Scope (E)) loop
9522 Set_Etype (N, Etype (E));
9528 when N_Component_Declaration =>
9530 ("component&! cannot be used before end of record declaration",
9533 when N_Parameter_Specification =>
9535 ("formal parameter&! cannot be used before end of specification",
9538 when N_Discriminant_Specification =>
9540 ("discriminant&! cannot be used before end of discriminant part",
9543 when N_Procedure_Specification | N_Function_Specification =>
9545 ("subprogram&! cannot be used before end of its declaration",
9548 when N_Full_Type_Declaration | N_Subtype_Declaration =>
9550 ("type& cannot be used before end of its declaration!", N);
9554 ("object& cannot be used before end of its declaration!", N);
9556 -- If the premature reference appears as the expression in its own
9557 -- declaration, rewrite it to prevent compiler loops in subsequent
9558 -- uses of this mangled declaration in address clauses.
9560 if Nkind (Parent (N)) = N_Object_Declaration then
9561 Set_Entity (N, Any_Id);
9564 end Premature_Usage;
9566 ------------------------
9567 -- Present_System_Aux --
9568 ------------------------
9570 function Present_System_Aux (N : Node_Id := Empty) return Boolean is
9572 Aux_Name : Unit_Name_Type;
9573 Unum : Unit_Number_Type;
9578 function Find_System (C_Unit : Node_Id) return Entity_Id;
9579 -- Scan context clause of compilation unit to find with_clause
9586 function Find_System (C_Unit : Node_Id) return Entity_Id is
9587 With_Clause : Node_Id;
9590 With_Clause := First (Context_Items (C_Unit));
9591 while Present (With_Clause) loop
9592 if (Nkind (With_Clause) = N_With_Clause
9593 and then Chars (Name (With_Clause)) = Name_System)
9594 and then Comes_From_Source (With_Clause)
9605 -- Start of processing for Present_System_Aux
9608 -- The child unit may have been loaded and analyzed already
9610 if Present (System_Aux_Id) then
9613 -- If no previous pragma for System.Aux, nothing to load
9615 elsif No (System_Extend_Unit) then
9618 -- Use the unit name given in the pragma to retrieve the unit.
9619 -- Verify that System itself appears in the context clause of the
9620 -- current compilation. If System is not present, an error will
9621 -- have been reported already.
9624 With_Sys := Find_System (Cunit (Current_Sem_Unit));
9626 The_Unit := Unit (Cunit (Current_Sem_Unit));
9630 (Nkind (The_Unit) = N_Package_Body
9631 or else (Nkind (The_Unit) = N_Subprogram_Body
9632 and then not Acts_As_Spec (Cunit (Current_Sem_Unit))))
9634 With_Sys := Find_System (Library_Unit (Cunit (Current_Sem_Unit)));
9637 if No (With_Sys) and then Present (N) then
9639 -- If we are compiling a subunit, we need to examine its
9640 -- context as well (Current_Sem_Unit is the parent unit);
9642 The_Unit := Parent (N);
9643 while Nkind (The_Unit) /= N_Compilation_Unit loop
9644 The_Unit := Parent (The_Unit);
9647 if Nkind (Unit (The_Unit)) = N_Subunit then
9648 With_Sys := Find_System (The_Unit);
9652 if No (With_Sys) then
9656 Loc := Sloc (With_Sys);
9657 Get_Name_String (Chars (Expression (System_Extend_Unit)));
9658 Name_Buffer (8 .. Name_Len + 7) := Name_Buffer (1 .. Name_Len);
9659 Name_Buffer (1 .. 7) := "system.";
9660 Name_Buffer (Name_Len + 8) := '%';
9661 Name_Buffer (Name_Len + 9) := 's
';
9662 Name_Len := Name_Len + 9;
9663 Aux_Name := Name_Find;
9667 (Load_Name => Aux_Name,
9670 Error_Node => With_Sys);
9672 if Unum /= No_Unit then
9673 Semantics (Cunit (Unum));
9675 Defining_Entity (Specification (Unit (Cunit (Unum))));
9678 Make_With_Clause (Loc,
9680 Make_Expanded_Name (Loc,
9681 Chars => Chars (System_Aux_Id),
9683 New_Occurrence_Of (Scope (System_Aux_Id), Loc),
9684 Selector_Name => New_Occurrence_Of (System_Aux_Id, Loc)));
9686 Set_Entity (Name (Withn), System_Aux_Id);
9688 Set_Corresponding_Spec (Withn, System_Aux_Id);
9689 Set_First_Name (Withn);
9690 Set_Implicit_With (Withn);
9691 Set_Library_Unit (Withn, Cunit (Unum));
9693 Insert_After (With_Sys, Withn);
9694 Mark_Rewrite_Insertion (Withn);
9695 Set_Context_Installed (Withn);
9699 -- Here if unit load failed
9702 Error_Msg_Name_1 := Name_System;
9703 Error_Msg_Name_2 := Chars (Expression (System_Extend_Unit));
9705 ("extension package `%.%` does not exist",
9706 Opt.System_Extend_Unit);
9710 end Present_System_Aux;
9712 -------------------------
9713 -- Restore_Scope_Stack --
9714 -------------------------
9716 procedure Restore_Scope_Stack
9718 Handle_Use : Boolean := True)
9720 SS_Last : constant Int := Scope_Stack.Last;
9724 -- Restore visibility of previous scope stack, if any, using the list
9725 -- we saved (we use Remove, since this list will not be used again).
9728 Elmt := First_Elmt (List);
9729 exit when Elmt = No_Elmt;
9730 Set_Is_Immediately_Visible (Node (Elmt));
9731 Remove_Elmt (List, Elmt);
9734 -- Restore use clauses
9736 if SS_Last >= Scope_Stack.First
9737 and then Scope_Stack.Table (SS_Last).Entity /= Standard_Standard
9741 (Scope_Stack.Table (SS_Last).First_Use_Clause,
9742 Force_Installation => True);
9744 end Restore_Scope_Stack;
9746 ----------------------
9747 -- Save_Scope_Stack --
9748 ----------------------
9750 -- Save_Scope_Stack/Restore_Scope_Stack were originally designed to avoid
9751 -- consuming any memory. That is, Save_Scope_Stack took care of removing
9752 -- from immediate visibility entities and Restore_Scope_Stack took care
9753 -- of restoring their visibility analyzing the context of each entity. The
9754 -- problem of such approach is that it was fragile and caused unexpected
9755 -- visibility problems, and indeed one test was found where there was a
9758 -- Furthermore, the following experiment was carried out:
9760 -- - Save_Scope_Stack was modified to store in an Elist1 all those
9761 -- entities whose attribute Is_Immediately_Visible is modified
9762 -- from True to False.
9764 -- - Restore_Scope_Stack was modified to store in another Elist2
9765 -- all the entities whose attribute Is_Immediately_Visible is
9766 -- modified from False to True.
9768 -- - Extra code was added to verify that all the elements of Elist1
9769 -- are found in Elist2
9771 -- This test shows that there may be more occurrences of this problem which
9772 -- have not yet been detected. As a result, we replaced that approach by
9773 -- the current one in which Save_Scope_Stack returns the list of entities
9774 -- whose visibility is changed, and that list is passed to Restore_Scope_
9775 -- Stack to undo that change. This approach is simpler and safer, although
9776 -- it consumes more memory.
9778 function Save_Scope_Stack (Handle_Use : Boolean := True) return Elist_Id is
9779 Result : constant Elist_Id := New_Elmt_List;
9782 SS_Last : constant Int := Scope_Stack.Last;
9784 procedure Remove_From_Visibility (E : Entity_Id);
9785 -- If E is immediately visible then append it to the result and remove
9786 -- it temporarily from visibility.
9788 ----------------------------
9789 -- Remove_From_Visibility --
9790 ----------------------------
9792 procedure Remove_From_Visibility (E : Entity_Id) is
9794 if Is_Immediately_Visible (E) then
9795 Append_Elmt (E, Result);
9796 Set_Is_Immediately_Visible (E, False);
9798 end Remove_From_Visibility;
9800 -- Start of processing for Save_Scope_Stack
9803 if SS_Last >= Scope_Stack.First
9804 and then Scope_Stack.Table (SS_Last).Entity /= Standard_Standard
9807 End_Use_Clauses (Scope_Stack.Table (SS_Last).First_Use_Clause);
9810 -- If the call is from within a compilation unit, as when called from
9811 -- Rtsfind, make current entries in scope stack invisible while we
9812 -- analyze the new unit.
9814 for J in reverse 0 .. SS_Last loop
9815 exit when Scope_Stack.Table (J).Entity = Standard_Standard
9816 or else No (Scope_Stack.Table (J).Entity);
9818 S := Scope_Stack.Table (J).Entity;
9820 Remove_From_Visibility (S);
9822 E := First_Entity (S);
9823 while Present (E) loop
9824 Remove_From_Visibility (E);
9832 end Save_Scope_Stack;
9838 procedure Set_Use (L : List_Id) is
9843 while Present (Decl) loop
9844 if Nkind (Decl) = N_Use_Package_Clause then
9845 Chain_Use_Clause (Decl);
9846 Use_One_Package (Decl, Name (Decl));
9848 elsif Nkind (Decl) = N_Use_Type_Clause then
9849 Chain_Use_Clause (Decl);
9850 Use_One_Type (Subtype_Mark (Decl));
9858 -----------------------------
9859 -- Update_Use_Clause_Chain --
9860 -----------------------------
9862 procedure Update_Use_Clause_Chain is
9864 procedure Update_Chain_In_Scope (Level : Int);
9865 -- Iterate through one level in the scope stack verifying each use-type
9866 -- clause within said level is used then reset the Current_Use_Clause
9867 -- to a redundant use clause outside of the current ending scope if such
9870 ---------------------------
9871 -- Update_Chain_In_Scope --
9872 ---------------------------
9874 procedure Update_Chain_In_Scope (Level : Int) is
9879 -- Loop through all use clauses within the scope dictated by Level
9881 Curr := Scope_Stack.Table (Level).First_Use_Clause;
9882 while Present (Curr) loop
9884 -- Retrieve the subtype mark or name within the current current
9887 if Nkind (Curr) = N_Use_Type_Clause then
9888 N := Subtype_Mark (Curr);
9893 -- If warnings for unreferenced entities are enabled and the
9894 -- current use clause has not been marked effective.
9896 if Check_Unreferenced
9897 and then Comes_From_Source (Curr)
9898 and then not Is_Effective_Use_Clause (Curr)
9899 and then not In_Instance
9900 and then not In_Inlined_Body
9902 -- We are dealing with a potentially unused use_package_clause
9904 if Nkind (Curr) = N_Use_Package_Clause then
9906 -- Renamings and formal subprograms may cause the associated
9907 -- node to be marked as effective instead of the original.
9909 if not (Present (Associated_Node (N))
9912 (Associated_Node (N)))
9913 and then Is_Effective_Use_Clause
9915 (Associated_Node (N))))
9917 Error_Msg_Node_1 := Entity (N);
9919 ("use clause for package & has no effect?u?",
9923 -- We are dealing with an unused use_type_clause
9926 Error_Msg_Node_1 := Etype (N);
9928 ("use clause for } has no effect?u?", Curr, Etype (N));
9932 -- Verify that we haven't already processed a redundant
9933 -- use_type_clause within the same scope before we move the
9934 -- current use clause up to a previous one for type T.
9936 if Present (Prev_Use_Clause (Curr)) then
9937 Set_Current_Use_Clause (Entity (N), Prev_Use_Clause (Curr));
9940 Next_Use_Clause (Curr);
9942 end Update_Chain_In_Scope;
9944 -- Start of processing for Update_Use_Clause_Chain
9947 Update_Chain_In_Scope (Scope_Stack.Last);
9949 -- Deal with use clauses within the context area if the current
9950 -- scope is a compilation unit.
9952 if Is_Compilation_Unit (Current_Scope)
9953 and then Sloc (Scope_Stack.Table
9954 (Scope_Stack.Last - 1).Entity) = Standard_Location
9956 Update_Chain_In_Scope (Scope_Stack.Last - 1);
9958 end Update_Use_Clause_Chain;
9960 ---------------------
9961 -- Use_One_Package --
9962 ---------------------
9964 procedure Use_One_Package
9966 Pack_Name : Entity_Id := Empty;
9967 Force : Boolean := False)
9969 procedure Note_Redundant_Use (Clause : Node_Id);
9970 -- Mark the name in a use clause as redundant if the corresponding
9971 -- entity is already use-visible. Emit a warning if the use clause comes
9972 -- from source and the proper warnings are enabled.
9974 ------------------------
9975 -- Note_Redundant_Use --
9976 ------------------------
9978 procedure Note_Redundant_Use (Clause : Node_Id) is
9979 Decl : constant Node_Id := Parent (Clause);
9980 Pack_Name : constant Entity_Id := Entity (Clause);
9982 Cur_Use : Node_Id := Current_Use_Clause (Pack_Name);
9983 Prev_Use : Node_Id := Empty;
9984 Redundant : Node_Id := Empty;
9985 -- The Use_Clause which is actually redundant. In the simplest case
9986 -- it is Pack itself, but when we compile a body we install its
9987 -- context before that of its spec, in which case it is the
9988 -- use_clause in the spec that will appear to be redundant, and we
9989 -- want the warning to be placed on the body. Similar complications
9990 -- appear when the redundancy is between a child unit and one of its
9994 -- Could be renamed...
9996 if No (Cur_Use) then
9997 Cur_Use := Current_Use_Clause (Renamed_Entity (Pack_Name));
10000 Set_Redundant_Use (Clause, True);
10002 -- Do not check for redundant use if clause is generated, or in an
10003 -- instance, or in a predefined unit to avoid misleading warnings
10004 -- that may occur as part of a rtsfind load.
10006 if not Comes_From_Source (Clause)
10007 or else In_Instance
10008 or else not Warn_On_Redundant_Constructs
10009 or else Is_Predefined_Unit (Current_Sem_Unit)
10014 if not Is_Compilation_Unit (Current_Scope) then
10016 -- If the use_clause is in an inner scope, it is made redundant by
10017 -- some clause in the current context, with one exception: If we
10018 -- are compiling a nested package body, and the use_clause comes
10019 -- from then corresponding spec, the clause is not necessarily
10020 -- fully redundant, so we should not warn. If a warning was
10021 -- warranted, it would have been given when the spec was
10024 if Nkind (Parent (Decl)) = N_Package_Specification then
10026 Package_Spec_Entity : constant Entity_Id :=
10027 Defining_Unit_Name (Parent (Decl));
10029 if In_Package_Body (Package_Spec_Entity) then
10035 Redundant := Clause;
10036 Prev_Use := Cur_Use;
10038 elsif Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Body then
10040 Cur_Unit : constant Unit_Number_Type :=
10041 Get_Source_Unit (Cur_Use);
10042 New_Unit : constant Unit_Number_Type :=
10043 Get_Source_Unit (Clause);
10048 if Cur_Unit = New_Unit then
10050 -- Redundant clause in same body
10052 Redundant := Clause;
10053 Prev_Use := Cur_Use;
10055 elsif Cur_Unit = Current_Sem_Unit then
10057 -- If the new clause is not in the current unit it has been
10058 -- analyzed first, and it makes the other one redundant.
10059 -- However, if the new clause appears in a subunit, Cur_Unit
10060 -- is still the parent, and in that case the redundant one
10061 -- is the one appearing in the subunit.
10063 if Nkind (Unit (Cunit (New_Unit))) = N_Subunit then
10064 Redundant := Clause;
10065 Prev_Use := Cur_Use;
10067 -- Most common case: redundant clause in body, original
10068 -- clause in spec. Current scope is spec entity.
10070 elsif Current_Scope = Cunit_Entity (Current_Sem_Unit) then
10071 Redundant := Cur_Use;
10072 Prev_Use := Clause;
10075 -- The new clause may appear in an unrelated unit, when
10076 -- the parents of a generic are being installed prior to
10077 -- instantiation. In this case there must be no warning.
10078 -- We detect this case by checking whether the current
10079 -- top of the stack is related to the current
10082 Scop := Current_Scope;
10083 while Present (Scop)
10084 and then Scop /= Standard_Standard
10086 if Is_Compilation_Unit (Scop)
10087 and then not Is_Child_Unit (Scop)
10091 elsif Scop = Cunit_Entity (Current_Sem_Unit) then
10095 Scop := Scope (Scop);
10098 Redundant := Cur_Use;
10099 Prev_Use := Clause;
10102 elsif New_Unit = Current_Sem_Unit then
10103 Redundant := Clause;
10104 Prev_Use := Cur_Use;
10107 -- Neither is the current unit, so they appear in parent or
10108 -- sibling units. Warning will be emitted elsewhere.
10114 elsif Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Declaration
10115 and then Present (Parent_Spec (Unit (Cunit (Current_Sem_Unit))))
10117 -- Use_clause is in child unit of current unit, and the child unit
10118 -- appears in the context of the body of the parent, so it has
10119 -- been installed first, even though it is the redundant one.
10120 -- Depending on their placement in the context, the visible or the
10121 -- private parts of the two units, either might appear as
10122 -- redundant, but the message has to be on the current unit.
10124 if Get_Source_Unit (Cur_Use) = Current_Sem_Unit then
10125 Redundant := Cur_Use;
10126 Prev_Use := Clause;
10128 Redundant := Clause;
10129 Prev_Use := Cur_Use;
10132 -- If the new use clause appears in the private part of a parent
10133 -- unit it may appear to be redundant w.r.t. a use clause in a
10134 -- child unit, but the previous use clause was needed in the
10135 -- visible part of the child, and no warning should be emitted.
10137 if Nkind (Parent (Decl)) = N_Package_Specification
10138 and then List_Containing (Decl) =
10139 Private_Declarations (Parent (Decl))
10142 Par : constant Entity_Id :=
10143 Defining_Entity (Parent (Decl));
10144 Spec : constant Node_Id :=
10145 Specification (Unit (Cunit (Current_Sem_Unit)));
10146 Cur_List : constant List_Id := List_Containing (Cur_Use);
10149 if Is_Compilation_Unit (Par)
10150 and then Par /= Cunit_Entity (Current_Sem_Unit)
10152 if Cur_List = Context_Items (Cunit (Current_Sem_Unit))
10153 or else Cur_List = Visible_Declarations (Spec)
10161 -- Finally, if the current use clause is in the context then the
10162 -- clause is redundant when it is nested within the unit.
10164 elsif Nkind (Parent (Cur_Use)) = N_Compilation_Unit
10165 and then Nkind (Parent (Parent (Clause))) /= N_Compilation_Unit
10166 and then Get_Source_Unit (Cur_Use) = Get_Source_Unit (Clause)
10168 Redundant := Clause;
10169 Prev_Use := Cur_Use;
10172 if Present (Redundant) and then Parent (Redundant) /= Prev_Use then
10174 -- Make sure we are looking at most-descendant use_package_clause
10175 -- by traversing the chain with Find_First_Use and then verifying
10176 -- there is no scope manipulation via Most_Descendant_Use_Clause.
10178 if Nkind (Prev_Use) = N_Use_Package_Clause
10180 (Nkind (Parent (Prev_Use)) /= N_Compilation_Unit
10181 or else Most_Descendant_Use_Clause
10182 (Prev_Use, Find_First_Use (Prev_Use)) /= Prev_Use)
10184 Prev_Use := Find_First_Use (Prev_Use);
10187 Error_Msg_Sloc := Sloc (Prev_Use);
10188 Error_Msg_NE -- CODEFIX
10189 ("& is already use-visible through previous use_clause #?r?",
10190 Redundant, Pack_Name);
10192 end Note_Redundant_Use;
10196 Current_Instance : Entity_Id := Empty;
10200 Private_With_OK : Boolean := False;
10201 Real_P : Entity_Id;
10203 -- Start of processing for Use_One_Package
10206 -- Use_One_Package may have been called recursively to handle an
10207 -- implicit use for a auxiliary system package, so set P accordingly
10208 -- and skip redundancy checks.
10210 if No (Pack_Name) and then Present_System_Aux (N) then
10211 P := System_Aux_Id;
10213 -- Check for redundant use_package_clauses
10216 -- Ignore cases where we are dealing with a non user defined package
10217 -- like Standard_Standard or something other than a valid package.
10219 if not Is_Entity_Name (Pack_Name)
10220 or else No (Entity (Pack_Name))
10221 or else Ekind (Entity (Pack_Name)) /= E_Package
10226 -- When a renaming exists we must check it for redundancy. The
10227 -- original package would have already been seen at this point.
10229 if Present (Renamed_Entity (Entity (Pack_Name))) then
10230 P := Renamed_Entity (Entity (Pack_Name));
10232 P := Entity (Pack_Name);
10235 -- Check for redundant clauses then set the current use clause for
10236 -- P if were are not "forcing" an installation from a scope
10237 -- reinstallation that is done throughout analysis for various
10241 Note_Redundant_Use (Pack_Name);
10244 Set_Current_Use_Clause (P, N);
10249 -- Warn about detected redundant clauses
10252 and then In_Open_Scopes (P)
10253 and then not Is_Hidden_Open_Scope (P)
10255 if Warn_On_Redundant_Constructs and then P = Current_Scope then
10256 Error_Msg_NE -- CODEFIX
10257 ("& is already use-visible within itself?r?",
10264 -- Set P back to the non-renamed package so that visibility of the
10265 -- entities within the package can be properly set below.
10267 P := Entity (Pack_Name);
10271 Set_Current_Use_Clause (P, N);
10273 -- Ada 2005 (AI-50217): Check restriction
10275 if From_Limited_With (P) then
10276 Error_Msg_N ("limited withed package cannot appear in use clause", N);
10279 -- Find enclosing instance, if any
10281 if In_Instance then
10282 Current_Instance := Current_Scope;
10283 while not Is_Generic_Instance (Current_Instance) loop
10284 Current_Instance := Scope (Current_Instance);
10287 if No (Hidden_By_Use_Clause (N)) then
10288 Set_Hidden_By_Use_Clause (N, New_Elmt_List);
10292 -- If unit is a package renaming, indicate that the renamed package is
10293 -- also in use (the flags on both entities must remain consistent, and a
10294 -- subsequent use of either of them should be recognized as redundant).
10296 if Present (Renamed_Entity (P)) then
10297 Set_In_Use (Renamed_Entity (P));
10298 Set_Current_Use_Clause (Renamed_Entity (P), N);
10299 Real_P := Renamed_Entity (P);
10304 -- Ada 2005 (AI-262): Check the use_clause of a private withed package
10305 -- found in the private part of a package specification
10307 if In_Private_Part (Current_Scope)
10308 and then Has_Private_With (P)
10309 and then Is_Child_Unit (Current_Scope)
10310 and then Is_Child_Unit (P)
10311 and then Is_Ancestor_Package (Scope (Current_Scope), P)
10313 Private_With_OK := True;
10316 -- Loop through entities in one package making them potentially
10319 Id := First_Entity (P);
10321 and then (Id /= First_Private_Entity (P)
10322 or else Private_With_OK) -- Ada 2005 (AI-262)
10324 Prev := Current_Entity (Id);
10325 while Present (Prev) loop
10326 if Is_Immediately_Visible (Prev)
10327 and then (not Is_Overloadable (Prev)
10328 or else not Is_Overloadable (Id)
10329 or else Type_Conformant (Id, Prev))
10331 if No (Current_Instance) then
10333 -- Potentially use-visible entity remains hidden
10335 if Warn_On_Hiding then
10336 Warn_On_Hiding_Entity (N, Hidden => Id, Visible => Prev,
10337 On_Use_Clause => True);
10340 goto Next_Usable_Entity;
10342 -- A use clause within an instance hides outer global entities,
10343 -- which are not used to resolve local entities in the
10344 -- instance. Note that the predefined entities in Standard
10345 -- could not have been hidden in the generic by a use clause,
10346 -- and therefore remain visible. Other compilation units whose
10347 -- entities appear in Standard must be hidden in an instance.
10349 -- To determine whether an entity is external to the instance
10350 -- we compare the scope depth of its scope with that of the
10351 -- current instance. However, a generic actual of a subprogram
10352 -- instance is declared in the wrapper package but will not be
10353 -- hidden by a use-visible entity. similarly, an entity that is
10354 -- declared in an enclosing instance will not be hidden by an
10355 -- an entity declared in a generic actual, which can only have
10356 -- been use-visible in the generic and will not have hidden the
10357 -- entity in the generic parent.
10359 -- If Id is called Standard, the predefined package with the
10360 -- same name is in the homonym chain. It has to be ignored
10361 -- because it has no defined scope (being the only entity in
10362 -- the system with this mandated behavior).
10364 elsif not Is_Hidden (Id)
10365 and then Present (Scope (Prev))
10366 and then not Is_Wrapper_Package (Scope (Prev))
10367 and then Scope_Depth (Scope (Prev)) <
10368 Scope_Depth (Current_Instance)
10369 and then (Scope (Prev) /= Standard_Standard
10370 or else Sloc (Prev) > Standard_Location)
10372 if In_Open_Scopes (Scope (Prev))
10373 and then Is_Generic_Instance (Scope (Prev))
10374 and then Present (Associated_Formal_Package (P))
10379 Set_Is_Potentially_Use_Visible (Id);
10380 Set_Is_Immediately_Visible (Prev, False);
10381 Append_Elmt (Prev, Hidden_By_Use_Clause (N));
10385 -- A user-defined operator is not use-visible if the predefined
10386 -- operator for the type is immediately visible, which is the case
10387 -- if the type of the operand is in an open scope. This does not
10388 -- apply to user-defined operators that have operands of different
10389 -- types, because the predefined mixed mode operations (multiply
10390 -- and divide) apply to universal types and do not hide anything.
10392 elsif Ekind (Prev) = E_Operator
10393 and then Operator_Matches_Spec (Prev, Id)
10394 and then In_Open_Scopes
10395 (Scope (Base_Type (Etype (First_Formal (Id)))))
10396 and then (No (Next_Formal (First_Formal (Id)))
10397 or else Etype (First_Formal (Id)) =
10398 Etype (Next_Formal (First_Formal (Id)))
10399 or else Chars (Prev) = Name_Op_Expon)
10401 goto Next_Usable_Entity;
10403 -- In an instance, two homonyms may become use_visible through the
10404 -- actuals of distinct formal packages. In the generic, only the
10405 -- current one would have been visible, so make the other one
10406 -- not use_visible.
10408 -- In certain pathological cases it is possible that unrelated
10409 -- homonyms from distinct formal packages may exist in an
10410 -- uninstalled scope. We must test for that here.
10412 elsif Present (Current_Instance)
10413 and then Is_Potentially_Use_Visible (Prev)
10414 and then not Is_Overloadable (Prev)
10415 and then Scope (Id) /= Scope (Prev)
10416 and then Used_As_Generic_Actual (Scope (Prev))
10417 and then Used_As_Generic_Actual (Scope (Id))
10418 and then Is_List_Member (Scope (Prev))
10419 and then not In_Same_List (Current_Use_Clause (Scope (Prev)),
10420 Current_Use_Clause (Scope (Id)))
10422 Set_Is_Potentially_Use_Visible (Prev, False);
10423 Append_Elmt (Prev, Hidden_By_Use_Clause (N));
10426 Prev := Homonym (Prev);
10429 -- On exit, we know entity is not hidden, unless it is private
10431 if not Is_Hidden (Id)
10432 and then (not Is_Child_Unit (Id) or else Is_Visible_Lib_Unit (Id))
10434 Set_Is_Potentially_Use_Visible (Id);
10436 if Is_Private_Type (Id) and then Present (Full_View (Id)) then
10437 Set_Is_Potentially_Use_Visible (Full_View (Id));
10441 <<Next_Usable_Entity>>
10445 -- Child units are also made use-visible by a use clause, but they may
10446 -- appear after all visible declarations in the parent entity list.
10448 while Present (Id) loop
10449 if Is_Child_Unit (Id) and then Is_Visible_Lib_Unit (Id) then
10450 Set_Is_Potentially_Use_Visible (Id);
10456 if Chars (Real_P) = Name_System
10457 and then Scope (Real_P) = Standard_Standard
10458 and then Present_System_Aux (N)
10460 Use_One_Package (N);
10462 end Use_One_Package;
10468 procedure Use_One_Type
10470 Installed : Boolean := False;
10471 Force : Boolean := False)
10473 function Spec_Reloaded_For_Body return Boolean;
10474 -- Determine whether the compilation unit is a package body and the use
10475 -- type clause is in the spec of the same package. Even though the spec
10476 -- was analyzed first, its context is reloaded when analysing the body.
10478 procedure Use_Class_Wide_Operations (Typ : Entity_Id);
10479 -- AI05-150: if the use_type_clause carries the "all" qualifier,
10480 -- class-wide operations of ancestor types are use-visible if the
10481 -- ancestor type is visible.
10483 ----------------------------
10484 -- Spec_Reloaded_For_Body --
10485 ----------------------------
10487 function Spec_Reloaded_For_Body return Boolean is
10489 if Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Body then
10491 Spec : constant Node_Id :=
10492 Parent (List_Containing (Parent (Id)));
10495 -- Check whether type is declared in a package specification,
10496 -- and current unit is the corresponding package body. The
10497 -- use clauses themselves may be within a nested package.
10500 Nkind (Spec) = N_Package_Specification
10501 and then In_Same_Source_Unit
10502 (Corresponding_Body (Parent (Spec)),
10503 Cunit_Entity (Current_Sem_Unit));
10508 end Spec_Reloaded_For_Body;
10510 -------------------------------
10511 -- Use_Class_Wide_Operations --
10512 -------------------------------
10514 procedure Use_Class_Wide_Operations (Typ : Entity_Id) is
10515 function Is_Class_Wide_Operation_Of
10517 T : Entity_Id) return Boolean;
10518 -- Determine whether a subprogram has a class-wide parameter or
10519 -- result that is T'Class.
10521 ---------------------------------
10522 -- Is_Class_Wide_Operation_Of --
10523 ---------------------------------
10525 function Is_Class_Wide_Operation_Of
10527 T : Entity_Id) return Boolean
10529 Formal : Entity_Id;
10532 Formal := First_Formal (Op);
10533 while Present (Formal) loop
10534 if Etype (Formal) = Class_Wide_Type (T) then
10538 Next_Formal (Formal);
10541 if Etype (Op) = Class_Wide_Type (T) then
10546 end Is_Class_Wide_Operation_Of;
10553 -- Start of processing for Use_Class_Wide_Operations
10556 Scop := Scope (Typ);
10557 if not Is_Hidden (Scop) then
10558 Ent := First_Entity (Scop);
10559 while Present (Ent) loop
10560 if Is_Overloadable (Ent)
10561 and then Is_Class_Wide_Operation_Of (Ent, Typ)
10562 and then not Is_Potentially_Use_Visible (Ent)
10564 Set_Is_Potentially_Use_Visible (Ent);
10565 Append_Elmt (Ent, Used_Operations (Parent (Id)));
10572 if Is_Derived_Type (Typ) then
10573 Use_Class_Wide_Operations (Etype (Base_Type (Typ)));
10575 end Use_Class_Wide_Operations;
10580 Is_Known_Used : Boolean;
10581 Op_List : Elist_Id;
10584 -- Start of processing for Use_One_Type
10587 if Entity (Id) = Any_Type then
10591 -- It is the type determined by the subtype mark (8.4(8)) whose
10592 -- operations become potentially use-visible.
10594 T := Base_Type (Entity (Id));
10596 -- Either the type itself is used, the package where it is declared is
10597 -- in use or the entity is declared in the current package, thus
10602 and then ((Present (Current_Use_Clause (T))
10603 and then All_Present (Current_Use_Clause (T)))
10604 or else not All_Present (Parent (Id))))
10605 or else In_Use (Scope (T))
10606 or else Scope (T) = Current_Scope;
10608 Set_Redundant_Use (Id,
10609 Is_Known_Used or else Is_Potentially_Use_Visible (T));
10611 if Ekind (T) = E_Incomplete_Type then
10612 Error_Msg_N ("premature usage of incomplete type", Id);
10614 elsif In_Open_Scopes (Scope (T)) then
10617 -- A limited view cannot appear in a use_type_clause. However, an access
10618 -- type whose designated type is limited has the flag but is not itself
10619 -- a limited view unless we only have a limited view of its enclosing
10622 elsif From_Limited_With (T) and then From_Limited_With (Scope (T)) then
10624 ("incomplete type from limited view cannot appear in use clause",
10627 -- If the use clause is redundant, Used_Operations will usually be
10628 -- empty, but we need to set it to empty here in one case: If we are
10629 -- instantiating a generic library unit, then we install the ancestors
10630 -- of that unit in the scope stack, which involves reprocessing use
10631 -- clauses in those ancestors. Such a use clause will typically have a
10632 -- nonempty Used_Operations unless it was redundant in the generic unit,
10633 -- even if it is redundant at the place of the instantiation.
10635 elsif Redundant_Use (Id) then
10636 Set_Used_Operations (Parent (Id), New_Elmt_List);
10638 -- If the subtype mark designates a subtype in a different package,
10639 -- we have to check that the parent type is visible, otherwise the
10640 -- use_type_clause is a no-op. Not clear how to do that???
10643 Set_Current_Use_Clause (T, Parent (Id));
10646 -- If T is tagged, primitive operators on class-wide operands are
10647 -- also deemed available. Note that this is really necessary only
10648 -- in semantics-only mode, because the primitive operators are not
10649 -- fully constructed in this mode, but we do it in all modes for the
10650 -- sake of uniformity, as this should not matter in practice.
10652 if Is_Tagged_Type (T) then
10653 Set_In_Use (Class_Wide_Type (T));
10656 -- Iterate over primitive operations of the type. If an operation is
10657 -- already use_visible, it is the result of a previous use_clause,
10658 -- and already appears on the corresponding entity chain. If the
10659 -- clause is being reinstalled, operations are already use-visible.
10665 Op_List := Collect_Primitive_Operations (T);
10666 Elmt := First_Elmt (Op_List);
10667 while Present (Elmt) loop
10668 if (Nkind (Node (Elmt)) = N_Defining_Operator_Symbol
10669 or else Chars (Node (Elmt)) in Any_Operator_Name)
10670 and then not Is_Hidden (Node (Elmt))
10671 and then not Is_Potentially_Use_Visible (Node (Elmt))
10673 Set_Is_Potentially_Use_Visible (Node (Elmt));
10674 Append_Elmt (Node (Elmt), Used_Operations (Parent (Id)));
10676 elsif Ada_Version >= Ada_2012
10677 and then All_Present (Parent (Id))
10678 and then not Is_Hidden (Node (Elmt))
10679 and then not Is_Potentially_Use_Visible (Node (Elmt))
10681 Set_Is_Potentially_Use_Visible (Node (Elmt));
10682 Append_Elmt (Node (Elmt), Used_Operations (Parent (Id)));
10689 if Ada_Version >= Ada_2012
10690 and then All_Present (Parent (Id))
10691 and then Is_Tagged_Type (T)
10693 Use_Class_Wide_Operations (T);
10697 -- If warning on redundant constructs, check for unnecessary WITH
10700 and then Warn_On_Redundant_Constructs
10701 and then Is_Known_Used
10703 -- with P; with P; use P;
10704 -- package P is package X is package body X is
10705 -- type T ... use P.T;
10707 -- The compilation unit is the body of X. GNAT first compiles the
10708 -- spec of X, then proceeds to the body. At that point P is marked
10709 -- as use visible. The analysis then reinstalls the spec along with
10710 -- its context. The use clause P.T is now recognized as redundant,
10711 -- but in the wrong context. Do not emit a warning in such cases.
10712 -- Do not emit a warning either if we are in an instance, there is
10713 -- no redundancy between an outer use_clause and one that appears
10714 -- within the generic.
10716 and then not Spec_Reloaded_For_Body
10717 and then not In_Instance
10718 and then not In_Inlined_Body
10720 -- The type already has a use clause
10724 -- Case where we know the current use clause for the type
10726 if Present (Current_Use_Clause (T)) then
10727 Use_Clause_Known : declare
10728 Clause1 : constant Node_Id :=
10729 Find_First_Use (Current_Use_Clause (T));
10730 Clause2 : constant Node_Id := Parent (Id);
10737 -- Start of processing for Use_Clause_Known
10740 -- If the unit is a subprogram body that acts as spec, the
10741 -- context clause is shared with the constructed subprogram
10742 -- spec. Clearly there is no redundancy.
10744 if Clause1 = Clause2 then
10748 Unit1 := Unit (Enclosing_Comp_Unit_Node (Clause1));
10749 Unit2 := Unit (Enclosing_Comp_Unit_Node (Clause2));
10751 -- If both clauses are on same unit, or one is the body of
10752 -- the other, or one of them is in a subunit, report
10753 -- redundancy on the later one.
10756 or else Nkind (Unit1) = N_Subunit
10758 (Nkind (Unit2) in N_Package_Body | N_Subprogram_Body
10759 and then Nkind (Unit1) /= Nkind (Unit2)
10760 and then Nkind (Unit1) /= N_Subunit)
10762 Error_Msg_Sloc := Sloc (Clause1);
10763 Error_Msg_NE -- CODEFIX
10764 ("& is already use-visible through previous "
10765 & "use_type_clause #?r?", Clause2, T);
10769 -- If there is a redundant use_type_clause in a child unit
10770 -- determine which of the units is more deeply nested. If a
10771 -- unit is a package instance, retrieve the entity and its
10772 -- scope from the instance spec.
10774 Ent1 := Entity_Of_Unit (Unit1);
10775 Ent2 := Entity_Of_Unit (Unit2);
10777 -- When the scope of both units' entities are
10778 -- Standard_Standard then neither Unit1 or Unit2 are child
10779 -- units - so return in that case.
10781 if Scope
(Ent1
) = Standard_Standard
10782 and then Scope
(Ent2
) = Standard_Standard
10786 -- Otherwise, determine if one of the units is not a child
10788 elsif Scope
(Ent2
) = Standard_Standard
then
10789 Error_Msg_Sloc
:= Sloc
(Clause2
);
10792 elsif Scope
(Ent1
) = Standard_Standard
then
10793 Error_Msg_Sloc
:= Sloc
(Id
);
10796 -- If both units are child units, we determine which one is
10797 -- the descendant by the scope distance to the ultimate
10806 S1
:= Scope
(Ent1
);
10807 S2
:= Scope
(Ent2
);
10809 and then Present
(S2
)
10810 and then S1
/= Standard_Standard
10811 and then S2
/= Standard_Standard
10817 if S1
= Standard_Standard
then
10818 Error_Msg_Sloc
:= Sloc
(Id
);
10821 Error_Msg_Sloc
:= Sloc
(Clause2
);
10827 if Parent
(Id
) /= Err_No
then
10828 if Most_Descendant_Use_Clause
10829 (Err_No
, Parent
(Id
)) = Parent
(Id
)
10831 Error_Msg_Sloc
:= Sloc
(Err_No
);
10832 Err_No
:= Parent
(Id
);
10835 Error_Msg_NE
-- CODEFIX
10836 ("& is already use-visible through previous "
10837 & "use_type_clause #?r?", Err_No
, Id
);
10839 end Use_Clause_Known
;
10841 -- Here Current_Use_Clause is not set for T, so we do not have the
10842 -- location information available.
10845 Error_Msg_NE
-- CODEFIX
10846 ("& is already use-visible through previous "
10847 & "use_type_clause?r?", Id
, T
);
10850 -- The package where T is declared is already used
10852 elsif In_Use
(Scope
(T
)) then
10853 -- Due to expansion of contracts we could be attempting to issue
10854 -- a spurious warning - so verify there is a previous use clause.
10856 if Current_Use_Clause
(Scope
(T
)) /=
10857 Find_First_Use
(Current_Use_Clause
(Scope
(T
)))
10860 Sloc
(Find_First_Use
(Current_Use_Clause
(Scope
(T
))));
10861 Error_Msg_NE
-- CODEFIX
10862 ("& is already use-visible through package use clause #?r?",
10866 -- The current scope is the package where T is declared
10869 Error_Msg_Node_2
:= Scope
(T
);
10870 Error_Msg_NE
-- CODEFIX
10871 ("& is already use-visible inside package &?r?", Id
, T
);
10880 procedure Write_Info
is
10881 Id
: Entity_Id
:= First_Entity
(Current_Scope
);
10884 -- No point in dumping standard entities
10886 if Current_Scope
= Standard_Standard
then
10890 Write_Str
("========================================================");
10892 Write_Str
(" Defined Entities in ");
10893 Write_Name
(Chars
(Current_Scope
));
10895 Write_Str
("========================================================");
10899 Write_Str
("-- none --");
10903 while Present
(Id
) loop
10904 Write_Entity_Info
(Id
, " ");
10909 if Scope
(Current_Scope
) = Standard_Standard
then
10911 -- Print information on the current unit itself
10913 Write_Entity_Info
(Current_Scope
, " ");
10926 for J
in reverse 1 .. Scope_Stack
.Last
loop
10927 S
:= Scope_Stack
.Table
(J
).Entity
;
10928 Write_Int
(Int
(S
));
10929 Write_Str
(" === ");
10930 Write_Name
(Chars
(S
));
10939 procedure we
(S
: Entity_Id
) is
10942 E
:= First_Entity
(S
);
10943 while Present
(E
) loop
10944 Write_Int
(Int
(E
));
10945 Write_Str
(" === ");
10946 Write_Name
(Chars
(E
));